- Added initial implementation of protocol-based object-oriented programming.

6 files changed, 213 insertions, 9 deletions

diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index c37b759a2..8a959b6c8 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -91,7 +91,7 @@
              g!self (code.local-symbol name)]]
       (wrap (list (` (def: (~+ (csw.export export))
                        (~ g!self)
-                       (All (~ (csw.type-variables t-vars))
+                       (All [(~+ (csw.type-variables t-vars))]
                          (..Exception [(~+ (list/map (get@ #cs.input-type) inputs))]))
                        (let [(~ g!descriptor) (~ (code.text descriptor))]
                          {#..label (~ g!descriptor)
diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux
index 27329e55c..01f1806c4 100644
--- a/stdlib/source/lux/macro.lux
+++ b/stdlib/source/lux/macro.lux
@@ -392,7 +392,7 @@
        #let [symbol-defs (list/join (list/map (: (-> Text (List Code))
                                                  (function [name] (list (code.symbol ["" name]) (` (gensym (~ (code.text name)))))))
                                               symbol-names))]]
-      (wrap (list (` (do Monad<Meta>
+      (wrap (list (` ((~! do) (~! Monad<Meta>)
                        [(~+ symbol-defs)]
                        (~ body))))))
 
diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux
index e9f899f1d..9c304223e 100644
--- a/stdlib/source/lux/macro/syntax/common/writer.lux
+++ b/stdlib/source/lux/macro/syntax/common/writer.lux
@@ -1,23 +1,27 @@
-(.module: {#.doc "Commons syntax writers."}
+(.module:
+  {#.doc "Commons syntax writers."}
   lux
   (lux (data (coll [list "list/" Functor<List>])
              [product])
        (macro [code]))
   [//])
 
-## Exports
 (def: #export (export exported?)
   (-> Bool (List Code))
   (if exported?
     (list (' #export))
     (list)))
 
-## Annotations
+(def: #export (declaration declaration)
+  (-> //.Declaration Code)
+  (` ((~ (code.local-symbol (get@ #//.declaration-name declaration)))
+      (~+ (list/map code.local-symbol
+                    (get@ #//.declaration-args declaration))))))
+
 (def: #export (annotations anns)
   (-> //.Annotations Code)
   (|> anns (list/map (product.both code.tag id)) code.record))
 
-## Type-Variables
 (def: #export (type-variables vars)
-  (-> (List Text) Code)
-  (code.tuple (list/map code.local-symbol vars)))
+  (-> (List Text) (List Code))
+  (list/map code.local-symbol vars))
diff --git a/stdlib/source/lux/type/object/protocol.lux b/stdlib/source/lux/type/object/protocol.lux
new file mode 100644
index 000000000..73bc9226f
--- /dev/null
+++ b/stdlib/source/lux/type/object/protocol.lux
@@ -0,0 +1,84 @@
+(.module:
+  lux
+  (lux (control ["p" parser]
+                [monad #+ do])
+       (data (coll [list "list/" Functor<List>]))
+       [macro "meta/" Monad<Meta>]
+       (macro [code]
+              ["s" syntax #+ syntax:]
+              (syntax ["cs" common]
+                      (common ["csr" reader]
+                              ["csw" writer])))))
+
+(type: #export (Simple i o)
+  (All [r] [i (-> o r)]))
+
+(type: #export (Message i o)
+  (Simple i o o))
+
+(def: #export (message input)
+  (All [i o] (-> i (Message i o)))
+  [input id])
+
+(type: #export (Method s p)
+  (All [r] (-> (p r) s [r s])))
+
+(type: #export (Object p)
+  (All [r] (-> (p r) [r (Object p)])))
+
+(def: #export (object method init)
+  (All [s p] (-> (Method s p) s (Object p)))
+  (loop [state init]
+    (function [input]
+      (let [[output state'] (method input state)]
+        [output (recur state')]))))
+
+(type: Method-Syntax
+  {#type-variables (List Text)
+   #name Text
+   #input Code
+   #output Code})
+
+(def: method|r
+  (s.Syntax Method-Syntax)
+  (s.form ($_ p.seq
+              (p.default (list) csr.type-variables)
+              s.local-symbol
+              s.any
+              s.any)))
+
+(def: (method|w g!return method)
+  (-> Code Method-Syntax Code)
+  (` ((~ (code.local-tag (get@ #name method)))
+      (All [(~+ (csw.type-variables (get@ #type-variables method)))]
+        [(~ (get@ #input method))
+         (-> (~ (get@ #output method)) (~ g!return))]))))
+
+(def: (method-constructor export protocol method)
+  (-> Bool cs.Declaration Method-Syntax (Meta Code))
+  (let [methodC (code.local-symbol (get@ #name method))
+        tagC (code.local-tag (get@ #name method))
+        protocolC (code.local-symbol (get@ #cs.declaration-name protocol))
+        protocol-varsC+ (csw.type-variables (get@ #cs.declaration-args protocol))
+        method-varsC+ (csw.type-variables (get@ #type-variables method))
+        method-inputC (get@ #input method)
+        method-outputC (get@ #output method)]
+    (macro.with-gensyms [g!input g!return]
+      (meta/wrap (` (def: (~+ (csw.export export)) ((~ methodC) (~ g!input))
+                      (All [(~+ protocol-varsC+) (~+ method-varsC+)]
+                        (-> (~ method-inputC)
+                            ((~ protocolC) (~+ protocol-varsC+) (~ method-outputC))))
+                      ((~ tagC) [(~ g!input) .id])))))))
+
+(syntax: #export (protocol: [export csr.export]
+                   [declaration csr.declaration]
+                   [methods (p.many method|r)])
+  (macro.with-gensyms [g!return]
+    (do @
+      [constructors (monad.map @ (method-constructor export declaration) methods)
+       #let [protocolC (code.local-symbol (get@ #cs.declaration-name declaration))
+             varsC+ (csw.type-variables (get@ #cs.declaration-args declaration))]]
+      (wrap (list& (` (type: (~+ (csw.export export))
+                        ((~ protocolC) (~+ varsC+) (~ g!return))
+                        (~+ (list/map (method|w g!return) methods))))
+                   constructors)))))
diff --git a/stdlib/test/test/lux/type/object/protocol.lux b/stdlib/test/test/lux/type/object/protocol.lux
new file mode 100644
index 000000000..a93f34aab
--- /dev/null
+++ b/stdlib/test/test/lux/type/object/protocol.lux
@@ -0,0 +1,114 @@
+(.module:
+  lux
+  (lux (data text/format)
+       (type (object protocol))))
+
+(type: Counter (Object (Simple Unit Nat)))
+
+(def: (count [tick return] state)
+  (Method Nat (Simple Unit Nat))
+  (let [state' (n/inc state)]
+    [(return state') state']))
+
+(def: counter
+  (-> Nat Counter)
+  (object count))
+
+(def: _test0
+  [Nat Counter]
+  ((counter +0) (message [])))
+
+(protocol: Protocol0
+  (method0 [Bool Nat Text] Bool)
+  (method1 [Nat Text Bool] Nat)
+  (method2 [Text Bool Nat] Text))
+
+(type: Object0 (Object Protocol0))
+
+(def: object0
+  Object0
+  (loop [num-calls +0]
+    (function [message]
+      [(case message
+         (#method0 [arg0 arg1 arg2] output)
+         (output (n/= +0 (n/% +2 num-calls)))
+         
+         (#method1 [arg0 arg1 arg2] output)
+         (output num-calls)
+         
+         (#method2 [arg0 arg1 arg2] output)
+         (output (%n num-calls)))
+       (recur (n/inc num-calls))])))
+
+(def: _test1
+  [Nat Object0]
+  (object0 (method1 [+0 "0" false])))
+
+(protocol: (Read a)
+  (read [] a))
+
+(def: (readM [tick return] state)
+  (All [s] (Method s (Simple Unit s)))
+  [(return state) state])
+
+(protocol: (Add n)
+  (+ n Unit)
+  (- n Unit))
+
+(protocol: (Mul n)
+  (* n Unit)
+  (/ n Unit))
+
+(do-template [<name> <op>]
+  [(def: (<name> [diff return] state)
+     (Method Nat (Simple Nat Unit))
+     [(return []) (<op> diff state)])]
+
+  [+M n/+]
+  [-M n/-]
+  [*M n/*]
+  [/M n//]
+  )
+
+## (def: addM
+##   (Method Nat (Add Nat))
+##   (seq +M -M))
+
+(def: (addM message state)
+  (Method Nat (Add Nat))
+  (case message
+    (#+ message)
+    (+M message state)
+    
+    (#- message)
+    (-M message state)))
+
+(def: (mulM message state)
+  (Method Nat (Mul Nat))
+  (case message
+    (#* message)
+    (*M message state)
+    
+    (#/ message)
+    (/M message state)))
+
+(type: (Number n r)
+  (#Read (Read n r))
+  (#Add (Add n r))
+  (#Mul (Mul n r)))
+
+(def: (numberM message state)
+  (Method Nat (Number Nat))
+  (case message
+    (#Read message)
+    (readM message state)
+    
+    (#Add message)
+    (addM message state)
+    
+    (#Mul message)
+    (mulM message state)))
+
+(def: numberO
+  (Object (Number Nat))
+  (object numberM +0))
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index b59e8008a..850abc865 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -69,7 +69,9 @@
                     (poly ["poly_." eq]
                           ["poly_." functor]))
              (type ["_." implicit]
-                   (object ["_." interface])
+                   (object
+                     ["_." interface]
+                     ["_." protocol])
                    ["_." resource])
              (lang ["lang/_." syntax]
                    ["_." type]