Added support for predicate-based polymorphism.

9 files changed, 400 insertions, 51 deletions

diff --git a/stdlib/source/library/lux/control/function/polymorphism/predicate.lux b/stdlib/source/library/lux/control/function/polymorphism/predicate.lux
new file mode 100644
index 000000000..4ae4ca483
--- /dev/null
+++ b/stdlib/source/library/lux/control/function/polymorphism/predicate.lux
@@ -0,0 +1,130 @@
+... https://en.wikipedia.org/wiki/Predicate_dispatch
+(.require
+ [library
+  [lux (.except def)
+   [abstract
+    [monad (.only do)]]
+   [control
+    ["?" parser (.use "[1]#[0]" monad)]]
+   [data
+    ["[0]" product]
+    ["[0]" text (.use "[1]#[0]" equivalence)]
+    [collection
+     ["[0]" list (.use "[1]#[0]" functor)]]]
+   ["[0]" meta (.only)
+    ["[0]" static]
+    ["[0]" code (.only)
+     ["?[1]" \\parser (.only Parser)]]
+    ["[0]" macro (.only with_symbols)
+     ["[0]" context]
+     [syntax (.only syntax)
+      ["[0]" export]]]]]]
+ [///
+  ["//" mixin]])
+
+(type Polymorphism
+  (Record
+   [#function Text
+    #quantifications (List Code)
+    #inputs (List Code)
+    #output Code
+    #default Code
+    #export_policy Code
+    #scenarios (List Code)]))
+
+(context.def [stack expression declaration] Polymorphism)
+
+(type Signature
+  (Record
+   [#name Text
+    #next Text
+    #parameters (List Code)]))
+
+(.def signature
+  (Parser Signature)
+  (?code.form
+   (all ?.and
+        ?code.local
+        ?code.local
+        (?.many ?code.any))))
+
+(.def (quoted it)
+  (-> Code Code)
+  (` ((,' .,') (, it))))
+
+(.def .public def
+  (syntax (_ [[export_policy signature quantifications inputs output default methods]
+              (export.parser
+               (all ?.and
+                    ..signature
+                    (?code.tuple (?.some ?code.any))
+                    (?code.tuple (?.many ?code.any))
+                    ?code.any
+                    ?code.any
+                    (?.some ?code.any)))])
+    (<| (with_symbols [g!self g!_ g!scenarios g!scenario g!mixin])
+        (..declaration [#function (the #name signature)
+                        #quantifications quantifications
+                        #inputs inputs
+                        #output output
+                        #default default
+                        #export_policy export_policy
+                        #scenarios (list)])
+        (let [name (quoted (code.local (the #name signature)))
+              next (quoted (code.local (the #next signature)))
+              parameters (list#each quoted (the #parameters signature))
+              [@ _] (symbol .._)
+
+              g!self (quoted g!self)])
+        (` (these (,* methods)
+
+                  (static.expansion
+                   (do meta.monad
+                     [[(, g!_) (, g!_) (, g!_) (, g!_) (, g!_) (, g!_) (, g!scenarios)]
+                      (context.search' (|>> product.left
+                                            (at text.equivalence (,' =) (, (code.text (the #name signature)))))
+                                       [("lux in-module" (, (code.text @)) ..stack)
+                                        (symbol ..stack)])]
+                     (at meta.monad (,' in)
+                         (list (` (.def (, export_policy) (, name)
+                                    (, (quoted (` (<| (,* quantifications)
+                                                      (-> (,* inputs) (, output))))))
+                                    (let [(, (quoted g!mixin)) (is (, (quoted (` (<| (,* quantifications)
+                                                                                     (-> [(,* inputs)] (, output))))))
+                                                                   (//.fixed (all //.mixed
+                                                                                  ((,' .,*) (, g!scenarios))
+                                                                                  (is (, (quoted (` (<| (,* quantifications)
+                                                                                                        (//.Mixin [(,* inputs)] (, output))))))
+                                                                                      (function ((, g!self) (, next) (, name) [(,* parameters)])
+                                                                                        (, (quoted default))))
+                                                                                  )))]
+                                      (function ((, name) (,* parameters))
+                                        ((, (quoted g!mixin)) [(,* parameters)])))))))))
+                  )))))
+
+(.def .public method
+  (syntax (_ [[signature predicate body]
+              (all ?.and
+                   ..signature
+                   ?code.any
+                   ?code.any)])
+    (do [! meta.monad]
+      [.let [criterion (is (-> Polymorphism Bit)
+                           (|>> (the #function)
+                                (text#= (the #name signature))))]
+       it (context.search criterion ..stack)]
+      (with_symbols [g!self]
+        (do !
+          [_ (context.revised {.#Some criterion}
+                              (revised #scenarios (|>> {.#Item (` (//.advice (function ((, g!self) [(,* (the #parameters signature))])
+                                                                               (, predicate))
+                                                                             (, g!self)))}))
+                              ..stack)]
+          (in (list (` (.def (, (the #export_policy it)) (, g!self)
+                         (<| (,* (the #quantifications it))
+                             (//.Mixin [(,* (the #inputs it))] (, (the #output it))))
+                         (function ((, g!self)
+                                    (, (code.local (the #next signature)))
+                                    (, (code.local (the #name signature)))
+                                    [(,* (the #parameters signature))])
+                           (, body)))))))))))
diff --git a/stdlib/source/library/lux/control/function/polymorphism/type.lux b/stdlib/source/library/lux/control/function/polymorphism/type.lux
index ffa657330..ed17649db 100644
--- a/stdlib/source/library/lux/control/function/polymorphism/type.lux
+++ b/stdlib/source/library/lux/control/function/polymorphism/type.lux
@@ -6,8 +6,7 @@
    [control
     ["?" parser (.use "[1]#[0]" monad)]]
    [data
-    ["[0]" text (.use "[1]#[0]" equivalence)
-     ["%" \\format]]
+    ["[0]" text (.use "[1]#[0]" equivalence)]
     [collection
      ["[0]" list (.use "[1]#[0]" functor)]]]
    ["[0]" meta (.only)
@@ -39,8 +38,8 @@
                     (?.many ?code.any)))])
     (<| (do meta.monad
           [@ meta.current_module_name
-           g!interface (macro.symbol (%.symbol [@ name]))
-           g!method (macro.symbol (%.symbol [@ name]))])
+           g!interface (macro.symbol name)
+           g!method (macro.symbol name)])
         (with_symbols [g!_ g!inputs])
         (..declaration [#name name #export_policy export_policy #interface g!interface #method g!method])
         (let [name (code.local name)
diff --git a/stdlib/source/library/lux/meta/macro/context.lux b/stdlib/source/library/lux/meta/macro/context.lux
index 9db9ef978..55faa9ef0 100644
--- a/stdlib/source/library/lux/meta/macro/context.lux
+++ b/stdlib/source/library/lux/meta/macro/context.lux
@@ -1,10 +1,11 @@
 (.require
  [library
-  [lux (.except def global)
+  [lux (.except def global revised)
    [abstract
     [monad (.only do)]]
    [control
     ["?" parser]
+    ["[0]" try (.only Try) (.use "[1]#[0]" functor)]
     ["[0]" exception (.only Exception)]
     ["[0]" maybe]
     [function
@@ -15,19 +16,32 @@
      ["[0]" list (.only)
       ["[0]" property]]]]
    ["[0]" meta (.only)
+    [type (.only sharing by_example)]
     ["[0]" symbol (.use "[1]#[0]" codec)]
     ["[0]" code (.only)
      ["?[1]" \\parser]]]]]
  ["[0]" // (.only)
-  [syntax (.only syntax)]])
+  [syntax (.only syntax)
+   ["[0]" export]]])
 
 (type .public Stack
   List)
 
-(exception.def (no_definition it)
-  (Exception Symbol)
-  (exception.report
-   (list ["Definition" (symbol#encoded it)])))
+(.def Stack'
+  (template (_ value)
+    [[(Stack value) Symbol]]))
+
+(with_template [<name> <type> <format>]
+  [(exception.def .public (<name> it)
+     (Exception <type>)
+     (exception.report
+      (list ["Definition" (<format> it)])))]
+
+  [not_a_definition Symbol symbol#encoded]
+  [not_a_global Symbol symbol#encoded]
+  [not_a_module Text text.format]
+  [no_example Symbol symbol#encoded]
+  )
 
 (.def (global it)
   (-> Symbol (Meta Any))
@@ -43,12 +57,12 @@
       (in it)
       
       {.#None}
-      (meta.failure (exception.error ..no_definition [it])))))
+      (meta.failure (exception.error ..not_a_definition [it])))))
 
 (exception.def .public no_active_context)
 
-(.def .public (peek' _ context)
-  (All (_ a) (-> (Stack a) Symbol (Meta a)))
+(.def .public (peek' [_ context])
+  (All (_ a) (-> (Stack' a) (Meta a)))
   (do meta.monad
     [stack (..global context)]
     (when (|> stack
@@ -62,12 +76,10 @@
 
 (.def .public peek
   (syntax (_ [g!it (at ?.monad each code.symbol ?code.global)])
-    (in (list (` (..peek' (, g!it) (.symbol (, g!it))))))))
-
-(exception.def .public no_example)
+    (in (list (` (..peek' [(, g!it) (.symbol (, g!it))]))))))
 
-(.def .public (search' ? _ context)
-  (All (_ a) (-> (Predicate a) (Stack a) Symbol (Meta a)))
+(.def .public (search' ? [_ context])
+  (All (_ a) (-> (Predicate a) (Stack' a) (Meta a)))
   (do meta.monad
     [stack (..global context)]
     (when (|> stack
@@ -77,84 +89,169 @@
       (in (as_expected it))
       
       {.#None}
-      (meta.failure (exception.error ..no_example [])))))
+      (meta.failure (exception.error ..no_example [context])))))
 
 (.def .public search
   (syntax (_ [g!? ?code.any
               g!context (at ?.monad each code.symbol ?code.global)])
-    (in (list (` (..search' (, g!?) (, g!context) (.symbol (, g!context))))))))
+    (in (list (` (..search' (, g!?) [(, g!context) (.symbol (, g!context))]))))))
 
-(.def (alter on_definition [@ context])
-  (-> (-> Definition Definition) Symbol (Meta Any))
+(.def (alter on_definition [_ definition])
+  (All (_ value)
+    (-> (-> Symbol Definition (Try Definition)) (Stack' value)
+        (Meta Any)))
   (function (_ lux)
-    (let [on_global (is (-> Global Global)
+    (let [[@ context] definition
+          on_global (is (-> Global (Try Global))
                         (function (_ it)
                           (when it
                             {.#Definition it}
-                            {.#Definition (on_definition it)}
+                            (try#each (|>> {.#Definition}) (on_definition definition it))
                             
                             _
-                            it)))
-          on_globals (is (-> (property.List Global) (property.List Global))
-                         (property.revised context on_global))
-          on_module (is (-> Module Module)
-                        (revised .#definitions on_globals))]
-      {.#Right [(revised .#modules (property.revised @ on_module) lux)
-                []]})))
-
-(.def .public (push' top _)
-  (All (_ a) (-> a (Stack a) Symbol (Meta Any)))
-  (alter (function (_ [exported? type stack])
+                            (exception.except ..not_a_definition [definition]))))
+          on_globals (is (-> (property.List Global) (Try (property.List Global)))
+                         (function (_ globals)
+                           (when (property.value context globals)
+                             {.#Some global}
+                             (try#each (function (_ global)
+                                         (property.has context global globals))
+                                       (on_global global))
+                             
+                             {.#None}
+                             (exception.except ..not_a_global [definition]))))
+          on_module (is (-> Module (Try Module))
+                        (function (_ module)
+                          (try#each (function (_ globals)
+                                      (has .#definitions globals module))
+                                    (on_globals (the .#definitions module)))))
+          on_lux (is (-> Lux (Try Lux))
+                     (function (_ lux)
+                       (when (property.value @ (the .#modules lux))
+                         {.#Some module}
+                         (try#each (function (_ module)
+                                     (.revised .#modules (property.has @ module) lux))
+                                   (on_module module))
+                         
+                         {.#None}
+                         (exception.except ..not_a_module [@]))))]
+      (when (on_lux lux)
+        {try.#Success it}
+        {try.#Success [it []]}
+        
+        {try.#Failure error}
+        ((meta.failure error) lux)))))
+
+(.def .public (push' top)
+  (All (_ value)
+    (-> value (Stack' value)
+        (Meta Any)))
+  (alter (function (_ _ [exported? type stack])
            (|> stack
                (as (Stack Any))
                {.#Item top}
                (is (Stack Any))
-               [exported? type]))))
+               [exported? type]
+               {try.#Success}))))
 
 (.def .public push
   (syntax (_ [g!it ?code.any
               g!context (at ?.monad each code.symbol ?code.global)])
-    (in (list (` (..push' (, g!it) (, g!context) (.symbol (, g!context))))))))
+    (in (list (` (..push' (, g!it) [(, g!context) (.symbol (, g!context))]))))))
+
+(.def .public (revised' ? !)
+  (All (_ value)
+    (-> (Maybe (Predicate value)) (-> value value) (Stack' value)
+        (Meta Any)))
+  (alter (function (_ @ [exported? type stack])
+           (let [stack (sharing [value]
+                         (is (-> value value)
+                             !)
+                         (is (Stack value)
+                             (as_expected stack)))]
+             (when ?
+               {.#Some ?}
+               (do try.monad
+                 [stack (loop (again [stack stack])
+                          (when stack
+                            (list.partial top stack')
+                            (if (? top)
+                              (in (list.partial (! top) stack'))
+                              (do try.monad
+                                [stack' (again stack')]
+                                (in (list.partial top stack'))))
+
+                            _
+                            (exception.except ..no_example [@])))]
+                 (in [exported? type stack]))
+               
+               {.#None}
+               (when stack
+                 (list.partial top stack')
+                 (|> stack'
+                     (list.partial (! top))
+                     (is (Stack Any))
+                     [exported? type]
+                     {try.#Success})
+                 
+                 _
+                 (exception.except ..no_example [@])))))))
+
+(.def .public revised
+  (syntax (_ [g!predicate ?code.any
+              g!revision ?code.any
+              g!context (at ?.monad each code.symbol ?code.global)])
+    (in (list (` (..revised' (, g!predicate)
+                             (, g!revision)
+                             [(, g!context) (.symbol (, g!context))]))))))
 
 (.def .public pop''
-  (-> Symbol (Meta Any))
-  (alter (function (_ [exported? type value])
-           [exported? type (let [value (as (Stack Any) value)]
-                             (maybe.else value (list.tail value)))])))
+  (All (_ value) (-> (Stack' value) (Meta Any)))
+  (alter (function (_ _ [exported? type value])
+           (|> (let [value (as (Stack Any) value)]
+                 (maybe.else value (list.tail value)))
+               [exported? type]
+               {try.#Success}))))
 
 (.def .public pop'
   (syntax (_ [expression? ?code.bit
               context ?code.global])
     (do meta.monad
-      [_ (..pop'' context)]
+      [_ (..pop'' [(list) context])]
       (in (if expression?
             (list (' []))
             (list))))))
 
 (.def .public pop
   (syntax (_ [g!context (at ?.monad each code.symbol ?code.global)])
-    (in (list (` (..pop'' (.symbol (, g!context))))))))
+    (in (list (` (..pop'' [(, g!context) (.symbol (, g!context))]))))))
 
 (.def .public def
   (syntax (_ [.let [! ?.monad
                     ?local (at ! each code.local ?code.local)]
-              [$ g!expression g!declaration] (?code.tuple (all ?.and ?code.local ?local ?local))
+
+              [[export_$? $] [export_expression? g!expression] [export_declaration? g!declaration]]
+              (?code.tuple (all ?.and
+                                (export.parser ?code.local)
+                                (export.parser ?local)
+                                (export.parser ?local)))
+              
               context_type ?code.any])
     (do [! meta.monad]
       [@ meta.current_module_name
        .let [g!context (code.symbol [@ $])]]
       (//.with_symbols [g!it g!body g!_]
-        (in (list (` (.def (, (code.local $))
+        (in (list (` (.def (, export_$?) (, (code.local $))
                        (..Stack (, context_type))
                        (list)))
-                  (` (.def ((, g!expression) (, g!it) (, g!body))
+                  (` (.def (, export_expression?) ((, g!expression) (, g!it) (, g!body))
                        (-> (, context_type) Code (Meta Code))
                        (do meta.monad
                          [(, g!_) (..push (, g!it) (, g!context))]
                          ((,' in) (` (let [((,' ,') (, g!body)) ((,' ,) (, g!body))
                                            ((,' ,') (, g!_)) (..pop' #1 (, g!context))]
                                        ((,' ,') (, g!body))))))))
-                  (` (.def ((, g!declaration) (, g!it) (, g!body))
+                  (` (.def (, export_declaration?) ((, g!declaration) (, g!it) (, g!body))
                        (-> (, context_type) Code (Meta (List Code)))
                        (do meta.monad
                          [(, g!_) (..push (, g!it) (, g!context))]
diff --git a/stdlib/source/library/lux/test/coverage.lux b/stdlib/source/library/lux/test/coverage.lux
index efc2644a6..86b1314cc 100644
--- a/stdlib/source/library/lux/test/coverage.lux
+++ b/stdlib/source/library/lux/test/coverage.lux
@@ -25,7 +25,7 @@
                      (` (is Symbol
                             [(, (code.text (symbol.module symbol)))
                              (, (code.text (symbol.short symbol)))]))))]
-    (syntax (_ [name <code>.symbol])
+    (syntax (_ [name <code>.global])
       (do meta.monad
         [_ (meta.export name)]
         (in (list (symbol name)))))))
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index fb2df3a0c..f970099ec 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -52,7 +52,7 @@
   
   ["[1][0]" meta]
   ["[1][0]" program]
-  ["[1][0]" test/property]
+  ["[1][0]" test]
   
   ["[1][0]" world]
 
@@ -1254,7 +1254,7 @@
 
              /meta.test
              /program.test
-             /test/property.test
+             /test.test
 
              /world.test
 
diff --git a/stdlib/source/test/lux/control/function.lux b/stdlib/source/test/lux/control/function.lux
index d87f6f3cd..f4333d520 100644
--- a/stdlib/source/test/lux/control/function.lux
+++ b/stdlib/source/test/lux/control/function.lux
@@ -25,7 +25,8 @@
   ["[1][0]" named]
   ["[1][0]" trampoline]
   ["[1][0]" polymorphism
-   ["[1]/[0]" type]]])
+   ["[1]/[0]" type]
+   ["[1]/[0]" predicate]]])
 
 (def .public test
   Test
@@ -76,4 +77,5 @@
              /named.test
              /trampoline.test
              /polymorphism/type.test
+             /polymorphism/predicate.test
              ))))
diff --git a/stdlib/source/test/lux/control/function/polymorphism/predicate.lux b/stdlib/source/test/lux/control/function/polymorphism/predicate.lux
new file mode 100644
index 000000000..10f608094
--- /dev/null
+++ b/stdlib/source/test/lux/control/function/polymorphism/predicate.lux
@@ -0,0 +1,41 @@
+(.require
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only do)]]
+   [math
+    ["[0]" random (.only Random)]
+    [number
+     ["i" int]]]
+   [test
+    ["_" property (.only Test)]]]]
+ [\\library
+  ["[0]" /]])
+
+(/.def .public (any _ choice positive negative zero)
+  [(All (_ value))] [Int value value value] value
+  zero
+
+  (/.method (any next choice positive negative zero)
+    (i.> +0 choice)
+    positive)
+
+  (/.method (any next choice positive negative zero)
+    (i.< +0 choice)
+    negative)
+  )
+
+(def .public test
+  Test
+  (<| (_.covering /._)
+      (do [! random.monad]
+        [positive random.nat
+         negative random.nat
+         zero random.nat])
+      (all _.and
+           (_.coverage [/.def]
+             (same? zero (any +0 positive negative zero)))
+           (_.coverage [/.method]
+             (and (same? positive (any +1 positive negative zero))
+                  (same? negative (any -1 positive negative zero))))
+           )))
diff --git a/stdlib/source/test/lux/test.lux b/stdlib/source/test/lux/test.lux
new file mode 100644
index 000000000..2ba71ac51
--- /dev/null
+++ b/stdlib/source/test/lux/test.lux
@@ -0,0 +1,15 @@
+(.require
+ [library
+  [lux (.except)
+   [test
+    ["_" property (.only Test)]]]]
+ ["[0]" /
+  ["[1][0]" coverage]
+  ["[1][0]" property]])
+
+(def .public test
+  Test
+  (all _.and
+       /coverage.test
+       /property.test
+       ))
diff --git a/stdlib/source/test/lux/test/coverage.lux b/stdlib/source/test/lux/test/coverage.lux
new file mode 100644
index 000000000..a7407ee6c
--- /dev/null
+++ b/stdlib/source/test/lux/test/coverage.lux
@@ -0,0 +1,65 @@
+(.require
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only do)]]
+   [control
+    ["[0]" try]]
+   [data
+    [collection
+     ["[0]" set]]]
+   [math
+    ["[0]" random (.only Random)]]
+   [meta
+    ["[0]" symbol (.use "[1]#[0]" equivalence)]
+    ["[0]" static]
+    ["[0]" code (.only)
+     ["<[1]>" \\parser]]
+    [macro
+     [syntax (.only syntax)]
+     ["[0]" template]
+     ["[0]" expansion]]]
+   [test
+    ["_" property (.only Test)]]]]
+ [\\library
+  ["[0]" /]])
+
+(def macro_error
+  (syntax (_ [macro <code>.any])
+    (function (_ compiler)
+      (when ((expansion.complete macro) compiler)
+        {try.#Failure error}
+        {try.#Success [compiler (list (code.text error))]}
+        
+        {try.#Success _}
+        {try.#Failure "OOPS!"}))))
+
+(template.with_locals [g!defined g!un_defined]
+  (these (def .public g!defined
+           Nat
+           (static.random_nat))
+         
+         (def .public test
+           Test
+           (<| (_.covering /._)
+               (_.for [/.Coverage])
+               (do [! random.monad]
+                 [module (random.upper_case 1)
+                  first (random.lower_case 2)
+                  second (random.lower_case 3)
+                  dummy (random.lower_case 4)])
+               (all _.and
+                    (`` (_.coverage [/.of]
+                          (and (let [[module _] (symbol .._)
+                                     [_ short] (symbol g!defined)]
+                                 (symbol#= [module short]
+                                           (/.of (,, (template.symbol [.._] [g!defined])))))
+                               (exec
+                                 (macro_error (/.of (,, (template.symbol [.._] [g!un_defined]))))
+                                 true))))
+                    (_.coverage [/.encoded /.decoded]
+                      (let [it (/.decoded module (/.encoded (list first second)))]
+                        (and (set.member? it [module first])
+                             (set.member? it [module second])
+                             (not (set.member? it [module dummy])))))
+                    )))))