module Ether.Reader
(
MonadReader
, ask
, local
, reader
, asks
, Reader
, runReader
, ReaderT
, readerT
, runReaderT
, Readers
, runReaders
, ReadersT
, runReadersT
, MonadReader'
, local'
, ask'
, reader'
, asks'
, Reader'
, runReader'
, ReaderT'
, readerT'
, runReaderT'
, TAGGED
, READER
, READERS
) where
import qualified Control.Monad.Reader as T
import qualified Control.Monad.Trans.Lift.Local as Lift
import Control.Monad.Trans.Lift.Local (Local)
import Data.Coerce
import Data.Functor.Identity
import Data.Kind
import Ether.TaggedTrans
import Ether.Internal
class Monad m => MonadReader tag r m | m tag -> r where
ask :: m r
ask = reader @tag id
local
:: (r -> r)
-> m a
-> m a
reader
:: (r -> a)
-> m a
reader f = fmap f (ask @tag)
instance
( Lift.LiftLocal t
, Monad (t m)
, MonadReader tag r m
) => MonadReader tag r (t m)
where
ask = Lift.lift (ask @tag)
local = Lift.liftLocal (ask @tag) (local @tag)
reader = Lift.lift . reader @tag
instance
( Monad (trans m)
, MonadReader tag r (TaggedTrans effs trans m)
) => MonadReader tag r (TaggedTrans (eff ': effs) trans (m :: Type -> Type))
where
ask =
(coerce ::
TaggedTrans effs trans m r ->
TaggedTrans (eff ': effs) trans m r)
(ask @tag)
local =
(coerce :: forall a .
Lift.Local r (TaggedTrans effs trans m) a ->
Lift.Local r (TaggedTrans (eff ': effs) trans m) a)
(local @tag)
reader =
(coerce :: forall a .
((r -> a) -> TaggedTrans effs trans m a) ->
((r -> a) -> TaggedTrans (eff ': effs) trans m a))
(reader @tag)
asks
:: forall tag r m a
. MonadReader tag r m
=> (r -> a)
-> m a
asks = reader @tag
data READER
type Reader tag r = ReaderT tag r Identity
type ReaderT tag r = TaggedTrans (TAGGED READER tag) (T.ReaderT r)
readerT :: forall tag r m a . (r -> m a) -> ReaderT tag r m a
readerT = coerce (T.ReaderT @r @m @a)
runReaderT :: forall tag r m a . ReaderT tag r m a -> r -> m a
runReaderT = coerce (T.runReaderT @r @_ @m @a)
runReader :: forall tag r a . Reader tag r a -> r -> a
runReader = coerce (T.runReader @r @a)
type instance HandleSuper READER r trans = ()
type instance HandleConstraint READER r trans m =
T.MonadReader r (trans m)
instance Handle READER r (T.ReaderT r) where
handling r = r
instance
( Handle READER r trans
, Monad m, Monad (trans m)
) => MonadReader tag r (TaggedTrans (TAGGED READER tag) trans m)
where
ask =
handling @READER @r @trans @m $
coerce (T.ask @r @(trans m))
local =
handling @READER @r @trans @m $
coerce (T.local @r @(trans m) @a) ::
forall eff a . Local r (TaggedTrans eff trans m) a
reader =
handling @READER @r @trans @m $
coerce (T.reader @r @(trans m) @a) ::
forall eff a . (r -> a) -> TaggedTrans eff trans m a
instance
( HasLens tag payload r
, Handle READER payload trans
, Monad m, Monad (trans m)
) => MonadReader tag r (TaggedTrans (TAGGED READER tag ': effs) trans m)
where
ask =
handling @READER @payload @trans @m $
(coerce :: forall eff a .
trans m a ->
TaggedTrans eff trans m a)
(T.asks (view (lensOf @tag @payload @r)))
local f =
handling @READER @payload @trans @m $
(coerce :: forall eff a .
(trans m a -> trans m a) ->
(TaggedTrans eff trans m a -> TaggedTrans eff trans m a))
(T.local (over (lensOf @tag @payload @r) f))
type family READERS (ts :: HList xs) :: [Type] where
READERS 'HNil = '[]
READERS ('HCons t ts) = TAGGED READER t ': READERS ts
type ReadersT r = TaggedTrans (READERS (Tags r)) (T.ReaderT r)
type Readers r = ReadersT r Identity
runReadersT :: forall p m a . ReadersT p m a -> p -> m a
runReadersT = coerce (T.runReaderT @p @_ @m @a)
runReaders :: forall p a . Readers p a -> p -> a
runReaders = coerce (T.runReader @p @a)
type ReaderT' r = ReaderT r r
readerT' :: (r -> m a) -> ReaderT' r m a
readerT' = readerT
runReaderT' :: ReaderT' r m a -> r -> m a
runReaderT' = runReaderT
type Reader' r = Reader r r
runReader' :: Reader' r a -> r -> a
runReader' = runReader
type MonadReader' r = MonadReader r r
local' :: forall r m a . MonadReader' r m => (r -> r) -> m a -> m a
local' = local @r
ask' :: forall r m . MonadReader' r m => m r
ask' = ask @r
reader' :: forall r m a . MonadReader' r m => (r -> a) -> m a
reader' = reader @r
asks' :: forall r m a . MonadReader' r m => (r -> a) -> m a
asks' = asks @r