diff options
-rw-r--r-- | stdlib/source/lux/concurrency/session.lux | 228 | ||||
-rw-r--r-- | stdlib/test/test/lux/concurrency/session.lux | 139 |
2 files changed, 0 insertions, 367 deletions
diff --git a/stdlib/source/lux/concurrency/session.lux b/stdlib/source/lux/concurrency/session.lux deleted file mode 100644 index ac9f984d9..000000000 --- a/stdlib/source/lux/concurrency/session.lux +++ /dev/null @@ -1,228 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["p" parser]] - [data - ["." lazy (#+ Lazy)] - [text - format] - [collection - ["." list ("list/." Functor<List>)]]] - ["." io] - ["." type (#+ :share)] - ["." macro - ["." code] - ["s" syntax (#+ syntax:) - [common - ["." reader] - ["." writer]]]]] - [// - ["." promise (#+ Promise)]]) - -(def: counterpart-doc - (-> Name Code) - (|>> %name (format "The session/type counterpart to ") code.text)) - -## Session -(type: #export Session - {#.doc (doc "A pair of types, for 'me' and 'you'." - "They describe each side in a session protocol.")} - [Type Type]) - -(def: #export ($session [mine yours]) - {#.doc (doc "Create an actual type from a session.")} - (-> Session Type) - (type [mine yours])) - -(def: #export << - {#.doc (doc "Create an actual type from a session.")} - $session) - -(do-template [<name> <alias> <side> <doc>] - [(def: #export (<name> [mine yours]) - {#.doc (code.text (format "'" <doc> "' side of the session."))} - (-> Session Type) - <side>) - - (def: #export <alias> <name>)] - - [$my +<< mine "My"] - [$your -<< yours "Your"] - ) - -## End -(type: #export End - {#.doc (doc "Represents the end of a protocol.")} - []) - -(def: #export end - {#.doc (doc "The last step in a session.")} - (Lazy [End End]) - (lazy.freeze [[] []])) - -(def: #export $end - {#.doc (doc (counterpart-doc (name-of ..end)))} - Session - [End End]) - -(def: #export >> - {#.doc (doc (counterpart-doc (name-of ..end)))} - $end) - -## Read (Receive) / Write (Send) -(type: #export (Read value next) - {#.doc (doc "A reading step.")} - (-> [] (Promise [value next]))) - -(type: #export (Write value next) - {#.doc (doc "A writing step.")} - (-> value (Promise next))) - -(def: #export (receive session) - {#.doc (doc "A Read step for 'me', and a Write step for 'you'.")} - (All [value mine yours] - (-> (Lazy [mine yours]) - (Lazy [(Read value mine) (Write value yours)]))) - (lazy.freeze (let [channel (promise.promise #.None)] - [(function (_ _) - (let [[mine yours] (lazy.thaw session)] - (do promise.Monad<Promise> - [value channel] - (wrap [value mine])))) - (function (_ value) - (let [[mine yours] (lazy.thaw session)] - (exec (io.run (promise.resolve value channel)) - (promise.promise (#.Some yours)))))]))) - -(def: #export (send session) - {#.doc (doc "A Write step for 'me', and a Read step for 'you'.")} - (All [value mine yours] - (-> (Lazy [mine yours]) - (Lazy [(Write value mine) (Read value yours)]))) - (lazy.freeze (let [channel (promise.promise #.None)] - [(function (_ value) - (let [[mine yours] (lazy.thaw session)] - (exec (io.run (promise.resolve value channel)) - (promise.promise (#.Some mine))))) - (function (_ _) - (let [[mine yours] (lazy.thaw session)] - (do promise.Monad<Promise> - [value channel] - (wrap [value yours]))))]))) - -(do-template [<name> <alias> <me> <you> <counterpart>] - [(def: #export (<name> value [mine yours]) - {#.doc (doc (counterpart-doc (name-of <counterpart>)))} - (-> Type Session Session) - [(type (<me> value mine)) (type (<you> value yours))]) - - (def: #export <alias> - {#.doc (doc <doc>)} - <name>)] - - [$receive ?? Read Write ..receive] - [$send !! Write Read ..send] - ) - -## Fork / Join -(type: #export (Fork left right) - {#.doc (doc "A forking step, that allows choosing which path to take.")} - (All [next] - (-> (| (-> left next) - (-> right next)) - (Promise next)))) - -(type: #export (Join left right) - {#.doc (doc "A joining step, which communicates which path was taken.")} - (-> [] (Promise (| left right)))) - -(def: #export (fork left right) - {#.doc (doc "A Fork step for 'me', and a Join step for 'you'.")} - (All [myL yourL myR yourR] - (-> (Lazy [myL yourL]) (Lazy [myR yourR]) - (Lazy [(Fork myL myR) (Join yourL yourR)]))) - (lazy.freeze (let [channel (: (Promise Bit) - (promise.promise #.None))] - [(function (_ signal) - (let [[myL yourL] (lazy.thaw left) - [myR yourR] (lazy.thaw right)] - (case signal - (#.Left go) - (exec (io.run (promise.resolve #0 channel)) - (promise.promise (#.Some (go myL)))) - - (#.Right go) - (exec (io.run (promise.resolve #1 channel)) - (promise.promise (#.Some (go myR))))))) - (function (_ _) - (let [[myL yourL] (lazy.thaw left) - [myR yourR] (lazy.thaw right)] - (do promise.Monad<Promise> - [choice channel] - (wrap (case choice - #0 (#.Left yourL) - #1 (#.Right yourR))))))]))) - -(def: #export (join left right) - {#.doc (doc "A Join step for 'me', and a Fork step for 'you'.")} - (All [myL yourL myR yourR] - (-> (Lazy [myL yourL]) (Lazy [myR yourR]) - (Lazy [(Join myL myR) (Fork yourL yourR)]))) - (lazy.freeze (let [channel (: (Promise Bit) - (promise.promise #.None))] - [(function (_ _) - (let [[myL yourL] (lazy.thaw left) - [myR yourR] (lazy.thaw right)] - (do promise.Monad<Promise> - [choice channel] - (wrap (case choice - #0 (#.Left myL) - #1 (#.Right myR)))))) - (function (_ signal) - (let [[myL yourL] (lazy.thaw left) - [myR yourR] (lazy.thaw right)] - (case signal - (#.Left go) - (exec (io.run (promise.resolve #0 channel)) - (promise.promise (#.Some (go yourL)))) - - (#.Right go) - (exec (io.run (promise.resolve #1 channel)) - (promise.promise (#.Some (go yourR)))))))]))) - -(do-template [<name> <alias> <+> <-> <counterpart>] - [(def: #export (<name> [myL yourL] [myR yourR]) - {#.doc (doc (counterpart-doc (name-of <counterpart>)))} - (-> Session Session Session) - [(type (<+> myL myR)) (type (<-> yourL yourR))]) - - (def: #export <alias> - {#.doc (doc (counterpart-doc (name-of <counterpart>)))} - <name>)] - - [$join /\ Join Fork ..join] - [$fork \/ Fork Join ..fork] - ) - -(def: #export ($rec scope) - (-> (-> Session Session) - Session) - (case (type (All $recur [$_] - (:~ ($session (scope [(#.Apply $_ $recur) - (#.Apply $_ $recur)]))))) - (^multi (#.UnivQ _env $scope) - [(type.flatten-tuple $scope) - (^ (list mine yours))]) - [(#.Apply Any (#.UnivQ _env mine)) - (#.Apply Any (#.UnivQ _env yours))] - - _ - (undefined))) - -(def: #export (rec scope) - (All [session] - (-> (-> (Lazy session) - (Lazy session)) - (Lazy session))) - (lazy.freeze (lazy.thaw (scope (rec scope))))) diff --git a/stdlib/test/test/lux/concurrency/session.lux b/stdlib/test/test/lux/concurrency/session.lux deleted file mode 100644 index ed538372c..000000000 --- a/stdlib/test/test/lux/concurrency/session.lux +++ /dev/null @@ -1,139 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]] - [data - ["." lazy (#+ Lazy)]] - ["." io (#+ IO)] - [concurrency - ["." promise] - ["$" session (#+ Session << >> ?? !! +<< -<< \/ /\ $rec)]] - [data - [text - format]] - [math - ["r" random]]] - lux/test) - -(def: $transfer (<| << (!! Int) >>)) - -(def: transfer - (IO (:~ $transfer)) - (io.io (lazy.thaw (<| $.send $.end)))) - -(context: "Transfer." - (do @ - [#let [[$me $you] (io.run ..transfer)] - expectation r.int] - ($_ seq - (wrap (do promise.Monad<Promise> - [$me ($me expectation)] - (assert "Client [Transfer]" - true))) - (wrap (do promise.Monad<Promise> - [[actual $end] ($you [])] - (assert "Server [Transfer]" - (i/= expectation actual)))) - ))) - -(def: $endless - (<< ($rec (function (_ $recur) - (<| (!! Int) $recur))))) - -(def: endless - (IO (:~ $endless)) - (io.io (lazy.thaw ($.rec (function (_ recur) - (<| $.send recur)))))) - -(context: "Endless." - (do @ - [#let [[$me $you] (io.run ..endless)] - expectation0 r.int - expectation1 r.int - expectation2 r.int] - ($_ seq - (wrap (do promise.Monad<Promise> - [$me ($me expectation0) - $me ($me expectation1) - $me ($me expectation2)] - (assert "Client [Endless]" - true))) - (wrap (do promise.Monad<Promise> - [[actual0 $you] ($you []) - [actual1 $you] ($you []) - [actual2 $you] ($you [])] - (assert "Server [Endless]" - (and (i/= expectation0 actual0) - (i/= expectation1 actual1) - (i/= expectation2 actual2))))) - ))) - -(def: $calculation - Session - ($rec - (function (_ $recur) - ($_ \/ - (<| (!! Int) (!! Int) (?? Int) $recur) - (<| (!! Int) (?? Int) $recur) - >>)))) - -(def: calculation - (IO (:~ (<< $calculation))) - (io.io (lazy.thaw ($.rec - (function (_ recur) - ($_ $.fork - (<| $.send $.send $.receive recur) - (<| $.send $.receive recur) - $.end)))))) - -(def: negate (i/* -1)) - -(context: "Complex session." - (do @ - [#let [[$me $you] (io.run calculation)] - param r.int - subject r.int - #let [expectation (i/+ param subject)]] - ($_ seq - (wrap (do promise.Monad<Promise> - [## Add - $me ($me (#.Left id)) - $me ($me param) - $me ($me subject) - [output $me] ($me []) - ## Negate - $me ($me (#.Right id)) - $me ($me (#.Left id)) - $me ($me output) - [-output $me] ($me []) - ## Quit - $me ($me (#.Right id)) - $me ($me (#.Right id))] - (assert "Client [Add & Negate & Quit]" - (and (i/= expectation output) - (i/= (..negate expectation) -output))))) - (wrap (loop [$add|<negate|quit> $you] - (do promise.Monad<Promise> - [add|<negate|quit> ($add|<negate|quit> [])] - (case add|<negate|quit> - (#.Left $add) - (do @ - [[param-input $add] ($add []) - [subject-input $add] ($add []) - $recur ($add (i/+ param-input subject-input))] - (recur $recur)) - - (#.Right $negate|quit) - (do @ - [negate|quit ($negate|quit [])] - (case negate|quit - (#.Left $negate) - (do @ - [[subject $negate] ($negate []) - $recur ($negate (..negate subject))] - (recur $recur)) - - (#.Right $quit) - (assert "Server [Quit]" - true))))))) - ))) |