state machines have an instance of Choice

src/CRM/BaseMachine.hs

@@ -4,7 +4,7 @@ module CRM.BaseMachine where
 
 import CRM.Topology
 import "base" Data.Kind (Type)
-import "profunctors" Data.Profunctor (Profunctor (..), Strong (..))
+import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
 
 -- * Specifying state machines
 
@@ -57,6 +57,25 @@ instance Strong (BaseMachine topology) where
       , 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
+      { initialState = initialState
+      , action = \state -> \case
+          Left a -> Left <$> action state a
+          Right c -> ActionResult state (Right c)
+      }
+
+  right' :: BaseMachine topology a b -> BaseMachine topology (Either c a) (Either c b)
+  right' (BaseMachine initialState action) =
+    BaseMachine
+      { initialState = initialState
+      , action = \state -> \case
+          Left c -> ActionResult state (Left c)
+          Right a -> Right <$> action state 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`

src/CRM/StateMachine.hs

@@ -5,7 +5,7 @@ module CRM.StateMachine where
 
 import CRM.BaseMachine
 import CRM.Topology
-import "profunctors" Data.Profunctor (Profunctor (..), Strong (..))
+import "profunctors" Data.Profunctor (Choice (..), Profunctor (..), Strong (..))
 import "singletons-base" Data.Singletons (Demote, SingI, SingKind)
 
 -- | A `StateMachine` is a [Mealy machine](https://en.wikipedia.org/wiki/Mealy_machine)
@@ -59,3 +59,12 @@ instance Strong StateMachine where
   second' (Compose machine1 machine2) = Compose (second' machine1) (second' machine2)
 
 -- * Choice
+
+instance Choice StateMachine where
+  left' :: StateMachine a b -> StateMachine (Either a c) (Either b c)
+  left' (Basic baseMachine) = Basic $ left' baseMachine
+  left' (Compose machine1 machine2) = Compose (left' machine1) (left' machine2)
+
+  right' :: StateMachine a b -> StateMachine (Either c a) (Either c b)
+  right' (Basic baseMachine) = Basic $ right' baseMachine
+  right' (Compose machine1 machine2) = Compose (right' machine1) (right' machine2)