1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DerivingVia #-}
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--
14module 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,
32        atomicUpdMutVar, atomicUpdMutVar'
33  ) where
34
35import GHC.Prelude
36
37import GHC.Driver.Session
38import GHC.Utils.Exception
39import GHC.Unit.Module
40import GHC.Utils.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 Control.Monad.Trans.Reader
48import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
49import GHC.Utils.Monad
50import Control.Applicative (Alternative(..))
51
52----------------------------------------------------------------------
53-- Defining the monad type
54----------------------------------------------------------------------
55
56
57newtype IOEnv env a = IOEnv (env -> IO a)
58  deriving (Functor)
59  deriving (MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT env IO)
60
61unIOEnv :: IOEnv env a -> (env -> IO a)
62unIOEnv (IOEnv m) = m
63
64instance Monad (IOEnv m) where
65    (>>=)  = thenM
66    (>>)   = (*>)
67
68instance MonadFail (IOEnv m) where
69    fail _ = failM -- Ignore the string
70
71instance Applicative (IOEnv m) where
72    pure = returnM
73    IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
74    (*>) = thenM_
75
76returnM :: a -> IOEnv env a
77returnM a = IOEnv (\ _ -> return a)
78
79thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b
80thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ;
81                                         unIOEnv (f r) env })
82
83thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
84thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env })
85
86failM :: IOEnv env a
87failM = IOEnv (\ _ -> throwIO IOEnvFailure)
88
89failWithM :: String -> IOEnv env a
90failWithM s = IOEnv (\ _ -> ioError (userError s))
91
92data IOEnvFailure = IOEnvFailure
93
94instance Show IOEnvFailure where
95    show IOEnvFailure = "IOEnv failure"
96
97instance Exception IOEnvFailure
98
99instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
100    getDynFlags = do env <- getEnv
101                     return $! extractDynFlags env
102
103instance ContainsModule env => HasModule (IOEnv env) where
104    getModule = do env <- getEnv
105                   return $ extractModule env
106
107----------------------------------------------------------------------
108-- Fundamental combinators specific to the monad
109----------------------------------------------------------------------
110
111
112---------------------------
113runIOEnv :: env -> IOEnv env a -> IO a
114runIOEnv env (IOEnv m) = m env
115
116
117---------------------------
118{-# NOINLINE fixM #-}
119  -- Aargh!  Not inlining fixM alleviates a space leak problem.
120  -- Normally fixM is used with a lazy tuple match: if the optimiser is
121  -- shown the definition of fixM, it occasionally transforms the code
122  -- in such a way that the code generator doesn't spot the selector
123  -- thunks.  Sigh.
124
125fixM :: (a -> IOEnv env a) -> IOEnv env a
126fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))
127
128
129---------------------------
130tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r)
131-- Reflect UserError exceptions (only) into IOEnv monad
132-- Other exceptions are not caught; they are simply propagated as exns
133--
134-- The idea is that errors in the program being compiled will give rise
135-- to UserErrors.  But, say, pattern-match failures in GHC itself should
136-- not be caught here, else they'll be reported as errors in the program
137-- begin compiled!
138tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env))
139
140tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a)
141tryIOEnvFailure = try
142
143-- XXX We shouldn't be catching everything, e.g. timeouts
144tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)
145-- Catch *all* exceptions
146-- This is used when running a Template-Haskell splice, when
147-- even a pattern-match failure is a programmer error
148tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env))
149
150tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r)
151tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))
152
153---------------------------
154unsafeInterleaveM :: IOEnv env a -> IOEnv env a
155unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))
156
157uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a
158uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env))
159
160----------------------------------------------------------------------
161-- Alternative/MonadPlus
162----------------------------------------------------------------------
163
164instance Alternative (IOEnv env) where
165    empty   = IOEnv (const empty)
166    m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env)
167
168instance MonadPlus (IOEnv env)
169
170----------------------------------------------------------------------
171-- Accessing input/output
172----------------------------------------------------------------------
173
174newMutVar :: a -> IOEnv env (IORef a)
175newMutVar val = liftIO (newIORef val)
176
177writeMutVar :: IORef a -> a -> IOEnv env ()
178writeMutVar var val = liftIO (writeIORef var val)
179
180readMutVar :: IORef a -> IOEnv env a
181readMutVar var = liftIO (readIORef var)
182
183updMutVar :: IORef a -> (a -> a) -> IOEnv env ()
184updMutVar var upd = liftIO (modifyIORef var upd)
185
186-- | Atomically update the reference.  Does not force the evaluation of the
187-- new variable contents.  For strict update, use 'atomicUpdMutVar''.
188atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b
189atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd)
190
191-- | Strict variant of 'atomicUpdMutVar'.
192atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b
193atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd)
194
195----------------------------------------------------------------------
196-- Accessing the environment
197----------------------------------------------------------------------
198
199getEnv :: IOEnv env env
200{-# INLINE getEnv #-}
201getEnv = IOEnv (\ env -> return env)
202
203-- | Perform a computation with a different environment
204setEnv :: env' -> IOEnv env' a -> IOEnv env a
205{-# INLINE setEnv #-}
206setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env)
207
208-- | Perform a computation with an altered environment
209updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a
210{-# INLINE updEnv #-}
211updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
212