module Control.Monad.Ology.Data.Prod where

import Control.Monad.Ology.Data.Param
import Control.Monad.Ology.General
import Control.Monad.Ology.Specific.WriterT
import Import

-- | A product of a monad (as in 'WriterT').
data Prod m a = MkProd
    { forall (m :: Type -> Type) a. Prod m a -> a -> m ()
prodTell :: a -> m ()
    , forall (m :: Type -> Type) a. Prod m a -> forall r. m r -> m (r, a)
prodCollect :: forall r. m r -> m (r, a)
    }

instance Functor m => Invariant (Prod m) where
    invmap :: forall a b. (a -> b) -> (b -> a) -> Prod m a -> Prod m b
invmap a -> b
f b -> a
g (MkProd a -> m ()
t forall r. m r -> m (r, a)
l) = forall (m :: Type -> Type) a.
(a -> m ()) -> (forall r. m r -> m (r, a)) -> Prod m a
MkProd (a -> m ()
t forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
g) (\m r
mr -> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall a b. (a -> b) -> a -> b
$ forall r. m r -> m (r, a)
l m r
mr)

instance Applicative m => Productable (Prod m) where
    rUnit :: Prod m ()
rUnit = forall (m :: Type -> Type) a.
(a -> m ()) -> (forall r. m r -> m (r, a)) -> Prod m a
MkProd (\() -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \r
r -> (r
r, ())
    (<***>) :: forall a b. Prod m a -> Prod m b -> Prod m (a, b)
    MkProd a -> m ()
tellA forall r. m r -> m (r, a)
collectA <***> :: forall a b. Prod m a -> Prod m b -> Prod m (a, b)
<***> MkProd b -> m ()
tellB forall r. m r -> m (r, b)
collectB = let
        tellAB :: (a, b) -> m ()
        tellAB :: (a, b) -> m ()
tellAB (a
a, b
b) = a -> m ()
tellA a
a forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> b -> m ()
tellB b
b
        collectAB :: m r -> m (r, (a, b))
        collectAB :: forall r. m r -> m (r, (a, b))
collectAB m r
m = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((r
r, a
a), b
b) -> (r
r, (a
a, b
b))) forall a b. (a -> b) -> a -> b
$ forall r. m r -> m (r, b)
collectB (forall r. m r -> m (r, a)
collectA m r
m)
        in forall (m :: Type -> Type) a.
(a -> m ()) -> (forall r. m r -> m (r, a)) -> Prod m a
MkProd (a, b) -> m ()
tellAB forall r. m r -> m (r, (a, b))
collectAB

prodCollect_ :: Functor m => Prod m a -> m () -> m a
prodCollect_ :: forall (m :: Type -> Type) a. Functor m => Prod m a -> m () -> m a
prodCollect_ Prod m a
p m ()
mu = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. Prod m a -> forall r. m r -> m (r, a)
prodCollect Prod m a
p m ()
mu

prodListen :: Monad m => Prod m a -> forall r. m r -> m (r, a)
prodListen :: forall (m :: Type -> Type) a.
Monad m =>
Prod m a -> forall r. m r -> m (r, a)
prodListen Prod m a
p m r
mr = do
    (r
r, a
a) <- forall (m :: Type -> Type) a. Prod m a -> forall r. m r -> m (r, a)
prodCollect Prod m a
p m r
mr
    forall (m :: Type -> Type) a. Prod m a -> a -> m ()
prodTell Prod m a
p a
a
    forall (m :: Type -> Type) a. Monad m => a -> m a
return (r
r, a
a)

prodListen_ :: Monad m => Prod m a -> m () -> m a
prodListen_ :: forall (m :: Type -> Type) a. Monad m => Prod m a -> m () -> m a
prodListen_ Prod m a
p m ()
mu = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a.
Monad m =>
Prod m a -> forall r. m r -> m (r, a)
prodListen Prod m a
p m ()
mu

prodPass :: Monad m => Prod m a -> m (r, a -> a) -> m r
prodPass :: forall (m :: Type -> Type) a r.
Monad m =>
Prod m a -> m (r, a -> a) -> m r
prodPass Prod m a
p m (r, a -> a)
mraa = do
    ((r
r, a -> a
f), a
a) <- forall (m :: Type -> Type) a. Prod m a -> forall r. m r -> m (r, a)
prodCollect Prod m a
p m (r, a -> a)
mraa
    forall (m :: Type -> Type) a. Prod m a -> a -> m ()
prodTell Prod m a
p forall a b. (a -> b) -> a -> b
$ a -> a
f a
a
    forall (m :: Type -> Type) a. Monad m => a -> m a
return r
r

prodCensor :: Monad m => Prod m a -> (a -> a) -> m --> m
prodCensor :: forall (m :: Type -> Type) a.
Monad m =>
Prod m a -> (a -> a) -> m --> m
prodCensor Prod m a
p a -> a
f m a
mr = do
    (a
r, a
a) <- forall (m :: Type -> Type) a. Prod m a -> forall r. m r -> m (r, a)
prodCollect Prod m a
p m a
mr
    forall (m :: Type -> Type) a. Prod m a -> a -> m ()
prodTell Prod m a
p forall a b. (a -> b) -> a -> b
$ a -> a
f a
a
    forall (m :: Type -> Type) a. Monad m => a -> m a
return a
r

prodTellItem :: Applicative f => Prod m (f a) -> a -> m ()
prodTellItem :: forall (f :: Type -> Type) (m :: Type -> Type) a.
Applicative f =>
Prod m (f a) -> a -> m ()
prodTellItem Prod m (f a)
p a
a = forall (m :: Type -> Type) a. Prod m a -> a -> m ()
prodTell Prod m (f a)
p forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a

prodCensorItems :: (Monad f, Monad m) => Prod m (f a) -> (a -> f a) -> m --> m
prodCensorItems :: forall (f :: Type -> Type) (m :: Type -> Type) a.
(Monad f, Monad m) =>
Prod m (f a) -> (a -> f a) -> m --> m
prodCensorItems Prod m (f a)
p a -> f a
afa = forall (m :: Type -> Type) a.
Monad m =>
Prod m a -> (a -> a) -> m --> m
prodCensor Prod m (f a)
p forall a b. (a -> b) -> a -> b
$ \f a
fa -> f a
fa forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> f a
afa

lensMapProd ::
       forall m a b. (Monad m, Monoid a, Monoid b)
    => Lens' a b
    -> Prod m a
    -> Prod m b
lensMapProd :: forall (m :: Type -> Type) a b.
(Monad m, Monoid a, Monoid b) =>
Lens' a b -> Prod m a -> Prod m b
lensMapProd Lens' a b
l Prod m a
p = let
    prodTell' :: b -> m ()
    prodTell' :: b -> m ()
prodTell' b
b = forall (m :: Type -> Type) a. Prod m a -> a -> m ()
prodTell Prod m a
p forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ Lens' a b
l (\b
_ -> forall a. a -> Identity a
Identity b
b) forall a. Monoid a => a
mempty
    prodCollect' :: forall r. m r -> m (r, b)
    prodCollect' :: forall r. m r -> m (r, b)
prodCollect' m r
mr = do
        (r
r, a
a) <- forall (m :: Type -> Type) a. Prod m a -> forall r. m r -> m (r, a)
prodCollect Prod m a
p m r
mr
        forall (m :: Type -> Type) a. Prod m a -> a -> m ()
prodTell Prod m a
p forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ Lens' a b
l (\b
_ -> forall a. a -> Identity a
Identity forall a. Monoid a => a
mempty) a
a
        forall (m :: Type -> Type) a. Monad m => a -> m a
return (r
r, forall {k} a (b :: k). Const a b -> a
getConst forall a b. (a -> b) -> a -> b
$ Lens' a b
l forall {k} a (b :: k). a -> Const a b
Const a
a)
    in forall (m :: Type -> Type) a.
(a -> m ()) -> (forall r. m r -> m (r, a)) -> Prod m a
MkProd b -> m ()
prodTell' forall r. m r -> m (r, b)
prodCollect'

liftProd :: (MonadTransTunnel t, Monad m) => Prod m --> Prod (t m)
liftProd :: forall (t :: TransKind) (m :: Type -> Type).
(MonadTransTunnel t, Monad m) =>
Prod m --> Prod (t m)
liftProd (MkProd a -> m ()
t forall r. m r -> m (r, a)
l) =
    forall (m :: Type -> Type) a.
(a -> m ()) -> (forall r. m r -> m (r, a)) -> Prod m a
MkProd (\a
a -> forall (t :: TransKind) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ a -> m ()
t a
a) forall a b. (a -> b) -> a -> b
$ \t m r
tmr -> forall (t :: TransKind) (m :: Type -> Type) r.
(MonadTransTunnel t, Monad m) =>
((forall (m1 :: Type -> Type) a.
  Monad m1 =>
  t m1 a -> m1 (Tunnel t a))
 -> m (Tunnel t r))
-> t m r
tunnel forall a b. (a -> b) -> a -> b
$ \forall (m1 :: Type -> Type) a.
Monad m1 =>
t m1 a -> m1 (Tunnel t a)
unlift -> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Tunnel t r
tun, a
a) -> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\r
r -> (r
r, a
a)) Tunnel t r
tun) forall a b. (a -> b) -> a -> b
$ forall r. m r -> m (r, a)
l forall a b. (a -> b) -> a -> b
$ forall (m1 :: Type -> Type) a.
Monad m1 =>
t m1 a -> m1 (Tunnel t a)
unlift t m r
tmr

writerProd :: (Monad m, Monoid w) => Prod (WriterT w m) w
writerProd :: forall (m :: Type -> Type) w.
(Monad m, Monoid w) =>
Prod (WriterT w m) w
writerProd = MkProd {prodTell :: w -> WriterT w m ()
prodTell = forall (m :: Type -> Type) w. Monad m => w -> WriterT w m ()
tell, prodCollect :: forall r. WriterT w m r -> WriterT w m (r, w)
prodCollect = forall (m :: Type -> Type) w a.
(Monad m, Monoid w) =>
WriterT w m a -> WriterT w m (a, w)
collect}

foldProd ::
       forall f m a. (Applicative f, Foldable f, Applicative m)
    => Prod m a
    -> Prod m (f a)
foldProd :: forall (f :: Type -> Type) (m :: Type -> Type) a.
(Applicative f, Foldable f, Applicative m) =>
Prod m a -> Prod m (f a)
foldProd (MkProd a -> m ()
prodTell forall r. m r -> m (r, a)
prodCollect) = let
    prodTell' :: f a -> m ()
    prodTell' :: f a -> m ()
prodTell' f a
aa = forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ f a
aa a -> m ()
prodTell
    prodCollect' :: forall r. m r -> m (r, f a)
    prodCollect' :: forall r. m r -> m (r, f a)
prodCollect' m r
mr = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(r
r, a
a) -> (r
r, forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a)) forall a b. (a -> b) -> a -> b
$ forall r. m r -> m (r, a)
prodCollect m r
mr
    in forall (m :: Type -> Type) a.
(a -> m ()) -> (forall r. m r -> m (r, a)) -> Prod m a
MkProd f a -> m ()
prodTell' forall r. m r -> m (r, f a)
prodCollect'