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, ())