{-# LANGUAGE TemplateHaskell #-}
module Control.Effect.RWS
(
RWS'(..)
, RWS
, ask
, local
, tell
, listen
, censor
, get
, put
, asks'
, asks
, listens'
, listens
, gets'
, gets
, modify'
, modify
, modifyStrict'
, modifyStrict
, Separation(..)
, runSeparatedRWS'
, runSeparatedRWS
, tagRWS'
, retagRWS'
, untagRWS'
) where
import Data.Coerce (coerce)
import Data.Tuple (swap)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.CPS as Strict
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
class Monad m => RWS' tag r w s m | tag m -> r w s where
ask' :: m r
local' :: (r -> r)
-> m a
-> m a
tell' :: w -> m ()
listen' :: m a -> m (w, a)
censor' :: (w -> w)
-> m a
-> m a
get' :: m s
put' :: s -> m ()
makeTaggedEffect ''RWS'
instance (Monad m, Monoid w) => RWS' tag r w s (Lazy.RWST r w s m) where
ask' :: RWST r w s m r
ask' = RWST r w s m r
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
Lazy.ask
{-# INLINE ask' #-}
local' :: (r -> r) -> RWST r w s m a -> RWST r w s m a
local' = (r -> r) -> RWST r w s m a -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> r) -> RWST r w s m a -> RWST r w s m a
Lazy.local
{-# INLINE local' #-}
tell' :: w -> RWST r w s m ()
tell' = w -> RWST r w s m ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
Lazy.tell
{-# INLINE tell' #-}
listen' :: RWST r w s m a -> RWST r w s m (w, a)
listen' = ((a, w) -> (w, a)) -> RWST r w s m (a, w) -> RWST r w s m (w, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> (w, a)
forall a b. (a, b) -> (b, a)
swap (RWST r w s m (a, w) -> RWST r w s m (w, a))
-> (RWST r w s m a -> RWST r w s m (a, w))
-> RWST r w s m a
-> RWST r w s m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWST r w s m a -> RWST r w s m (a, w)
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> RWST r w s m (a, w)
Lazy.listen
{-# INLINE listen' #-}
censor' :: (w -> w) -> RWST r w s m a -> RWST r w s m a
censor' = (w -> w) -> RWST r w s m a -> RWST r w s m a
forall (m :: * -> *) w r s a.
Monad m =>
(w -> w) -> RWST r w s m a -> RWST r w s m a
Lazy.censor
{-# INLINE censor' #-}
get' :: RWST r w s m s
get' = RWST r w s m s
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
Lazy.get
{-# INLINE get' #-}
put' :: s -> RWST r w s m ()
put' = s -> RWST r w s m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
Lazy.put
{-# INLINE put' #-}
instance (Monad m, Monoid w) => RWS' tag r w s (Strict.RWST r w s m) where
ask' :: RWST r w s m r
ask' = RWST r w s m r
forall (m :: * -> *) r w s. Monad m => RWST r w s m r
Strict.ask
{-# INLINE ask' #-}
local' :: (r -> r) -> RWST r w s m a -> RWST r w s m a
local' = (r -> r) -> RWST r w s m a -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> r) -> RWST r w s m a -> RWST r w s m a
Strict.local
{-# INLINE local' #-}
tell' :: w -> RWST r w s m ()
tell' = w -> RWST r w s m ()
forall w (m :: * -> *) r s.
(Monoid w, Monad m) =>
w -> RWST r w s m ()
Strict.tell
{-# INLINE tell' #-}
listen' :: RWST r w s m a -> RWST r w s m (w, a)
listen' = ((a, w) -> (w, a)) -> RWST r w s m (a, w) -> RWST r w s m (w, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> (w, a)
forall a b. (a, b) -> (b, a)
swap (RWST r w s m (a, w) -> RWST r w s m (w, a))
-> (RWST r w s m a -> RWST r w s m (a, w))
-> RWST r w s m a
-> RWST r w s m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWST r w s m a -> RWST r w s m (a, w)
forall w (m :: * -> *) r s a.
(Monoid w, Monad m) =>
RWST r w s m a -> RWST r w s m (a, w)
Strict.listen
{-# INLINE listen' #-}
censor' :: (w -> w) -> RWST r w s m a -> RWST r w s m a
censor' = (w -> w) -> RWST r w s m a -> RWST r w s m a
forall w (m :: * -> *) r s a.
(Monoid w, Monad m) =>
(w -> w) -> RWST r w s m a -> RWST r w s m a
Strict.censor
{-# INLINE censor' #-}
get' :: RWST r w s m s
get' = RWST r w s m s
forall (m :: * -> *) r w s. Monad m => RWST r w s m s
Strict.get
{-# INLINE get' #-}
put' :: s -> RWST r w s m ()
put' = s -> RWST r w s m ()
forall (m :: * -> *) s r w. Monad m => s -> RWST r w s m ()
Strict.put
{-# INLINE put' #-}
asks' :: forall tag r w s m a. RWS' tag r w s m
=> (r -> a)
-> m a
asks' :: (r -> a) -> m a
asks' = ((r -> a) -> m r -> m a) -> m r -> (r -> a) -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (r -> a) -> m r -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k (tag :: k) r w s (m :: * -> *). RWS' tag r w s m => m r
forall r w s (m :: * -> *). RWS' tag r w s m => m r
ask' @tag)
{-# INLINE asks' #-}
asks :: RWS r w s m => (r -> a) -> m a
asks :: (r -> a) -> m a
asks = forall k (tag :: k) r w s (m :: * -> *) a.
RWS' tag r w s m =>
(r -> a) -> m a
forall r w s (m :: * -> *) a. RWS' G r w s m => (r -> a) -> m a
asks' @G
{-# INLINE asks #-}
listens' :: forall tag r w s b m a. RWS' tag r w s m
=> (w -> b)
-> m a
-> m (b, a)
listens' :: (w -> b) -> m a -> m (b, a)
listens' f :: w -> b
f action :: m a
action = do
~(w :: w
w, a :: a
a) <- m a -> m (w, a)
forall k (tag :: k) r w s (m :: * -> *) a.
RWS' tag r w s m =>
m a -> m (w, a)
listen' @tag m a
action
(b, a) -> m (b, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (w -> b
f w
w, a
a)
{-# INLINE listens' #-}
listens :: RWS r w s m => (w -> b) -> m a -> m (b, a)
listens :: (w -> b) -> m a -> m (b, a)
listens = forall k (tag :: k) r w s b (m :: * -> *) a.
RWS' tag r w s m =>
(w -> b) -> m a -> m (b, a)
forall r w s b (m :: * -> *) a.
RWS' G r w s m =>
(w -> b) -> m a -> m (b, a)
listens' @G
{-# INLINE listens #-}
gets' :: forall tag r w s m a. RWS' tag r w s m => (s -> a) -> m a
gets' :: (s -> a) -> m a
gets' f :: s -> a
f = (s -> a) -> m s -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> a
f (forall k (tag :: k) r w s (m :: * -> *). RWS' tag r w s m => m s
forall r w s (m :: * -> *). RWS' tag r w s m => m s
get' @tag)
{-# INLINE gets' #-}
gets :: RWS r w s m => (s -> a) -> m a
gets :: (s -> a) -> m a
gets f :: s -> a
f = (s -> a) -> m s -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> a
f m s
forall r w s (m :: * -> *). RWS r w s m => m s
get
{-# INLINE gets #-}
modify' :: forall tag r w s m. RWS' tag r w s m => (s -> s) -> m ()
modify' :: (s -> s) -> m ()
modify' f :: s -> s
f = do
s
s <- forall k (tag :: k) r w s (m :: * -> *). RWS' tag r w s m => m s
forall r w s (m :: * -> *). RWS' tag r w s m => m s
get' @tag
s -> m ()
forall k (tag :: k) r w s (m :: * -> *).
RWS' tag r w s m =>
s -> m ()
put' @tag (s -> s
f s
s)
{-# INLINE modify' #-}
modify :: RWS r w s m => (s -> s) -> m ()
modify :: (s -> s) -> m ()
modify = forall k (tag :: k) r w s (m :: * -> *).
RWS' tag r w s m =>
(s -> s) -> m ()
forall r w s (m :: * -> *). RWS' G r w s m => (s -> s) -> m ()
modify' @G
{-# INLINE modify #-}
modifyStrict' :: forall tag r w s m. RWS' tag r w s m => (s -> s) -> m ()
modifyStrict' :: (s -> s) -> m ()
modifyStrict' f :: s -> s
f = do
s
s <- forall k (tag :: k) r w s (m :: * -> *). RWS' tag r w s m => m s
forall r w s (m :: * -> *). RWS' tag r w s m => m s
get' @tag
forall k (tag :: k) r w s (m :: * -> *).
RWS' tag r w s m =>
s -> m ()
forall r w s (m :: * -> *). RWS' tag r w s m => s -> m ()
put' @tag (s -> m ()) -> s -> m ()
forall a b. (a -> b) -> a -> b
$! s -> s
f s
s
{-# INLINE modifyStrict' #-}
modifyStrict :: RWS r w s m => (s -> s) -> m ()
modifyStrict :: (s -> s) -> m ()
modifyStrict = forall k (tag :: k) r w s (m :: * -> *).
RWS' tag r w s m =>
(s -> s) -> m ()
forall r w s (m :: * -> *). RWS' G r w s m => (s -> s) -> m ()
modifyStrict' @G
{-# INLINE modifyStrict #-}
newtype Separation m a =
Separation { Separation m a -> m a
runSeparation :: m a }
deriving (Functor (Separation m)
a -> Separation m a
Functor (Separation m) =>
(forall a. a -> Separation m a)
-> (forall a b.
Separation m (a -> b) -> Separation m a -> Separation m b)
-> (forall a b c.
(a -> b -> c)
-> Separation m a -> Separation m b -> Separation m c)
-> (forall a b. Separation m a -> Separation m b -> Separation m b)
-> (forall a b. Separation m a -> Separation m b -> Separation m a)
-> Applicative (Separation m)
Separation m a -> Separation m b -> Separation m b
Separation m a -> Separation m b -> Separation m a
Separation m (a -> b) -> Separation m a -> Separation m b
(a -> b -> c) -> Separation m a -> Separation m b -> Separation m c
forall a. a -> Separation m a
forall a b. Separation m a -> Separation m b -> Separation m a
forall a b. Separation m a -> Separation m b -> Separation m b
forall a b.
Separation m (a -> b) -> Separation m a -> Separation m b
forall a b c.
(a -> b -> c) -> Separation m a -> Separation m b -> Separation m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (Separation m)
forall (m :: * -> *) a. Applicative m => a -> Separation m a
forall (m :: * -> *) a b.
Applicative m =>
Separation m a -> Separation m b -> Separation m a
forall (m :: * -> *) a b.
Applicative m =>
Separation m a -> Separation m b -> Separation m b
forall (m :: * -> *) a b.
Applicative m =>
Separation m (a -> b) -> Separation m a -> Separation m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> Separation m a -> Separation m b -> Separation m c
<* :: Separation m a -> Separation m b -> Separation m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
Separation m a -> Separation m b -> Separation m a
*> :: Separation m a -> Separation m b -> Separation m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
Separation m a -> Separation m b -> Separation m b
liftA2 :: (a -> b -> c) -> Separation m a -> Separation m b -> Separation m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> Separation m a -> Separation m b -> Separation m c
<*> :: Separation m (a -> b) -> Separation m a -> Separation m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
Separation m (a -> b) -> Separation m a -> Separation m b
pure :: a -> Separation m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> Separation m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (Separation m)
Applicative, a -> Separation m b -> Separation m a
(a -> b) -> Separation m a -> Separation m b
(forall a b. (a -> b) -> Separation m a -> Separation m b)
-> (forall a b. a -> Separation m b -> Separation m a)
-> Functor (Separation m)
forall a b. a -> Separation m b -> Separation m a
forall a b. (a -> b) -> Separation m a -> Separation m b
forall (m :: * -> *) a b.
Functor m =>
a -> Separation m b -> Separation m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Separation m a -> Separation m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Separation m b -> Separation m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Separation m b -> Separation m a
fmap :: (a -> b) -> Separation m a -> Separation m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Separation m a -> Separation m b
Functor, Applicative (Separation m)
a -> Separation m a
Applicative (Separation m) =>
(forall a b.
Separation m a -> (a -> Separation m b) -> Separation m b)
-> (forall a b. Separation m a -> Separation m b -> Separation m b)
-> (forall a. a -> Separation m a)
-> Monad (Separation m)
Separation m a -> (a -> Separation m b) -> Separation m b
Separation m a -> Separation m b -> Separation m b
forall a. a -> Separation m a
forall a b. Separation m a -> Separation m b -> Separation m b
forall a b.
Separation m a -> (a -> Separation m b) -> Separation m b
forall (m :: * -> *). Monad m => Applicative (Separation m)
forall (m :: * -> *) a. Monad m => a -> Separation m a
forall (m :: * -> *) a b.
Monad m =>
Separation m a -> Separation m b -> Separation m b
forall (m :: * -> *) a b.
Monad m =>
Separation m a -> (a -> Separation m b) -> Separation m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Separation m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> Separation m a
>> :: Separation m a -> Separation m b -> Separation m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Separation m a -> Separation m b -> Separation m b
>>= :: Separation m a -> (a -> Separation m b) -> Separation m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Separation m a -> (a -> Separation m b) -> Separation m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (Separation m)
Monad, Monad (Separation m)
Monad (Separation m) =>
(forall a. IO a -> Separation m a) -> MonadIO (Separation m)
IO a -> Separation m a
forall a. IO a -> Separation m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (Separation m)
forall (m :: * -> *) a. MonadIO m => IO a -> Separation m a
liftIO :: IO a -> Separation m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Separation m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (Separation m)
MonadIO)
deriving (m a -> Separation m a
(forall (m :: * -> *) a. Monad m => m a -> Separation m a)
-> MonadTrans Separation
forall (m :: * -> *) a. Monad m => m a -> Separation m a
forall (t :: Transformer).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> Separation m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> Separation m a
MonadTrans, MonadTrans Separation
m (StT Separation a) -> Separation m a
MonadTrans Separation =>
(forall (m :: * -> *) a.
Monad m =>
(Run Separation -> m a) -> Separation m a)
-> (forall (m :: * -> *) a.
Monad m =>
m (StT Separation a) -> Separation m a)
-> MonadTransControl Separation
(Run Separation -> m a) -> Separation m a
forall (m :: * -> *) a.
Monad m =>
m (StT Separation a) -> Separation m a
forall (m :: * -> *) a.
Monad m =>
(Run Separation -> m a) -> Separation m a
forall (t :: Transformer).
MonadTrans t =>
(forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
restoreT :: m (StT Separation a) -> Separation m a
$crestoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT Separation a) -> Separation m a
liftWith :: (Run Separation -> m a) -> Separation m a
$cliftWith :: forall (m :: * -> *) a.
Monad m =>
(Run Separation -> m a) -> Separation m a
$cp1MonadTransControl :: MonadTrans Separation
MonadTransControl) via Default
deriving (MonadBase b, MonadBaseControl b)
instance (R.Reader' tag r m, W.Writer' tag w m, S.State' tag s m) => RWS' tag r w s (Separation m) where
ask' :: Separation m r
ask' = m r -> Separation m r
forall k (m :: k -> *) (a :: k). m a -> Separation m a
Separation (forall k (tag :: k) r (m :: * -> *). Reader' tag r m => m r
forall r (m :: * -> *). Reader' tag r m => m r
R.ask' @tag)
{-# INLINE ask' #-}
local' :: (r -> r) -> Separation m a -> Separation m a
local' f :: r -> r
f = m a -> Separation m a
forall k (m :: k -> *) (a :: k). m a -> Separation m a
Separation (m a -> Separation m a)
-> (Separation m a -> m a) -> Separation m a -> Separation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> r) -> m a -> m a
forall k (tag :: k) r (m :: * -> *) a.
Reader' tag r m =>
(r -> r) -> m a -> m a
R.local' @tag r -> r
f (m a -> m a) -> (Separation m a -> m a) -> Separation m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Separation m a -> m a
forall k (m :: k -> *) (a :: k). Separation m a -> m a
runSeparation
{-# INLINE local' #-}
tell' :: w -> Separation m ()
tell' = m () -> Separation m ()
forall k (m :: k -> *) (a :: k). m a -> Separation m a
Separation (m () -> Separation m ()) -> (w -> m ()) -> w -> Separation m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (tag :: k) w (m :: * -> *). Writer' tag w m => w -> m ()
forall w (m :: * -> *). Writer' tag w m => w -> m ()
W.tell' @tag
{-# INLINE tell' #-}
listen' :: Separation m a -> Separation m (w, a)
listen' = m (w, a) -> Separation m (w, a)
forall k (m :: k -> *) (a :: k). m a -> Separation m a
Separation (m (w, a) -> Separation m (w, a))
-> (Separation m a -> m (w, a))
-> Separation m a
-> Separation m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (tag :: k) w (m :: * -> *) a.
Writer' tag w m =>
m a -> m (w, a)
forall w (m :: * -> *) a. Writer' tag w m => m a -> m (w, a)
W.listen' @tag (m a -> m (w, a))
-> (Separation m a -> m a) -> Separation m a -> m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Separation m a -> m a
forall k (m :: k -> *) (a :: k). Separation m a -> m a
runSeparation
{-# INLINE listen' #-}
censor' :: (w -> w) -> Separation m a -> Separation m a
censor' f :: w -> w
f = m a -> Separation m a
forall k (m :: k -> *) (a :: k). m a -> Separation m a
Separation (m a -> Separation m a)
-> (Separation m a -> m a) -> Separation m a -> Separation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w -> w) -> m a -> m a
forall k (tag :: k) w (m :: * -> *) a.
Writer' tag w m =>
(w -> w) -> m a -> m a
W.censor' @tag w -> w
f (m a -> m a) -> (Separation m a -> m a) -> Separation m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Separation m a -> m a
forall k (m :: k -> *) (a :: k). Separation m a -> m a
runSeparation
{-# INLINE censor' #-}
get' :: Separation m s
get' = m s -> Separation m s
forall k (m :: k -> *) (a :: k). m a -> Separation m a
Separation (forall k (tag :: k) s (m :: * -> *). State' tag s m => m s
forall s (m :: * -> *). State' tag s m => m s
S.get' @tag)
{-# INLINE get' #-}
put' :: s -> Separation m ()
put' = m () -> Separation m ()
forall k (m :: k -> *) (a :: k). m a -> Separation m a
Separation (m () -> Separation m ()) -> (s -> m ()) -> s -> Separation m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (tag :: k) s (m :: * -> *). State' tag s m => s -> m ()
forall s (m :: * -> *). State' tag s m => s -> m ()
S.put' @tag
{-# INLINE put' #-}
runSeparatedRWS' :: (RWS' tag r w s `Via` Separation) m a
-> m a
runSeparatedRWS' :: Via (RWS' tag r w s) Separation m a -> m a
runSeparatedRWS' = Via (RWS' tag r w s) Separation m a -> m a
forall a b. Coercible a b => a -> b
coerce
{-# INLINE runSeparatedRWS' #-}
runSeparatedRWS :: (RWS r w s `Via` Separation) m a -> m a
runSeparatedRWS :: Via (RWS r w s) Separation m a -> m a
runSeparatedRWS = Via (RWS r w s) Separation m a -> m a
forall a b. Coercible a b => a -> b
coerce
{-# INLINE runSeparatedRWS #-}