{-# LANGUAGE CPP #-}---- (c) The University of Glasgow 2002-2006---- The IO Monad with an environment---- The environment is passed around as a Reader monad but-- as its in the IO monad, mutable references can be used-- for updating state.--moduleIOEnv(IOEnv ,-- Instance of Monad-- Monad utilitiesmoduleMonadUtils ,-- ErrorsfailM ,failWithM ,IOEnvFailure (..),-- Getting at the environmentgetEnv ,setEnv ,updEnv ,runIOEnv ,unsafeInterleaveM ,uninterruptibleMaskM_ ,tryM ,tryAllM ,tryMostM ,fixM ,-- I/O operationsIORef,newMutVar ,readMutVar ,writeMutVar ,updMutVar ,atomicUpdMutVar ,atomicUpdMutVar' )whereimportGhcPrelude importDynFlags importException importModule importPanic importData.IORef(IORef,newIORef,readIORef,writeIORef,modifyIORef,atomicModifyIORef,atomicModifyIORef')importSystem.IO.Unsafe(unsafeInterleaveIO)importSystem.IO(fixIO)importControl.MonadimportqualifiedControl.Monad.FailasMonadFailimportMonadUtils importControl.Applicative(Alternative(..))------------------------------------------------------------------------ Defining the monad type----------------------------------------------------------------------newtypeIOEnv env a =IOEnv (env ->IOa )unIOEnv::IOEnv env a ->(env ->IOa )unIOEnv (IOEnv m )=m instanceMonad(IOEnv m )where(>>= )=thenM (>> )=(*>)#if !MIN_VERSION_base(4,13,0)
fail =MonadFail.fail#endif
instanceMonadFail.MonadFail(IOEnv m )wherefail _=failM -- Ignore the stringinstanceApplicative(IOEnv m )wherepure =returnM IOEnv f <*> IOEnv x =IOEnv (\env ->f env <*>x env )(*> )=thenM_ instanceFunctor(IOEnv m )wherefmap f (IOEnv m )=IOEnv (\env ->fmapf (m env ))returnM::a ->IOEnv env a returnM a =IOEnv (\_->returna )thenM::IOEnv env a ->(a ->IOEnv env b )->IOEnv env b thenM (IOEnv m )f =IOEnv (\env ->do{r <-m env ;unIOEnv (f r )env })thenM_::IOEnv env a ->IOEnv env b ->IOEnv env b thenM_ (IOEnv m )f =IOEnv (\env ->do{_<-m env ;unIOEnv f env })failM::IOEnv env a failM =IOEnv (\_->throwIOIOEnvFailure )failWithM::String->IOEnv env a failWithM s =IOEnv (\_->ioError(userErrors ))dataIOEnvFailure =IOEnvFailure instanceShowIOEnvFailure whereshow IOEnvFailure ="IOEnv failure"instanceExceptionIOEnvFailure instanceExceptionMonad (IOEnv a )wheregcatch act handle =IOEnv $\s ->unIOEnv act s `gcatch `\e ->unIOEnv (handle e )s gmask f =IOEnv $\s ->gmask $\io_restore ->letg_restore (IOEnv m )=IOEnv $\s ->io_restore (m s )inunIOEnv (f g_restore )s instanceContainsDynFlags env =>HasDynFlags (IOEnv env )wheregetDynFlags =doenv <-getEnv return$!extractDynFlags env instanceContainsModule env =>HasModule (IOEnv env )wheregetModule =doenv <-getEnv return$extractModule env ------------------------------------------------------------------------ Fundamental combinators specific to the monad-------------------------------------------------------------------------------------------------runIOEnv::env ->IOEnv env a ->IOa runIOEnv env (IOEnv m )=m env ---------------------------{-# NOINLINEfixM#-}-- Aargh! Not inlining fixM alleviates a space leak problem.-- Normally fixM is used with a lazy tuple match: if the optimiser is-- shown the definition of fixM, it occasionally transforms the code-- in such a way that the code generator doesn't spot the selector-- thunks. Sigh.fixM::(a ->IOEnv env a )->IOEnv env a fixM f =IOEnv (\env ->fixIO(\r ->unIOEnv (f r )env ))---------------------------tryM::IOEnv env r ->IOEnv env (EitherIOEnvFailure r )-- Reflect UserError exceptions (only) into IOEnv monad-- Other exceptions are not caught; they are simply propagated as exns---- The idea is that errors in the program being compiled will give rise-- to UserErrors. But, say, pattern-match failures in GHC itself should-- not be caught here, else they'll be reported as errors in the program-- begin compiled!tryM (IOEnv thing )=IOEnv (\env ->tryIOEnvFailure (thing env ))tryIOEnvFailure::IOa ->IO(EitherIOEnvFailure a )tryIOEnvFailure =try-- XXX We shouldn't be catching everything, e.g. timeoutstryAllM::IOEnv env r ->IOEnv env (EitherSomeExceptionr )-- Catch *all* exceptions-- This is used when running a Template-Haskell splice, when-- even a pattern-match failure is a programmer errortryAllM (IOEnv thing )=IOEnv (\env ->try(thing env ))tryMostM::IOEnv env r ->IOEnv env (EitherSomeExceptionr )tryMostM (IOEnv thing )=IOEnv (\env ->tryMost (thing env ))---------------------------unsafeInterleaveM::IOEnv env a ->IOEnv env a unsafeInterleaveM (IOEnv m )=IOEnv (\env ->unsafeInterleaveIO(m env ))uninterruptibleMaskM_::IOEnv env a ->IOEnv env a uninterruptibleMaskM_ (IOEnv m )=IOEnv (\env ->uninterruptibleMask_(m env ))------------------------------------------------------------------------ Alternative/MonadPlus----------------------------------------------------------------------instanceAlternative(IOEnv env )whereempty =IOEnv (constempty)m <|> n =IOEnv (\env ->unIOEnv m env <|>unIOEnv n env )instanceMonadPlus(IOEnv env )------------------------------------------------------------------------ Accessing input/output----------------------------------------------------------------------instanceMonadIO(IOEnv env )whereliftIO io =IOEnv (\_->io )newMutVar::a ->IOEnv env (IORefa )newMutVar val =liftIO(newIORefval )writeMutVar::IORefa ->a ->IOEnv env ()writeMutVar var val =liftIO(writeIORefvar val )readMutVar::IORefa ->IOEnv env a readMutVar var =liftIO(readIORefvar )updMutVar::IORefa ->(a ->a )->IOEnv env ()updMutVar var upd =liftIO(modifyIORefvar upd )-- | Atomically update the reference. Does not force the evaluation of the-- new variable contents. For strict update, use 'atomicUpdMutVar''.atomicUpdMutVar::IORefa ->(a ->(a ,b ))->IOEnv env b atomicUpdMutVar var upd =liftIO(atomicModifyIORefvar upd )-- | Strict variant of 'atomicUpdMutVar'.atomicUpdMutVar'::IORefa ->(a ->(a ,b ))->IOEnv env b atomicUpdMutVar' var upd =liftIO(atomicModifyIORef'var upd )------------------------------------------------------------------------ Accessing the environment----------------------------------------------------------------------getEnv::IOEnv env env {-# INLINEgetEnv#-}getEnv =IOEnv (\env ->returnenv )-- | Perform a computation with a different environmentsetEnv::env' ->IOEnv env' a ->IOEnv env a {-# INLINEsetEnv#-}setEnv new_env (IOEnv m )=IOEnv (\_->m new_env )-- | Perform a computation with an altered environmentupdEnv::(env ->env' )->IOEnv env' a ->IOEnv env a {-# INLINEupdEnv#-}updEnv upd (IOEnv m )=IOEnv (\env ->m (upd env ))