packages feed

typed-session 0.1.2.0 → 0.1.3.0

raw patch · 11 files changed

+47/−16 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

- TypedSession.Driver: decodeLoop :: (Exception failure, MonadSTM n, MonadThrow n) => Tracer role' ps n -> Maybe bytes -> Decode role' ps failure bytes -> Channel n bytes -> TVar n (MsgCache role' ps) -> n ()
+ TypedSession.Driver: decodeLoop :: (Exception failure, MonadDelay n, MonadSTM n, MonadThrow n) => Tracer role' ps n -> Maybe bytes -> Decode role' ps failure bytes -> Channel n bytes -> TVar n (MsgCache role' ps) -> n ()

Files

src/TypedSession/Core.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}
src/TypedSession/Driver.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-}+{-# LANGUAGE NumericUnderscores #-}  {- | Schematic diagram of the communication structure of three roles through typed-session:@@ -31,6 +32,7 @@  import Control.Concurrent.Class.MonadSTM import Control.Monad.Class.MonadThrow (MonadThrow, throwIO)+import Control.Monad.Class.MonadTimer (MonadDelay, threadDelay) import Data.IFunctor (At (..), Sing, SingI (sing)) import qualified Data.IFunctor as I import Data.IntMap (IntMap)@@ -196,7 +198,7 @@ This usually happens when the efficiency of Msg generation is greater than the efficiency of consumption. -} decodeLoop-  :: (Exception failure, MonadSTM n, MonadThrow n)+  :: (Exception failure, MonadDelay n, MonadSTM n, MonadThrow n)   => Tracer role' ps n   -> Maybe bytes   -> Decode role' ps failure bytes@@ -214,4 +216,6 @@           Nothing -> writeTVar tvar (IntMap.insert agencyInt (AnyMsg msg) agencyMsg)           Just _v -> retry       decodeLoop tracer mbt' d channel tvar-    Left failure -> throwIO failure+    Left failure -> do+      threadDelay 1_000_000+      throwIO failure
src/TypedSession/TH.hs view
@@ -21,6 +21,7 @@ import Data.IFunctor (Sing, SingI (..)) import Data.Kind import qualified Data.Set as Set+import Data.Traversable (for) import GHC.Exts (DataToTag (..), Int (..)) import Language.Haskell.TH hiding (Type) import qualified Language.Haskell.TH as TH@@ -77,7 +78,7 @@     _ -> 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} = do+protDecsAndMsgDecs protN roleName bstName PipeResult{msgT1, dnySet, stBound = (fromVal, toVal), branchResultTypeInfo, branchFunList} = do   let protName = mkName protN       protSName = mkName ("S" <> protN)       mkSiName i = mkName $ "S" <> show i@@ -109,6 +110,8 @@           )         | ag <- args         ]+      typeListT :: [TH.Type] -> TH.Type+      typeListT = foldl1 AppT    sVar <- newName "s"   aVar <- newName "a"@@ -150,6 +153,23 @@         | (name, constrs) <- branchResultTypeInfo         , let dataName = mkName name         ]+  branchFunTypes <- for branchFunList $ \(r, st, t) -> do+    mVar <- newName "m"+    pure+      ( TySynD+          (mkName (st <> "Fun"))+          [KindedTV mVar BndrReq (AppT (AppT ArrowT StarT) StarT)]+          ( typeListT+              [ ConT ''TSC.Peer+              , ConT roleName+              , ConT protName+              , ConT (mkName (show r))+              , VarT mVar+              , ConT (mkName st)+              , (tAnyToType (mkName "s") t)+              ]+          )+      )    s1 <- newName "s1"   -- generate instance SingI@@ -197,10 +217,7 @@         ]     _ -> error $ "Name: " ++ show roleName ++ " is not a data constructor" -  let typeListT :: [TH.Type] -> TH.Type-      typeListT = foldl1 AppT--      isTAny :: T bst -> Bool+  let isTAny :: T bst -> Bool       isTAny = \case         TAny _ -> True         _ -> False@@ -276,6 +293,7 @@       ++ dataSingletonProt       ++ singSingletonProt       ++ branchResultDatas+      ++ branchFunTypes       ++ instanceSingI       ++ instanceSingToInt       ++ instanceMsg
test/Book.hs view
@@ -31,6 +31,7 @@ import TypedSession.Codec import TypedSession.Core import TypedSession.Driver+import Control.Monad.Class.MonadTimer (MonadDelay)  {- @@ -205,7 +206,7 @@     Date i -> "Date " <> show i     NotBuy -> "NotBuy" -runAll :: forall m. (Monad m, MonadSTM m, MonadSay m, MonadFork m, MonadThrow m) => m ()+runAll :: forall m. (Monad m, MonadDelay m, MonadSTM m, MonadSay m, MonadFork m, MonadThrow m) => m () runAll = do   buyerTMVar <- newEmptyTMVarIO @m @(AnyMsg Role BookSt)   sellerTMVar <- newEmptyTMVarIO @m @(AnyMsg Role BookSt)
test/Book1.hs view
@@ -31,6 +31,7 @@ import TypedSession.Codec import TypedSession.Core import TypedSession.Driver+import Control.Monad.Class.MonadTimer (MonadDelay)  {- @@ -235,7 +236,7 @@     Date i -> "Date " <> show i     NotBuy -> "NotBuy" -runAll :: forall m. (Monad m, MonadSTM m, MonadSay m, MonadFork m, MonadThrow m) => m ()+runAll :: forall m. (Monad m, MonadDelay m, MonadSTM m, MonadSay m, MonadFork m, MonadThrow m) => m () runAll = do   buyerTMVar <- newEmptyTMVarIO @m @(AnyMsg Role BookSt)   buyer2TMVar <- newEmptyTMVarIO @m @(AnyMsg Role BookSt)
test/Book2.hs view
@@ -22,6 +22,7 @@ import Control.Monad.Class.MonadFork (MonadFork, forkIO) import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadThrow (MonadThrow)+import Control.Monad.Class.MonadTimer (MonadDelay) import Data.IFunctor (At (..), Sing, SingI, ireturn, returnAt) import qualified Data.IFunctor as I import qualified Data.IntMap as IntMap@@ -296,7 +297,7 @@     BookNotFoun -> "BookNotFound"     SellerNotFoundBook -> "SellerNotFoundBook" -runAll :: forall m. (Monad m, MonadSTM m, MonadSay m, MonadFork m, MonadThrow m) => m ()+runAll :: forall m. (Monad m, MonadDelay m, MonadSTM m, MonadSay m, MonadFork m, MonadThrow m) => m () runAll = do   buyerTMVar <- newEmptyTMVarIO @m @(AnyMsg Role BookSt)   buyer2TMVar <- newEmptyTMVarIO @m @(AnyMsg Role BookSt)
test/Book3/Main.hs view
@@ -31,6 +31,7 @@ import TypedSession.Codec import TypedSession.Core import TypedSession.Driver+import Control.Monad.Class.MonadTimer (MonadDelay)  mvarsAsChannel   :: (MonadSTM m)@@ -53,6 +54,7 @@      , MonadSay n      , MonadThrow n      , MonadFork n+     , MonadDelay n      )   => StdGen   -> n ()
test/Book3/Peer.hs view
@@ -32,7 +32,7 @@   :: (Has Random sig m)   => Int   -> Int-  -> Peer BookRole Book Buyer m EnoughOrNotEnough S8+  -> EnoughOrNotEnoughFun m checkPrice _i _h = I.do   At b <- liftm $ uniform @Bool   if b@@ -42,7 +42,7 @@ choiceOT   :: (Has Random sig m)   => Int-  -> Peer BookRole Book Buyer m OneOrTwo S4+  -> OneOrTwoFun m choiceOT _i = I.do   At b <- liftm $ uniform @Bool   if b@@ -91,7 +91,7 @@ choiceB   :: (Has Random sig m)   => Int-  -> Peer BookRole Book Buyer2 m SupportOrNotSupport S7+  -> SupportOrNotSupportFun m choiceB _i = I.do   At b <- liftm $ uniform @Bool   if b@@ -119,7 +119,7 @@ findBook   :: (Has Random sig m)   => String-  -> Peer BookRole Book Seller m FindBookResult S3+  -> FindBookResultFun m findBook _st = I.do   At b <- liftm $ uniform @Bool   if b
test/Book3/Protocol.hs view
@@ -17,6 +17,7 @@  import Book3.Type +import Language.Haskell.TH hiding (Type) import TypedSession.Codec import TypedSession.Core
test/PingPong.hs view
@@ -22,6 +22,7 @@ import Control.Monad.Class.MonadFork (MonadFork, forkIO) import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadThrow (MonadThrow)+import Control.Monad.Class.MonadTimer (MonadDelay) import Data.IFunctor (At (..), Sing, SingI, ireturn, returnAt) import qualified Data.IFunctor as I import qualified Data.IntMap as IntMap@@ -169,7 +170,7 @@     Pong i -> "Pong " <> show i     Stop -> "Stop" -runAll :: forall m. (Monad m, MonadSTM m, MonadSay m, MonadFork m, MonadThrow m) => m ()+runAll :: forall m. (Monad m, MonadDelay m, MonadSTM m, MonadSay m, MonadFork m, MonadThrow m) => m () runAll = do   clientTMVar <- newEmptyTMVarIO @m @(AnyMsg Role PingPong)   serverTMVar <- newEmptyTMVarIO @m @(AnyMsg Role PingPong)
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.1.2.0+version:            0.1.3.0  -- A short (one-line) description of the package. synopsis: typed session framework