diff options
| -rw-r--r-- | stdlib/source/lux/type/object/protocol.lux | 116 | ||||
| -rw-r--r-- | stdlib/test/test/lux/type/object/protocol.lux | 103 |
2 files changed, 151 insertions, 68 deletions
diff --git a/stdlib/source/lux/type/object/protocol.lux b/stdlib/source/lux/type/object/protocol.lux index 73bc9226f..b19c1b203 100644 --- a/stdlib/source/lux/type/object/protocol.lux +++ b/stdlib/source/lux/type/object/protocol.lux @@ -2,7 +2,8 @@ lux (lux (control ["p" parser] [monad #+ do]) - (data (coll [list "list/" Functor<List>])) + (data [sum] + (coll [list "list/" Functor<List>])) [macro "meta/" Monad<Meta>] (macro [code] ["s" syntax #+ syntax:] @@ -10,34 +11,50 @@ (common ["csr" reader] ["csw" writer]))))) -(type: #export (Simple i o) +(type: #export (Method i o) (All [r] [i (-> o r)])) (type: #export (Message i o) - (Simple i o o)) + (Method i o o)) (def: #export (message input) (All [i o] (-> i (Message i o))) [input id]) -(type: #export (Method s p) +(type: #export (Class s p) (All [r] (-> (p r) s [r s]))) +(type: #export (Alt lp rp) + (All [r] (| (lp r) (rp r)))) + +(def: #export (alt left right) + (All [s lp rp] + (-> (Class s lp) + (Class s rp) + (Class s (Alt lp rp)))) + (function [input state] + (case input + (#.Left input) + (left input state) + + (#.Right input) + (right input state)))) + (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))) +(def: #export (object class init) + (All [s p] (-> (Class s p) s (Object p))) (loop [state init] (function [input] - (let [[output state'] (method input state)] + (let [[output state'] (class input state)] [output (recur state')])))) (type: Method-Syntax - {#type-variables (List Text) - #name Text - #input Code - #output Code}) + {#method-variables (List Text) + #method-name Text + #method-input Code + #method-output Code}) (def: method|r (s.Syntax Method-Syntax) @@ -49,20 +66,22 @@ (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))])))) + (let [tagC (code.local-tag (get@ #method-name method)) + varsC+ (csw.type-variables (get@ #method-variables method)) + inputC (get@ #method-input method) + outputC (get@ #method-output method)] + (` ((~ tagC) (All [(~+ varsC+)] + (Method (~ inputC) (~ outputC) (~ g!return))))))) -(def: (method-constructor export protocol method) +(def: (method|c 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)) + (let [methodC (code.local-symbol (get@ #method-name method)) + tagC (code.local-tag (get@ #method-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)] + method-varsC+ (csw.type-variables (get@ #method-variables method)) + method-inputC (get@ #method-input method) + method-outputC (get@ #method-output method)] (macro.with-gensyms [g!input g!return] (meta/wrap (` (def: (~+ (csw.export export)) ((~ methodC) (~ g!input)) (All [(~+ protocol-varsC+) (~+ method-varsC+)] @@ -70,15 +89,64 @@ ((~ protocolC) (~+ protocol-varsC+) (~ method-outputC)))) ((~ tagC) [(~ g!input) .id]))))))) +(type: Class-Syntax + {#class-name Text + #class-protocol Code}) + +(def: class|r + (s.Syntax Class-Syntax) + (s.form ($_ p.seq + s.local-symbol + s.any))) + +(def: (class|w g!return class) + (-> Code Class-Syntax Code) + (let [tagC (code.local-tag (get@ #class-name class)) + protocolC (get@ #class-protocol class)] + (` ((~ tagC) ((~ protocolC) (~ g!return)))))) + +(def: (class|c export protocol class) + (-> Bool cs.Declaration Class-Syntax (Meta Code)) + (let [classC (code.local-symbol (get@ #class-name class)) + tagC (code.local-tag (get@ #class-name class)) + protocolC (code.local-symbol (get@ #cs.declaration-name protocol)) + protocol-varsC+ (csw.type-variables (get@ #cs.declaration-args protocol)) + class-protocolC (get@ #class-protocol class)] + (macro.with-gensyms [g!sub g!return] + (meta/wrap (` (def: (~+ (csw.export export)) ((~ classC) (~ g!sub)) + (All [(~+ protocol-varsC+)] + (-> (~ class-protocolC) + ((~ protocolC) (~+ protocol-varsC+)))) + ((~ tagC) (~ g!sub)))))))) + +(type: Super-Syntax + (#Method Method-Syntax) + (#Class Class-Syntax)) + +(def: super|r + (s.Syntax Super-Syntax) + (p.alt method|r + class|r)) + +(def: (super|w g!return) + (-> Code Super-Syntax Code) + (sum.either (method|w g!return) + (class|w g!return))) + +(def: (super|c export protocol) + (-> Bool cs.Declaration (| Method-Syntax Class-Syntax) (Meta Code)) + (sum.either (method|c export protocol) + (class|c export protocol))) + (syntax: #export (protocol: [export csr.export] [declaration csr.declaration] - [methods (p.many method|r)]) + [supers (p.many super|r)]) (macro.with-gensyms [g!return] (do @ - [constructors (monad.map @ (method-constructor export declaration) methods) + [constructors (monad.map @ (super|c export declaration) supers) #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)))) + (~+ (list/map (super|w g!return) supers)))) constructors))))) diff --git a/stdlib/test/test/lux/type/object/protocol.lux b/stdlib/test/test/lux/type/object/protocol.lux index a93f34aab..2017459bd 100644 --- a/stdlib/test/test/lux/type/object/protocol.lux +++ b/stdlib/test/test/lux/type/object/protocol.lux @@ -3,10 +3,10 @@ (lux (data text/format) (type (object protocol)))) -(type: Counter (Object (Simple Unit Nat))) +(type: Counter (Object (Method Unit Nat))) (def: (count [tick return] state) - (Method Nat (Simple Unit Nat)) + (Class Nat (Method Unit Nat)) (let [state' (n/inc state)] [(return state') state'])) @@ -48,7 +48,7 @@ (read [] a)) (def: (readM [tick return] state) - (All [s] (Method s (Simple Unit s))) + (All [s] (Class s (Method Unit s))) [(return state) state]) (protocol: (Add n) @@ -61,7 +61,7 @@ (do-template [<name> <op>] [(def: (<name> [diff return] state) - (Method Nat (Simple Nat Unit)) + (Class Nat (Method Nat Unit)) [(return []) (<op> diff state)])] [+M n/+] @@ -70,45 +70,60 @@ [/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: addM + (Class Nat (Add Nat)) + (alt +M -M)) + +(def: mulM + (Class Nat (Mul Nat)) + (alt *M /M)) + +(type: (Number n) + ($_ Alt + (Read n) + (Add n) + (Mul n))) + +## TODO: Fix when new-luxc is the official compiler. +## (protocol: (Number n) +## (^read (Read n)) +## (^add (Add n)) +## (^mul (Mul n))) + +(def: numberM + (Class Nat (Number Nat)) + ($_ alt + readM + addM + mulM)) + +(type: NatO (Object (Number Nat))) (def: numberO - (Object (Number Nat)) - (object numberM +0)) + NatO + (object numberM +1)) + +(def: _test2 + [Nat NatO] + (numberO (+0 (read [])))) + +(def: _test3 + [Unit NatO] + (numberO (+1 (+0 (+ +123))))) + +(def: _test4 + [Unit NatO] + (numberO (+1 (+1 (* +123))))) + +## TODO: Fix when new-luxc is the official compiler. +## (def: _test2 +## [Nat NatO] +## (numberO (^read (read [])))) + +## (def: _test3 +## [Unit NatO] +## (numberO (^add (+ +123)))) + +## (def: _test4 +## [Unit NatO] +## (numberO (^mul (* +123)))) |