{-# LANGUAGE TupleSections #-}

module Proarrow.Promonad.Writer where

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

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

newtype Writer m a b = Writer {forall m a b. Writer m a b -> a -> (m, b)
unWriter :: 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 Procomonad (Writer m) where
  extract :: Writer m :~> (~>)
extract (Writer a -> (m, b)
f) = (m, b) -> b
forall a b. (a, b) -> b
snd ((m, b) -> b) -> (a -> (m, b)) -> a -> 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
. a -> (m, b)
f
  duplicate :: Writer m :~> (Writer m :.: Writer m)
duplicate (Writer a -> (m, b)
f) = (a -> (m, a)) -> Writer m a a
forall m a b. (a -> (m, b)) -> Writer m a b
Writer (\a
a -> ((m, b) -> m
forall a b. (a, b) -> a
fst (a -> (m, b)
f a
a), a
a)) Writer m a a -> Writer m a b -> (:.:) (Writer m) (Writer m) a b
forall {j} {k} {i} (p :: j +-> k) (a :: k) (b :: j) (q :: i +-> j)
       (c :: i).
p a b -> q b c -> (:.:) p q a c
:.: (a -> (m, b)) -> Writer m a b
forall m a b. (a -> (m, b)) -> Writer m a b
Writer a -> (m, b)
f

instance (Monoid m) => MonoidalProfunctor (Writer m) where
  par0 :: Writer m Unit Unit
par0 = 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
  Writer x1 -> (m, x2)
f par :: forall x1 x2 y1 y2.
Writer m x1 x2 -> Writer m y1 y2 -> Writer m (x1 ** y1) (x2 ** y2)
`par` 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))