├── .gitignore ├── System └── Concurrency │ └── Channel │ ├── Linear.idr │ └── Session │ ├── Raw.idr │ └── Tree.idr ├── sesh.ipkg └── tests ├── Main.idr ├── Makefile └── tests.ipkg /.gitignore: -------------------------------------------------------------------------------- 1 | *.ibc 2 | *.o 3 | build/ 4 | -------------------------------------------------------------------------------- /System/Concurrency/Channel/Linear.idr: -------------------------------------------------------------------------------- 1 | module System.Concurrency.Channel.Linear 2 | 3 | import Control.Linear.LIO 4 | import System.Concurrency 5 | 6 | ||| Represents the endpoint of a one-shot channel over which the value is sent. 7 | ||| 8 | ||| This is created by `makeLinearChannel`. 9 | export 10 | record Sender a where 11 | constructor MkSender 12 | 1 chan : Channel a 13 | 14 | ||| Represents the endpoint of a one-shot channel over which the value is 15 | ||| received. 16 | ||| 17 | ||| This is created by `makeLinearChannel`. 18 | export 19 | record Receiver a where 20 | constructor MkReceiver 21 | 1 chan : Channel a 22 | 23 | ||| Creates a one-shot channel, consisting of a `Sender` and a `Receiver`. 24 | export 25 | makeLinearChannel : LinearIO io => L io (Sender a, Receiver a) 26 | makeLinearChannel = do 27 | chan <- makeChannel 28 | pure (MkSender chan, MkReceiver chan) 29 | 30 | unsafe_channelGet : HasIO io => (1 chan : Channel a) -> io a 31 | unsafe_channelGet chan = assert_linear channelGet chan 32 | 33 | ||| Receives a value over a one-shot channel, thereby consuming the `Receiver` 34 | ||| endpoint of the channel. 35 | export 36 | linearChannelReceive : LinearIO io => (1 receiver : Receiver a) -> L io a 37 | linearChannelReceive (MkReceiver chan) = unsafe_channelGet chan 38 | 39 | unsafe_channelPut : HasIO io => (1 chan : Channel a) -> (1 val : a) -> io () 40 | unsafe_channelPut chan val = assert_linear (assert_linear channelPut chan) val 41 | 42 | ||| Sends a value over a one-shot channel, thereby consuming the `Sender` 43 | ||| endpoint of the channel. 44 | export 45 | linearChannelSend : LinearIO io => (1 sender : Sender a) -> (1 val : a) -> L io () 46 | linearChannelSend (MkSender chan) val = unsafe_channelPut chan val 47 | -------------------------------------------------------------------------------- /System/Concurrency/Channel/Session/Raw.idr: -------------------------------------------------------------------------------- 1 | module System.Concurrency.Channel.Session.Raw 2 | 3 | import Control.Linear.LIO 4 | import System.Concurrency 5 | import System.Concurrency.Channel.Linear 6 | 7 | public export 8 | data SessionType : Type where 9 | Send : Type -> SessionType -> SessionType 10 | Receive : Type -> SessionType -> SessionType 11 | End : SessionType 12 | 13 | public export 14 | dual : SessionType -> SessionType 15 | dual (Send a s) = Receive a (dual s) 16 | dual (Receive a s) = Send a (dual s) 17 | dual End = End 18 | 19 | export 20 | dualInv : (s : SessionType) -> dual (dual s) = s 21 | dualInv (Send a s) = rewrite dualInv s in Refl 22 | dualInv (Receive a s) = rewrite dualInv s in Refl 23 | dualInv End = Refl 24 | 25 | export 26 | data Session : SessionType -> Type where 27 | MkSend : (1 sender : Sender (a, Session (dual s))) -> Session (Send a s) 28 | MkReceive : (1 receiver : Receiver (a, Session s)) -> Session (Receive a s) 29 | MkEnd : (1 barrier : Barrier) -> Session End 30 | 31 | ||| Create a new session and return two dual endpoints. 32 | export 33 | makeSession : (LinearBind io, HasIO io) => 34 | {1 s : SessionType} -> 35 | L io (Session s, Session (dual s)) 36 | makeSession {s = Send a s} = do 37 | (sender, receiver) <- makeLinearChannel 38 | pure (MkSend sender, MkReceive receiver) 39 | makeSession {s = Receive a s} = do 40 | (sender, receiver) <- makeLinearChannel 41 | pure (MkReceive receiver, MkSend (rewrite dualInv s in sender)) 42 | makeSession {s = End} = do 43 | barrier <- makeBarrier 2 44 | pure (MkEnd barrier, MkEnd barrier) 45 | 46 | ||| Send a value of type `a` and return the continuation of the session `s`. 47 | export 48 | sessionSend : (LinearBind io, HasIO io) => 49 | {1 s : SessionType} -> 50 | (1 sess : Session (Send a s)) -> 51 | (1 val : a) -> 52 | L io (Session s) 53 | sessionSend {s = s} (MkSend sender) val = do 54 | (myCont, theirCont) <- makeSession {s = s} 55 | linearChannelSend sender (val, theirCont) 56 | pure myCont 57 | 58 | ||| Receive a value of type `a`, and return a pair of the received value and the 59 | ||| continuation of the session `s`. 60 | export 61 | sessionReceive : (LinearBind io, HasIO io) => 62 | (1 sess : Session (Receive a s)) -> 63 | L io (a, Session s) 64 | sessionReceive (MkReceive receiver) = do 65 | linearChannelReceive receiver 66 | 67 | ||| End a session. 68 | export 69 | sessionEnd : (LinearBind io, HasIO io) => 70 | (1 sess : Session End) -> 71 | L io () 72 | sessionEnd (MkEnd barrier) = do 73 | assert_linear barrierWait barrier 74 | -------------------------------------------------------------------------------- /System/Concurrency/Channel/Session/Tree.idr: -------------------------------------------------------------------------------- 1 | module System.Concurrency.Channel.Session.Tree 2 | 3 | import Control.Linear.LIO as LIO 4 | import System.Concurrency.Channel.Session.Raw as Raw 5 | 6 | export 7 | record Par (i : Type) (a : Type) where 8 | constructor MkPar 9 | runPar' : L IO a 10 | 11 | export 12 | data Session : Type -> SessionType -> Type where 13 | MkSession : Raw.Session s -> Session i s 14 | 15 | export 16 | runPar : (forall i . Par i a) -> a 17 | runPar par = let MkPar prog = par {i = ()} in 18 | unsafePerformIO (LIO.run prog) 19 | 20 | mutual 21 | export 22 | Functor (Par i) where 23 | map fn par = pure $ fn !par 24 | 25 | export 26 | Applicative (Par i) where 27 | pure = MkPar . pure 28 | (<*>) f a = pure $ !f !a 29 | 30 | export 31 | Monad (Par i) where 32 | MkPar p >>= k 33 | = MkPar $ do p' <- p 34 | let MkPar kp = k p' 35 | kp 36 | 37 | ||| Send a value of type `a` and return the continuation of the session `s`. 38 | export 39 | sessionSend : {1 s : SessionType} -> 40 | (1 sess : Session i (Send a s)) -> 41 | (1 val : a) -> 42 | Par i (Session i s) 43 | sessionSend (MkSession sess) val = MkPar $ do 44 | myCont <- Raw.sessionSend {s = s} sess val 45 | pure (MkSession myCont) 46 | 47 | ||| Receive a value of type `a`, and return a pair of the received value and the 48 | ||| continuation of the session `s`. 49 | export 50 | sessionReceive : (1 sess : Session i (Receive a s)) -> 51 | Par i (a, Session i s) 52 | sessionReceive (MkSession sess) = MkPar $ do 53 | (val, myCont) <- Raw.sessionReceive sess 54 | pure (val, MkSession myCont) 55 | 56 | ||| End a session. 57 | export 58 | sessionEnd : (1 sess : Session i End) -> 59 | Par i () 60 | sessionEnd (MkSession sess) = MkPar $ do 61 | Raw.sessionEnd sess 62 | -------------------------------------------------------------------------------- /sesh.ipkg: -------------------------------------------------------------------------------- 1 | package sesh 2 | 3 | depends = contrib 4 | modules = System.Concurrency.Channel.Linear 5 | , System.Concurrency.Channel.Session.Raw 6 | , System.Concurrency.Channel.Session.Tree 7 | -------------------------------------------------------------------------------- /tests/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Test.Golden 4 | 5 | -------------------------------------------------------------------------------- 6 | -- Test cases 7 | 8 | barrierTests : TestPool 9 | barrierTests = MkTestPool [] 10 | [ "basic001" 11 | ] 12 | 13 | semaphoreTests : TestPool 14 | semaphoreTests = MkTestPool [] 15 | [ "basic001" 16 | , "basic002" 17 | ] 18 | 19 | 20 | main : IO () 21 | main = runner 22 | [ testPaths "barrier" barrierTests 23 | , testPaths "semaphore" semaphoreTests 24 | ] 25 | where 26 | testPaths : String -> TestPool -> TestPool 27 | testPaths dir = record { testCases $= map ((dir ++ "/") ++) } 28 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | IDRIS2 ?= idris2 2 | RUNTESTS := ./build/exec/runtests 3 | 4 | .PHONY: test 5 | 6 | test: $(RUNTESTS) 7 | $(RUNTESTS) $(IDRIS2) 8 | 9 | $(RUNTESTS): Main.idr 10 | $(IDRIS2) --build tests.ipkg 11 | 12 | 13 | .PHONY: clean 14 | 15 | clean: 16 | @rm -rf build 17 | @find . -type f -name 'output' -exec rm -rf {} \; 18 | @find . -type f -name '*.ttc' -exec rm -f {} \; 19 | @find . -type f -name '*.ttm' -exec rm -f {} \; 20 | @find . -type f -name '*.ibc' -exec rm -f {} \; 21 | 22 | -------------------------------------------------------------------------------- /tests/tests.ipkg: -------------------------------------------------------------------------------- 1 | package runtests 2 | 3 | depends = contrib 4 | main = Main 5 | executable = runtests 6 | --------------------------------------------------------------------------------