allow machines to execute effects when emitting output

spec/CRM/Example/BooleanStateMachine.hs

@@ -15,11 +15,11 @@ booleanStateMachine initialState =
     ( \state input -> case state of
         SFalse ->
           if even input
-            then ActionResult SFalse (input + 1)
-            else ActionResult STrue (input * 3)
+            then pureResult (input + 1) SFalse
+            else pureResult (input * 3) STrue
         STrue ->
           if even input
-            then ActionResult STrue (input - 1)
-            else ActionResult SFalse (input * 5)
+            then pureResult (input - 1) STrue
+            else pureResult (input * 5) SFalse
     )
     (InitialState initialState)

spec/CRM/Example/LockDoor.hs

@@ -47,22 +47,22 @@ data LockDoorEvent
 
 lockDoorMachine :: SLockDoorVertex a -> BaseMachine LockDoorTopology LockDoorCommand LockDoorEvent
 lockDoorMachine initialState =
-  BaseMachine
+  BaseMachineT
     { initialState = InitialState initialState
     , action = \case
         SIsLockOpen -> \case
-          LockOpen -> ActionResult SIsLockOpen LockNoOp
-          LockClose -> ActionResult SIsLockClosed LockClosed
-          LockLock -> ActionResult SIsLockOpen LockNoOp
-          LockUnlock -> ActionResult SIsLockOpen LockNoOp
+          LockOpen -> pureResult LockNoOp SIsLockOpen
+          LockClose -> pureResult LockClosed SIsLockClosed
+          LockLock -> pureResult LockNoOp SIsLockOpen
+          LockUnlock -> pureResult LockNoOp SIsLockOpen
         SIsLockClosed -> \case
-          LockOpen -> ActionResult SIsLockOpen LockOpened
-          LockClose -> ActionResult SIsLockClosed LockNoOp
-          LockLock -> ActionResult SIsLockLocked LockLocked
-          LockUnlock -> ActionResult SIsLockClosed LockNoOp
+          LockOpen -> pureResult LockOpened SIsLockOpen
+          LockClose -> pureResult LockNoOp SIsLockClosed
+          LockLock -> pureResult LockLocked SIsLockLocked
+          LockUnlock -> pureResult LockNoOp SIsLockClosed
         SIsLockLocked -> \case
-          LockOpen -> ActionResult SIsLockLocked LockNoOp
-          LockClose -> ActionResult SIsLockLocked LockNoOp
-          LockLock -> ActionResult SIsLockLocked LockNoOp
-          LockUnlock -> ActionResult SIsLockClosed LockUnlocked
+          LockOpen -> pureResult LockNoOp SIsLockLocked
+          LockClose -> pureResult LockNoOp SIsLockLocked
+          LockLock -> pureResult LockNoOp SIsLockLocked
+          LockUnlock -> pureResult LockUnlocked SIsLockClosed
     }

spec/CRM/Example/OneState.hs

@@ -9,7 +9,7 @@ import "singletons-base" Data.Singletons.Base.TH
 
 oneVertexMachine :: BaseMachine (TrivialTopology @()) () ()
 oneVertexMachine =
-  BaseMachine
+  BaseMachineT
     { initialState = InitialState STuple0
-    , action = \STuple0 _ -> ActionResult STuple0 ()
+    , action = \STuple0 _ -> pureResult () STuple0
     }

src/CRM/BaseMachine.hs

@@ -3,92 +3,115 @@
 module CRM.BaseMachine where
 
 import CRM.Topology
+import "base" Data.Bifunctor (Bifunctor (..), first)
 import "base" Data.Kind (Type)
-import "base" Data.List.NonEmpty (NonEmpty (..))
+
+-- import "base" Data.List.NonEmpty (NonEmpty (..))
 import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
-import "profunctors" Data.Profunctor.Sieve (Cosieve (..))
+
+-- import "profunctors" Data.Profunctor.Sieve (Cosieve (..))
+
+import "base" Data.Functor.Identity (Identity (..))
 import "singletons-base" Data.Singletons.Base.TH (STuple0 (..))
 
 -- * Specifying state machines
 
--- | A `BaseMachine topology input output` describes a state machine with
+-- | A `BaseMachineT 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`
 data
-  BaseMachine
+  BaseMachineT
+    m
     (topology :: Topology vertex)
     (input :: Type)
     (output :: Type) = forall state.
-  BaseMachine
+  BaseMachineT
   { initialState :: InitialState state
   , action
       :: forall initialVertex
        . state initialVertex
       -> input
-      -> ActionResult topology state initialVertex output
+      -> ActionResult m topology state initialVertex output
   }
 
-instance Profunctor (BaseMachine topology) where
-  lmap :: (a -> b) -> BaseMachine topology b c -> BaseMachine topology a c
-  lmap f (BaseMachine initialState action) =
-    BaseMachine
+type BaseMachine
+  (topology :: Topology vertex)
+  (input :: Type)
+  (output :: Type) =
+  forall m. Monad m => BaseMachineT m topology input output
+
+-- * Hoist
+
+baseHoist
+  :: (forall x. m x -> n x)
+  -> BaseMachineT m topology a b
+  -> BaseMachineT n topology a b
+baseHoist f (BaseMachineT initialState action) =
+  BaseMachineT
+    initialState
+    ((hoistResult f .) . action)
+
+instance Functor m => Profunctor (BaseMachineT m topology) where
+  lmap :: (a -> b) -> BaseMachineT m topology b c -> BaseMachineT m topology a c
+  lmap f (BaseMachineT initialState action) =
+    BaseMachineT
       { initialState = initialState
       , action = (. f) . action
       }
 
-  rmap :: (b -> c) -> BaseMachine topology a b -> BaseMachine topology a c
-  rmap f (BaseMachine initialState action) =
-    BaseMachine
+  rmap :: (b -> c) -> BaseMachineT m topology a b -> BaseMachineT m topology a c
+  rmap f (BaseMachineT initialState action) =
+    BaseMachineT
       { initialState = initialState
       , action = ((f <$>) .) . action
       }
 
-instance Strong (BaseMachine topology) where
-  first' :: BaseMachine topology a b -> BaseMachine topology (a, c) (b, c)
-  first' (BaseMachine initialState action) =
-    BaseMachine
+instance Functor m => Strong (BaseMachineT m topology) where
+  first' :: BaseMachineT m topology a b -> BaseMachineT m topology (a, c) (b, c)
+  first' (BaseMachineT initialState action) =
+    BaseMachineT
       { initialState = initialState
       , action = \state (a, c) -> (,c) <$> action state a
       }
 
-  second' :: BaseMachine topology a b -> BaseMachine topology (c, a) (c, b)
-  second' (BaseMachine initialState action) =
-    BaseMachine
+  second' :: BaseMachineT m topology a b -> BaseMachineT m topology (c, a) (c, b)
+  second' (BaseMachineT initialState action) =
+    BaseMachineT
       { initialState = initialState
       , action = \state (c, a) -> (c,) <$> action state a
       }
 
-instance Choice (BaseMachine topology) where
-  left' :: BaseMachine topology a b -> BaseMachine topology (Either a c) (Either b c)
-  left' (BaseMachine initialState action) =
-    BaseMachine
+instance Applicative m => Choice (BaseMachineT m topology) where
+  left' :: BaseMachineT m topology a b -> BaseMachineT m topology (Either a c) (Either b c)
+  left' (BaseMachineT initialState action) =
+    BaseMachineT
       { initialState = initialState
       , action = \state -> \case
           Left a -> Left <$> action state a
-          Right c -> ActionResult state (Right c)
+          Right c -> ActionResult $ pure (Right c, state)
       }
 
-  right' :: BaseMachine topology a b -> BaseMachine topology (Either c a) (Either c b)
-  right' (BaseMachine initialState action) =
-    BaseMachine
+  right' :: BaseMachineT m topology a b -> BaseMachineT m topology (Either c a) (Either c b)
+  right' (BaseMachineT initialState action) =
+    BaseMachineT
       { initialState = initialState
       , action = \state -> \case
-          Left c -> ActionResult state (Left c)
+          Left c -> ActionResult $ pure (Left c, state)
           Right a -> Right <$> action state a
       }
 
--- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Sieve.html#v:cosieve
--- This is basically saying that we can interpret a `BaseMachine topology a b`
--- as a function from a `NonEmpty a` to `b`
-instance Cosieve (BaseMachine topology) NonEmpty where
-  cosieve :: BaseMachine topology a b -> NonEmpty a -> b
-  cosieve machine (a0 :| as0) =
-    case runBaseMachine machine a0 of
-      (b, machine') -> case as0 of
-        [] -> b
-        a1 : as1 -> cosieve machine' (a1 :| as1)
+-- -- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Sieve.html#v:cosieve
+-- -- This is basically saying that we can interpret a `BaseMachineT m topology a b`
+-- -- as a function from a `NonEmpty a` to `b`
+-- instance Cosieve (BaseMachineT m topology) NonEmpty where
+--   cosieve :: BaseMachineT m topology a b -> NonEmpty a -> m b
+--   cosieve machine (a0 :| as0) =
+--     case runBaseMachineT machine a0 of
+--       (b, machine') -> case as0 of
+--         [] -> b
+--         a1 : as1 -> cosieve machine' (a1 :| as1)
 
 -- | A value of type `InitialState state` describes the initial state of a
 -- state machine, describing the initial `vertex` in the `topology` and the
@@ -101,6 +124,7 @@ data InitialState (state :: vertex -> Type) where
 -- where the transition from `initialVertex` to `finalVertex` is allowed by the machine `topology`
 data
   ActionResult
+    m
     (topology :: Topology vertex)
     (state :: vertex -> Type)
     (initialVertex :: vertex)
@@ -108,44 +132,65 @@ data
   where
   ActionResult
     :: AllowedTransition topology initialVertex finalVertex
-    => state finalVertex
-    -> output
-    -> ActionResult topology state initialVertex output
+    => m (output, state finalVertex)
+    -> ActionResult m topology state initialVertex output
 
-instance Functor (ActionResult topology state initialVertex) where
+hoistResult
+  :: (forall x. m x -> n x)
+  -> ActionResult m topology state initialVertex output
+  -> ActionResult n topology state initialVertex output
+hoistResult f (ActionResult outputStatePair) = ActionResult $ f outputStatePair
+
+instance Functor m => Functor (ActionResult m topology state initialVertex) where
   fmap
     :: (a -> b)
-    -> ActionResult topology state initialVertex a
-    -> ActionResult topology state initialVertex b
-  fmap f (ActionResult state output) =
-    ActionResult state (f output)
+    -> ActionResult m topology state initialVertex a
+    -> ActionResult m topology state initialVertex b
+  fmap f (ActionResult outputStatePair) =
+    ActionResult $ first f <$> outputStatePair
+
+pureResult
+  :: (Applicative m, AllowedTransition topology initialVertex finalVertex)
+  => output
+  -> state finalVertex
+  -> ActionResult m topology state initialVertex output
+pureResult output state = ActionResult . pure $ (output, state)
+
+sequence
+  :: ActionResult Identity topology state initialVertex [output]
+  -> ActionResult [] topology state initialVertex output
+sequence (ActionResult (Identity (outputs, state))) =
+  ActionResult $ (,state) <$> outputs
 
 -- ** Stateless machines
 
--- | The `statelessBase` transforms its input to its output and never changes its state
-statelessBase :: (a -> b) -> BaseMachine (TrivialTopology @()) a b
-statelessBase f =
-  BaseMachine
+-- | The `statelessBaseT` transforms its input to its output and never changes its state
+statelessBaseT :: Applicative m => (a -> m b) -> BaseMachineT m (TrivialTopology @()) a b
+statelessBaseT f =
+  BaseMachineT
     { initialState = InitialState STuple0
     , action = \state input ->
-        ActionResult state $ f input
+        ActionResult $ (,state) <$> f input
     }
 
+statelessBase :: (a -> b) -> BaseMachine (TrivialTopology @()) a b
+statelessBase f = statelessBaseT (pure . f)
+
 -- ** Identity machine
 
 -- | The `identity` machine simply outputs its input and never changes its state. It is the result of `statelessBase id`.
 identity :: BaseMachine (TrivialTopology @()) a a
 identity = statelessBase id
 
--- ** Unfold
+-- ** Unrestricted machines
 
 -- | a machine modelled with explicit state, where every transition is allowed
-unrestrictedBaseMachine
-  :: (forall initialVertex. state initialVertex -> a -> ActionResult (AllowAllTopology @vertex) state initialVertex b)
+unrestrictedBaseMachineT
+  :: (forall initialVertex. state initialVertex -> a -> ActionResult m (AllowAllTopology @vertex) state initialVertex b)
   -> InitialState (state :: vertex -> Type)
-  -> BaseMachine (AllowAllTopology @vertex) a b
-unrestrictedBaseMachine action initialState =
-  BaseMachine
+  -> BaseMachineT m (AllowAllTopology @vertex) a b
+unrestrictedBaseMachineT action initialState =
+  BaseMachineT
     { initialState = initialState
     , action = action
     }
@@ -154,19 +199,22 @@ unrestrictedBaseMachine action initialState =
 
 -- | Given an `input`, run the machine to get an output and a new version of
 -- the machine
-runBaseMachine
-  :: BaseMachine topology input output
+runBaseMachineT
+  :: Functor m
+  => BaseMachineT m topology input output
   -> input
-  -> (output, BaseMachine topology input output)
-runBaseMachine (BaseMachine (InitialState initialState) action) input =
+  -> m (output, BaseMachineT m topology input output)
+runBaseMachineT (BaseMachineT (InitialState initialState) action) input =
   let
     actionResult = action initialState input
    in
     case actionResult of
-      (ActionResult finalState output) ->
-        ( output
-        , BaseMachine
-            { initialState = InitialState finalState
-            , action = action
-            }
-        )
+      ActionResult outputStatePair ->
+        second
+          ( \finalState ->
+              BaseMachineT
+                { initialState = InitialState finalState
+                , action = action
+                }
+          )
+          <$> outputStatePair

src/CRM/Render.hs

@@ -27,9 +27,9 @@ topologyAsGraph (Topology edges) = Graph $ edges >>= edgify
 -- | Interpret a `BaseMachine` as a `Graph` using the information contained in
 -- its topology
 baseMachineAsGraph
-  :: forall vertex topology input output
+  :: forall vertex topology input output m
    . (Demote (Topology vertex) ~ Topology vertex, SingKind vertex, SingI topology)
-  => BaseMachine (topology :: Topology vertex) input output
+  => BaseMachineT m (topology :: Topology vertex) input output
   -> Graph vertex
 baseMachineAsGraph _ = topologyAsGraph (demote @topology)
 
@@ -39,7 +39,7 @@ renderUntypedMermaid (UntypedGraph graph) = renderMermaid graph
 
 -- | Interpret a `StateMachine` as an `UntypedGraph` using the information
 -- contained in its structure and in the topology of its basic components
-machineAsGraph :: StateMachine input output -> UntypedGraph
+machineAsGraph :: StateMachineT m input output -> UntypedGraph
 machineAsGraph (Basic baseMachine) =
   UntypedGraph (baseMachineAsGraph baseMachine)
 machineAsGraph (Compose machine1 machine2) =

src/CRM/StateMachine.hs

@@ -8,47 +8,64 @@ import CRM.BaseMachine as BaseMachine
 import CRM.Topology
 import "base" Control.Category (Category (..))
 import "base" Data.Bifunctor (Bifunctor (..), bimap)
-import "base" Data.Foldable (foldl')
+import "base" Data.Foldable (foldlM)
 import "base" Data.Kind (Type)
-import "base" Data.List.NonEmpty (NonEmpty (..), fromList)
-import "profunctors" Data.Profunctor (Choice (..), Costrong (..), Profunctor (..), Strong (..))
-import "profunctors" Data.Profunctor.Rep (Corepresentable (..), unfirstCorep, unsecondCorep)
-import "profunctors" Data.Profunctor.Sieve (Cosieve (..))
+
+-- import "base" Data.List.NonEmpty (NonEmpty (..), fromList)
+import "profunctors" Data.Profunctor (Choice {-Costrong (..),-} (..), Profunctor (..), Strong (..))
+
+-- import "profunctors" Data.Profunctor.Rep (Corepresentable (..), unfirstCorep, unsecondCorep)
+-- import "profunctors" Data.Profunctor.Sieve (Cosieve (..))
 import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
 import Prelude hiding ((.))
 
 -- | A `StateMachine` is a [Mealy machine](https://en.wikipedia.org/wiki/Mealy_machine)
 -- with inputs of type `input` and outputs of type `output`
-data StateMachine input output where
+data StateMachineT m input output where
   Basic
-    :: forall vertex (topology :: Topology vertex) input output
+    :: forall m vertex (topology :: Topology vertex) input output
      . ( Demote vertex ~ vertex
        , SingKind vertex
        , SingI topology
        , Eq vertex
        , Show vertex
        )
-    => BaseMachine topology input output
-    -> StateMachine input output
+    => BaseMachineT m topology input output
+    -> StateMachineT m input output
   Compose
-    :: StateMachine a b
-    -> StateMachine b c
-    -> StateMachine a c
+    :: StateMachineT m a b
+    -> StateMachineT m b c
+    -> StateMachineT m a c
   Parallel
-    :: StateMachine a b
-    -> StateMachine c d
-    -> StateMachine (a, c) (b, d)
+    :: StateMachineT m a b
+    -> StateMachineT m c d
+    -> StateMachineT m (a, c) (b, d)
   Alternative
-    :: StateMachine a b
-    -> StateMachine c d
-    -> StateMachine (Either a c) (Either b d)
+    :: StateMachineT m a b
+    -> StateMachineT m c d
+    -> StateMachineT m (Either a c) (Either b d)
   Loop
-    :: StateMachine a [a]
-    -> StateMachine a [a]
+    :: StateMachineT m a [a]
+    -> StateMachineT m a [a]
+
+type StateMachine a b = forall m. Monad m => StateMachineT m a b
+
+-- * Hoist
+
+hoist :: (forall x. m x -> n x) -> StateMachineT m a b -> StateMachineT n a b
+hoist f machine = case machine of
+  Basic baseMachine -> Basic $ baseHoist f baseMachine
+  Compose machine1 machine2 -> Compose (hoist f machine1) (hoist f machine2)
+  Parallel machine1 machine2 -> Parallel (hoist f machine1) (hoist f machine2)
+  Alternative machine1 machine2 -> Alternative (hoist f machine1) (hoist f machine2)
+  Loop machine' -> Loop $ hoist f machine'
 
 -- | a state machine which does not rely on state
-stateless :: (a -> b) -> StateMachine a b
-stateless f = Basic $ statelessBase f
+statelessT :: Applicative m => (a -> m b) -> StateMachineT m a b
+statelessT f = Basic $ statelessBaseT f
+
+stateless :: Applicative m => (a -> b) -> StateMachineT m a b
+stateless f = statelessT (pure . f)
 
 -- | a machine modelled with explicit state, where every transition is allowed
 unrestrictedMachine
@@ -61,138 +78,132 @@ unrestrictedMachine
   => ( forall initialVertex
         . state initialVertex
        -> a
-       -> ActionResult (AllowAllTopology @vertex) state initialVertex b
+       -> ActionResult m (AllowAllTopology @vertex) state initialVertex b
      )
   -> InitialState (state :: vertex -> Type)
-  -> StateMachine a b
-unrestrictedMachine action state = Basic $ unrestrictedBaseMachine action state
+  -> StateMachineT m a b
+unrestrictedMachine action state = Basic $ unrestrictedBaseMachineT action state
 
 -- * Category
 
-instance Category StateMachine where
-  id :: StateMachine a a
+instance Monad m => Category (StateMachineT m) where
+  id :: StateMachineT m a a
   id = Basic identity
 
-  (.) :: StateMachine b c -> StateMachine a b -> StateMachine a c
+  (.) :: StateMachineT m b c -> StateMachineT m a b -> StateMachineT m a c
   (.) = flip Compose
 
 -- * Profunctor
 
-instance Profunctor StateMachine where
-  lmap :: (a -> b) -> StateMachine b c -> StateMachine a c
+instance Applicative m => Profunctor (StateMachineT m) where
+  lmap :: (a -> b) -> StateMachineT m b c -> StateMachineT m a c
   lmap f (Basic baseMachine) = Basic $ lmap f baseMachine
   lmap f (Compose machine1 machine2) = Compose (lmap f machine1) machine2
   lmap f machine = Compose (stateless f) machine
 
-  rmap :: (b -> c) -> StateMachine a b -> StateMachine a c
+  rmap :: (b -> c) -> StateMachineT m a b -> StateMachineT m a c
   rmap f (Basic baseMachine) = Basic $ rmap f baseMachine
   rmap f (Compose machine1 machine2) = Compose machine1 (rmap f machine2)
   rmap f machine = Compose machine (stateless f)
 
 -- * Strong
 
-instance Strong StateMachine where
-  first' :: StateMachine a b -> StateMachine (a, c) (b, c)
+instance Monad m => Strong (StateMachineT m) where
+  first' :: StateMachineT m a b -> StateMachineT m (a, c) (b, c)
   first' = flip Parallel Control.Category.id
 
-  second' :: StateMachine a b -> StateMachine (c, a) (c, b)
+  second' :: StateMachineT m a b -> StateMachineT m (c, a) (c, b)
   second' = Parallel 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 Choice StateMachine where
-  left' :: StateMachine a b -> StateMachine (Either a c) (Either b c)
+instance Monad m => Choice (StateMachineT m) where
+  left' :: StateMachineT m a b -> StateMachineT m (Either a c) (Either b c)
   left' = flip Alternative Control.Category.id
 
-  right' :: StateMachine a b -> StateMachine (Either c a) (Either c b)
+  right' :: StateMachineT m a b -> StateMachineT m (Either c a) (Either c b)
   right' = Alternative Control.Category.id
 
--- * Cosieve
+-- -- * Cosieve
 
--- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Sieve.html#v:cosieve
--- This is basically saying that we can interpret a `StateMachine a b` as a
--- function from a `NonEmpty a` to `b`
-instance Cosieve StateMachine NonEmpty where
-  cosieve :: StateMachine a b -> NonEmpty a -> b
-  cosieve machine (a0 :| as0) =
-    case run machine a0 of
-      (b, machine') -> case as0 of
-        [] -> b
-        a1 : as1 -> cosieve machine' (a1 :| as1)
+-- -- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Sieve.html#v:cosieve
+-- -- This is basically saying that we can interpret a `StateMachine a b` as a
+-- -- function from a `NonEmpty a` to `b`
+-- instance Cosieve (StateMachineT m) NonEmpty where
+--   cosieve :: StateMachineT m a b -> NonEmpty a -> m b
+--   cosieve machine (a0 :| as0) =
+--     case run machine a0 of
+--       (b, machine') -> case as0 of
+--         [] -> b
+--         a1 : as1 -> cosieve machine' (a1 :| as1)
 
--- * Corepresentable
+-- -- * Corepresentable
 
--- the state space for a machine with a topology containing a single vertex
--- and a type of possible states in that vertex
-data SingleVertexState a (vertex :: ()) where
-  SingleVertexState :: a -> SingleVertexState a '()
+-- -- the state space for a machine with a topology containing a single vertex
+-- -- and a type of possible states in that vertex
+-- data SingleVertexState a (vertex :: ()) where
+--   SingleVertexState :: a -> SingleVertexState a '()
 
--- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Rep.html#t:Corepresentable
--- This is basically saying that we can interpret a function from `NonEmpty a`
--- to `b` as a `StateMachine a b`, where we store the tail of the non-empty
--- list in the state of the machine.
-instance Corepresentable StateMachine where
-  type Corep StateMachine = NonEmpty
+-- -- | see https://hackage.haskell.org/package/profunctors-5.6.2/docs/Data-Profunctor-Rep.html#t:Corepresentable
+-- -- This is basically saying that we can interpret a function from `NonEmpty a`
+-- -- to `b` as a `StateMachine a b`, where we store the tail of the non-empty
+-- -- list in the state of the machine.
+-- instance Corepresentable (StateMachineT m) where
+--   type Corep (StateMachineT m) = NonEmpty
 
-  cotabulate :: forall a b. (NonEmpty a -> b) -> StateMachine a b
-  cotabulate f =
-    Basic @() @TrivialTopology $
-      BaseMachine
-        { initialState = InitialState $ SingleVertexState ([] :: [a])
-        , action = \(SingleVertexState as) input ->
-            let
-              allInputs = input : as
-             in
-              ActionResult
-                (SingleVertexState allInputs)
-                (f . fromList . reverse $ allInputs)
-        }
+--   cotabulate :: forall a b. (NonEmpty a -> m b) -> StateMachineT m a b
+--   cotabulate f =
+--     Basic @_ @() @TrivialTopology $
+--       BaseMachineT
+--         { initialState = InitialState $ SingleVertexState ([] :: [a])
+--         , action = \(SingleVertexState as) input ->
+--             let
+--               allInputs = input : as
+--              in
+--               ActionResult
+--                 (SingleVertexState allInputs)
+--                 (f . fromList . reverse $ allInputs)
+--         }
 
--- * Costrong
+-- -- * Costrong
 
-instance Costrong StateMachine where
-  unfirst :: StateMachine (a, c) (b, c) -> StateMachine a b
-  unfirst = unfirstCorep
+-- instance Costrong (StateMachineT m) where
+--   unfirst :: StateMachineT m (a, c) (b, c) -> StateMachineT m a b
+--   unfirst = unfirstCorep
 
-  unsecond :: StateMachine (c, a) (c, b) -> StateMachine a b
-  unsecond = unsecondCorep
+--   unsecond :: StateMachineT m (c, a) (c, b) -> StateMachineT m a b
+--   unsecond = unsecondCorep
 
 -- * Run a state machine
 
 -- | Given an `input`, run the machine to get an output and a new version of
 -- the machine
-run :: StateMachine a b -> a -> (b, StateMachine a b)
-run (Basic baseMachine) a = Basic <$> runBaseMachine baseMachine a
-run (Compose machine1 machine2) a =
-  let
-    (output1, machine1') = run machine1 a
-    (output2, machine2') = run machine2 output1
-   in
-    (output2, Compose machine1' machine2')
-run (Parallel machine1 machine2) (a, b) =
-  let
-    (output1, machine1') = run machine1 a
-    (output2, machine2') = run machine2 b
-   in
-    ((output1, output2), Parallel machine1' machine2')
+run :: Monad m => StateMachineT m a b -> a -> m (b, StateMachineT m a b)
+run (Basic baseMachine) a = second Basic <$> runBaseMachineT baseMachine a
+run (Compose machine1 machine2) a = do
+  (output1, machine1') <- run machine1 a
+  (output2, machine2') <- run machine2 output1
+  pure (output2, Compose machine1' machine2')
+run (Parallel machine1 machine2) a = do
+  (output1, machine1') <- run machine1 (fst a)
+  (output2, machine2') <- run machine2 (snd a)
+  pure ((output1, output2), Parallel machine1' machine2')
 run (Alternative machine1 machine2) a =
   case a of
-    Left a1 -> bimap Left (`Alternative` machine2) $ run machine1 a1
-    Right a2 -> bimap Right (machine1 `Alternative`) $ run machine2 a2
-run (Loop machine) a =
-  let
-    (as, machine') = run machine a
-   in
-    first (as <>) $ runMultiple (Loop machine') as
+    Left a1 -> bimap Left (`Alternative` machine2) <$> run machine1 a1
+    Right a2 -> bimap Right (machine1 `Alternative`) <$> run machine2 a2
+run (Loop machine) a = do
+  (as, machine') <- run machine a
+  first (as <>) <$> runMultiple (Loop machine') as
 
 -- | process multiple inputs in one go, accumulating the results in a monoid
 runMultiple
-  :: (Foldable f, Monoid b)
-  => StateMachine a b
+  :: (Monad m, Foldable f, Monoid b)
+  => StateMachineT m a b
   -> f a
-  -> (b, StateMachine a b)
+  -> m (b, StateMachineT m a b)
 runMultiple machine =
-  foldl'
-    (\(b, machine') -> first (b <>) . run machine')
+  foldlM
+    (\(b, machine') a -> first (b <>) <$> run machine' a)
     (mempty, machine)