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