{-# LANGUAGE CPP #-}
module Control.Effect.Type.ListenPrim
(
ListenPrim(..)
, threadListenPrim
, threadListenPrimViaClass
) where
import Control.Monad.Trans
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Except (ExceptT)
import qualified Control.Monad.Trans.State.Strict as SSt
import qualified Control.Monad.Trans.State.Lazy as LSt
import qualified Control.Monad.Trans.Writer.Lazy as LWr
import qualified Control.Monad.Trans.Writer.Strict as SWr
import qualified Control.Monad.Trans.Writer.CPS as CPSWr
import Control.Monad.Writer.Class
import Control.Effect.Internal.ViaAlg
import Control.Effect.Internal.Reflection
import Control.Effect.Internal.Union
data ListenPrim w m a where
ListenPrimTell :: w -> ListenPrim w m ()
ListenPrimListen :: m a -> ListenPrim w m (w, a)
threadListenPrim :: forall w t m a
. (MonadTrans t, Monad m)
=> ( forall x
. (forall y. ListenPrim w m y -> m y)
-> t m x -> t m (w, x)
)
-> (forall x. ListenPrim w m x -> m x)
-> ListenPrim w (t m) a -> t m a
threadListenPrim h alg = \case
ListenPrimTell w -> lift (alg (ListenPrimTell w))
ListenPrimListen m -> h alg m
{-# INLINE threadListenPrim #-}
instance ( Reifies s (ReifiedEffAlgebra (ListenPrim w) m)
, Monoid w
, Monad m
)
=> MonadWriter w (ViaAlg s (ListenPrim w) m) where
tell w = case reflect @s of
ReifiedEffAlgebra alg -> coerceAlg alg (ListenPrimTell w)
pass = error "threadListenPrimViaClass: Transformers threading ListenPrim \
\are not allowed to use pass."
listen m = case reflect @s of
ReifiedEffAlgebra alg ->
fmap (\(s, a) -> (a, s)) $ coerceAlg alg (ListenPrimListen m)
{-# INLINE listen #-}
threadListenPrimViaClass :: forall w t m a
. (Monoid w, Monad m)
=> ( RepresentationalT t
, MonadTrans t
, forall b. MonadWriter w b => MonadWriter w (t b)
)
=> (forall x. ListenPrim w m x -> m x)
-> ListenPrim w (t m) a -> t m a
threadListenPrimViaClass alg = \case
ListenPrimTell w -> lift $ alg (ListenPrimTell w)
ListenPrimListen m ->
reify (ReifiedEffAlgebra alg) $ \(_ :: pr s) ->
unViaAlgT
$ fmap (\(a, s) -> (s, a))
$ listen
$ viaAlgT @s @(ListenPrim w) m
{-# INLINE threadListenPrimViaClass #-}
#define THREAD_LISTENPRIM(monadT) \
instance Monoid threadedMonoid \
=> ThreadsEff (monadT) (ListenPrim threadedMonoid) where \
threadEff = threadListenPrimViaClass; \
{-# INLINE threadEff #-}
THREAD_LISTENPRIM(ReaderT i)
THREAD_LISTENPRIM(ExceptT e)
THREAD_LISTENPRIM(LSt.StateT s)
THREAD_LISTENPRIM(SSt.StateT s)
instance Monoid s => ThreadsEff (LWr.WriterT s) (ListenPrim w) where
threadEff = threadListenPrim $ \alg m ->
LWr.WriterT
$ fmap (\(s, (a, w)) -> ((s, a), w))
$ alg
$ ListenPrimListen
$ LWr.runWriterT m
{-# INLINE threadEff #-}
instance Monoid s => ThreadsEff (SWr.WriterT s) (ListenPrim w) where
threadEff = threadListenPrim $ \alg m ->
SWr.WriterT
$ fmap (\(s, (a, w)) -> ((s, a), w))
$ alg
$ ListenPrimListen
$ SWr.runWriterT m
{-# INLINE threadEff #-}
instance Monoid s => ThreadsEff (CPSWr.WriterT s) (ListenPrim w) where
threadEff = threadListenPrim $ \alg m ->
CPSWr.writerT
$ fmap (\(s, (a, w)) -> ((s, a), w))
$ alg
$ ListenPrimListen
$ CPSWr.runWriterT m
{-# INLINE threadEff #-}