module Control.Joint.Effects.State where

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

import Control.Joint.Core (type (:.), type (:=))
import Control.Joint.Operators ((<$$>))
import Control.Joint.Abilities.Completable (Completable (complete))
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 (TUT (TUT), type (<:<.>:>))
import Control.Joint.Effects.Reader (Reader (Reader))
import Control.Joint.Effects.Writer (Writer (Writer))

newtype State s a = State ((->) s :. (,) s := a)

statefully :: s -> State s a -> (s, a)
statefully :: s -> State s a -> (s, a)
statefully s
initial (State ((->) s :. (,) s) := a
x) = ((->) s :. (,) s) := a
x s
initial

instance Functor (State s) where
	fmap :: (a -> b) -> State s a -> State s b
fmap a -> b
f (State ((->) s :. (,) s) := a
x) = (((->) s :. (,) s) := b) -> State s b
forall s a. (((->) s :. (,) s) := a) -> State s a
State ((((->) s :. (,) s) := b) -> State s b)
-> (((->) s :. (,) s) := b) -> State s b
forall a b. (a -> b) -> a -> b
$ \s
old -> a -> b
f (a -> b) -> (s, a) -> (s, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((->) s :. (,) s) := a
x s
old

instance Applicative (State s) where
	pure :: a -> State s a
pure a
x = (((->) s :. (,) s) := a) -> State s a
forall s a. (((->) s :. (,) s) := a) -> State s a
State ((((->) s :. (,) s) := a) -> State s a)
-> (((->) s :. (,) s) := a) -> State s a
forall a b. (a -> b) -> a -> b
$ \s
s -> (s
s, a
x)
	State ((->) s :. (,) s) := (a -> b)
f <*> :: State s (a -> b) -> State s a -> State s b
<*> State ((->) s :. (,) s) := a
x = (((->) s :. (,) s) := b) -> State s b
forall s a. (((->) s :. (,) s) := a) -> State s a
State ((((->) s :. (,) s) := b) -> State s b)
-> (((->) s :. (,) s) := b) -> State s b
forall a b. (a -> b) -> a -> b
$ \s
old ->
		let (s
new, a -> b
g) = ((->) s :. (,) s) := (a -> b)
f s
old in a -> b
g (a -> b) -> (s, a) -> (s, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((->) s :. (,) s) := a
x s
new

instance Monad (State s) where
	State ((->) s :. (,) s) := a
x >>= :: State s a -> (a -> State s b) -> State s b
>>= a -> State s b
f = (((->) s :. (,) s) := b) -> State s b
forall s a. (((->) s :. (,) s) := a) -> State s a
State ((((->) s :. (,) s) := b) -> State s b)
-> (((->) s :. (,) s) := b) -> State s b
forall a b. (a -> b) -> a -> b
$ \s
old ->
		(s -> State s b -> (s, b)) -> (s, State s b) -> (s, b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry s -> State s b -> (s, b)
forall s a. s -> State s a -> (s, a)
statefully ((s, State s b) -> (s, b)) -> (s, State s b) -> (s, b)
forall a b. (a -> b) -> a -> b
$ a -> State s b
f (a -> State s b) -> (s, a) -> (s, State s b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((->) s :. (,) s) := a
x s
old

instance Interpreted (State s) where
	type Primary (State s) a = (->) s :. (,) s := a
	run :: State s a -> Primary (State s) a
run (State ((->) s :. (,) s) := a
x) = Primary (State s) a
((->) s :. (,) s) := a
x

type instance Schema (State s) = (->) s <:<.>:> (,) s

instance Transformer (State s) where
	build :: State s ~> (State s :> u)
build State s a
x = TUT ((->) s) ((,) s) u a -> (:>) (State s) u a
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T (TUT ((->) s) ((,) s) u a -> (:>) (State s) u a)
-> ((((->) s :. (u :. (,) s)) := a) -> TUT ((->) s) ((,) s) u a)
-> (((->) s :. (u :. (,) s)) := a)
-> (:>) (State s) u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((->) s :. (u :. (,) s)) := a) -> TUT ((->) s) ((,) s) u a
forall k k k (t :: k -> *) (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT t t' u a
TUT ((((->) s :. (u :. (,) s)) := a) -> (:>) (State s) u a)
-> (((->) s :. (u :. (,) s)) := a) -> (:>) (State s) u a
forall a b. (a -> b) -> a -> b
$ (s, a) -> u (s, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((s, a) -> u (s, a))
-> (s -> (s, a)) -> ((->) s :. (u :. (,) s)) := a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State s a -> Primary (State s) a
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run State s a
x
	unite :: Primary (Schema (State s) u) a -> (:>) (State s) u a
unite = TUT ((->) s) ((,) s) u a -> (:>) (State s) u a
forall (t :: * -> *) (u :: * -> *) a.
(Transformer t => Schema t u a) -> (:>) t u a
T (TUT ((->) s) ((,) s) u a -> (:>) (State s) u a)
-> ((((->) s :. (u :. (,) s)) := a) -> TUT ((->) s) ((,) s) u a)
-> (((->) s :. (u :. (,) s)) := a)
-> (:>) (State s) u a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((->) s :. (u :. (,) s)) := a) -> TUT ((->) s) ((,) s) u a
forall k k k (t :: k -> *) (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT t t' u a
TUT

instance Functor u => Functor ((->) s <:<.>:> (,) s := u) where
	fmap :: (a -> b)
-> (:=) ((->) s <:<.>:> (,) s) u a
-> (:=) ((->) s <:<.>:> (,) s) u b
fmap a -> b
f (TUT ((->) s :. (u :. (,) s)) := a
x) = (((->) s :. (u :. (,) s)) := b) -> (:=) ((->) s <:<.>:> (,) s) u b
forall k k k (t :: k -> *) (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT t t' u a
TUT ((((->) s :. (u :. (,) s)) := b)
 -> (:=) ((->) s <:<.>:> (,) s) u b)
-> (((->) s :. (u :. (,) s)) := b)
-> (:=) ((->) s <:<.>:> (,) s) u b
forall a b. (a -> b) -> a -> b
$ \s
old -> a -> b
f (a -> b) -> ((u :. (,) s) := a) -> (u :. (,) s) := b
forall (t :: * -> *) (u :: * -> *) a b.
(Functor t, Functor u) =>
(a -> b) -> ((t :. u) := a) -> (t :. u) := b
<$$> ((->) s :. (u :. (,) s)) := a
x s
old

instance Monad u => Applicative ((->) s <:<.>:> (,) s := u) where
	pure :: a -> (:=) ((->) s <:<.>:> (,) s) u a
pure a
x = (((->) s :. (u :. (,) s)) := a) -> (:=) ((->) s <:<.>:> (,) s) u a
forall k k k (t :: k -> *) (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT t t' u a
TUT ((((->) s :. (u :. (,) s)) := a)
 -> (:=) ((->) s <:<.>:> (,) s) u a)
-> (((->) s :. (u :. (,) s)) := a)
-> (:=) ((->) s <:<.>:> (,) s) u a
forall a b. (a -> b) -> a -> b
$ \s
s -> (s, a) -> u (s, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s, a
x)
	TUT ((->) s :. (u :. (,) s)) := (a -> b)
f <*> :: (:=) ((->) s <:<.>:> (,) s) u (a -> b)
-> (:=) ((->) s <:<.>:> (,) s) u a
-> (:=) ((->) s <:<.>:> (,) s) u b
<*> TUT ((->) s :. (u :. (,) s)) := a
x = (((->) s :. (u :. (,) s)) := b) -> (:=) ((->) s <:<.>:> (,) s) u b
forall k k k (t :: k -> *) (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT t t' u a
TUT ((((->) s :. (u :. (,) s)) := b)
 -> (:=) ((->) s <:<.>:> (,) s) u b)
-> (((->) s :. (u :. (,) s)) := b)
-> (:=) ((->) s <:<.>:> (,) s) u b
forall a b. (a -> b) -> a -> b
$ \s
old -> ((->) s :. (u :. (,) s)) := (a -> b)
f s
old u (s, a -> b) -> ((s, a -> b) -> u (s, b)) -> u (s, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(s
new, a -> b
g) -> a -> b
g (a -> b) -> ((u :. (,) s) := a) -> u (s, b)
forall (t :: * -> *) (u :: * -> *) a b.
(Functor t, Functor u) =>
(a -> b) -> ((t :. u) := a) -> (t :. u) := b
<$$> ((->) s :. (u :. (,) s)) := a
x s
new

instance Monad u => Monad ((->) s <:<.>:> (,) s := u) where
	TUT ((->) s :. (u :. (,) s)) := a
x >>= :: (:=) ((->) s <:<.>:> (,) s) u a
-> (a -> (:=) ((->) s <:<.>:> (,) s) u b)
-> (:=) ((->) s <:<.>:> (,) s) u b
>>= a -> (:=) ((->) s <:<.>:> (,) s) u b
f = (((->) s :. (u :. (,) s)) := b) -> (:=) ((->) s <:<.>:> (,) s) u b
forall k k k (t :: k -> *) (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT t t' u a
TUT ((((->) s :. (u :. (,) s)) := b)
 -> (:=) ((->) s <:<.>:> (,) s) u b)
-> (((->) s :. (u :. (,) s)) := b)
-> (:=) ((->) s <:<.>:> (,) s) u b
forall a b. (a -> b) -> a -> b
$ \s
old -> ((->) s :. (u :. (,) s)) := a
x s
old u (s, a) -> ((s, a) -> u (s, b)) -> u (s, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(s
new, a
y) -> ((((->) s :. (u :. (,) s)) := b) -> ((->) s :. (u :. (,) s)) := b
forall a b. (a -> b) -> a -> b
$ s
new) ((((->) s :. (u :. (,) s)) := b) -> u (s, b))
-> (a -> ((->) s :. (u :. (,) s)) := b) -> a -> u (s, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:=) ((->) s <:<.>:> (,) s) u b -> ((->) s :. (u :. (,) s)) := b
forall (t :: * -> *) a. Interpreted t => t a -> Primary t a
run ((:=) ((->) s <:<.>:> (,) s) u b -> ((->) s :. (u :. (,) s)) := b)
-> (a -> (:=) ((->) s <:<.>:> (,) s) u b)
-> a
-> ((->) s :. (u :. (,) s)) := b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (:=) ((->) s <:<.>:> (,) s) u b
f (a -> u (s, b)) -> a -> u (s, b)
forall a b. (a -> b) -> a -> b
$ a
y

instance (Alternative u, Monad u) => Alternative ((->) s <:<.>:> (,) s := u) where
	TUT ((->) s :. (u :. (,) s)) := a
x <|> :: (:=) ((->) s <:<.>:> (,) s) u a
-> (:=) ((->) s <:<.>:> (,) s) u a
-> (:=) ((->) s <:<.>:> (,) s) u a
<|> TUT ((->) s :. (u :. (,) s)) := a
y = (((->) s :. (u :. (,) s)) := a) -> (:=) ((->) s <:<.>:> (,) s) u a
forall k k k (t :: k -> *) (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT t t' u a
TUT ((((->) s :. (u :. (,) s)) := a)
 -> (:=) ((->) s <:<.>:> (,) s) u a)
-> (((->) s :. (u :. (,) s)) := a)
-> (:=) ((->) s <:<.>:> (,) s) u a
forall a b. (a -> b) -> a -> b
$ \s
s -> ((->) s :. (u :. (,) s)) := a
x s
s u (s, a) -> u (s, a) -> u (s, a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((->) s :. (u :. (,) s)) := a
y s
s
	empty :: (:=) ((->) s <:<.>:> (,) s) u a
empty = (((->) s :. (u :. (,) s)) := a) -> (:=) ((->) s <:<.>:> (,) s) u a
forall k k k (t :: k -> *) (t' :: k -> k) (u :: k -> k) (a :: k).
((t :. (u :. t')) := a) -> TUT t t' u a
TUT ((((->) s :. (u :. (,) s)) := a)
 -> (:=) ((->) s <:<.>:> (,) s) u a)
-> (((->) s :. (u :. (,) s)) := a)
-> (:=) ((->) s <:<.>:> (,) s) u a
forall a b. (a -> b) -> a -> b
$ \s
_ -> u (s, a)
forall (f :: * -> *) a. Alternative f => f a
empty

instance Completable (Reader e) (State e) where
	complete :: Reader e a -> State e a
complete (Reader e -> a
f) = (((->) e :. (,) e) := a) -> State e a
forall s a. (((->) s :. (,) s) := a) -> State s a
State (\e
e -> (e
e, e -> a
f e
e))

instance Completable (Writer e) (State e) where
	complete :: Writer e a -> State e a
complete (Writer (e
e, a
x)) = (((->) e :. (,) e) := a) -> State e a
forall s a. (((->) s :. (,) s) := a) -> State s a
State ((((->) e :. (,) e) := a) -> State e a)
-> (((->) e :. (,) e) := a) -> State e a
forall a b. (a -> b) -> a -> b
$ \e
e -> (e
e, a
x)

type Stateful e = Adaptable (State e)

modify :: Stateful s t => (s -> s) -> t ()
modify :: (s -> s) -> t ()
modify s -> s
f = State s () -> t ()
forall (eff :: * -> *) (schema :: * -> *).
Adaptable eff schema =>
eff ~> schema
adapt (State s () -> t ()) -> State s () -> t ()
forall a b. (a -> b) -> a -> b
$ (((->) s :. (,) s) := ()) -> State s ()
forall s a. (((->) s :. (,) s) := a) -> State s a
State ((((->) s :. (,) s) := ()) -> State s ())
-> (((->) s :. (,) s) := ()) -> State s ()
forall a b. (a -> b) -> a -> b
$ \s
s -> (s -> s
f s
s, ())

current :: Stateful s t => t s
current :: t s
current = State s s -> t s
forall (eff :: * -> *) (schema :: * -> *).
Adaptable eff schema =>
eff ~> schema
adapt (State s s -> t s) -> State s s -> t s
forall a b. (a -> b) -> a -> b
$ (((->) s :. (,) s) := s) -> State s s
forall s a. (((->) s :. (,) s) := a) -> State s a
State ((((->) s :. (,) s) := s) -> State s s)
-> (((->) s :. (,) s) := s) -> State s s
forall a b. (a -> b) -> a -> b
$ \s
s -> (s
s, s
s)

replace :: Stateful s t => s -> t ()
replace :: s -> t ()
replace s
new = State s () -> t ()
forall (eff :: * -> *) (schema :: * -> *).
Adaptable eff schema =>
eff ~> schema
adapt (State s () -> t ()) -> State s () -> t ()
forall a b. (a -> b) -> a -> b
$ (((->) s :. (,) s) := ()) -> State s ()
forall s a. (((->) s :. (,) s) := a) -> State s a
State ((((->) s :. (,) s) := ()) -> State s ())
-> (((->) s :. (,) s) := ()) -> State s ()
forall a b. (a -> b) -> a -> b
$ \s
_ -> (s
new, ())