diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux/control/exception.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/macro.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/macro/syntax/common/writer.lux | 16 | ||||
| -rw-r--r-- | stdlib/source/lux/type/object/protocol.lux | 84 |
4 files changed, 96 insertions, 8 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))))) |