- Some improvements to protocol-based objects.

2 files changed, 151 insertions, 68 deletions

diff --git a/stdlib/source/lux/type/object/protocol.lux b/stdlib/source/lux/type/object/protocol.lux
index 73bc9226f..b19c1b203 100644
--- a/stdlib/source/lux/type/object/protocol.lux
+++ b/stdlib/source/lux/type/object/protocol.lux
@@ -2,7 +2,8 @@
   lux
   (lux (control ["p" parser]
                 [monad #+ do])
-       (data (coll [list "list/" Functor<List>]))
+       (data [sum]
+             (coll [list "list/" Functor<List>]))
        [macro "meta/" Monad<Meta>]
        (macro [code]
               ["s" syntax #+ syntax:]
@@ -10,34 +11,50 @@
                       (common ["csr" reader]
                               ["csw" writer])))))
 
-(type: #export (Simple i o)
+(type: #export (Method i o)
   (All [r] [i (-> o r)]))
 
 (type: #export (Message i o)
-  (Simple i o o))
+  (Method i o o))
 
 (def: #export (message input)
   (All [i o] (-> i (Message i o)))
   [input id])
 
-(type: #export (Method s p)
+(type: #export (Class s p)
   (All [r] (-> (p r) s [r s])))
 
+(type: #export (Alt lp rp)
+  (All [r] (| (lp r) (rp r))))
+
+(def: #export (alt left right)
+  (All [s lp rp]
+    (-> (Class s lp)
+        (Class s rp)
+        (Class s (Alt lp rp))))
+  (function [input state]
+    (case input
+      (#.Left input)
+      (left input state)
+
+      (#.Right input)
+      (right input state))))
+
 (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)))
+(def: #export (object class init)
+  (All [s p] (-> (Class s p) s (Object p)))
   (loop [state init]
     (function [input]
-      (let [[output state'] (method input state)]
+      (let [[output state'] (class input state)]
         [output (recur state')]))))
 
 (type: Method-Syntax
-  {#type-variables (List Text)
-   #name Text
-   #input Code
-   #output Code})
+  {#method-variables (List Text)
+   #method-name Text
+   #method-input Code
+   #method-output Code})
 
 (def: method|r
   (s.Syntax Method-Syntax)
@@ -49,20 +66,22 @@
 
 (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))]))))
+  (let [tagC (code.local-tag (get@ #method-name method))
+        varsC+ (csw.type-variables (get@ #method-variables method))
+        inputC (get@ #method-input method)
+        outputC (get@ #method-output method)]
+    (` ((~ tagC) (All [(~+ varsC+)]
+                   (Method (~ inputC) (~ outputC) (~ g!return)))))))
 
-(def: (method-constructor export protocol method)
+(def: (method|c 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))
+  (let [methodC (code.local-symbol (get@ #method-name method))
+        tagC (code.local-tag (get@ #method-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)]
+        method-varsC+ (csw.type-variables (get@ #method-variables method))
+        method-inputC (get@ #method-input method)
+        method-outputC (get@ #method-output method)]
     (macro.with-gensyms [g!input g!return]
       (meta/wrap (` (def: (~+ (csw.export export)) ((~ methodC) (~ g!input))
                       (All [(~+ protocol-varsC+) (~+ method-varsC+)]
@@ -70,15 +89,64 @@
                             ((~ protocolC) (~+ protocol-varsC+) (~ method-outputC))))
                       ((~ tagC) [(~ g!input) .id])))))))
 
+(type: Class-Syntax
+  {#class-name Text
+   #class-protocol Code})
+
+(def: class|r
+  (s.Syntax Class-Syntax)
+  (s.form ($_ p.seq
+              s.local-symbol
+              s.any)))
+
+(def: (class|w g!return class)
+  (-> Code Class-Syntax Code)
+  (let [tagC (code.local-tag (get@ #class-name class))
+        protocolC (get@ #class-protocol class)]
+    (` ((~ tagC) ((~ protocolC) (~ g!return))))))
+
+(def: (class|c export protocol class)
+  (-> Bool cs.Declaration Class-Syntax (Meta Code))
+  (let [classC (code.local-symbol (get@ #class-name class))
+        tagC (code.local-tag (get@ #class-name class))
+        protocolC (code.local-symbol (get@ #cs.declaration-name protocol))
+        protocol-varsC+ (csw.type-variables (get@ #cs.declaration-args protocol))
+        class-protocolC (get@ #class-protocol class)]
+    (macro.with-gensyms [g!sub g!return]
+      (meta/wrap (` (def: (~+ (csw.export export)) ((~ classC) (~ g!sub))
+                      (All [(~+ protocol-varsC+)]
+                        (-> (~ class-protocolC)
+                            ((~ protocolC) (~+ protocol-varsC+))))
+                      ((~ tagC) (~ g!sub))))))))
+
+(type: Super-Syntax
+  (#Method Method-Syntax)
+  (#Class Class-Syntax))
+
+(def: super|r
+  (s.Syntax Super-Syntax)
+  (p.alt method|r
+         class|r))
+
+(def: (super|w g!return)
+  (-> Code Super-Syntax Code)
+  (sum.either (method|w g!return)
+              (class|w g!return)))
+
+(def: (super|c export protocol)
+  (-> Bool cs.Declaration (| Method-Syntax Class-Syntax) (Meta Code))
+  (sum.either (method|c export protocol)
+              (class|c export protocol)))
+
 (syntax: #export (protocol: [export csr.export]
                    [declaration csr.declaration]
-                   [methods (p.many method|r)])
+                   [supers (p.many super|r)])
   (macro.with-gensyms [g!return]
     (do @
-      [constructors (monad.map @ (method-constructor export declaration) methods)
+      [constructors (monad.map @ (super|c export declaration) supers)
        #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))))
+                        (~+ (list/map (super|w g!return) supers))))
                    constructors)))))
diff --git a/stdlib/test/test/lux/type/object/protocol.lux b/stdlib/test/test/lux/type/object/protocol.lux
index a93f34aab..2017459bd 100644
--- a/stdlib/test/test/lux/type/object/protocol.lux
+++ b/stdlib/test/test/lux/type/object/protocol.lux
@@ -3,10 +3,10 @@
   (lux (data text/format)
        (type (object protocol))))
 
-(type: Counter (Object (Simple Unit Nat)))
+(type: Counter (Object (Method Unit Nat)))
 
 (def: (count [tick return] state)
-  (Method Nat (Simple Unit Nat))
+  (Class Nat (Method Unit Nat))
   (let [state' (n/inc state)]
     [(return state') state']))
 
@@ -48,7 +48,7 @@
   (read [] a))
 
 (def: (readM [tick return] state)
-  (All [s] (Method s (Simple Unit s)))
+  (All [s] (Class s (Method Unit s)))
   [(return state) state])
 
 (protocol: (Add n)
@@ -61,7 +61,7 @@
 
 (do-template [<name> <op>]
   [(def: (<name> [diff return] state)
-     (Method Nat (Simple Nat Unit))
+     (Class Nat (Method Nat Unit))
      [(return []) (<op> diff state)])]
 
   [+M n/+]
@@ -70,45 +70,60 @@
   [/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: addM
+  (Class Nat (Add Nat))
+  (alt +M -M))
+
+(def: mulM
+  (Class Nat (Mul Nat))
+  (alt *M /M))
+
+(type: (Number n)
+  ($_ Alt
+      (Read n)
+      (Add n)
+      (Mul n)))
+
+## TODO: Fix when new-luxc is the official compiler.
+## (protocol: (Number n)
+##   (^read (Read n))
+##   (^add (Add n))
+##   (^mul (Mul n)))
+
+(def: numberM
+  (Class Nat (Number Nat))
+  ($_ alt
+      readM
+      addM
+      mulM))
+
+(type: NatO (Object (Number Nat)))
 
 (def: numberO
-  (Object (Number Nat))
-  (object numberM +0))
+  NatO
+  (object numberM +1))
+
+(def: _test2
+  [Nat NatO]
+  (numberO (+0 (read []))))
+
+(def: _test3
+  [Unit NatO]
+  (numberO (+1 (+0 (+ +123)))))
+
+(def: _test4
+  [Unit NatO]
+  (numberO (+1 (+1 (* +123)))))
+
+## TODO: Fix when new-luxc is the official compiler.
+## (def: _test2
+##   [Nat NatO]
+##   (numberO (^read (read []))))
+
+## (def: _test3
+##   [Unit NatO]
+##   (numberO (^add (+ +123))))
+
+## (def: _test4
+##   [Unit NatO]
+##   (numberO (^mul (* +123))))