- Forgot to commit some of the sub-modules for lux/paradigm/object.

4 files changed, 351 insertions, 0 deletions

diff --git a/stdlib/source/lux/paradigm/object/common.lux b/stdlib/source/lux/paradigm/object/common.lux
new file mode 100644
index 000000000..b9d9d0fd6
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object/common.lux
@@ -0,0 +1,65 @@
+(;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
new file mode 100644
index 000000000..9b384fd1d
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object/inheritance.lux
@@ -0,0 +1,109 @@
+(;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   #extends]
+  [inheritance #inherits]
+  )
diff --git a/stdlib/source/lux/paradigm/object/method.lux b/stdlib/source/lux/paradigm/object/method.lux
new file mode 100644
index 000000000..1ed759c30
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object/method.lux
@@ -0,0 +1,60 @@
+(;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
new file mode 100644
index 000000000..215963d41
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object/notation.lux
@@ -0,0 +1,117 @@
+(;module:
+  [lux #- struct]
+  (lux (control monad
+                ["p" parser "p/" Monad<Parser>])
+       (data [text]
+             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>]
+       (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))))))