git.iko.soy/typeable/control-has
on master help sign in
typeable/control-has/src/Control/EnvT.hs
70 lines 1.9 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TemplateHaskell #-}
4module Control.EnvT
5 ( EnvT(..)
6 , runEnvT
7 , execEnvT
8 , module X
9 ) where
11import Control.Applicative
12import Control.Has
13import Control.Lens
14import Control.Monad.Base
15import Control.Monad.Catch
16import Control.Monad.Except
17import Control.Monad.Reader as X
18import Control.Monad.Trans.Control
19import Control.Monad.Trans.Resource
20import Control.Monad.Zip
22#if MIN_VERSION_mtl(2,3,0)
23import Control.Monad
24import Control.Monad.Fix
25#endif
27#if !MIN_VERSION_base(4,13,0)
28import Control.Monad.Fail
29#endif
31-- | The only reason this exists is that there are a lot of instances for
32-- 'EnvT, which simply pass the implementation to the inner 'm'
33-- such as 'MonadLogger'.
34newtype EnvT r m a = EnvT { unEnvT :: ReaderT r m a}
35 deriving newtype (Functor, Applicative, Alternative, Monad
36 , MonadFix, MonadFail, Contravariant, MonadZip, MonadIO, MonadPlus)
38instance MonadTrans (EnvT r) where
39 lift = EnvT . lift
41deriving newtype instance Monad m => MonadReader r (EnvT r m)
42deriving newtype instance MonadCatch m => MonadCatch (EnvT r m)
43deriving newtype instance MonadThrow m => MonadThrow (EnvT r m)
44deriving newtype instance MonadMask m => MonadMask (EnvT r m)
45deriving newtype instance MonadError e m => MonadError e (EnvT r m)
47deriving newtype instance
48 ( MonadBase b m
49 , Applicative b
50 , Applicative m
51 , Monad b
52 , Monad m )
53 => MonadBase b (EnvT r m)
55deriving newtype instance
56 (MonadBaseControl b m, Monad m)
57 => MonadBaseControl b (EnvT r m)
59-- | Run 'EnvT' transformer.
60runEnvT :: forall r m a. EnvT r m a -> r -> m a
61runEnvT m r = flip runReaderT r . unEnvT $ m
62{-# INLINE runEnvT #-}
64-- | Same as 'runEnvT' but with arguments flipped.
65execEnvT :: forall r m a. r -> EnvT r m a -> m a
66execEnvT = flip runEnvT
67{-# INLINE execEnvT #-}
69instance MonadResource m => MonadResource (EnvT r m) where
70 liftResourceT = lift . liftResourceT