mirror of
https://github.com/marcosh/crem.git
synced 2024-10-26 11:52:20 +03:00
use Feedback constructor instead of Loop
This commit is contained in:
parent
57df8ae1c3
commit
14f9d03939
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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]
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user