{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}

-- | This is the main module of the whole library. It defines the central
-- `StateMachineT` type, which allows us to create composable state machines.
module Crem.StateMachine where

import Crem.BaseMachine as BaseMachine
import Crem.Render.RenderableVertices (RenderableVertices)
import Crem.Topology (AllowAllTopology, Topology)
import "base" Control.Arrow (Arrow (arr, first), ArrowChoice (left))
import "base" Control.Category (Category (..))
import "base" Data.Bifunctor (Bifunctor (second), bimap)
import "base" Data.Foldable (foldlM)
import "base" Data.Kind (Type)
import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
import Prelude hiding ((.))

-- | A `StateMachineT` is an effectful [Mealy machine](https://en.wikipedia.org/wiki/Mealy_machine)
-- with inputs of type @input@ and outputs of type @output@
--
-- Effects are described by the context @m@ in which the action of the machine
-- is executed
--
-- `StateMachineT` is a tree, where leaves are `BaseMachineT` and other nodes
-- describe how to combine the subtrees to obtain more complex machines.
--
-- Please refer to https://github.com/tweag/crem/blob/main/docs/how-to-create-a-machine.md
-- for a more complete discussion on the various constructors.
data StateMachineT m input output where
  -- | `Basic` allows to interpret a `BaseMachineT` as a `StateMachineT`,
  -- making the @topology@ type variable existential
  Basic
    :: forall m vertex (topology :: Topology vertex) input output
     . ( Demote vertex ~ vertex
       , SingKind vertex
       , SingI topology
       , Eq vertex
       , Show vertex
       , RenderableVertices vertex
       )
    => BaseMachineT m topology input output
    -> StateMachineT m input output
  -- | `Sequential` adds categorical composition for `StateMachineT`
  Sequential
    :: StateMachineT m a b
    -> StateMachineT m b c
    -> StateMachineT m a c
  -- | `Parallel` allows to process two machine simultaneously
  Parallel
    :: StateMachineT m a b
    -> StateMachineT m c d
    -> StateMachineT m (a, c) (b, d)
  -- | `Alternative` allows to process one out of two machines depending on the
  -- input
  Alternative
    :: StateMachineT m a b
    -> StateMachineT m c d
    -> StateMachineT m (Either a c) (Either b d)
  -- | `Feedback` allows to compose two machine going in oppositive directions
  -- and run them in a loop
  Feedback
    :: (Foldable n, Monoid (n a), Monoid (n b))
    => StateMachineT m a (n b)
    -> StateMachineT m b (n a)
    -> StateMachineT m a (n b)
  -- | `Kleisli` allows to compose sequentially machines which emit multiple
  -- outputs
  Kleisli
    :: (Foldable n, Monoid (n c))
    => StateMachineT m a (n b)
    -> StateMachineT m b (n c)
    -> StateMachineT m a (n c)

-- | A `StateMachine` is an effectful machine for every possible monad @m@.
-- Needing to work for every monad, in fact it can not perform any kind of
-- effect and needs to be pure in nature.
type StateMachine a b = forall m. Monad m => StateMachineT m a b

-- * Hoist

-- | Allows to change the context @m@ where the machine operates to another
-- context @n@, provided we have a [natural transformation](https://stackoverflow.com/a/58364172/2718064)
-- from @m@ to @n@
hoist :: (forall x. m x -> n x) -> StateMachineT m a b -> StateMachineT n a b
hoist :: forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist forall x. m x -> n x
f StateMachineT m a b
machine = case StateMachineT m a b
machine of
  Basic BaseMachineT m topology a b
baseMachine -> BaseMachineT n topology a b -> StateMachineT n a b
forall (m :: * -> *) n (c :: Topology n) input output.
(Demote n ~ n, SingKind n, SingI c, Eq n, Show n,
 RenderableVertices n) =>
BaseMachineT m c input output -> StateMachineT m input output
Basic (BaseMachineT n topology a b -> StateMachineT n a b)
-> BaseMachineT n topology a b -> StateMachineT n a b
forall a b. (a -> b) -> a -> b
$ (forall x. m x -> n x)
-> BaseMachineT m topology a b -> BaseMachineT n topology a b
forall {vertex} (m :: * -> *) (n :: * -> *)
       (topology :: Topology vertex) a b.
(forall x. m x -> n x)
-> BaseMachineT m topology a b -> BaseMachineT n topology a b
baseHoist m x -> n x
forall x. m x -> n x
f BaseMachineT m topology a b
baseMachine
  Sequential StateMachineT m a b
machine1 StateMachineT m b b
machine2 -> StateMachineT n a b -> StateMachineT n b b -> StateMachineT n a b
forall (m :: * -> *) a n c.
StateMachineT m a n -> StateMachineT m n c -> StateMachineT m a c
Sequential ((forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m a b
machine1) ((forall x. m x -> n x)
-> StateMachineT m b b -> StateMachineT n b b
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m b b
machine2)
  Parallel StateMachineT m a b
machine1 StateMachineT m c d
machine2 -> StateMachineT n a b
-> StateMachineT n c d -> StateMachineT n (a, c) (b, d)
forall (m :: * -> *) n c b d.
StateMachineT m n c
-> StateMachineT m b d -> StateMachineT m (n, b) (c, d)
Parallel ((forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m a b
machine1) ((forall x. m x -> n x)
-> StateMachineT m c d -> StateMachineT n c d
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m c d
machine2)
  Alternative StateMachineT m a b
machine1 StateMachineT m c d
machine2 -> StateMachineT n a b
-> StateMachineT n c d -> StateMachineT n (Either a c) (Either b d)
forall (m :: * -> *) n c b d.
StateMachineT m n c
-> StateMachineT m b d -> StateMachineT m (Either n b) (Either c d)
Alternative ((forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m a b
machine1) ((forall x. m x -> n x)
-> StateMachineT m c d -> StateMachineT n c d
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m c d
machine2)
  Feedback StateMachineT m a (n b)
machine1 StateMachineT m b (n a)
machine2 -> StateMachineT n a (n b)
-> StateMachineT n b (n a) -> StateMachineT n a (n b)
forall (n :: * -> *) a c (m :: * -> *).
(Foldable n, Monoid (n a), Monoid (n c)) =>
StateMachineT m a (n c)
-> StateMachineT m c (n a) -> StateMachineT m a (n c)
Feedback ((forall x. m x -> n x)
-> StateMachineT m a (n b) -> StateMachineT n a (n b)
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m a (n b)
machine1) ((forall x. m x -> n x)
-> StateMachineT m b (n a) -> StateMachineT n b (n a)
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m b (n a)
machine2)
  Kleisli StateMachineT m a (n b)
machine1 StateMachineT m b (n c)
machine2 -> StateMachineT n a (n b)
-> StateMachineT n b (n c) -> StateMachineT n a (n c)
forall (n :: * -> *) c (m :: * -> *) a b.
(Foldable n, Monoid (n c)) =>
StateMachineT m a (n b)
-> StateMachineT m b (n c) -> StateMachineT m a (n c)
Kleisli ((forall x. m x -> n x)
-> StateMachineT m a (n b) -> StateMachineT n a (n b)
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m a (n b)
machine1) ((forall x. m x -> n x)
-> StateMachineT m b (n c) -> StateMachineT n b (n c)
forall (m :: * -> *) (n :: * -> *) a b.
(forall x. m x -> n x)
-> StateMachineT m a b -> StateMachineT n a b
hoist m x -> n x
forall x. m x -> n x
f StateMachineT m b (n c)
machine2)

-- | a state machine which does not rely on state
statelessT :: Applicative m => (a -> m b) -> StateMachineT m a b
statelessT :: forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> StateMachineT m a b
statelessT a -> m b
f = BaseMachineT m ('Topology '[]) a b -> StateMachineT m a b
forall (m :: * -> *) n (c :: Topology n) input output.
(Demote n ~ n, SingKind n, SingI c, Eq n, Show n,
 RenderableVertices n) =>
BaseMachineT m c input output -> StateMachineT m input output
Basic (BaseMachineT m ('Topology '[]) a b -> StateMachineT m a b)
-> BaseMachineT m ('Topology '[]) a b -> StateMachineT m a b
forall a b. (a -> b) -> a -> b
$ (a -> m b) -> BaseMachineT m TrivialTopology a b
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> BaseMachineT m TrivialTopology a b
statelessBaseT a -> m b
f

-- | a state machine which does not rely on state and does not perform side
-- effects
stateless :: Applicative m => (a -> b) -> StateMachineT m a b
stateless :: forall (m :: * -> *) a b.
Applicative m =>
(a -> b) -> StateMachineT m a b
stateless a -> b
f = (a -> m b) -> StateMachineT m a b
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> StateMachineT m a b
statelessT (b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> m b) -> (a -> b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
f)

-- | a machine modelled with explicit state, where every transition is allowed
unrestrictedMachine
  :: ( Demote vertex ~ vertex
     , SingKind vertex
     , SingI (AllowAllTopology @vertex)
     , Eq vertex
     , Show vertex
     , RenderableVertices vertex
     )
  => ( forall initialVertex
        . state initialVertex
       -> a
       -> ActionResult m (AllowAllTopology @vertex) state initialVertex b
     )
  -> InitialState (state :: vertex -> Type)
  -> StateMachineT m a b
unrestrictedMachine :: forall vertex (state :: vertex -> *) a (m :: * -> *) b.
(Demote vertex ~ vertex, SingKind vertex, SingI AllowAllTopology,
 Eq vertex, Show vertex, RenderableVertices vertex) =>
(forall (initialVertex :: vertex).
 state initialVertex
 -> a -> ActionResult m AllowAllTopology state initialVertex b)
-> InitialState state -> StateMachineT m a b
unrestrictedMachine forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m AllowAllTopology state initialVertex b
action InitialState state
state = BaseMachineT
  m
  ('Topology
     (Let6989586621679177149Go
        ((++@#@$) .@#@$$$ Lambda_6989586621679106594Sym0)
        '[]
        (EnumFromTo MinBound MaxBound)
        (EnumFromTo MinBound MaxBound)))
  a
  b
-> StateMachineT m a b
forall (m :: * -> *) n (c :: Topology n) input output.
(Demote n ~ n, SingKind n, SingI c, Eq n, Show n,
 RenderableVertices n) =>
BaseMachineT m c input output -> StateMachineT m input output
Basic (BaseMachineT
   m
   ('Topology
      (Let6989586621679177149Go
         ((++@#@$) .@#@$$$ Lambda_6989586621679106594Sym0)
         '[]
         (EnumFromTo MinBound MaxBound)
         (EnumFromTo MinBound MaxBound)))
   a
   b
 -> StateMachineT m a b)
-> BaseMachineT
     m
     ('Topology
        (Let6989586621679177149Go
           ((++@#@$) .@#@$$$ Lambda_6989586621679106594Sym0)
           '[]
           (EnumFromTo MinBound MaxBound)
           (EnumFromTo MinBound MaxBound)))
     a
     b
-> StateMachineT m a b
forall a b. (a -> b) -> a -> b
$ (forall (initialVertex :: vertex).
 state initialVertex
 -> a -> ActionResult m AllowAllTopology state initialVertex b)
-> InitialState state -> BaseMachineT m AllowAllTopology a b
forall vertex (state :: vertex -> *) a (m :: * -> *) b.
(forall (initialVertex :: vertex).
 state initialVertex
 -> a -> ActionResult m AllowAllTopology state initialVertex b)
-> InitialState state -> BaseMachineT m AllowAllTopology a b
unrestrictedBaseMachineT state initialVertex
-> a -> ActionResult m AllowAllTopology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m AllowAllTopology state initialVertex b
action InitialState state
state

-- * Category

instance Monad m => Category (StateMachineT m) where
  id :: StateMachineT m a a
  id :: forall a. StateMachineT m a a
id = BaseMachineT m ('Topology '[]) a a -> StateMachineT m a a
forall (m :: * -> *) n (c :: Topology n) input output.
(Demote n ~ n, SingKind n, SingI c, Eq n, Show n,
 RenderableVertices n) =>
BaseMachineT m c input output -> StateMachineT m input output
Basic BaseMachineT m ('Topology '[]) a a
BaseMachineT m TrivialTopology a a
forall a (m :: * -> *).
Monad m =>
BaseMachineT m TrivialTopology a a
identity

  (.) :: StateMachineT m b c -> StateMachineT m a b -> StateMachineT m a c
  . :: forall b c a.
StateMachineT m b c -> StateMachineT m a b -> StateMachineT m a c
(.) = (StateMachineT m a b -> StateMachineT m b c -> StateMachineT m a c)
-> StateMachineT m b c
-> StateMachineT m a b
-> StateMachineT m a c
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateMachineT m a b -> StateMachineT m b c -> StateMachineT m a c
forall (m :: * -> *) a n c.
StateMachineT m a n -> StateMachineT m n c -> StateMachineT m a c
Sequential

-- * Profunctor

instance Applicative m => Profunctor (StateMachineT m) where
  lmap :: (a -> b) -> StateMachineT m b c -> StateMachineT m a c
  lmap :: forall a b c.
(a -> b) -> StateMachineT m b c -> StateMachineT m a c
lmap a -> b
f (Basic BaseMachineT m topology b c
baseMachine) = BaseMachineT m topology a c -> StateMachineT m a c
forall (m :: * -> *) n (c :: Topology n) input output.
(Demote n ~ n, SingKind n, SingI c, Eq n, Show n,
 RenderableVertices n) =>
BaseMachineT m c input output -> StateMachineT m input output
Basic (BaseMachineT m topology a c -> StateMachineT m a c)
-> BaseMachineT m topology a c -> StateMachineT m a c
forall a b. (a -> b) -> a -> b
$ (a -> b)
-> BaseMachineT m topology b c -> BaseMachineT m topology a c
forall a b c.
(a -> b)
-> BaseMachineT m topology b c -> BaseMachineT m topology a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a -> b
f BaseMachineT m topology b c
baseMachine
  lmap a -> b
f (Sequential StateMachineT m b b
machine1 StateMachineT m b c
machine2) = StateMachineT m a b -> StateMachineT m b c -> StateMachineT m a c
forall (m :: * -> *) a n c.
StateMachineT m a n -> StateMachineT m n c -> StateMachineT m a c
Sequential ((a -> b) -> StateMachineT m b b -> StateMachineT m a b
forall a b c.
(a -> b) -> StateMachineT m b c -> StateMachineT m a c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a -> b
f StateMachineT m b b
machine1) StateMachineT m b c
machine2
  lmap a -> b
f StateMachineT m b c
machine = StateMachineT m a b -> StateMachineT m b c -> StateMachineT m a c
forall (m :: * -> *) a n c.
StateMachineT m a n -> StateMachineT m n c -> StateMachineT m a c
Sequential ((a -> b) -> StateMachineT m a b
forall (m :: * -> *) a b.
Applicative m =>
(a -> b) -> StateMachineT m a b
stateless a -> b
f) StateMachineT m b c
machine

  rmap :: (b -> c) -> StateMachineT m a b -> StateMachineT m a c
  rmap :: forall b c a.
(b -> c) -> StateMachineT m a b -> StateMachineT m a c
rmap b -> c
f (Basic BaseMachineT m topology a b
baseMachine) = BaseMachineT m topology a c -> StateMachineT m a c
forall (m :: * -> *) n (c :: Topology n) input output.
(Demote n ~ n, SingKind n, SingI c, Eq n, Show n,
 RenderableVertices n) =>
BaseMachineT m c input output -> StateMachineT m input output
Basic (BaseMachineT m topology a c -> StateMachineT m a c)
-> BaseMachineT m topology a c -> StateMachineT m a c
forall a b. (a -> b) -> a -> b
$ (b -> c)
-> BaseMachineT m topology a b -> BaseMachineT m topology a c
forall b c a.
(b -> c)
-> BaseMachineT m topology a b -> BaseMachineT m topology a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap b -> c
f BaseMachineT m topology a b
baseMachine
  rmap b -> c
f (Sequential StateMachineT m a b
machine1 StateMachineT m b b
machine2) = StateMachineT m a b -> StateMachineT m b c -> StateMachineT m a c
forall (m :: * -> *) a n c.
StateMachineT m a n -> StateMachineT m n c -> StateMachineT m a c
Sequential StateMachineT m a b
machine1 ((b -> c) -> StateMachineT m b b -> StateMachineT m b c
forall b c a.
(b -> c) -> StateMachineT m a b -> StateMachineT m a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap b -> c
f StateMachineT m b b
machine2)
  rmap b -> c
f StateMachineT m a b
machine = StateMachineT m a b -> StateMachineT m b c -> StateMachineT m a c
forall (m :: * -> *) a n c.
StateMachineT m a n -> StateMachineT m n c -> StateMachineT m a c
Sequential StateMachineT m a b
machine ((b -> c) -> StateMachineT m b c
forall (m :: * -> *) a b.
Applicative m =>
(a -> b) -> StateMachineT m a b
stateless b -> c
f)

-- * Strong

instance Monad m => Strong (StateMachineT m) where
  first' :: StateMachineT m a b -> StateMachineT m (a, c) (b, c)
  first' :: forall a b c. StateMachineT m a b -> StateMachineT m (a, c) (b, c)
first' = (StateMachineT m a b
 -> StateMachineT m c c -> StateMachineT m (a, c) (b, c))
-> StateMachineT m c c
-> StateMachineT m a b
-> StateMachineT m (a, c) (b, c)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateMachineT m a b
-> StateMachineT m c c -> StateMachineT m (a, c) (b, c)
forall (m :: * -> *) n c b d.
StateMachineT m n c
-> StateMachineT m b d -> StateMachineT m (n, b) (c, d)
Parallel StateMachineT m c c
forall a. StateMachineT m a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Control.Category.id

  second' :: StateMachineT m a b -> StateMachineT m (c, a) (c, b)
  second' :: forall a b c. StateMachineT m a b -> StateMachineT m (c, a) (c, b)
second' = StateMachineT m c c
-> StateMachineT m a b -> StateMachineT m (c, a) (c, b)
forall (m :: * -> *) n c b d.
StateMachineT m n c
-> StateMachineT m b d -> StateMachineT m (n, b) (c, d)
Parallel StateMachineT m c c
forall a. StateMachineT m a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Control.Category.id

-- * Choice

-- | An instance of `Choice` allows us to have parallel composition of state
-- machines, meaning that we can pass two inputs to two state machines and get
-- out the outputs of both
instance Monad m => Choice (StateMachineT m) where
  left' :: StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)
  left' :: forall a b c.
StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)
left' = (StateMachineT m a b
 -> StateMachineT m c c
 -> StateMachineT m (Either a c) (Either b c))
-> StateMachineT m c c
-> StateMachineT m a b
-> StateMachineT m (Either a c) (Either b c)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateMachineT m a b
-> StateMachineT m c c -> StateMachineT m (Either a c) (Either b c)
forall (m :: * -> *) n c b d.
StateMachineT m n c
-> StateMachineT m b d -> StateMachineT m (Either n b) (Either c d)
Alternative StateMachineT m c c
forall a. StateMachineT m a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Control.Category.id

  right' :: StateMachineT m a b -> StateMachineT m (Either c a) (Either c b)
  right' :: forall a b c.
StateMachineT m a b -> StateMachineT m (Either c a) (Either c b)
right' = StateMachineT m c c
-> StateMachineT m a b -> StateMachineT m (Either c a) (Either c b)
forall (m :: * -> *) n c b d.
StateMachineT m n c
-> StateMachineT m b d -> StateMachineT m (Either n b) (Either c d)
Alternative StateMachineT m c c
forall a. StateMachineT m a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Control.Category.id

-- * Arrow

instance Monad m => Arrow (StateMachineT m) where
  arr :: (a -> b) -> StateMachineT m a b
  arr :: forall b c. (b -> c) -> StateMachineT m b c
arr = (a -> b) -> StateMachineT m a b
forall (m :: * -> *) a b.
Applicative m =>
(a -> b) -> StateMachineT m a b
stateless

  first :: StateMachineT m a b -> StateMachineT m (a, c) (b, c)
  first :: forall b c d. StateMachineT m b c -> StateMachineT m (b, d) (c, d)
first = StateMachineT m a b -> StateMachineT m (a, c) (b, c)
forall b c d. StateMachineT m b c -> StateMachineT m (b, d) (c, d)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (a, c) (b, c)
first'

-- * ArrowChoice

instance Monad m => ArrowChoice (StateMachineT m) where
  left :: StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)
  left :: forall b c d.
StateMachineT m b c -> StateMachineT m (Either b d) (Either c d)
left = StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)
forall b c d.
StateMachineT m b c -> StateMachineT m (Either b d) (Either c d)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left'

-- * Run a state machine

-- | Given an @input@, run the machine to get an output and a new version of
-- the machine
run :: Monad m => StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run :: forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run (Basic BaseMachineT m topology a b
baseMachine) a
a = (BaseMachineT m topology a b -> StateMachineT m a b)
-> (b, BaseMachineT m topology a b) -> (b, StateMachineT m a b)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second BaseMachineT m topology a b -> StateMachineT m a b
forall (m :: * -> *) n (c :: Topology n) input output.
(Demote n ~ n, SingKind n, SingI c, Eq n, Show n,
 RenderableVertices n) =>
BaseMachineT m c input output -> StateMachineT m input output
Basic ((b, BaseMachineT m topology a b) -> (b, StateMachineT m a b))
-> m (b, BaseMachineT m topology a b) -> m (b, StateMachineT m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BaseMachineT m topology a b
-> a -> m (b, BaseMachineT m topology a b)
forall {vertex} (m :: * -> *) (topology :: Topology vertex) input
       output.
Functor m =>
BaseMachineT m topology input output
-> input -> m (output, BaseMachineT m topology input output)
runBaseMachineT BaseMachineT m topology a b
baseMachine a
a
run (Sequential StateMachineT m a b
machine1 StateMachineT m b b
machine2) a
a = do
  (b
output1, StateMachineT m a b
machine1') <- StateMachineT m a b -> a -> m (b, StateMachineT m a b)
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m a b
machine1 a
a
  (b
output2, StateMachineT m b b
machine2') <- StateMachineT m b b -> b -> m (b, StateMachineT m b b)
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m b b
machine2 b
output1
  (b, StateMachineT m a b) -> m (b, StateMachineT m a b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
output2, StateMachineT m a b -> StateMachineT m b b -> StateMachineT m a b
forall (m :: * -> *) a n c.
StateMachineT m a n -> StateMachineT m n c -> StateMachineT m a c
Sequential StateMachineT m a b
machine1' StateMachineT m b b
machine2')
run (Parallel StateMachineT m a b
machine1 StateMachineT m c d
machine2) a
a = do
  (b
output1, StateMachineT m a b
machine1') <- StateMachineT m a b -> a -> m (b, StateMachineT m a b)
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m a b
machine1 ((a, c) -> a
forall a b. (a, b) -> a
fst a
(a, c)
a)
  (d
output2, StateMachineT m c d
machine2') <- StateMachineT m c d -> c -> m (d, StateMachineT m c d)
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m c d
machine2 ((a, c) -> c
forall a b. (a, b) -> b
snd a
(a, c)
a)
  (b, StateMachineT m a b) -> m (b, StateMachineT m a b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b
output1, d
output2), StateMachineT m a b
-> StateMachineT m c d -> StateMachineT m (a, c) (b, d)
forall (m :: * -> *) n c b d.
StateMachineT m n c
-> StateMachineT m b d -> StateMachineT m (n, b) (c, d)
Parallel StateMachineT m a b
machine1' StateMachineT m c d
machine2')
run (Alternative StateMachineT m a b
machine1 StateMachineT m c d
machine2) a
a =
  case a
a of
    Left a
a1 -> (b -> b)
-> (StateMachineT m a b -> StateMachineT m a b)
-> (b, StateMachineT m a b)
-> (b, StateMachineT m a b)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap b -> b
b -> Either b d
forall a b. a -> Either a b
Left (StateMachineT m a b
-> StateMachineT m c d -> StateMachineT m (Either a c) (Either b d)
forall (m :: * -> *) n c b d.
StateMachineT m n c
-> StateMachineT m b d -> StateMachineT m (Either n b) (Either c d)
`Alternative` StateMachineT m c d
machine2) ((b, StateMachineT m a b) -> (b, StateMachineT m a b))
-> m (b, StateMachineT m a b) -> m (b, StateMachineT m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateMachineT m a b -> a -> m (b, StateMachineT m a b)
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m a b
machine1 a
a1
    Right c
a2 -> (d -> b)
-> (StateMachineT m c d -> StateMachineT m a b)
-> (d, StateMachineT m c d)
-> (b, StateMachineT m a b)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap d -> b
d -> Either b d
forall a b. b -> Either a b
Right (StateMachineT m a b
machine1 `Alternative`) ((d, StateMachineT m c d) -> (b, StateMachineT m a b))
-> m (d, StateMachineT m c d) -> m (b, StateMachineT m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateMachineT m c d -> c -> m (d, StateMachineT m c d)
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m c d
machine2 c
a2
run (Feedback StateMachineT m a (n b)
machine1 StateMachineT m b (n a)
machine2) a
a = do
  (n b
bs, StateMachineT m a (n b)
machine1') <- StateMachineT m a (n b) -> a -> m (n b, StateMachineT m a (n b))
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m a (n b)
machine1 a
a
  (n a
as, StateMachineT m b (n a)
machine2') <- StateMachineT m b (n a) -> n b -> m (n a, StateMachineT m b (n a))
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
StateMachineT m a b -> f a -> m (b, StateMachineT m a b)
runMultiple StateMachineT m b (n a)
machine2 n b
bs
  (n b -> n b)
-> (n b, StateMachineT m a (n b)) -> (n b, StateMachineT m a (n b))
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (n b
bs <>) ((n b, StateMachineT m a (n b)) -> (b, StateMachineT m a b))
-> m (n b, StateMachineT m a (n b)) -> m (b, StateMachineT m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateMachineT m a (n b) -> n a -> m (n b, StateMachineT m a (n b))
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
StateMachineT m a b -> f a -> m (b, StateMachineT m a b)
runMultiple (StateMachineT m a (n b)
-> StateMachineT m b (n a) -> StateMachineT m a (n b)
forall (n :: * -> *) a c (m :: * -> *).
(Foldable n, Monoid (n a), Monoid (n c)) =>
StateMachineT m a (n c)
-> StateMachineT m c (n a) -> StateMachineT m a (n c)
Feedback StateMachineT m a (n b)
machine1' StateMachineT m b (n a)
machine2') n a
as
run (Kleisli StateMachineT m a (n b)
machine1 StateMachineT m b (n c)
machine2) a
a = do
  (n b
bs, StateMachineT m a (n b)
machine1') <- StateMachineT m a (n b) -> a -> m (n b, StateMachineT m a (n b))
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m a (n b)
machine1 a
a
  (n c
cs, StateMachineT m b (n c)
machine2') <- StateMachineT m b (n c) -> n b -> m (n c, StateMachineT m b (n c))
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
StateMachineT m a b -> f a -> m (b, StateMachineT m a b)
runMultiple StateMachineT m b (n c)
machine2 n b
bs
  (b, StateMachineT m a b) -> m (b, StateMachineT m a b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
n c
cs, StateMachineT m a (n b)
-> StateMachineT m b (n c) -> StateMachineT m a (n c)
forall (n :: * -> *) c (m :: * -> *) a b.
(Foldable n, Monoid (n c)) =>
StateMachineT m a (n b)
-> StateMachineT m b (n c) -> StateMachineT m a (n c)
Kleisli StateMachineT m a (n b)
machine1' StateMachineT m b (n c)
machine2')

-- | process multiple inputs in one go, accumulating the results in a monoid
runMultiple
  :: (Monad m, Foldable f, Monoid b)
  => StateMachineT m a b
  -> f a
  -> m (b, StateMachineT m a b)
runMultiple :: forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
StateMachineT m a b -> f a -> m (b, StateMachineT m a b)
runMultiple StateMachineT m a b
machine =
  ((b, StateMachineT m a b) -> a -> m (b, StateMachineT m a b))
-> (b, StateMachineT m a b) -> f a -> m (b, StateMachineT m a b)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
    (\(b
b, StateMachineT m a b
machine') a
a -> (b -> b) -> (b, StateMachineT m a b) -> (b, StateMachineT m a b)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (b
b <>) ((b, StateMachineT m a b) -> (b, StateMachineT m a b))
-> m (b, StateMachineT m a b) -> m (b, StateMachineT m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateMachineT m a b -> a -> m (b, StateMachineT m a b)
forall (m :: * -> *) a b.
Monad m =>
StateMachineT m a b -> a -> m (b, StateMachineT m a b)
run StateMachineT m a b
machine' a
a)
    (b
forall a. Monoid a => a
mempty, StateMachineT m a b
machine)