diff --git a/src/TypedSession/State/Pipeline.hs b/src/TypedSession/State/Pipeline.hs --- a/src/TypedSession/State/Pipeline.hs +++ b/src/TypedSession/State/Pipeline.hs @@ -329,16 +329,20 @@ , dnySet :: Set Int , stBound :: (Int, Int) , branchResultTypeInfo :: [(String, [(bst, [[String]], T bst)])] + , branchFunList :: [(r, String, T bst)] } genBranchResultTIXFold :: forall r bst sig m - . (Has (State String :+: (State (Map String [(bst, [[String]], T bst)]))) sig m) + . ( Has (State String :+: Writer [(r, String, T bst)] :+: (State (Map String [(bst, [[String]], T bst)]))) sig m + , Enum r + ) => XFold m (MsgT1 r bst) r bst genBranchResultTIXFold = ( \_ -> pure () , \_ -> pure () - , \(_, (_, st, _)) -> do + , \(ts, (r, st, _)) -> do + tell [(r, st, ts !! (fromEnum r))] put st pure (restoreWrapper @String) , \(_, (bst, args, prot)) -> do @@ -410,13 +414,13 @@ trace (TracerProtocolMsgT prot4) prot5 <- xtraverse genMsgT1XTraverse prot4 trace (TracerProtocolMsgT1 prot5) - branchTIMap <- - fmap (fst . snd) + (bfl, (_, (branchTIMap, _))) <- + runWriter @[(r, String, T bst)] . runState @String (error internalError) . runState @(Map String [(bst, [[String]], T bst)]) Map.empty $ xfold genBranchResultTIXFold prot5 - trace (TracerBranchResultTI branchTIMap) - pure (PipeResult prot4 prot5 dnys stBound (Map.toList branchTIMap)) + trace (TracerBranchResultTI bfl branchTIMap) + pure (PipeResult prot4 prot5 dnys stBound (Map.toList branchTIMap) bfl) pipe :: forall r bst diff --git a/src/TypedSession/State/Type.hs b/src/TypedSession/State/Type.hs --- a/src/TypedSession/State/Type.hs +++ b/src/TypedSession/State/Type.hs @@ -175,7 +175,7 @@ | TracerCollectBranchDynVal (Set Int) | TracerProtocolMsgT (Protocol (MsgT r bst) r bst) | TracerProtocolMsgT1 (Protocol (MsgT1 r bst) r bst) - | TracerBranchResultTI (Map String [(bst, [[String]], T bst)]) + | TracerBranchResultTI [(r, String, T bst)] (Map String [(bst, [[String]], T bst)]) traceWrapper :: String -> String -> String traceWrapper desc st = @@ -195,7 +195,7 @@ TracerCollectBranchDynVal dvs -> traceWrapper "CollectBranchDynVal" $ show dvs TracerProtocolMsgT p -> traceWrapper "MsgT" $ show p TracerProtocolMsgT1 p -> traceWrapper "MsgT1" $ show p - TracerBranchResultTI st -> traceWrapper "BranchResultTI" $ show st + TracerBranchResultTI v1 st -> traceWrapper "BranchResultTI" $ show v1 <> "\n" <> show st ------------------------ diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -132,39 +132,39 @@ {- >>> error r2 --------------------------------------------Buyer----------------------Seller---------------------Buyer2--------------------- -Label 0 S0 S0 S1 s - Title [String] S0 -> S0 <- S1 s - [Branch Seller FindBookResult] S2 s S3 S1 s - * BranchSt_Found [] - Price [Int] S2 s <- {S2 Found} -> S1 s - [Branch Buyer OneOrTwo] S4 S5 s S1 s - * BranchSt_Two [] - PriceToBuyer2 [Int] {S1 Two} -> S5 s S1 s <- - [Branch Buyer2 SupportOrNotSupport] S6 s S5 s S7 - * BranchSt_NotSupport [] - NotSupport1 [] S6 s <- S5 s {S6 NotSupport} -> - TwoNotBuy [] S5 NotSupport -> S5 s <- S1 s - Goto 0 S0 S0 S1 s - * BranchSt_Support [] - SupportVal [Int] S6 s <- S5 s {S6 Support} -> - [Branch Buyer EnoughOrNotEnough] S8 S5 s S9 s - * BranchSt_Enough [] - TwoAccept [] {S5 Enough} -> S5 s <- S9 s - TwoDate [Int] S10 <- S10 -> S9 s - TwoSuccess [Int] S9 Enough -> S0 S9 s <- - Goto 0 S0 S0 S1 s - * BranchSt_NotEnough [] - TwoNotBuy1 [] {S5 NotEnough} -> S5 s <- S9 s - TwoFailed [] S9 NotEnough -> End S9 s <- - Terminal End End End - * BranchSt_One [] - OneAccept [] {S5 One} -> S5 s <- S1 s - OneDate [Int] S11 <- S11 -> S1 s - OneSuccess [Int] S1 One -> S0 S1 s <- - Goto 0 S0 S0 S1 s - * BranchSt_NotFound [] - NoBook [] S2 s <- {S2 NotFound} -> S1 s - SellerNoBook [] S1 NotFound -> S0 S1 s <- - Goto 0 S0 S0 S1 s +Label 0 S0 S0 S1 s + Title [String] S0 -> S0 <- S1 s + [Branch Seller FindBookResult] S2 s S3 S1 s + * BranchSt_Found [] + Price [Int] S2 s <- {S2 Found} -> S1 s + [Branch Buyer OneOrTwo] S4 S5 s S1 s + * BranchSt_Two [] + PriceToBuyer2 [Int] {S1 Two} -> S5 s S1 s <- + [Branch Buyer2 SupportOrNotSupport] S6 s S5 s S7 + * BranchSt_NotSupport [] + NotSupport1 [] S6 s <- S5 s {S6 NotSupport} -> + TwoNotBuy [] S5 NotSupport -> S5 s <- S1 s + Goto 0 S0 S0 S1 s + * BranchSt_Support [] + SupportVal [Int] S6 s <- S5 s {S6 Support} -> + [Branch Buyer EnoughOrNotEnough] S8 S5 s S9 s + * BranchSt_Enough [] + TwoAccept [] {S5 Enough} -> S5 s <- S9 s + TwoDate [Int] S10 <- S10 -> S9 s + TwoSuccess [Int] S9 Enough -> S0 S9 s <- + Goto 0 S0 S0 S1 s + * BranchSt_NotEnough [] + TwoNotBuy1 [] {S5 NotEnough} -> S5 s <- S9 s + TwoFailed [] S9 NotEnough -> End S9 s <- + Terminal End End End + * BranchSt_One [] + OneAccept [] {S5 One} -> S5 s <- S1 s + OneDate [Int] S11 <- S11 -> S1 s + OneSuccess [Int] S1 One -> S0 S1 s <- + Goto 0 S0 S0 S1 s + * BranchSt_NotFound [] + NoBook [] S2 s <- {S2 NotFound} -> S1 s + SellerNoBook [] S1 NotFound -> S0 S1 s <- + Goto 0 S0 S0 S1 s -} diff --git a/typed-session-state-algorithm.cabal b/typed-session-state-algorithm.cabal --- a/typed-session-state-algorithm.cabal +++ b/typed-session-state-algorithm.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.0.0 +version: 0.4.1.0 -- A short (one-line) description of the package. synopsis: Automatically generate status for typed-session.