1{-# LANGUAGE CPP #-} 2 3-- | The multi-valued version of mtl's Reader / ReaderT 4module Control.Monad.Trans.MultiReader.Strict 5 ( 6 -- * MultiReaderT 7 MultiReaderT(..) 8 , MultiReaderTNull 9 , MultiReader 10 -- * MonadMultiReader class 11 , MonadMultiReader(..) 12 , MonadMultiGet(..) 13 -- * run-functions 14 , runMultiReaderT 15 , runMultiReaderT_ 16 , runMultiReaderTNil 17 , runMultiReaderTNil_ 18 -- * with-functions (single reader) 19 , withMultiReader 20 , withMultiReader_ 21 -- * with-functions (multiple readers) 22 , withMultiReaders 23 , withMultiReaders_ 24 -- * without-function (single reader) 25 , withoutMultiReader 26 -- * inflate-function (run ReaderT in MultiReaderT) 27 , inflateReader 28 -- * other functions 29 , mapMultiReaderT 30 , mGetRaw 31 , mPutRaw 32) where 33 34 35 36import Data.HList.HList 37import Data.HList.ContainsType 38 39import Control.Monad.Trans.MultiReader.Class 40import Control.Monad.Trans.MultiState.Class 41 42import Control.Monad.State.Strict ( StateT(..) 43 , MonadState(..) 44 , evalStateT 45 , mapStateT ) 46import Control.Monad.Reader ( ReaderT(..) ) 47import Control.Monad.Trans.Class ( MonadTrans 48 , lift ) 49import Control.Monad.Writer.Class ( MonadWriter 50 , listen 51 , tell 52 , writer 53 , pass ) 54 55import Data.Functor.Identity ( Identity ) 56 57import Control.Applicative ( Applicative(..) 58 , Alternative(..) 59 ) 60import Control.Monad ( MonadPlus(..) 61 , liftM 62 , ap 63 , void ) 64import Control.Monad.Base ( MonadBase(..) 65 , liftBaseDefault 66 ) 67import Control.Monad.Trans.Control ( MonadTransControl(..) 68 , MonadBaseControl(..) 69 , ComposeSt 70 , defaultLiftBaseWith 71 , defaultRestoreM 72 ) 73import Control.Monad.Fix ( MonadFix(..) ) 74import Control.Monad.IO.Class ( MonadIO(..) ) 75 76 77 78-- | A Reader transformer monad patameterized by: 79-- 80-- * x - The list of types constituting the environment / input (to be read), 81-- * m - The inner monad. 82-- 83-- 'MultiReaderT' corresponds to mtl's 'ReaderT', but can contain 84-- a heterogenous list of types. 85-- 86-- This heterogenous list is represented using Types.Data.List, i.e: 87-- 88-- * @'[]@ - The empty list, 89-- * @a ': b@ - A list where @/a/@ is an arbitrary type 90-- and @/b/@ is the rest list. 91-- 92-- For example, 93-- 94-- > MultiReaderT '[Int, Bool] :: (* -> *) -> (* -> *) 95-- 96-- is a Reader transformer containing the types [Int, Bool]. 97newtype MultiReaderT x m a = MultiReaderT { 98 runMultiReaderTRaw :: StateT (HList x) m a 99} 100 101-- | A MultiReader transformer carrying an empty state. 102type MultiReaderTNull = MultiReaderT '[] 103 104-- | A reader monad parameterized by the list of types x of the environment 105-- / input to carry. 106-- 107-- Similar to @Reader r = ReaderT r Identity@ 108type MultiReader x = MultiReaderT x Identity 109 110instance (Functor f) => Functor (MultiReaderT x f) where 111 fmap f = MultiReaderT . fmap f . runMultiReaderTRaw 112 113instance (Applicative m, Monad m) => Applicative (MultiReaderT x m) where 114 pure = MultiReaderT . pure 115 (<*>) = ap 116 117instance Monad m => Monad (MultiReaderT x m) where 118 return = MultiReaderT . return 119 k >>= f = MultiReaderT $ runMultiReaderTRaw k >>= (runMultiReaderTRaw . f) 120 121instance MonadTrans (MultiReaderT x) where 122 lift = MultiReaderT . lift 123 124#if MIN_VERSION_base(4,8,0) 125instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 126#else 127instance (Monad m, ContainsType a c) 128#endif 129 => MonadMultiReader a (MultiReaderT c m) where 130 mAsk = MultiReaderT $ liftM getHListElem get 131 132#if MIN_VERSION_base(4,8,0) 133instance {-# OVERLAPPING #-} (Monad m, ContainsType a c) 134#else 135instance (Monad m, ContainsType a c) 136#endif 137 => MonadMultiGet a (MultiReaderT c m) where 138 mGet = MultiReaderT $ liftM getHListElem get 139 140instance MonadFix m => MonadFix (MultiReaderT r m) where 141 mfix f = MultiReaderT $ mfix (runMultiReaderTRaw . f) 142 143-- methods 144 145-- | A raw extractor of the contained HList (i.e. the complete Reader). 146mGetRaw :: Monad m => MultiReaderT a m (HList a) 147mGetRaw = MultiReaderT get 148 149mPutRaw :: Monad m => HList s -> MultiReaderT s m () 150mPutRaw = MultiReaderT . put 151 152-- | Map both the return value and the environment of a computation 153-- using the given function. 154-- 155-- Note that there is a difference to mtl's ReaderT, 156-- where it is /not/ possible to modify the environment. 157mapMultiReaderT :: (m (a, HList w) -> m' (a', HList w)) 158 -> MultiReaderT w m a 159 -> MultiReaderT w m' a' 160mapMultiReaderT f = MultiReaderT . mapStateT f . runMultiReaderTRaw 161 162runMultiReaderT :: Monad m => HList r -> MultiReaderT r m a -> m a 163runMultiReaderT_ :: Functor m => HList r -> MultiReaderT r m a -> m () 164-- ghc too dumb for this shortcut, unfortunately 165-- runMultiReaderT s k = runMultiReaderTNil $ withMultiReaders s k 166-- runMultiReaderT_ s k = runMultiReaderTNil $ withMultiReaders_ s k 167runMultiReaderT s k = evalStateT (runMultiReaderTRaw k) s 168runMultiReaderT_ s k = void $ runStateT (runMultiReaderTRaw k) s 169 170runMultiReaderTNil :: Monad m => MultiReaderT '[] m a -> m a 171runMultiReaderTNil_ :: Functor m => MultiReaderT '[] m a -> m () 172runMultiReaderTNil k = evalStateT (runMultiReaderTRaw k) HNil 173runMultiReaderTNil_ k = void $ runStateT (runMultiReaderTRaw k) HNil 174 175withMultiReader :: Monad m => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m a 176withMultiReader_ :: (Functor m, Monad m) => r -> MultiReaderT (r ': rs) m a -> MultiReaderT rs m () 177withMultiReader x k = MultiReaderT $ 178 get >>= lift . evalStateT (runMultiReaderTRaw k) . (x :+:) 179withMultiReader_ x k = void $ withMultiReader x k 180 181withMultiReaders :: Monad m => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m a 182withMultiReaders_ :: (Functor m, Monad m) => HList r1 -> MultiReaderT (Append r1 r2) m a -> MultiReaderT r2 m () 183withMultiReaders HNil = id 184withMultiReaders (x :+: xs) = withMultiReaders xs . withMultiReader x 185withMultiReaders_ HNil = liftM (const ()) 186withMultiReaders_ (x :+: xs) = withMultiReaders_ xs . withMultiReader_ x 187 188withoutMultiReader :: Monad m => MultiReaderT rs m a -> MultiReaderT (r ': rs) m a 189withoutMultiReader k = MultiReaderT $ get >>= \case 190 (_ :+: rr) -> lift $ runMultiReaderT rr k 191 192inflateReader :: (Monad m, ContainsType r rs) 193 => ReaderT r m a 194 -> MultiReaderT rs m a 195inflateReader k = mAsk >>= lift . runReaderT k 196 197-- foreign lifting instances 198 199instance (MonadState s m) => MonadState s (MultiReaderT c m) where 200 put = lift . put 201 get = lift $ get 202 state = lift . state 203 204instance (MonadWriter w m) => MonadWriter w (MultiReaderT c m) where 205 writer = lift . writer 206 tell = lift . tell 207 listen = MultiReaderT . 208 mapStateT (liftM (\((a,w), w') -> ((a, w'), w)) . listen) . 209 runMultiReaderTRaw 210 pass = MultiReaderT . 211 mapStateT (pass . liftM (\((a, f), w) -> ((a, w), f))) . 212 runMultiReaderTRaw 213 214instance MonadIO m => MonadIO (MultiReaderT c m) where 215 liftIO = lift . liftIO 216 217instance (Functor m, Applicative m, MonadPlus m) => Alternative (MultiReaderT c m) where 218 empty = lift mzero 219 MultiReaderT m <|> MultiReaderT n = MultiReaderT $ m <|> n 220 221instance MonadPlus m => MonadPlus (MultiReaderT c m) where 222 mzero = MultiReaderT $ mzero 223 MultiReaderT m `mplus` MultiReaderT n = MultiReaderT $ m `mplus` n 224 225instance MonadBase b m => MonadBase b (MultiReaderT r m) where 226 liftBase = liftBaseDefault 227 228instance MonadTransControl (MultiReaderT r) where 229 type StT (MultiReaderT r) a = (a, HList r) 230 liftWith f = MultiReaderT $ liftWith $ \s -> f $ \r -> s $ runMultiReaderTRaw r 231 restoreT = MultiReaderT . restoreT 232 233instance MonadBaseControl b m => MonadBaseControl b (MultiReaderT r m) where 234 type StM (MultiReaderT r m) a = ComposeSt (MultiReaderT r) m a 235 liftBaseWith = defaultLiftBaseWith 236 restoreM = defaultRestoreM 237