Added support for type-based polymorphism.

6 files changed, 175 insertions, 6 deletions

diff --git a/stdlib/source/library/lux/control/function/polymorphism/type.lux b/stdlib/source/library/lux/control/function/polymorphism/type.lux
new file mode 100644
index 000000000..1159bc488
--- /dev/null
+++ b/stdlib/source/library/lux/control/function/polymorphism/type.lux
@@ -0,0 +1,72 @@
+(.require
+ [library
+  [lux (.except def)
+   [abstract
+    [monad (.only do)]]
+   [control
+    ["?" parser (.use "[1]#[0]" monad)]]
+   [data
+    ["[0]" text (.use "[1]#[0]" equivalence)]
+    [collection
+     ["[0]" list (.use "[1]#[0]" functor)]]]
+   ["[0]" meta (.only)
+    ["[0]" code (.only)
+     ["?[1]" \\parser (.only Parser)]]
+    [macro (.only with_symbols)
+     ["[0]" context]
+     [syntax (.only syntax)
+      ["[0]" export]]]
+    [type
+     [implicit (.only a/an)]]]]])
+
+(type Polymorphism
+  (Record
+   [#name Text
+    #interface Code
+    #method Code]))
+
+(context.def [stack expression declaration] Polymorphism)
+
+(.def .public def
+  (syntax (_ [[export_policy name parameters type methods]
+              (export.parser
+               (all ?.and
+                    ?code.local
+                    (?code.tuple (?.many ?code.local))
+                    ?code.any
+                    (?.many ?code.any)))])
+    (<| (with_symbols [g!_ g!interface g!method g!inputs])
+        (..declaration [#name name #interface g!interface #method g!method])
+        (let [name (code.local name)
+              parameters (list#each code.local parameters)])
+        (` (these (type (, export_policy) (, g!interface)
+                    (Interface
+                     (is (All ((, g!_) (,* parameters))
+                           (, type))
+                         (, g!method))))
+                  (.def (, export_policy) (, name)
+                    (syntax ((, g!_) [(, g!inputs) (?.many ?code.any)])
+                      (at meta.monad (,' in)
+                          (list (` (a/an (, g!method) ((,' .,*) (, g!inputs))))))))
+                  (,* methods))))))
+
+(.def method_declaration
+  (Parser [Text (List Code)])
+  (?.either (?code.form (?.and ?code.local (?.some ?code.any)))
+            (?.and ?code.local (?#in (list)))))
+
+(.def .public method
+  (syntax (_ [[[name inputs] specialization body]
+              (all ?.and
+                   ..method_declaration
+                   (?code.tuple (?.many ?code.any))
+                   ?code.any)])
+    (do meta.monad
+      [it (context.search (|>> (the #name) (text#= name)) ..stack)
+       .let [name (code.local name)]]
+      (with_symbols [g!self]
+        (in (list (` (.def .public (, g!self)
+                       ((, (the #interface it)) (,* specialization))
+                       (implementation
+                        (.def ((, (the #method it)) (,* inputs))
+                          (, body)))))))))))
diff --git a/stdlib/source/library/lux/meta/type/poly.lux b/stdlib/source/library/lux/meta/type/poly.lux
index cccc9e518..a98fd211c 100644
--- a/stdlib/source/library/lux/meta/type/poly.lux
+++ b/stdlib/source/library/lux/meta/type/poly.lux
@@ -39,7 +39,7 @@
                                                     (, body)))
                                                  (.as .Type (, g!type))))
                             {.#Right (, g!output)}
-                            ((,' in) (.list (, g!output)))
+                            (at ///.monad (,' in) (.list (, g!output)))
 
                             {.#Left (, g!output)}
                             (///.failure (, g!output))))))))))))
@@ -54,7 +54,8 @@
     (^.with_template [<tag>]
       [{<tag> idx}
        (` {<tag> (, (code.nat idx))})])
-    ([.#Var] [.#Ex])
+    ([.#Var]
+     [.#Ex])
 
     {.#Parameter idx}
     (let [idx (<//>.argument env idx)]
@@ -72,7 +73,8 @@
       [{<tag> left right}
        (` {<tag> (, (code env left))
                  (, (code env right))})])
-    ([.#Function] [.#Apply])
+    ([.#Function]
+     [.#Apply])
 
     (^.with_template [<macro> <tag> <flattener>]
       [{<tag> left right}
@@ -87,4 +89,5 @@
       [{<tag> scope body}
        (` {<tag> (.list (,* (list#each (code env) scope)))
                  (, (code env body))})])
-    ([.#UnivQ] [.#ExQ])))
+    ([.#UnivQ]
+     [.#ExQ])))
diff --git a/stdlib/source/test/lux/control/function.lux b/stdlib/source/test/lux/control/function.lux
index aad5f2ebf..d87f6f3cd 100644
--- a/stdlib/source/test/lux/control/function.lux
+++ b/stdlib/source/test/lux/control/function.lux
@@ -23,7 +23,9 @@
   ["[1][0]" predicate]
   ["[1][0]" variadic]
   ["[1][0]" named]
-  ["[1][0]" trampoline]])
+  ["[1][0]" trampoline]
+  ["[1][0]" polymorphism
+   ["[1]/[0]" type]]])
 
 (def .public test
   Test
@@ -73,4 +75,5 @@
              /variadic.test
              /named.test
              /trampoline.test
+             /polymorphism/type.test
              ))))
diff --git a/stdlib/source/test/lux/control/function/polymorphism/type.lux b/stdlib/source/test/lux/control/function/polymorphism/type.lux
new file mode 100644
index 000000000..a5ed74cca
--- /dev/null
+++ b/stdlib/source/test/lux/control/function/polymorphism/type.lux
@@ -0,0 +1,41 @@
+(.require
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only do)]]
+   [data
+    ["[0]" text (.use "[1]#[0]" equivalence)
+     ["%" \\format]]]
+   [math
+    ["[0]" random]]
+   [test
+    ["_" property (.only Test)]]]]
+ [\\library
+  ["[0]" /]])
+
+(/.def .public format
+  [a]
+  (-> a Text)
+
+  (/.method format
+    [Bit]
+    %.bit)
+
+  (/.method (format it)
+    [Nat]
+    (%.nat it))
+  )
+
+(def .public test
+  Test
+  (<| (_.covering /._)
+      (do [! random.monad]
+        [bit random.bit
+         nat random.nat])
+      (all _.and
+           (_.coverage [/.def /.method]
+             (and (text#= (%.bit bit)
+                          (format bit))
+                  (text#= (%.nat nat)
+                          (format nat))))
+           )))
diff --git a/stdlib/source/test/lux/meta/type.lux b/stdlib/source/test/lux/meta/type.lux
index 3c6872d26..67119dd60 100644
--- a/stdlib/source/test/lux/meta/type.lux
+++ b/stdlib/source/test/lux/meta/type.lux
@@ -41,7 +41,8 @@
   ["[1][0]" refinement]
   ["[1][0]" resource]
   ["[1][0]" unit]
-  ["[1][0]" variance]])
+  ["[1][0]" variance]
+  ["[1][0]" poly]])
 
 (def !expect
   (template (_ <pattern> <value>)
@@ -570,4 +571,5 @@
            /resource.test
            /unit.test
            /variance.test
+           /poly.test
            )))
diff --git a/stdlib/source/test/lux/meta/type/poly.lux b/stdlib/source/test/lux/meta/type/poly.lux
new file mode 100644
index 000000000..e2aa7d03e
--- /dev/null
+++ b/stdlib/source/test/lux/meta/type/poly.lux
@@ -0,0 +1,48 @@
+(.require
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only do)]]
+   [control
+    ["?" parser]]
+   [data
+    ["[0]" bit (.use "[1]#[0]" equivalence)]]
+   [math
+    ["[0]" random]
+    [number
+     ["[0]" nat (.use "[1]#[0]" equivalence)]]]
+   [meta
+    ["[0]" static]
+    ["[0]" type
+     ["?[1]" \\parser]]]
+   [test
+    ["_" property (.only Test)]]]]
+ [\\library
+  ["[0]" /]])
+
+(with_expansions [<bit> (static.random_bit)
+                  <nat> (static.random_nat)]
+  (def constant
+    (/.polytypic constant
+      (`` (all ?.either
+               (,, (with_template [<type> <constant>]
+                     [(do ?.monad
+                        [_ (?type.sub <type>)]
+                        (in (` (is <type>
+                                   <constant>))))]
+
+                     [Bit <bit>]
+                     [Nat <nat>]))
+               ))))
+
+  (def .public test
+    Test
+    (<| (_.covering /._)
+        (do [! random.monad]
+          [])
+        (all _.and
+             (_.coverage [/.polytypic]
+               (and (bit#= <bit> (constant Bit))
+                    (nat#= <nat> (constant Nat))))
+             )))
+  )