use Feedback constructor instead of Loop

spec/CRM/Example/RiskManager/Application.hs

@@ -16,14 +16,8 @@ aggregate = rmap maybeToList $ Basic riskAggregate
 policy :: StateMachine RiskEvent [RiskCommand]
 policy = rmap maybeToList riskPolicy
 
-circle :: StateMachine RiskEvent [RiskEvent]
-circle = Kleisli policy aggregate
-
-loop :: StateMachine RiskEvent [RiskEvent]
-loop = Loop circle
-
 writeModel :: StateMachine RiskCommand [RiskEvent]
-writeModel = Kleisli aggregate loop
+writeModel = Feedback aggregate policy
 
 projection :: StateMachine RiskEvent ReceivedData
 projection = Basic riskProjection

spec/CRM/RiskManagerSpec.hs

@@ -90,23 +90,20 @@ spec =
         run policy (CreditBureauDataReceived creditBureauData)
           `shouldOutput` []
 
-    describe "loop" $ do
-      it "emits a user registration event when the same event is received" $ do
-        run loop (UserDataRegistered myUserData)
-          `shouldOutput` [UserDataRegistered myUserData]
-
-      it "emits two user registration events when the same events are received" $ do
-        runMultiple loop [UserDataRegistered myUserData, UserDataRegistered myUserData]
-          `shouldOutput` [UserDataRegistered myUserData, UserDataRegistered myUserData]
-
     describe "writeModel" $ do
       it "emits a registered event when a registration command is received" $ do
         run writeModel (RegisterUserData myUserData)
-          `shouldOutput` [UserDataRegistered myUserData]
+          `shouldOutput` [ UserDataRegistered myUserData
+                         , CreditBureauDataReceived creditBureauData
+                         ]
 
       it "emits two registered events when two registration command are received" $ do
         runMultiple writeModel [RegisterUserData myUserData, RegisterUserData myUserData]
-          `shouldOutput` [UserDataRegistered myUserData, UserDataRegistered myUserData]
+          `shouldOutput` [ UserDataRegistered myUserData
+                         , CreditBureauDataReceived creditBureauData
+                         , UserDataRegistered myUserData
+                         , CreditBureauDataReceived creditBureauData
+                         ]
 
     describe "riskProjection" $ do
       it "registers one user when a registration event is received" $ do
@@ -157,6 +154,11 @@ spec =
                             , receivedLoanDetails = Nothing
                             , receivedCreditBureauData = Nothing
                             }
+                         , ReceivedData
+                            { receivedUserData = Just myUserData
+                            , receivedLoanDetails = Nothing
+                            , receivedCreditBureauData = Just creditBureauData
+                            }
                          ]
 
       it "registers two users when two registration commands are received" $ do
@@ -166,10 +168,15 @@ spec =
                             , receivedLoanDetails = Nothing
                             , receivedCreditBureauData = Nothing
                             }
+                         , ReceivedData
+                            { receivedUserData = Just myUserData
+                            , receivedLoanDetails = Nothing
+                            , receivedCreditBureauData = Just creditBureauData
+                            }
                          , ReceivedData
                             { receivedUserData = Just notMyUserData
                             , receivedLoanDetails = Nothing
-                            , receivedCreditBureauData = Nothing
+                            , receivedCreditBureauData = Just creditBureauData
                             }
                          ]
 
@@ -179,7 +186,7 @@ spec =
           `shouldOutput` ReceivedData
             { receivedUserData = Just myUserData
             , receivedLoanDetails = Nothing
-            , receivedCreditBureauData = Nothing
+            , receivedCreditBureauData = Just creditBureauData
             }
 
       it "updates the user data" $ do
@@ -187,5 +194,5 @@ spec =
           `shouldOutput` ReceivedData
             { receivedUserData = Just myUserData
             , receivedLoanDetails = Nothing
-            , receivedCreditBureauData = Nothing
+            , receivedCreditBureauData = Just creditBureauData
             }

spec/CRM/StateMachineSpec.hs

@@ -5,7 +5,10 @@ import CRM.Example.LockDoor
 import CRM.Example.PlusOneUpToFour (plus1UpTo4)
 import CRM.Example.Switch (switchMachine)
 import "crm" CRM.StateMachine
-import Data.Functor.Identity (Identity (..))
+import "base" Control.Category qualified
+import "base" Data.Functor.Identity (Identity (..))
+import "base" Data.List (singleton)
+import "profunctors" Data.Profunctor (rmap)
 import "singletons-base" Data.Singletons.Base.TH
 import "hspec" Test.Hspec (Expectation, Spec, describe, it, shouldBe)
 
@@ -108,11 +111,15 @@ spec =
     --         nonEmptyFunction input
     --           `shouldBe` (cosieve . cotabulate @StateMachine $ nonEmptyFunction) input
 
-    describe "Loop constructor runs correctly" $ do
+    describe "Feedback constructor runs correctly" $ do
       describe "with the plus1UpTo4 machine" $ do
+        let
+          echo :: StateMachine a [a]
+          echo = rmap singleton Control.Category.id
+
         it "runs correctly on a single input" $ do
-          run (Loop plus1UpTo4) 1 `shouldOutput` [1, 2, 3, 4, 5]
-          run (Loop plus1UpTo4) 5 `shouldOutput` [5]
+          run (Feedback echo plus1UpTo4) 1 `shouldOutput` [1, 2, 3, 4, 5]
+          run (Feedback echo plus1UpTo4) 5 `shouldOutput` [5]
 
         it "processes correctly multiple inputs" $ do
-          runMultiple (Loop plus1UpTo4) [1, 1] `shouldOutput` [1, 2, 3, 4, 5, 1, 2, 3, 4, 5]
+          runMultiple (Feedback echo plus1UpTo4) [1, 1] `shouldOutput` [1, 2, 3, 4, 5, 1, 2, 3, 4, 5]

src/CRM/Render.hs

@@ -54,8 +54,11 @@ machineAsGraph (Alternative machine1 machine2) =
   untypedProductGraph
     (machineAsGraph machine1)
     (machineAsGraph machine2)
-machineAsGraph (Loop machine) =
-  untypedTransitiveClosureGraph (machineAsGraph machine)
+machineAsGraph (Feedback machine1 machine2) =
+  untypedTransitiveClosureGraph $
+    untypedProductGraph
+      (machineAsGraph machine1)
+      (machineAsGraph machine2)
 machineAsGraph (Kleisli machine1 machine2) =
   untypedProductGraph
     (machineAsGraph machine1)

src/CRM/StateMachine.hs

@@ -39,9 +39,10 @@ data StateMachineT m input output where
     :: StateMachineT m a b
     -> StateMachineT m c d
     -> StateMachineT m (Either a c) (Either b d)
-  Loop
-    :: StateMachineT m a [a]
-    -> StateMachineT m a [a]
+  Feedback
+    :: StateMachineT m a [b]
+    -> StateMachineT m b [a]
+    -> StateMachineT m a [b]
   Kleisli
     :: (Foldable n, Monoid (n c))
     => StateMachineT m a (n b)
@@ -58,7 +59,7 @@ hoist f machine = case machine of
   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'
+  Feedback machine1 machine2 -> Feedback (hoist f machine1) (hoist f machine2)
   Kleisli machine1 machine2 -> Kleisli (hoist f machine1) (hoist f machine2)
 
 -- | a state machine which does not rely on state
@@ -194,9 +195,10 @@ 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 = do
-  (as, machine') <- run machine a
-  first (a :) <$> runMultiple (Loop machine') as
+run (Feedback machine1 machine2) a = do
+  (bs, machine1') <- run machine1 a
+  (as, machine2') <- runMultiple machine2 bs
+  first (bs <>) <$> runMultiple (Feedback machine1' machine2') as
 run (Kleisli machine1 machine2) a = do
   (bs, machine1') <- run machine1 a
   (cs, machine2') <- runMultiple machine2 bs