aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/paradigm/object.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/paradigm/object.lux388
1 files changed, 218 insertions, 170 deletions
diff --git a/stdlib/source/lux/paradigm/object.lux b/stdlib/source/lux/paradigm/object.lux
index ae742fac7..16269b66d 100644
--- a/stdlib/source/lux/paradigm/object.lux
+++ b/stdlib/source/lux/paradigm/object.lux
@@ -1,178 +1,226 @@
(;module:
lux
- (lux (control monad)
- (data text/format
+ (lux (control monad
+ ["p" parser "p/" Monad<Parser>])
+ (data [text]
+ text/format
[product]
- (coll [list "L/" Functor<List> Monoid<List>]))
- [macro #+ Monad<Lux>]
+ maybe
+ (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
+ [set #+ Set]))
+ [macro #+ Monad<Lux> "Lux/" Monad<Lux>]
(macro [code]
- ["s" syntax #+ syntax: "s/" Monad<Syntax>]
- (syntax [common]))))
-
-(type: #export (Class interface)
- (Ex [state] [(interface state) state]))
-
-(type: Declaration
- [Text (List Text)])
-
-(type: Reference
- [Ident (List Code)])
-
-(type: Alias Text)
-
-(type: Method
- {#type-vars (List Text)
- #method Text
- #inputs (List Code)
- #output Code})
-
-(def: default-alias Alias "@")
-
-(def: declaration^
- (s;Syntax Declaration)
- (s;either (s;form (s;seq s;local-symbol
- (s;some s;local-symbol)))
- (s;seq s;local-symbol
- (s/wrap (list)))))
-
-(def: reference^
- (s;Syntax Reference)
- (s;either (s;form (s;seq s;symbol
- (s;some s;any)))
- (s;seq s;symbol
- (s/wrap (list)))))
-
-(def: alias^
- (s;Syntax Alias)
- (|> s;local-symbol
- (s;after (s;this (' #as)))))
-
-(def: method^
- (s;Syntax Method)
- (s;form ($_ s;seq
- (s;either (s;tuple (s;some s;local-symbol))
- (s/wrap (list)))
- s;local-symbol
- (s;tuple (s;some s;any))
- s;any)))
-
-(def: (interface-name raw)
- (-> Text Text)
- (format raw "{Interface}"))
-
-(def: (state-name raw)
- (-> Text Text)
- (format raw "{State}"))
-
-(def: identifier (-> Text Code) (|>. [""] code;symbol))
-
-(def: (type-declaration name parameters)
- (-> Text (List Text) Code)
- (if (list;empty? parameters)
- (identifier name)
- (` ((~ (identifier name)) (~@ (L/map identifier parameters))))))
-
-(def: (method-declaration g!class (^open))
- (-> Code Method Code)
- (let [g!type-vars (L/map identifier type-vars)]
- (` (: (All [(~@ g!type-vars)]
- (-> (~@ inputs) (~ g!class) (~ output)))
- (~ (identifier method))))))
-
-(def: (method-definition export [interface parameters] g!class g!impl (^open))
- (-> (Maybe common;Export) Declaration Code Code Method Code)
- (let [g!object (code;symbol ["" "_object"])
- g!behavior (code;symbol ["" "_behavior"])
- g!state (code;symbol ["" "_state"])
- args (L/map (|>. product;left nat-to-int %i (format "_") identifier)
- (list;enumerate inputs))]
- (` (def: (~@ (common;gen-export export)) ((~ (identifier method)) (~@ args) (~ g!object))
- (All [(~@ (L/map identifier parameters))
- (~ g!impl)
- (~@ (L/map identifier type-vars))]
- (-> (~@ inputs) (~ g!class) (~ output)))
- (let [[(~ g!behavior) (~ g!state)] (~ g!object)]
- (:: (~ g!behavior) (~ (identifier method)) (~@ args) (~ g!object)))))))
-
-(syntax: #export (interface: [export common;export]
- [(^@ decl [interface parameters]) declaration^]
- [alias (s;default default-alias alias^)]
- [annotations (s;default common;empty-annotations common;annotations)]
- [methods (s;many method^)])
- (macro;with-gensyms [g!state]
+ ["s" syntax #+ syntax:]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer])))
+ [type])
+ (. ["./c" common]
+ ["./n" notation]
+ ["./i" inheritance]
+ ["./m" method]))
+
+(def: (type-to-code type)
+ (-> Type (Lux Code))
+ (case type
+ (#;Host name params)
+ (do Monad<Lux>
+ [paramsC+ (mapM @ type-to-code params)]
+ (wrap (` (;host (~ (code;symbol ["" name]))
+ (~@ paramsC+)))))
+
+ #;Void
+ (Lux/wrap (` (;|)))
+
+ #;Unit
+ (Lux/wrap (` (;&)))
+
+ (^template [<tag> <macro> <flatten>]
+ (<tag> _)
+ (do Monad<Lux>
+ [partsC+ (mapM @ type-to-code (<flatten> type))]
+ (wrap (` (<macro> (~@ partsC+))))))
+ ([#;Sum ;| type;flatten-variant]
+ [#;Product ;& type;flatten-tuple])
+
+ (#;Function input output)
+ (do Monad<Lux>
+ [#let [[insT+ outT] (type;flatten-function type)]
+ insC+ (mapM @ type-to-code insT+)
+ outC (type-to-code outT)]
+ (wrap (` (;-> (~@ insC+) (~ outC)))))
+
+ (^template [<tag>]
+ (<tag> idx)
+ (Lux/wrap (` (<tag> (~ (code;nat idx))))))
+ ([#;Bound]
+ [#;Var]
+ [#;Ex])
+
+ (#;Apply param fun)
+ (do Monad<Lux>
+ [#let [[funcT argsT+] (type;flatten-application type)]
+ funcC (type-to-code funcT)
+ argsC+ (mapM @ 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]) ./c;declaration]
+ [?extends (p;opt ./i;extension)]
+ [alias ./c;alias]
+ [annotations (p;default cs;empty-annotations csr;annotations)]
+ [methods (p;many (./m;method (./c;var-set parameters)))])
+ (macro;with-gensyms [g!self-class g!child g!ext]
(do @
[module macro;current-module-name
- #let [g!behavior (` ((~ (identifier (interface-name interface))) (~@ (L/map identifier parameters))))
- g!class (` (;;Class (~ g!behavior) (~ g!state)))
- interface-declaration (` ((~ (identifier (interface-name interface))) (~@ (L/map identifier parameters)) (~ g!state)))
- de-alias (code;replace (code;symbol ["" alias]) g!class)
- methods (L/map (|>. (update@ #inputs (L/map de-alias))
- (update@ #output de-alias))
- methods)]]
- (wrap (list& (` (sig: (~@ (common;gen-export export)) (~ interface-declaration)
- (~@ (L/map (method-declaration g!class) methods))))
- (` (type: (~@ (common;gen-export export)) (~ (type-declaration interface parameters))
- (~ (common;gen-annotations (|> annotations
- (#;Cons [(ident-for #;;interface)
- (code;tag [module (interface-name interface)])]))))
- (;;Class (~ (type-declaration (interface-name interface) parameters)))))
- (L/map (method-definition export decl g!class g!state) methods))))))
-
-(syntax: #export (class: [export common;export]
- [[instance parameters] declaration^]
- [[class mappings] reference^]
- [state-type (s;alt (s;record (s;many (s;seq s;any s;any)))
- s;any)]
- [impls (s;many s;any)])
- (macro;with-gensyms [g!init]
+ [parent ancestors mappings] (: (Lux [Ident (List Ident) (List Code)])
+ (case ?extends
+ #;None
+ (wrap [./i;no-parent (list) (list)])
+
+ (#;Some [super mappings])
+ (do @
+ [[parent ancestors] (./i;interface super)]
+ (wrap [parent (list& parent ancestors) mappings]))))
+ #let [g!signature (code;local-symbol (./n;signature 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)
+ (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!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@ #./m;inputs (L/map de-alias))
+ (update@ #./m;output de-alias)
+ (./m;declaration g!self-class))
+ methods)))))
+
+ (` (type: (~@ (csw;export export)) ((~ g!interface) (~@ g!parameters))
+ (~ (|> annotations
+ (./i;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)
+
+ (let [g!ancestors (./c;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))
+ methods))))
+ )))
+
+(syntax: #export (class: [export csr;export]
+ [[instance parameters] ./c;declaration]
+ [annotations (p;default cs;empty-annotations csr;annotations)]
+ [[interface interface-mappings] ./i;reference]
+ [super (p;opt ./i;inheritance)]
+ state-type
+ [impls (p;many s;any)])
+ (macro;with-gensyms [g!init g!extension]
(do @
- [class (macro;normalize class)
- [_ annotations _] (macro;find-def class)]
- (case (macro;get-ident-ann (ident-for #;;interface) annotations)
- #;None
- (macro;fail (format (%ident class) " is not a class."))
-
- (#;Some interface)
- (let [[must-define-state? state-def] (case state-type
- (#;Left members)
- [true (code;record members)]
+ [module macro;current-module-name
+ [interface _] (./i;interface 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)]
+ (wrap [parent ancestors super-mappings]))
- (#;Right type)
- [false type])
- g!state (if must-define-state?
- (type-declaration (state-name instance) parameters)
- state-def)
- g!new (|> instance (format "new-") identifier)
- g!instance (identifier instance)
- g!parameters (L/map identifier parameters)
- instance-declaration (type-declaration instance parameters)]
- (wrap (L/append (if must-define-state?
- (list (` (type: (~@ (common;gen-export export))
- (~ g!state)
- (~ state-def))))
- (list))
- (list (` (struct: (~@ (common;gen-export export)) (~ g!instance)
- (All [(~@ g!parameters)]
- ((~ (code;symbol interface)) (~@ mappings) (~ g!state)))
- (~@ impls)))
- (` (def: (~@ (common;gen-export export)) ((~ g!new) (~ g!init))
- (All [(~@ g!parameters)]
- (-> (~ g!state)
- ((~ (code;symbol class)) (~@ mappings) (~ g!state))))
- [(~ g!instance) (~ g!init)]))))))
- ))))
-
-(def: #export (get! object)
- (All [I s] (-> (Class I s) s))
- (let [[behavior state] object]
- state))
-
-(def: #export (set! state object)
- (All [I s] (-> s (Class I s) (Class I s)))
- (let [[behavior _] object]
- [behavior state]))
-
-(def: #export (update! change object)
- (All [I s] (-> (-> s s) (Class I s) (Class I s)))
- (let [[behavior state] object]
- [behavior (change state)]))
+ #;None
+ (wrap [./i;no-parent (list) (list)])))
+ g!inheritance (: (Lux (List Code))
+ (if (./i;no-parent? parent)
+ (wrap (list))
+ (do @
+ [newT (macro;find-def-type (product;both id ./n;new parent))
+ [depth rawT+] (./i;extract newT)
+ codeT+ (mapM @ type-to-code rawT+)]
+ (wrap (L/map (./i;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!class (code;local-symbol instance)
+
+ g!signature (code;symbol (product;both id ./n;signature interface))
+ g!interface (code;symbol interface)
+
+ g!parent-structs (if (./i;no-parent? parent)
+ (list)
+ (L/map (|>. (product;both id ./n;struct) code;symbol) (list& parent ancestors)))]
+ g!parent-inits (mapM @ (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!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
+ (./i;with-class interface parent [module instance])
+ csw;annotations))
+ (Ex [(~ g!extension)]
+ (~ (if (./i;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)))
+ ))
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 07:52:44 +0000