A StateMachine is a profunctor

package.yaml

@@ -44,6 +44,8 @@ dependencies:
 
 library:
   source-dirs:      src
+  dependencies:
+    - profunctors
 
 tests:
   crm-spec:

src/CRM/BaseMachine.hs

@@ -4,6 +4,7 @@ module CRM.BaseMachine where
 
 import CRM.Topology
 import "base" Data.Kind (Type)
+import "profunctors" Data.Profunctor (Profunctor (..))
 
 -- * Specifying state machines
 
@@ -27,6 +28,21 @@ data
       -> ActionResult 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
+      { initialState = initialState
+      , action = (. f) . action
+      }
+
+  rmap :: (b -> c) -> BaseMachine topology a b -> BaseMachine topology a c
+  rmap f (BaseMachine initialState action) =
+    BaseMachine
+      { initialState = initialState
+      , action = ((f <$>) .) . action
+      }
+
 {- | 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`
@@ -50,3 +66,11 @@ data
     => state finalVertex
     -> output
     -> ActionResult topology state initialVertex output
+
+instance Functor (ActionResult 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)

src/CRM/StateMachine.hs

@@ -5,6 +5,7 @@ module CRM.StateMachine where
 
 import CRM.BaseMachine
 import CRM.Topology
+import "profunctors" Data.Profunctor (Profunctor (..))
 import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
 
 -- import "base" Control.Category (Category (..))
@@ -36,6 +37,15 @@ infixr 1 <<<
 
 -- * Profunctor
 
+instance Profunctor StateMachine where
+  lmap :: (a -> b) -> StateMachine b c -> StateMachine a c
+  lmap f (Basic baseMachine) = Basic $ lmap f baseMachine
+  lmap f (Compose machine1 machine2) = Compose (lmap f machine1) machine2
+
+  rmap :: (b -> c) -> StateMachine a b -> StateMachine a c
+  rmap f (Basic baseMachine) = Basic $ rmap f baseMachine
+  rmap f (Compose machine1 machine2) = Compose machine1 (rmap f machine2)
+
 -- * Strong
 
 -- * Choice