diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux/type/object/protocol.lux | 116 |
1 files changed, 92 insertions, 24 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))))) |