typed-session-state-algorithm 0.3.0.2 → 0.4.0.0
raw patch · 7 files changed
+201/−146 lines, 7 files
Files
- src/TypedSession/State/Parser.hs +13/−25
- src/TypedSession/State/Pipeline.hs +64/−15
- src/TypedSession/State/Render.hs +9/−7
- src/TypedSession/State/Type.hs +29/−22
- src/TypedSession/State/Utils.hs +1/−1
- test/Main.hs +84/−75
- typed-session-state-algorithm.cabal +1/−1
src/TypedSession/State/Parser.hs view
@@ -7,24 +7,15 @@ module TypedSession.State.Parser (runProtocolParser) where -import Data.Char (isUpper) import qualified Data.List as L+import Data.Void (Void) import Text.Megaparsec hiding (Label, label)-import Text.Megaparsec.Char (char, space1, string)+import Text.Megaparsec.Char (space1, string)+import qualified Text.Megaparsec.Char as LC import qualified Text.Megaparsec.Char.Lexer as L import TypedSession.State.Type -data ParserError- = EmptyInput- | TheFirstLetterNotCapitalized- deriving (Show, Eq, Ord)--instance ShowErrorComponent ParserError where- showErrorComponent = \case- EmptyInput -> "Trying to parse constructor or type, but input is empty!"- TheFirstLetterNotCapitalized -> "Try to parse constructor or type, but the first letter is not capitalized!"--type Parser = Parsec ParserError String+type Parser = Parsec Void String spaceConsumer :: Parser () spaceConsumer =@@ -64,15 +55,10 @@ constrOrType :: Parser String constrOrType = dbg "constrOrType" $ do- st <- char '"' >> manyTill L.charLiteral (char '"')- case st of- [] -> customFailure EmptyInput- (x : _) ->- if isUpper x- then pure st- else customFailure TheFirstLetterNotCapitalized+ x <- LC.upperChar+ xs <- many LC.alphaNumChar spaceConsumer- pure st+ pure (x : xs) mkParserA :: forall a. (Enum a, Bounded a, Show a) => Parser a mkParserA = do@@ -93,7 +79,7 @@ parseMsg = dbg "Msg" $ do msg constr <- constrOrType- args <- brackets (constrOrType `sepBy` comma)+ args <- brackets ((some constrOrType) `sepBy` comma) from <- mkParserA @r to <- mkParserA @r pure $ Msg () constr args from to@@ -122,8 +108,9 @@ parseBranchSt = dbg "BranchSt" $ do branchSt bst <- mkParserA @bst+ args <- brackets ((some constrOrType) `sepBy` comma) prot <- parseProtocol @r @bst- pure (BranchSt () bst prot)+ pure (BranchSt () bst args prot) parseBranch :: forall r bst@@ -131,9 +118,10 @@ parseBranch = dbg "Branch" $ do branch r1 <- mkParserA @r+ st <- constrOrType braces $ do branchSts <- some (parseBranchSt @bst @r)- pure (Branch () r1 branchSts)+ pure (Branch () r1 st branchSts) parseMsgOrLabel :: forall r bst@@ -159,5 +147,5 @@ runProtocolParser st = let res = runParser (between spaceConsumer eof $ parseProtocol @r @bst) "" st in case res of- Left e -> Left $ errorBundlePretty @String @ParserError e+ Left e -> Left $ errorBundlePretty @String @Void e Right a -> Right a
src/TypedSession/State/Pipeline.hs view
@@ -75,6 +75,12 @@ , const get ) +reRank :: Set Int -> Int -> IntMap Int+reRank branchValSet maxSize =+ let allSet = Set.insert 0 branchValSet+ restList = [i | i <- [0 .. maxSize], i `Set.notMember` allSet]+ in IntMap.fromList $ zip (Set.toList allSet ++ restList) [0 ..]+ reRankXTraverse :: (Monad m) => IntMap Int -> XTraverse m Idx Idx r bst reRankXTraverse sbm = ( \((a, b, idx), _) -> pure (replaceVal sbm a, replaceVal sbm b, idx)@@ -134,7 +140,13 @@ checkProtXFold :: forall r bst sig m- . (Has (State (Map r CurrSt) :+: State r :+: Error (ProtocolError r bst)) sig m, Eq r, Ord r, Enum r, Bounded r)+ . ( Has (State (Map r CurrSt) :+: State r :+: Error (ProtocolError r bst)) sig m+ , Eq r+ , Ord r+ , Enum r+ , Bounded r+ , Show bst+ ) => XFold m (GenConst r) r bst checkProtXFold = ( \((_, (from, to), idx), (msgName, _, _, _, prot)) -> do@@ -152,18 +164,27 @@ when (any (/= Decide) vals) (throwError @(ProtocolError r bst) (TerminalNeedAllRoleDecide msgName)) _ -> pure () , \_ -> pure ()- , \(_, (r1, ls)) -> do+ , \(_, (r1, _, ls)) -> do r1CurrSt <- getRCurrSt r1 when (r1CurrSt == Undecide) (throwError @(ProtocolError r bst) (UndecideStateCanNotStartBranch ls)) for_ [r | r <- rRange, r /= r1] $ \r -> modify (Map.insert r Undecide) when (length ls < 1) (throwError @(ProtocolError r bst) BranchAtLeastOneBranch) put r1 pure (restoreWrapper1 @r)- , \_ -> pure ()+ , \(_, (r, _, prot)) ->+ if isMsgExistBeforeNextTerm prot+ then pure ()+ else throwError @(ProtocolError r bst) (MsgDoNotExistBeforeNextTerm (show r)) , \_ -> pure () , \_ -> pure () ) +isMsgExistBeforeNextTerm :: Protocol eta r bst -> Bool+isMsgExistBeforeNextTerm = \case+ Msg{} :> _ -> True+ Label{} :> port -> isMsgExistBeforeNextTerm port+ _ -> False+ genConstrXFold :: forall r bst sig m . (Has (State (IntMap [Int]) :+: State [Int] :+: Writer (Seq C.Constraint) :+: Error (ProtocolError r bst)) sig m, Enum r)@@ -234,7 +255,7 @@ collectBranchDynValXFold = ( \_ -> pure () , \_ -> pure ()- , \(ls, (r, _)) -> do+ , \(ls, (r, _, _)) -> do let ls' = map snd $ filter (\(i, _) -> i /= fromEnum r) $ zip [0 ..] ls modify (`Set.union` (Set.fromList ls')) pure id@@ -270,10 +291,10 @@ , \((ls, idx), _) -> do ls' <- mapM (genT (const TAny)) ls pure (ls', idx)- , \(ls, (r, _)) -> do+ , \(ls, (r, _, _)) -> do ls' <- mapM (\(idx, v) -> genT (if idx == fromEnum r then const TNum else (const TAny)) v) (zip [0 ..] ls) pure (ls', restoreWrapper @bst)- , \(_, (bst, _)) -> put bst+ , \(_, (bst, _, _)) -> put bst , \((is, i), _) -> do is' <- mapM (genT @bst (const TAny)) is pure (is', i)@@ -284,7 +305,7 @@ getFirstXV = \case Msg (xv, _, _) _ _ _ _ :> _ -> xv Label (xv, _) _ :> _ -> xv- Branch xv _ _ -> xv+ Branch xv _ _ _ -> xv Goto (xv, _) _ -> xv Terminal xv -> xv @@ -307,14 +328,35 @@ , msgT1 :: Protocol (MsgT1 r bst) r bst , dnySet :: Set Int , stBound :: (Int, Int)+ , branchResultTypeInfo :: [(String, [(bst, [[String]], T bst)])] } -reRank :: Set Int -> Int -> IntMap Int-reRank branchValSet maxSize =- let allSet = Set.insert 0 branchValSet- restList = [i | i <- [0 .. maxSize], i `Set.notMember` allSet]- in IntMap.fromList $ zip (Set.toList allSet ++ restList) [0 ..]+genBranchResultTIXFold+ :: forall r bst sig m+ . (Has (State String :+: (State (Map String [(bst, [[String]], T bst)]))) sig m)+ => XFold m (MsgT1 r bst) r bst+genBranchResultTIXFold =+ ( \_ -> pure ()+ , \_ -> pure ()+ , \(_, (_, st, _)) -> do+ put st+ pure (restoreWrapper @String)+ , \(_, (bst, args, prot)) -> do+ case getNextT prot of+ Nothing -> error internalError+ Just t -> do+ name <- get @String+ modify @(Map String [(bst, [[String]], T bst)]) (Map.insertWith (<>) name [(bst, args, t)])+ , \_ -> pure ()+ , \_ -> pure ()+ ) +getNextT :: Protocol (MsgT1 r bst) r bst -> Maybe (T bst)+getNextT = \case+ Msg ((a, _, _), _, _) _ _ _ _ :> _ -> Just a+ Label{} :> prot -> getNextT prot+ _ -> Nothing+ pipe' :: forall r bst sig m . ( Has (Error (ProtocolError r bst)) sig m@@ -322,6 +364,7 @@ , Bounded r , Eq r , Ord r+ , Show bst ) => (Tracer r bst -> m ()) -> Protocol Creat r bst@@ -367,11 +410,17 @@ trace (TracerProtocolMsgT prot4) prot5 <- xtraverse genMsgT1XTraverse prot4 trace (TracerProtocolMsgT1 prot5)- pure (PipeResult prot4 prot5 dnys stBound)+ branchTIMap <-+ fmap (fst . snd)+ . 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)) pipe :: forall r bst- . (Enum r, Bounded r, Eq r, Ord r)+ . (Enum r, Bounded r, Eq r, Ord r, Show bst) => Protocol Creat r bst -> Either (ProtocolError r bst)@@ -381,7 +430,7 @@ pipeWithTracer :: forall r bst- . (Enum r, Bounded r, Eq r, Ord r)+ . (Enum r, Bounded r, Eq r, Ord r, Show bst) => Protocol Creat r bst -> ( Seq (Tracer r bst) , Either
src/TypedSession/State/Render.hs view
@@ -32,7 +32,7 @@ type instance XMsg RenderProt = (String, [String]) type instance XLabel RenderProt = (String, [String]) type instance XBranch RenderProt = (String, [String])-type instance XBranchSt RenderProt = ()+type instance XBranchSt RenderProt = String type instance XGoto RenderProt = (String, [String]) type instance XTerminal RenderProt = (String, [String]) @@ -48,7 +48,7 @@ mkLeftStr :: (Has (State Int :+: Writer (Max LV)) sig m) => String -> m String mkLeftStr str = do indent <- get @Int- let str' = replicate (indent * 2 + 3) ' ' <> str+ let str' = replicate (indent * 2 + 2) ' ' <> str tell (Max $ LV $ length str') pure str' @@ -65,7 +65,7 @@ => XTraverse m (MsgT r bst) RenderProt r bst render1XTraverse = ( \((ts, (from, to), idx), (constr, args, _, _, _)) -> do- nst <- mkLeftStr (constr <> " [" <> L.intercalate "," args <> "]")+ nst <- mkLeftStr (constr <> " [" <> L.intercalate "," (fmap (L.intercalate " ") args) <> "]") ts' <- for (zip (rRange @r) ts) $ \(r, t) -> do indent <- get @Int let sht =@@ -82,15 +82,17 @@ when (idx == 0) (modify @Int (+ 1)) pure (nst, ts') , \((ts, i), _) -> pure ("Label " <> show i, map show ts)- , \(ts, (r, _)) -> do- nst <- mkLeftStr $ "[Branch " <> show r <> "]"+ , \(ts, (r, st, _)) -> do+ nst <- mkLeftStr $ "[Branch " <> show r <> " " <> st <> "]" indent <- get @Int let ts' = [ if r1 == r then replicate (indent * 2 + 2) ' ' <> show t else show t | (r1, t) <- zip (rRange @r) ts ] pure ((nst, ts'), restoreWrapper @Int)- , \_ -> pure ()+ , \(_, (bst, args, _)) -> do+ nst <- mkLeftStr $ "* BranchSt_" <> show bst <> " [" <> L.intercalate "," (fmap (L.intercalate " ") args) <> "]"+ pure nst , \((ts, i), _) -> do nst <- mkLeftStr $ "Goto " <> show i pure (nst, map show ts)@@ -134,7 +136,7 @@ , \(vs, _) -> do mkLine @r vs pure id- , \_ -> pure ()+ , \(ls, _) -> mkLine @r (ls, []) , \(vs, _) -> mkLine @r vs , \vs -> mkLine @r vs )
src/TypedSession/State/Type.hs view
@@ -19,6 +19,8 @@ import Control.Monad import Data.IntMap (IntMap) import Data.Kind (Constraint, Type)+import qualified Data.List as L+import Data.Map (Map) import Data.Sequence (Seq) import Data.Set (Set) import Prettyprinter@@ -37,12 +39,12 @@ (f (XMsg eta), f (XLabel eta), f (XBranch eta), f (XBranchSt eta), f (XGoto eta), f (XTerminal eta)) -- | BranchSt-data BranchSt eta r bst = BranchSt (XBranchSt eta) bst (Protocol eta r bst)+data BranchSt eta r bst = BranchSt (XBranchSt eta) bst [[String]] (Protocol eta r bst) deriving (Functor) -- | MsgOrLabel data MsgOrLabel eta r- = Msg (XMsg eta) String [String] r r+ = Msg (XMsg eta) String [[String]] r r | Label (XLabel eta) Int deriving (Functor) @@ -51,21 +53,21 @@ -- | Protocol data Protocol eta r bst = (MsgOrLabel eta r) :> (Protocol eta r bst)- | Branch (XBranch eta) r [BranchSt eta r bst]+ | Branch (XBranch eta) r String [BranchSt eta r bst] | Goto (XGoto eta) Int | Terminal (XTerminal eta) deriving (Functor) -- | XTraverse type XTraverse m eta gama r bst =- ( (XMsg eta, (String, [String], r, r, Protocol eta r bst)) -> m (XMsg gama)+ ( (XMsg eta, (String, [[String]], r, r, Protocol eta r bst)) -> m (XMsg gama) , (XLabel eta, (Int, Protocol eta r bst)) -> m (XLabel gama)- , (XBranch eta, (r, [BranchSt eta r bst]))+ , (XBranch eta, (r, String, [BranchSt eta r bst])) -> m ( XBranch gama , m (Protocol gama r bst) -> m (Protocol gama r bst) )- , (XBranchSt eta, (bst, Protocol eta r bst)) -> m (XBranchSt gama)+ , (XBranchSt eta, (bst, [[String]], Protocol eta r bst)) -> m (XBranchSt gama) , (XGoto eta, Int) -> m (XGoto gama) , (XTerminal eta) -> m (XTerminal gama) )@@ -87,13 +89,13 @@ pure (Label xv' i) prots' <- xtraverse xt prots pure (res :> prots')- Branch xv r ls -> do- (xv', wrapper) <- xbranch (xv, (r, ls))- ls' <- forM ls $ \(BranchSt xbst bst prot1) -> do- xbst' <- xbranchSt (xbst, (bst, prot1))+ Branch xv r st ls -> do+ (xv', wrapper) <- xbranch (xv, (r, st, ls))+ ls' <- forM ls $ \(BranchSt xbst bst args prot1) -> do+ xbst' <- xbranchSt (xbst, (bst, args, prot1)) prot' <- wrapper $ xtraverse xt prot1- pure (BranchSt xbst' bst prot')- pure (Branch xv' r ls')+ pure (BranchSt xbst' bst args prot')+ pure (Branch xv' r st ls') Goto xv i -> do xv' <- xgoto (xv, i) pure (Goto xv' i)@@ -103,10 +105,10 @@ -- | XFold type XFold m eta r bst =- ( (XMsg eta, (String, [String], r, r, Protocol eta r bst)) -> m ()+ ( (XMsg eta, (String, [[String]], r, r, Protocol eta r bst)) -> m () , (XLabel eta, Int) -> m ()- , (XBranch eta, (r, [BranchSt eta r bst])) -> m (m () -> m ())- , (XBranchSt eta, (bst, Protocol eta r bst)) -> m ()+ , (XBranch eta, (r, String, [BranchSt eta r bst])) -> m (m () -> m ())+ , (XBranchSt eta, (bst, [[String]], Protocol eta r bst)) -> m () , (XGoto eta, Int) -> m () , (XTerminal eta) -> m () )@@ -119,10 +121,10 @@ Msg xv a b c d -> xmsg (xv, (a, b, c, d, prots)) Label xv i -> xlabel (xv, i) xfold xt prots- Branch xv r ls -> do- wrapper <- xbranch (xv, (r, ls))- forM_ ls $ \(BranchSt xbst bst prot1) -> do- xbranchst (xbst, (bst, prot1))+ Branch xv r st ls -> do+ wrapper <- xbranch (xv, (r, st, ls))+ forM_ ls $ \(BranchSt xbst bst args prot1) -> do+ xbranchst (xbst, (bst, args, prot1)) wrapper $ xfold xt prot1 Goto xv i -> xgoto (xv, i) Terminal xv -> xterminal xv@@ -137,6 +139,7 @@ | TerminalNeedAllRoleDecide String | BranchAtLeastOneBranch | AStateOnlyBeUsedForTheSamePair+ | MsgDoNotExistBeforeNextTerm String instance (Show r, Show bst) => Show (ProtocolError r bst) where show = \case@@ -154,6 +157,7 @@ TerminalNeedAllRoleDecide msgName -> "Msg " <> msgName <> ", Terminal need all role decide!" BranchAtLeastOneBranch -> "Branch at least one branch!" AStateOnlyBeUsedForTheSamePair -> "A state can only be used for the same pair of communicators." ++ internalError+ MsgDoNotExistBeforeNextTerm st -> "BranchSt " <> st <> " do not exist any Msg before next term!" internalError :: String internalError = "Internal error, please report: https://github.com/sdzx-1/typed-session/issues"@@ -171,6 +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)]) traceWrapper :: String -> String -> String traceWrapper desc st =@@ -190,6 +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 ------------------------ @@ -262,18 +268,19 @@ ------------------------ instance (Pretty (Protocol eta r bst), Show (XBranchSt eta), Show bst) => Pretty (BranchSt eta r bst) where- pretty (BranchSt xbst bst prot) = "* BranchSt" <+> pretty (show xbst) <+> pretty (show bst) <> line <> (pretty prot)+ pretty (BranchSt xbst bst args prot) =+ "* BranchSt" <+> pretty (show xbst) <+> pretty (show bst) <+> pretty ((fmap (L.intercalate " ") args)) <> line <> (pretty prot) instance (Show (XMsg eta), Show (XLabel eta), Show r) => Pretty (MsgOrLabel eta r) where pretty = \case Msg xv cst args from to ->- hsep ["Msg", angles (pretty $ show xv), pretty cst, pretty args, pretty (show from), pretty (show to)]+ hsep ["Msg", angles (pretty $ show xv), pretty cst, pretty ((fmap (L.intercalate " ") args)), pretty (show from), pretty (show to)] Label xv i -> hsep ["Label", pretty $ show xv, pretty i] instance (ForallX Show eta, Show r, Show bst) => Pretty (Protocol eta r bst) where pretty = \case msgOrLabel :> prots -> pretty msgOrLabel <> line <> pretty prots- Branch is r ls -> nest 2 $ "[Branch]" <+> pretty (show is) <+> pretty (show r) <> line <> vsep (fmap pretty ls)+ Branch is r st ls -> nest 2 $ "[Branch]" <+> pretty (show is) <+> pretty (show r) <+> pretty (show st) <> line <> vsep (fmap pretty ls) Goto xv i -> "Goto" <+> pretty (show xv) <+> pretty i Terminal xv -> "Terminal" <+> pretty (show xv)
src/TypedSession/State/Utils.hs view
@@ -53,7 +53,7 @@ msgOrLabel :> prots -> case msgOrLabel of Msg _ _ _ from to -> (from, to) : getAllMsgInfo prots _ -> getAllMsgInfo prots- Branch _ _ ls -> concatMap (\(BranchSt _ _ prots) -> getAllMsgInfo prots) ls+ Branch _ _ _ ls -> concatMap (\(BranchSt _ _ _ prots) -> getAllMsgInfo prots) ls Goto _ _ -> [] Terminal _ -> []
test/Main.hs view
@@ -15,22 +15,22 @@ data PingPongRole = Client | Server | Counter deriving (Show, Read, Eq, Ord, Enum, Bounded) -data PingPongBranchSt = STrue | SFalse+data PingPongBranchSt = Continue | Finish deriving (Show, Read, Eq, Ord, Enum, Bounded) s1 = [r| Label 0- Branch Client {- BranchSt STrue- Msg "AddOne" [] Client Counter- Msg "Ping" ["Int", "Int", "Int"] Client Server- Msg "Pong" [] Server Client+ Branch Client ContinueOrFinish {+ BranchSt Continue []+ Msg AddOne [Maybe Int, Int, Either String Int] Client Counter+ Msg Ping [Int, Int, Int] Client Server+ Msg Pong [] Server Client Goto 0- BranchSt SFalse- Msg "Stop" [] Client Server- Msg "CStop" [] Client Counter+ BranchSt Finish []+ Msg Stop [] Client Server+ Msg CStop [] Client Counter Terminal } |]@@ -45,17 +45,19 @@ {- >>> error r1+---------------------------------------------Client--------------Server--------------Counter-------------+Label 0 S0 S1 s S2 s + [Branch Client ContinueOrFinish] S0 S1 s S2 s + * BranchSt_Continue [] + AddOne [Maybe Int,Int,Either String Int] {S2 Continue} -> S1 s S2 s <- + Ping [Int,Int,Int] S1 Continue -> S1 s <- S2 s + Pong [] S3 <- S3 -> S2 s + Goto 0 S0 S1 s S2 s + * BranchSt_Finish [] + Stop [] {S1 Finish} -> S1 s <- S2 s + CStop [] S2 Finish -> End S2 s <- + Terminal End End End ---------------------------Client------------Server------------Counter------------Label 0 S0 S1 s S2 s - [Branch Client] S0 S1 s S2 s - AddOne [] {S2 STrue} -> S1 s S2 s <- - Ping [Int,Int,Int] S1 STrue -> S1 s <- S2 s - Pong [] S3 <- S3 -> S2 s - Goto 0 S0 S1 s S2 s - Stop [] {S1 SFalse} -> S1 s <- S2 s - CStop [] S2 SFalse -> End S2 s <- - Terminal End End End -} data Role@@ -78,41 +80,41 @@ s2 = [r| Label 0- Msg "Title" ["String"] Buyer Seller- Branch Seller {- BranchSt Found - Msg "Price" ["Int"] Seller Buyer- Branch Buyer {- BranchSt Two - Msg "PriceToBuyer2" ["Int"] Buyer Buyer2- Branch Buyer2 {- BranchSt NotSupport - Msg "NotSupport1" [] Buyer2 Buyer- Msg "TwoNotBuy" [] Buyer Seller+ Msg Title [String] Buyer Seller+ Branch Seller FindBookResult {+ BranchSt Found []+ Msg Price [Int] Seller Buyer+ Branch Buyer OneOrTwo {+ BranchSt Two []+ Msg PriceToBuyer2 [Int] Buyer Buyer2+ Branch Buyer2 SupportOrNotSupport {+ BranchSt NotSupport [] + Msg NotSupport1 [] Buyer2 Buyer+ Msg TwoNotBuy [] Buyer Seller Goto 0- BranchSt Support - Msg "SupportVal" ["Int"] Buyer2 Buyer- Branch Buyer {- BranchSt Enough - Msg "TwoAccept" [] Buyer Seller- Msg "TwoDate" ["Int"] Seller Buyer- Msg "TwoSuccess" ["Int"] Buyer Buyer2+ BranchSt Support []+ Msg SupportVal [Int] Buyer2 Buyer+ Branch Buyer EnoughOrNotEnough {+ BranchSt Enough []+ Msg TwoAccept [] Buyer Seller+ Msg TwoDate [Int] Seller Buyer+ Msg TwoSuccess [Int] Buyer Buyer2 Goto 0- BranchSt NotEnough - Msg "TwoNotBuy1" [] Buyer Seller- Msg "TwoFailed" [] Buyer Buyer2+ BranchSt NotEnough []+ Msg TwoNotBuy1 [] Buyer Seller+ Msg TwoFailed [] Buyer Buyer2 Terminal } }- BranchSt One - Msg "OneAccept" [] Buyer Seller- Msg "OneDate" ["Int"] Seller Buyer- Msg "OneSuccess" ["Int"] Buyer Buyer2+ BranchSt One []+ Msg OneAccept [] Buyer Seller+ Msg OneDate [Int] Seller Buyer+ Msg OneSuccess [Int] Buyer Buyer2 Goto 0 }- BranchSt NotFound - Msg "NoBook" [] Seller Buyer- Msg "SellerNoBook" [] Buyer Buyer2+ BranchSt NotFound []+ Msg NoBook [] Seller Buyer+ Msg SellerNoBook [] Buyer Buyer2 Goto 0 } |]@@ -127,35 +129,42 @@ let st = show seqList in runRender msgT - {- >>> error r2-------------------------------Buyer----------------------Seller---------------------Buyer2----------------------Label 0 S0 S0 S1 s - Title [String] S0 -> S0 <- S1 s - [Branch Seller] S2 s S3 S1 s - Price [Int] S2 s <- {S2 Found} -> S1 s - [Branch Buyer] S4 S5 s S1 s - PriceToBuyer2 [Int] {S1 Two} -> S5 s S1 s <- - [Branch Buyer2] S6 s S5 s S7 - NotSupport1 [] S6 s <- S5 s {S6 NotSupport} -> - TwoNotBuy [] S5 NotSupport -> S5 s <- S1 s - Goto 0 S0 S0 S1 s - SupportVal [Int] S6 s <- S5 s {S6 Support} -> - [Branch Buyer] S8 S5 s S9 s - 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 - TwoNotBuy1 [] {S5 NotEnough} -> S5 s <- S9 s - TwoFailed [] S9 NotEnough -> End S9 s <- - Terminal End End End - 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 - NoBook [] S2 s <- {S2 NotFound} -> S1 s - SellerNoBook [] S1 NotFound -> S0 S1 s <- - Goto 0 S0 S0 S1 s +--------------------------------------------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 -}
typed-session-state-algorithm.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.3.0.2+version: 0.4.0.0 -- A short (one-line) description of the package. synopsis: Automatically generate status for typed-session.