Added support for row polymorphism.

7 files changed, 450 insertions, 5 deletions

diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux
index 5cb1d3894..2b68b7e89 100644
--- a/stdlib/source/library/lux/meta.lux
+++ b/stdlib/source/library/lux/meta.lux
@@ -368,14 +368,20 @@
 
 (def .public (export name)
   (-> Symbol (Meta Definition))
-  (do ..monad
-    [definition (..definition name)]
+  (do [! ..monad]
+    [name (..normal name)
+     definition (..definition name)]
     (when definition
       {.#Definition definition}
       (let [[exported? def_type def_value] definition]
         (if exported?
           (in definition)
-          (failure (all text#composite "Definition is not an export: " (symbol#encoded name)))))
+          (do !
+            [.let [[expected _] name]
+             actual ..current_module_name]
+            (if (text#= expected actual)
+              (in definition)
+              (failure (all text#composite "Definition is not an export: " (symbol#encoded name)))))))
 
       {.#Type [exported? type labels]}
       (if exported?
diff --git a/stdlib/source/library/lux/meta/type/row.lux b/stdlib/source/library/lux/meta/type/row.lux
new file mode 100644
index 000000000..1966a4768
--- /dev/null
+++ b/stdlib/source/library/lux/meta/type/row.lux
@@ -0,0 +1,217 @@
+... https://en.wikipedia.org/wiki/Row_polymorphism
+(.require
+ [library
+  [lux (.except macro type the has revised)
+   [abstract
+    ["[0]" monad (.only do)]]
+   [control
+    ["?" parser (.use "[1]#[0]" monad)]
+    ["[0]" maybe (.use "[1]#[0]" monad)]
+    ["[0]" exception (.only Exception)]]
+   [data
+    ["[0]" product]
+    ["[0]" text (.only)
+     ["%" \\format]]
+    [collection
+     ["[0]" list (.use "[1]#[0]" monad mix)]
+     ["[0]" dictionary (.only Dictionary)]
+     ["[0]" set]]]
+   [math
+    [number
+     ["n" nat]]]
+   ["[0]" meta (.only)
+    ["[0]" symbol]
+    ["[0]" type]
+    ["[0]" code (.only)
+     ["?[1]" \\parser (.only Parser)]]
+    ["[0]" macro (.only with_symbols)
+     [vocabulary (.only vocabulary)]
+     [syntax (.only syntax)
+      ["[0]" export]]]]]])
+
+(vocabulary [.public Slot]
+            [.public slot]
+            [.private macro]
+            [.private by_name])
+
+(.type .public (Row content extra)
+  (Record
+   [#content content
+    #extra extra]))
+
+(def declaration
+  (Parser [Text (List Text)])
+  (all ?.either
+       (?.and ?code.local (?#in (list)))
+       (?code.form (?.and ?code.local (?.some ?code.local)))
+       ))
+
+(def un_paired
+  (All (_ value)
+    (-> (List [value value])
+        (List value)))
+  (|>> (list#each (function (_ [left right])
+                    (list left right)))
+       list#conjoint))
+
+(def record
+  (Parser (List [Text Code]))
+  (?code.tuple (?.many (?.and ?code.local ?code.any))))
+
+(def super
+  (Parser Code)
+  ?code.any)
+
+(def definition
+  (Parser [(Maybe Code) (List [Text Code])])
+  (all ?.either
+       (?.and (?#in {.#None}) ..record)
+       (?.and (?#each maybe#in ..super) ..record)
+       ))
+
+(def row_module (symbol.module (symbol ..Row)))
+(def row_short (symbol.short (symbol ..Row)))
+
+(def (nesting it)
+  (-> Type Nat)
+  (when it
+    {.#Named _ it}
+    (nesting it)
+
+    {.#ExQ (list) un_quantified}
+    (when (type.flat_application un_quantified)
+      [{.#Named [..row_module ..row_short] _} _]
+      1
+
+      [super _]
+      (++ (nesting super)))
+
+    _
+    0))
+
+(exception.def .public (cannot_repeat_slot_names slots)
+  (Exception (List Text))
+  (exception.report
+   (list ["Slots" (exception.listing %.text slots)])))
+
+(def (unique_slots? it)
+  (-> (List Text) Bit)
+  (|> it
+      (set.of_list text.hash)
+      set.size
+      (n.= (list.size it))))
+
+(def .public type
+  (syntax (_ [[export_policy [name parameters]] (export.parser ..declaration)
+              [super slots] ..definition])
+    (let [slot_names (list#each product.left slots)]
+      (if (unique_slots? slot_names)
+        (do [! meta.monad]
+          [.let [parameters (list#each code.local parameters)]
+           name' (macro.symbol name)
+           slots' (monad.each ! (function (_ [slot type])
+                                  (do !
+                                    [slot' (macro.symbol slot)]
+                                    (in [slot' type])))
+                              slots)
+           :super: (when super
+                     {.#Some super}
+                     (do !
+                       [super (meta.eval Type
+                                         (` (type_literal (, super))))]
+                       (in {.#Some (as Type super)}))
+
+                     _
+                     (in {.#None}))]
+          (with_symbols [g!_ g!&]
+            (let [self (` (Row ((, name') (,* parameters))
+                               (, g!&)))]
+              (in (list.partial (` (.type (, export_policy) ((, name') (,* parameters))
+                                     (Record
+                                      [(,* (un_paired slots'))])))
+                                (` (.type (, export_policy) ((, (code.local name)) (,* parameters))
+                                     (Ex ((, g!_) (, g!&))
+                                       (, (when super
+                                            {.#Some super}
+                                            (` ((, super) (, self)))
+
+                                            _
+                                            self)))))
+                                (list#each (function (_ [[row_slot _] [record_slot _]])
+                                             (` (def (, export_policy) (, (code.local row_slot))
+                                                  (..slot
+                                                   (syntax ((, g!_) [])
+                                                     (at meta.monad (,' in)
+                                                         (list (,* (list.repeated (|> :super:
+                                                                                      (maybe#each nesting)
+                                                                                      (maybe.else 0))
+                                                                                  (` (` ..#extra))))
+                                                               (` ..#content)
+                                                               (` (, record_slot)))))))))
+                                           (list.zipped_2 slots slots'))
+                                )))))
+        (meta.lifted (exception.except ..cannot_repeat_slot_names [slot_names]))))))
+
+(def .public the
+  (syntax (_ [slot ?code.symbol
+              row ?code.any])
+    (do meta.monad
+      [slot (by_name slot)
+       path ((macro.function slot) (list))]
+      (in (list (` (.the [(,* path)] (, row))))))))
+
+(def .public has
+  (syntax (_ [slot ?code.symbol
+              value ?code.any
+              row ?code.any])
+    (do meta.monad
+      [slot (by_name slot)
+       path ((macro.function slot) (list))]
+      (in (list (` (.has [(,* path)] (, value) (, row))))))))
+
+(def .public revised
+  (syntax (_ [slot ?code.symbol
+              revision ?code.any
+              row ?code.any])
+    (do meta.monad
+      [slot (by_name slot)
+       path ((macro.function slot) (list))]
+      (in (list (` (.revised [(,* path)] (, revision) (, row))))))))
+
+(exception.def .public (missing_level it)
+  (Exception Nat)
+  (exception.report
+   (list ["Level" (%.nat it)])))
+
+(def .public row
+  (syntax (_ [slots (?code.tuple (?.many (?.and ?code.symbol ?code.any)))])
+    (do [! meta.monad]
+      [record (monad.each ! (function (_ [slot value])
+                              (do !
+                                [slot (by_name slot)
+                                 path ((macro.function slot) (list))
+                                 .let [nesting (n.- 2 (list.size path))
+                                       slot (maybe.trusted (list.last path))]]
+                                (in [nesting [slot value]])))
+                          slots)
+       .let [levels (list#mix (function (_ [nesting slot,value] levels)
+                                (dictionary.revised' nesting
+                                                     (list)
+                                                     (|>> (list.partial slot,value))
+                                                     levels))
+                              (is (Dictionary Nat (List [Code Code]))
+                                  (dictionary.empty n.hash))
+                              record)]
+       row (monad.mix ! (function (_ level extra)
+                          (when (dictionary.value level levels)
+                            {.#Some record}
+                            (in (` [..#content [(,* (un_paired record))]
+                                    ..#extra (, extra)]))
+                            
+                            {.#None}
+                            (meta.lifted (exception.except ..missing_level [level]))))
+                      (` [])
+                      (|> (dictionary.size levels)
+                          list.indices
+                          list.reversed))]
+      (in (list row)))))
diff --git a/stdlib/source/test/lux/meta/type.lux b/stdlib/source/test/lux/meta/type.lux
index 67119dd60..e4c8ad2ea 100644
--- a/stdlib/source/test/lux/meta/type.lux
+++ b/stdlib/source/test/lux/meta/type.lux
@@ -42,7 +42,8 @@
   ["[1][0]" resource]
   ["[1][0]" unit]
   ["[1][0]" variance]
-  ["[1][0]" poly]])
+  ["[1][0]" poly]
+  ["[1][0]" row]])
 
 (def !expect
   (template (_ <pattern> <value>)
@@ -572,4 +573,5 @@
            /unit.test
            /variance.test
            /poly.test
+           /row.test
            )))
diff --git a/stdlib/source/test/lux/meta/type/row.lux b/stdlib/source/test/lux/meta/type/row.lux
new file mode 100644
index 000000000..49988cc33
--- /dev/null
+++ b/stdlib/source/test/lux/meta/type/row.lux
@@ -0,0 +1,146 @@
+(.require
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only do)]]
+   [control
+    ["[0]" try]
+    ["[0]" exception]]
+   [data
+    ["[0]" text]]
+   [math
+    ["[0]" random (.only Random)]
+    [number
+     ["n" nat]]]
+   [meta
+    ["[0]" code (.only)
+     ["<[1]>" \\parser]]
+    [macro
+     [syntax (.only syntax)]
+     ["[0]" expansion]
+     ["[0]" template]]]
+   [test
+    ["_" property (.only Test)]]
+   [world
+    [time
+     ["[0]" instant (.only Instant)]
+     ["[0]" duration (.only Duration)]]]]]
+ [\\library
+  ["[0]" /]])
+
+(/.type .public Mortal
+  [@birth Instant
+   @life_span (Maybe Duration)])
+
+(/.type Human
+  Mortal
+  [@name Text])
+
+(/.type (TransHuman id)
+  Human
+  [@id id])
+
+(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 [<slot>]
+  (def repeat_slot_error
+    (macro_error
+     (/.type Bad_Row
+       [<slot> Bit
+        <slot> Nat]))))
+
+(def .public test
+  Test
+  (<| (_.covering /._)
+      (_.for [/.Row])
+      (do [! random.monad]
+        [dummy_birth random.instant
+         expected_birth (random.only (|>> (same? dummy_birth) not)
+                                     random.instant)
+         expected_life_span (random.maybe random.duration)
+
+         dummy_name (random.upper_case 1)
+         expected_name (random.upper_case 2)
+
+         dummy_id random.nat
+         expected_id (random.only (|>> (n.= dummy_id) not) random.nat)])
+      (all _.and
+           (_.coverage [/.type /.row]
+             (exec
+               (is Mortal
+                   (/.row [@birth expected_birth
+                           @life_span expected_life_span]))
+               (is Human
+                   (/.row [@name expected_name
+                           @birth expected_birth
+                           @life_span expected_life_span]))
+               (is (TransHuman Nat)
+                   (/.row [@id expected_id
+                           @name expected_name
+                           @birth expected_birth
+                           @life_span expected_life_span]))
+               true))
+           (_.coverage [/.cannot_repeat_slot_names]
+             (text.contains? (the exception.#label /.cannot_repeat_slot_names)
+                             repeat_slot_error))
+           (_.coverage [/.missing_level]
+             (and (|> (/.row [@name expected_name])
+                      macro_error
+                      (text.contains? (the exception.#label /.missing_level)))
+                  (|> (/.row [@id expected_id])
+                      macro_error
+                      (text.contains? (the exception.#label /.missing_level)))
+                  (|> (/.row [@id expected_id
+                              @name expected_name])
+                      macro_error
+                      (text.contains? (the exception.#label /.missing_level)))
+                  (|> (/.row [@id expected_id
+                              @birth expected_birth
+                              @life_span expected_life_span])
+                      macro_error
+                      (text.contains? (the exception.#label /.missing_level)))))
+           (_.for [/.Slot /.slot]
+                  (all _.and
+                       (_.coverage [/.the]
+                         (and (|> (/.row [@birth expected_birth
+                                          @life_span expected_life_span])
+                                  (is Mortal)
+                                  (/.the @birth)
+                                  (same? expected_birth))
+                              (|> (/.row [@name expected_name
+                                          @birth expected_birth
+                                          @life_span expected_life_span])
+                                  (is Human)
+                                  (/.the @name)
+                                  (same? expected_name))
+                              (|> (/.row [@id expected_id
+                                          @name expected_name
+                                          @birth expected_birth
+                                          @life_span expected_life_span])
+                                  (is (TransHuman Nat))
+                                  (/.the @id)
+                                  (same? expected_id))))
+                       (_.coverage [/.has]
+                         (|> (/.row [@birth dummy_birth
+                                     @life_span expected_life_span])
+                             (is Mortal)
+                             (/.has @birth expected_birth)
+                             (/.the @birth)
+                             (same? expected_birth)))
+                       (_.coverage [/.revised]
+                         (|> (/.row [@birth dummy_birth
+                                     @life_span expected_life_span])
+                             (is Mortal)
+                             (/.revised @birth (function (_ _) expected_birth))
+                             (/.the @birth)
+                             (same? expected_birth)))
+                       ))
+           )))
diff --git a/stdlib/source/test/lux/test.lux b/stdlib/source/test/lux/test.lux
index 2ba71ac51..6400db17f 100644
--- a/stdlib/source/test/lux/test.lux
+++ b/stdlib/source/test/lux/test.lux
@@ -5,11 +5,13 @@
     ["_" property (.only Test)]]]]
  ["[0]" /
   ["[1][0]" coverage]
+  ["[1][0]" tally]
   ["[1][0]" property]])
 
 (def .public test
   Test
   (all _.and
        /coverage.test
+       /tally.test
        /property.test
        ))
diff --git a/stdlib/source/test/lux/test/property.lux b/stdlib/source/test/lux/test/property.lux
index 67dd9c7e1..8a1fa2f0d 100644
--- a/stdlib/source/test/lux/test/property.lux
+++ b/stdlib/source/test/lux/test/property.lux
@@ -42,7 +42,7 @@
          (in (do async.monad
                [[success_tally success_message] (unit.test expected_message/0 true)
                 [failure_tally failure_message] (unit.test expected_message/0 false)]
-               (unit.coverage [unit.test tally.Tally]
+               (unit.coverage [unit.test]
                  (and (text.ends_with? (%.text expected_message/0) success_message)
                       (text.ends_with? (%.text expected_message/0) failure_message)
                       (and (n.= 1 (the tally.#successes success_tally))
diff --git a/stdlib/source/test/lux/test/tally.lux b/stdlib/source/test/lux/test/tally.lux
new file mode 100644
index 000000000..c1d43ad79
--- /dev/null
+++ b/stdlib/source/test/lux/test/tally.lux
@@ -0,0 +1,72 @@
+(.require
+ [library
+  [lux (.except)
+   [abstract
+    [monad (.only do)]]
+   [data
+    [collection
+     ["[0]" set (.use "[1]#[0]" equivalence)]]]
+   [math
+    ["[0]" random]
+    [number
+     ["n" nat]]]
+   [meta
+    ["[0]" symbol]]
+   [test
+    ["_" property (.only Test)]]]]
+ [\\library
+  ["[0]" /]]
+ [///
+  [meta
+   ["[0]T" symbol]]])
+
+(def .public test
+  Test
+  (<| (_.covering /._)
+      (_.for [/.Tally])
+      (do [! random.monad]
+        [left (symbolT.random 1 1)
+         right (symbolT.random 2 2)
+         expected_successes random.nat
+         expected_failures random.nat])
+      (all _.and
+           (_.coverage [/.empty]
+             (and (n.= 0 (the /.#successes /.empty))
+                  (n.= 0 (the /.#failures /.empty))
+                  (n.= 0 (set.size (the /.#expected /.empty)))
+                  (n.= 0 (set.size (the /.#actual /.empty)))))
+           (_.coverage [/.success]
+             (and (n.= 1 (the /.#successes /.success))
+                  (n.= 0 (the /.#failures /.success))
+                  (n.= 0 (set.size (the /.#expected /.success)))
+                  (n.= 0 (set.size (the /.#actual /.success)))))
+           (_.coverage [/.failure]
+             (and (n.= 0 (the /.#successes /.failure))
+                  (n.= 1 (the /.#failures /.failure))
+                  (n.= 0 (set.size (the /.#expected /.failure)))
+                  (n.= 0 (set.size (the /.#actual /.failure)))))
+           (_.coverage [/.and]
+             (and (let [it (/.and /.success /.success)]
+                    (and (n.= 2 (the /.#successes it))
+                         (n.= 0 (the /.#failures it))))
+                  (let [it (/.and /.failure /.failure)]
+                    (and (n.= 0 (the /.#successes it))
+                         (n.= 2 (the /.#failures it))))
+                  (let [it (/.and /.success /.failure)]
+                    (and (n.= 1 (the /.#successes it))
+                         (n.= 1 (the /.#failures it))))
+                  (let [custom [/.#successes expected_successes
+                                /.#failures expected_failures
+                                /.#expected (set.of_list symbol.hash (list left))
+                                /.#actual (set.of_list symbol.hash (list right))]]
+                    (and (let [it (/.and /.success custom)]
+                           (and (n.= (++ expected_successes) (the /.#successes it))
+                                (n.= expected_failures (the /.#failures it))
+                                (set#= (the /.#expected custom) (the /.#expected it))
+                                (set#= (the /.#actual custom) (the /.#actual it))))
+                         (let [it (/.and custom /.failure)]
+                           (and (n.= expected_successes (the /.#successes it))
+                                (n.= (++ expected_failures) (the /.#failures it))
+                                (set#= (the /.#expected custom) (the /.#expected it))
+                                (set#= (the /.#actual custom) (the /.#actual it))))))))
+           )))