{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.RWS
(
RWS'
, RWS
, Separation
, runSeparatedRWS'
, runSeparatedRWS
, Tagger
, tagRWS'
, retagRWS'
, untagRWS'
) where
import Data.Coerce (coerce)
import qualified Control.Monad.Trans.RWS.CPS as Strict
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Effect.Reader as R
import qualified Control.Effect.State as S
import qualified Control.Effect.Writer as W
import Control.Effect.Machinery hiding (Tagger)
class (R.Reader' tag r m, W.Writer' tag w m, S.State' tag s m) => RWS' tag r w s m | tag m -> r w s
type RWS r w s = RWS' G r w s
instance ( Monad (t m),
R.Reader' tag r (EachVia effs t m),
W.Writer' tag w (EachVia effs t m),
S.State' tag s (EachVia effs t m)
) => RWS' tag r w s (EachVia (RWS' tag r w s : effs) t m)
instance {-# OVERLAPPABLE #-}
Find (RWS' tag r w s) effs t m => RWS' tag r w s (EachVia (other : effs) t m)
instance Control (RWS' tag r w s) t m => RWS' tag r w s (EachVia '[] t m)
instance (Monad m, Monoid w) => RWS' tag r w s (Lazy.RWST r w s m)
instance (Monad m, Monoid w) => RWS' tag r w s (Strict.RWST r w s m)
newtype Separation m a =
Separation { runSeparation :: m a }
deriving (Applicative, Functor, Monad, MonadIO)
deriving (MonadTrans, MonadTransControl) via IdentityT
deriving (MonadBase b, MonadBaseControl b)
instance R.Reader' tag r m => R.Reader' tag r (Separation m) where
ask' = Separation (R.ask' @tag)
{-# INLINE ask' #-}
local' f m = Separation (R.local' @tag f (runSeparation m))
{-# INLINE local' #-}
reader' f = Separation (R.reader' @tag f)
{-# INLINE reader' #-}
instance W.Writer' tag w m => W.Writer' tag w (Separation m) where
tell' w = Separation (W.tell' @tag w)
{-# INLINE tell' #-}
listen' m = Separation (W.listen' @tag (runSeparation m))
{-# INLINE listen' #-}
censor' f m = Separation (W.censor' @tag f (runSeparation m))
{-# INLINE censor' #-}
instance S.State' tag s m => S.State' tag s (Separation m) where
get' = Separation (S.get' @tag)
{-# INLINE get' #-}
put' s = Separation (S.put' @tag s)
{-# INLINE put' #-}
state' f = Separation (S.state' @tag f)
{-# INLINE state' #-}
instance (R.Reader' tag r m, W.Writer' tag w m, S.State' tag s m) => RWS' tag r w s (Separation m)
runSeparatedRWS'
:: ('[RWS' tag r w s, R.Reader' tag r, W.Writer' tag w, S.State' tag s] `EachVia` Separation) m a
-> m a
runSeparatedRWS' = coerce
{-# INLINE runSeparatedRWS' #-}
runSeparatedRWS :: ('[RWS r w s, R.Reader r, W.Writer w, S.State s] `EachVia` Separation) m a -> m a
runSeparatedRWS = coerce
{-# INLINE runSeparatedRWS #-}
newtype Tagger tag new m a =
Tagger { runRWSTagger :: m a }
deriving (Applicative, Functor, Monad, MonadIO)
deriving (MonadTrans, MonadTransControl) via IdentityT
deriving (MonadBase b, MonadBaseControl b)
instance RWS' new r w s m => RWS' tag r w s (Tagger tag new m)
instance RWS' new r w s m => R.Reader' tag r (Tagger tag new m) where
ask' = Tagger (R.ask' @new)
{-# INLINE ask' #-}
local' f m = Tagger (R.local' @new f (runRWSTagger m))
{-# INLINE local' #-}
reader' f = Tagger (R.reader' @new f)
{-# INLINE reader' #-}
instance RWS' new r w s m => W.Writer' tag w (Tagger tag new m) where
tell' w = Tagger (W.tell' @new w)
{-# INLINE tell' #-}
listen' m = Tagger (W.listen' @new (runRWSTagger m))
{-# INLINE listen' #-}
censor' f m = Tagger (W.censor' @new f (runRWSTagger m))
{-# INLINE censor' #-}
instance RWS' new r w s m => S.State' tag s (Tagger tag new m) where
get' = Tagger (S.get' @new)
{-# INLINE get' #-}
put' s = Tagger (S.put' @new s)
{-# INLINE put' #-}
state' f = Tagger (S.state' @new f)
{-# INLINE state' #-}
tagRWS' :: forall new r w s m a. ('[RWS' G r w s, R.Reader' G r, W.Writer' G w, S.State' G s] `EachVia` Tagger G new) m a -> m a
tagRWS' = coerce
{-# INLINE tagRWS' #-}
retagRWS' :: forall tag new r w s m a. ('[RWS' tag r w s, R.Reader' tag r, W.Writer' tag w, S.State' tag s] `EachVia` Tagger tag new) m a -> m a
retagRWS' = coerce
{-# INLINE retagRWS' #-}
untagRWS' :: forall tag r w s m a. ('[RWS' tag r w s, R.Reader' tag r, W.Writer' tag w, S.State' tag s] `EachVia` Tagger tag G) m a -> m a
untagRWS' = coerce
{-# INLINE untagRWS' #-}