module Control.Joint.Effects.Writer where

import Control.Applicative (Alternative (empty, (<|>)))

import Control.Joint.Operators ((<$$>), (<**>))
import Control.Joint.Abilities.Interpreted (Interpreted (Primary, run))
import Control.Joint.Abilities.Transformer (Transformer (build, unite), Schema, (:>) (T))
import Control.Joint.Abilities.Adaptable (Adaptable (adapt))
import Control.Joint.Schemes (UT (UT), type (<.:>) )

newtype Writer e a = Writer (e, a)

instance Functor (Writer e) where
	fmap :: (a -> b) -> Writer e a -> Writer e b
fmap a -> b
f (Writer (e, a)
x) = (e, b) -> Writer e b
forall e a. (e, a) -> Writer e a
Writer ((e, b) -> Writer e b) -> (e, b) -> Writer e b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> (e, a) -> (e, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e, a)
x

instance Monoid e => Applicative (Writer e) where
	pure :: a -> Writer e a
pure = (e, a) -> Writer e a
forall e a. (e, a) -> Writer e a
Writer ((e, a) -> Writer e a) -> (a -> (e, a)) -> a -> Writer e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) e
forall a. Monoid a => a
mempty
	Writer e (a -> b)
f <*> :: Writer e (a -> b) -> Writer e a -> Writer e b
<*> Writer e a
v = (e, b) -> Writer e b
forall e a. (e, a) -> Writer e a
Writer ((e, b) -> Writer e b) -> (e, b) -> Writer e b
forall a b. (a -> b) -> a -> b
$ (e, a -> b) -> (e, a) -> (e, b)
forall a t b. Semigroup a => (a, t -> b) -> (a, t) -> (a, b)
k (Writer e (a -> b) -> Primary (Writer e) (a -> b)
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Writer e (a -> b)
f) (Writer e a -> Primary (Writer e) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run Writer e a
v) where
		k :: (a, t -> b) -> (a, t) -> (a, b)
k ~(a
e, t -> b
a) ~(a
e', t
b) = (a
e a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
e', t -> b
a t
b)

instance Monoid e => Monad (Writer e) where
	Writer (e
e, a
x) >>= :: Writer e a -> (a -> Writer e b) -> Writer e b
>>= a -> Writer e b
f = let (e
e', b
b) = Writer e b -> Primary (Writer e) b
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (Writer e b -> Primary (Writer e) b)
-> Writer e b -> Primary (Writer e) b
forall a b. (a -> b) -> a -> b
$ a -> Writer e b
f a
x in
		(e, b) -> Writer e b
forall e a. (e, a) -> Writer e a
Writer (e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e', b
b)

instance Interpreted (Writer e) where
	type Primary (Writer e) a = (e, a)
	run :: Writer e a -> Primary (Writer e) a
run (Writer (e, a)
x) = (e, a)
Primary (Writer e) a
x

type instance Schema (Writer e) = UT ((,) e)

instance Monoid e => Transformer (Writer e) where
	build :: Writer e ~> (Writer e :> u)
build = UT ((,) e) u a -> (:>) (Writer e) u a
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T (UT ((,) e) u a -> (:>) (Writer e) u a)
-> (Writer e a -> UT ((,) e) u a)
-> Writer e a
-> (:>) (Writer e) u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((u :. (,) e) := a) -> UT ((,) e) u a
forall k k (t :: k -> k) (u :: k -> *) (a :: k).
((u :. t) := a) -> UT t u a
UT (((u :. (,) e) := a) -> UT ((,) e) u a)
-> (Writer e a -> (u :. (,) e) := a)
-> Writer e a
-> UT ((,) e) u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e, a) -> (u :. (,) e) := a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((e, a) -> (u :. (,) e) := a)
-> (Writer e a -> (e, a)) -> Writer e a -> (u :. (,) e) := a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer e a -> (e, a)
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run
	unite :: Primary (Schema (Writer e) u) a -> (:>) (Writer e) u a
unite = UT ((,) e) u a -> (:>) (Writer e) u a
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T (UT ((,) e) u a -> (:>) (Writer e) u a)
-> (((u :. (,) e) := a) -> UT ((,) e) u a)
-> ((u :. (,) e) := a)
-> (:>) (Writer e) u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((u :. (,) e) := a) -> UT ((,) e) u a
forall k k (t :: k -> k) (u :: k -> *) (a :: k).
((u :. t) := a) -> UT t u a
UT

instance Functor u => Functor ((,) e <.:> u) where
	fmap :: (a -> b) -> (<.:>) ((,) e) u a -> (<.:>) ((,) e) u b
fmap a -> b
f (UT (u :. (,) e) := a
x) = ((u :. (,) e) := b) -> (<.:>) ((,) e) u b
forall k k (t :: k -> k) (u :: k -> *) (a :: k).
((u :. t) := a) -> UT t u a
UT (((u :. (,) e) := b) -> (<.:>) ((,) e) u b)
-> ((u :. (,) e) := b) -> (<.:>) ((,) e) u b
forall a b. (a -> b) -> a -> b
$ a -> b
f (a -> b) -> ((u :. (,) e) := a) -> (u :. (,) e) := b
forall (t :: * -> *) (u :: * -> *) a b.
(Functor t, Functor u) =>
(a -> b) -> ((t :. u) := a) -> (t :. u) := b
<$$> (u :. (,) e) := a
x

instance (Monoid e, Applicative u) => Applicative ((,) e <.:> u) where
	pure :: a -> (<.:>) ((,) e) u a
pure = ((u :. (,) e) := a) -> (<.:>) ((,) e) u a
forall k k (t :: k -> k) (u :: k -> *) (a :: k).
((u :. t) := a) -> UT t u a
UT (((u :. (,) e) := a) -> (<.:>) ((,) e) u a)
-> (a -> (u :. (,) e) := a) -> a -> (<.:>) ((,) e) u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e, a) -> (u :. (,) e) := a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((e, a) -> (u :. (,) e) := a)
-> (a -> (e, a)) -> a -> (u :. (,) e) := a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (e, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
	UT (u :. (,) e) := (a -> b)
f <*> :: (<.:>) ((,) e) u (a -> b)
-> (<.:>) ((,) e) u a -> (<.:>) ((,) e) u b
<*> UT (u :. (,) e) := a
x = ((u :. (,) e) := b) -> (<.:>) ((,) e) u b
forall k k (t :: k -> k) (u :: k -> *) (a :: k).
((u :. t) := a) -> UT t u a
UT (((u :. (,) e) := b) -> (<.:>) ((,) e) u b)
-> ((u :. (,) e) := b) -> (<.:>) ((,) e) u b
forall a b. (a -> b) -> a -> b
$ (u :. (,) e) := (a -> b)
f ((u :. (,) e) := (a -> b))
-> ((u :. (,) e) := a) -> (u :. (,) e) := b
forall (t :: * -> *) (u :: * -> *) a b.
(Applicative t, Applicative u) =>
((t :. u) := (a -> b)) -> ((t :. u) := a) -> (t :. u) := b
<**> (u :. (,) e) := a
x

instance (Monoid e, Alternative u) => Alternative ((,) e <.:> u) where
	(<.:>) ((,) e) u a
x <|> :: (<.:>) ((,) e) u a -> (<.:>) ((,) e) u a -> (<.:>) ((,) e) u a
<|> (<.:>) ((,) e) u a
y = ((u :. (,) e) := a) -> (<.:>) ((,) e) u a
forall k k (t :: k -> k) (u :: k -> *) (a :: k).
((u :. t) := a) -> UT t u a
UT (((u :. (,) e) := a) -> (<.:>) ((,) e) u a)
-> ((u :. (,) e) := a) -> (<.:>) ((,) e) u a
forall a b. (a -> b) -> a -> b
$ (<.:>) ((,) e) u a -> Primary ((,) e <.:> u) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (<.:>) ((,) e) u a
x ((u :. (,) e) := a) -> ((u :. (,) e) := a) -> (u :. (,) e) := a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (<.:>) ((,) e) u a -> Primary ((,) e <.:> u) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (<.:>) ((,) e) u a
y
	empty :: (<.:>) ((,) e) u a
empty = ((u :. (,) e) := a) -> (<.:>) ((,) e) u a
forall k k (t :: k -> k) (u :: k -> *) (a :: k).
((u :. t) := a) -> UT t u a
UT (u :. (,) e) := a
forall (f :: * -> *) a. Alternative f => f a
empty

instance (Monoid e, Applicative u, Monad u) => Monad ((,) e <.:> u) where
	UT (u :. (,) e) := a
x >>= :: (<.:>) ((,) e) u a
-> (a -> (<.:>) ((,) e) u b) -> (<.:>) ((,) e) u b
>>= a -> (<.:>) ((,) e) u b
f = ((u :. (,) e) := b) -> (<.:>) ((,) e) u b
forall k k (t :: k -> k) (u :: k -> *) (a :: k).
((u :. t) := a) -> UT t u a
UT (((u :. (,) e) := b) -> (<.:>) ((,) e) u b)
-> ((u :. (,) e) := b) -> (<.:>) ((,) e) u b
forall a b. (a -> b) -> a -> b
$ (u :. (,) e) := a
x ((u :. (,) e) := a)
-> ((e, a) -> (u :. (,) e) := b) -> (u :. (,) e) := b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(e
acc, a
v) -> (\(e
acc', b
y) -> (e
acc e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
acc', b
y)) ((e, b) -> (e, b)) -> ((u :. (,) e) := b) -> (u :. (,) e) := b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (<.:>) ((,) e) u b -> Primary ((,) e <.:> u) b
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run (a -> (<.:>) ((,) e) u b
f a
v)

type Accumulated e t = Adaptable (Writer e) t

add :: Accumulated e t => e -> t ()
add :: e -> t ()
add e
s = Writer e () -> t ()
forall (eff :: * -> *) (schema :: * -> *).
Adaptable eff schema =>
eff ~> schema
adapt (Writer e () -> t ()) -> Writer e () -> t ()
forall a b. (a -> b) -> a -> b
$ (e, ()) -> Writer e ()
forall e a. (e, a) -> Writer e a
Writer (e
s, ())