diff options
| -rw-r--r-- | lux-mode/lux-mode.el | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/concurrency/session.lux | 211 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/syntax.lux | 10 | ||||
| -rw-r--r-- | stdlib/test/test/lux/concurrency/session.lux | 78 |
4 files changed, 297 insertions, 4 deletions
diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el index 45fbb75ec..1f2805a30 100644 --- a/lux-mode/lux-mode.el +++ b/lux-mode/lux-mode.el @@ -295,7 +295,7 @@ Called by `imenu--generic-function'." function-application ;;;;;;;;;;;;;;;;;;;;;;;; "\\.module:" - "def:" "type:" "program:" "context:" + "def:" "type:" "program:" "context:" "choice:" "macro:" "syntax:" "with-expansions" "exception:" diff --git a/stdlib/source/lux/concurrency/session.lux b/stdlib/source/lux/concurrency/session.lux new file mode 100644 index 000000000..9214860ca --- /dev/null +++ b/stdlib/source/lux/concurrency/session.lux @@ -0,0 +1,211 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["p" parser]] + [data + [text + format] + [collection + ["." list ("list/." Functor<List>)]]] + ["." io] + [type (#+ :share)] + ["." macro + ["." code] + ["s" syntax (#+ syntax:) + [common + ["." reader] + ["." writer]]]]] + [// + ["." promise (#+ Promise)]]) + +(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))) + +(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))) + +(type: #export End + {#.doc (doc "Represents the end of a protocol.")} + []) + +(def: #export end + {#.doc (doc "The last step in a session.")} + [End End] + [[] []]) + +(template: (!write <read> <write>) + (function (_ value) + (exec (io.run (promise.resolve [value <read>] channel)) + (promise.promise (#.Some <write>))))) + +(def: #export receive + {#.doc (doc "A Read step for 'me', and a Write step for 'you'.")} + (All [value mine yours] + (-> [mine yours] [(Read value mine) (Write value yours)])) + (function (_ [mine yours]) + (let [channel (promise.promise #.None)] + [channel + (!write mine yours)]))) + +(def: #export send + {#.doc (doc "A Write step for 'me', and a Read step for 'you'.")} + (All [value mine yours] + (-> [mine yours] [(Write value mine) (Read value yours)])) + (function (_ [mine yours]) + (let [channel (promise.promise #.None)] + [(!write yours mine) + channel]))) + +(def: #export (fork left right) + {#.doc (doc "A Fork step for 'me', and a Join step for 'you'.")} + (All [myL yourL myR yourR] + (-> [myL yourL] [myR yourR] + [(Fork myL myR) (Join yourL yourR)])) + (let [[myL yourL] left + [myR yourR] right + channel (:share [yourL yourR] + {[yourL yourR] + [yourL yourR]} + {(Join yourL yourR) + (promise.promise #.None)})] + [(function (_ signal) + (case signal + (#.Left go) + (exec (io.run (promise.resolve (#.Left yourL) channel)) + (promise.promise (#.Some (go myL)))) + + (#.Right go) + (exec (io.run (promise.resolve (#.Right yourR) channel)) + (promise.promise (#.Some (go myR)))))) + channel])) + +(def: #export (join left right) + {#.doc (doc "A Join step for 'me', and a Fork step for 'you'.")} + (All [myL yourL myR yourR] + (-> [myL yourL] [myR yourR] + [(Join myL myR) (Fork yourL yourR)])) + (let [[myL yourL] left + [myR yourR] right + channel (:share [myL myR] + {[myL myR] + [myL myR]} + {(Join myL myR) + (promise.promise #.None)})] + [channel + (function (_ signal) + (case signal + (#.Left go) + (exec (io.run (promise.resolve (#.Left myL) channel)) + (promise.promise (#.Some (go yourL)))) + + (#.Right go) + (exec (io.run (promise.resolve (#.Right myR) channel)) + (promise.promise (#.Some (go yourR))))))])) + +(do-template [<name> <side> <doc>] + [(def: #export (<name> session) + {#.doc (doc <doc>)} + (All [mine yours] (-> [mine yours] <side>)) + (let [[mine yours] session] + <side>))] + + [my mine + "'My' side of the session."] + [your yours + "'Your' side of the 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: counterpart-doc + (-> Name Code) + (|>> %name (format "The session/type counterpart to ") code.text)) + +(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] + ) + +(def: #export $end + {#.doc (doc (counterpart-doc (name-of ..end)))} + Session + [End End]) + +(def: #export >> + {#.doc (doc (counterpart-doc (name-of ..end)))} + $end) + +(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 ($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> <counterpart>] + [(def: #export (<name> [mine yours]) + {#.doc (doc (counterpart-doc (name-of <counterpart>)))} + (-> Session Type) + <side>) + + (def: #export <alias> <name>)] + + [$my +<< mine ..my] + [$your -<< yours ..your] + ) + +(syntax: #export (choice: {export reader.export} + {name s.local-identifier} + {tags (s.tuple (p.many s.local-tag))}) + {#.doc (doc "Defines tags to be used for fork/join branching in sessions.")} + (do @ + [g!vars (monad.map @ macro.gensym + (list.repeat (list.size tags) "var")) + #let [cases (list/map (function (_ [tag g!var]) + (` ((~ (code.local-tag tag)) (~ g!var)))) + (list.zip2 tags g!vars))]] + (wrap (list (` (type: (~+ (writer.export export)) ((~ (code.local-identifier name)) + (~+ g!vars)) + (~+ cases))))))) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index 07b0a4b9e..edee25af3 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -107,7 +107,7 @@ (#error.Error ($_ text/compose "Cannot parse local " <desc> (remaining-inputs tokens))))))] [local-identifier #.Identifier "identifier"] - [ local-tag #.Tag "tag"] + [ local-tag #.Tag "tag"] ) (do-template [<name> <tag> <desc>] @@ -195,6 +195,10 @@ (wrap [real value])))) ## [Syntax] +(def: (quote name) + (-> Text Text) + ($_ text/compose "'" name "'")) + (macro: #export (syntax: tokens) {#.doc (doc "A more advanced way to define macros than 'macro:'." "The inputs to the macro can be parsed in complex ways through the use of syntax parsers." @@ -250,7 +254,7 @@ (//.fail "Syntax pattern expects records or identifiers.")))) args) #let [g!state (code.identifier ["" "*compiler*"]) - error-msg (code.text (text/compose "Wrong syntax for " name)) + error-msg (code.text ($_ text/compose "Wrong syntax for " (quote name) ": ")) export-ast (: (List Code) (if exported? (list (' #export)) @@ -271,4 +275,4 @@ (~ body))))))))))))) _ - (//.fail "Wrong syntax for syntax:")))) + (//.fail (text/compose "Wrong syntax for " (quote "syntax:")))))) diff --git a/stdlib/test/test/lux/concurrency/session.lux b/stdlib/test/test/lux/concurrency/session.lux new file mode 100644 index 000000000..ad0343d15 --- /dev/null +++ b/stdlib/test/test/lux/concurrency/session.lux @@ -0,0 +1,78 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [concurrency + ["." promise] + ["$" session (#+ Session choice: << >> ?? !! +<< -<< \/ /\)]] + [data + [text + format]] + [math + ["r" random]]] + lux/test) + +(choice: Calculation [#Add #Negate]) + +(def: $add (<| (!! Int) (!! Int) (?? Int) >>)) +(def: $negate (<| (!! Int) (?? Int) >>)) + +(def: (add-session _) + (-> [] (:~ (<< $add))) + (<| $.send $.send $.receive $.end)) + +(def: (negate-session _) + (-> [] (:~ (<< $negate))) + (<| $.send $.receive $.end)) + +(def: $calculation + Session + ($_ \/ + $add + $negate)) + +(def: (calculation-session _) + (-> [] (:~ (<< $calculation))) + ($_ $.fork + (add-session []) + (negate-session []))) + +(def: (__my-calculation _) + (-> [] (:~ (+<< $calculation))) + ($.my (calculation-session []))) + +(def: (__your-calculation _) + (-> [] (:~ (-<< $calculation))) + ($.your (calculation-session []))) + +(context: "Sessions." + (do @ + [#let [[$me $you] (calculation-session [])] + param r.int + subject r.int] + ($_ seq + (wrap (do promise.Monad<Promise> + [$me ($me (#Add id)) + $me ($me param) + $me ($me subject) + [output $end] $me] + (assert "Client [#Add]" + (i/= (i/+ param subject) output)))) + (wrap (do promise.Monad<Promise> + [choice $you] + (case choice + (#Add $you) + (do @ + [[param-input $you] $you + [subject-input $you] $you + $end ($you (i/+ param-input subject-input))] + (assert "Server [#Add]" + true)) + + (#Negate $you) + (do @ + [[subject $you] $you + $end ($you (i/* -1 subject))] + (assert "Server [#Negate]" + true))))) + ))) |