From 2c1a4d14de8f968ea0530ad471a1999488983c9d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Jul 2017 15:13:36 -0400 Subject: - Relocated the "object" and "concatenative" modules. --- stdlib/source/lux/control/concatenative.lux | 333 +++++++++++++++++ stdlib/source/lux/paradigm/concatenative.lux | 333 ----------------- stdlib/source/lux/paradigm/object.lux | 514 -------------------------- stdlib/source/lux/type/object.lux | 515 +++++++++++++++++++++++++++ 4 files changed, 848 insertions(+), 847 deletions(-) create mode 100644 stdlib/source/lux/control/concatenative.lux delete mode 100644 stdlib/source/lux/paradigm/concatenative.lux delete mode 100644 stdlib/source/lux/paradigm/object.lux create mode 100644 stdlib/source/lux/type/object.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux new file mode 100644 index 000000000..a0854ffcf --- /dev/null +++ b/stdlib/source/lux/control/concatenative.lux @@ -0,0 +1,333 @@ +(;module: [lux #- if loop + n.+ n.- n.* n./ n.% n.= n.< n.<= n.> n.>= + i.+ i.- i.* i./ i.% i.= i.< i.<= i.> i.>= + d.+ d.- d.* d./ d.% d.= d.< d.<= d.> d.>= + r.+ r.- r.* r./ r.% r.= r.< r.<= r.> r.>=] + (lux (control ["p" parser "p/" Monad] + [monad]) + (data [text] + text/format + [maybe "m/" Monad] + (coll [list "L/" Fold Functor])) + [macro #+ with-gensyms Monad] + (macro [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))))) + +## [Syntax] +(type: Alias [Text Code]) + +(type: Stack + {#bottom (Maybe Nat) + #top (List Code)}) + +(def: aliases^ + (s;Syntax (List Alias)) + (|> (p;seq s;local-symbol s;any) + p;some + s;record + (p;default (list)))) + +(def: bottom^ + (s;Syntax Nat) + (s;form (p;after (s;this (` #;Bound)) s;nat))) + +(def: stack^ + (s;Syntax Stack) + (p;either (p;seq (p;opt bottom^) + (s;tuple (p;some s;any))) + (p;seq (|> bottom^ (p/map (|>. #;Some))) + (p/wrap (list))))) + +(def: (stack-fold tops bottom) + (-> (List Code) Code Code) + (L/fold (function [top bottom] + (` [(~ bottom) (~ top)])) + bottom + tops)) + +(def: (singleton expander) + (-> (Lux (List Code)) (Lux Code)) + (monad;do Monad + [expansion expander] + (case expansion + (#;Cons singleton #;Nil) + (wrap singleton) + + _ + (macro;fail (format "Cannot expand to more than a single AST/Code node:\n" + (|> expansion (L/map %code) (text;join-with " "))))))) + +(syntax: #export (=> [aliases aliases^] + [inputs stack^] + [outputs stack^]) + (let [de-alias (function [aliased] + (L/fold (function [[from to] pre] + (code;replace (code;local-symbol from) to pre)) + aliased + aliases))] + (case [(|> inputs (get@ #bottom) (m/map (|>. code;nat (~) #;Bound (`)))) + (|> outputs (get@ #bottom) (m/map (|>. code;nat (~) #;Bound (`))))] + [(#;Some bottomI) (#;Some bottomO)] + (monad;do @ + [inputC (singleton (macro;expand-all (stack-fold (get@ #top inputs) bottomI))) + outputC (singleton (macro;expand-all (stack-fold (get@ #top outputs) bottomO)))] + (wrap (list (` (-> (~ (de-alias inputC)) + (~ (de-alias outputC))))))) + + [?bottomI ?bottomO] + (with-gensyms [g!stack] + (monad;do @ + [inputC (singleton (macro;expand-all (stack-fold (get@ #top inputs) (default g!stack ?bottomI)))) + outputC (singleton (macro;expand-all (stack-fold (get@ #top outputs) (default g!stack ?bottomO))))] + (wrap (list (` (All [(~ g!stack)] + (-> (~ (de-alias inputC)) + (~ (de-alias outputC)))))))))))) + +(def: #hidden begin! Unit []) + +(def: #hidden end! + (All [a] (-> [Unit a] a)) + (function [[_ top]] + top)) + +(def: (prepare command) + (-> Code Code) + (case command + (^or [_ (#;Bool _)] + [_ (#;Nat _)] [_ (#;Int _)] + [_ (#;Deg _)] [_ (#;Real _)] + [_ (#;Text _)] + [_ (#;Tag _)] (^ [_ (#;Form (list [_ (#;Tag _)]))])) + (` (;;push (~ command))) + + [_ (#;Tuple block)] + (` (;;push (|>. (~@ (L/map prepare block))))) + + _ + command)) + +(syntax: #export (||> [commands (p;some s;any)]) + (wrap (list (` (|> ;;begin! (~@ (L/map prepare commands)) ;;end!))))) + +(syntax: #export (word: [export csr;export] [name s;local-symbol] + [annotations (p;default cs;empty-annotations csr;annotations)] + type + [commands (p;some s;any)]) + (wrap (list (` (def: (~@ (csw;export export)) (~ (code;local-symbol name)) + (~ (csw;annotations annotations)) + (~ type) + (|>. (~@ (L/map prepare commands)))))))) + +(syntax: #export (apply [arity (|> s;nat (p;filter (;n.> +0)))]) + (with-gensyms [g!func g!stack g!output] + (monad;do @ + [g!inputs (|> (macro;gensym "input") (list;repeat arity) (monad;seq @))] + (wrap (list (` (: (All [(~@ g!inputs) (~ g!output)] + (-> (-> (~@ g!inputs) (~ g!output)) + (=> [(~@ g!inputs)] [(~ g!output)]))) + (function [(~ g!func)] + (function [(~ (stack-fold g!inputs g!stack))] + [(~ g!stack) ((~ g!func) (~@ g!inputs))]))))))))) + +## [Primitives] +(def: #export apply1 (apply +1)) +(def: #export apply2 (apply +2)) +(def: #export apply3 (apply +3)) +(def: #export apply4 (apply +4)) +(def: #export apply5 (apply +5)) +(def: #export apply6 (apply +6)) +(def: #export apply7 (apply +7)) +(def: #export apply8 (apply +8)) + +(def: #export (push x) + (All [a] (-> a (=> [] [a]))) + (function [stack] + [stack x])) + +(def: #export drop + (All [t] (=> [t] [])) + (function [[stack top]] + stack)) + +(def: #export nip + (All [_ a] (=> [_ a] [a])) + (function [[[stack _] top]] + [stack top])) + +(def: #export dup + (All [a] (=> [a] [a a])) + (function [[stack top]] + [[stack top] top])) + +(def: #export swap + (All [a b] (=> [a b] [b a])) + (function [[[stack l] r]] + [[stack r] l])) + +(def: #export rotL + (All [a b c] (=> [a b c] [b c a])) + (function [[[[stack a] b] c]] + [[[stack b] c] a])) + +(def: #export rotR + (All [a b c] (=> [a b c] [c a b])) + (function [[[[stack a] b] c]] + [[[stack c] a] b])) + +(def: #export && + (All [a b] (=> [a b] [(& a b)])) + (function [[[stack l] r]] + [stack [l r]])) + +(def: #export ||L + (All [a b] (=> [a] [(| a b)])) + (function [[stack l]] + [stack (+0 l)])) + +(def: #export ||R + (All [a b] (=> [b] [(| a b)])) + (function [[stack r]] + [stack (+1 r)])) + +(do-template [ ] + [(def: #export + (=> [ ] []) + (function [[[stack subject] param]] + [stack ( param subject)]))] + + [Nat Nat n.+ ;n.+] + [Nat Nat n.- ;n.-] + [Nat Nat n.* ;n.*] + [Nat Nat n./ ;n./] + [Nat Nat n.% ;n.%] + [Nat Bool n.= ;n.=] + [Nat Bool n.< ;n.<] + [Nat Bool n.<= ;n.<=] + [Nat Bool n.> ;n.>] + [Nat Bool n.>= ;n.>=] + + [Int Int i.+ ;i.+] + [Int Int i.- ;i.-] + [Int Int i.* ;i.*] + [Int Int i./ ;i./] + [Int Int i.% ;i.%] + [Int Bool i.= ;i.=] + [Int Bool i.< ;i.<] + [Int Bool i.<= ;i.<=] + [Int Bool i.> ;i.>] + [Int Bool i.>= ;i.>=] + + [Deg Deg d.+ ;d.+] + [Deg Deg d.- ;d.-] + [Deg Deg d.* ;d.*] + [Deg Deg d./ ;d./] + [Deg Deg d.% ;d.%] + [Deg Bool d.= ;d.=] + [Deg Bool d.< ;d.<] + [Deg Bool d.<= ;d.<=] + [Deg Bool d.> ;d.>] + [Deg Bool d.>= ;d.>=] + + [Real Real r.+ ;r.+] + [Real Real r.- ;r.-] + [Real Real r.* ;r.*] + [Real Real r./ ;r./] + [Real Real r.% ;r.%] + [Real Bool r.= ;r.=] + [Real Bool r.< ;r.<] + [Real Bool r.<= ;r.<=] + [Real Bool r.> ;r.>] + [Real Bool r.>= ;r.>=] + ) + +(def: #export if + (All [..a ..b] + (=> {then (=> ..a ..b) + else (=> ..a ..b)} + ..a [Bool then else] ..b)) + (function [[[[stack test] then] else]] + (;if test + (then stack) + (else stack)))) + +(def: #export call + (All [..a ..b] + (=> {quote (=> ..a ..b)} + ..a [quote] ..b)) + (function [[stack block]] + (block stack))) + +(def: #export loop + (All [...] + (=> {test (=> ... ... [Bool])} + ... [test] ...)) + (function loop [[stack pred]] + (let [[stack' verdict] (pred stack)] + (;if verdict + (loop [stack' pred]) + stack')))) + +(def: #export dip + (All [... a] + (=> ... [a (=> ... ...)] + ... [a])) + (function [[[stack a] quote]] + [(quote stack) a])) + +(def: #export dip2 + (All [... a b] + (=> ... [a b (=> ... ...)] + ... [a b])) + (function [[[[stack a] b] quote]] + [[(quote stack) a] b])) + +(def: #export do + (All [..a ..b] + (=> {pred (=> ..a ..b [Bool]) + body (=> ..b ..a)} + ..b [pred body] + ..a [pred body])) + (function [[[stack pred] body]] + [[(body stack) pred] body])) + +(def: #export while + (All [..a ..b] + (=> {pred (=> ..a ..b [Bool]) + body (=> ..b ..a)} + ..a [pred body] + ..b)) + (function while [[[stack pred] body]] + (let [[stack' verdict] (pred stack)] + (;if verdict + (while [[(body stack') pred] body]) + stack')))) + +(def: #export compose + (All [..a ..b ..c] + (=> [(=> ..a ..b) (=> ..b ..c)] + [(=> ..a ..c)])) + (function [[[stack f] g]] + [stack (|>. f g)])) + +(def: #export curry + (All [..a ..b a] + (=> ..a [a (=> ..a [a] ..b)] + ..a [(=> ..a ..b)])) + (function [[[stack arg] quote]] + [stack (|>. (push arg) quote)])) + +## [Words] +(word: #export when + (All [...] + (=> {body (=> ... ...)} + ... [Bool body] + ...)) + swap [call] [drop] if) + +(word: #export ? + (All [a] + (=> [Bool a a] [a])) + rotL [drop] [nip] if) diff --git a/stdlib/source/lux/paradigm/concatenative.lux b/stdlib/source/lux/paradigm/concatenative.lux deleted file mode 100644 index a0854ffcf..000000000 --- a/stdlib/source/lux/paradigm/concatenative.lux +++ /dev/null @@ -1,333 +0,0 @@ -(;module: [lux #- if loop - n.+ n.- n.* n./ n.% n.= n.< n.<= n.> n.>= - i.+ i.- i.* i./ i.% i.= i.< i.<= i.> i.>= - d.+ d.- d.* d./ d.% d.= d.< d.<= d.> d.>= - r.+ r.- r.* r./ r.% r.= r.< r.<= r.> r.>=] - (lux (control ["p" parser "p/" Monad] - [monad]) - (data [text] - text/format - [maybe "m/" Monad] - (coll [list "L/" Fold Functor])) - [macro #+ with-gensyms Monad] - (macro [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))))) - -## [Syntax] -(type: Alias [Text Code]) - -(type: Stack - {#bottom (Maybe Nat) - #top (List Code)}) - -(def: aliases^ - (s;Syntax (List Alias)) - (|> (p;seq s;local-symbol s;any) - p;some - s;record - (p;default (list)))) - -(def: bottom^ - (s;Syntax Nat) - (s;form (p;after (s;this (` #;Bound)) s;nat))) - -(def: stack^ - (s;Syntax Stack) - (p;either (p;seq (p;opt bottom^) - (s;tuple (p;some s;any))) - (p;seq (|> bottom^ (p/map (|>. #;Some))) - (p/wrap (list))))) - -(def: (stack-fold tops bottom) - (-> (List Code) Code Code) - (L/fold (function [top bottom] - (` [(~ bottom) (~ top)])) - bottom - tops)) - -(def: (singleton expander) - (-> (Lux (List Code)) (Lux Code)) - (monad;do Monad - [expansion expander] - (case expansion - (#;Cons singleton #;Nil) - (wrap singleton) - - _ - (macro;fail (format "Cannot expand to more than a single AST/Code node:\n" - (|> expansion (L/map %code) (text;join-with " "))))))) - -(syntax: #export (=> [aliases aliases^] - [inputs stack^] - [outputs stack^]) - (let [de-alias (function [aliased] - (L/fold (function [[from to] pre] - (code;replace (code;local-symbol from) to pre)) - aliased - aliases))] - (case [(|> inputs (get@ #bottom) (m/map (|>. code;nat (~) #;Bound (`)))) - (|> outputs (get@ #bottom) (m/map (|>. code;nat (~) #;Bound (`))))] - [(#;Some bottomI) (#;Some bottomO)] - (monad;do @ - [inputC (singleton (macro;expand-all (stack-fold (get@ #top inputs) bottomI))) - outputC (singleton (macro;expand-all (stack-fold (get@ #top outputs) bottomO)))] - (wrap (list (` (-> (~ (de-alias inputC)) - (~ (de-alias outputC))))))) - - [?bottomI ?bottomO] - (with-gensyms [g!stack] - (monad;do @ - [inputC (singleton (macro;expand-all (stack-fold (get@ #top inputs) (default g!stack ?bottomI)))) - outputC (singleton (macro;expand-all (stack-fold (get@ #top outputs) (default g!stack ?bottomO))))] - (wrap (list (` (All [(~ g!stack)] - (-> (~ (de-alias inputC)) - (~ (de-alias outputC)))))))))))) - -(def: #hidden begin! Unit []) - -(def: #hidden end! - (All [a] (-> [Unit a] a)) - (function [[_ top]] - top)) - -(def: (prepare command) - (-> Code Code) - (case command - (^or [_ (#;Bool _)] - [_ (#;Nat _)] [_ (#;Int _)] - [_ (#;Deg _)] [_ (#;Real _)] - [_ (#;Text _)] - [_ (#;Tag _)] (^ [_ (#;Form (list [_ (#;Tag _)]))])) - (` (;;push (~ command))) - - [_ (#;Tuple block)] - (` (;;push (|>. (~@ (L/map prepare block))))) - - _ - command)) - -(syntax: #export (||> [commands (p;some s;any)]) - (wrap (list (` (|> ;;begin! (~@ (L/map prepare commands)) ;;end!))))) - -(syntax: #export (word: [export csr;export] [name s;local-symbol] - [annotations (p;default cs;empty-annotations csr;annotations)] - type - [commands (p;some s;any)]) - (wrap (list (` (def: (~@ (csw;export export)) (~ (code;local-symbol name)) - (~ (csw;annotations annotations)) - (~ type) - (|>. (~@ (L/map prepare commands)))))))) - -(syntax: #export (apply [arity (|> s;nat (p;filter (;n.> +0)))]) - (with-gensyms [g!func g!stack g!output] - (monad;do @ - [g!inputs (|> (macro;gensym "input") (list;repeat arity) (monad;seq @))] - (wrap (list (` (: (All [(~@ g!inputs) (~ g!output)] - (-> (-> (~@ g!inputs) (~ g!output)) - (=> [(~@ g!inputs)] [(~ g!output)]))) - (function [(~ g!func)] - (function [(~ (stack-fold g!inputs g!stack))] - [(~ g!stack) ((~ g!func) (~@ g!inputs))]))))))))) - -## [Primitives] -(def: #export apply1 (apply +1)) -(def: #export apply2 (apply +2)) -(def: #export apply3 (apply +3)) -(def: #export apply4 (apply +4)) -(def: #export apply5 (apply +5)) -(def: #export apply6 (apply +6)) -(def: #export apply7 (apply +7)) -(def: #export apply8 (apply +8)) - -(def: #export (push x) - (All [a] (-> a (=> [] [a]))) - (function [stack] - [stack x])) - -(def: #export drop - (All [t] (=> [t] [])) - (function [[stack top]] - stack)) - -(def: #export nip - (All [_ a] (=> [_ a] [a])) - (function [[[stack _] top]] - [stack top])) - -(def: #export dup - (All [a] (=> [a] [a a])) - (function [[stack top]] - [[stack top] top])) - -(def: #export swap - (All [a b] (=> [a b] [b a])) - (function [[[stack l] r]] - [[stack r] l])) - -(def: #export rotL - (All [a b c] (=> [a b c] [b c a])) - (function [[[[stack a] b] c]] - [[[stack b] c] a])) - -(def: #export rotR - (All [a b c] (=> [a b c] [c a b])) - (function [[[[stack a] b] c]] - [[[stack c] a] b])) - -(def: #export && - (All [a b] (=> [a b] [(& a b)])) - (function [[[stack l] r]] - [stack [l r]])) - -(def: #export ||L - (All [a b] (=> [a] [(| a b)])) - (function [[stack l]] - [stack (+0 l)])) - -(def: #export ||R - (All [a b] (=> [b] [(| a b)])) - (function [[stack r]] - [stack (+1 r)])) - -(do-template [ ] - [(def: #export - (=> [ ] []) - (function [[[stack subject] param]] - [stack ( param subject)]))] - - [Nat Nat n.+ ;n.+] - [Nat Nat n.- ;n.-] - [Nat Nat n.* ;n.*] - [Nat Nat n./ ;n./] - [Nat Nat n.% ;n.%] - [Nat Bool n.= ;n.=] - [Nat Bool n.< ;n.<] - [Nat Bool n.<= ;n.<=] - [Nat Bool n.> ;n.>] - [Nat Bool n.>= ;n.>=] - - [Int Int i.+ ;i.+] - [Int Int i.- ;i.-] - [Int Int i.* ;i.*] - [Int Int i./ ;i./] - [Int Int i.% ;i.%] - [Int Bool i.= ;i.=] - [Int Bool i.< ;i.<] - [Int Bool i.<= ;i.<=] - [Int Bool i.> ;i.>] - [Int Bool i.>= ;i.>=] - - [Deg Deg d.+ ;d.+] - [Deg Deg d.- ;d.-] - [Deg Deg d.* ;d.*] - [Deg Deg d./ ;d./] - [Deg Deg d.% ;d.%] - [Deg Bool d.= ;d.=] - [Deg Bool d.< ;d.<] - [Deg Bool d.<= ;d.<=] - [Deg Bool d.> ;d.>] - [Deg Bool d.>= ;d.>=] - - [Real Real r.+ ;r.+] - [Real Real r.- ;r.-] - [Real Real r.* ;r.*] - [Real Real r./ ;r./] - [Real Real r.% ;r.%] - [Real Bool r.= ;r.=] - [Real Bool r.< ;r.<] - [Real Bool r.<= ;r.<=] - [Real Bool r.> ;r.>] - [Real Bool r.>= ;r.>=] - ) - -(def: #export if - (All [..a ..b] - (=> {then (=> ..a ..b) - else (=> ..a ..b)} - ..a [Bool then else] ..b)) - (function [[[[stack test] then] else]] - (;if test - (then stack) - (else stack)))) - -(def: #export call - (All [..a ..b] - (=> {quote (=> ..a ..b)} - ..a [quote] ..b)) - (function [[stack block]] - (block stack))) - -(def: #export loop - (All [...] - (=> {test (=> ... ... [Bool])} - ... [test] ...)) - (function loop [[stack pred]] - (let [[stack' verdict] (pred stack)] - (;if verdict - (loop [stack' pred]) - stack')))) - -(def: #export dip - (All [... a] - (=> ... [a (=> ... ...)] - ... [a])) - (function [[[stack a] quote]] - [(quote stack) a])) - -(def: #export dip2 - (All [... a b] - (=> ... [a b (=> ... ...)] - ... [a b])) - (function [[[[stack a] b] quote]] - [[(quote stack) a] b])) - -(def: #export do - (All [..a ..b] - (=> {pred (=> ..a ..b [Bool]) - body (=> ..b ..a)} - ..b [pred body] - ..a [pred body])) - (function [[[stack pred] body]] - [[(body stack) pred] body])) - -(def: #export while - (All [..a ..b] - (=> {pred (=> ..a ..b [Bool]) - body (=> ..b ..a)} - ..a [pred body] - ..b)) - (function while [[[stack pred] body]] - (let [[stack' verdict] (pred stack)] - (;if verdict - (while [[(body stack') pred] body]) - stack')))) - -(def: #export compose - (All [..a ..b ..c] - (=> [(=> ..a ..b) (=> ..b ..c)] - [(=> ..a ..c)])) - (function [[[stack f] g]] - [stack (|>. f g)])) - -(def: #export curry - (All [..a ..b a] - (=> ..a [a (=> ..a [a] ..b)] - ..a [(=> ..a ..b)])) - (function [[[stack arg] quote]] - [stack (|>. (push arg) quote)])) - -## [Words] -(word: #export when - (All [...] - (=> {body (=> ... ...)} - ... [Bool body] - ...)) - swap [call] [drop] if) - -(word: #export ? - (All [a] - (=> [Bool a a] [a])) - rotL [drop] [nip] if) diff --git a/stdlib/source/lux/paradigm/object.lux b/stdlib/source/lux/paradigm/object.lux deleted file mode 100644 index c7cdcb4d3..000000000 --- a/stdlib/source/lux/paradigm/object.lux +++ /dev/null @@ -1,514 +0,0 @@ -(;module: - lux - (lux (control ["M" monad #+ do Monad] - ["p" parser "p/" Monad]) - (data [text] - text/format - [product] - maybe - [ident #+ "Ident/" Eq] - (coll [list "L/" Functor Fold Monoid] - [set #+ Set])) - [macro #+ Monad "Lux/" Monad] - (macro [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))) - [type])) - -## [Common] -(type: Declaration - [Text (List Text)]) - -(type: Alias Text) - -(def: default-alias Alias "@") - -(def: (var-set vars) - (-> (List Text) (Set Text)) - (set;from-list text;Hash vars)) - -(def: (unique-type-vars parser) - (-> (s;Syntax (List Text)) (s;Syntax (List Text))) - (do p;Monad - [raw parser - _ (p;assert "Cannot repeat the names of type variables/parameters." - (n.= (set;size (var-set raw)) - (list;size raw)))] - (wrap raw))) - -(def: (safe-type-vars exclusions) - (-> (Set Text) (s;Syntax Text)) - (do p;Monad - [raw s;local-symbol - _ (p;assert "Cannot re-use names between method type-variables and interface type-parameters." - (|> raw (set;member? exclusions) not))] - (wrap raw))) - -(def: declarationS - (s;Syntax Declaration) - (p;either (s;form (p;seq s;local-symbol - (unique-type-vars (p;some s;local-symbol)))) - (p;seq s;local-symbol - (p/wrap (list))))) - -(def: aliasS - (s;Syntax Alias) - (|> s;local-symbol - (p;after (s;this (' #as))) - (p;default default-alias))) - -(def: (ancestor-inputs ancestors) - (-> (List Ident) (List Code)) - (if (list;empty? ancestors) - (list) - (|> (list;size ancestors) - n.dec - (list;n.range +0) - (L/map (|>. %n (format "ancestor") code;local-symbol))))) - -## [Methods] -(type: Method - {#type-vars (List Text) - #name Text - #inputs (List Code) - #output Code}) - -(def: (method exclusions) - (-> (Set Text) (s;Syntax Method)) - (s;form ($_ p;seq - (p;either (unique-type-vars (s;tuple (p;some (safe-type-vars exclusions)))) - (p/wrap (list))) - s;local-symbol - (s;tuple (p;some s;any)) - s;any))) - -(def: (declarationM g!self (^open)) - (-> Code Method Code) - (let [g!type-vars (L/map code;local-symbol type-vars) - g!method (code;local-symbol name)] - (` (: (All [(~@ g!type-vars)] - (-> (~@ inputs) (~ g!self) (~ output))) - (~ g!method))))) - -(def: (definition export [interface parameters] g!self-object g!ext g!states (^open)) - (-> (Maybe cs;Export) Declaration Code Code (List Code) Method Code) - (let [g!method (code;local-symbol name) - g!parameters (L/map code;local-symbol parameters) - g!type-vars (L/map code;local-symbol type-vars) - g!_temp (code;symbol ["" "_temp"]) - g!_object (code;symbol ["" "_object"]) - g!_behavior (code;symbol ["" "_behavior"]) - g!_state (code;symbol ["" "_state"]) - g!_extension (code;symbol ["" "_extension"]) - g!_args (L/map (|>. product;left nat-to-int %i (format "_") code;local-symbol) - (list;enumerate inputs)) - g!destructuring (L/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)])) - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]) - (default g!states (list;tail g!states)))] - (` (def: (~@ (csw;export export)) ((~ g!method) (~@ g!_args) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!states) (~@ g!type-vars)] - (-> (~@ inputs) (~ g!self-object) (~ output))) - (let [(~ g!destructuring) (~ g!_object)] - (:: (~ g!_behavior) (~ g!method) (~@ g!_args) (~ g!_object))))))) - -## [Inheritance] -(type: Reference - [Ident (List Code)]) - -(def: no-parent Ident ["" ""]) - -(def: (no-parent? parent) - (-> Ident Bool) - (Ident/= no-parent parent)) - -(def: (with-interface parent interface) - (-> Ident Ident cs;Annotations cs;Annotations) - (|>. (#;Cons [(ident-for #;;interface-name) - (code;tag interface)]) - (#;Cons [(ident-for #;;interface-parent) - (code;tag parent)]))) - -(def: (with-class interface parent class) - (-> Ident Ident Ident cs;Annotations cs;Annotations) - (|>. (#;Cons [(ident-for #;;class-interface) - (code;tag interface)]) - (#;Cons [(ident-for #;;class-parent) - (code;tag parent)]) - (#;Cons [(ident-for #;;class-name) - (code;tag class)]))) - -(do-template [ ] - [(def: ( name) - (-> Ident (Lux [Ident (List Ident)])) - (do Monad - [name (macro;normalize name) - [_ annotations _] (macro;find-def name)] - (case [(macro;get-ident-ann (ident-for ) annotations) - (macro;get-ident-ann (ident-for ) annotations)] - [(#;Some real-name) (#;Some parent)] - (if (Ident/= no-parent parent) - (wrap [real-name (list)]) - (do @ - [[_ ancestors] ( parent)] - (wrap [real-name (#;Cons parent ancestors)]))) - - _ - (macro;fail (format "Wrong format for " " lineage.")))))] - - [interfaceN #;;interface-name #;;interface-parent "interface"] - [classN #;;class-name #;;class-parent "class"] - ) - -(def: (extract newT) - (-> Type (Lux [Nat (List Type)])) - (loop [depth +0 - currentT newT] - (case currentT - (#;UnivQ _ bodyT) - (recur (n.inc depth) bodyT) - - (#;Function inputT outputT) - (let [[stateT+ objectT] (type;flatten-function currentT)] - (Lux/wrap [depth stateT+])) - - _ - (macro;fail (format "Cannot extract inheritance from type: " (type;to-text newT)))))) - -(def: (specialize mappings typeC) - (-> (List Code) Code Code) - (case (list;size mappings) - +0 - typeC - - size - (|> (n.dec size) - (list;n.range +0) - (L/map (|>. (n.* +2) n.inc code;nat (~) #;Bound (`))) - (list;zip2 (list;reverse mappings)) - (L/fold (function [[mappingC boundC] genericC] - (code;replace boundC mappingC genericC)) - typeC)))) - -(def: referenceS - (s;Syntax Reference) - (p;either (s;form (p;seq s;symbol - (p;some s;any))) - (p;seq s;symbol - (p/wrap (list))))) - -(do-template [ ] - [(def: - (s;Syntax Reference) - (|> referenceS - (p;after (s;this (' )))))] - - [extension #super] - [inheritance #super] - ) - -## [Notation] -## Utils -(def: (nest ancestors bottom) - (-> (List Code) Code Code) - (L/fold (function [[level _] g!bottom] - (let [g!_behavior' (code;local-symbol (format "_behavior" (%n level))) - g!_state' (code;local-symbol (format "_state" (%n level)))] - (` [(~ g!_behavior') (~ g!_state') (~ g!bottom)]))) - bottom - (list;enumerate ancestors))) - -## Names -(do-template [ ] - [(def: ( base) - (-> Text Text) - (|> base (format "@")))] - - [newN "new"] - [getN "get"] - [setN "set"] - [updateN "update"] - ) - -(do-template [ ] - [(def: ( raw) - (-> Text Text) - (format raw "//OOP:" ))] - - [signatureN "Signature"] - [stateN "State"] - [structN "Struct"] - ) - -(def: (getterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) - Code) - (let [g!get (code;local-symbol (getN interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) - g!tear-down (nest g!ancestors - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))] - (` (def: (~@ (csw;export export)) ((~ g!get) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] - (-> (~ g!object) (~ g!child))) - (let [(~ g!tear-down) (~ g!_object)] - (~ g!_state)))))) - -(def: (setterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) - Code) - (let [g!set (code;local-symbol (setN interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!_input (' _input) - g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) - g!tear-down (nest g!ancestors - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) - g!build-up (nest g!ancestors - (` [(~ g!_behavior) (~ g!_input) (~ g!_extension)]))] - (` (def: (~@ (csw;export export)) - ((~ g!set) (~ g!_input) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] - (-> (~ g!child) (~ g!object) (~ g!object))) - (let [(~ g!tear-down) (~ g!_object)] - (~ g!build-up)))))) - -(def: (updaterN export interface g!parameters g!ext g!child ancestors) - (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) - Code) - (let [g!update (code;local-symbol (updateN interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!_change (' _change) - g!ancestors (ancestor-inputs ancestors) - g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) - g!tear-down (nest g!ancestors - (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) - g!build-up (nest g!ancestors - (` [(~ g!_behavior) ((~ g!_change) (~ g!_state)) (~ g!_extension)]))] - (` (def: (~@ (csw;export export)) - ((~ g!update) (~ g!_change) (~ g!_object)) - (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] - (-> (-> (~ g!child) (~ g!child)) - (-> (~ g!object) (~ g!object)))) - (let [(~ g!tear-down) (~ g!_object)] - (~ g!build-up)))))) - -## [Macros] -(def: (type-to-code type) - (-> Type (Lux Code)) - (case type - (#;Host name params) - (do Monad - [paramsC+ (M;map @ type-to-code params)] - (wrap (` (;host (~ (code;symbol ["" name])) - (~@ paramsC+))))) - - #;Void - (Lux/wrap (` (;|))) - - #;Unit - (Lux/wrap (` (;&))) - - (^template [ ] - ( _) - (do Monad - [partsC+ (M;map @ type-to-code ( type))] - (wrap (` ( (~@ partsC+)))))) - ([#;Sum ;| type;flatten-variant] - [#;Product ;& type;flatten-tuple]) - - (#;Function input output) - (do Monad - [#let [[insT+ outT] (type;flatten-function type)] - insC+ (M;map @ type-to-code insT+) - outC (type-to-code outT)] - (wrap (` (;-> (~@ insC+) (~ outC))))) - - (^template [] - ( idx) - (Lux/wrap (` ( (~ (code;nat idx)))))) - ([#;Bound] - [#;Var] - [#;Ex]) - - (#;Apply param fun) - (do Monad - [#let [[funcT argsT+] (type;flatten-application type)] - funcC (type-to-code funcT) - argsC+ (M;map @ type-to-code argsT+)] - (wrap (` ((~ funcC) (~@ argsC+))))) - - (#;Named name unnamedT) - (Lux/wrap (code;symbol name)) - - _ - (macro;fail (format "Cannot convert type to code: " (type;to-text type))))) - -(syntax: #export (interface: [export csr;export] - [(^@ decl [interface parameters]) declarationS] - [?extends (p;opt extension)] - [alias aliasS] - [annotations (p;default cs;empty-annotations csr;annotations)] - [methods (p;many (method (var-set parameters)))]) - (macro;with-gensyms [g!self-class g!child g!ext] - (do @ - [module macro;current-module-name - [parent ancestors mappings] (: (Lux [Ident (List Ident) (List Code)]) - (case ?extends - #;None - (wrap [no-parent (list) (list)]) - - (#;Some [super mappings]) - (do @ - [[parent ancestors] (interfaceN super)] - (wrap [parent (list& parent ancestors) mappings])))) - #let [g!signature (code;local-symbol (signatureN interface)) - g!interface (code;local-symbol interface) - g!parameters (L/map code;local-symbol parameters) - g!self-ref (if (list;empty? g!parameters) - (list g!interface) - (list)) - g!interface-def (if (no-parent? parent) - (let [g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~ g!child)))] - (` (Ex (~@ g!self-ref) [(~ g!ext) (~ g!child)] - [((~ g!signature) (~@ g!parameters) (~ g!recur)) - (~ g!child) - (~ g!ext)]))) - (let [g!parent (code;symbol parent) - g!ancestors (ancestor-inputs ancestors) - g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))] - (` (Ex (~@ g!self-ref) [(~ g!ext) (~@ g!ancestors) (~ g!child)] - ((~ g!parent) (~@ mappings) - [((~ g!signature) (~@ g!parameters) (~ g!recur)) - (~ g!child) - (~ g!ext)] - (~@ g!ancestors))))))]] - (wrap (list& (` (sig: (~@ (csw;export export)) - ((~ g!signature) (~@ g!parameters) (~ g!self-class)) - (~@ (let [de-alias (code;replace (code;local-symbol alias) g!self-class)] - (L/map (|>. (update@ #inputs (L/map de-alias)) - (update@ #output de-alias) - (declarationM g!self-class)) - methods))))) - - (` (type: (~@ (csw;export export)) ((~ g!interface) (~@ g!parameters)) - (~ (|> annotations - (with-interface parent [module interface]) - csw;annotations)) - (~ g!interface-def))) - - (getterN export interface g!parameters g!ext g!child ancestors) - (setterN export interface g!parameters g!ext g!child ancestors) - (updaterN export interface g!parameters g!ext g!child ancestors) - - (let [g!ancestors (ancestor-inputs ancestors) - g!states (L/append g!ancestors (list g!child)) - g!self-object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) - de-alias (code;replace (code;symbol ["" alias]) g!self-object)] - (L/map (|>. (update@ #inputs (L/map de-alias)) - (update@ #output de-alias) - (definition export decl g!self-object g!ext g!states)) - methods)))) - ))) - -(syntax: #export (class: [export csr;export] - [[instance parameters] declarationS] - [annotations (p;default cs;empty-annotations csr;annotations)] - [[interface interface-mappings] referenceS] - [super (p;opt inheritance)] - state-type - [impls (p;many s;any)]) - (macro;with-gensyms [g!init g!extension] - (do @ - [module macro;current-module-name - [interface _] (interfaceN interface) - [parent ancestors parent-mappings] (: (Lux [Ident (List Ident) (List Code)]) - (case super - (#;Some [super-class super-mappings]) - (do @ - [[parent ancestors] (classN super-class)] - (wrap [parent ancestors super-mappings])) - - #;None - (wrap [no-parent (list) (list)]))) - g!inheritance (: (Lux (List Code)) - (if (no-parent? parent) - (wrap (list)) - (do @ - [newT (macro;find-def-type (product;both id newN parent)) - [depth rawT+] (extract newT) - codeT+ (M;map @ type-to-code rawT+)] - (wrap (L/map (specialize parent-mappings) codeT+))))) - #let [g!parameters (L/map code;local-symbol parameters) - - g!state (code;local-symbol (stateN instance)) - g!struct (code;local-symbol (structN instance)) - g!class (code;local-symbol instance) - - g!signature (code;symbol (product;both id signatureN interface)) - g!interface (code;symbol interface) - - g!parent-structs (if (no-parent? parent) - (list) - (L/map (|>. (product;both id structN) code;symbol) (list& parent ancestors)))] - g!parent-inits (M;map @ (function [_] (macro;gensym "parent-init")) - g!parent-structs) - #let [g!full-init (L/fold (function [[parent-struct parent-state] child] - (` [(~ parent-struct) (~ parent-state) (~ child)])) - (` [(~ g!struct) (~ g!init) []]) - (list;zip2 g!parent-structs g!parent-inits)) - g!new (code;local-symbol (newN instance)) - g!recur (` ((~ g!class) (~@ g!parameters) (~ g!extension))) - g!rec (if (list;empty? g!parameters) - (list (' #rec)) - (list))]] - (wrap (list (` (type: (~@ (csw;export export)) - ((~ g!state) (~@ g!parameters)) - (~ state-type))) - - (` (type: (~@ (csw;export export)) (~@ g!rec) ((~ g!class) (~@ g!parameters)) - (~ (|> annotations - (with-class interface parent [module instance]) - csw;annotations)) - (Ex [(~ g!extension)] - (~ (if (no-parent? parent) - (` ((~ g!interface) (~@ interface-mappings) - (~ g!extension) - ((~ g!state) (~@ g!parameters)))) - (let [g!parent (code;symbol parent)] - (` ((~ g!parent) (~@ parent-mappings) - [((~ g!signature) (~@ interface-mappings) (~ g!recur)) - ((~ g!state) (~@ g!parameters)) - (~ g!extension)])))))))) - - (` (struct: (~@ (csw;export export)) (~ g!struct) - (All [(~@ g!parameters) (~ g!extension)] - ((~ g!signature) (~@ interface-mappings) - ((~ g!interface) (~@ interface-mappings) - (~ g!extension) - (~@ g!inheritance) - ((~ g!state) (~@ g!parameters))))) - (~@ impls))) - - (` (def: (~@ (csw;export export)) ((~ g!new) (~@ g!parent-inits) (~ g!init)) - (All [(~@ g!parameters)] - (-> (~@ g!inheritance) - ((~ g!state) (~@ g!parameters)) - ((~ g!class) (~@ g!parameters)))) - (~ g!full-init))) - )) - ))) diff --git a/stdlib/source/lux/type/object.lux b/stdlib/source/lux/type/object.lux new file mode 100644 index 000000000..961be9b03 --- /dev/null +++ b/stdlib/source/lux/type/object.lux @@ -0,0 +1,515 @@ +(;module: + lux + (lux (control ["M" monad #+ do Monad] + ["p" parser "p/" Monad]) + (data [text] + text/format + [product] + maybe + [ident #+ "Ident/" Eq] + (coll [list "L/" Functor Fold Monoid] + [set #+ Set])) + [macro #+ Monad "Lux/" Monad] + (macro [code] + ["s" syntax #+ syntax:] + (syntax ["cs" common] + (common ["csr" reader] + ["csw" writer]))) + [type])) + +## [Common] +(type: Declaration + [Text (List Text)]) + +(type: Alias Text) + +(def: default-alias Alias "@") + +(def: (var-set vars) + (-> (List Text) (Set Text)) + (set;from-list text;Hash vars)) + +(def: (unique-type-vars parser) + (-> (s;Syntax (List Text)) (s;Syntax (List Text))) + (do p;Monad + [raw parser + _ (p;assert "Cannot repeat the names of type variables/parameters." + (n.= (set;size (var-set raw)) + (list;size raw)))] + (wrap raw))) + +(def: (safe-type-vars exclusions) + (-> (Set Text) (s;Syntax Text)) + (do p;Monad + [raw s;local-symbol + _ (p;assert "Cannot re-use names between method type-variables and interface type-parameters." + (|> raw (set;member? exclusions) not))] + (wrap raw))) + +(def: declarationS + (s;Syntax Declaration) + (p;either (s;form (p;seq s;local-symbol + (unique-type-vars (p;some s;local-symbol)))) + (p;seq s;local-symbol + (p/wrap (list))))) + +(def: aliasS + (s;Syntax Alias) + (|> s;local-symbol + (p;after (s;this (' #as))) + (p;default default-alias))) + +(def: (ancestor-inputs ancestors) + (-> (List Ident) (List Code)) + (if (list;empty? ancestors) + (list) + (|> (list;size ancestors) + n.dec + (list;n.range +0) + (L/map (|>. %n (format "ancestor") code;local-symbol))))) + +## [Methods] +(type: Method + {#type-vars (List Text) + #name Text + #inputs (List Code) + #output Code}) + +(def: (method exclusions) + (-> (Set Text) (s;Syntax Method)) + (s;form ($_ p;seq + (p;either (unique-type-vars (s;tuple (p;some (safe-type-vars exclusions)))) + (p/wrap (list))) + s;local-symbol + (s;tuple (p;some s;any)) + s;any))) + +(def: (declarationM g!self (^open)) + (-> Code Method Code) + (let [g!type-vars (L/map code;local-symbol type-vars) + g!method (code;local-symbol name)] + (` (: (All [(~@ g!type-vars)] + (-> (~@ inputs) (~ g!self) (~ output))) + (~ g!method))))) + +(def: (definition export [interface parameters] g!self-object g!ext g!states (^open)) + (-> (Maybe cs;Export) Declaration Code Code (List Code) Method Code) + (let [g!method (code;local-symbol name) + g!parameters (L/map code;local-symbol parameters) + g!type-vars (L/map code;local-symbol type-vars) + g!_temp (code;symbol ["" "_temp"]) + g!_object (code;symbol ["" "_object"]) + g!_behavior (code;symbol ["" "_behavior"]) + g!_state (code;symbol ["" "_state"]) + g!_extension (code;symbol ["" "_extension"]) + g!_args (L/map (|>. product;left nat-to-int %i (format "_") code;local-symbol) + (list;enumerate inputs)) + g!destructuring (L/fold (function [_ g!bottom] (` [(~ g!_temp) (~ g!_temp) (~ g!bottom)])) + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]) + (default g!states (list;tail g!states)))] + (` (def: (~@ (csw;export export)) ((~ g!method) (~@ g!_args) (~ g!_object)) + (All [(~@ g!parameters) (~ g!ext) (~@ g!states) (~@ g!type-vars)] + (-> (~@ inputs) (~ g!self-object) (~ output))) + (let [(~ g!destructuring) (~ g!_object)] + (:: (~ g!_behavior) (~ g!method) (~@ g!_args) (~ g!_object))))))) + +## [Inheritance] +(type: Reference + [Ident (List Code)]) + +(def: no-parent Ident ["" ""]) + +(def: (no-parent? parent) + (-> Ident Bool) + (Ident/= no-parent parent)) + +(def: (with-interface parent interface) + (-> Ident Ident cs;Annotations cs;Annotations) + (|>. (#;Cons [(ident-for #;;interface-name) + (code;tag interface)]) + (#;Cons [(ident-for #;;interface-parent) + (code;tag parent)]))) + +(def: (with-class interface parent class) + (-> Ident Ident Ident cs;Annotations cs;Annotations) + (|>. (#;Cons [(ident-for #;;class-interface) + (code;tag interface)]) + (#;Cons [(ident-for #;;class-parent) + (code;tag parent)]) + (#;Cons [(ident-for #;;class-name) + (code;tag class)]))) + +(do-template [ ] + [(def: ( name) + (-> Ident (Lux [Ident (List Ident)])) + (do Monad + [name (macro;normalize name) + [_ annotations _] (macro;find-def name)] + (case [(macro;get-ident-ann (ident-for ) annotations) + (macro;get-ident-ann (ident-for ) annotations)] + [(#;Some real-name) (#;Some parent)] + (if (Ident/= no-parent parent) + (wrap [real-name (list)]) + (do @ + [[_ ancestors] ( parent)] + (wrap [real-name (#;Cons parent ancestors)]))) + + _ + (macro;fail (format "Wrong format for " " lineage.")))))] + + [interfaceN #;;interface-name #;;interface-parent "interface"] + [classN #;;class-name #;;class-parent "class"] + ) + +(def: (extract newT) + (-> Type (Lux [Nat (List Type)])) + (loop [depth +0 + currentT newT] + (case currentT + (#;UnivQ _ bodyT) + (recur (n.inc depth) bodyT) + + (#;Function inputT outputT) + (let [[stateT+ objectT] (type;flatten-function currentT)] + (Lux/wrap [depth stateT+])) + + _ + (macro;fail (format "Cannot extract inheritance from type: " (type;to-text newT)))))) + +(def: (specialize mappings typeC) + (-> (List Code) Code Code) + (case (list;size mappings) + +0 + typeC + + size + (|> (n.dec size) + (list;n.range +0) + (L/map (|>. (n.* +2) n.inc code;nat (~) #;Bound (`))) + (list;zip2 (list;reverse mappings)) + (L/fold (function [[mappingC boundC] genericC] + (code;replace boundC mappingC genericC)) + typeC)))) + +(def: referenceS + (s;Syntax Reference) + (p;either (s;form (p;seq s;symbol + (p;some s;any))) + (p;seq s;symbol + (p/wrap (list))))) + +(do-template [ ] + [(def: + (s;Syntax Reference) + (|> referenceS + (p;after (s;this (' )))))] + + [extension #super] + [inheritance #super] + ) + +## [Notation] +## Utils +(def: (nest ancestors bottom) + (-> (List Code) Code Code) + (L/fold (function [[level _] g!bottom] + (let [g!_behavior' (code;local-symbol (format "_behavior" (%n level))) + g!_state' (code;local-symbol (format "_state" (%n level)))] + (` [(~ g!_behavior') (~ g!_state') (~ g!bottom)]))) + bottom + (list;enumerate ancestors))) + +## Names +(do-template [ ] + [(def: ( base) + (-> Text Text) + (|> base (format "@")))] + + [newN "new"] + [getN "get"] + [setN "set"] + [updateN "update"] + ) + +(do-template [ ] + [(def: ( raw) + (-> Text Text) + (let [[module kind] (ident-for )] + (format "{" kind "@" module "}" raw)))] + + [signatureN #;;Signature] + [stateN #;;State] + [structN #;;Struct] + ) + +(def: (getterN export interface g!parameters g!ext g!child ancestors) + (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) + Code) + (let [g!get (code;local-symbol (getN interface)) + g!interface (code;local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!ancestors (ancestor-inputs ancestors) + g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!tear-down (nest g!ancestors + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)]))] + (` (def: (~@ (csw;export export)) ((~ g!get) (~ g!_object)) + (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (-> (~ g!object) (~ g!child))) + (let [(~ g!tear-down) (~ g!_object)] + (~ g!_state)))))) + +(def: (setterN export interface g!parameters g!ext g!child ancestors) + (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) + Code) + (let [g!set (code;local-symbol (setN interface)) + g!interface (code;local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!_input (' _input) + g!ancestors (ancestor-inputs ancestors) + g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!tear-down (nest g!ancestors + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) + g!build-up (nest g!ancestors + (` [(~ g!_behavior) (~ g!_input) (~ g!_extension)]))] + (` (def: (~@ (csw;export export)) + ((~ g!set) (~ g!_input) (~ g!_object)) + (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (-> (~ g!child) (~ g!object) (~ g!object))) + (let [(~ g!tear-down) (~ g!_object)] + (~ g!build-up)))))) + +(def: (updaterN export interface g!parameters g!ext g!child ancestors) + (-> (Maybe cs;Export) Text (List Code) Code Code (List Ident) + Code) + (let [g!update (code;local-symbol (updateN interface)) + g!interface (code;local-symbol interface) + g!_object (' _object) + g!_behavior (' _behavior) + g!_state (' _state) + g!_extension (' _extension) + g!_change (' _change) + g!ancestors (ancestor-inputs ancestors) + g!object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + g!tear-down (nest g!ancestors + (` [(~ g!_behavior) (~ g!_state) (~ g!_extension)])) + g!build-up (nest g!ancestors + (` [(~ g!_behavior) ((~ g!_change) (~ g!_state)) (~ g!_extension)]))] + (` (def: (~@ (csw;export export)) + ((~ g!update) (~ g!_change) (~ g!_object)) + (All [(~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)] + (-> (-> (~ g!child) (~ g!child)) + (-> (~ g!object) (~ g!object)))) + (let [(~ g!tear-down) (~ g!_object)] + (~ g!build-up)))))) + +## [Macros] +(def: (type-to-code type) + (-> Type (Lux Code)) + (case type + (#;Host name params) + (do Monad + [paramsC+ (M;map @ type-to-code params)] + (wrap (` (;host (~ (code;symbol ["" name])) + (~@ paramsC+))))) + + #;Void + (Lux/wrap (` (;|))) + + #;Unit + (Lux/wrap (` (;&))) + + (^template [ ] + ( _) + (do Monad + [partsC+ (M;map @ type-to-code ( type))] + (wrap (` ( (~@ partsC+)))))) + ([#;Sum ;| type;flatten-variant] + [#;Product ;& type;flatten-tuple]) + + (#;Function input output) + (do Monad + [#let [[insT+ outT] (type;flatten-function type)] + insC+ (M;map @ type-to-code insT+) + outC (type-to-code outT)] + (wrap (` (;-> (~@ insC+) (~ outC))))) + + (^template [] + ( idx) + (Lux/wrap (` ( (~ (code;nat idx)))))) + ([#;Bound] + [#;Var] + [#;Ex]) + + (#;Apply param fun) + (do Monad + [#let [[funcT argsT+] (type;flatten-application type)] + funcC (type-to-code funcT) + argsC+ (M;map @ type-to-code argsT+)] + (wrap (` ((~ funcC) (~@ argsC+))))) + + (#;Named name unnamedT) + (Lux/wrap (code;symbol name)) + + _ + (macro;fail (format "Cannot convert type to code: " (type;to-text type))))) + +(syntax: #export (interface: [export csr;export] + [(^@ decl [interface parameters]) declarationS] + [?extends (p;opt extension)] + [alias aliasS] + [annotations (p;default cs;empty-annotations csr;annotations)] + [methods (p;many (method (var-set parameters)))]) + (macro;with-gensyms [g!self-class g!child g!ext] + (do @ + [module macro;current-module-name + [parent ancestors mappings] (: (Lux [Ident (List Ident) (List Code)]) + (case ?extends + #;None + (wrap [no-parent (list) (list)]) + + (#;Some [super mappings]) + (do @ + [[parent ancestors] (interfaceN super)] + (wrap [parent (list& parent ancestors) mappings])))) + #let [g!signature (code;local-symbol (signatureN interface)) + g!interface (code;local-symbol interface) + g!parameters (L/map code;local-symbol parameters) + g!self-ref (if (list;empty? g!parameters) + (list g!interface) + (list)) + g!interface-def (if (no-parent? parent) + (let [g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~ g!child)))] + (` (Ex (~@ g!self-ref) [(~ g!ext) (~ g!child)] + [((~ g!signature) (~@ g!parameters) (~ g!recur)) + (~ g!child) + (~ g!ext)]))) + (let [g!parent (code;symbol parent) + g!ancestors (ancestor-inputs ancestors) + g!recur (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child)))] + (` (Ex (~@ g!self-ref) [(~ g!ext) (~@ g!ancestors) (~ g!child)] + ((~ g!parent) (~@ mappings) + [((~ g!signature) (~@ g!parameters) (~ g!recur)) + (~ g!child) + (~ g!ext)] + (~@ g!ancestors))))))]] + (wrap (list& (` (sig: (~@ (csw;export export)) + ((~ g!signature) (~@ g!parameters) (~ g!self-class)) + (~@ (let [de-alias (code;replace (code;local-symbol alias) g!self-class)] + (L/map (|>. (update@ #inputs (L/map de-alias)) + (update@ #output de-alias) + (declarationM g!self-class)) + methods))))) + + (` (type: (~@ (csw;export export)) ((~ g!interface) (~@ g!parameters)) + (~ (|> annotations + (with-interface parent [module interface]) + csw;annotations)) + (~ g!interface-def))) + + (getterN export interface g!parameters g!ext g!child ancestors) + (setterN export interface g!parameters g!ext g!child ancestors) + (updaterN export interface g!parameters g!ext g!child ancestors) + + (let [g!ancestors (ancestor-inputs ancestors) + g!states (L/append g!ancestors (list g!child)) + g!self-object (` ((~ g!interface) (~@ g!parameters) (~ g!ext) (~@ g!ancestors) (~ g!child))) + de-alias (code;replace (code;symbol ["" alias]) g!self-object)] + (L/map (|>. (update@ #inputs (L/map de-alias)) + (update@ #output de-alias) + (definition export decl g!self-object g!ext g!states)) + methods)))) + ))) + +(syntax: #export (class: [export csr;export] + [[instance parameters] declarationS] + [annotations (p;default cs;empty-annotations csr;annotations)] + [[interface interface-mappings] referenceS] + [super (p;opt inheritance)] + state-type + [impls (p;many s;any)]) + (macro;with-gensyms [g!init g!extension] + (do @ + [module macro;current-module-name + [interface _] (interfaceN interface) + [parent ancestors parent-mappings] (: (Lux [Ident (List Ident) (List Code)]) + (case super + (#;Some [super-class super-mappings]) + (do @ + [[parent ancestors] (classN super-class)] + (wrap [parent ancestors super-mappings])) + + #;None + (wrap [no-parent (list) (list)]))) + g!inheritance (: (Lux (List Code)) + (if (no-parent? parent) + (wrap (list)) + (do @ + [newT (macro;find-def-type (product;both id newN parent)) + [depth rawT+] (extract newT) + codeT+ (M;map @ type-to-code rawT+)] + (wrap (L/map (specialize parent-mappings) codeT+))))) + #let [g!parameters (L/map code;local-symbol parameters) + + g!state (code;local-symbol (stateN instance)) + g!struct (code;local-symbol (structN instance)) + g!class (code;local-symbol instance) + + g!signature (code;symbol (product;both id signatureN interface)) + g!interface (code;symbol interface) + + g!parent-structs (if (no-parent? parent) + (list) + (L/map (|>. (product;both id structN) code;symbol) (list& parent ancestors)))] + g!parent-inits (M;map @ (function [_] (macro;gensym "parent-init")) + g!parent-structs) + #let [g!full-init (L/fold (function [[parent-struct parent-state] child] + (` [(~ parent-struct) (~ parent-state) (~ child)])) + (` [(~ g!struct) (~ g!init) []]) + (list;zip2 g!parent-structs g!parent-inits)) + g!new (code;local-symbol (newN instance)) + g!recur (` ((~ g!class) (~@ g!parameters) (~ g!extension))) + g!rec (if (list;empty? g!parameters) + (list (' #rec)) + (list))]] + (wrap (list (` (type: (~@ (csw;export export)) + ((~ g!state) (~@ g!parameters)) + (~ state-type))) + + (` (type: (~@ (csw;export export)) (~@ g!rec) ((~ g!class) (~@ g!parameters)) + (~ (|> annotations + (with-class interface parent [module instance]) + csw;annotations)) + (Ex [(~ g!extension)] + (~ (if (no-parent? parent) + (` ((~ g!interface) (~@ interface-mappings) + (~ g!extension) + ((~ g!state) (~@ g!parameters)))) + (let [g!parent (code;symbol parent)] + (` ((~ g!parent) (~@ parent-mappings) + [((~ g!signature) (~@ interface-mappings) (~ g!recur)) + ((~ g!state) (~@ g!parameters)) + (~ g!extension)])))))))) + + (` (struct: (~@ (csw;export export)) (~ g!struct) + (All [(~@ g!parameters) (~ g!extension)] + ((~ g!signature) (~@ interface-mappings) + ((~ g!interface) (~@ interface-mappings) + (~ g!extension) + (~@ g!inheritance) + ((~ g!state) (~@ g!parameters))))) + (~@ impls))) + + (` (def: (~@ (csw;export export)) ((~ g!new) (~@ g!parent-inits) (~ g!init)) + (All [(~@ g!parameters)] + (-> (~@ g!inheritance) + ((~ g!state) (~@ g!parameters)) + ((~ g!class) (~@ g!parameters)))) + (~ g!full-init))) + )) + ))) -- cgit v1.2.3