{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GADTs #-}

-- | A Writer carrier that discards any values it is told

module MonadicBang.Internal.Effect.Writer.Discard where

import Control.Algebra
import Control.Effect.Writer

newtype DiscardC w m a = DiscardC { forall {k} {k} (w :: k) (m :: k -> *) (a :: k).
DiscardC w m a -> m a
evalDiscardC :: m a }
  deriving newtype ((forall a b. (a -> b) -> DiscardC w m a -> DiscardC w m b)
-> (forall a b. a -> DiscardC w m b -> DiscardC w m a)
-> Functor (DiscardC w m)
forall k (w :: k) (m :: * -> *) a b.
Functor m =>
a -> DiscardC w m b -> DiscardC w m a
forall k (w :: k) (m :: * -> *) a b.
Functor m =>
(a -> b) -> DiscardC w m a -> DiscardC w m b
forall a b. a -> DiscardC w m b -> DiscardC w m a
forall a b. (a -> b) -> DiscardC w m a -> DiscardC w m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall k (w :: k) (m :: * -> *) a b.
Functor m =>
(a -> b) -> DiscardC w m a -> DiscardC w m b
fmap :: forall a b. (a -> b) -> DiscardC w m a -> DiscardC w m b
$c<$ :: forall k (w :: k) (m :: * -> *) a b.
Functor m =>
a -> DiscardC w m b -> DiscardC w m a
<$ :: forall a b. a -> DiscardC w m b -> DiscardC w m a
Functor, Functor (DiscardC w m)
Functor (DiscardC w m) =>
(forall a. a -> DiscardC w m a)
-> (forall a b.
    DiscardC w m (a -> b) -> DiscardC w m a -> DiscardC w m b)
-> (forall a b c.
    (a -> b -> c)
    -> DiscardC w m a -> DiscardC w m b -> DiscardC w m c)
-> (forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m b)
-> (forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m a)
-> Applicative (DiscardC w m)
forall a. a -> DiscardC w m a
forall k (w :: k) (m :: * -> *).
Applicative m =>
Functor (DiscardC w m)
forall k (w :: k) (m :: * -> *) a.
Applicative m =>
a -> DiscardC w m a
forall k (w :: k) (m :: * -> *) a b.
Applicative m =>
DiscardC w m a -> DiscardC w m b -> DiscardC w m a
forall k (w :: k) (m :: * -> *) a b.
Applicative m =>
DiscardC w m a -> DiscardC w m b -> DiscardC w m b
forall k (w :: k) (m :: * -> *) a b.
Applicative m =>
DiscardC w m (a -> b) -> DiscardC w m a -> DiscardC w m b
forall k (w :: k) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> DiscardC w m a -> DiscardC w m b -> DiscardC w m c
forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m a
forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m b
forall a b.
DiscardC w m (a -> b) -> DiscardC w m a -> DiscardC w m b
forall a b c.
(a -> b -> c) -> DiscardC w m a -> DiscardC w m b -> DiscardC w 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
$cpure :: forall k (w :: k) (m :: * -> *) a.
Applicative m =>
a -> DiscardC w m a
pure :: forall a. a -> DiscardC w m a
$c<*> :: forall k (w :: k) (m :: * -> *) a b.
Applicative m =>
DiscardC w m (a -> b) -> DiscardC w m a -> DiscardC w m b
<*> :: forall a b.
DiscardC w m (a -> b) -> DiscardC w m a -> DiscardC w m b
$cliftA2 :: forall k (w :: k) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> DiscardC w m a -> DiscardC w m b -> DiscardC w m c
liftA2 :: forall a b c.
(a -> b -> c) -> DiscardC w m a -> DiscardC w m b -> DiscardC w m c
$c*> :: forall k (w :: k) (m :: * -> *) a b.
Applicative m =>
DiscardC w m a -> DiscardC w m b -> DiscardC w m b
*> :: forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m b
$c<* :: forall k (w :: k) (m :: * -> *) a b.
Applicative m =>
DiscardC w m a -> DiscardC w m b -> DiscardC w m a
<* :: forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m a
Applicative, Applicative (DiscardC w m)
Applicative (DiscardC w m) =>
(forall a b.
 DiscardC w m a -> (a -> DiscardC w m b) -> DiscardC w m b)
-> (forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m b)
-> (forall a. a -> DiscardC w m a)
-> Monad (DiscardC w m)
forall a. a -> DiscardC w m a
forall k (w :: k) (m :: * -> *).
Monad m =>
Applicative (DiscardC w m)
forall k (w :: k) (m :: * -> *) a. Monad m => a -> DiscardC w m a
forall k (w :: k) (m :: * -> *) a b.
Monad m =>
DiscardC w m a -> DiscardC w m b -> DiscardC w m b
forall k (w :: k) (m :: * -> *) a b.
Monad m =>
DiscardC w m a -> (a -> DiscardC w m b) -> DiscardC w m b
forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m b
forall a b.
DiscardC w m a -> (a -> DiscardC w m b) -> DiscardC w 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
$c>>= :: forall k (w :: k) (m :: * -> *) a b.
Monad m =>
DiscardC w m a -> (a -> DiscardC w m b) -> DiscardC w m b
>>= :: forall a b.
DiscardC w m a -> (a -> DiscardC w m b) -> DiscardC w m b
$c>> :: forall k (w :: k) (m :: * -> *) a b.
Monad m =>
DiscardC w m a -> DiscardC w m b -> DiscardC w m b
>> :: forall a b. DiscardC w m a -> DiscardC w m b -> DiscardC w m b
$creturn :: forall k (w :: k) (m :: * -> *) a. Monad m => a -> DiscardC w m a
return :: forall a. a -> DiscardC w m a
Monad)

evalWriter :: (Monoid w, Algebra sig m) => DiscardC w m a -> m a
evalWriter :: forall w (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Monoid w, Algebra sig m) =>
DiscardC w m a -> m a
evalWriter = DiscardC w m a -> m a
forall {k} {k} (w :: k) (m :: k -> *) (a :: k).
DiscardC w m a -> m a
evalDiscardC

instance (Monoid w, Algebra sig m) => Algebra (Writer w :+: sig) (DiscardC w m) where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (DiscardC w m)
-> (:+:) (Writer w) sig n a -> ctx () -> DiscardC w m (ctx a)
alg Handler ctx n (DiscardC w m)
hdl (:+:) (Writer w) sig n a
sig ctx ()
ctx = m (ctx a) -> DiscardC w m (ctx a)
forall {k} {k} (w :: k) (m :: k -> *) (a :: k).
m a -> DiscardC w m a
DiscardC (m (ctx a) -> DiscardC w m (ctx a))
-> m (ctx a) -> DiscardC w m (ctx a)
forall a b. (a -> b) -> a -> b
$ case (:+:) (Writer w) sig n a
sig of
    L Writer w n a
writer -> case Writer w n a
writer of
      Tell w
_ -> ctx a -> m (ctx a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ctx a
ctx ()
ctx
      Listen n a
m -> (a -> a) -> ctx a -> ctx a
forall a b. (a -> b) -> ctx a -> ctx b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w
forall a. Monoid a => a
mempty,) (ctx a -> ctx a) -> m (ctx a) -> m (ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiscardC w m (ctx a) -> m (ctx a)
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Monoid w, Algebra sig m) =>
DiscardC w m a -> m a
evalWriter (ctx (n a) -> DiscardC w m (ctx a)
Handler ctx n (DiscardC w m)
hdl (n a
m n a -> ctx () -> ctx (n a)
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx))
      Censor w -> w
_ n a
m -> DiscardC w m (ctx a) -> m (ctx a)
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Monoid w, Algebra sig m) =>
DiscardC w m a -> m a
evalWriter (ctx (n a) -> DiscardC w m (ctx a)
Handler ctx n (DiscardC w m)
hdl (n a
m n a -> ctx () -> ctx (n a)
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx))
    R sig n a
other -> Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (ctx :: * -> *)
       (n :: * -> *) a.
(Algebra sig m, Functor ctx) =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
alg (DiscardC w m (ctx x) -> m (ctx x)
forall {k} {k} (w :: k) (m :: k -> *) (a :: k).
DiscardC w m a -> m a
evalDiscardC (DiscardC w m (ctx x) -> m (ctx x))
-> (ctx (n x) -> DiscardC w m (ctx x)) -> ctx (n x) -> m (ctx x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx (n x) -> DiscardC w m (ctx x)
Handler ctx n (DiscardC w m)
hdl) sig n a
other ctx ()
ctx