{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | The 'Algebra' class is the mechanism with which effects are interpreted.

An instance of the 'Algebra' class defines an interpretation of an effect signature atop a given monad.

@since 1.0.0.0
-}
module Control.Algebra
( Algebra(..)
, run
, Has
, send
  -- * Re-exports
, (:+:) (..)
, module Control.Effect.Class
) where

import           Control.Effect.Catch.Internal
import           Control.Effect.Choose.Internal
import           Control.Effect.Class
import           Control.Effect.Empty.Internal
import           Control.Effect.Error.Internal
import           Control.Effect.Lift.Internal
import           Control.Effect.NonDet.Internal
import           Control.Effect.Reader.Internal
import           Control.Effect.State.Internal
import           Control.Effect.Sum ((:+:)(..), Member(..), Members)
import           Control.Effect.Throw.Internal
import           Control.Effect.Writer.Internal
import           Control.Monad ((<=<))
import qualified Control.Monad.Trans.Except as Except
import qualified Control.Monad.Trans.Identity as Identity
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.RWS.Lazy as RWS.Lazy
import qualified Control.Monad.Trans.RWS.Strict as RWS.Strict
import qualified Control.Monad.Trans.State.Lazy as State.Lazy
import qualified Control.Monad.Trans.State.Strict as State.Strict
import qualified Control.Monad.Trans.Writer.Lazy as Writer.Lazy
import qualified Control.Monad.Trans.Writer.Strict as Writer.Strict
import           Data.Coerce
import           Data.Functor.Identity
import           Data.List.NonEmpty (NonEmpty)
import           Data.Monoid
import qualified Data.Semigroup as S
import           Data.Tuple (swap)

-- | The class of carriers (results) for algebras (effect handlers) over signatures (effects), whose actions are given by the 'alg' method.
--
-- @since 1.0.0.0
class (HFunctor sig, Monad m) => Algebra sig m | m -> sig where
  -- | Construct a value in the carrier for an effect signature (typically a sum of a handled effect and any remaining effects).
  alg :: sig m a -> m a


-- | Run an action exhausted of effects to produce its final result value.
--
-- @since 1.0.0.0
run :: Identity a -> a
run :: Identity a -> a
run = Identity a -> a
forall a. Identity a -> a
runIdentity
{-# INLINE run #-}


-- | @m@ is a carrier for @sig@ containing @eff@.
--
-- Note that if @eff@ is a sum, it will be decomposed into multiple 'Member' constraints. While this technically allows one to combine multiple unrelated effects into a single 'Has' constraint, doing so has two significant drawbacks:
--
-- 1. Due to [a problem with recursive type families](https://gitlab.haskell.org/ghc/ghc/issues/8095), this can lead to significantly slower compiles.
--
-- 2. It defeats @ghc@’s warnings for redundant constraints, and thus can lead to a proliferation of redundant constraints as code is changed.
type Has eff sig m = (Members eff sig, Algebra sig m)

-- | Construct a request for an effect to be interpreted by some handler later on.
send :: (Member eff sig, Algebra sig m) => eff m a -> m a
send :: eff m a -> m a
send = sig m a -> m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (sig m a -> m a) -> (eff m a -> sig m a) -> eff m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. eff m a -> sig m a
forall (sub :: (* -> *) -> * -> *) (sup :: (* -> *) -> * -> *)
       (m :: * -> *) a.
Member sub sup =>
sub m a -> sup m a
inj
{-# INLINE send #-}


-- base

instance Algebra (Lift IO) IO where
  alg :: Lift IO IO a -> IO a
alg (LiftWith with :: forall (ctx :: * -> *).
Functor ctx =>
ctx () -> (forall a. ctx (IO a) -> IO (ctx a)) -> IO (ctx a)
with k :: a -> IO a
k) = Identity ()
-> (forall a. Identity (IO a) -> IO (Identity a))
-> IO (Identity a)
forall (ctx :: * -> *).
Functor ctx =>
ctx () -> (forall a. ctx (IO a) -> IO (ctx a)) -> IO (ctx a)
with (() -> Identity ()
forall a. a -> Identity a
Identity ()) forall a. Identity (IO a) -> IO (Identity a)
forall a b. Coercible a b => a -> b
coerce IO (Identity a) -> (Identity a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO a
k (a -> IO a) -> (Identity a -> a) -> Identity a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity

instance Algebra (Lift Identity) Identity where
  alg :: Lift Identity Identity a -> Identity a
alg (LiftWith with :: forall (ctx :: * -> *).
Functor ctx =>
ctx ()
-> (forall a. ctx (Identity a) -> Identity (ctx a))
-> Identity (ctx a)
with k :: a -> Identity a
k) = Identity ()
-> (forall a. Identity (Identity a) -> Identity (Identity a))
-> Identity (Identity a)
forall (ctx :: * -> *).
Functor ctx =>
ctx ()
-> (forall a. ctx (Identity a) -> Identity (ctx a))
-> Identity (ctx a)
with (() -> Identity ()
forall a. a -> Identity a
Identity ()) forall a. Identity (Identity a) -> Identity (Identity a)
forall a b. Coercible a b => a -> b
coerce Identity (Identity a) -> (Identity a -> Identity a) -> Identity a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Identity a
k (a -> Identity a) -> (Identity a -> a) -> Identity a -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity

instance Algebra Choose NonEmpty where
  alg :: Choose NonEmpty a -> NonEmpty a
alg (Choose m :: Bool -> NonEmpty a
m) = Bool -> NonEmpty a
m Bool
True NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
S.<> Bool -> NonEmpty a
m Bool
False

instance Algebra Empty Maybe where
  alg :: Empty Maybe a -> Maybe a
alg Empty = Maybe a
forall a. Maybe a
Nothing

instance Algebra (Error e) (Either e) where
  alg :: Error e (Either e) a -> Either e a
alg (L (Throw e :: e
e))     = e -> Either e a
forall a b. a -> Either a b
Left e
e
  alg (R (Catch m :: Either e b
m h :: e -> Either e b
h k :: b -> Either e a
k)) = (e -> Either e a) -> (b -> Either e a) -> Either e b -> Either e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (b -> Either e a
k (b -> Either e a) -> (e -> Either e b) -> e -> Either e a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< e -> Either e b
h) b -> Either e a
k Either e b
m

instance Algebra (Reader r) ((->) r) where
  alg :: Reader r ((->) r) a -> r -> a
alg (Ask       k :: r -> r -> a
k) r :: r
r = r -> r -> a
k r
r r
r
  alg (Local f :: r -> r
f m :: r -> b
m k :: b -> r -> a
k) r :: r
r = b -> r -> a
k (r -> b
m (r -> r
f r
r)) r
r

instance Algebra NonDet [] where
  alg :: NonDet [] a -> [a]
alg (L Empty)      = []
  alg (R (Choose k :: Bool -> [a]
k)) = Bool -> [a]
k Bool
True [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Bool -> [a]
k Bool
False

instance Monoid w => Algebra (Writer w) ((,) w) where
  alg :: Writer w ((,) w) a -> (w, a)
alg (Tell w :: w
w (w' :: w
w', k :: a
k))    = (w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w w
w', a
k)
  alg (Listen (w :: w
w, a :: a
a) k :: w -> a -> (w, a)
k)   = let (w' :: w
w', a' :: a
a') = w -> a -> (w, a)
k w
w a
a in (w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w w
w', a
a')
  alg (Censor f :: w -> w
f (w :: w
w, a :: a
a) k :: a -> (w, a)
k) = let (w' :: w
w', a' :: a
a') = a -> (w, a)
k a
a in (w -> w -> w
forall a. Monoid a => a -> a -> a
mappend (w -> w
f w
w) w
w', a
a')


-- transformers

instance (Algebra sig m, Effect sig) => Algebra (Error e :+: sig) (Except.ExceptT e m) where
  alg :: (:+:) (Error e) sig (ExceptT e m) a -> ExceptT e m a
alg (L (L (Throw e :: e
e)))     = e -> ExceptT e m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE e
e
  alg (L (R (Catch m :: ExceptT e m b
m h :: e -> ExceptT e m b
h k :: b -> ExceptT e m a
k))) = ExceptT e m b -> (e -> ExceptT e m b) -> ExceptT e m b
forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
Except.catchE ExceptT e m b
m e -> ExceptT e m b
h ExceptT e m b -> (b -> ExceptT e m a) -> ExceptT e m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> ExceptT e m a
k
  alg (R other :: sig (ExceptT e m) a
other)             = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
Except.ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ sig m (Either e a) -> m (Either e a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (Either e ()
-> (forall x. Either e (ExceptT e m x) -> m (Either e x))
-> sig (ExceptT e m) a
-> sig m (Either e a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (() -> Either e ()
forall a b. b -> Either a b
Right ()) ((e -> m (Either e x))
-> (ExceptT e m x -> m (Either e x))
-> Either e (ExceptT e m x)
-> m (Either e x)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either e x -> m (Either e x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e x -> m (Either e x))
-> (e -> Either e x) -> e -> m (Either e x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e x
forall a b. a -> Either a b
Left) ExceptT e m x -> m (Either e x)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT) sig (ExceptT e m) a
other)

instance Algebra sig m => Algebra sig (Identity.IdentityT m) where
  alg :: sig (IdentityT m) a -> IdentityT m a
alg = m a -> IdentityT m a
forall k (f :: k -> *) (a :: k). f a -> IdentityT f a
Identity.IdentityT (m a -> IdentityT m a)
-> (sig (IdentityT m) a -> m a)
-> sig (IdentityT m) a
-> IdentityT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig m a -> m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (sig m a -> m a)
-> (sig (IdentityT m) a -> sig m a) -> sig (IdentityT m) a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig (IdentityT m) a -> sig m a
forall (sig :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *) a.
(HFunctor sig, Functor f, Coercible f g) =>
sig f a -> sig g a
handleCoercible

#if MIN_VERSION_base(4,12,0)
-- | This instance permits effectful actions to be lifted into the 'Ap' monad
-- given a monoidal return type, which can provide clarity when chaining calls
-- to 'mappend'.
--
-- > mappend <$> act1 <*> (mappend <$> act2 <*> act3)
--
-- is equivalent to
--
-- > getAp (act1 <> act2 <> act3)
--
-- @since 1.0.1.0
instance Algebra sig m => Algebra sig (Ap m) where
  alg :: sig (Ap m) a -> Ap m a
alg = m a -> Ap m a
forall k (f :: k -> *) (a :: k). f a -> Ap f a
Ap (m a -> Ap m a) -> (sig (Ap m) a -> m a) -> sig (Ap m) a -> Ap m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig m a -> m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (sig m a -> m a)
-> (sig (Ap m) a -> sig m a) -> sig (Ap m) a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig (Ap m) a -> sig m a
forall (sig :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *) a.
(HFunctor sig, Functor f, Coercible f g) =>
sig f a -> sig g a
handleCoercible
#endif

-- | This instance permits effectful actions to be lifted into the 'Alt' monad,
-- which eases the invocation of repeated alternation with 'Control.Applicative.<|>':
--
-- > a <|> b <|> c <|> d
--
-- is equivalent to
--
-- > getAlt (mconcat [a, b, c, d])
--
-- @since 1.0.1.0
instance Algebra sig m => Algebra sig (Alt m) where
  alg :: sig (Alt m) a -> Alt m a
alg = m a -> Alt m a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt (m a -> Alt m a)
-> (sig (Alt m) a -> m a) -> sig (Alt m) a -> Alt m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig m a -> m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (sig m a -> m a)
-> (sig (Alt m) a -> sig m a) -> sig (Alt m) a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sig (Alt m) a -> sig m a
forall (sig :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *) a.
(HFunctor sig, Functor f, Coercible f g) =>
sig f a -> sig g a
handleCoercible

instance Algebra sig m => Algebra (Reader r :+: sig) (Reader.ReaderT r m) where
  alg :: (:+:) (Reader r) sig (ReaderT r m) a -> ReaderT r m a
alg (L (Ask       k :: r -> ReaderT r m a
k)) = ReaderT r m r
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask ReaderT r m r -> (r -> ReaderT r m a) -> ReaderT r m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= r -> ReaderT r m a
k
  alg (L (Local f :: r -> r
f m :: ReaderT r m b
m k :: b -> ReaderT r m a
k)) = (r -> r) -> ReaderT r m b -> ReaderT r m b
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
Reader.local r -> r
f ReaderT r m b
m ReaderT r m b -> (b -> ReaderT r m a) -> ReaderT r m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> ReaderT r m a
k
  alg (R other :: sig (ReaderT r m) a
other)         = (r -> m a) -> ReaderT r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
Reader.ReaderT ((r -> m a) -> ReaderT r m a) -> (r -> m a) -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ \ r :: r
r -> sig m a -> m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg ((forall x. ReaderT r m x -> m x) -> sig (ReaderT r m) a -> sig m a
forall (h :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *) a.
(HFunctor h, Functor m) =>
(forall x. m x -> n x) -> h m a -> h n a
hmap (ReaderT r m x -> r -> m x
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`Reader.runReaderT` r
r) sig (ReaderT r m) a
other)

newtype RWSTF w s a = RWSTF { RWSTF w s a -> (a, s, w)
unRWSTF :: (a, s, w) }
  deriving (a -> RWSTF w s b -> RWSTF w s a
(a -> b) -> RWSTF w s a -> RWSTF w s b
(forall a b. (a -> b) -> RWSTF w s a -> RWSTF w s b)
-> (forall a b. a -> RWSTF w s b -> RWSTF w s a)
-> Functor (RWSTF w s)
forall a b. a -> RWSTF w s b -> RWSTF w s a
forall a b. (a -> b) -> RWSTF w s a -> RWSTF w s b
forall w s a b. a -> RWSTF w s b -> RWSTF w s a
forall w s a b. (a -> b) -> RWSTF w s a -> RWSTF w s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RWSTF w s b -> RWSTF w s a
$c<$ :: forall w s a b. a -> RWSTF w s b -> RWSTF w s a
fmap :: (a -> b) -> RWSTF w s a -> RWSTF w s b
$cfmap :: forall w s a b. (a -> b) -> RWSTF w s a -> RWSTF w s b
Functor)

toRWSTF :: Monoid w => w -> (a, s, w) -> RWSTF w s a
toRWSTF :: w -> (a, s, w) -> RWSTF w s a
toRWSTF w :: w
w (a :: a
a, s :: s
s, w' :: w
w') = (a, s, w) -> RWSTF w s a
forall w s a. (a, s, w) -> RWSTF w s a
RWSTF (a
a, s
s, w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w w
w')
{-# INLINE toRWSTF #-}

instance (Algebra sig m, Effect sig, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Lazy.RWST r w s m) where
  alg :: (:+:) (Reader r) (Writer w :+: (State s :+: sig)) (RWST r w s m) a
-> RWST r w s m a
alg (L (Ask       k :: r -> RWST r w s m a
k))      = RWST r w s m r
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
RWS.Lazy.ask RWST r w s m r -> (r -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= r -> RWST r w s m a
k
  alg (L (Local f :: r -> r
f m :: RWST r w s m b
m k :: b -> RWST r w s m a
k))      = (r -> r) -> RWST r w s m b -> RWST r w s m b
forall r w s (m :: * -> *) a.
(r -> r) -> RWST r w s m a -> RWST r w s m a
RWS.Lazy.local r -> r
f RWST r w s m b
m RWST r w s m b -> (b -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> RWST r w s m a
k
  alg (R (L (Tell w :: w
w k :: RWST r w s m a
k)))     = w -> RWST r w s m ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.Lazy.tell w
w RWST r w s m () -> RWST r w s m a -> RWST r w s m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RWST r w s m a
k
  alg (R (L (Listen m :: RWST r w s m a
m k :: w -> a -> RWST r w s m a
k)))   = 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)
RWS.Lazy.listen RWST r w s m a
m RWST r w s m (a, w) -> ((a, w) -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> w -> RWST r w s m a) -> (a, w) -> RWST r w s m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((w -> a -> RWST r w s m a) -> a -> w -> RWST r w s m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip w -> a -> RWST r w s m a
k)
  alg (R (L (Censor f :: w -> w
f m :: RWST r w s m a
m k :: a -> RWST r w s m a
k))) = (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
RWS.Lazy.censor w -> w
f RWST r w s m a
m RWST r w s m a -> (a -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> RWST r w s m a
k
  alg (R (R (L (Get   k :: s -> RWST r w s m a
k))))  = RWST r w s m s
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.Lazy.get RWST r w s m s -> (s -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> RWST r w s m a
k
  alg (R (R (L (Put s :: s
s k :: RWST r w s m a
k))))  = s -> RWST r w s m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
RWS.Lazy.put s
s RWST r w s m () -> RWST r w s m a -> RWST r w s m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RWST r w s m a
k
  alg (R (R (R other :: sig (RWST r w s m) a
other)))      = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWS.Lazy.RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \ r :: r
r s :: s
s -> RWSTF w s a -> (a, s, w)
forall w s a. RWSTF w s a -> (a, s, w)
unRWSTF (RWSTF w s a -> (a, s, w)) -> m (RWSTF w s a) -> m (a, s, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sig m (RWSTF w s a) -> m (RWSTF w s a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (RWSTF w s ()
-> (forall x. RWSTF w s (RWST r w s m x) -> m (RWSTF w s x))
-> sig (RWST r w s m) a
-> sig m (RWSTF w s a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (((), s, w) -> RWSTF w s ()
forall w s a. (a, s, w) -> RWSTF w s a
RWSTF ((), s
s, w
forall a. Monoid a => a
mempty)) (\ (RWSTF (x :: RWST r w s m x
x, s :: s
s, w :: w
w)) -> w -> (x, s, w) -> RWSTF w s x
forall w a s. Monoid w => w -> (a, s, w) -> RWSTF w s a
toRWSTF w
w ((x, s, w) -> RWSTF w s x) -> m (x, s, w) -> m (RWSTF w s x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST r w s m x -> r -> s -> m (x, s, w)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
RWS.Lazy.runRWST RWST r w s m x
x r
r s
s) sig (RWST r w s m) a
other)

instance (Algebra sig m, Effect sig, Monoid w) => Algebra (Reader r :+: Writer w :+: State s :+: sig) (RWS.Strict.RWST r w s m) where
  alg :: (:+:) (Reader r) (Writer w :+: (State s :+: sig)) (RWST r w s m) a
-> RWST r w s m a
alg (L (Ask       k :: r -> RWST r w s m a
k))      = RWST r w s m r
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
RWS.Strict.ask RWST r w s m r -> (r -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= r -> RWST r w s m a
k
  alg (L (Local f :: r -> r
f m :: RWST r w s m b
m k :: b -> RWST r w s m a
k))      = (r -> r) -> RWST r w s m b -> RWST r w s m b
forall r w s (m :: * -> *) a.
(r -> r) -> RWST r w s m a -> RWST r w s m a
RWS.Strict.local r -> r
f RWST r w s m b
m RWST r w s m b -> (b -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> RWST r w s m a
k
  alg (R (L (Tell w :: w
w k :: RWST r w s m a
k)))     = w -> RWST r w s m ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
RWS.Strict.tell w
w RWST r w s m () -> RWST r w s m a -> RWST r w s m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RWST r w s m a
k
  alg (R (L (Listen m :: RWST r w s m a
m k :: w -> a -> RWST r w s m a
k)))   = 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)
RWS.Strict.listen RWST r w s m a
m RWST r w s m (a, w) -> ((a, w) -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> w -> RWST r w s m a) -> (a, w) -> RWST r w s m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((w -> a -> RWST r w s m a) -> a -> w -> RWST r w s m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip w -> a -> RWST r w s m a
k)
  alg (R (L (Censor f :: w -> w
f m :: RWST r w s m a
m k :: a -> RWST r w s m a
k))) = (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
RWS.Strict.censor w -> w
f RWST r w s m a
m RWST r w s m a -> (a -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> RWST r w s m a
k
  alg (R (R (L (Get   k :: s -> RWST r w s m a
k))))  = RWST r w s m s
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m s
RWS.Strict.get RWST r w s m s -> (s -> RWST r w s m a) -> RWST r w s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> RWST r w s m a
k
  alg (R (R (L (Put s :: s
s k :: RWST r w s m a
k))))  = s -> RWST r w s m ()
forall w (m :: * -> *) s r.
(Monoid w, Monad m) =>
s -> RWST r w s m ()
RWS.Strict.put s
s RWST r w s m () -> RWST r w s m a -> RWST r w s m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RWST r w s m a
k
  alg (R (R (R other :: sig (RWST r w s m) a
other)))      = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWS.Strict.RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \ r :: r
r s :: s
s -> RWSTF w s a -> (a, s, w)
forall w s a. RWSTF w s a -> (a, s, w)
unRWSTF (RWSTF w s a -> (a, s, w)) -> m (RWSTF w s a) -> m (a, s, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sig m (RWSTF w s a) -> m (RWSTF w s a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (RWSTF w s ()
-> (forall x. RWSTF w s (RWST r w s m x) -> m (RWSTF w s x))
-> sig (RWST r w s m) a
-> sig m (RWSTF w s a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (((), s, w) -> RWSTF w s ()
forall w s a. (a, s, w) -> RWSTF w s a
RWSTF ((), s
s, w
forall a. Monoid a => a
mempty)) (\ (RWSTF (x :: RWST r w s m x
x, s :: s
s, w :: w
w)) -> w -> (x, s, w) -> RWSTF w s x
forall w a s. Monoid w => w -> (a, s, w) -> RWSTF w s a
toRWSTF w
w ((x, s, w) -> RWSTF w s x) -> m (x, s, w) -> m (RWSTF w s x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST r w s m x -> r -> s -> m (x, s, w)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
RWS.Strict.runRWST RWST r w s m x
x r
r s
s) sig (RWST r w s m) a
other)

instance (Algebra sig m, Effect sig) => Algebra (State s :+: sig) (State.Lazy.StateT s m) where
  alg :: (:+:) (State s) sig (StateT s m) a -> StateT s m a
alg (L (Get   k :: s -> StateT s m a
k)) = StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
State.Lazy.get StateT s m s -> (s -> StateT s m a) -> StateT s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> StateT s m a
k
  alg (L (Put s :: s
s k :: StateT s m a
k)) = s -> StateT s m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.Lazy.put s
s StateT s m () -> StateT s m a -> StateT s m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT s m a
k
  alg (R other :: sig (StateT s m) a
other)     = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.Lazy.StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \ s :: s
s -> (s, a) -> (a, s)
forall a b. (a, b) -> (b, a)
swap ((s, a) -> (a, s)) -> m (s, a) -> m (a, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sig m (s, a) -> m (s, a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg ((s, ())
-> (forall x. (s, StateT s m x) -> m (s, x))
-> sig (StateT s m) a
-> sig m (s, a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (s
s, ()) (\ (s :: s
s, x :: StateT s m x
x) -> (x, s) -> (s, x)
forall a b. (a, b) -> (b, a)
swap ((x, s) -> (s, x)) -> m (x, s) -> m (s, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT s m x -> s -> m (x, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.Lazy.runStateT StateT s m x
x s
s) sig (StateT s m) a
other)

instance (Algebra sig m, Effect sig) => Algebra (State s :+: sig) (State.Strict.StateT s m) where
  alg :: (:+:) (State s) sig (StateT s m) a -> StateT s m a
alg (L (Get   k :: s -> StateT s m a
k)) = StateT s m s
forall (m :: * -> *) s. Monad m => StateT s m s
State.Strict.get StateT s m s -> (s -> StateT s m a) -> StateT s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> StateT s m a
k
  alg (L (Put s :: s
s k :: StateT s m a
k)) = s -> StateT s m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.Strict.put s
s StateT s m () -> StateT s m a -> StateT s m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT s m a
k
  alg (R other :: sig (StateT s m) a
other)     = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.Strict.StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \ s :: s
s -> (s, a) -> (a, s)
forall a b. (a, b) -> (b, a)
swap ((s, a) -> (a, s)) -> m (s, a) -> m (a, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sig m (s, a) -> m (s, a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg ((s, ())
-> (forall x. (s, StateT s m x) -> m (s, x))
-> sig (StateT s m) a
-> sig m (s, a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (s
s, ()) (\ (s :: s
s, x :: StateT s m x
x) -> (x, s) -> (s, x)
forall a b. (a, b) -> (b, a)
swap ((x, s) -> (s, x)) -> m (x, s) -> m (s, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT s m x -> s -> m (x, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
State.Strict.runStateT StateT s m x
x s
s) sig (StateT s m) a
other)

instance (Algebra sig m, Effect sig, Monoid w) => Algebra (Writer w :+: sig) (Writer.Lazy.WriterT w m) where
  alg :: (:+:) (Writer w) sig (WriterT w m) a -> WriterT w m a
alg (L (Tell w :: w
w k :: WriterT w m a
k))     = w -> WriterT w m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.Lazy.tell w
w WriterT w m () -> WriterT w m a -> WriterT w m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriterT w m a
k
  alg (L (Listen m :: WriterT w m a
m k :: w -> a -> WriterT w m a
k))   = WriterT w m a -> WriterT w m (a, w)
forall (m :: * -> *) w a.
Monad m =>
WriterT w m a -> WriterT w m (a, w)
Writer.Lazy.listen WriterT w m a
m WriterT w m (a, w) -> ((a, w) -> WriterT w m a) -> WriterT w m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> w -> WriterT w m a) -> (a, w) -> WriterT w m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((w -> a -> WriterT w m a) -> a -> w -> WriterT w m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip w -> a -> WriterT w m a
k)
  alg (L (Censor f :: w -> w
f m :: WriterT w m a
m k :: a -> WriterT w m a
k)) = (w -> w) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) w a.
Monad m =>
(w -> w) -> WriterT w m a -> WriterT w m a
Writer.Lazy.censor w -> w
f WriterT w m a
m WriterT w m a -> (a -> WriterT w m a) -> WriterT w m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> WriterT w m a
k
  alg (R other :: sig (WriterT w m) a
other)          = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Writer.Lazy.WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ (w, a) -> (a, w)
forall a b. (a, b) -> (b, a)
swap ((w, a) -> (a, w)) -> m (w, a) -> m (a, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sig m (w, a) -> m (w, a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg ((w, ())
-> (forall x. (w, WriterT w m x) -> m (w, x))
-> sig (WriterT w m) a
-> sig m (w, a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (w
forall a. Monoid a => a
mempty, ()) (\ (s :: w
s, x :: WriterT w m x
x) -> (x, w) -> (w, x)
forall a b. (a, b) -> (b, a)
swap ((x, w) -> (w, x)) -> ((x, w) -> (x, w)) -> (x, w) -> (w, x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w -> w) -> (x, w) -> (x, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
s) ((x, w) -> (w, x)) -> m (x, w) -> m (w, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT w m x -> m (x, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Writer.Lazy.runWriterT WriterT w m x
x) sig (WriterT w m) a
other)

instance (Algebra sig m, Effect sig, Monoid w) => Algebra (Writer w :+: sig) (Writer.Strict.WriterT w m) where
  alg :: (:+:) (Writer w) sig (WriterT w m) a -> WriterT w m a
alg (L (Tell w :: w
w k :: WriterT w m a
k))     = w -> WriterT w m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.Strict.tell w
w WriterT w m () -> WriterT w m a -> WriterT w m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> WriterT w m a
k
  alg (L (Listen m :: WriterT w m a
m k :: w -> a -> WriterT w m a
k))   = WriterT w m a -> WriterT w m (a, w)
forall (m :: * -> *) w a.
Monad m =>
WriterT w m a -> WriterT w m (a, w)
Writer.Strict.listen WriterT w m a
m WriterT w m (a, w) -> ((a, w) -> WriterT w m a) -> WriterT w m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> w -> WriterT w m a) -> (a, w) -> WriterT w m a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((w -> a -> WriterT w m a) -> a -> w -> WriterT w m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip w -> a -> WriterT w m a
k)
  alg (L (Censor f :: w -> w
f m :: WriterT w m a
m k :: a -> WriterT w m a
k)) = (w -> w) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) w a.
Monad m =>
(w -> w) -> WriterT w m a -> WriterT w m a
Writer.Strict.censor w -> w
f WriterT w m a
m WriterT w m a -> (a -> WriterT w m a) -> WriterT w m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> WriterT w m a
k
  alg (R other :: sig (WriterT w m) a
other)          = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Writer.Strict.WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ (w, a) -> (a, w)
forall a b. (a, b) -> (b, a)
swap ((w, a) -> (a, w)) -> m (w, a) -> m (a, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sig m (w, a) -> m (w, a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg ((w, ())
-> (forall x. (w, WriterT w m x) -> m (w, x))
-> sig (WriterT w m) a
-> sig m (w, a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (w
forall a. Monoid a => a
mempty, ()) (\ (s :: w
s, x :: WriterT w m x
x) -> (x, w) -> (w, x)
forall a b. (a, b) -> (b, a)
swap ((x, w) -> (w, x)) -> ((x, w) -> (x, w)) -> (x, w) -> (w, x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w -> w) -> (x, w) -> (x, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
s) ((x, w) -> (w, x)) -> m (x, w) -> m (w, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT w m x -> m (x, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Writer.Strict.runWriterT WriterT w m x
x) sig (WriterT w m) a
other)