├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── cabal.project ├── data ├── example.gif └── fm.png ├── desigen.dio ├── examples ├── Bank │ └── Bank.hs ├── Book3 │ ├── Buyer.hs │ ├── Buyer2.hs │ └── Seller.hs ├── KV │ └── Main.hs ├── PingPong │ ├── Client.hs │ ├── Counter.hs │ └── Server.hs ├── Ring │ └── Main.hs ├── cabal.project ├── examples.cabal └── src │ ├── Bank │ ├── Peer.hs │ ├── Protocol.hs │ └── Type.hs │ ├── Book3 │ ├── Codec.hs │ ├── Peer.hs │ ├── Protocol.hs │ └── Type.hs │ ├── KV │ ├── Peer.hs │ ├── Protocol.hs │ └── Type.hs │ ├── PingPong │ ├── Peer.hs │ ├── Protocol.hs │ └── Type.hs │ └── Ring │ ├── Peer.hs │ ├── Protocol.hs │ └── Type.hs ├── src ├── Data │ └── IFunctor.hs └── TypedSession │ ├── Codec.hs │ ├── Core.hs │ ├── Driver.hs │ └── TH.hs ├── test ├── Book3 │ ├── Main.hs │ ├── Peer.hs │ ├── Protocol.hs │ └── Type.hs └── Main.hs └── typed-session.cabal /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Haskell CI 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | pull_request: 7 | branches: [ "main" ] 8 | 9 | permissions: 10 | contents: read 11 | 12 | jobs: 13 | build: 14 | 15 | runs-on: ubuntu-latest 16 | 17 | steps: 18 | - uses: actions/checkout@v4 19 | - uses: haskell-actions/setup@v2.7.2 20 | with: 21 | ghc-version: '9.10.1' 22 | cabal-version: '3.12.1.0' 23 | 24 | - name: Cache 25 | uses: actions/cache@v3 26 | env: 27 | cache-name: cache-cabal 28 | with: 29 | path: ~/.cabal 30 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 31 | restore-keys: | 32 | ${{ runner.os }}-build-${{ env.cache-name }}- 33 | ${{ runner.os }}-build- 34 | ${{ runner.os }}- 35 | 36 | - name: Install dependencies 37 | run: | 38 | cabal update 39 | cabal build --only-dependencies --enable-tests --enable-benchmarks 40 | - name: Build 41 | run: cabal build --enable-tests --enable-benchmarks all 42 | - name: Run tests 43 | run: cabal test all 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | *.prot -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for typed-session 2 | ## 0.2.0.0 3 | * Remove data Recv 4 | 5 | ## 0.1.1.0 6 | * add protocol TH 7 | 8 | ## 0.1.0.0-- 2024-8-6 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 Yang Miao 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # typed-session 2 | 3 | ![img](data/example.gif) 4 | 5 | 6 | Typed session are used to ensure desirable properties in concurrent and distributed systems, i.e. absence of communication errors or deadlocks, and protocol conformance. 7 | 8 | [Introduction to typed-session](https://discourse.haskell.org/t/introduction-to-typed-session/10100) 9 | 10 | [How to use typed session](https://github.com/sdzx-1/How-to-use-typed-session) 11 | 12 | [typed-session-tutorial](https://github.com/sdzx-1/typed-session-tutorial) 13 | 14 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | tests: True 4 | -------------------------------------------------------------------------------- /data/example.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdzx-1/typed-session/1bccfea71a68094d4c7a2fb01f88f4f5770ceffa/data/example.gif -------------------------------------------------------------------------------- /data/fm.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sdzx-1/typed-session/1bccfea71a68094d4c7a2fb01f88f4f5770ceffa/data/fm.png -------------------------------------------------------------------------------- /desigen.dio: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | -------------------------------------------------------------------------------- /examples/Bank/Bank.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Bank.Peer 4 | 5 | main = Bank.Peer.main 6 | -------------------------------------------------------------------------------- /examples/Book3/Buyer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 4 | 5 | -- Echo server program 6 | module Main (main) where 7 | 8 | import Book3.Codec 9 | import Book3.Peer 10 | import Book3.Protocol 11 | import Control.Carrier.Random.Gen (runRandom) 12 | import qualified Control.Exception as E 13 | import Control.Monad (void) 14 | import Control.Monad.Class.MonadFork 15 | import Control.Monad.IO.Class (liftIO) 16 | import Network.Socket 17 | import System.Random (newStdGen) 18 | import TypedSession.Codec (Decode (..)) 19 | import TypedSession.Driver 20 | import Control.Carrier.Lift (runM) 21 | 22 | main :: IO () 23 | main = runTCPServer Nothing "3000" 24 | 25 | runTCPServer :: Maybe HostName -> ServiceName -> IO () 26 | runTCPServer mhost port = withSocketsDo $ do 27 | addr <- resolve 28 | E.bracket (open addr) close start 29 | where 30 | resolve = do 31 | let hints = 32 | defaultHints 33 | { addrFlags = [AI_PASSIVE] 34 | , addrSocketType = Stream 35 | } 36 | head <$> getAddrInfo (Just hints) mhost (Just port) 37 | 38 | open addr = E.bracketOnError (openSocket addr) close $ \sock -> do 39 | setSocketOption sock ReuseAddr 1 40 | withFdSocket sock setCloseOnExecIfNeeded 41 | bind sock $ addrAddress addr 42 | listen sock 1024 43 | return sock 44 | 45 | start sock = do 46 | (buyer2, _peer) <- accept sock 47 | (seller, _peer) <- accept sock 48 | 49 | let buyer2Channel = socketAsChannel buyer2 50 | sellerChannel = socketAsChannel seller 51 | 52 | buyerDriver <- 53 | driverSimple 54 | (myTracer "buyer :") 55 | encodeMsg 56 | (Decode decodeMsg) 57 | [ (SomeRole SBuyer2, buyer2Channel) 58 | , (SomeRole SSeller, sellerChannel) 59 | ] 60 | liftIO 61 | 62 | g <- newStdGen 63 | 64 | void $ runM $ runRandom g $ runPeerWithDriver buyerDriver buyerPeer 65 | 66 | close buyer2 67 | close seller 68 | -------------------------------------------------------------------------------- /examples/Book3/Buyer2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Echo client program 4 | module Main (main) where 5 | 6 | import Book3.Codec (decodeMsg, encodeMsg, myTracer, socketAsChannel) 7 | import Book3.Peer 8 | import Book3.Protocol 9 | import Book3.Type 10 | import Control.Carrier.Random.Gen (runRandom) 11 | import Control.Concurrent.Class.MonadSTM 12 | import qualified Control.Exception as E 13 | import Control.Monad.Class.MonadFork 14 | import Control.Monad.IO.Class (liftIO) 15 | import qualified Data.ByteString.Char8 as C 16 | import Data.Functor (void) 17 | import qualified Data.IntMap as IntMap 18 | import Network.Socket 19 | import Network.Socket.ByteString (recv, sendAll) 20 | import System.Random (newStdGen) 21 | import TypedSession.Codec (Decode (..)) 22 | import qualified TypedSession.Codec as C 23 | import TypedSession.Core (SingToInt (singToInt)) 24 | import TypedSession.Driver 25 | import TypedSession.Driver (driverSimple) 26 | import Control.Carrier.Lift (runM) 27 | 28 | main :: IO () 29 | main = runTCPClient "127.0.0.1" "3000" 30 | 31 | runTCPClient :: HostName -> ServiceName -> IO () 32 | runTCPClient host port = withSocketsDo $ do 33 | addr <- resolve 34 | E.bracket (open addr) close client 35 | where 36 | resolve = do 37 | let hints = defaultHints{addrSocketType = Stream} 38 | head <$> getAddrInfo (Just hints) (Just host) (Just port) 39 | 40 | open addr = E.bracketOnError (openSocket addr) close $ \sock -> do 41 | connect sock $ addrAddress addr 42 | return sock 43 | 44 | client sock = do 45 | buyer2Driver <- driverSimple (myTracer "buyer2 :") encodeMsg (Decode decodeMsg) [(SomeRole SBuyer, socketAsChannel sock)] liftIO 46 | g <- newStdGen 47 | void $ runM $ runRandom g $ runPeerWithDriver buyer2Driver buyer2Peer 48 | -------------------------------------------------------------------------------- /examples/Book3/Seller.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -- Echo client program 5 | module Main (main) where 6 | 7 | import Book3.Codec (decodeMsg, encodeMsg, myTracer, socketAsChannel) 8 | import Book3.Peer 9 | import Book3.Protocol 10 | import Book3.Type 11 | import Control.Carrier.Random.Gen (runRandom) 12 | import Control.Carrier.State.Strict (runState) 13 | import Control.Concurrent.Class.MonadSTM 14 | import qualified Control.Exception as E 15 | import Control.Monad.Class.MonadFork 16 | import Control.Monad.IO.Class (liftIO) 17 | import qualified Data.ByteString.Char8 as C 18 | import Data.Functor (void) 19 | import qualified Data.IntMap as IntMap 20 | import Network.Socket 21 | import Network.Socket.ByteString (recv, sendAll) 22 | import System.Random (newStdGen) 23 | import TypedSession.Codec (Decode (..)) 24 | import qualified TypedSession.Codec as C 25 | import TypedSession.Core (SingToInt (singToInt)) 26 | import TypedSession.Driver 27 | import TypedSession.Driver (driverSimple) 28 | import Control.Carrier.Lift (runM) 29 | 30 | main :: IO () 31 | main = runTCPClient "127.0.0.1" "3000" 32 | 33 | runTCPClient :: HostName -> ServiceName -> IO () 34 | runTCPClient host port = withSocketsDo $ do 35 | addr <- resolve 36 | E.bracket (open addr) close client 37 | where 38 | resolve = do 39 | let hints = defaultHints{addrSocketType = Stream} 40 | head <$> getAddrInfo (Just hints) (Just host) (Just port) 41 | 42 | open addr = E.bracketOnError (openSocket addr) close $ \sock -> do 43 | connect sock $ addrAddress addr 44 | return sock 45 | 46 | client sock = do 47 | sellerDriver <- driverSimple (myTracer "seller :") encodeMsg (Decode decodeMsg) [(SomeRole SBuyer, socketAsChannel sock)] liftIO 48 | g <- newStdGen 49 | void $ runM $ runRandom g $ runState @Int 0 $ runPeerWithDriver sellerDriver sellerPeer 50 | -------------------------------------------------------------------------------- /examples/KV/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import KV.Peer 4 | 5 | main :: IO () 6 | main = KV.Peer.main -------------------------------------------------------------------------------- /examples/PingPong/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Echo client program 4 | module Main (main) where 5 | 6 | import Control.Concurrent.Class.MonadSTM 7 | import qualified Control.Exception as E 8 | import Control.Monad (void) 9 | import Control.Monad.Class.MonadFork 10 | import qualified Data.IntMap as IntMap 11 | import Network.Socket 12 | import PingPong.Peer 13 | import PingPong.Protocol 14 | import PingPong.Type 15 | import TypedSession.Codec (Decode (..)) 16 | import qualified TypedSession.Codec as C 17 | import TypedSession.Core 18 | import TypedSession.Driver (SomeRole (SomeRole), decodeLoop, driverSimple, runPeerWithDriver) 19 | 20 | main :: IO () 21 | main = runTCPClient 22 | 23 | getSocket :: HostName -> ServiceName -> IO Socket 24 | getSocket host port = do 25 | addr <- resolve 26 | open addr 27 | where 28 | resolve = do 29 | let hints = defaultHints{addrSocketType = Stream} 30 | head <$> getAddrInfo (Just hints) (Just host) (Just port) 31 | 32 | open addr = E.bracketOnError (openSocket addr) close $ \sock -> do 33 | connect sock $ addrAddress addr 34 | return sock 35 | 36 | runTCPClient :: IO () 37 | runTCPClient = withSocketsDo $ do 38 | E.bracket 39 | ( do 40 | serverSock <- getSocket "127.0.0.1" "3000" 41 | countSock <- getSocket "127.0.0.1" "3001" 42 | pure (serverSock, countSock) 43 | ) 44 | (\(a, b) -> close a >> close b) 45 | (client) 46 | where 47 | client (serverSock, countSock) = do 48 | let serverChannel = socketAsChannel serverSock 49 | counterChannel = socketAsChannel countSock 50 | clientDriver <- 51 | driverSimple 52 | (myTracer "client: ") 53 | encodeMsg 54 | (Decode decodeMsg) 55 | [ (SomeRole SServer, serverChannel) 56 | , (SomeRole SCounter, counterChannel) 57 | ] 58 | id 59 | 60 | void $ runPeerWithDriver clientDriver (clientPeer 0) 61 | -------------------------------------------------------------------------------- /examples/PingPong/Counter.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Control.Exception as E 4 | import qualified Data.IntMap as IntMap 5 | import Network.Socket 6 | 7 | import Control.Concurrent.Class.MonadSTM 8 | import Control.Monad (void) 9 | import Control.Monad.Class.MonadFork 10 | import PingPong.Peer 11 | import PingPong.Protocol 12 | import PingPong.Type 13 | import TypedSession.Codec (Decode (..)) 14 | import qualified TypedSession.Codec as C 15 | import TypedSession.Core (singToInt) 16 | import TypedSession.Driver (SomeRole (SomeRole), decodeLoop, driverSimple, runPeerWithDriver) 17 | 18 | main :: IO () 19 | main = runTCPServer Nothing "3001" 20 | 21 | runTCPServer :: Maybe HostName -> ServiceName -> IO () 22 | runTCPServer mhost port = withSocketsDo $ do 23 | addr <- resolve 24 | E.bracket (open addr) close start 25 | where 26 | resolve = do 27 | let hints = 28 | defaultHints 29 | { addrFlags = [AI_PASSIVE] 30 | , addrSocketType = Stream 31 | } 32 | head <$> getAddrInfo (Just hints) mhost (Just port) 33 | 34 | open addr = E.bracketOnError (openSocket addr) close $ \sock -> do 35 | setSocketOption sock ReuseAddr 1 36 | withFdSocket sock setCloseOnExecIfNeeded 37 | bind sock $ addrAddress addr 38 | listen sock 1024 39 | return sock 40 | 41 | start sock = do 42 | (client, _peer) <- accept sock 43 | 44 | let clientChannel = socketAsChannel client 45 | 46 | counterDriver <- driverSimple (myTracer "counter: ") encodeMsg (Decode decodeMsg) [(SomeRole SClient, clientChannel)] id 47 | 48 | void $ runPeerWithDriver counterDriver (counterPeer 0) 49 | 50 | close client 51 | -------------------------------------------------------------------------------- /examples/PingPong/Server.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent.Class.MonadSTM 4 | import qualified Control.Exception as E 5 | import Control.Monad (void) 6 | import Control.Monad.Class.MonadFork 7 | import qualified Data.IntMap as IntMap 8 | import Network.Socket 9 | import PingPong.Peer 10 | import PingPong.Protocol 11 | import PingPong.Type 12 | import TypedSession.Codec (Decode (..)) 13 | import qualified TypedSession.Codec as C 14 | import TypedSession.Core (singToInt) 15 | import TypedSession.Driver (SomeRole (SomeRole), decodeLoop, driverSimple, runPeerWithDriver) 16 | 17 | main :: IO () 18 | main = runTCPServer Nothing "3000" 19 | 20 | runTCPServer :: Maybe HostName -> ServiceName -> IO () 21 | runTCPServer mhost port = withSocketsDo $ do 22 | addr <- resolve 23 | E.bracket (open addr) close start 24 | where 25 | resolve = do 26 | let hints = 27 | defaultHints 28 | { addrFlags = [AI_PASSIVE] 29 | , addrSocketType = Stream 30 | } 31 | head <$> getAddrInfo (Just hints) mhost (Just port) 32 | 33 | open addr = E.bracketOnError (openSocket addr) close $ \sock -> do 34 | setSocketOption sock ReuseAddr 1 35 | withFdSocket sock setCloseOnExecIfNeeded 36 | bind sock $ addrAddress addr 37 | listen sock 1024 38 | return sock 39 | 40 | start sock = do 41 | (client, _peer) <- accept sock 42 | let clientChannel = socketAsChannel client 43 | serverDriver <- driverSimple (myTracer "server: ") encodeMsg (Decode decodeMsg) [(SomeRole SClient, clientChannel)] id 44 | void $ runPeerWithDriver serverDriver serverPeer 45 | close client 46 | -------------------------------------------------------------------------------- /examples/Ring/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Ring.Peer 4 | 5 | main :: IO () 6 | main = Ring.Peer.main -------------------------------------------------------------------------------- /examples/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | , ../typed-session.cabal 3 | -------------------------------------------------------------------------------- /examples/examples.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | -- The cabal-version field refers to the version of the .cabal specification, 3 | -- and can be different from the cabal-install (the tool) version and the 4 | -- Cabal (the library) version you are using. As such, the Cabal (the library) 5 | -- version used must be equal or greater than the version stated in this field. 6 | -- Starting from the specification version 2.2, the cabal-version field must be 7 | -- the first thing in the cabal file. 8 | 9 | -- Initial package description 'examples' generated by 10 | -- 'cabal init'. For further documentation, see: 11 | -- http://haskell.org/cabal/users-guide/ 12 | -- 13 | -- The name of the package. 14 | name: examples 15 | 16 | -- The package version. 17 | -- See the Haskell package versioning policy (PVP) for standards 18 | -- guiding when and how versions should be incremented. 19 | -- https://pvp.haskell.org 20 | -- PVP summary: +-+------- breaking API changes 21 | -- | | +----- non-breaking API additions 22 | -- | | | +--- code changes with no API change 23 | version: 0.1.0.0 24 | 25 | -- A short (one-line) description of the package. 26 | -- synopsis: 27 | 28 | -- A longer description of the package. 29 | -- description: 30 | 31 | -- The package author(s). 32 | author: sdzx-1 33 | 34 | -- An email address to which users can send suggestions, bug reports, and patches. 35 | maintainer: shangdizhixia1993@163.com 36 | 37 | -- A copyright notice. 38 | -- copyright: 39 | build-type: Simple 40 | 41 | -- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. 42 | extra-doc-files: CHANGELOG.md 43 | 44 | -- Extra source files to be distributed with the package, such as examples, or a tutorial module. 45 | -- extra-source-files: 46 | 47 | 48 | library 49 | build-depends: base 50 | , typed-session 51 | , containers 52 | , io-classes 53 | , io-sim 54 | , random 55 | , fused-effects 56 | , fused-effects-random 57 | , binary 58 | , bytestring 59 | , network 60 | , template-haskell 61 | , split 62 | default-language: Haskell2010 63 | hs-source-dirs: src 64 | exposed-modules: Book3.Type 65 | , Book3.Peer 66 | , Book3.Codec 67 | , Book3.Protocol 68 | , PingPong.Type 69 | , PingPong.Protocol 70 | , PingPong.Peer 71 | , Bank.Type 72 | , Bank.Protocol 73 | , Bank.Peer 74 | , Ring.Peer 75 | , Ring.Protocol 76 | , Ring.Type 77 | , KV.Peer 78 | , KV.Protocol 79 | , KV.Type 80 | 81 | executable kv 82 | build-depends: base 83 | , examples 84 | main-is: Main.hs 85 | default-language: Haskell2010 86 | hs-source-dirs: KV 87 | 88 | executable ring 89 | build-depends: base 90 | , examples 91 | main-is: Main.hs 92 | default-language: Haskell2010 93 | hs-source-dirs: Ring 94 | 95 | 96 | executable bank 97 | build-depends: base 98 | , examples 99 | main-is: Bank.hs 100 | default-language: Haskell2010 101 | hs-source-dirs: Bank 102 | 103 | 104 | executable buyer 105 | build-depends: base 106 | , fused-effects 107 | , typed-session 108 | , io-classes 109 | , io-sim 110 | , random 111 | , containers 112 | , fused-effects-random 113 | , network 114 | , examples 115 | main-is: Buyer.hs 116 | default-language: Haskell2010 117 | hs-source-dirs: Book3 118 | 119 | 120 | executable seller 121 | build-depends: base 122 | , fused-effects 123 | , typed-session 124 | , io-classes 125 | , io-sim 126 | , random 127 | , containers 128 | , fused-effects-random 129 | , network 130 | , examples 131 | , bytestring 132 | main-is: Seller.hs 133 | default-language: Haskell2010 134 | hs-source-dirs: Book3 135 | 136 | executable buyer2 137 | build-depends: base 138 | , fused-effects 139 | , typed-session 140 | , io-classes 141 | , io-sim 142 | , random 143 | , containers 144 | , fused-effects-random 145 | , network 146 | , examples 147 | , bytestring 148 | main-is: Buyer2.hs 149 | default-language: Haskell2010 150 | hs-source-dirs: Book3 151 | 152 | 153 | executable server 154 | build-depends: base 155 | , typed-session 156 | , containers 157 | , io-classes 158 | , io-sim 159 | , random 160 | , fused-effects 161 | , fused-effects-random 162 | , binary 163 | , bytestring 164 | , network 165 | , examples 166 | main-is: Server.hs 167 | default-language: Haskell2010 168 | hs-source-dirs: PingPong 169 | 170 | executable client 171 | build-depends: base 172 | , typed-session 173 | , containers 174 | , io-classes 175 | , io-sim 176 | , random 177 | , fused-effects 178 | , fused-effects-random 179 | , binary 180 | , bytestring 181 | , network 182 | , examples 183 | main-is: Client.hs 184 | default-language: Haskell2010 185 | hs-source-dirs: PingPong 186 | 187 | 188 | executable counter 189 | build-depends: base 190 | , typed-session 191 | , containers 192 | , io-classes 193 | , io-sim 194 | , random 195 | , fused-effects 196 | , fused-effects-random 197 | , binary 198 | , bytestring 199 | , network 200 | , examples 201 | main-is: Counter.hs 202 | default-language: Haskell2010 203 | hs-source-dirs: PingPong -------------------------------------------------------------------------------- /examples/src/Bank/Peer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE QualifiedDo #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# OPTIONS_GHC -Wall #-} 7 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 8 | 9 | module Bank.Peer where 10 | 11 | import Bank.Protocol 12 | import Bank.Type 13 | 14 | import Control.Concurrent.Class.MonadSTM 15 | import Control.Monad 16 | import Control.Monad.Class.MonadFork (forkIO) 17 | import Data.IFunctor (At (..), returnAt) 18 | import qualified Data.IFunctor as I 19 | import qualified Data.IntMap as IntMap 20 | import TypedSession.Core 21 | import TypedSession.Driver 22 | 23 | choice :: ChoiceNextActionFun IO 24 | choice = I.do 25 | At tr <- liftm $ do 26 | putStrLn "Input command:" 27 | getLine 28 | case tr of 29 | "q" -> liftConstructor BranchSt_Finish 30 | st -> liftConstructor (BranchSt_Continue (parse st)) 31 | 32 | clientPeer 33 | :: Peer BankRole Bank Client IO (At () Done) ClientStartSt 34 | clientPeer = do 35 | choice I.>>= \case 36 | BranchSt_Finish -> I.do 37 | yield CStop 38 | BranchSt_Continue tr -> I.do 39 | yield (Command tr) 40 | await I.>>= \case 41 | ValidFailed -> I.do 42 | liftm $ putStrLn "valid failed" 43 | clientPeer 44 | ValidSuccessed -> I.do 45 | liftm $ putStrLn "valid successed" 46 | clientPeer 47 | 48 | validC :: Bool -> Bool -> ValidResultFun IO 49 | validC ar br = 50 | if ar && br 51 | then liftConstructor BranchSt_CTrue 52 | else liftConstructor BranchSt_CFalse 53 | 54 | coordinatorPeer 55 | :: Peer BankRole Bank Coordinator IO (At () Done) (CoordinatorStartSt s) 56 | coordinatorPeer = do 57 | await I.>>= \case 58 | CStop -> I.do 59 | yield BStop 60 | yield AStop 61 | Command tr -> I.do 62 | yield (Transaction1 tr) 63 | yield (Transaction2 tr) 64 | AliceValidResult ar <- await 65 | BobValidResult br <- await 66 | validC ar br I.>>= \case 67 | BranchSt_CFalse -> I.do 68 | yield ValidFailed 69 | yield ValidFailedA 70 | yield ValidFailedB 71 | coordinatorPeer 72 | BranchSt_CTrue -> I.do 73 | yield ValidSuccessed 74 | yield ValidSuccessedA 75 | yield ValidSuccessedB 76 | coordinatorPeer 77 | 78 | alicePeer :: Int -> Peer BankRole Bank Alice IO (At () Done) (AliceStartSt s) 79 | alicePeer val = I.do 80 | liftm $ putStrLn $ "alice's val: " ++ show val 81 | await I.>>= \case 82 | Transaction1 tr -> I.do 83 | let (valid, val') = validate "alice" val tr 84 | yield (AliceValidResult valid) 85 | await I.>>= \case 86 | ValidFailedA -> alicePeer val 87 | ValidSuccessedA -> alicePeer val' 88 | AStop -> returnAt () 89 | 90 | bobPeer :: Int -> Peer BankRole Bank Bob IO (At () Done) (BobStartSt s) 91 | bobPeer val = I.do 92 | liftm $ putStrLn $ "Bob's val: " ++ show val 93 | await I.>>= \case 94 | Transaction2 tr -> I.do 95 | let (valid, val') = validate "bob" val tr 96 | yield (BobValidResult valid) 97 | await I.>>= \case 98 | ValidFailedB -> bobPeer val 99 | ValidSuccessedB -> bobPeer val' 100 | BStop -> returnAt () 101 | 102 | main :: IO () 103 | main = do 104 | let rg = [Client .. Bob] 105 | vs <- forM rg $ \r -> do 106 | tvar <- newTVarIO IntMap.empty 107 | pure (fromEnum r, tvar) 108 | let allMap = IntMap.fromList vs 109 | driver r = localDriverSimple (\v -> putStrLn (show v)) allMap r id 110 | forkIO $ void $ runPeerWithDriver (driver $ SomeRole SCoordinator) coordinatorPeer 111 | forkIO $ void $ runPeerWithDriver (driver $ SomeRole SAlice) (alicePeer 0) 112 | forkIO $ void $ runPeerWithDriver (driver $ SomeRole SBob) (bobPeer 0) 113 | void $ runPeerWithDriver (driver $ SomeRole SClient) clientPeer -------------------------------------------------------------------------------- /examples/src/Bank/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MagicHash #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# OPTIONS_GHC -Wall #-} 12 | {-# OPTIONS_GHC -Wno-orphans #-} 13 | {-# OPTIONS_GHC -ddump-splices #-} 14 | 15 | module Bank.Protocol where 16 | 17 | import Bank.Type 18 | import TypedSession.Core 19 | 20 | [bankProtocol| 21 | Label 0 22 | Branch Client ChoiceNextAction { 23 | BranchSt Finish [] 24 | Msg CStop [] Client Coordinator 25 | Msg BStop [] Coordinator Bob 26 | Msg AStop [] Coordinator Alice 27 | Terminal 28 | BranchSt Continue [Transaction] 29 | Msg Command [Transaction] Client Coordinator 30 | Msg Transaction1 [Transaction] Coordinator Alice 31 | Msg Transaction2 [Transaction] Coordinator Bob 32 | Msg AliceValidResult [Bool] Alice Coordinator 33 | Msg BobValidResult [Bool] Bob Coordinator 34 | Branch Coordinator ValidResult { 35 | BranchSt CFalse [] 36 | Msg ValidFailed [] Coordinator Client 37 | Msg ValidFailedA [] Coordinator Alice 38 | Msg ValidFailedB [] Coordinator Bob 39 | Goto 0 40 | BranchSt CTrue [] 41 | Msg ValidSuccessed [] Coordinator Client 42 | Msg ValidSuccessedA [] Coordinator Alice 43 | Msg ValidSuccessedB [] Coordinator Bob 44 | Goto 0 45 | 46 | } 47 | } 48 | |] 49 | 50 | instance Show (AnyMsg BankRole Bank) where 51 | show (AnyMsg msg) = case msg of 52 | CStop -> "CStop" 53 | BStop -> "BStop" 54 | AStop -> "AStop" 55 | Command tr -> "Command " ++ show tr 56 | Transaction1 tr -> "Transaction1 " ++ show tr 57 | Transaction2 tr -> "Transaction2 " ++ show tr 58 | AliceValidResult b -> "AliceValidResult " ++ show b 59 | BobValidResult b -> "BobValidResult " ++ show b 60 | ValidFailed -> "ValidFailed" 61 | ValidFailedA -> "ValidFailedA" 62 | ValidFailedB -> "ValidFailedB" 63 | ValidSuccessed -> "ValidSuccessed" 64 | ValidSuccessedA -> "ValidSuccessedA" 65 | ValidSuccessedB -> "ValidSuccessedB" 66 | -------------------------------------------------------------------------------- /examples/src/Bank/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE NumericUnderscores #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE QualifiedDo #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | {-# LANGUAGE TypeApplications #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | {-# OPTIONS_GHC -Wall #-} 19 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 20 | 21 | module Bank.Type where 22 | 23 | import Language.Haskell.TH.Quote 24 | import TypedSession.TH 25 | import Data.List.Split (splitOn) 26 | import Data.Maybe (mapMaybe) 27 | import Text.Read (readMaybe) 28 | 29 | {- 30 | bank-2pc 31 | 32 | https://github.com/gshen42/HasChor/tree/main/examples/bank-2pc 33 | -} 34 | 35 | data BankRole = Client | Coordinator | Alice | Bob 36 | deriving (Show, Eq, Ord, Enum, Bounded) 37 | 38 | data BankBranchSt = Continue | Finish | CTrue | CFalse 39 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 40 | 41 | bankProtocol :: QuasiQuoter 42 | bankProtocol = protocol @BankRole @BankBranchSt "Bank" ''BankRole ''BankBranchSt 43 | 44 | type Action = (String, Int) 45 | 46 | type Transaction = [Action] 47 | 48 | validate :: String -> Int -> Transaction -> (Bool, Int) 49 | validate name balance tx = 50 | foldl (\(valid, i) (_, amount) -> (let next = i + amount in (valid && next >= 0, next))) (True, balance) actions 51 | where 52 | actions = filter (\(n, _) -> n == name) tx 53 | 54 | parse :: String -> Transaction 55 | parse s = tx 56 | where 57 | t = splitOn ";" s 58 | f :: String -> Maybe Action 59 | f l = do 60 | [target, amountStr] <- return $ words l 61 | amount <- readMaybe amountStr :: Maybe Int 62 | target' <- if target == "alice" || target == "bob" then Just target else Nothing 63 | return (target', amount) 64 | tx = mapMaybe f t -------------------------------------------------------------------------------- /examples/src/Book3/Codec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE QualifiedDo #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# OPTIONS_GHC -Wall #-} 16 | 17 | module Book3.Codec where 18 | 19 | import Book3.Protocol 20 | import Book3.Type 21 | import Control.Monad.Class.MonadSay (MonadSay (say)) 22 | import Data.Binary 23 | import Data.Binary.Get 24 | import Data.Binary.Put 25 | import qualified Data.ByteString as BS 26 | import qualified Data.ByteString.Builder.Extra as L 27 | import qualified Data.ByteString.Lazy as L 28 | import qualified Network.Socket as Socket 29 | import qualified Network.Socket.ByteString as Socket 30 | import TypedSession.Codec 31 | import TypedSession.Core 32 | import TypedSession.Driver 33 | 34 | encodeMsg :: Encode BookRole Book L.ByteString 35 | encodeMsg = Encode $ \x -> runPut $ case x of 36 | Title st -> putWord8 0 >> put st 37 | NoBook -> putWord8 1 38 | SellerNoBook -> putWord8 2 39 | Price i -> putWord8 3 >> put i 40 | OneAccept -> putWord8 5 41 | OneDate i -> putWord8 6 >> put i 42 | OneSuccess i -> putWord8 7 >> put i 43 | PriceToBuyer2 i -> putWord8 8 >> put i 44 | NotSupport1 -> putWord8 9 45 | TwoNotBuy -> putWord8 10 46 | SupportVal i -> putWord8 11 >> put i 47 | TwoAccept -> putWord8 12 48 | TwoDate i -> putWord8 13 >> put i 49 | TwoSuccess i -> putWord8 14 >> put i 50 | TwoNotBuy1 -> putWord8 15 51 | TwoFailed -> putWord8 16 52 | FinishBuyer -> putWord8 17 53 | FinishBuyer2 -> putWord8 18 54 | 55 | getAnyMsg :: Get (AnyMsg BookRole Book) 56 | getAnyMsg = do 57 | v <- getWord8 58 | case v of 59 | -- Title st -> putWord8 0 >> put st 60 | 0 -> get >>= pure . AnyMsg . Title 61 | -- NoBook -> putWord8 1 62 | 1 -> pure (AnyMsg NoBook) 63 | -- SellerNoBook -> putWord8 2 64 | 2 -> pure (AnyMsg SellerNoBook) 65 | -- Price i -> putWord8 3 >> put i 66 | 3 -> get >>= pure . AnyMsg . Price 67 | -- OneAccept -> putWord8 5 68 | 5 -> pure (AnyMsg OneAccept) 69 | -- OneDate i -> putWord8 6 >> put i 70 | 6 -> get >>= pure . AnyMsg . OneDate 71 | -- OneSuccess i -> putWord8 7 >> put i 72 | 7 -> get >>= pure . AnyMsg . OneSuccess 73 | -- PriceToBuyer2 i -> putWord8 8 >> put i 74 | 8 -> get >>= pure . AnyMsg . PriceToBuyer2 75 | -- NotSupport1 -> putWord8 9 76 | 9 -> pure (AnyMsg NotSupport1) 77 | -- TwoNotBuy -> putWord8 10 78 | 10 -> pure (AnyMsg TwoNotBuy) 79 | -- SupportVal i -> putWord8 11 >> put i 80 | 11 -> get >>= pure . AnyMsg . SupportVal 81 | -- TwoAccept -> putWord8 12 82 | 12 -> pure (AnyMsg TwoAccept) 83 | -- TwoDate i -> putWord8 13 >> put i 84 | 13 -> get >>= pure . AnyMsg . TwoDate 85 | -- TwoSuccess i -> putWord8 14 >> put i 86 | 14 -> get >>= pure . AnyMsg . TwoSuccess 87 | -- TwoNotBuy1 -> putWord8 15 88 | 15 -> pure (AnyMsg TwoNotBuy1) 89 | -- TwoFailed -> putWord8 16 90 | 16 -> pure (AnyMsg TwoFailed) 91 | 17 -> pure (AnyMsg FinishBuyer) 92 | 18 -> pure (AnyMsg FinishBuyer2) 93 | i -> error $ "undefined index: " ++ show i 94 | 95 | convertDecoderLBS1 96 | :: Decoder a 97 | -> (DecodeStep L.ByteString CodecFailure a) 98 | convertDecoderLBS1 = go 99 | where 100 | go :: Decoder a -> DecodeStep L.ByteString CodecFailure a 101 | go (Done tr _ a) = DecodeDone a (Just $ L.fromStrict tr) 102 | go (Fail _ _ e) = DecodeFail (CodecFailure e) 103 | go (Partial k) = DecodePartial $ \mbs -> case mbs of 104 | Nothing -> DecodeFail (CodecFailure "Peer disconnected!!") 105 | Just _bs -> go (k $ fmap L.toStrict mbs) 106 | 107 | decodeMsg 108 | :: DecodeStep 109 | L.ByteString 110 | CodecFailure 111 | (AnyMsg BookRole Book) 112 | decodeMsg = convertDecoderLBS1 (runGetIncremental getAnyMsg) 113 | 114 | socketAsChannel :: Socket.Socket -> Channel IO L.ByteString 115 | socketAsChannel socket = 116 | Channel{send, recv} 117 | where 118 | send :: L.ByteString -> IO () 119 | send chunks = 120 | Socket.sendMany socket (L.toChunks chunks) 121 | 122 | recv :: IO (Maybe L.ByteString) 123 | recv = do 124 | chunk <- Socket.recv socket L.smallChunkSize 125 | if BS.null chunk 126 | then return Nothing 127 | else return (Just (L.fromStrict chunk)) 128 | 129 | myTracer :: (MonadSay m) => String -> Tracer BookRole Book m 130 | myTracer st v = say (st <> show v) -------------------------------------------------------------------------------- /examples/src/Book3/Peer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE QualifiedDo #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# OPTIONS_GHC -Wall #-} 17 | 18 | module Book3.Peer where 19 | 20 | import Book3.Protocol 21 | import Book3.Type 22 | import Control.Algebra ((:+:)) 23 | import Control.Effect.Random (Random, uniform) 24 | import Control.Effect.State 25 | import Data.IFunctor (At (..), returnAt) 26 | import qualified Data.IFunctor as I 27 | import TypedSession.Core 28 | 29 | budget :: Int 30 | budget = 16 31 | 32 | type Date = Int 33 | 34 | checkPrice 35 | :: (Has Random sig m) 36 | => Int 37 | -> Int 38 | -> EnoughtOrNotEnoughFun m 39 | checkPrice _i _h = I.do 40 | At b <- liftm $ uniform @Bool 41 | if b 42 | then liftConstructor BranchSt_Enough 43 | else liftConstructor BranchSt_NotEnough 44 | 45 | choiceOT 46 | :: (Has Random sig m) 47 | => Int 48 | -> OneOrTwoFun m 49 | choiceOT _i = I.do 50 | At b <- liftm $ uniform @Bool 51 | if b 52 | then liftConstructor BranchSt_One 53 | else liftConstructor BranchSt_Two 54 | 55 | buyerPeer 56 | :: (Has Random sig m) 57 | => Peer BookRole Book Buyer m (At (Maybe Date) Done) BuyerStartSt 58 | buyerPeer = I.do 59 | yield (Title "haskell book") 60 | await I.>>= \case 61 | FinishBuyer -> I.do 62 | yield FinishBuyer2 63 | returnAt Nothing 64 | NoBook -> I.do 65 | yield SellerNoBook 66 | buyerPeer 67 | (Price i) -> I.do 68 | choiceOT i I.>>= \case 69 | BranchSt_One -> I.do 70 | yield OneAccept 71 | (OneDate d) <- await 72 | yield (OneSuccess d) 73 | buyerPeer 74 | BranchSt_Two -> I.do 75 | yield (PriceToBuyer2 (i `div` 2)) 76 | await I.>>= \case 77 | NotSupport1 -> I.do 78 | yield TwoNotBuy 79 | buyerPeer 80 | (SupportVal h) -> I.do 81 | checkPrice 10 h I.>>= \case 82 | BranchSt_Enough -> I.do 83 | yield TwoAccept 84 | (TwoDate d) <- await 85 | yield (TwoSuccess d) 86 | buyerPeer 87 | BranchSt_NotEnough -> I.do 88 | yield TwoNotBuy1 89 | yield TwoFailed 90 | buyerPeer 91 | 92 | choiceB 93 | :: (Has Random sig m) 94 | => Int 95 | -> SupportOrNotSupportFun m 96 | choiceB _i = I.do 97 | At b <- liftm $ uniform @Bool 98 | if b 99 | then liftConstructor BranchSt_Support 100 | else liftConstructor BranchSt_NotSupport 101 | 102 | buyer2Peer 103 | :: (Has Random sig m) 104 | => Peer BookRole Book Buyer2 m (At (Maybe Date) Done) (Buyer2StartSt s) 105 | buyer2Peer = I.do 106 | await I.>>= \case 107 | FinishBuyer2 -> returnAt Nothing 108 | SellerNoBook -> buyer2Peer 109 | (OneSuccess d) -> buyer2Peer 110 | (PriceToBuyer2 i) -> I.do 111 | choiceB i I.>>= \case 112 | BranchSt_NotSupport -> I.do 113 | yield NotSupport1 114 | buyer2Peer 115 | BranchSt_Support -> I.do 116 | yield (SupportVal (i `div` 2)) 117 | await I.>>= \case 118 | (TwoSuccess d) -> buyer2Peer 119 | TwoFailed -> buyer2Peer 120 | 121 | findBook 122 | :: (Has (Random :+: State Int) sig m) 123 | => String 124 | -> ChoiceActionFun m 125 | findBook _st = I.do 126 | At i <- liftm $ get @Int 127 | if i > 30 128 | then liftConstructor BranchSt_Finish 129 | else I.do 130 | At b <- liftm $ uniform @Bool 131 | if b 132 | then liftConstructor BranchSt_Found 133 | else liftConstructor BranchSt_NotFound 134 | 135 | sellerPeer 136 | :: (Has (Random :+: State Int) sig m) 137 | => Peer BookRole Book Seller m (At () Done) SellerStartSt 138 | sellerPeer = I.do 139 | liftm $ modify @Int (+ 1) 140 | (Title st) <- await 141 | findBook st I.>>= \case 142 | BranchSt_Finish -> I.do 143 | yield FinishBuyer 144 | BranchSt_NotFound -> I.do 145 | yield NoBook 146 | sellerPeer 147 | BranchSt_Found -> I.do 148 | yield (Price 30) 149 | await I.>>= \case 150 | OneAccept -> I.do 151 | yield (OneDate 100) 152 | sellerPeer 153 | TwoNotBuy -> sellerPeer 154 | TwoAccept -> I.do 155 | yield (TwoDate 100) 156 | sellerPeer 157 | TwoNotBuy1 -> sellerPeer 158 | -------------------------------------------------------------------------------- /examples/src/Book3/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MagicHash #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# OPTIONS_GHC -Wno-orphans #-} 14 | {-# OPTIONS_GHC -ddump-splices #-} 15 | 16 | module Book3.Protocol where 17 | 18 | import Book3.Type 19 | 20 | import Data.IFunctor (Sing, SingI (sing)) 21 | import GHC.Exts (Int (..), dataToTag#) 22 | import TypedSession.Codec 23 | import TypedSession.Core 24 | 25 | [bookProtocol| 26 | Label 0 27 | Msg Title [String] Buyer Seller 28 | Branch Seller ChoiceAction{ 29 | BranchSt Finish [] 30 | Msg FinishBuyer [] Seller Buyer 31 | Msg FinishBuyer2 [] Buyer Buyer2 32 | Terminal 33 | BranchSt NotFound [] 34 | Msg NoBook [] Seller Buyer 35 | Msg SellerNoBook [] Buyer Buyer2 36 | Goto 0 37 | BranchSt Found [] 38 | Msg Price [Int] Seller Buyer 39 | Branch Buyer OneOrTwo { 40 | BranchSt One [] 41 | Msg OneAccept [] Buyer Seller 42 | Msg OneDate [Int] Seller Buyer 43 | Msg OneSuccess [Int] Buyer Buyer2 44 | Goto 0 45 | BranchSt Two [] 46 | Msg PriceToBuyer2 [Int] Buyer Buyer2 47 | Branch Buyer2 SupportOrNotSupport { 48 | BranchSt NotSupport [] 49 | Msg NotSupport1 [] Buyer2 Buyer 50 | Msg TwoNotBuy [] Buyer Seller 51 | Goto 0 52 | BranchSt Support [] 53 | Msg SupportVal [Int] Buyer2 Buyer 54 | Branch Buyer EnoughtOrNotEnough { 55 | BranchSt Enough [] 56 | Msg TwoAccept [] Buyer Seller 57 | Msg TwoDate [Int] Seller Buyer 58 | Msg TwoSuccess [Int] Buyer Buyer2 59 | Goto 0 60 | BranchSt NotEnough [] 61 | Msg TwoNotBuy1 [] Buyer Seller 62 | Msg TwoFailed [] Buyer Buyer2 63 | Goto 0 64 | } 65 | } 66 | } 67 | } 68 | 69 | |] 70 | 71 | instance Show (AnyMsg BookRole Book) where 72 | show (AnyMsg msg) = case msg of 73 | Title st -> "Title " <> show st 74 | NoBook -> "NoBook" 75 | SellerNoBook -> "SellerNoBook" 76 | Price i -> "Price " <> show i 77 | OneAccept -> "OneAccept" 78 | OneDate d -> "OneDate " <> show d 79 | OneSuccess d -> "OneSuccess" <> show d 80 | PriceToBuyer2 i -> "PriceToBuyer2 " <> show i 81 | NotSupport1 -> "NotSupport1" 82 | TwoNotBuy -> "TwoNotBuy" 83 | SupportVal v -> "SupportVal " <> show v 84 | TwoAccept -> "TwoAccept" 85 | TwoDate d -> "TwoDate " <> show d 86 | TwoSuccess d -> "TwoSuccess " <> show d 87 | TwoNotBuy1 -> "TwoNotBuy1" 88 | TwoFailed -> "TwoFailed" 89 | FinishBuyer -> "FinishBuyer" 90 | FinishBuyer2 -> "FinishBuyer2" -------------------------------------------------------------------------------- /examples/src/Book3/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE QualifiedDo #-} 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | 18 | module Book3.Type where 19 | 20 | import Data.IFunctor (Sing, SingI) 21 | import qualified Data.IFunctor as I 22 | import Data.Kind 23 | import GHC.Exts (dataToTag#) 24 | import GHC.Int (Int (I#)) 25 | import Language.Haskell.TH.Quote (QuasiQuoter) 26 | import TypedSession.Core 27 | import TypedSession.TH (protocol) 28 | 29 | data BookRole = Buyer | Seller | Buyer2 30 | deriving (Show, Eq, Ord, Enum, Bounded) 31 | 32 | data BookBranchSt 33 | = Finish 34 | | NotFound 35 | | Found 36 | | One 37 | | Two 38 | | Support 39 | | NotSupport 40 | | Enough 41 | | NotEnough 42 | deriving (Show, Eq, Ord, Enum, Bounded) 43 | 44 | bookProtocol :: QuasiQuoter 45 | bookProtocol = 46 | protocol 47 | @BookRole 48 | @BookBranchSt 49 | "Book" 50 | ''BookRole 51 | ''BookBranchSt 52 | -------------------------------------------------------------------------------- /examples/src/KV/Peer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE QualifiedDo #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 7 | 8 | module KV.Peer where 9 | 10 | import Control.Concurrent.Class.MonadSTM (MonadSTM (..)) 11 | import Control.Monad (void) 12 | import Control.Monad.Class.MonadFork (forkIO) 13 | import Data.IFunctor (At (At), returnAt) 14 | import qualified Data.IFunctor as I 15 | import Data.IORef 16 | import qualified Data.IntMap as IntMap 17 | import Data.Map (Map) 18 | import qualified Data.Map as Map 19 | import Data.Traversable (for) 20 | import KV.Protocol 21 | import KV.Type 22 | import TypedSession.Core 23 | import TypedSession.Driver (SomeRole (SomeRole), localDriverSimple, runPeerWithDriver) 24 | 25 | choice :: ChoiceNextActionFun IO 26 | choice = I.do 27 | At st <- liftm $ readRequest 28 | case st of 29 | RExit -> liftConstructor BranchSt_Stop 30 | RPut k v -> liftConstructor (BranchSt_Put k v) 31 | RGet k -> liftConstructor (BranchSt_Get k) 32 | 33 | clientPeer :: Peer KVRole KV Client IO (At () Done) ClientStartSt 34 | clientPeer = I.do 35 | choice I.>>= \case 36 | BranchSt_Stop -> I.do 37 | yield PStop 38 | yield BStop 39 | BranchSt_Put k v -> I.do 40 | yield (PutKV k v) 41 | clientPeer 42 | BranchSt_Get k -> I.do 43 | yield (GetKey k) 44 | GetKeyResult res <- await 45 | liftm $ putStrLn $ "Result: " <> show res 46 | clientPeer 47 | 48 | primaryPeer 49 | :: IORef (Map String String) 50 | -> Peer KVRole KV Primary IO (At () Done) (PrimaryStartSt s) 51 | primaryPeer kvmapRef = I.do 52 | await I.>>= \case 53 | PStop -> returnAt () 54 | PutKV k v -> I.do 55 | liftm $ modifyIORef' kvmapRef (Map.insert k v) 56 | yield (BackupKV k v) 57 | primaryPeer kvmapRef 58 | GetKey k -> I.do 59 | At v <- liftm $ (Map.lookup k) <$> readIORef kvmapRef 60 | yield (GetKeyResult v) 61 | primaryPeer kvmapRef 62 | 63 | backupPeer :: IORef (Map String String) -> Peer KVRole KV Backup IO (At () Done) (BackupStartSt s) 64 | backupPeer kvmapRef = I.do 65 | await I.>>= \case 66 | BStop -> returnAt () 67 | BackupKV k v -> I.do 68 | liftm $ do 69 | modifyIORef' kvmapRef (Map.insert k v) 70 | putStrLn $ "Backup: " <> k <> "," <> v 71 | backupPeer kvmapRef 72 | 73 | main :: IO () 74 | main = do 75 | let rg = [Client .. Backup] 76 | vs <- for rg $ \r -> do 77 | tvar <- newTVarIO IntMap.empty 78 | pure (fromEnum r, tvar) 79 | let allMap = IntMap.fromList vs 80 | driver someRole = localDriverSimple (\v -> putStrLn (show v)) allMap someRole id 81 | kvmapP <- newIORef Map.empty 82 | kvmapB <- newIORef Map.empty 83 | forkIO $ void $ runPeerWithDriver (driver $ SomeRole SPrimary) (primaryPeer kvmapP) 84 | forkIO $ void $ runPeerWithDriver (driver $ SomeRole SBackup) (backupPeer kvmapB) 85 | void $ runPeerWithDriver (driver $ SomeRole SClient) clientPeer -------------------------------------------------------------------------------- /examples/src/KV/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# OPTIONS_GHC -Wall #-} 13 | {-# OPTIONS_GHC -Wno-orphans #-} 14 | {-# OPTIONS_GHC -ddump-splices #-} 15 | 16 | module KV.Protocol where 17 | 18 | import KV.Type 19 | import TypedSession.Core 20 | 21 | [kvProtocol| 22 | 23 | Label 0 24 | Branch Client ChoiceNextAction { 25 | BranchSt Stop [] 26 | Msg PStop [] Client Primary 27 | Msg BStop [] Client Backup 28 | Terminal 29 | BranchSt Put [String, String] 30 | Msg PutKV [String, String] Client Primary 31 | Msg BackupKV [String, String] Primary Backup 32 | Goto 0 33 | BranchSt Get [String] 34 | Msg GetKey [String] Client Primary 35 | Msg GetKeyResult [Maybe String] Primary Client 36 | Goto 0 37 | } 38 | 39 | |] 40 | 41 | instance Show (AnyMsg KVRole KV) where 42 | show (AnyMsg msg) = case msg of 43 | PStop -> "PStop" 44 | BStop -> "BStop" 45 | PutKV k v -> "PutKV: " <> k <> "," <> v 46 | BackupKV k v -> "BackupKV: " <> k <> "," <> v 47 | GetKey k -> "GetKey: " <> k 48 | GetKeyResult r -> "GetKeyResult: " <> show r 49 | 50 | data Request = RExit | RPut String String | RGet String deriving (Show, Read) 51 | 52 | readRequest :: IO Request 53 | readRequest = do 54 | putStrLn "Command?" 55 | line <- getLine 56 | case parseRequest line of 57 | Just t -> return t 58 | Nothing -> putStrLn "Invalid command" >> readRequest 59 | where 60 | parseRequest :: String -> Maybe Request 61 | parseRequest s = 62 | let l = words s 63 | in case l of 64 | ["GET", k] -> Just (RGet k) 65 | ["PUT", k, v] -> Just (RPut k v) 66 | "q" : _ -> Just RExit 67 | _ -> Nothing 68 | -------------------------------------------------------------------------------- /examples/src/KV/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskellQuotes #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module KV.Type where 5 | 6 | -- origin example: https://github.com/gshen42/HasChor/blob/main/examples/kvs-2-primary-backup/Main.hs 7 | import TypedSession.TH 8 | 9 | data KVRole = Client | Primary | Backup 10 | deriving (Eq, Ord, Show, Enum, Bounded) 11 | 12 | data KVBranchSt = Stop | Put | Get 13 | deriving (Eq, Ord, Show, Enum, Bounded) 14 | 15 | kvProtocol = protocol @KVRole @KVBranchSt "KV" ''KVRole ''KVBranchSt -------------------------------------------------------------------------------- /examples/src/PingPong/Peer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE NumericUnderscores #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE QualifiedDo #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TypeApplications #-} 16 | {-# LANGUAGE TypeFamilies #-} 17 | {-# OPTIONS_GHC -Wall #-} 18 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 19 | 20 | module PingPong.Peer where 21 | 22 | import Control.Monad.Class.MonadSay 23 | import Control.Monad.IO.Class (MonadIO, liftIO) 24 | import Data.Binary 25 | import Data.Binary.Get 26 | import Data.Binary.Put 27 | import qualified Data.ByteString as BS 28 | import qualified Data.ByteString.Builder.Extra as L 29 | import qualified Data.ByteString.Lazy as L 30 | import Data.IFunctor (At (..), ireturn, returnAt) 31 | import qualified Data.IFunctor as I 32 | import Data.Kind 33 | import qualified Network.Socket as Socket 34 | import qualified Network.Socket.ByteString as Socket 35 | import PingPong.Protocol 36 | import PingPong.Type 37 | import TypedSession.Codec 38 | import TypedSession.Core 39 | import TypedSession.Driver 40 | 41 | encodeMsg :: Encode PingPongRole PingPong L.ByteString 42 | encodeMsg = Encode $ \x -> runPut $ case x of 43 | Ping -> putWord8 0 44 | Pong -> putWord8 1 45 | Stop -> putWord8 2 46 | AddOne -> putWord8 3 47 | CStop -> putWord8 4 48 | Check i -> putWord8 6 >> put i 49 | CheckResult i -> putWord8 7 >> put i 50 | 51 | getAnyMsg :: Get (AnyMsg PingPongRole PingPong) 52 | getAnyMsg = do 53 | v <- getWord8 54 | case v of 55 | 0 -> pure (AnyMsg Ping) 56 | 1 -> pure (AnyMsg Pong) 57 | 2 -> pure (AnyMsg Stop) 58 | 3 -> pure (AnyMsg AddOne) 59 | 4 -> pure (AnyMsg CStop) 60 | 6 -> do 61 | i <- get 62 | pure (AnyMsg $ Check i) 63 | 7 -> do 64 | i <- get 65 | pure (AnyMsg $ CheckResult i) 66 | i -> error $ "undefined index: " ++ show i 67 | 68 | convertDecoderLBS1 69 | :: Decoder a 70 | -> (DecodeStep L.ByteString CodecFailure a) 71 | convertDecoderLBS1 = go 72 | where 73 | go :: Decoder a -> DecodeStep L.ByteString CodecFailure a 74 | go (Done tr _ a) = DecodeDone a (Just $ L.fromStrict tr) 75 | go (Fail _ _ e) = DecodeFail (CodecFailure e) 76 | go (Partial k) = DecodePartial $ \mbs -> case mbs of 77 | Nothing -> DecodeFail (CodecFailure "Peer disconnected!!") 78 | Just bs -> go (k $ Just $ L.toStrict bs) 79 | 80 | decodeMsg 81 | :: DecodeStep 82 | L.ByteString 83 | CodecFailure 84 | (AnyMsg PingPongRole PingPong) 85 | decodeMsg = convertDecoderLBS1 (runGetIncremental getAnyMsg) 86 | 87 | socketAsChannel :: Socket.Socket -> Channel IO L.ByteString 88 | socketAsChannel socket = 89 | Channel{send, recv} 90 | where 91 | send :: L.ByteString -> IO () 92 | send chunks = do 93 | Socket.sendMany socket (L.toChunks chunks) 94 | 95 | recv :: IO (Maybe L.ByteString) 96 | recv = do 97 | chunk <- Socket.recv socket L.smallChunkSize 98 | if BS.null chunk 99 | then return Nothing 100 | else return (Just (L.fromStrict chunk)) 101 | 102 | myTracer :: (MonadSay m) => String -> Tracer PingPongRole PingPong m 103 | myTracer st v = say (st <> show v) 104 | 105 | choice :: (Monad m) => Int -> ChoiceNextActionFun m 106 | choice i = 107 | if i `mod` 10 == 1 108 | then liftConstructor BranchSt_CheckVal 109 | else 110 | if i <= 50 111 | then liftConstructor BranchSt_Continue 112 | else liftConstructor BranchSt_Finish 113 | 114 | clientPeer 115 | :: (Monad m) => Int -> Peer PingPongRole PingPong Client m (At () Done) ClientStartSt 116 | clientPeer i = I.do 117 | res <- choice i 118 | case res of 119 | BranchSt_CheckVal -> I.do 120 | yield (Check i) 121 | (CheckResult _b) <- await 122 | clientPeer (i + 1) 123 | BranchSt_Continue -> I.do 124 | yield Ping 125 | Pong <- await 126 | yield AddOne 127 | clientPeer (i + 1) 128 | BranchSt_Finish -> I.do 129 | yield Stop 130 | yield CStop 131 | 132 | serverPeer 133 | :: (Monad m) => Peer PingPongRole PingPong Server m (At () Done) (ServerStartSt s) 134 | serverPeer = I.do 135 | msg <- await 136 | case msg of 137 | Ping -> I.do 138 | yield Pong 139 | serverPeer 140 | Stop -> returnAt () 141 | 142 | counterPeer 143 | :: (MonadIO m) => Int -> Peer PingPongRole PingPong Counter m (At () Done) (CounterStartSt s) 144 | counterPeer i = I.do 145 | msg <- await 146 | case msg of 147 | Check _i -> I.do 148 | yield (CheckResult True) 149 | counterPeer i 150 | AddOne -> I.do 151 | liftm $ liftIO $ putStrLn $ "counter val: " <> show i 152 | counterPeer (i + 1) 153 | CStop -> returnAt () -------------------------------------------------------------------------------- /examples/src/PingPong/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MagicHash #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# OPTIONS_GHC -Wall #-} 12 | {-# OPTIONS_GHC -Wno-orphans #-} 13 | 14 | module PingPong.Protocol where 15 | 16 | import PingPong.Type 17 | import TypedSession.Core 18 | 19 | [pingpongProtocl| 20 | 21 | Label 0 22 | Branch Client ChoiceNextAction { 23 | BranchSt CheckVal [] 24 | Msg Check [Int] Client Counter 25 | Msg CheckResult [Bool] Counter Client 26 | Goto 0 27 | BranchSt Continue [] 28 | Msg Ping [] Client Server 29 | Msg Pong [] Server Client 30 | Msg AddOne [] Client Counter 31 | Goto 0 32 | BranchSt Finish [] 33 | Msg Stop [] Client Server 34 | Msg CStop [] Client Counter 35 | Terminal 36 | } 37 | 38 | |] 39 | 40 | instance Show (AnyMsg PingPongRole PingPong) where 41 | show (AnyMsg msg) = case msg of 42 | Ping -> "Ping" 43 | Pong -> "Pong" 44 | Stop -> "Stop" 45 | AddOne -> "AddOne" 46 | CStop -> "CStop" 47 | Check i -> "CheckValue " ++ show i 48 | CheckResult b -> "CheckResult " ++ show b 49 | -------------------------------------------------------------------------------- /examples/src/PingPong/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE NumericUnderscores #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE QualifiedDo #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | {-# LANGUAGE TypeApplications #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | {-# OPTIONS_GHC -Wall #-} 19 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 20 | 21 | module PingPong.Type where 22 | 23 | import Language.Haskell.TH.Quote 24 | import TypedSession.TH 25 | 26 | data PingPongRole = Client | Server | Counter 27 | deriving (Show, Eq, Ord, Enum, Bounded) 28 | 29 | data PingPongBranchSt = Continue | Finish | CheckVal 30 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 31 | 32 | pingpongProtocl :: QuasiQuoter 33 | pingpongProtocl = protocol @PingPongRole @PingPongBranchSt "PingPong" ''PingPongRole ''PingPongBranchSt 34 | -------------------------------------------------------------------------------- /examples/src/Ring/Peer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE QualifiedDo #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 7 | 8 | module Ring.Peer where 9 | 10 | import Control.Concurrent.Class.MonadSTM (newTVarIO) 11 | import Control.Monad (forM, void) 12 | import Control.Monad.Class.MonadFork (forkIO) 13 | import Data.IFunctor (At, returnAt) 14 | import qualified Data.IFunctor as I 15 | import qualified Data.IntMap as IntMap 16 | import GHC.Base (Any) 17 | import Ring.Protocol 18 | import Ring.Type 19 | import TypedSession.Core 20 | import TypedSession.Driver (SomeRole (..), localDriverSimple, runPeerWithDriver) 21 | 22 | choice :: Int -> ChoiceNAFun IO 23 | choice i = 24 | if i >= 3 25 | then liftConstructor BranchSt_Stop 26 | else liftConstructor BranchSt_Continue 27 | 28 | aPeer :: Int -> Peer RingRole Ring A IO (At () Done) (AStartSt) 29 | aPeer i = I.do 30 | choice i I.>>= \case 31 | BranchSt_Stop -> I.do 32 | yield BStop 33 | DStopA <- await 34 | returnAt () 35 | BranchSt_Continue -> I.do 36 | yield AB 37 | DA <- await 38 | aPeer (i + 1) 39 | 40 | bPeer :: Peer RingRole Ring B IO (At () Done) (BStartSt s) 41 | bPeer = 42 | await I.>>= \case 43 | BStop -> I.do 44 | yield CStop 45 | AB -> I.do 46 | yield BC 47 | bPeer 48 | 49 | cPeer :: Peer RingRole Ring C IO (At () Done) (CStartSt s) 50 | cPeer = 51 | await I.>>= \case 52 | CStop -> I.do 53 | yield DStop 54 | BC -> I.do 55 | yield CD 56 | cPeer 57 | 58 | dPeer :: Peer RingRole Ring D IO (At () Done) (DStartSt s) 59 | dPeer = 60 | await I.>>= \case 61 | DStop -> I.do 62 | yield DStopA 63 | CD -> I.do 64 | yield DA 65 | dPeer 66 | 67 | main :: IO () 68 | main = do 69 | let rg = [A .. D] 70 | vs <- forM rg $ \r -> do 71 | tvar <- newTVarIO IntMap.empty 72 | pure (fromEnum r, tvar) 73 | let allMap = IntMap.fromList vs 74 | driver someRole = localDriverSimple (\v -> putStrLn (show v)) allMap someRole id 75 | forkIO $ void $ runPeerWithDriver (driver $ SomeRole SB) bPeer 76 | forkIO $ void $ runPeerWithDriver (driver $ SomeRole SC) cPeer 77 | forkIO $ void $ runPeerWithDriver (driver $ SomeRole SD) dPeer 78 | void $ runPeerWithDriver (driver $ SomeRole SA) (aPeer 0) -------------------------------------------------------------------------------- /examples/src/Ring/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | module Ring.Protocol where 11 | 12 | import Ring.Type 13 | import TypedSession.Core 14 | 15 | [ringPrtocol| 16 | 17 | Label 0 18 | Branch A ChoiceNA { 19 | BranchSt Stop [] 20 | Msg BStop [] A B 21 | Msg CStop [] B C 22 | Msg DStop [] C D 23 | Msg DStopA [] D A 24 | Terminal 25 | BranchSt Continue [] 26 | Msg AB [] A B 27 | Msg BC [] B C 28 | Msg CD [] C D 29 | Msg DA [] D A 30 | Goto 0 31 | } 32 | 33 | |] 34 | 35 | instance Show (AnyMsg RingRole Ring) where 36 | show (AnyMsg msg) = case msg of 37 | BStop -> "BStop" 38 | CStop -> "CStop" 39 | DStop -> "DStop" 40 | DStopA -> "DStopA" 41 | AB -> "AB" 42 | BC -> "BC" 43 | CD -> "CD" 44 | DA -> "DA" -------------------------------------------------------------------------------- /examples/src/Ring/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskellQuotes #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Ring.Type where 5 | 6 | import TypedSession.TH 7 | 8 | data RingRole = A | B | C | D 9 | deriving (Eq, Ord, Show, Enum, Bounded) 10 | 11 | data RingBranchSt = Stop | Continue 12 | deriving (Eq, Ord, Show, Enum, Bounded) 13 | 14 | ringPrtocol = protocol @RingRole @RingBranchSt "Ring" ''RingRole ''RingBranchSt 15 | -------------------------------------------------------------------------------- /src/Data/IFunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE StandaloneKindSignatures #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Data.IFunctor where 9 | 10 | import Data.Data 11 | import Data.Kind 12 | 13 | {- | 14 | Singletons are not used here. I am not sure if singletons can generate the instances I need. 15 | 16 | Here is an example: Ping-Pong 17 | 18 | @ 19 | data PingPong 20 | = S0 [Bool] 21 | | S1 22 | | S2 [Bool] 23 | | End 24 | 25 | data SPingPong :: PingPong -> Type where 26 | SS0 :: SPingPong (S0 b) 27 | SS1 :: SPingPong S1 28 | SS2 :: SPingPong (S2 b) 29 | SEnd :: SPingPong End 30 | @ 31 | 32 | Note here /SS0 :: SPingPong (S0 b)/ 33 | 34 | Using singletons will generate /SS0 :: Sing b -> SPingPong (S0 b)/ which is not what I need. 35 | 36 | Please note the following example: 37 | 38 | @ 39 | serverPeer :: 40 | (Monad m) => Peer Role PingPong Server m (At () Done) (S0 s) 41 | serverPeer = I.do 42 | -- The server is in a state (S0 s) while it is awaiting a message, 43 | -- and its state is indeterminate until it receives a message. 44 | -- SS0 :: SPingPong (S0 b) correctly indicates this indeterminacy. 45 | Recv msg <- await 46 | case msg of 47 | Ping -> I.do 48 | yield Pong 49 | serverPeer 50 | Stop -> returnAt () 51 | @ 52 | -} 53 | type family Sing :: k -> Type 54 | 55 | type SingI :: forall {k}. k -> Constraint 56 | 57 | {- | 58 | 59 | example：Ping-Pong 60 | 61 | @ 62 | type instance Sing = SPingPong 63 | 64 | instance SingI (S0 b) where 65 | sing = SS0 66 | 67 | instance SingI S1 where 68 | sing = SS1 69 | 70 | instance SingI (S2 b) where 71 | sing = SS2 72 | 73 | instance SingI End where 74 | sing = SEnd 75 | @ 76 | -} 77 | class SingI a where 78 | sing :: Sing a 79 | 80 | infixr 0 ~> 81 | 82 | type f ~> g = forall x. f x -> g x 83 | 84 | class IFunctor f where 85 | imap :: (a ~> b) -> f a ~> f b 86 | 87 | {- | McBride Indexed Monads 88 | 89 | Here's Edward Kmett's [introduction to Indexed Monads](https://stackoverflow.com/questions/28690448/what-is-indexed-monad). 90 | 91 | As he said, there are at least three indexed monads: 92 | 93 | 94 | * Bob Atkey 95 | 96 | @ 97 | class IMonad m where 98 | ireturn :: a -> m i i a 99 | ibind :: m i j a -> (a -> m j k b) -> m i k b 100 | @ 101 | 102 | * Conor McBride 103 | 104 | @ 105 | type a ~> b = forall i. a i -> b i 106 | 107 | class IMonad m where 108 | ireturn :: a ~> m a 109 | ibind :: (a ~> m b) -> (m a ~> m b) 110 | @ 111 | 112 | * Dominic Orchard 113 | 114 | No detailed description, just a link to this [lecture](https://github.com/dorchard/effect-monad/blob/master/docs/ixmonad-fita14.pdf)。 115 | 116 | I use the McBride Indexed Monad, the earliest paper [here](https://personal.cis.strath.ac.uk/conor.mcbride/Kleisli.pdf). 117 | 118 | The following is my understanding of (\~>): through GADT, let the value contain type information, 119 | and then use ((\~>), pattern match) to pass the type to subsequent functions 120 | 121 | @ 122 | data V = A | B 123 | 124 | data SV :: V -> Type where -- GADT, let the value contain type information 125 | SA :: SV A 126 | SB :: SV B 127 | 128 | data SV1 :: V -> Type where 129 | SA1 :: SV1 A 130 | SB1 :: SV1 B 131 | 132 | fun :: SV ~> SV1 -- type f ~> g = forall x. f x -> g x 133 | fun sv = case sv of -- x is arbitrary but f, g must have the same x 134 | SA -> SA1 -- Pass concrete type state to subsequent functions via pattern matching 135 | SB -> SB1 136 | 137 | 138 | class (IFunctor m) => IMonad m where 139 | ireturn :: a ~> m a 140 | ibind :: (a ~> m b) -- The type information contained in a will be passed to (m b), 141 | -- which is exactly what we need: external input has an impact on the type! 142 | -> m a ~> m b 143 | @ 144 | -} 145 | class (IFunctor m) => IMonad m where 146 | ireturn :: a ~> m a 147 | ibind :: (a ~> m b) -> m a ~> m b 148 | 149 | class (IMonad m) => IMonadFail m where 150 | fail :: String -> m a ix 151 | 152 | data At :: Type -> k -> k -> Type where 153 | At :: a -> At a k k 154 | deriving (Typeable) 155 | 156 | (>>=) :: (IMonad (m :: (x -> Type) -> x -> Type)) => m a ix -> (a ~> m b) -> m b ix 157 | m >>= f = ibind f m 158 | 159 | (>>) :: (IMonad (m :: (x -> Type) -> x -> Type)) => m (At a j) i -> m b j -> m b i 160 | m >> f = ibind (\(At _) -> f) m 161 | 162 | returnAt :: (IMonad m) => a -> m (At a k) k 163 | returnAt = ireturn . At 164 | -------------------------------------------------------------------------------- /src/TypedSession/Codec.hs: -------------------------------------------------------------------------------- 1 | -- This part of the code comes from typed-protocols, I modified a few things. 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE QuantifiedConstraints #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | 13 | module TypedSession.Codec where 14 | 15 | import Control.Exception (Exception) 16 | import TypedSession.Core 17 | 18 | {- | 19 | Function to encode Msg into bytes. 20 | -} 21 | newtype Encode role' ps bytes = Encode 22 | { encode 23 | :: forall (send :: role') (recv :: role') (st :: ps) (st' :: ps) (st'' :: ps) 24 | . Msg role' ps st send st' recv st'' 25 | -> bytes 26 | } 27 | 28 | {- | 29 | Incremental decoding function. 30 | -} 31 | newtype Decode role' ps failure bytes = Decode 32 | { decode :: DecodeStep bytes failure (AnyMsg role' ps) 33 | } 34 | 35 | {- | 36 | Generic incremental decoder constructor, you need to convert specific incremental decoders to it. 37 | -} 38 | data DecodeStep bytes failure a 39 | = DecodePartial (Maybe bytes -> (DecodeStep bytes failure a)) 40 | | DecodeDone a (Maybe bytes) 41 | | DecodeFail failure 42 | 43 | data CodecFailure 44 | = CodecFailureOutOfInput 45 | | CodecFailure String 46 | deriving (Eq, Show) 47 | 48 | instance Exception CodecFailure 49 | 50 | {- | 51 | Bottom functions for sending and receiving bytes. 52 | -} 53 | data Channel m bytes = Channel 54 | { send :: bytes -> m () 55 | , recv :: m (Maybe bytes) 56 | } 57 | 58 | {- | 59 | Generic incremental decoding function. 60 | -} 61 | runDecoderWithChannel 62 | :: (Monad m) 63 | => Channel m bytes 64 | -> Maybe bytes 65 | -> DecodeStep bytes failure a 66 | -> m (Either failure (a, Maybe bytes)) 67 | runDecoderWithChannel Channel{recv} = go 68 | where 69 | go _ (DecodeDone x trailing) = return (Right (x, trailing)) 70 | go _ (DecodeFail failure) = return (Left failure) 71 | go Nothing (DecodePartial k) = recv >>= pure . k >>= go Nothing 72 | go (Just trailing) (DecodePartial k) = (pure . k) (Just trailing) >>= go Nothing 73 | -------------------------------------------------------------------------------- /src/TypedSession/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE StandaloneKindSignatures #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | 15 | module TypedSession.Core where 16 | 17 | import Control.Concurrent.Class.MonadSTM (MonadSTM (..)) 18 | import Data.IFunctor 19 | import Data.IntMap (IntMap) 20 | import Data.Kind 21 | 22 | {- | 23 | 24 | typed-session is a communication framework. 25 | The messages received from the outside will be placed in MsgCache. 26 | When interpreting the Peer, (Sing (r :: s)) will be generated according to the Peer's status. 27 | SingToInt can convert Sing (r :: s) to Int. 28 | Depending on this Int value, the required Msg is finally found from MsgCache. 29 | 30 | In the process of multi-role communication, a message cache structure like MsgCache is needed. 31 | 32 | Consider the following scenario 33 | 34 | @ 35 | s1 s1 s2 Initial state 36 | ------------ 37 | a -> b a sends message MsgA to b 38 | ------------ 39 | s3 s2 s2 State after sending 40 | ------------ 41 | b <- c c sends message MsgC to b 42 | ------------ 43 | s3 s4 s5 State after sending 44 | @ 45 | 46 | For b, due to the influence of network transmission, it cannot guarantee that it can receive MsgA first and then MsgC. 47 | If it receives MsgC first, it will directly put it in MsgCache and continue to wait until 48 | MsgA arrives, then it will start to process MsgA first and then MsgC. 49 | 50 | In general, dataToTag# is used directly here. 51 | 52 | Example: 53 | 54 | @ 55 | instance SingToInt Role where 56 | singToInt x = I# (dataToTag# x) 57 | 58 | instance SingToInt PingPong where 59 | singToInt x = I# (dataToTag# x) 60 | @ 61 | -} 62 | class SingToInt s where 63 | singToInt :: Sing (r :: s) -> Int 64 | 65 | {- | 66 | 67 | Describes the type class of Msg. The core of typed-session. 68 | 69 | @ 70 | type Done :: ps 71 | @ 72 | 73 | Describe the state of each role when it terminates. 74 | 75 | @ 76 | data 77 | Msg 78 | role' 79 | ps 80 | (fromSt :: ps) 81 | (sender :: role') 82 | (senderNewSt :: ps) 83 | (receiver :: role') 84 | (receiverNewSt :: ps) 85 | @ 86 | * role': the type of the role. 87 | * ps: the type of the state machine. 88 | * ​​fromSt: when sending a message, the sender is in this state, 89 | where the receiver may be in this state, or a more generalized state related to this state. 90 | For example, the sender is in state (S1 [True]), and the receiver is in state (S1 s). 91 | * sender: the role that sends the message 92 | * senderNewSt: the state of the role after sending the message 93 | * receiver: the role that receives the message 94 | * receiverNewSt: the state of the role after receiving the message 95 | 96 | There are two principles to follow when designing the state of Msg: 97 | 98 | 1. When sending a message, the sender and receiver must be in the same state. Here the receiver may be in a more generalized state related to the state. 99 | For example, the sender is in state (S1 [True]), and the receiver is in state (S1 s). 100 | 101 | 2. The same state can only be used for the same pair of receiver and sender. 102 | 103 | For example, in the following example, state s1 is used for both (a -> b) and (b -> c), which is wrong. 104 | 105 | @ 106 | s1 s1 s1 107 | a -> b 108 | s2 s1 s1 109 | b -> c 110 | s2 s4 s5 111 | @ 112 | -} 113 | class (SingToInt role', SingToInt ps) => Protocol role' ps where 114 | type Done :: ps 115 | data 116 | Msg 117 | role' 118 | ps 119 | (fromSt :: ps) 120 | (sender :: role') 121 | (senderNewSt :: ps) 122 | (receiver :: role') 123 | (receiverNewSt :: ps) 124 | 125 | {- | 126 | Messages received from the outside are placed in MsgCache. When interpreting 127 | Peer will use the Msg in MsgCache. 128 | -} 129 | type MsgCache role' ps n = TVar n (IntMap (AnyMsg role' ps)) 130 | 131 | {- | 132 | Packaging of Msg, shielding part of the type information, mainly used for serialization. 133 | -} 134 | data AnyMsg role' ps where 135 | AnyMsg 136 | :: ( SingI recv 137 | , SingI st 138 | , SingToInt role' 139 | , SingToInt ps 140 | ) 141 | => Msg role' ps st send st' recv st'' 142 | -> AnyMsg role' ps 143 | 144 | msgFromStSing 145 | :: forall role' ps st send recv st' st'' 146 | . (SingI recv, SingI st) 147 | => Msg role' ps st send st' recv st'' 148 | -> Sing st 149 | msgFromStSing _ = sing @st 150 | 151 | {- | 152 | Core Ast, all we do is build this Ast and then interpret it. 153 | 154 | @ 155 | IReturn :: ia st -> Peer role' ps r m ia st 156 | @ 157 | IReturn indicates the termination of the continuation. 158 | 159 | @ 160 | LiftM :: m (Peer role' ps r m ia st') -> Peer role' ps r m ia st 161 | @ 162 | 163 | Liftm can transform state st to any state st'. 164 | It looks a bit strange, as if it is a constructor that is not constrained by the Msg type. 165 | Be careful when using it, it is a type breakpoint. 166 | But some state transition functions need it, which can make the code more flexible. 167 | Be very careful when using it! 168 | 169 | @ 170 | Yield 171 | :: ( SingI recv 172 | , SingI from 173 | , SingToInt ps 174 | ) 175 | => Msg role' ps from '(send, sps) '(recv, rps) 176 | -> Peer role' ps send m ia sps 177 | -> Peer role' ps send m ia from 178 | @ 179 | Yield represents sending a message. Note that the Peer status changes from `from` to `sps`. 180 | 181 | @ 182 | Await 183 | :: ( SingI recv 184 | , SingI from 185 | , SingToInt ps 186 | ) 187 | => (Msg role' ps from send sps recv ~> Peer role' ps recv m ia) 188 | -> Peer role' ps recv m ia from 189 | @ 190 | 191 | Await represents receiving messages. 192 | Different messages will lead to different states. 193 | The state is passed to the next behavior through (~>). 194 | -} 195 | data Peer role' ps (r :: role') (m :: Type -> Type) (ia :: ps -> Type) (st :: ps) where 196 | IReturn :: ia st -> Peer role' ps r m ia st 197 | LiftM :: m (Peer role' ps r m ia st') -> Peer role' ps r m ia st 198 | Yield 199 | :: ( SingI recv 200 | , SingI from 201 | , SingToInt ps 202 | ) 203 | => Msg role' ps from send sps recv rps 204 | -> Peer role' ps send m ia sps 205 | -> Peer role' ps send m ia from 206 | Await 207 | :: ( SingI recv 208 | , SingI from 209 | , SingToInt ps 210 | ) 211 | => (Msg role' ps from send sps recv ~> Peer role' ps recv m ia) 212 | -> Peer role' ps recv m ia from 213 | 214 | instance (Functor m) => IMonadFail (Peer role' ps r m) where 215 | fail = error 216 | 217 | instance (Functor m) => IFunctor (Peer role' ps r m) where 218 | imap f = \case 219 | IReturn ia -> IReturn (f ia) 220 | LiftM f' -> LiftM (fmap (imap f) f') 221 | Yield ms cont -> Yield ms (imap f cont) 222 | Await cont -> Await (imap f . cont) 223 | 224 | instance (Functor m) => IMonad (Peer role' ps r m) where 225 | ireturn = IReturn 226 | ibind f = \case 227 | IReturn ia -> (f ia) 228 | LiftM f' -> LiftM (fmap (ibind f) f') 229 | Yield ms cont -> Yield ms (ibind f cont) 230 | Await cont -> Await (ibind f . cont) 231 | 232 | {- | 233 | Send a message, the Peer status changes from `from` to `sps`. 234 | -} 235 | yield 236 | :: ( Functor m 237 | , SingI recv 238 | , SingI from 239 | , SingToInt ps 240 | ) 241 | => Msg role' ps from send sps recv rps 242 | -> Peer role' ps send m (At () sps) from 243 | yield msg = Yield msg (returnAt ()) 244 | 245 | {- | 246 | Receiving Messages. 247 | -} 248 | await 249 | :: ( Functor m 250 | , SingI recv 251 | , SingI from 252 | , SingToInt ps 253 | ) 254 | => Peer role' ps recv m (Msg role' ps from send sps recv) from 255 | await = Await ireturn 256 | 257 | {- | 258 | Lift any m to Peer role' ps r m, which is an application of LiftM. 259 | Note that the state of `ts` has not changed. 260 | -} 261 | liftm :: (Functor m) => m a -> Peer role' ps r m (At a ts) ts 262 | liftm m = LiftM (returnAt <$> m) 263 | 264 | liftConstructor :: (Applicative m) => ia st' -> Peer role' k r m ia st 265 | liftConstructor a = LiftM $ pure $ ireturn a -------------------------------------------------------------------------------- /src/TypedSession/Driver.hs: -------------------------------------------------------------------------------- 1 | -- This part of the code comes from typed-protocols, I modified a few things. 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE NumericUnderscores #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 14 | 15 | {- | 16 | Schematic diagram of the communication structure of three roles through typed-session: 17 | 18 | <> 19 | 20 | Some explanations for this diagram: 21 | 22 | 1. Roles are connected through channels, and there are many types of channels, such as channels established through TCP or channels established through TMVar. 23 | 24 | 2. Each role has a Peer thread, in which the Peer runs. 25 | 26 | 3. Each role has one or more decode threads, and the decoded Msgs are placed in the MsgCache. 27 | -} 28 | module TypedSession.Driver where 29 | 30 | import Control.Concurrent.Class.MonadSTM 31 | import Control.Monad.Class.MonadFork (MonadFork (killThread), forkIO) 32 | import Control.Monad.Class.MonadThrow (MonadThrow, throwIO) 33 | import Control.Monad.Class.MonadTimer (MonadDelay, threadDelay) 34 | import Data.Data (Typeable) 35 | import Data.IFunctor (At (..), Sing, SingI (sing)) 36 | import qualified Data.IFunctor as I 37 | import Data.IntMap (IntMap) 38 | import qualified Data.IntMap as IntMap 39 | import Data.Traversable (for) 40 | import GHC.Exception (Exception) 41 | import TypedSession.Codec 42 | import TypedSession.Core 43 | import Unsafe.Coerce (unsafeCoerce) 44 | 45 | {- | 46 | Contains two functions sendMsg, recvMsg. 47 | runPeerWithDriver uses them to send and receive Msg. 48 | -} 49 | data Driver role' ps m 50 | = Driver 51 | { sendMsg 52 | :: forall (send :: role') (recv :: role') (st :: ps) (st' :: ps) (st'' :: ps) 53 | . ( SingI recv 54 | , SingI st 55 | , SingToInt ps 56 | , SingToInt role' 57 | ) 58 | => Sing recv 59 | -> Msg role' ps st send st' recv st'' 60 | -> m () 61 | , recvMsg 62 | :: forall (st' :: ps) 63 | . (SingToInt ps) 64 | => Sing st' 65 | -> m (AnyMsg role' ps) 66 | , terminalDecodeThreads :: [m ()] 67 | } 68 | 69 | {- | 70 | Interpret Peer. 71 | -} 72 | runPeerWithDriver 73 | :: forall role' ps (r :: role') (st :: ps) m a 74 | . ( Monad m 75 | , (SingToInt role') 76 | ) 77 | => Driver role' ps m 78 | -> Peer role' ps r m (At a Done) st 79 | -> m a 80 | runPeerWithDriver Driver{sendMsg, recvMsg, terminalDecodeThreads} peer = do 81 | a <- go peer 82 | sequence_ terminalDecodeThreads 83 | pure a 84 | where 85 | go 86 | :: forall st' 87 | . Peer role' ps r m (At a Done) st' 88 | -> m a 89 | go (IReturn (At a)) = pure a 90 | go (LiftM k) = k >>= go 91 | go (Yield (msg :: Msg role' ps st' r sps recv rps) k) = do 92 | sendMsg (sing @recv) msg 93 | go k 94 | go (Await (k :: (Msg role' ps st' send sps r I.~> Peer role' ps r m ia))) = do 95 | AnyMsg msg <- recvMsg (sing @st') 96 | go (k $ unsafeCoerce msg) 97 | 98 | {- | 99 | A wrapper around AnyMsg that represents sending and receiving Msg. 100 | -} 101 | data TraceSendRecv role' ps where 102 | TraceSendMsg :: AnyMsg role' ps -> TraceSendRecv role' ps 103 | TraceRecvMsg :: AnyMsg role' ps -> TraceSendRecv role' ps 104 | 105 | instance (Show (AnyMsg role' ps)) => Show (TraceSendRecv role' ps) where 106 | show (TraceSendMsg msg) = "Send " ++ show msg 107 | show (TraceRecvMsg msg) = "Recv " ++ show msg 108 | 109 | {- | 110 | Similar to the log function, used to print received or sent messages. 111 | -} 112 | type Tracer role' ps m = TraceSendRecv role' ps -> m () 113 | 114 | {- | 115 | The default trace function. It simply ignores everything. 116 | -} 117 | nullTracer :: (Monad m) => a -> m () 118 | nullTracer _ = pure () 119 | 120 | {- | 121 | ConnChannels aggregates the multiple connect channels together. 122 | -} 123 | type ConnChannels role' m bytes = [(SomeRole role', Channel m bytes)] 124 | 125 | data NotConnect role' = NotConnect role' 126 | deriving (Show) 127 | 128 | instance (Show role', Typeable role') => Exception (NotConnect role') 129 | 130 | data SomeRole role' = forall (r :: role'). (SingToInt role') => SomeRole (Sing r) 131 | 132 | {- | 133 | 134 | Build Driver through ConnChannels. 135 | Here we need some help from other functions: 136 | 137 | 1. `Tracer role' ps n` is similar to the log function, used to print received or sent messages. 138 | 2. `Encode role' ps` bytes encoding function, converts Msg into bytes. 139 | 3. `Decode role' ps failure bytes` bytes decode function, converts bytes into Msg. 140 | 4. `forall a. n a -> m a` This is a bit complicated, I will explain it in detail below. 141 | 142 | I see Peer as three layers: 143 | 144 | 1. `Peer` upper layer, meets the requirements of McBride Indexed Monad, uses do syntax construction, has semantic checks, and is interpreted to the second layer m through runPeerWithDriver. 145 | 2. `m` middle layer, describes the business requirements in this layer, and converts the received Msg into specific business actions. 146 | 3. `n` bottom layer, responsible for receiving and sending bytes. It can have multiple options such as IO or IOSim. Using IOSim can easily test the code. 147 | -} 148 | driverSimple 149 | :: forall role' ps failure bytes m n 150 | . ( Monad m 151 | , Monad n 152 | , MonadSTM n 153 | , MonadFork n 154 | , MonadDelay n 155 | , MonadThrow n 156 | , SingToInt role' 157 | , Enum role' 158 | , Show role' 159 | , Typeable role' 160 | , Exception failure 161 | ) 162 | => Tracer role' ps n 163 | -> Encode role' ps bytes 164 | -> Decode role' ps failure bytes 165 | -> ConnChannels role' n bytes 166 | -> (forall a. n a -> m a) 167 | -> n (Driver role' ps m) 168 | driverSimple 169 | tracer 170 | Encode{encode} 171 | decodeV 172 | connChannels 173 | liftFun = do 174 | msgCache <- newTVarIO IntMap.empty 175 | ths <- for connChannels $ \(_, channel) -> forkIO $ decodeLoop Nothing decodeV channel msgCache 176 | let terminalDecodeThreads = map (\tid -> liftFun $ killThread tid) ths 177 | pure $ Driver{sendMsg, recvMsg = recvMsg' msgCache, terminalDecodeThreads} 178 | where 179 | sendMap = IntMap.fromList $ fmap (\(SomeRole r, c) -> (singToInt r, send c)) connChannels 180 | sendMsg 181 | :: forall (send :: role') (recv :: role') (from :: ps) (st :: ps) (st1 :: ps) 182 | . ( SingI recv 183 | , SingI from 184 | , SingToInt ps 185 | , SingToInt role' 186 | ) 187 | => Sing recv 188 | -> Msg role' ps from send st recv st1 189 | -> m () 190 | sendMsg role msg = liftFun $ do 191 | let recvKey = singToInt role 192 | case IntMap.lookup recvKey sendMap of 193 | Nothing -> do 194 | let recvRole = toEnum @role' recvKey 195 | throwIO (NotConnect recvRole) 196 | Just sendFun -> sendFun (encode msg) 197 | tracer (TraceSendMsg (AnyMsg msg)) 198 | 199 | recvMsg' 200 | :: forall (st' :: ps) 201 | . (SingToInt ps) 202 | => MsgCache role' ps n 203 | -> Sing st' 204 | -> m (AnyMsg role' ps) 205 | recvMsg' msgCache sst' = do 206 | let singInt = singToInt sst' 207 | liftFun $ do 208 | anyMsg <- atomically $ do 209 | agencyMsg <- readTVar msgCache 210 | case IntMap.lookup singInt agencyMsg of 211 | Nothing -> retry 212 | Just v -> do 213 | writeTVar msgCache (IntMap.delete singInt agencyMsg) 214 | pure v 215 | tracer (TraceRecvMsg (anyMsg)) 216 | pure anyMsg 217 | 218 | {- | 219 | decode loop, usually in a separate thread. 220 | 221 | The decoded Msg is placed in MsgCache. 222 | 223 | @ 224 | data Msg role' ps (from :: ps) (sendAndSt :: (role', ps)) (recvAndSt :: (role', ps)) 225 | @ 226 | Note that when placing a new Msg in MsgCache, if a Msg with the same `from` already exists in MsgCache, the decoding process will be blocked, 227 | until that Msg is consumed before placing the new Msg in MsgCache. 228 | 229 | This usually happens when the efficiency of Msg generation is greater than the efficiency of consumption. 230 | -} 231 | decodeLoop 232 | :: (Exception failure, MonadDelay n, MonadSTM n, MonadThrow n) 233 | => Maybe bytes 234 | -> Decode role' ps failure bytes 235 | -> Channel n bytes 236 | -> MsgCache role' ps n 237 | -> n () 238 | decodeLoop mbt d@Decode{decode} channel tvar = do 239 | result <- runDecoderWithChannel channel mbt decode 240 | case result of 241 | Right (AnyMsg msg, mbt') -> do 242 | let agencyInt = singToInt $ msgFromStSing msg 243 | atomically $ do 244 | agencyMsg <- readTVar tvar 245 | case IntMap.lookup agencyInt agencyMsg of 246 | Nothing -> writeTVar tvar (IntMap.insert agencyInt (AnyMsg msg) agencyMsg) 247 | Just _v -> retry 248 | decodeLoop mbt' d channel tvar 249 | Left failure -> do 250 | threadDelay 1_000_000 251 | throwIO failure 252 | 253 | localDriverSimple 254 | :: forall role' ps m n 255 | . ( Monad m 256 | , Monad n 257 | , MonadSTM n 258 | , Enum role' 259 | , MonadThrow n 260 | , Show role' 261 | , Typeable role' 262 | ) 263 | => Tracer role' ps n 264 | -> IntMap (MsgCache role' ps n) 265 | -> SomeRole role' 266 | -> (forall a. n a -> m a) 267 | -> Driver role' ps m 268 | localDriverSimple tracer allMsgCache (SomeRole r) liftFun = 269 | Driver{sendMsg, recvMsg = recvMsg' (allMsgCache IntMap.! (singToInt r)), terminalDecodeThreads = []} 270 | where 271 | sendMsg 272 | :: forall (send :: role') (recv :: role') (from :: ps) (st :: ps) (st1 :: ps) 273 | . ( SingI recv 274 | , SingI from 275 | , SingToInt ps 276 | , SingToInt role' 277 | ) 278 | => Sing recv 279 | -> Msg role' ps from send st recv st1 280 | -> m () 281 | sendMsg role msg = liftFun $ do 282 | let recvKey = singToInt role 283 | case IntMap.lookup (singToInt role) allMsgCache of 284 | Nothing -> do 285 | let recvRole = toEnum @role' recvKey 286 | throwIO (NotConnect recvRole) 287 | Just ttvar -> atomically $ do 288 | agencyMsg <- readTVar ttvar 289 | let singInt = singToInt (sing @from) 290 | case IntMap.lookup singInt agencyMsg of 291 | Nothing -> writeTVar ttvar (IntMap.insert singInt (AnyMsg msg) agencyMsg) 292 | Just _v -> retry 293 | tracer (TraceSendMsg (AnyMsg msg)) 294 | 295 | recvMsg' 296 | :: forall (st' :: ps) 297 | . (SingToInt ps) 298 | => MsgCache role' ps n 299 | -> Sing st' 300 | -> m (AnyMsg role' ps) 301 | recvMsg' msgCache sst' = do 302 | let singInt = singToInt sst' 303 | liftFun $ do 304 | anyMsg <- atomically $ do 305 | agencyMsg <- readTVar msgCache 306 | case IntMap.lookup singInt agencyMsg of 307 | Nothing -> retry 308 | Just v -> do 309 | writeTVar msgCache (IntMap.delete singInt agencyMsg) 310 | pure v 311 | tracer (TraceRecvMsg (anyMsg)) 312 | pure anyMsg -------------------------------------------------------------------------------- /src/TypedSession/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# OPTIONS_GHC -Wno-unused-imports #-} 15 | {-# OPTIONS_GHC -split-sections #-} 16 | 17 | module TypedSession.TH (protocol, protocol') where 18 | 19 | import Control.Monad (forM, when) 20 | import Data.Either (fromRight) 21 | import Data.IFunctor (Sing, SingI (..)) 22 | import Data.Kind 23 | import qualified Data.Set as Set 24 | import Data.Traversable (for) 25 | import GHC.Exts (DataToTag (..), Int (..)) 26 | import Language.Haskell.TH hiding (Type) 27 | import qualified Language.Haskell.TH as TH 28 | import Language.Haskell.TH.Quote 29 | import TypedSession.Core (SingToInt (..)) 30 | import qualified TypedSession.Core as TSC 31 | import TypedSession.State.Parser (runProtocolParser) 32 | import TypedSession.State.Pipeline (PipeResult (..), genGraph, pipe) 33 | import TypedSession.State.Render 34 | import TypedSession.State.Type (BranchSt (..), Creat, MsgOrLabel (..), MsgT1, Protocol (..), ProtocolError, T (..)) 35 | 36 | roleDecs :: Name -> Q [Dec] 37 | roleDecs name = do 38 | res <- reify name 39 | case res of 40 | TyConI (DataD [] dName [] Nothing cons _) -> do 41 | aVar <- newName "a" 42 | xVar <- newName "x" 43 | let 44 | addPerfixS :: Name -> Name 45 | addPerfixS vname = 46 | let n = (nameBase vname) 47 | in mkName ("S" <> n) 48 | 49 | roleSingleton = 50 | [ DataD 51 | [] 52 | (addPerfixS dName) 53 | [KindedTV aVar BndrReq (ConT dName)] 54 | Nothing 55 | [GadtC [addPerfixS n] [] (AppT (ConT (addPerfixS dName)) (PromotedT n)) | NormalC n [] <- cons] 56 | [] 57 | ] 58 | singToSRole = [TySynInstD (TySynEqn Nothing (ConT ''Sing) (ConT (addPerfixS dName)))] 59 | instanceSingI = 60 | [ InstanceD 61 | Nothing 62 | [] 63 | (AppT (ConT ''SingI) (PromotedT n)) 64 | [FunD 'sing [Clause [] (NormalB (ConE (addPerfixS n))) []]] 65 | | NormalC n [] <- cons 66 | ] 67 | instanceSingToInt = 68 | [ InstanceD 69 | Nothing 70 | [] 71 | (AppT (ConT ''SingToInt) (ConT name)) 72 | [ FunD 73 | 'singToInt 74 | [Clause [VarP xVar] (NormalB (AppE (ConE 'I#) (AppE (VarE 'dataToTag#) (VarE xVar)))) []] 75 | ] 76 | ] 77 | pure $ roleSingleton ++ singToSRole ++ instanceSingI ++ instanceSingToInt 78 | _ -> error $ "Name: " ++ show name ++ " is not a data constructor" 79 | 80 | protDecsAndMsgDecs :: forall r bst. (Show r, Show bst, Enum r, Bounded r) => String -> Name -> Name -> PipeResult r bst -> Q [Dec] 81 | protDecsAndMsgDecs protN roleName bstName PipeResult{msgT, msgT1, dnySet, stList, branchResultTypeInfo, branchFunList, allMsgBATypes} = do 82 | let protName = mkName protN 83 | protSName = mkName ("S" <> protN) 84 | mkSiName i = mkName $ "S" <> show i 85 | mkSSiName i = mkName $ "SS" <> show i 86 | genConstr i = 87 | if i == -1 88 | then NormalC (mkName "End") [] 89 | else 90 | if i `Set.member` dnySet 91 | then 92 | NormalC 93 | (mkSiName i) 94 | [(Bang NoSourceUnpackedness NoSourceStrictness, ConT bstName)] 95 | else NormalC (mkSiName i) [] 96 | -- generate protocol data type 97 | dataProt = [DataD [] protName [] Nothing [genConstr i | i <- stList] []] 98 | 99 | let tAnyToType :: Name -> T bst -> TH.Type 100 | tAnyToType s = \case 101 | TNum i -> PromotedT (mkSiName i) 102 | BstList i bst -> AppT (PromotedT (mkSiName i)) (PromotedT (mkName (show bst))) 103 | TAny i -> AppT (PromotedT (mkSiName i)) (VarT s) 104 | TEnd -> PromotedT $ mkName "End" 105 | mkArgs args = 106 | [ ( Bang NoSourceUnpackedness NoSourceStrictness 107 | , case ag of 108 | [] -> error "np" 109 | (x : xs) -> foldl' AppT (ConT (mkName x)) (map (ConT . mkName) xs) 110 | ) 111 | | ag <- args 112 | ] 113 | typeListT :: [TH.Type] -> TH.Type 114 | typeListT = foldl1 AppT 115 | 116 | isTAny :: T bst -> Bool 117 | isTAny = \case 118 | TAny _ -> True 119 | _ -> False 120 | 121 | sVar <- newName "s" 122 | aVar <- newName "a" 123 | let genSConstr i = 124 | if i == -1 125 | then 126 | GadtC [mkName "SEnd"] [] (AppT (ConT protSName) (PromotedT (mkName "End"))) 127 | else 128 | if i `Set.member` dnySet 129 | then 130 | ForallC 131 | [KindedTV sVar SpecifiedSpec (ConT bstName)] 132 | [] 133 | ( GadtC 134 | [mkSSiName i] 135 | [] 136 | (AppT (ConT protSName) (AppT (PromotedT $ mkSiName i) (VarT sVar))) 137 | ) 138 | else 139 | GadtC [mkSSiName i] [] (AppT (ConT protSName) (PromotedT $ mkSiName i)) 140 | -- generate protocol singleton data type 141 | dataSingletonProt = [DataD [] protSName [KindedTV aVar BndrReq (ConT protName)] Nothing [genSConstr i | i <- stList] []] 142 | 143 | -- generate type family Sing to Singleton protocol 144 | let singSingletonProt = [TySynInstD (TySynEqn Nothing (ConT ''Sing) (ConT protSName))] 145 | 146 | aVar1 <- newName "a" 147 | let branchResultDatas = 148 | [ DataD 149 | [] 150 | dataName 151 | [KindedTV aVar1 BndrReq (ConT protName)] 152 | Nothing 153 | [ GadtC [constrName] (mkArgs args) (AppT (ConT dataName) (tAnyToType (mkName "s") t)) 154 | | (bst, args, t) <- constrs 155 | , let constrName = mkName ("BranchSt_" <> show bst) 156 | ] 157 | [] 158 | | (name, constrs) <- branchResultTypeInfo 159 | , let dataName = mkName name 160 | ] 161 | branchFunTypes <- for branchFunList $ \(r, st, t) -> do 162 | mVar <- newName "m" 163 | pure 164 | ( TySynD 165 | (mkName (st <> "Fun")) 166 | [KindedTV mVar BndrReq (AppT (AppT ArrowT StarT) StarT)] 167 | ( typeListT 168 | [ ConT ''TSC.Peer 169 | , ConT roleName 170 | , ConT protName 171 | , ConT (mkName (show r)) 172 | , VarT mVar 173 | , ConT (mkName st) 174 | , (tAnyToType (mkName "s") t) 175 | ] 176 | ) 177 | ) 178 | let firstTList = case msgT of 179 | Msg (ts, _, _) _ _ _ _ :> _ -> ts 180 | Label (ts, _) _ :> _ -> ts 181 | Branch ts _ _ _ -> ts 182 | Goto (ts, _) _ -> ts 183 | Terminal ts -> ts 184 | 185 | mkTySynDFun name t = 186 | if isTAny t 187 | then do 188 | sVar1 <- newName @Q "s" 189 | pure (TySynD name [KindedTV sVar1 BndrReq (ConT bstName)] (tAnyToType sVar1 t)) 190 | else pure (TySynD name [] (tAnyToType (mkName "s") t)) 191 | 192 | mkAllRoleTySynDFun nameFun ts = 193 | for (zip [minBound @r .. maxBound] ts) $ 194 | \(r, t) -> mkTySynDFun (nameFun r) t 195 | 196 | roleStartSts <- mkAllRoleTySynDFun (\r -> (mkName (show r <> "StartSt"))) firstTList 197 | 198 | allMsgBADecs <- 199 | concat <$> do 200 | for allMsgBATypes $ \(cname, beforeSt, afterSt) -> do 201 | bfs <- mkAllRoleTySynDFun (\r -> mkName (show r <> "Before" <> cname <> "St")) beforeSt 202 | afs <- mkAllRoleTySynDFun (\r -> mkName (show r <> "After" <> cname <> "St")) afterSt 203 | pure (bfs <> afs) 204 | 205 | s1 <- newName "s1" 206 | -- generate instance SingI 207 | let instanceSingI = 208 | [ InstanceD 209 | Nothing 210 | [] 211 | ( AppT 212 | (ConT ''SingI) 213 | ( if i == -1 214 | then PromotedT (mkName "End") 215 | else 216 | if i `Set.member` dnySet 217 | then SigT (AppT (PromotedT (mkSiName i)) (VarT s1)) (ConT protName) 218 | else PromotedT (mkSiName i) 219 | ) 220 | ) 221 | [FunD 'sing [Clause [] (NormalB (ConE (mkName $ "S" <> (if i == -1 then "End" else ("S" <> show i))))) []]] 222 | | i <- stList 223 | ] 224 | 225 | xVar <- newName "x" 226 | -- generate instance SingToInt 227 | let instanceSingToInt = 228 | [ InstanceD 229 | Nothing 230 | [] 231 | (AppT (ConT ''SingToInt) (ConT protName)) 232 | [ FunD 'singToInt [Clause [VarP xVar] (NormalB (AppE (ConE 'I#) (AppE (VarE 'dataToTag#) (VarE xVar)))) []] 233 | ] 234 | ] 235 | 236 | -- make instance type family Done 237 | let instDoneDesc = [TySynInstD (TySynEqn Nothing (ConT (mkName "Done")) (PromotedT (mkName "End")))] 238 | 239 | let mkDataInstanceMsg :: Name -> Protocol (MsgT1 r bst) r bst -> Q [Con] 240 | mkDataInstanceMsg s = \case 241 | Msg ((a, b, c), (from, to), _) constr args _ _ :> prots -> do 242 | let mkTName = 243 | typeListT 244 | [ ConT ''TSC.Msg 245 | , ConT roleName 246 | , ConT protName 247 | , tAnyToType s a 248 | , PromotedT (mkName (show from)) 249 | , tAnyToType s b 250 | , PromotedT (mkName (show to)) 251 | , tAnyToType s c 252 | ] 253 | let val = 254 | let gadtc = 255 | GadtC 256 | [mkName constr] 257 | (mkArgs args) 258 | mkTName 259 | in if any isTAny [a, b, c] 260 | then ForallC [KindedTV s SpecifiedSpec (ConT bstName)] [] gadtc 261 | else gadtc 262 | vals <- mkDataInstanceMsg s prots 263 | pure (val : vals) 264 | Label _ _ :> prots -> mkDataInstanceMsg s prots 265 | Branch _ _ _ ls -> do 266 | ls' <- forM ls $ \(BranchSt _ _ _ prot) -> mkDataInstanceMsg s prot 267 | pure $ concat ls' 268 | _ -> pure [] 269 | 270 | -- make data instance Msg 271 | ssVar <- newName "s" 272 | instMsgDesc <- mkDataInstanceMsg ssVar (msgT1) 273 | fromVar <- newName "from" 274 | sendVar <- newName "send" 275 | sendNewStVar <- newName "sendNewSt" 276 | recvVar <- newName "recv" 277 | receiverNewStVar <- newName "receiverNewSt" 278 | let instanceMsg = 279 | [ InstanceD 280 | Nothing 281 | [] 282 | (AppT (AppT (ConT ''TSC.Protocol) (ConT roleName)) (ConT protName)) 283 | ( instDoneDesc 284 | ++ [ DataInstD 285 | [] 286 | ( Just 287 | [ KindedTV fromVar () (ConT protName) 288 | , KindedTV sendVar () (ConT roleName) 289 | , KindedTV sendNewStVar () (ConT protName) 290 | , KindedTV recvVar () (ConT roleName) 291 | , KindedTV receiverNewStVar () (ConT protName) 292 | ] 293 | ) 294 | ( typeListT 295 | [ ConT ''TSC.Msg 296 | , ConT roleName 297 | , ConT protName 298 | , (SigT (VarT fromVar) (ConT protName)) 299 | , (SigT (VarT sendVar) (ConT roleName)) 300 | , (SigT (VarT sendNewStVar) (ConT protName)) 301 | , (SigT (VarT recvVar) (ConT roleName)) 302 | , (SigT (VarT receiverNewStVar) (ConT protName)) 303 | ] 304 | ) 305 | Nothing 306 | instMsgDesc 307 | [] 308 | ] 309 | ) 310 | ] 311 | 312 | pure $ 313 | dataProt 314 | ++ dataSingletonProt 315 | ++ singSingletonProt 316 | ++ branchResultDatas 317 | ++ branchFunTypes 318 | ++ roleStartSts 319 | ++ allMsgBADecs 320 | ++ instanceSingI 321 | ++ instanceSingToInt 322 | ++ instanceMsg 323 | 324 | protocol' 325 | :: forall r bst 326 | . ( Enum r 327 | , Bounded r 328 | , Show r 329 | , Enum bst 330 | , Bounded bst 331 | , Show bst 332 | , Ord r 333 | ) 334 | => String -> Name -> Name -> Bool -> QuasiQuoter 335 | protocol' protN roleName bstName b = 336 | QuasiQuoter 337 | { quoteExp = const $ fail "No protocol parse for exp" 338 | , quotePat = const $ fail "No protocol parse for pat" 339 | , quoteType = const $ fail "No protocol parser for type" 340 | , quoteDec = parseOrThrow 341 | } 342 | where 343 | parseOrThrow :: String -> Q [Dec] 344 | parseOrThrow st = case runProtocolParser @r @bst st of 345 | Left e -> fail (show e) 346 | Right protCreat -> case pipe protCreat of 347 | Left e -> fail (show e) 348 | Right pipResult -> do 349 | let graphStr = genGraph @r @bst pipResult 350 | when b $ runIO $ do 351 | writeFile (protN <> ".prot") graphStr 352 | putStrLn graphStr 353 | d1 <- roleDecs roleName 354 | d2 <- protDecsAndMsgDecs protN roleName bstName pipResult 355 | pure (d1 ++ d2) 356 | 357 | protocol 358 | :: forall r bst 359 | . ( Enum r 360 | , Bounded r 361 | , Show r 362 | , Enum bst 363 | , Bounded bst 364 | , Show bst 365 | , Ord r 366 | ) 367 | => String -> Name -> Name -> QuasiQuoter 368 | protocol protN roleName bstName = 369 | protocol' @r @bst protN roleName bstName False 370 | -------------------------------------------------------------------------------- /test/Book3/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE QualifiedDo #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 15 | 16 | module Book3.Main where 17 | 18 | import Book3.Peer 19 | import Book3.Protocol 20 | import Book3.Type 21 | import Control.Carrier.Lift (runM, sendM) 22 | import Control.Carrier.Random.Gen (runRandom) 23 | import Control.Concurrent.Class.MonadSTM 24 | import Control.Monad 25 | import Control.Monad.Class.MonadFork (MonadFork, forkIO) 26 | import Control.Monad.Class.MonadSay 27 | import Control.Monad.Class.MonadThrow (MonadThrow) 28 | import Control.Monad.Class.MonadTimer (MonadDelay) 29 | import Control.Monad.IOSim 30 | import System.Random (StdGen, split) 31 | import TypedSession.Codec 32 | import TypedSession.Core 33 | import TypedSession.Driver 34 | 35 | mvarsAsChannel 36 | :: (MonadSTM m) 37 | => TMVar m a 38 | -> TMVar m a 39 | -> Channel m a 40 | mvarsAsChannel bufferRead bufferWrite = 41 | Channel{send, recv} 42 | where 43 | send x = atomically (putTMVar bufferWrite x) 44 | recv = atomically (Just <$> takeTMVar bufferRead) 45 | 46 | myTracer :: (MonadSay m) => String -> Tracer BookRole Book m 47 | myTracer st v = say (st <> show v) 48 | 49 | runAll 50 | :: forall n 51 | . ( Monad n 52 | , MonadSTM n 53 | , MonadSay n 54 | , MonadThrow n 55 | , MonadFork n 56 | , MonadDelay n 57 | ) 58 | => StdGen 59 | -> n () 60 | runAll g = do 61 | buyerTMVar <- newEmptyTMVarIO @n @(AnyMsg BookRole Book) 62 | buyer2TMVar <- newEmptyTMVarIO @n @(AnyMsg BookRole Book) 63 | sellerTMVar <- newEmptyTMVarIO @n @(AnyMsg BookRole Book) 64 | 65 | buyerDriver <- 66 | driverSimple 67 | (myTracer "buyer :") 68 | encodeMsg 69 | (Decode decodeMsg) 70 | [ (SomeRole SSeller, mvarsAsChannel buyerTMVar sellerTMVar) 71 | , (SomeRole SBuyer2, mvarsAsChannel buyerTMVar buyer2TMVar) 72 | ] 73 | sendM 74 | 75 | buyer2Driver <- 76 | driverSimple 77 | (myTracer "buyer2 :") 78 | encodeMsg 79 | (Decode decodeMsg) 80 | [(SomeRole SBuyer, mvarsAsChannel buyer2TMVar buyerTMVar)] 81 | sendM 82 | 83 | sellerDriver <- 84 | driverSimple 85 | (myTracer "seller :") 86 | encodeMsg 87 | (Decode decodeMsg) 88 | [(SomeRole SBuyer, mvarsAsChannel sellerTMVar buyerTMVar)] 89 | sendM 90 | 91 | let (g0, g1) = split g 92 | (g2, g3) = split g0 93 | 94 | resultTMVar1 <- newEmptyTMVarIO 95 | resultTMVar2 <- newEmptyTMVarIO 96 | 97 | -- fork seller Peer thread 98 | forkIO $ do 99 | runM $ runRandom g1 $ runPeerWithDriver sellerDriver sellerPeer 100 | atomically $ writeTMVar resultTMVar1 () 101 | 102 | -- fork buyer2 Peer thread 103 | forkIO $ do 104 | runM $ runRandom g2 $ runPeerWithDriver buyer2Driver buyer2Peer 105 | atomically $ writeTMVar resultTMVar2 () 106 | 107 | -- run buyer Peer 108 | void $ runM $ runRandom g3 $ runPeerWithDriver buyerDriver buyerPeer 109 | 110 | -- wait seller, buyer 111 | atomically $ do 112 | takeTMVar resultTMVar1 113 | takeTMVar resultTMVar2 114 | 115 | book3Prop :: StdGen -> Either Failure () 116 | book3Prop v = runSim (runAll v) -------------------------------------------------------------------------------- /test/Book3/Peer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE QualifiedDo #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 17 | 18 | module Book3.Peer where 19 | 20 | import Book3.Protocol 21 | import Book3.Type 22 | import Control.Carrier.Lift 23 | import Control.Carrier.Random.Gen 24 | import Data.IFunctor (At (..), returnAt) 25 | import qualified Data.IFunctor as I 26 | import TypedSession.Core 27 | 28 | budget :: Int 29 | budget = 16 30 | 31 | type Date = Int 32 | 33 | checkPrice 34 | :: (Has Random sig m) 35 | => Int 36 | -> Int 37 | -> EnoughOrNotEnoughFun m 38 | checkPrice _i _h = I.do 39 | At b <- liftm $ uniform @Bool 40 | if b 41 | then liftConstructor BranchSt_Enough 42 | else liftConstructor BranchSt_NotEnough 43 | 44 | choiceOT 45 | :: (Has Random sig m) 46 | => Int 47 | -> OneOrTwoFun m 48 | choiceOT _i = I.do 49 | At b <- liftm $ uniform @Bool 50 | if b 51 | then liftConstructor BranchSt_One 52 | else liftConstructor BranchSt_Two 53 | 54 | buyerPeer 55 | :: (Has Random sig m) 56 | => Peer BookRole Book Buyer m (At (Maybe Date) Done) BuyerStartSt 57 | buyerPeer = I.do 58 | yield (Title "haskell book") 59 | await I.>>= \case 60 | NoBook -> I.do 61 | yield SellerNoBook 62 | returnAt Nothing 63 | Price i -> I.do 64 | choiceOT i I.>>= \case 65 | BranchSt_One -> I.do 66 | yield OneAccept 67 | OneDate d <- await 68 | yield (OneSuccess d) 69 | returnAt $ Just d 70 | BranchSt_Two -> I.do 71 | yield (PriceToBuyer2 (i `div` 2)) 72 | await I.>>= \case 73 | NotSupport1 -> I.do 74 | yield TwoNotBuy 75 | returnAt Nothing 76 | SupportVal h -> I.do 77 | checkPrice 10 h I.>>= \case 78 | BranchSt_Enough -> I.do 79 | yield TwoAccept 80 | TwoDate d <- await 81 | yield (TwoSuccess d) 82 | returnAt (Just d) 83 | BranchSt_NotEnough -> I.do 84 | yield TwoNotBuy1 85 | yield TwoFailed 86 | returnAt Nothing 87 | 88 | choiceB 89 | :: (Has Random sig m) 90 | => Int 91 | -> SupportOrNotSupportFun m 92 | choiceB _i = I.do 93 | At b <- liftm $ uniform @Bool 94 | if b 95 | then liftConstructor BranchSt_Support 96 | else liftConstructor BranchSt_NotSupport 97 | 98 | buyer2Peer 99 | :: (Has Random sig m) 100 | => Peer BookRole Book Buyer2 m (At (Maybe Date) Done) (Buyer2StartSt s) 101 | buyer2Peer = I.do 102 | await I.>>= \case 103 | SellerNoBook -> returnAt Nothing 104 | (OneSuccess d) -> returnAt (Just d) 105 | (PriceToBuyer2 i) -> I.do 106 | choiceB i I.>>= \case 107 | BranchSt_NotSupport -> I.do 108 | yield NotSupport1 109 | returnAt Nothing 110 | BranchSt_Support -> I.do 111 | yield (SupportVal (i `div` 2)) 112 | await I.>>= \case 113 | TwoSuccess d -> returnAt $ Just d 114 | TwoFailed -> returnAt Nothing 115 | 116 | findBook 117 | :: (Has Random sig m) 118 | => String 119 | -> FindBookResultFun m 120 | findBook _st = I.do 121 | At b <- liftm $ uniform @Bool 122 | if b 123 | then liftConstructor BranchSt_Found 124 | else liftConstructor BranchSt_NotFound 125 | 126 | sellerPeer 127 | :: (Has Random sig m) 128 | => Peer BookRole Book Seller m (At () Done) SellerStartSt 129 | sellerPeer = I.do 130 | (Title st) <- await 131 | findBook st I.>>= \case 132 | BranchSt_NotFound -> yield NoBook 133 | BranchSt_Found -> I.do 134 | yield (Price 30) 135 | await I.>>= \case 136 | OneAccept -> yield (OneDate 100) 137 | TwoNotBuy -> returnAt () 138 | TwoAccept -> yield (TwoDate 100) 139 | TwoNotBuy1 -> returnAt () 140 | 141 | -- data AnyPeer role' ps m where 142 | -- AnyPeer :: Peer role' ps r m (At () (Done r)) st -> AnyPeer role' ps m 143 | 144 | -- runAnyPeers 145 | -- :: forall n role' ps sig m 146 | -- . ( SingToInt role' 147 | -- , Has (State (IntMap (AnyPeer role' ps n))) sig m 148 | -- ) 149 | -- => (forall a. n a -> m a) -> m () 150 | -- runAnyPeers liftFun = do 151 | -- im <- get @(IntMap (AnyPeer role' ps n)) 152 | -- case IntMap.keys im of 153 | -- [] -> pure () 154 | -- keys -> do 155 | -- forM_ keys $ \key -> do 156 | -- gets @(IntMap (AnyPeer role' ps n)) (IntMap.lookup key) >>= \case 157 | -- Nothing -> error "np" 158 | -- Just (AnyPeer peer) -> case peer of 159 | -- IReturn (At ()) -> do 160 | -- modify @(IntMap (AnyPeer role' ps n)) (IntMap.delete key) 161 | -- LiftM fm -> do 162 | -- np <- liftFun fm 163 | -- modify @(IntMap (AnyPeer role' ps n)) (IntMap.insert key (AnyPeer np)) 164 | -- Yield (msg :: Msg role' ps st send sps recv rps) cont -> do 165 | -- let recvKey = (singToInt $ sing @recv) 166 | -- gets @(IntMap (AnyPeer role' ps n)) (IntMap.lookup recvKey) >>= \case 167 | -- Nothing -> error "np" 168 | -- Just (AnyPeer recvPeer) -> case recvPeer of 169 | -- Await scont -> do 170 | -- let nS = scont (unsafeCoerce msg) 171 | -- modify @(IntMap (AnyPeer role' ps n)) (IntMap.insert recvKey (AnyPeer nS)) 172 | -- _ -> error "np" 173 | -- modify @(IntMap (AnyPeer role' ps n)) (IntMap.insert key (AnyPeer cont)) 174 | -- Await{} -> pure () 175 | -- runAnyPeers @n @role' @ps liftFun 176 | 177 | -- runAP = do 178 | -- i <- randomIO @Int 179 | -- runRandom (mkStdGen i) 180 | -- $ runM @(RandomC StdGen IO) 181 | -- $ runState 182 | -- ( IntMap.fromList 183 | -- [ (singToInt SBuyer, AnyPeer (buyerPeer @_ @(RandomC StdGen IO) I.>> returnAt ())) 184 | -- , (singToInt SBuyer2, AnyPeer (buyer2Peer @_ @(RandomC StdGen IO) I.>> returnAt ())) 185 | -- , (singToInt SSeller, AnyPeer (sellerPeer @_ @(RandomC StdGen IO) I.>> returnAt ())) 186 | -- ] 187 | -- ) 188 | -- $ (runAnyPeers @(RandomC StdGen IO) @BookRole @Book sendM) 189 | -------------------------------------------------------------------------------- /test/Book3/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MagicHash #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# OPTIONS_GHC -Wno-orphans #-} 14 | {-# OPTIONS_GHC -Wno-unused-do-bind #-} 15 | 16 | module Book3.Protocol where 17 | 18 | import Book3.Type 19 | 20 | import TypedSession.Codec 21 | import TypedSession.Core 22 | 23 | 24 | [bookProtocol| 25 | Label 0 26 | Msg Title [String] Buyer Seller 27 | Branch Seller FindBookResult { 28 | BranchSt NotFound [] 29 | Msg NoBook [] Seller Buyer 30 | Msg SellerNoBook [] Buyer Buyer2 31 | Terminal 32 | BranchSt Found [] 33 | Msg Price [Int] Seller Buyer 34 | Branch Buyer OneOrTwo { 35 | BranchSt One [] 36 | Msg OneAccept [] Buyer Seller 37 | Msg OneDate [Int] Seller Buyer 38 | Msg OneSuccess [Int] Buyer Buyer2 39 | Terminal 40 | BranchSt Two [] 41 | Msg PriceToBuyer2 [Int] Buyer Buyer2 42 | Branch Buyer2 SupportOrNotSupport { 43 | BranchSt NotSupport [] 44 | Msg NotSupport1 [] Buyer2 Buyer 45 | Msg TwoNotBuy [] Buyer Seller 46 | Terminal 47 | BranchSt Support [] 48 | Msg SupportVal [Int] Buyer2 Buyer 49 | Branch Buyer EnoughOrNotEnough { 50 | BranchSt Enough [] 51 | Msg TwoAccept [] Buyer Seller 52 | Msg TwoDate [Int] Seller Buyer 53 | Msg TwoSuccess [Int] Buyer Buyer2 54 | Terminal 55 | BranchSt NotEnough [] 56 | Msg TwoNotBuy1 [] Buyer Seller 57 | Msg TwoFailed [] Buyer Buyer2 58 | Terminal 59 | } 60 | } 61 | } 62 | } 63 | 64 | |] 65 | 66 | encodeMsg :: Encode BookRole Book (AnyMsg BookRole Book) 67 | encodeMsg = Encode $ \x -> case x of 68 | Title{} -> AnyMsg x 69 | NoBook{} -> AnyMsg x 70 | SellerNoBook{} -> AnyMsg x 71 | Price{} -> AnyMsg x 72 | OneAccept{} -> AnyMsg x 73 | OneDate{} -> AnyMsg x 74 | OneSuccess{} -> AnyMsg x 75 | PriceToBuyer2{} -> AnyMsg x 76 | NotSupport1{} -> AnyMsg x 77 | TwoNotBuy{} -> AnyMsg x 78 | SupportVal{} -> AnyMsg x 79 | TwoAccept{} -> AnyMsg x 80 | TwoDate{} -> AnyMsg x 81 | TwoSuccess{} -> AnyMsg x 82 | TwoNotBuy1{} -> AnyMsg x 83 | TwoFailed{} -> AnyMsg x 84 | 85 | decodeMsg 86 | :: DecodeStep 87 | (AnyMsg BookRole Book) 88 | CodecFailure 89 | (AnyMsg BookRole Book) 90 | decodeMsg = 91 | DecodePartial $ \case 92 | Nothing -> DecodeFail (CodecFailure "expected more data") 93 | Just anyMsg -> DecodeDone anyMsg Nothing 94 | 95 | instance Show (AnyMsg BookRole Book) where 96 | show (AnyMsg msg) = case msg of 97 | Title st -> "Title " <> show st 98 | NoBook -> "NoBook" 99 | SellerNoBook -> "SellerNoBook" 100 | Price i -> "Price " <> show i 101 | OneAccept -> "OneAccept" 102 | OneDate d -> "OneDate " <> show d 103 | OneSuccess d -> "OneSuccess" <> show d 104 | PriceToBuyer2 i -> "PriceToBuyer2 " <> show i 105 | NotSupport1 -> "NotSupport1" 106 | TwoNotBuy -> "TwoNotBuy" 107 | SupportVal v -> "SupportVal " <> show v 108 | TwoAccept -> "TwoAccept" 109 | TwoDate d -> "TwoDate " <> show d 110 | TwoSuccess d -> "TwoSuccess " <> show d 111 | TwoNotBuy1 -> "TwoNotBuy1" 112 | TwoFailed -> "TwoFailed" 113 | -------------------------------------------------------------------------------- /test/Book3/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE QualifiedDo #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | 17 | module Book3.Type where 18 | 19 | import Language.Haskell.TH.Quote (QuasiQuoter) 20 | import TypedSession.TH (protocol) 21 | 22 | data BookRole = Buyer | Seller | Buyer2 23 | deriving (Show, Eq, Ord, Enum, Bounded) 24 | 25 | data BookBranchSt 26 | = NotFound 27 | | Found 28 | | One 29 | | Two 30 | | Support 31 | | NotSupport 32 | | Enough 33 | | NotEnough 34 | deriving (Show, Eq, Ord, Enum, Bounded) 35 | 36 | bookProtocol :: QuasiQuoter 37 | bookProtocol = 38 | protocol 39 | @BookRole 40 | @BookBranchSt 41 | "Book" 42 | ''BookRole 43 | ''BookBranchSt 44 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module Main (main) where 3 | 4 | import Book3.Main 5 | import Control.Monad 6 | import System.Random 7 | import Control.Exception 8 | 9 | main :: IO () 10 | main = do 11 | replicateM_ 100 $ do 12 | g <- newStdGen 13 | case book3Prop g of 14 | Left e -> throwIO e 15 | Right _ -> pure () 16 | -------------------------------------------------------------------------------- /typed-session.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | -- The cabal-version field refers to the version of the .cabal specification, 3 | -- and can be different from the cabal-install (the tool) version and the 4 | -- Cabal (the library) version you are using. As such, the Cabal (the library) 5 | -- version used must be equal or greater than the version stated in this field. 6 | -- Starting from the specification version 2.2, the cabal-version field must be 7 | -- the first thing in the cabal file. 8 | 9 | -- Initial package description 'typed-session' generated by 10 | -- 'cabal init'. For further documentation, see: 11 | -- http://haskell.org/cabal/users-guide/ 12 | -- 13 | -- The name of the package. 14 | name: typed-session 15 | 16 | -- The package version. 17 | -- See the Haskell package versioning policy (PVP) for standards 18 | -- guiding when and how versions should be incremented. 19 | -- https://pvp.haskell.org 20 | -- PVP summary: +-+------- breaking API changes 21 | -- | | +----- non-breaking API additions 22 | -- | | | +--- code changes with no API change 23 | version: 0.3.0.1 24 | 25 | -- A short (one-line) description of the package. 26 | synopsis: typed session framework 27 | 28 | -- A longer description of the package. 29 | description: 30 | Typed session are used to ensure desirable properties in concurrent and distributed systems, 31 | i.e. absence of communication errors or deadlocks, and protocol conformance. 32 | 33 | -- The license under which the package is released. 34 | license: MIT 35 | 36 | -- The file containing the license text. 37 | license-file: LICENSE 38 | 39 | -- The package author(s). 40 | author: sdzx-1 41 | 42 | -- An email address to which users can send suggestions, bug reports, and patches. 43 | maintainer: shangdizhixia1993@163.com 44 | 45 | category: Control, Network 46 | -- A copyright notice. 47 | -- copyright: 48 | build-type: Simple 49 | 50 | -- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. 51 | extra-doc-files: CHANGELOG.md 52 | 53 | -- Extra source files to be distributed with the package, such as examples, or a tutorial module. 54 | -- extra-source-files: 55 | extra-doc-files: data/*.png 56 | 57 | common warnings 58 | ghc-options: -Wall 59 | 60 | library 61 | -- Import common warning flags. 62 | import: warnings 63 | 64 | -- Modules exported by the library. 65 | exposed-modules: Data.IFunctor 66 | , TypedSession.Core 67 | , TypedSession.Codec 68 | , TypedSession.Driver 69 | , TypedSession.TH 70 | 71 | -- Modules included in this library but not exported. 72 | -- other-modules: 73 | 74 | -- LANGUAGE extensions used by modules in this package. 75 | -- other-extensions: 76 | 77 | -- Other library packages from which modules are imported. 78 | build-depends: base >= 4.20.0 && < 4.21 79 | , containers >= 0.7 && < 0.8 80 | , io-classes >= 1.7.0 && < 1.8 81 | , template-haskell >= 2.22.0 && < 2.23 82 | , typed-session-state-algorithm >= 0.5.0 && < 0.6 83 | 84 | -- Directories containing source files. 85 | hs-source-dirs: src 86 | 87 | -- Base language which the package is written in. 88 | default-language: Haskell2010 89 | 90 | test-suite typed-session-test 91 | -- Import common warning flags. 92 | import: warnings 93 | 94 | -- Base language which the package is written in. 95 | default-language: Haskell2010 96 | 97 | -- Modules included in this executable, other than Main. 98 | other-modules: Book3.Type 99 | , Book3.Protocol 100 | , Book3.Peer 101 | , Book3.Main 102 | 103 | -- LANGUAGE extensions used by modules in this package. 104 | -- other-extensions: 105 | 106 | -- The interface type and version of the test suite. 107 | type: exitcode-stdio-1.0 108 | 109 | -- Directories containing source files. 110 | hs-source-dirs: test 111 | 112 | -- The entrypoint to the test suite. 113 | main-is: Main.hs 114 | 115 | -- Test dependencies. 116 | build-depends: 117 | base >=4.20.0.0, 118 | typed-session, 119 | containers, 120 | io-classes, 121 | io-sim, 122 | random, 123 | fused-effects, 124 | fused-effects-random, 125 | template-haskell 126 | ghc-options: -Werror=inaccessible-code -threaded 127 | 128 | source-repository head 129 | type: git 130 | location: https://github.com/sdzx-1/typed-session 131 | --------------------------------------------------------------------------------