{-# LANGUAGE TupleSections #-}
module Proarrow.Promonad.Writer where

import Prelude (Monoid(..), (<>), fmap)

import Proarrow.Core (Promonad(..), Profunctor(..))
import Proarrow.Category.Monoidal (MonoidalProfunctor (..))
import Proarrow.Object.BinaryProduct ()

newtype Writer m a b = Writer { forall m a b. Writer m a b -> a -> (m, b)
getWriter :: a -> (m, b) }

instance Profunctor (Writer m) where
  dimap :: forall c a b d.
(c ~> a) -> (b ~> d) -> Writer m a b -> Writer m c d
dimap c ~> a
l b ~> d
r (Writer a -> (m, b)
f) = (c -> (m, d)) -> Writer m c d
forall m a b. (a -> (m, b)) -> Writer m a b
Writer ((b -> d) -> (m, b) -> (m, d)
forall a b. (a -> b) -> (m, a) -> (m, b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap b ~> d
b -> d
r ((m, b) -> (m, d)) -> (c -> (m, b)) -> c -> (m, d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (p :: PRO k k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. a -> (m, b)
f (a -> (m, b)) -> (c -> a) -> c -> (m, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (p :: PRO k k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. c ~> a
c -> a
l)

instance Monoid m => Promonad (Writer m) where
  id :: forall a. Ob a => Writer m a a
id = (a -> (m, a)) -> Writer m a a
forall m a b. (a -> (m, b)) -> Writer m a b
Writer (m
forall a. Monoid a => a
mempty,)
  Writer b -> (m, c)
g . :: forall b c a. Writer m b c -> Writer m a b -> Writer m a c
. Writer a -> (m, b)
f = (a -> (m, c)) -> Writer m a c
forall m a b. (a -> (m, b)) -> Writer m a b
Writer \a
a -> case a -> (m, b)
f a
a of (m
m1, b
b) -> case b -> (m, c)
g b
b of (m
m2, c
c) -> (m
m1 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
m2, c
c)

instance Monoid m => MonoidalProfunctor (Writer m) where
  lift0 :: Writer m Unit Unit
lift0 = Writer m () ()
Writer m Unit Unit
forall a. Ob a => Writer m a a
forall {k} (p :: PRO k k) (a :: k). (Promonad p, Ob a) => p a a
id
  lift2 :: forall x1 x2 y1 y2.
Writer m x1 x2 -> Writer m y1 y2 -> Writer m (x1 ** y1) (x2 ** y2)
lift2 (Writer x1 -> (m, x2)
f) (Writer y1 -> (m, y2)
g) = ((x1, y1) -> (m, (x2, y2))) -> Writer m (x1, y1) (x2, y2)
forall m a b. (a -> (m, b)) -> Writer m a b
Writer \(x1
a1, y1
a2) -> case x1 -> (m, x2)
f x1
a1 of (m
m1, x2
b1) -> case y1 -> (m, y2)
g y1
a2 of (m
m2, y2
b2) -> (m
m1 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
m2, (x2
b1, y2
b2))