{-# LANGUAGE DataKinds #-}

-- | A `BaseMachine` is a Mealy machine constrained by a provided `Topology` of
-- allowed transitions.
module Crem.BaseMachine where

import Crem.Topology
import "base" Data.Bifunctor (Bifunctor (..), first)
import "base" Data.Functor.Identity (Identity (..))
import "base" Data.Kind (Type)
import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
import "singletons-base" Data.Singletons.Base.TH (STuple0 (..))

-- * Specifying state machines

-- | A @BaseMachineT m topology input output@ describes a state machine with
-- allowed transitions constrained by a given @topology@.
-- A state machine is composed by an `initialState` and an `action`, which
-- defines the @output@ and the new @state@ given the current @state@ and an
-- @input@.
-- The @m@ parameter describes the context where the `action` of the machine is
-- executed
data
  BaseMachineT
    m
    (topology :: Topology vertex)
    (input :: Type)
    (output :: Type) = forall state.
  BaseMachineT
  { ()
initialState :: InitialState state
  , ()
action
      :: forall initialVertex
       . state initialVertex
      -> input
      -> ActionResult m topology state initialVertex output
  }

-- | A `BaseMachine` 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 BaseMachine
  (topology :: Topology vertex)
  (input :: Type)
  (output :: Type) =
  forall m. Monad m => BaseMachineT m topology input output

-- * 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@
baseHoist
  :: (forall x. m x -> n x)
  -> BaseMachineT m topology a b
  -> BaseMachineT n topology a b
baseHoist :: 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 forall x. m x -> n x
f (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action) =
  InitialState state
-> (forall (initialVertex :: vertex).
    state initialVertex
    -> a -> ActionResult n topology state initialVertex b)
-> BaseMachineT n topology a b
forall vertex (m :: * -> *) (topology :: Topology vertex) input
       output (state :: vertex -> *).
InitialState state
-> (forall (initialVertex :: vertex).
    state initialVertex
    -> input -> ActionResult m topology state initialVertex output)
-> BaseMachineT m topology input output
BaseMachineT
    InitialState state
initialState
    (((forall x. m x -> n x)
-> ActionResult m topology state initialVertex b
-> ActionResult n topology state initialVertex b
forall {vertex} (m :: * -> *) (n :: * -> *)
       (topology :: Topology vertex) (state :: vertex -> *)
       (initialVertex :: vertex) output.
(forall x. m x -> n x)
-> ActionResult m topology state initialVertex output
-> ActionResult n topology state initialVertex output
hoistResult m x -> n x
forall x. m x -> n x
f .) ((a -> ActionResult m topology state initialVertex b)
 -> a -> ActionResult n topology state initialVertex b)
-> (state initialVertex
    -> a -> ActionResult m topology state initialVertex b)
-> state initialVertex
-> a
-> ActionResult n topology state initialVertex b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state initialVertex
-> a -> ActionResult m topology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action)

instance Functor m => Profunctor (BaseMachineT m topology) where
  lmap :: (a -> b) -> BaseMachineT m topology b c -> BaseMachineT m topology a c
  lmap :: forall a b c.
(a -> b)
-> BaseMachineT m topology b c -> BaseMachineT m topology a c
lmap a -> b
f (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> b -> ActionResult m topology state initialVertex c
action) =
    BaseMachineT
      { initialState :: InitialState state
initialState = InitialState state
initialState
      , action :: forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex c
action = ((b -> ActionResult m topology state initialVertex c)
-> (a -> b) -> a -> ActionResult m topology state initialVertex c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) ((b -> ActionResult m topology state initialVertex c)
 -> a -> ActionResult m topology state initialVertex c)
-> (state initialVertex
    -> b -> ActionResult m topology state initialVertex c)
-> state initialVertex
-> a
-> ActionResult m topology state initialVertex c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state initialVertex
-> b -> ActionResult m topology state initialVertex c
forall (initialVertex :: vertex).
state initialVertex
-> b -> ActionResult m topology state initialVertex c
action
      }

  rmap :: (b -> c) -> BaseMachineT m topology a b -> BaseMachineT m topology a c
  rmap :: forall b c a.
(b -> c)
-> BaseMachineT m topology a b -> BaseMachineT m topology a c
rmap b -> c
f (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action) =
    BaseMachineT
      { initialState :: InitialState state
initialState = InitialState state
initialState
      , action :: forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex c
action = ((b -> c
f <$>) .) ((a -> ActionResult m topology state initialVertex b)
 -> a -> ActionResult m topology state initialVertex c)
-> (state initialVertex
    -> a -> ActionResult m topology state initialVertex b)
-> state initialVertex
-> a
-> ActionResult m topology state initialVertex c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. state initialVertex
-> a -> ActionResult m topology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action
      }

instance Functor m => Strong (BaseMachineT m topology) where
  first' :: BaseMachineT m topology a b -> BaseMachineT m topology (a, c) (b, c)
  first' :: forall a b c.
BaseMachineT m topology a b
-> BaseMachineT m topology (a, c) (b, c)
first' (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action) =
    BaseMachineT
      { initialState :: InitialState state
initialState = InitialState state
initialState
      , action :: forall (initialVertex :: vertex).
state initialVertex
-> (a, c) -> ActionResult m topology state initialVertex (b, c)
action = \state initialVertex
state (a
a, c
c) -> (,c
c) (b -> (b, c))
-> ActionResult m topology state initialVertex b
-> ActionResult m topology state initialVertex (b, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state initialVertex
-> a -> ActionResult m topology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action state initialVertex
state a
a
      }

  second' :: BaseMachineT m topology a b -> BaseMachineT m topology (c, a) (c, b)
  second' :: forall a b c.
BaseMachineT m topology a b
-> BaseMachineT m topology (c, a) (c, b)
second' (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action) =
    BaseMachineT
      { initialState :: InitialState state
initialState = InitialState state
initialState
      , action :: forall (initialVertex :: vertex).
state initialVertex
-> (c, a) -> ActionResult m topology state initialVertex (c, b)
action = \state initialVertex
state (c
c, a
a) -> (c
c,) (b -> (c, b))
-> ActionResult m topology state initialVertex b
-> ActionResult m topology state initialVertex (c, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state initialVertex
-> a -> ActionResult m topology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action state initialVertex
state a
a
      }

instance Applicative m => Choice (BaseMachineT m topology) where
  left' :: BaseMachineT m topology a b -> BaseMachineT m topology (Either a c) (Either b c)
  left' :: forall a b c.
BaseMachineT m topology a b
-> BaseMachineT m topology (Either a c) (Either b c)
left' (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action) =
    BaseMachineT
      { initialState :: InitialState state
initialState = InitialState state
initialState
      , action :: forall (initialVertex :: vertex).
state initialVertex
-> Either a c
-> ActionResult m topology state initialVertex (Either b c)
action = \state initialVertex
state -> \case
          Left a
a -> b -> Either b c
forall a b. a -> Either a b
Left (b -> Either b c)
-> ActionResult m topology state initialVertex b
-> ActionResult m topology state initialVertex (Either b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state initialVertex
-> a -> ActionResult m topology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action state initialVertex
state a
a
          Right c
c -> m (Either b c, state initialVertex)
-> ActionResult m topology state initialVertex (Either b c)
forall {vertex} (topology :: Topology vertex)
       (initialVertex :: vertex) (vertex :: vertex) (m :: * -> *) output
       (state :: vertex -> *).
AllowedTransition topology initialVertex vertex =>
m (output, state vertex)
-> ActionResult m topology state initialVertex output
ActionResult (m (Either b c, state initialVertex)
 -> ActionResult m topology state initialVertex (Either b c))
-> m (Either b c, state initialVertex)
-> ActionResult m topology state initialVertex (Either b c)
forall a b. (a -> b) -> a -> b
$ (Either b c, state initialVertex)
-> m (Either b c, state initialVertex)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> Either b c
forall a b. b -> Either a b
Right c
c, state initialVertex
state)
      }

  right' :: BaseMachineT m topology a b -> BaseMachineT m topology (Either c a) (Either c b)
  right' :: forall a b c.
BaseMachineT m topology a b
-> BaseMachineT m topology (Either c a) (Either c b)
right' (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action) =
    BaseMachineT
      { initialState :: InitialState state
initialState = InitialState state
initialState
      , action :: forall (initialVertex :: vertex).
state initialVertex
-> Either c a
-> ActionResult m topology state initialVertex (Either c b)
action = \state initialVertex
state -> \case
          Left c
c -> m (Either c b, state initialVertex)
-> ActionResult m topology state initialVertex (Either c b)
forall {vertex} (topology :: Topology vertex)
       (initialVertex :: vertex) (vertex :: vertex) (m :: * -> *) output
       (state :: vertex -> *).
AllowedTransition topology initialVertex vertex =>
m (output, state vertex)
-> ActionResult m topology state initialVertex output
ActionResult (m (Either c b, state initialVertex)
 -> ActionResult m topology state initialVertex (Either c b))
-> m (Either c b, state initialVertex)
-> ActionResult m topology state initialVertex (Either c b)
forall a b. (a -> b) -> a -> b
$ (Either c b, state initialVertex)
-> m (Either c b, state initialVertex)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c -> Either c b
forall a b. a -> Either a b
Left c
c, state initialVertex
state)
          Right a
a -> b -> Either c b
forall a b. b -> Either a b
Right (b -> Either c b)
-> ActionResult m topology state initialVertex b
-> ActionResult m topology state initialVertex (Either c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state initialVertex
-> a -> ActionResult m topology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action state initialVertex
state a
a
      }

-- | A value of type @InitialState state@ describes the initial state of a
-- state machine, describing the initial @vertex@ in the @topology@ and the
-- actual initial data of type @state vertex@
data InitialState (state :: vertex -> Type) where
  InitialState :: state vertex -> InitialState state

-- | The result of an action of the state machine.
-- An @ActionResult m topology state initialVertex output@ contains an @output@
-- and a @state finalVertex@, where the transition from @initialVertex@ to
-- @finalVertex@ is allowed by the machine @topology@
data
  ActionResult
    m
    (topology :: Topology vertex)
    (state :: vertex -> Type)
    (initialVertex :: vertex)
    (output :: Type)
  where
  ActionResult
    :: AllowedTransition topology initialVertex finalVertex
    => m (output, state finalVertex)
    -> ActionResult m topology state initialVertex output

-- | Allows to change the computational context of an `ActionResult` from @m@
-- to @n@, given we have a [natural transformation](https://stackoverflow.com/a/58364172/2718064)
-- from @m@ to @n@.
hoistResult
  :: (forall x. m x -> n x)
  -> ActionResult m topology state initialVertex output
  -> ActionResult n topology state initialVertex output
hoistResult :: forall {vertex} (m :: * -> *) (n :: * -> *)
       (topology :: Topology vertex) (state :: vertex -> *)
       (initialVertex :: vertex) output.
(forall x. m x -> n x)
-> ActionResult m topology state initialVertex output
-> ActionResult n topology state initialVertex output
hoistResult forall x. m x -> n x
f (ActionResult m (output, state finalVertex)
outputStatePair) = n (output, state finalVertex)
-> ActionResult n topology state initialVertex output
forall {vertex} (topology :: Topology vertex)
       (initialVertex :: vertex) (vertex :: vertex) (m :: * -> *) output
       (state :: vertex -> *).
AllowedTransition topology initialVertex vertex =>
m (output, state vertex)
-> ActionResult m topology state initialVertex output
ActionResult (n (output, state finalVertex)
 -> ActionResult n topology state initialVertex output)
-> n (output, state finalVertex)
-> ActionResult n topology state initialVertex output
forall a b. (a -> b) -> a -> b
$ m (output, state finalVertex) -> n (output, state finalVertex)
forall x. m x -> n x
f m (output, state finalVertex)
outputStatePair

instance Functor m => Functor (ActionResult m topology state initialVertex) where
  fmap
    :: (a -> b)
    -> ActionResult m topology state initialVertex a
    -> ActionResult m topology state initialVertex b
  fmap :: forall a b.
(a -> b)
-> ActionResult m topology state initialVertex a
-> ActionResult m topology state initialVertex b
fmap a -> b
f (ActionResult m (a, state finalVertex)
outputStatePair) =
    m (b, state finalVertex)
-> ActionResult m topology state initialVertex b
forall {vertex} (topology :: Topology vertex)
       (initialVertex :: vertex) (vertex :: vertex) (m :: * -> *) output
       (state :: vertex -> *).
AllowedTransition topology initialVertex vertex =>
m (output, state vertex)
-> ActionResult m topology state initialVertex output
ActionResult (m (b, state finalVertex)
 -> ActionResult m topology state initialVertex b)
-> m (b, state finalVertex)
-> ActionResult m topology state initialVertex b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> (a, state finalVertex) -> (b, state finalVertex)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f ((a, state finalVertex) -> (b, state finalVertex))
-> m (a, state finalVertex) -> m (b, state finalVertex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a, state finalVertex)
outputStatePair

-- | Create an `ActionResult` without performing any side effect in the @m@
-- context
pureResult
  :: (Applicative m, AllowedTransition topology initialVertex finalVertex)
  => output
  -> state finalVertex
  -> ActionResult m topology state initialVertex output
pureResult :: forall {vertex} (m :: * -> *) (topology :: Topology vertex)
       (initialVertex :: vertex) (finalVertex :: vertex) output
       (state :: vertex -> *).
(Applicative m,
 AllowedTransition topology initialVertex finalVertex) =>
output
-> state finalVertex
-> ActionResult m topology state initialVertex output
pureResult output
output state finalVertex
state = m (output, state finalVertex)
-> ActionResult m topology state initialVertex output
forall {vertex} (topology :: Topology vertex)
       (initialVertex :: vertex) (vertex :: vertex) (m :: * -> *) output
       (state :: vertex -> *).
AllowedTransition topology initialVertex vertex =>
m (output, state vertex)
-> ActionResult m topology state initialVertex output
ActionResult (m (output, state finalVertex)
 -> ActionResult m topology state initialVertex output)
-> ((output, state finalVertex) -> m (output, state finalVertex))
-> (output, state finalVertex)
-> ActionResult m topology state initialVertex output
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (output, state finalVertex) -> m (output, state finalVertex)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((output, state finalVertex)
 -> ActionResult m topology state initialVertex output)
-> (output, state finalVertex)
-> ActionResult m topology state initialVertex output
forall a b. (a -> b) -> a -> b
$ (output
output, state finalVertex
state)

-- | This is fairly similar to `sequenceA` from `Data.Traversable` and in fact
-- it does the same job, with the slight difference that `sequenceA` would
-- return @f (ActionResult Identity topology state initialVertex output)@
sequence
  :: Functor f
  => ActionResult Identity topology state initialVertex (f output)
  -> ActionResult f topology state initialVertex output
sequence :: forall {vertex} (f :: * -> *) (topology :: Topology vertex)
       (state :: vertex -> *) (initialVertex :: vertex) output.
Functor f =>
ActionResult Identity topology state initialVertex (f output)
-> ActionResult f topology state initialVertex output
sequence (ActionResult (Identity (f output
outputs, state finalVertex
state))) =
  f (output, state finalVertex)
-> ActionResult f topology state initialVertex output
forall {vertex} (topology :: Topology vertex)
       (initialVertex :: vertex) (vertex :: vertex) (m :: * -> *) output
       (state :: vertex -> *).
AllowedTransition topology initialVertex vertex =>
m (output, state vertex)
-> ActionResult m topology state initialVertex output
ActionResult (f (output, state finalVertex)
 -> ActionResult f topology state initialVertex output)
-> f (output, state finalVertex)
-> ActionResult f topology state initialVertex output
forall a b. (a -> b) -> a -> b
$ (,state finalVertex
state) (output -> (output, state finalVertex))
-> f output -> f (output, state finalVertex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f output
outputs

-- ** Lift machines

-- | Lift a @BaseMachineT@ to operate with `Maybe` inputs and outputs. If the
-- input is a `Nothing`, then the output will be a `Nothing`. If the input is a
-- `Just`, then the machine will be used to compute the output.
maybeM
  :: Applicative m
  => BaseMachineT m topology a b
  -> BaseMachineT m topology (Maybe a) (Maybe b)
maybeM :: forall {vertex} (m :: * -> *) (topology :: Topology vertex) a b.
Applicative m =>
BaseMachineT m topology a b
-> BaseMachineT m topology (Maybe a) (Maybe b)
maybeM (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action) =
  BaseMachineT
    { initialState :: InitialState state
initialState = InitialState state
initialState
    , action :: forall (initialVertex :: vertex).
state initialVertex
-> Maybe a -> ActionResult m topology state initialVertex (Maybe b)
action = \state initialVertex
initialState' -> \case
        Maybe a
Nothing -> Maybe b
-> state initialVertex
-> ActionResult m topology state initialVertex (Maybe b)
forall {vertex} (m :: * -> *) (topology :: Topology vertex)
       (initialVertex :: vertex) (finalVertex :: vertex) output
       (state :: vertex -> *).
(Applicative m,
 AllowedTransition topology initialVertex finalVertex) =>
output
-> state finalVertex
-> ActionResult m topology state initialVertex output
pureResult Maybe b
forall a. Maybe a
Nothing state initialVertex
initialState'
        Just a
a -> b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b)
-> ActionResult m topology state initialVertex b
-> ActionResult m topology state initialVertex (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state initialVertex
-> a -> ActionResult m topology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action state initialVertex
initialState' a
a
    }

-- | Lift a @BaseMachineT@ to operate with `Either` inputs and outputs. If the
-- input is a `Left`, then the output will be that `Left`. If the input is a
-- `Right`, then the machine will be used to compute the output.
eitherM
  :: Applicative m
  => BaseMachineT m topology a b
  -> BaseMachineT m topology (Either e a) (Either e b)
eitherM :: forall {vertex} (m :: * -> *) (topology :: Topology vertex) a b e.
Applicative m =>
BaseMachineT m topology a b
-> BaseMachineT m topology (Either e a) (Either e b)
eitherM (BaseMachineT InitialState state
initialState forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action) =
  BaseMachineT
    { initialState :: InitialState state
initialState = InitialState state
initialState
    , action :: forall (initialVertex :: vertex).
state initialVertex
-> Either e a
-> ActionResult m topology state initialVertex (Either e b)
action = \state initialVertex
initialState' -> \case
        Left e
e -> Either e b
-> state initialVertex
-> ActionResult m topology state initialVertex (Either e b)
forall {vertex} (m :: * -> *) (topology :: Topology vertex)
       (initialVertex :: vertex) (finalVertex :: vertex) output
       (state :: vertex -> *).
(Applicative m,
 AllowedTransition topology initialVertex finalVertex) =>
output
-> state finalVertex
-> ActionResult m topology state initialVertex output
pureResult (e -> Either e b
forall a b. a -> Either a b
Left e
e) state initialVertex
initialState'
        Right a
a -> b -> Either e b
forall a b. b -> Either a b
Right (b -> Either e b)
-> ActionResult m topology state initialVertex b
-> ActionResult m topology state initialVertex (Either e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> state initialVertex
-> a -> ActionResult m topology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m topology state initialVertex b
action state initialVertex
initialState' a
a
    }

-- ** Stateless machines

-- | `statelessBaseT` transforms its input to its output and never changes its
-- state
statelessBaseT :: Applicative m => (a -> m b) -> BaseMachineT m (TrivialTopology @()) a b
statelessBaseT :: forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> BaseMachineT m TrivialTopology a b
statelessBaseT a -> m b
f =
  BaseMachineT
    { initialState :: InitialState STuple0
initialState = STuple0 '() -> InitialState STuple0
forall {vertex} (state :: vertex -> *) (vertex :: vertex).
state vertex -> InitialState state
InitialState STuple0 '()
STuple0
    , action :: forall (initialVertex :: ()).
STuple0 initialVertex
-> a -> ActionResult m ('Topology '[]) STuple0 initialVertex b
action = \STuple0 initialVertex
state a
input ->
        m (b, STuple0 initialVertex)
-> ActionResult m ('Topology '[]) STuple0 initialVertex b
forall {vertex} (topology :: Topology vertex)
       (initialVertex :: vertex) (vertex :: vertex) (m :: * -> *) output
       (state :: vertex -> *).
AllowedTransition topology initialVertex vertex =>
m (output, state vertex)
-> ActionResult m topology state initialVertex output
ActionResult (m (b, STuple0 initialVertex)
 -> ActionResult m ('Topology '[]) STuple0 initialVertex b)
-> m (b, STuple0 initialVertex)
-> ActionResult m ('Topology '[]) STuple0 initialVertex b
forall a b. (a -> b) -> a -> b
$ (,STuple0 initialVertex
state) (b -> (b, STuple0 initialVertex))
-> m b -> m (b, STuple0 initialVertex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m b
f a
input
    }

-- | `statelessBase` transforms its input to its output and never changes its
-- state, without performing any side effect
statelessBase :: (a -> b) -> BaseMachine (TrivialTopology @()) a b
statelessBase :: forall a b. (a -> b) -> BaseMachine TrivialTopology a b
statelessBase a -> b
f = (a -> m b) -> BaseMachineT m TrivialTopology a b
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> BaseMachineT m TrivialTopology a b
statelessBaseT (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
. a -> b
f)

-- ** Identity machine

-- | The `identity` machine simply outputs its input and never changes its
-- state.
identity :: BaseMachine (TrivialTopology @()) a a
identity :: forall a (m :: * -> *).
Monad m =>
BaseMachineT m TrivialTopology a a
identity = (a -> a) -> BaseMachine TrivialTopology a a
forall a b. (a -> b) -> BaseMachine TrivialTopology a b
statelessBase a -> a
forall a. a -> a
id

-- ** Unrestricted machines

-- | a machine modelled with explicit state, where every transition is allowed
unrestrictedBaseMachineT
  :: (forall initialVertex. state initialVertex -> a -> ActionResult m (AllowAllTopology @vertex) state initialVertex b)
  -> InitialState (state :: vertex -> Type)
  -> BaseMachineT m (AllowAllTopology @vertex) a b
unrestrictedBaseMachineT :: 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 forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m AllowAllTopology state initialVertex b
action InitialState state
initialState =
  BaseMachineT
    { initialState :: InitialState state
initialState = InitialState state
initialState
    , action :: forall (initialVertex :: vertex).
state initialVertex
-> a
-> ActionResult
     m
     ('Topology
        (Let6989586621679177149Go
           ((++@#@$) .@#@$$$ Lambda_6989586621679106594Sym0)
           '[]
           (EnumFromTo MinBound MaxBound)
           (EnumFromTo MinBound MaxBound)))
     state
     initialVertex
     b
action = state initialVertex
-> a
-> ActionResult
     m
     ('Topology
        (Let6989586621679177149Go
           ((++@#@$) .@#@$$$ Lambda_6989586621679106594Sym0)
           '[]
           (EnumFromTo MinBound MaxBound)
           (EnumFromTo MinBound MaxBound)))
     state
     initialVertex
     b
state initialVertex
-> a -> ActionResult m AllowAllTopology state initialVertex b
forall (initialVertex :: vertex).
state initialVertex
-> a
-> ActionResult
     m
     ('Topology
        (Let6989586621679177149Go
           ((++@#@$) .@#@$$$ Lambda_6989586621679106594Sym0)
           '[]
           (EnumFromTo MinBound MaxBound)
           (EnumFromTo MinBound MaxBound)))
     state
     initialVertex
     b
forall (initialVertex :: vertex).
state initialVertex
-> a -> ActionResult m AllowAllTopology state initialVertex b
action
    }

-- ** Run a machine

-- | Given an @input@, run the machine to get an output and a new version of
-- the machine
runBaseMachineT
  :: Functor m
  => BaseMachineT m topology input output
  -> input
  -> m (output, BaseMachineT m topology input output)
runBaseMachineT :: 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 (InitialState state vertex
initialState) forall (initialVertex :: vertex).
state initialVertex
-> input -> ActionResult m topology state initialVertex output
action) input
input =
  case state vertex
-> input -> ActionResult m topology state vertex output
forall (initialVertex :: vertex).
state initialVertex
-> input -> ActionResult m topology state initialVertex output
action state vertex
initialState input
input of
    ActionResult m (output, state finalVertex)
outputStatePair ->
      (state finalVertex -> BaseMachineT m topology input output)
-> (output, state finalVertex)
-> (output, BaseMachineT m topology input output)
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
        ( \state finalVertex
finalState ->
            BaseMachineT
              { initialState :: InitialState state
initialState = state finalVertex -> InitialState state
forall {vertex} (state :: vertex -> *) (vertex :: vertex).
state vertex -> InitialState state
InitialState state finalVertex
finalState
              , action :: forall (initialVertex :: vertex).
state initialVertex
-> input -> ActionResult m topology state initialVertex output
action = state initialVertex
-> input -> ActionResult m topology state initialVertex output
forall (initialVertex :: vertex).
state initialVertex
-> input -> ActionResult m topology state initialVertex output
action
              }
        )
        ((output, state finalVertex)
 -> (output, BaseMachineT m topology input output))
-> m (output, state finalVertex)
-> m (output, BaseMachineT m topology input output)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (output, state finalVertex)
outputStatePair