aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2017-07-22 19:27:26 -0400
committerEduardo Julian2017-07-22 19:27:26 -0400
commit1872b871a2affefdc5f8f4264c11f3c5ec9341db (patch)
treec8ed08e9e6fe51790e068b22a9c2a1dd2664115b /stdlib/source
parent17aec08b4bc4764f81693808987f1d54dc056ede (diff)
- Merged the submodules of lux/paradigm/object into their parent module.
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/paradigm/object.lux380
-rw-r--r--stdlib/source/lux/paradigm/object/common.lux65
-rw-r--r--stdlib/source/lux/paradigm/object/inheritance.lux109
-rw-r--r--stdlib/source/lux/paradigm/object/method.lux60
-rw-r--r--stdlib/source/lux/paradigm/object/notation.lux116
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))))))