diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/lux/paradigm/object.lux | 380 | ||||
| -rw-r--r-- | stdlib/source/lux/paradigm/object/common.lux | 65 | ||||
| -rw-r--r-- | stdlib/source/lux/paradigm/object/inheritance.lux | 109 | ||||
| -rw-r--r-- | stdlib/source/lux/paradigm/object/method.lux | 60 | ||||
| -rw-r--r-- | stdlib/source/lux/paradigm/object/notation.lux | 116 |
5 files changed, 334 insertions, 396 deletions
diff --git a/stdlib/source/lux/paradigm/object.lux b/stdlib/source/lux/paradigm/object.lux index f215e4071..c7cdcb4d3 100644 --- a/stdlib/source/lux/paradigm/object.lux +++ b/stdlib/source/lux/paradigm/object.lux @@ -6,6 +6,7 @@ text/format [product] maybe + [ident #+ "Ident/" Eq<Ident>] (coll [list "L/" Functor<List> Fold<List> Monoid<List>] [set #+ Set])) [macro #+ Monad<Lux> "Lux/" Monad<Lux>] @@ -14,12 +15,299 @@ (syntax ["cs" common] (common ["csr" reader] ["csw" writer]))) - [type]) - (. ["./c" common] - ["./n" notation] - ["./i" inheritance] - ["./m" method])) + [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<Text> vars)) + +(def: (unique-type-vars parser) + (-> (s;Syntax (List Text)) (s;Syntax (List Text))) + (do p;Monad<Parser> + [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<Parser> + [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 [<name> <name-tag> <parent-tag> <desc>] + [(def: (<name> name) + (-> Ident (Lux [Ident (List Ident)])) + (do Monad<Lux> + [name (macro;normalize name) + [_ annotations _] (macro;find-def name)] + (case [(macro;get-ident-ann (ident-for <name-tag>) annotations) + (macro;get-ident-ann (ident-for <parent-tag>) annotations)] + [(#;Some real-name) (#;Some parent)] + (if (Ident/= no-parent parent) + (wrap [real-name (list)]) + (do @ + [[_ ancestors] (<name> parent)] + (wrap [real-name (#;Cons parent ancestors)]))) + + _ + (macro;fail (format "Wrong format for " <desc> " 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 [<name> <keyword>] + [(def: <name> + (s;Syntax Reference) + (|> referenceS + (p;after (s;this (' <keyword>)))))] + + [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 [<name> <category>] + [(def: (<name> base) + (-> Text Text) + (|> base (format <category> "@")))] + + [newN "new"] + [getN "get"] + [setN "set"] + [updateN "update"] + ) + +(do-template [<name> <category>] + [(def: (<name> raw) + (-> Text Text) + (format raw "//OOP:" <category>))] + + [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 @@ -71,37 +359,37 @@ (macro;fail (format "Cannot convert type to code: " (type;to-text type))))) (syntax: #export (interface: [export csr;export] - [(^@ decl [interface parameters]) ./c;declaration] - [?extends (p;opt ./i;extension)] - [alias ./c;alias] + [(^@ decl [interface parameters]) declarationS] + [?extends (p;opt extension)] + [alias aliasS] [annotations (p;default cs;empty-annotations csr;annotations)] - [methods (p;many (./m;method (./c;var-set parameters)))]) + [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 [./i;no-parent (list) (list)]) + (wrap [no-parent (list) (list)]) (#;Some [super mappings]) (do @ - [[parent ancestors] (./i;interface super)] + [[parent ancestors] (interfaceN super)] (wrap [parent (list& parent ancestors) mappings])))) - #let [g!signature (code;local-symbol (./n;signature interface)) + #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 (./i;no-parent? parent) + 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 (./c;ancestor-inputs ancestors) + 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) @@ -112,78 +400,78 @@ (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@ #./m;inputs (L/map de-alias)) - (update@ #./m;output de-alias) - (./m;declaration 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 - (./i;with-interface parent [module interface]) + (with-interface parent [module interface]) csw;annotations)) (~ g!interface-def))) - (./n;getter export interface g!parameters g!ext g!child ancestors) - (./n;setter export interface g!parameters g!ext g!child ancestors) - (./n;updater export interface g!parameters g!ext g!child ancestors) + (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 (./c;ancestor-inputs 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@ #./m;inputs (L/map de-alias)) - (update@ #./m;output de-alias) - (./m;definition export decl g!self-object g!ext g!states)) + (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] ./c;declaration] + [[instance parameters] declarationS] [annotations (p;default cs;empty-annotations csr;annotations)] - [[interface interface-mappings] ./i;reference] - [super (p;opt ./i;inheritance)] + [[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 _] (./i;interface interface) + [interface _] (interfaceN interface) [parent ancestors parent-mappings] (: (Lux [Ident (List Ident) (List Code)]) (case super (#;Some [super-class super-mappings]) (do @ - [[parent ancestors] (./i;class super-class)] + [[parent ancestors] (classN super-class)] (wrap [parent ancestors super-mappings])) - + #;None - (wrap [./i;no-parent (list) (list)]))) + (wrap [no-parent (list) (list)]))) g!inheritance (: (Lux (List Code)) - (if (./i;no-parent? parent) + (if (no-parent? parent) (wrap (list)) (do @ - [newT (macro;find-def-type (product;both id ./n;new parent)) - [depth rawT+] (./i;extract newT) + [newT (macro;find-def-type (product;both id newN parent)) + [depth rawT+] (extract newT) codeT+ (M;map @ type-to-code rawT+)] - (wrap (L/map (./i;specialize parent-mappings) codeT+))))) + (wrap (L/map (specialize parent-mappings) codeT+))))) #let [g!parameters (L/map code;local-symbol parameters) - - g!state (code;local-symbol (./n;state instance)) - g!struct (code;local-symbol (./n;struct instance)) + + 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 ./n;signature interface)) + g!signature (code;symbol (product;both id signatureN interface)) g!interface (code;symbol interface) - g!parent-structs (if (./i;no-parent? parent) + g!parent-structs (if (no-parent? parent) (list) - (L/map (|>. (product;both id ./n;struct) code;symbol) (list& parent ancestors)))] + (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 (./n;new instance)) + g!new (code;local-symbol (newN instance)) g!recur (` ((~ g!class) (~@ g!parameters) (~ g!extension))) g!rec (if (list;empty? g!parameters) (list (' #rec)) @@ -194,10 +482,10 @@ (` (type: (~@ (csw;export export)) (~@ g!rec) ((~ g!class) (~@ g!parameters)) (~ (|> annotations - (./i;with-class interface parent [module instance]) + (with-class interface parent [module instance]) csw;annotations)) (Ex [(~ g!extension)] - (~ (if (./i;no-parent? parent) + (~ (if (no-parent? parent) (` ((~ g!interface) (~@ interface-mappings) (~ g!extension) ((~ g!state) (~@ g!parameters)))) @@ -215,7 +503,7 @@ (~@ g!inheritance) ((~ g!state) (~@ g!parameters))))) (~@ impls))) - + (` (def: (~@ (csw;export export)) ((~ g!new) (~@ g!parent-inits) (~ g!init)) (All [(~@ g!parameters)] (-> (~@ g!inheritance) diff --git a/stdlib/source/lux/paradigm/object/common.lux b/stdlib/source/lux/paradigm/object/common.lux deleted file mode 100644 index b9d9d0fd6..000000000 --- a/stdlib/source/lux/paradigm/object/common.lux +++ /dev/null @@ -1,65 +0,0 @@ -(;module: - lux - (lux (control monad - ["p" parser "p/" Monad<Parser>]) - (data [text] - text/format - [product] - (coll [list "L/" Functor<List> Fold<List>] - ["S" set])) - [macro] - (macro [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))))) - -(type: #export Declaration - [Text (List Text)]) - -(type: #export Alias Text) - -(def: #export default-alias Alias "@") - -(def: #export (var-set vars) - (-> (List Text) (S;Set Text)) - (S;from-list text;Hash<Text> vars)) - -(def: #export (unique-type-vars parser) - (-> (s;Syntax (List Text)) (s;Syntax (List Text))) - (do p;Monad<Parser> - [raw parser - _ (p;assert "Cannot repeat the names of type variables/parameters." - (n.= (S;size (var-set raw)) - (list;size raw)))] - (wrap raw))) - -(def: #export (safe-type-vars exclusions) - (-> (S;Set Text) (s;Syntax Text)) - (do p;Monad<Parser> - [raw s;local-symbol - _ (p;assert "Cannot re-use names between method type-variables and interface type-parameters." - (|> raw (S;member? exclusions) not))] - (wrap raw))) - -(def: #export declaration - (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: #export alias - (s;Syntax Alias) - (|> s;local-symbol - (p;after (s;this (' #as))) - (p;default default-alias))) - -(def: #export (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))))) diff --git a/stdlib/source/lux/paradigm/object/inheritance.lux b/stdlib/source/lux/paradigm/object/inheritance.lux deleted file mode 100644 index d3eef515d..000000000 --- a/stdlib/source/lux/paradigm/object/inheritance.lux +++ /dev/null @@ -1,109 +0,0 @@ -(;module: - lux - (lux (control monad - ["p" parser "p/" Monad<Parser>]) - (data [text] - text/format - [ident "Ident/" Eq<Ident>] - (coll [list "L/" Functor<List> Fold<List>])) - [macro #+ Monad<Lux> "Lux/" Monad<Lux>] - (macro [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))) - [type])) - -(type: #export Reference - [Ident (List Code)]) - -(def: #export no-parent Ident ["" ""]) - -(def: #export (no-parent? parent) - (-> Ident Bool) - (Ident/= no-parent parent)) - -(def: #export (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: #export (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 [<name> <name-tag> <parent-tag> <desc>] - [(def: #export (<name> name) - (-> Ident (Lux [Ident (List Ident)])) - (do Monad<Lux> - [name (macro;normalize name) - [_ annotations _] (macro;find-def name)] - (case [(macro;get-ident-ann (ident-for <name-tag>) annotations) - (macro;get-ident-ann (ident-for <parent-tag>) annotations)] - [(#;Some real-name) (#;Some parent)] - (if (Ident/= no-parent parent) - (wrap [real-name (list)]) - (do @ - [[_ ancestors] (<name> parent)] - (wrap [real-name (#;Cons parent ancestors)]))) - - _ - (macro;fail (format "Wrong format for " <desc> " lineage.")))))] - - [interface #;;interface-name #;;interface-parent "interface"] - [class #;;class-name #;;class-parent "class"] - ) - -(def: #export (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: #export (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: #export reference - (s;Syntax Reference) - (p;either (s;form (p;seq s;symbol - (p;some s;any))) - (p;seq s;symbol - (p/wrap (list))))) - -(do-template [<name> <keyword>] - [(def: #export <name> - (s;Syntax Reference) - (|> reference - (p;after (s;this (' <keyword>)))))] - - [extension #super] - [inheritance #super] - ) diff --git a/stdlib/source/lux/paradigm/object/method.lux b/stdlib/source/lux/paradigm/object/method.lux deleted file mode 100644 index 1ed759c30..000000000 --- a/stdlib/source/lux/paradigm/object/method.lux +++ /dev/null @@ -1,60 +0,0 @@ -(;module: - lux - (lux (control monad - ["p" parser "p/" Monad<Parser>]) - (data [text] - text/format - [product] - (coll [list "L/" Functor<List> Fold<List>] - ["S" set])) - [macro] - (macro [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer])))) - (.. ["../c" common])) - -(type: #export Method - {#type-vars (List Text) - #name Text - #inputs (List Code) - #output Code}) - -(def: #export (method exclusions) - (-> (S;Set Text) (s;Syntax Method)) - (s;form ($_ p;seq - (p;either (../c;unique-type-vars (s;tuple (p;some (../c;safe-type-vars exclusions)))) - (p/wrap (list))) - s;local-symbol - (s;tuple (p;some s;any)) - s;any))) - -(def: #export (declaration 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: #export (definition export [interface parameters] g!self-object g!ext g!states (^open)) - (-> (Maybe cs;Export) ../c;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))))))) diff --git a/stdlib/source/lux/paradigm/object/notation.lux b/stdlib/source/lux/paradigm/object/notation.lux deleted file mode 100644 index a70ff5ece..000000000 --- a/stdlib/source/lux/paradigm/object/notation.lux +++ /dev/null @@ -1,116 +0,0 @@ -(;module: - [lux #- struct] - (lux (control [monad #+ do Monad] - ["p" parser "p/" Monad<Parser>]) - (data [text] - text/format - [product] - [ident "Ident/" Eq<Ident>] - (coll [list "L/" Functor<List> Fold<List> Monoid<List>] - [set #+ Set])) - [macro #+ Monad<Lux> "Lux/" Monad<Lux>] - (macro [code] - ["s" syntax #+ syntax:] - (syntax ["cs" common] - (common ["csr" reader] - ["csw" writer]))) - [type]) - (.. ["../c" common])) - -## [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 [<name> <category>] - [(def: #export (<name> base) - (-> Text Text) - (|> base (format <category> "@")))] - - [new "new"] - [get "get"] - [set "set"] - [update "update"] - ) - -(do-template [<name> <category>] - [(def: #export (<name> raw) - (-> Text Text) - (format raw "//OOP:" <category>))] - - [signature "Signature"] - [state "State"] - [struct "Struct"] - ) - -(def: #export (getter 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 (get interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!ancestors (../c;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: #export (setter 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 (set interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!_input (' _input) - g!ancestors (../c;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: #export (updater 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 (update interface)) - g!interface (code;local-symbol interface) - g!_object (' _object) - g!_behavior (' _behavior) - g!_state (' _state) - g!_extension (' _extension) - g!_change (' _change) - g!ancestors (../c;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)))))) |