- Implemented single-inheritance.

- Fixed some bugs.

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)))
+                  ))
+      )))