aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/exception.lux2
-rw-r--r--stdlib/source/lux/macro.lux2
-rw-r--r--stdlib/source/lux/macro/syntax/common/writer.lux16
-rw-r--r--stdlib/source/lux/type/object/protocol.lux84
-rw-r--r--stdlib/test/test/lux/type/object/protocol.lux114
-rw-r--r--stdlib/test/tests.lux4
6 files changed, 213 insertions, 9 deletions
diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index c37b759a2..8a959b6c8 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -91,7 +91,7 @@
g!self (code.local-symbol name)]]
(wrap (list (` (def: (~+ (csw.export export))
(~ g!self)
- (All (~ (csw.type-variables t-vars))
+ (All [(~+ (csw.type-variables t-vars))]
(..Exception [(~+ (list/map (get@ #cs.input-type) inputs))]))
(let [(~ g!descriptor) (~ (code.text descriptor))]
{#..label (~ g!descriptor)
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
index 27329e55c..01f1806c4 100644
--- a/stdlib/source/lux/macro.lux
+++ b/stdlib/source/lux/macro.lux
@@ -392,7 +392,7 @@
#let [symbol-defs (list/join (list/map (: (-> Text (List Code))
(function [name] (list (code.symbol ["" name]) (` (gensym (~ (code.text name)))))))
symbol-names))]]
- (wrap (list (` (do Monad<Meta>
+ (wrap (list (` ((~! do) (~! Monad<Meta>)
[(~+ symbol-defs)]
(~ body))))))
diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux
index e9f899f1d..9c304223e 100644
--- a/stdlib/source/lux/macro/syntax/common/writer.lux
+++ b/stdlib/source/lux/macro/syntax/common/writer.lux
@@ -1,23 +1,27 @@
-(.module: {#.doc "Commons syntax writers."}
+(.module:
+ {#.doc "Commons syntax writers."}
lux
(lux (data (coll [list "list/" Functor<List>])
[product])
(macro [code]))
[//])
-## Exports
(def: #export (export exported?)
(-> Bool (List Code))
(if exported?
(list (' #export))
(list)))
-## Annotations
+(def: #export (declaration declaration)
+ (-> //.Declaration Code)
+ (` ((~ (code.local-symbol (get@ #//.declaration-name declaration)))
+ (~+ (list/map code.local-symbol
+ (get@ #//.declaration-args declaration))))))
+
(def: #export (annotations anns)
(-> //.Annotations Code)
(|> anns (list/map (product.both code.tag id)) code.record))
-## Type-Variables
(def: #export (type-variables vars)
- (-> (List Text) Code)
- (code.tuple (list/map code.local-symbol vars)))
+ (-> (List Text) (List Code))
+ (list/map code.local-symbol vars))
diff --git a/stdlib/source/lux/type/object/protocol.lux b/stdlib/source/lux/type/object/protocol.lux
new file mode 100644
index 000000000..73bc9226f
--- /dev/null
+++ b/stdlib/source/lux/type/object/protocol.lux
@@ -0,0 +1,84 @@
+(.module:
+ lux
+ (lux (control ["p" parser]
+ [monad #+ do])
+ (data (coll [list "list/" Functor<List>]))
+ [macro "meta/" Monad<Meta>]
+ (macro [code]
+ ["s" syntax #+ syntax:]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer])))))
+
+(type: #export (Simple i o)
+ (All [r] [i (-> o r)]))
+
+(type: #export (Message i o)
+ (Simple i o o))
+
+(def: #export (message input)
+ (All [i o] (-> i (Message i o)))
+ [input id])
+
+(type: #export (Method s p)
+ (All [r] (-> (p r) s [r s])))
+
+(type: #export (Object p)
+ (All [r] (-> (p r) [r (Object p)])))
+
+(def: #export (object method init)
+ (All [s p] (-> (Method s p) s (Object p)))
+ (loop [state init]
+ (function [input]
+ (let [[output state'] (method input state)]
+ [output (recur state')]))))
+
+(type: Method-Syntax
+ {#type-variables (List Text)
+ #name Text
+ #input Code
+ #output Code})
+
+(def: method|r
+ (s.Syntax Method-Syntax)
+ (s.form ($_ p.seq
+ (p.default (list) csr.type-variables)
+ s.local-symbol
+ s.any
+ s.any)))
+
+(def: (method|w g!return method)
+ (-> Code Method-Syntax Code)
+ (` ((~ (code.local-tag (get@ #name method)))
+ (All [(~+ (csw.type-variables (get@ #type-variables method)))]
+ [(~ (get@ #input method))
+ (-> (~ (get@ #output method)) (~ g!return))]))))
+
+(def: (method-constructor export protocol method)
+ (-> Bool cs.Declaration Method-Syntax (Meta Code))
+ (let [methodC (code.local-symbol (get@ #name method))
+ tagC (code.local-tag (get@ #name method))
+ protocolC (code.local-symbol (get@ #cs.declaration-name protocol))
+ protocol-varsC+ (csw.type-variables (get@ #cs.declaration-args protocol))
+ method-varsC+ (csw.type-variables (get@ #type-variables method))
+ method-inputC (get@ #input method)
+ method-outputC (get@ #output method)]
+ (macro.with-gensyms [g!input g!return]
+ (meta/wrap (` (def: (~+ (csw.export export)) ((~ methodC) (~ g!input))
+ (All [(~+ protocol-varsC+) (~+ method-varsC+)]
+ (-> (~ method-inputC)
+ ((~ protocolC) (~+ protocol-varsC+) (~ method-outputC))))
+ ((~ tagC) [(~ g!input) .id])))))))
+
+(syntax: #export (protocol: [export csr.export]
+ [declaration csr.declaration]
+ [methods (p.many method|r)])
+ (macro.with-gensyms [g!return]
+ (do @
+ [constructors (monad.map @ (method-constructor export declaration) methods)
+ #let [protocolC (code.local-symbol (get@ #cs.declaration-name declaration))
+ varsC+ (csw.type-variables (get@ #cs.declaration-args declaration))]]
+ (wrap (list& (` (type: (~+ (csw.export export))
+ ((~ protocolC) (~+ varsC+) (~ g!return))
+ (~+ (list/map (method|w g!return) methods))))
+ constructors)))))
diff --git a/stdlib/test/test/lux/type/object/protocol.lux b/stdlib/test/test/lux/type/object/protocol.lux
new file mode 100644
index 000000000..a93f34aab
--- /dev/null
+++ b/stdlib/test/test/lux/type/object/protocol.lux
@@ -0,0 +1,114 @@
+(.module:
+ lux
+ (lux (data text/format)
+ (type (object protocol))))
+
+(type: Counter (Object (Simple Unit Nat)))
+
+(def: (count [tick return] state)
+ (Method Nat (Simple Unit Nat))
+ (let [state' (n/inc state)]
+ [(return state') state']))
+
+(def: counter
+ (-> Nat Counter)
+ (object count))
+
+(def: _test0
+ [Nat Counter]
+ ((counter +0) (message [])))
+
+(protocol: Protocol0
+ (method0 [Bool Nat Text] Bool)
+ (method1 [Nat Text Bool] Nat)
+ (method2 [Text Bool Nat] Text))
+
+(type: Object0 (Object Protocol0))
+
+(def: object0
+ Object0
+ (loop [num-calls +0]
+ (function [message]
+ [(case message
+ (#method0 [arg0 arg1 arg2] output)
+ (output (n/= +0 (n/% +2 num-calls)))
+
+ (#method1 [arg0 arg1 arg2] output)
+ (output num-calls)
+
+ (#method2 [arg0 arg1 arg2] output)
+ (output (%n num-calls)))
+ (recur (n/inc num-calls))])))
+
+(def: _test1
+ [Nat Object0]
+ (object0 (method1 [+0 "0" false])))
+
+(protocol: (Read a)
+ (read [] a))
+
+(def: (readM [tick return] state)
+ (All [s] (Method s (Simple Unit s)))
+ [(return state) state])
+
+(protocol: (Add n)
+ (+ n Unit)
+ (- n Unit))
+
+(protocol: (Mul n)
+ (* n Unit)
+ (/ n Unit))
+
+(do-template [<name> <op>]
+ [(def: (<name> [diff return] state)
+ (Method Nat (Simple Nat Unit))
+ [(return []) (<op> diff state)])]
+
+ [+M n/+]
+ [-M n/-]
+ [*M n/*]
+ [/M n//]
+ )
+
+## (def: addM
+## (Method Nat (Add Nat))
+## (seq +M -M))
+
+(def: (addM message state)
+ (Method Nat (Add Nat))
+ (case message
+ (#+ message)
+ (+M message state)
+
+ (#- message)
+ (-M message state)))
+
+(def: (mulM message state)
+ (Method Nat (Mul Nat))
+ (case message
+ (#* message)
+ (*M message state)
+
+ (#/ message)
+ (/M message state)))
+
+(type: (Number n r)
+ (#Read (Read n r))
+ (#Add (Add n r))
+ (#Mul (Mul n r)))
+
+(def: (numberM message state)
+ (Method Nat (Number Nat))
+ (case message
+ (#Read message)
+ (readM message state)
+
+ (#Add message)
+ (addM message state)
+
+ (#Mul message)
+ (mulM message state)))
+
+(def: numberO
+ (Object (Number Nat))
+ (object numberM +0))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index b59e8008a..850abc865 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -69,7 +69,9 @@
(poly ["poly_." eq]
["poly_." functor]))
(type ["_." implicit]
- (object ["_." interface])
+ (object
+ ["_." interface]
+ ["_." protocol])
["_." resource])
(lang ["lang/_." syntax]
["_." type]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 16:00:38 +0000