diff options
author | Eduardo Julian | 2018-02-11 20:16:22 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-02-11 20:16:22 -0400 |
commit | 8d5b71001f0600909d11909acaffa4c2d6f98131 (patch) | |
tree | 7a23e3f6241a8590f64edc94f333bafc738413de | |
parent | fd9def43d37bfa548f62915f62e5e6cb0a1dfcac (diff) |
- Added initial implementation of protocol-based object-oriented programming.
-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 | ||||
-rw-r--r-- | stdlib/test/test/lux/type/object/protocol.lux | 114 | ||||
-rw-r--r-- | stdlib/test/tests.lux | 4 |
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] |