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))