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