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