module Data.Profunctor.Writer where

import Data.Profunctor
import Control.Category (Category)
import qualified Control.Category as C
import Data.Bifunctor (first)
import Data.Profunctor.Writer.Class

newtype WriterT w p a b = WriterT (p a (b, w))

instance Profunctor p => Profunctor (WriterT w p) where
  dimap :: (a -> b) -> (c -> d) -> WriterT w p b c -> WriterT w p a d
dimap f :: a -> b
f g :: c -> d
g (WriterT w :: p b (c, w)
w) = p a (d, w) -> WriterT w p a d
forall w (p :: * -> * -> *) a b. p a (b, w) -> WriterT w p a b
WriterT ((a -> b) -> ((c, w) -> (d, w)) -> p b (c, w) -> p a (d, w)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f ((c -> d) -> (c, w) -> (d, w)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first c -> d
g) p b (c, w)
w)

instance (Monoid w, Category p, Strong p) => Category (WriterT w p) where
  id :: WriterT w p a a
id = p a (a, w) -> WriterT w p a a
forall w (p :: * -> * -> *) a b. p a (b, w) -> WriterT w p a b
WriterT ((a -> (a, w)) -> p a a -> p a (a, w)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (\b :: a
b -> (a
b, w
forall a. Monoid a => a
mempty)) p a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id)
  WriterT x :: p b (c, w)
x . :: WriterT w p b c -> WriterT w p a b -> WriterT w p a c
. WriterT y :: p a (b, w)
y = p a (c, w) -> WriterT w p a c
forall w (p :: * -> * -> *) a b. p a (b, w) -> WriterT w p a b
WriterT ((((c, w), w) -> (c, w)) -> p (b, w) ((c, w), w) -> p (b, w) (c, w)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (\((c :: c
c, w :: w
w), w' :: w
w') -> (c
c, w
w w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w')) (p b (c, w) -> p (b, w) ((c, w), w)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (a, c) (b, c)
first' p b (c, w)
x) p (b, w) (c, w) -> p a (b, w) -> p a (c, w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
C.. p a (b, w)
y)

instance (Profunctor p, Monoid w) => ProfunctorWriter' w (WriterT w p) where
  tell' :: WriterT w p a (b, w) -> WriterT w p a b
tell' (WriterT p :: p a ((b, w), w)
p) = p a (b, w) -> WriterT w p a b
forall w (p :: * -> * -> *) a b. p a (b, w) -> WriterT w p a b
WriterT ((((b, w), w) -> (b, w)) -> p a ((b, w), w) -> p a (b, w)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (\((b :: b
b, w :: w
w), w' :: w
w') -> (b
b, w
w w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w')) p a ((b, w), w)
p)
  listen' :: WriterT w p a b -> WriterT w p a (b, w)
listen' (WriterT p :: p a (b, w)
p) = p a ((b, w), w) -> WriterT w p a (b, w)
forall w (p :: * -> * -> *) a b. p a (b, w) -> WriterT w p a b
WriterT (((b, w) -> ((b, w), w)) -> p a (b, w) -> p a ((b, w), w)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (\(b :: b
b, w :: w
w) -> ((b
b, w
w), w
w)) p a (b, w)
p)
  pass' :: WriterT w p a (b, w -> w) -> WriterT w p a b
pass' (WriterT p :: p a ((b, w -> w), w)
p) = p a (b, w) -> WriterT w p a b
forall w (p :: * -> * -> *) a b. p a (b, w) -> WriterT w p a b
WriterT ((((b, w -> w), w) -> (b, w)) -> p a ((b, w -> w), w) -> p a (b, w)
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (\((b :: b
b, f :: w -> w
f), w :: w
w) -> (b
b, w -> w
f w
w)) p a ((b, w -> w), w)
p)