diff --git a/src/TypedSession/State/Parser.hs b/src/TypedSession/State/Parser.hs --- a/src/TypedSession/State/Parser.hs +++ b/src/TypedSession/State/Parser.hs @@ -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 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 @@ -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 diff --git a/src/TypedSession/State/Render.hs b/src/TypedSession/State/Render.hs --- a/src/TypedSession/State/Render.hs +++ b/src/TypedSession/State/Render.hs @@ -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 ) 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 @@ -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) diff --git a/src/TypedSession/State/Utils.hs b/src/TypedSession/State/Utils.hs --- a/src/TypedSession/State/Utils.hs +++ b/src/TypedSession/State/Utils.hs @@ -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 _ -> [] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 -} 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.3.0.2 +version: 0.4.0.0 -- A short (one-line) description of the package. synopsis: Automatically generate status for typed-session.