never executed always true always false
1
2 {-# LANGUAGE DerivingVia #-}
3 {-# LANGUAGE PatternSynonyms #-}
4 --
5 -- (c) The University of Glasgow 2002-2006
6 --
7
8 -- | The IO Monad with an environment
9 --
10 -- The environment is passed around as a Reader monad but
11 -- as its in the IO monad, mutable references can be used
12 -- for updating state.
13 --
14 module GHC.Data.IOEnv (
15 IOEnv, -- Instance of Monad
16
17 -- Monad utilities
18 module GHC.Utils.Monad,
19
20 -- Errors
21 failM, failWithM,
22 IOEnvFailure(..),
23
24 -- Getting at the environment
25 getEnv, setEnv, updEnv,
26
27 runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,
28 tryM, tryAllM, tryMostM, fixM,
29
30 -- I/O operations
31 IORef, newMutVar, readMutVar, writeMutVar, updMutVar, updMutVarM,
32 atomicUpdMutVar, atomicUpdMutVar'
33 ) where
34
35 import GHC.Prelude
36
37 import GHC.Driver.Session
38 import {-# SOURCE #-} GHC.Driver.Hooks
39 import GHC.IO (catchException)
40 import GHC.Utils.Exception
41 import GHC.Unit.Module
42 import GHC.Utils.Panic
43
44 import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
45 atomicModifyIORef, atomicModifyIORef' )
46 import System.IO.Unsafe ( unsafeInterleaveIO )
47 import System.IO ( fixIO )
48 import Control.Monad
49 import Control.Monad.Trans.Reader
50 import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
51 import GHC.Utils.Monad
52 import GHC.Utils.Logger
53 import Control.Applicative (Alternative(..))
54 import GHC.Exts( oneShot )
55 import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
56 import Control.Concurrent (forkIO, killThread)
57
58 ----------------------------------------------------------------------
59 -- Defining the monad type
60 ----------------------------------------------------------------------
61
62
63 newtype IOEnv env a = IOEnv' (env -> IO a)
64 deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT env IO)
65
66 -- See Note [The one-shot state monad trick] in GHC.Utils.Monad
67 instance Functor (IOEnv env) where
68 fmap f (IOEnv g) = IOEnv $ \env -> fmap f (g env)
69 a <$ IOEnv g = IOEnv $ \env -> g env >> pure a
70
71 instance MonadIO (IOEnv env) where
72 liftIO f = IOEnv (\_ -> f)
73
74 pattern IOEnv :: forall env a. (env -> IO a) -> IOEnv env a
75 pattern IOEnv m <- IOEnv' m
76 where
77 IOEnv m = IOEnv' (oneShot m)
78
79 {-# COMPLETE IOEnv #-}
80
81 unIOEnv :: IOEnv env a -> (env -> IO a)
82 unIOEnv (IOEnv m) = m
83
84 instance Monad (IOEnv m) where
85 (>>=) = thenM
86 (>>) = (*>)
87
88 instance MonadFail (IOEnv m) where
89 fail _ = failM -- Ignore the string
90
91 instance Applicative (IOEnv m) where
92 pure = returnM
93 IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
94 (*>) = thenM_
95
96 returnM :: a -> IOEnv env a
97 returnM a = IOEnv (\ _ -> return a)
98
99 thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b
100 thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ;
101 unIOEnv (f r) env })
102
103 thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
104 thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env })
105
106 failM :: IOEnv env a
107 failM = IOEnv (\ _ -> throwIO IOEnvFailure)
108
109 failWithM :: String -> IOEnv env a
110 failWithM s = IOEnv (\ _ -> ioError (userError s))
111
112 data IOEnvFailure = IOEnvFailure
113
114 instance Show IOEnvFailure where
115 show IOEnvFailure = "IOEnv failure"
116
117 instance Exception IOEnvFailure
118
119 instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
120 getDynFlags = do env <- getEnv
121 return $! extractDynFlags env
122
123 instance ContainsHooks env => HasHooks (IOEnv env) where
124 getHooks = do env <- getEnv
125 return $! extractHooks env
126
127 instance ContainsLogger env => HasLogger (IOEnv env) where
128 getLogger = do env <- getEnv
129 return $! extractLogger env
130
131
132 instance ContainsModule env => HasModule (IOEnv env) where
133 getModule = do env <- getEnv
134 return $ extractModule env
135
136 ----------------------------------------------------------------------
137 -- Fundamental combinators specific to the monad
138 ----------------------------------------------------------------------
139
140
141 ---------------------------
142 runIOEnv :: env -> IOEnv env a -> IO a
143 runIOEnv env (IOEnv m) = m env
144
145
146 ---------------------------
147 {-# NOINLINE fixM #-}
148 -- Aargh! Not inlining fixM alleviates a space leak problem.
149 -- Normally fixM is used with a lazy tuple match: if the optimiser is
150 -- shown the definition of fixM, it occasionally transforms the code
151 -- in such a way that the code generator doesn't spot the selector
152 -- thunks. Sigh.
153
154 fixM :: (a -> IOEnv env a) -> IOEnv env a
155 fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))
156
157
158 ---------------------------
159 tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r)
160 -- Reflect UserError exceptions (only) into IOEnv monad
161 -- Other exceptions are not caught; they are simply propagated as exns
162 --
163 -- The idea is that errors in the program being compiled will give rise
164 -- to UserErrors. But, say, pattern-match failures in GHC itself should
165 -- not be caught here, else they'll be reported as errors in the program
166 -- begin compiled!
167 tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env))
168
169 tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a)
170 tryIOEnvFailure = try
171
172 tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)
173 -- Catch *all* synchronous exceptions
174 -- This is used when running a Template-Haskell splice, when
175 -- even a pattern-match failure is a programmer error
176 tryAllM (IOEnv thing) = IOEnv (\ env -> safeTry (thing env))
177
178 -- | Like 'try', but doesn't catch asynchronous exceptions
179 safeTry :: IO a -> IO (Either SomeException a)
180 safeTry act = do
181 var <- newEmptyMVar
182 -- uninterruptible because we want to mask around 'killThread', which is interruptible.
183 uninterruptibleMask $ \restore -> do
184 -- Fork, so that 'act' is safe from all asynchronous exceptions other than the ones we send it
185 t <- forkIO $ try (restore act) >>= putMVar var
186 restore (readMVar var)
187 `catchException` \(e :: SomeException) -> do
188 -- Control reaches this point only if the parent thread was sent an async exception
189 -- In that case, kill the 'act' thread and re-raise the exception
190 killThread t
191 throwIO e
192
193 tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r)
194 tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))
195
196 ---------------------------
197 unsafeInterleaveM :: IOEnv env a -> IOEnv env a
198 unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))
199
200 uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a
201 uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env))
202
203 ----------------------------------------------------------------------
204 -- Alternative/MonadPlus
205 ----------------------------------------------------------------------
206
207 instance Alternative (IOEnv env) where
208 empty = IOEnv (const empty)
209 m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env)
210
211 instance MonadPlus (IOEnv env)
212
213 ----------------------------------------------------------------------
214 -- Accessing input/output
215 ----------------------------------------------------------------------
216
217 newMutVar :: a -> IOEnv env (IORef a)
218 newMutVar val = liftIO (newIORef val)
219
220 writeMutVar :: IORef a -> a -> IOEnv env ()
221 writeMutVar var val = liftIO (writeIORef var val)
222
223 readMutVar :: IORef a -> IOEnv env a
224 readMutVar var = liftIO (readIORef var)
225
226 updMutVar :: IORef a -> (a -> a) -> IOEnv env ()
227 updMutVar var upd = liftIO (modifyIORef var upd)
228
229 updMutVarM :: IORef a -> (a -> IOEnv env a) -> IOEnv env ()
230 updMutVarM ref upd
231 = do { contents <- liftIO $ readIORef ref
232 ; new_contents <- upd contents
233 ; liftIO $ writeIORef ref new_contents }
234
235 -- | Atomically update the reference. Does not force the evaluation of the
236 -- new variable contents. For strict update, use 'atomicUpdMutVar''.
237 atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b
238 atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd)
239
240 -- | Strict variant of 'atomicUpdMutVar'.
241 atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b
242 atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd)
243
244 ----------------------------------------------------------------------
245 -- Accessing the environment
246 ----------------------------------------------------------------------
247
248 getEnv :: IOEnv env env
249 {-# INLINE getEnv #-}
250 getEnv = IOEnv (\ env -> return env)
251
252 -- | Perform a computation with a different environment
253 setEnv :: env' -> IOEnv env' a -> IOEnv env a
254 {-# INLINE setEnv #-}
255 setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env)
256
257 -- | Perform a computation with an altered environment
258 updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a
259 {-# INLINE updEnv #-}
260 updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))