{-# LANGUAGE CPP #-}
module Control.Effect.Type.ListenPrim
  ( -- * Effects

    ListenPrim(..)

    -- * Threading utilities

  , 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

-- | A primitive effect that may be used for

-- interpreters of connected 'Control.Effect.Writer.Tell' and

-- 'Control.Effect.Writer.Listen' effects.

--

-- This combines 'Control.Effect.Writer.Tell' and

-- 'Control.Effect.Writer.Listen'. This may be relevant if there

-- are monad transformers that may only lift

-- 'Control.Effect.Writer.listen' if they also have access to

-- 'Control.Effect.Writer.tell'.

--

-- __'ListenPrim' is only used as a primitive effect.__

-- If you define a 'Control.Effect.Carrier' that relies on a novel

-- non-trivial monad transformer @t@, then you need to make

-- a @'Monoid' o => 'ThreadsEff' t ('ListenPrim' o)@ instance (if possible).

-- 'threadListenPrim' and 'threadListenPrimViaClass' can help you with that.

--

-- The following threading constraints accept 'ListenPrim':

--

-- * 'Control.Effect.ReaderThreads'

-- * 'Control.Effect.State.StateThreads'

-- * 'Control.Effect.State.StateLazyThreads'

-- * 'Control.Effect.Error.ErrorThreads'

-- * 'Control.Effect.Writer.WriterThreads'

-- * 'Control.Effect.Writer.WriterLazyThreads'

-- * 'Control.Effect.NonDet.NonDetThreads'

-- * 'Control.Effect.Stepped.SteppedThreads'

-- * 'Control.Effect.Cont.ContThreads'

data ListenPrim o :: Effect where
  ListenPrimTell   :: o -> ListenPrim o m ()
  ListenPrimListen :: m a -> ListenPrim o m (o, a)

-- | Construct a valid definition of 'threadEff' for a

-- @'ThreadsEff' t ('ListenPrim' o)@ instance

-- only be specifying how 'ListenPrimListen' should be lifted.

--

-- This uses 'lift' to lift 'ListenPrimTell'.

threadListenPrim :: forall o t m a
                  . (MonadTrans t, Monad m)
                 => ( forall x
                     . (forall y. ListenPrim o m y -> m y)
                    -> t m x -> t m (o, x)
                    )
                 -> (forall x. ListenPrim o m x -> m x)
                 -> ListenPrim o (t m) a -> t m a
threadListenPrim :: (forall x.
 (forall y. ListenPrim o m y -> m y) -> t m x -> t m (o, x))
-> (forall y. ListenPrim o m y -> m y)
-> ListenPrim o (t m) a
-> t m a
threadListenPrim forall x.
(forall y. ListenPrim o m y -> m y) -> t m x -> t m (o, x)
h forall y. ListenPrim o m y -> m y
alg = \case
  ListenPrimTell o
o   -> m () -> t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ListenPrim o m () -> m ()
forall y. ListenPrim o m y -> m y
alg (o -> ListenPrim o m ()
forall o (m :: * -> *). o -> ListenPrim o m ()
ListenPrimTell o
o))
  ListenPrimListen t m a
m -> (forall y. ListenPrim o m y -> m y) -> t m a -> t m (o, a)
forall x.
(forall y. ListenPrim o m y -> m y) -> t m x -> t m (o, x)
h forall y. ListenPrim o m y -> m y
alg t m a
m
{-# INLINE threadListenPrim #-}

instance ( Reifies s (ReifiedEffAlgebra (ListenPrim o) m)
         , Monoid o
         , Monad m
         )
      => MonadWriter o (ViaAlg s (ListenPrim o) m) where
  tell :: o -> ViaAlg s (ListenPrim o) m ()
tell o
o = case forall a. Reifies s a => a
forall k (s :: k) a. Reifies s a => a
reflect @s of
    ReifiedEffAlgebra forall x. ListenPrim o m x -> m x
alg -> (ListenPrim o m () -> m ())
-> ListenPrim o (ViaAlg s (ListenPrim o) m) ()
-> ViaAlg s (ListenPrim o) m ()
forall (n :: * -> *) (m :: * -> *) (e :: (* -> *) -> * -> *) a b.
(Coercible n m, RepresentationalEff e) =>
(e m a -> m b) -> e n a -> n b
coerceAlg ListenPrim o m () -> m ()
forall x. ListenPrim o m x -> m x
alg (o -> ListenPrim o (ViaAlg s (ListenPrim o) m) ()
forall o (m :: * -> *). o -> ListenPrim o m ()
ListenPrimTell o
o)

  pass :: ViaAlg s (ListenPrim o) m (a, o -> o)
-> ViaAlg s (ListenPrim o) m a
pass = [Char]
-> ViaAlg s (ListenPrim o) m (a, o -> o)
-> ViaAlg s (ListenPrim o) m a
forall a. HasCallStack => [Char] -> a
error "threadListenPrimViaClass: Transformers threading ListenPrim \
                 \are not allowed to use pass."

  listen :: ViaAlg s (ListenPrim o) m a -> ViaAlg s (ListenPrim o) m (a, o)
listen ViaAlg s (ListenPrim o) m a
m = case forall a. Reifies s a => a
forall k (s :: k) a. Reifies s a => a
reflect @s of
    ReifiedEffAlgebra forall x. ListenPrim o m x -> m x
alg ->
      ((o, a) -> (a, o))
-> ViaAlg s (ListenPrim o) m (o, a)
-> ViaAlg s (ListenPrim o) m (a, o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(o
s, a
a) -> (a
a, o
s)) (ViaAlg s (ListenPrim o) m (o, a)
 -> ViaAlg s (ListenPrim o) m (a, o))
-> ViaAlg s (ListenPrim o) m (o, a)
-> ViaAlg s (ListenPrim o) m (a, o)
forall a b. (a -> b) -> a -> b
$ (ListenPrim o m (o, a) -> m (o, a))
-> ListenPrim o (ViaAlg s (ListenPrim o) m) (o, a)
-> ViaAlg s (ListenPrim o) m (o, a)
forall (n :: * -> *) (m :: * -> *) (e :: (* -> *) -> * -> *) a b.
(Coercible n m, RepresentationalEff e) =>
(e m a -> m b) -> e n a -> n b
coerceAlg ListenPrim o m (o, a) -> m (o, a)
forall x. ListenPrim o m x -> m x
alg (ViaAlg s (ListenPrim o) m a
-> ListenPrim o (ViaAlg s (ListenPrim o) m) (o, a)
forall (m :: * -> *) a o. m a -> ListenPrim o m (o, a)
ListenPrimListen ViaAlg s (ListenPrim o) m a
m)
  {-# INLINE listen #-}

-- | A valid definition of 'threadEff' for a @'ThreadsEff' t ('ListenPrim' o)@

-- instance, given that @t@ lifts @'MonadWriter' w@.

--

-- __BEWARE__: 'threadListenPrimViaClass' is only safe if the implementation of

-- 'listen' for @t m@ only makes use of 'listen' and 'tell' for @m@, and not

-- 'pass'.

threadListenPrimViaClass :: forall o t m a
                          . (Monoid o, Monad m)
                         => ( RepresentationalT t
                            , MonadTrans t
                            , forall b. MonadWriter o b => MonadWriter o (t b)
                            )
                         => (forall x. ListenPrim o m x -> m x)
                         -> ListenPrim o (t m) a -> t m a
threadListenPrimViaClass :: (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (t m) a -> t m a
threadListenPrimViaClass forall x. ListenPrim o m x -> m x
alg = \case
  ListenPrimTell o
o -> m () -> t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> m () -> t m ()
forall a b. (a -> b) -> a -> b
$ ListenPrim o m () -> m ()
forall x. ListenPrim o m x -> m x
alg (o -> ListenPrim o m ()
forall o (m :: * -> *). o -> ListenPrim o m ()
ListenPrimTell o
o)
  ListenPrimListen t m a
m ->
    ReifiedEffAlgebra (ListenPrim o) m
-> (forall s (pr :: * -> *).
    (pr ~ Proxy, Reifies s (ReifiedEffAlgebra (ListenPrim o) m)) =>
    pr s -> t m a)
-> t m a
forall a r.
a
-> (forall s (pr :: * -> *).
    (pr ~ Proxy, Reifies s a) =>
    pr s -> r)
-> r
reify ((forall x. ListenPrim o m x -> m x)
-> ReifiedEffAlgebra (ListenPrim o) m
forall k (e :: (k -> *) -> k -> *) (m :: k -> *).
(forall (x :: k). e m x -> m x) -> ReifiedEffAlgebra e m
ReifiedEffAlgebra forall x. ListenPrim o m x -> m x
alg) ((forall s (pr :: * -> *).
  (pr ~ Proxy, Reifies s (ReifiedEffAlgebra (ListenPrim o) m)) =>
  pr s -> t m a)
 -> t m a)
-> (forall s (pr :: * -> *).
    (pr ~ Proxy, Reifies s (ReifiedEffAlgebra (ListenPrim o) m)) =>
    pr s -> t m a)
-> t m a
forall a b. (a -> b) -> a -> b
$ \(pr s
_ :: pr s) ->
        t (ViaAlg s (ListenPrim o) m) (o, a) -> t m (o, a)
forall s (e :: (* -> *) -> * -> *) (t :: (* -> *) -> * -> *)
       (m :: * -> *) a.
RepresentationalT t =>
t (ViaAlg s e m) a -> t m a
unViaAlgT
      (t (ViaAlg s (ListenPrim o) m) (o, a) -> t m (o, a))
-> t (ViaAlg s (ListenPrim o) m) (o, a) -> t m (o, a)
forall a b. (a -> b) -> a -> b
$ ((a, o) -> (o, a))
-> t (ViaAlg s (ListenPrim o) m) (a, o)
-> t (ViaAlg s (ListenPrim o) m) (o, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
a, o
o) -> (o
o, a
a))
      (t (ViaAlg s (ListenPrim o) m) (a, o)
 -> t (ViaAlg s (ListenPrim o) m) (o, a))
-> t (ViaAlg s (ListenPrim o) m) (a, o)
-> t (ViaAlg s (ListenPrim o) m) (o, a)
forall a b. (a -> b) -> a -> b
$ t (ViaAlg s (ListenPrim o) m) a
-> t (ViaAlg s (ListenPrim o) m) (a, o)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      (t (ViaAlg s (ListenPrim o) m) a
 -> t (ViaAlg s (ListenPrim o) m) (a, o))
-> t (ViaAlg s (ListenPrim o) m) a
-> t (ViaAlg s (ListenPrim o) m) (a, o)
forall a b. (a -> b) -> a -> b
$ t m a -> t (ViaAlg s (ListenPrim o) m) a
forall s (e :: (* -> *) -> * -> *) (t :: (* -> *) -> * -> *)
       (m :: * -> *) a.
RepresentationalT t =>
t m a -> t (ViaAlg s e m) a
viaAlgT @s @(ListenPrim o) t m a
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 o) where
  threadEff :: (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a -> WriterT s m a
threadEff = (forall x.
 (forall x. ListenPrim o m x -> m x)
 -> WriterT s m x -> WriterT s m (o, x))
-> (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a
-> WriterT s m a
forall o (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
(forall x.
 (forall y. ListenPrim o m y -> m y) -> t m x -> t m (o, x))
-> (forall y. ListenPrim o m y -> m y)
-> ListenPrim o (t m) a
-> t m a
threadListenPrim ((forall x.
  (forall x. ListenPrim o m x -> m x)
  -> WriterT s m x -> WriterT s m (o, x))
 -> (forall x. ListenPrim o m x -> m x)
 -> ListenPrim o (WriterT s m) a
 -> WriterT s m a)
-> (forall x.
    (forall x. ListenPrim o m x -> m x)
    -> WriterT s m x -> WriterT s m (o, x))
-> (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a
-> WriterT s m a
forall a b. (a -> b) -> a -> b
$ \forall x. ListenPrim o m x -> m x
alg WriterT s m x
m ->
      m ((o, x), s) -> WriterT s m (o, x)
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
LWr.WriterT
    (m ((o, x), s) -> WriterT s m (o, x))
-> m ((o, x), s) -> WriterT s m (o, x)
forall a b. (a -> b) -> a -> b
$ ((o, (x, s)) -> ((o, x), s)) -> m (o, (x, s)) -> m ((o, x), s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(o
s, (x
a, s
o)) -> ((o
s, x
a), s
o))
    (m (o, (x, s)) -> m ((o, x), s)) -> m (o, (x, s)) -> m ((o, x), s)
forall a b. (a -> b) -> a -> b
$ ListenPrim o m (o, (x, s)) -> m (o, (x, s))
forall x. ListenPrim o m x -> m x
alg
    (ListenPrim o m (o, (x, s)) -> m (o, (x, s)))
-> ListenPrim o m (o, (x, s)) -> m (o, (x, s))
forall a b. (a -> b) -> a -> b
$ m (x, s) -> ListenPrim o m (o, (x, s))
forall (m :: * -> *) a o. m a -> ListenPrim o m (o, a)
ListenPrimListen
    (m (x, s) -> ListenPrim o m (o, (x, s)))
-> m (x, s) -> ListenPrim o m (o, (x, s))
forall a b. (a -> b) -> a -> b
$ WriterT s m x -> m (x, s)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
LWr.runWriterT WriterT s m x
m
  {-# INLINE threadEff #-}

instance Monoid s => ThreadsEff (SWr.WriterT s) (ListenPrim o) where
  threadEff :: (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a -> WriterT s m a
threadEff = (forall x.
 (forall x. ListenPrim o m x -> m x)
 -> WriterT s m x -> WriterT s m (o, x))
-> (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a
-> WriterT s m a
forall o (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
(forall x.
 (forall y. ListenPrim o m y -> m y) -> t m x -> t m (o, x))
-> (forall y. ListenPrim o m y -> m y)
-> ListenPrim o (t m) a
-> t m a
threadListenPrim ((forall x.
  (forall x. ListenPrim o m x -> m x)
  -> WriterT s m x -> WriterT s m (o, x))
 -> (forall x. ListenPrim o m x -> m x)
 -> ListenPrim o (WriterT s m) a
 -> WriterT s m a)
-> (forall x.
    (forall x. ListenPrim o m x -> m x)
    -> WriterT s m x -> WriterT s m (o, x))
-> (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a
-> WriterT s m a
forall a b. (a -> b) -> a -> b
$ \forall x. ListenPrim o m x -> m x
alg WriterT s m x
m ->
      m ((o, x), s) -> WriterT s m (o, x)
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
SWr.WriterT
    (m ((o, x), s) -> WriterT s m (o, x))
-> m ((o, x), s) -> WriterT s m (o, x)
forall a b. (a -> b) -> a -> b
$ ((o, (x, s)) -> ((o, x), s)) -> m (o, (x, s)) -> m ((o, x), s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(o
s, (x
a, s
o)) -> ((o
s, x
a), s
o))
    (m (o, (x, s)) -> m ((o, x), s)) -> m (o, (x, s)) -> m ((o, x), s)
forall a b. (a -> b) -> a -> b
$ ListenPrim o m (o, (x, s)) -> m (o, (x, s))
forall x. ListenPrim o m x -> m x
alg
    (ListenPrim o m (o, (x, s)) -> m (o, (x, s)))
-> ListenPrim o m (o, (x, s)) -> m (o, (x, s))
forall a b. (a -> b) -> a -> b
$ m (x, s) -> ListenPrim o m (o, (x, s))
forall (m :: * -> *) a o. m a -> ListenPrim o m (o, a)
ListenPrimListen
    (m (x, s) -> ListenPrim o m (o, (x, s)))
-> m (x, s) -> ListenPrim o m (o, (x, s))
forall a b. (a -> b) -> a -> b
$ WriterT s m x -> m (x, s)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
SWr.runWriterT WriterT s m x
m
  {-# INLINE threadEff #-}

instance Monoid s => ThreadsEff (CPSWr.WriterT s) (ListenPrim o) where
  threadEff :: (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a -> WriterT s m a
threadEff = (forall x.
 (forall x. ListenPrim o m x -> m x)
 -> WriterT s m x -> WriterT s m (o, x))
-> (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a
-> WriterT s m a
forall o (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
(forall x.
 (forall y. ListenPrim o m y -> m y) -> t m x -> t m (o, x))
-> (forall y. ListenPrim o m y -> m y)
-> ListenPrim o (t m) a
-> t m a
threadListenPrim ((forall x.
  (forall x. ListenPrim o m x -> m x)
  -> WriterT s m x -> WriterT s m (o, x))
 -> (forall x. ListenPrim o m x -> m x)
 -> ListenPrim o (WriterT s m) a
 -> WriterT s m a)
-> (forall x.
    (forall x. ListenPrim o m x -> m x)
    -> WriterT s m x -> WriterT s m (o, x))
-> (forall x. ListenPrim o m x -> m x)
-> ListenPrim o (WriterT s m) a
-> WriterT s m a
forall a b. (a -> b) -> a -> b
$ \forall x. ListenPrim o m x -> m x
alg WriterT s m x
m ->
      m ((o, x), s) -> WriterT s m (o, x)
forall (m :: * -> *) w a.
(Functor m, Monoid w) =>
m (a, w) -> WriterT w m a
CPSWr.writerT
    (m ((o, x), s) -> WriterT s m (o, x))
-> m ((o, x), s) -> WriterT s m (o, x)
forall a b. (a -> b) -> a -> b
$ ((o, (x, s)) -> ((o, x), s)) -> m (o, (x, s)) -> m ((o, x), s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(o
s, (x
a, s
o)) -> ((o
s, x
a), s
o))
    (m (o, (x, s)) -> m ((o, x), s)) -> m (o, (x, s)) -> m ((o, x), s)
forall a b. (a -> b) -> a -> b
$ ListenPrim o m (o, (x, s)) -> m (o, (x, s))
forall x. ListenPrim o m x -> m x
alg
    (ListenPrim o m (o, (x, s)) -> m (o, (x, s)))
-> ListenPrim o m (o, (x, s)) -> m (o, (x, s))
forall a b. (a -> b) -> a -> b
$ m (x, s) -> ListenPrim o m (o, (x, s))
forall (m :: * -> *) a o. m a -> ListenPrim o m (o, a)
ListenPrimListen
    (m (x, s) -> ListenPrim o m (o, (x, s)))
-> m (x, s) -> ListenPrim o m (o, (x, s))
forall a b. (a -> b) -> a -> b
$ WriterT s m x -> m (x, s)
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
CPSWr.runWriterT WriterT s m x
m
  {-# INLINE threadEff #-}