typed-session 0.2.0.0 → 0.2.0.1
raw patch · 4 files changed
+60/−14 lines, 4 files
Files
- src/TypedSession/TH.hs +36/−8
- test/Book3/Peer.hs +3/−3
- test/Book3/Protocol.hs +20/−2
- typed-session.cabal +1/−1
src/TypedSession/TH.hs view
@@ -77,8 +77,8 @@ pure $ roleSingleton ++ singToSRole ++ instanceSingI ++ instanceSingToInt _ -> error $ "Name: " ++ show name ++ " is not a data constructor" -protDecsAndMsgDecs :: forall r bst. (Show r, Show bst) => String -> Name -> Name -> PipeResult r bst -> Q [Dec]-protDecsAndMsgDecs protN roleName bstName PipeResult{msgT1, dnySet, stBound = (fromVal, toVal), branchResultTypeInfo, branchFunList} = do+protDecsAndMsgDecs :: forall r bst. (Show r, Show bst, Enum r, Bounded r) => String -> Name -> Name -> PipeResult r bst -> Q [Dec]+protDecsAndMsgDecs protN roleName bstName PipeResult{msgT, msgT1, dnySet, stBound = (fromVal, toVal), branchResultTypeInfo, branchFunList, allMsgBATypes} = do let protName = mkName protN protSName = mkName ("S" <> protN) mkSiName i = mkName $ "S" <> show i@@ -113,6 +113,11 @@ typeListT :: [TH.Type] -> TH.Type typeListT = foldl1 AppT + isTAny :: T bst -> Bool+ isTAny = \case+ TAny _ -> True+ _ -> False+ sVar <- newName "s" aVar <- newName "a" let genSConstr i =@@ -170,7 +175,33 @@ ] ) )+ let firstTList = case msgT of+ Msg (ts, _, _) _ _ _ _ :> _ -> ts+ Label (ts, _) _ :> _ -> ts+ Branch ts _ _ _ -> ts+ Goto (ts, _) _ -> ts+ Terminal ts -> ts + mkTySynDFun name t =+ if isTAny t+ then do+ sVar1 <- newName @Q "s"+ pure (TySynD name [KindedTV sVar1 BndrReq (ConT bstName)] (tAnyToType sVar1 t))+ else pure (TySynD name [] (tAnyToType (mkName "s") t))++ mkAllRoleTySynDFun nameFun ts =+ for (zip [minBound @r .. maxBound] ts) $+ \(r, t) -> mkTySynDFun (nameFun r) t++ roleStartSts <- mkAllRoleTySynDFun (\r -> (mkName (show r <> "StartSt"))) firstTList++ allMsgBADecs <-+ concat <$> do+ for allMsgBATypes $ \(cname, beforeSt, afterSt) -> do+ bfs <- mkAllRoleTySynDFun (\r -> mkName (show r <> "Before" <> cname <> "St")) beforeSt+ afs <- mkAllRoleTySynDFun (\r -> mkName (show r <> "After" <> cname <> "St")) afterSt+ pure (bfs <> afs)+ s1 <- newName "s1" -- generate instance SingI let instanceSingI =@@ -217,12 +248,7 @@ ] _ -> error $ "Name: " ++ show roleName ++ " is not a data constructor" - let isTAny :: T bst -> Bool- isTAny = \case- TAny _ -> True- _ -> False-- mkDataInstanceMsg :: Name -> Protocol (MsgT1 r bst) r bst -> Q [Con]+ let mkDataInstanceMsg :: Name -> Protocol (MsgT1 r bst) r bst -> Q [Con] mkDataInstanceMsg s = \case Msg ((a, b, c), (from, to), _) constr args _ _ :> prots -> do let mkTName =@@ -301,6 +327,8 @@ ++ singSingletonProt ++ branchResultDatas ++ branchFunTypes+ ++ roleStartSts+ ++ allMsgBADecs ++ instanceSingI ++ instanceSingToInt ++ instanceMsg
test/Book3/Peer.hs view
@@ -51,7 +51,7 @@ buyerPeer :: (Has Random sig m)- => Peer BookRole Book Buyer m (At (Maybe Date) (Done Buyer)) S0+ => Peer BookRole Book Buyer m (At (Maybe Date) (Done Buyer)) BuyerStartSt buyerPeer = I.do yield (Title "haskell book") await I.>>= \case@@ -95,7 +95,7 @@ buyer2Peer :: (Has Random sig m)- => Peer BookRole Book Buyer2 m (At (Maybe Date) (Done Buyer2)) (S1 s)+ => Peer BookRole Book Buyer2 m (At (Maybe Date) (Done Buyer2)) (Buyer2StartSt s) buyer2Peer = I.do await I.>>= \case SellerNoBook -> returnAt Nothing@@ -123,7 +123,7 @@ sellerPeer :: (Has Random sig m)- => Peer BookRole Book Seller m (At () (Done Seller)) S0+ => Peer BookRole Book Seller m (At () (Done Seller)) SellerStartSt sellerPeer = I.do (Title st) <- await findBook st I.>>= \case
test/Book3/Protocol.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -ddump-splices #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Book3.Protocol where @@ -19,15 +20,17 @@ import TypedSession.Codec import TypedSession.Core+import Language.Haskell.TH + [bookProtocol| Label 0 Msg Title [String] Buyer Seller Branch Seller FindBookResult { BranchSt NotFound [] Msg NoBook [] Seller Buyer- Msg SellerNoBook [] Buyer Buyer2- Terminal+ Msg SellerNoBook [] Buyer Buyer2+ Terminal BranchSt Found [] Msg Price [Int] Seller Buyer Branch Buyer OneOrTwo {@@ -109,3 +112,18 @@ TwoSuccess d -> "TwoSuccess " <> show d TwoNotBuy1 -> "TwoNotBuy1" TwoFailed -> "TwoFailed"++type Start s = Maybe s+type Start1 = Int++$( do + x <- reify ''Start + y <- reify ''Start1+ runIO $ do + putStrLn "--------------------------------------------"+ putStrLn $ show x+ putStrLn $ show y+ putStrLn "--------------------------------------------"+ pure []++ )
typed-session.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.2.0.0+version: 0.2.0.1 -- A short (one-line) description of the package. synopsis: typed session framework