- Implemented functional object-oriented programming.

3 files changed, 227 insertions, 0 deletions

diff --git a/stdlib/source/lux/paradigm/object.lux b/stdlib/source/lux/paradigm/object.lux
new file mode 100644
index 000000000..ae742fac7
--- /dev/null
+++ b/stdlib/source/lux/paradigm/object.lux
@@ -0,0 +1,178 @@
+(;module:
+  lux
+  (lux (control monad)
+       (data text/format
+             [product]
+             (coll [list "L/" Functor<List> Monoid<List>]))
+       [macro #+ 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]
+    (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]
+    (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)]
+                                               
+                                               (#;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)]))
diff --git a/stdlib/test/test/lux/paradigm/object.lux b/stdlib/test/test/lux/paradigm/object.lux
new file mode 100644
index 000000000..0171ab41f
--- /dev/null
+++ b/stdlib/test/test/lux/paradigm/object.lux
@@ -0,0 +1,48 @@
+(;module:
+  lux
+  (lux (data (coll [list]))
+       (paradigm object)))
+
+(interface: (Queue a)
+  (push [a] @)
+  (peek [] (Maybe a))
+  (pop [] @)
+  (size [] Nat))
+
+(class: (List-Queue a) (Queue a)
+  (List a)
+  
+  (def: (push a)
+    (update! (|>. (#;Cons a))))
+
+  (def: peek
+    (|>. get! list;head))
+
+  (def: pop
+    (update! (function [state] (|> state list;tail (default state)))))
+  
+  (def: size
+    (|>. get! list;size)))
+
+(type: Coord [Real Real])
+(type: Angle Real)
+
+(interface: Geometry
+  (translate [Coord] @)
+  (rotate [Coord Angle] @)
+  (scale [Real Real] @))
+
+(class: Point Geometry
+  {#label Text
+   #coord Coord}
+  (def: (translate coord self) self)
+  (def: (rotate coord angle self) self)
+  (def: (scale width height self) self))
+
+(def: queue0 (|> (new-List-Queue (list))
+                 (: (Queue Nat))
+                 (push +123)
+                 (push +456)
+                 (push +789)
+                 pop))
+(def: point0 (new-Point ["YOLO" [123.4 567.8]]))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index b55373330..0a609ce13 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -67,6 +67,7 @@
              ["_;" type]
              (type ["_;" check]
                    ["_;" auto])
+             (paradigm ["_;" object])
              ))
   (lux (control [contract])
        (data [env]