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