aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/concurrency/session.lux211
-rw-r--r--stdlib/source/lux/macro/syntax.lux10
-rw-r--r--stdlib/test/test/lux/concurrency/session.lux78
3 files changed, 296 insertions, 3 deletions
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)))))
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 15:34:56 +0000