module Control.Effect.RWS.Strict
(
RWST
, evalRWS'
, execRWS'
, runRWS'
, evalRWS
, execRWS
, runRWS
) where
import Control.Monad (liftM)
import Data.Coerce (coerce)
import qualified Control.Monad.Trans.RWS.CPS as RWS
import Control.Effect.Machinery
import Control.Effect.Reader (Reader, Reader')
import Control.Effect.RWS (RWS, RWS')
import Control.Effect.State (State, State')
import Control.Effect.Writer (Writer, Writer')
newtype RWST r w s m a =
RWST { runRWST :: RWS.RWST r w s m a }
deriving (Applicative, Functor, Monad, MonadIO)
deriving (MonadTrans)
deriving (RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s)
instance MonadBase b m => MonadBase b (RWST r w s m) where
liftBase = liftBaseDefault
{-# INLINE liftBase #-}
instance (MonadBaseControl b m, Monoid w) => MonadBaseControl b (RWST r w s m) where
type StM (RWST r w s m) a = ComposeSt (RWST r w s) m a
liftBaseWith = defaultLiftBaseWith
{-# INLINE liftBaseWith #-}
restoreM = defaultRestoreM
{-# INLINE restoreM #-}
instance Monoid w => MonadTransControl (RWST r w s) where
type StT (RWST r w s) a = (a, s, w)
liftWith f = RWST . RWS.rwsT $
\r s -> liftM ( \x -> (x, s, mempty) )
( f $ \t -> (RWS.runRWST . runRWST) t r s )
{-# INLINABLE liftWith #-}
restoreT mSt = RWST . RWS.rwsT $ \_ _ -> mSt
{-# INLINABLE restoreT #-}
evalRWS'
:: forall tag r w s m a. (Functor m, Monoid w)
=> r
-> s
-> ('[RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s] `EachVia` RWST r w s) m a
-> m (w, a)
evalRWS' r s = fmap reorder . (\m -> RWS.runRWST m r s) . coerce
where
reorder (a, _, w) = (w, a)
{-# INLINE evalRWS' #-}
evalRWS :: (Functor m, Monoid w) => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` RWST r w s) m a -> m (w, a)
evalRWS = evalRWS' @G
{-# INLINE evalRWS #-}
execRWS'
:: forall tag r w s m a. (Functor m, Monoid w)
=> r
-> s
-> ('[RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s] `EachVia` RWST r w s) m a
-> m (w, s)
execRWS' r s = fmap reorder . (\m -> RWS.runRWST m r s) . coerce
where
reorder (_, s', w) = (w, s')
{-# INLINE execRWS' #-}
execRWS :: (Functor m, Monoid w) => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` RWST r w s) m a -> m (w, s)
execRWS = execRWS' @G
{-# INLINE execRWS #-}
runRWS'
:: forall tag r w s m a. (Functor m, Monoid w)
=> r
-> s
-> ('[RWS' tag r w s, Reader' tag r, Writer' tag w, State' tag s] `EachVia` RWST r w s) m a
-> m (w, s, a)
runRWS' r s = fmap reorder . (\m -> RWS.runRWST m r s) . coerce
where
reorder (a, s', w) = (w, s', a)
{-# INLINE runRWS' #-}
runRWS :: (Functor m, Monoid w) => r -> s -> ('[RWS r w s, Reader r, Writer w, State s] `EachVia` RWST r w s) m a -> m (w, s, a)
runRWS = runRWS' @G
{-# INLINE runRWS #-}