Improved error reporting for syntax macros.

8 files changed, 253 insertions, 92 deletions

diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux
index a4fd15bec..c9994aafa 100644
--- a/stdlib/source/test/aedifex.lux
+++ b/stdlib/source/test/aedifex.lux
@@ -21,7 +21,8 @@
    ["#." cli]
    ["#." hash]
    ["#." parser]
-   ["#." pom]])
+   ["#." pom]
+   ["#." repository]])
 
 (def: test
   Test
@@ -41,6 +42,7 @@
       /hash.test
       /parser.test
       /pom.test
+      /repository.test
       ))
 
 (program: args
diff --git a/stdlib/source/test/aedifex/cli.lux b/stdlib/source/test/aedifex/cli.lux
index 0dde0402a..1edfb381f 100644
--- a/stdlib/source/test/aedifex/cli.lux
+++ b/stdlib/source/test/aedifex/cli.lux
@@ -18,8 +18,8 @@
   {#program
    ["." /
     ["/#" // #_
-     ["#" profile]
-     [upload (#+ User Password)]]]})
+     [repository (#+ User Password)]
+     ["#" profile]]]})
 
 (def: compilation
   (Random /.Compilation)
diff --git a/stdlib/source/test/aedifex/parser.lux b/stdlib/source/test/aedifex/parser.lux
index e26240562..12fa349bb 100644
--- a/stdlib/source/test/aedifex/parser.lux
+++ b/stdlib/source/test/aedifex/parser.lux
@@ -29,7 +29,7 @@
      ["#" profile]
      ["#." project (#+ Project)]
      ["#." artifact (#+ Artifact)]
-     ["#." dependency (#+ Repository Dependency)]
+     ["#." dependency (#+ Dependency)]
      ["#." format]]]})
 
 (def: name
diff --git a/stdlib/source/test/aedifex/profile.lux b/stdlib/source/test/aedifex/profile.lux
index d0da1ff2a..10d921f94 100644
--- a/stdlib/source/test/aedifex/profile.lux
+++ b/stdlib/source/test/aedifex/profile.lux
@@ -28,7 +28,8 @@
   {#program
    ["." /
     ["/#" // #_
-     ["#." dependency (#+ Repository Dependency)]
+     [repository (#+ Address)]
+     ["#." dependency (#+ Dependency)]
      ["#." format]]]})
 
 (def: distribution
@@ -103,7 +104,7 @@
   (random.ascii/alpha 1))
 
 (def: repository
-  (Random Repository)
+  (Random Address)
   (random.ascii/alpha 1))
 
 (def: source
diff --git a/stdlib/source/test/aedifex/repository.lux b/stdlib/source/test/aedifex/repository.lux
new file mode 100644
index 000000000..4f96d9329
--- /dev/null
+++ b/stdlib/source/test/aedifex/repository.lux
@@ -0,0 +1,93 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   [abstract
+    ["." hash (#+ Hash)]
+    ["." equivalence (#+ Equivalence)]
+    ["." monad (#+ do)]]
+   [control
+    ["." io]
+    ["." try]
+    ["." exception (#+ exception:)]]
+   [data
+    ["." binary (#+ Binary)]
+    ["." text
+     ["%" format (#+ format)]]
+    [collection
+     ["." dictionary (#+ Dictionary)]]]
+   [math
+    ["." random (#+ Random)]]]
+  [//
+   ["@." artifact]]
+  {#spec
+   ["$." /]}
+  {#program
+   ["." / (#+ Identity)
+    ["/#" // #_
+     ["#." artifact (#+ Version Artifact)
+      ["#/." extension (#+ Extension)]]]]})
+
+(def: identity
+  (Random Identity)
+  (random.and (random.ascii/alpha 10)
+              (random.ascii/alpha 10)))
+
+(def: identity-equivalence
+  (Equivalence Identity)
+  (equivalence.product text.equivalence
+                       text.equivalence))
+
+(def: artifact
+  (-> Version Artifact)
+  (|>> ["com.github.luxlang" "test-artifact"]))
+
+(def: item-hash
+  (Hash [Artifact Extension])
+  (hash.product //artifact.hash
+                text.hash))
+
+(exception: (not-found {artifact Artifact}
+                       {extension Extension})
+  (exception.report
+   ["Artifact" (//artifact.format artifact)]
+   ["Extension" (%.text extension)]))
+
+(exception: (invalid-identity {[user _] Identity})
+  (exception.report
+   ["User" (%.text user)]))
+
+(type: Store
+  (Dictionary [Artifact Extension] Binary))
+
+(def: empty
+  Store
+  (dictionary.new ..item-hash))
+
+(structure: (simulation identity)
+  (-> Identity (/.Simulation Store))
+
+  (def: (on-download artifact extension state)
+    (case (dictionary.get [artifact extension] state)
+      (#.Some content)
+      (exception.return [state content])
+      
+      #.None
+      (exception.throw ..not-found [artifact extension])))
+  (def: (on-upload requester artifact extension content state)
+    (if (:: identity-equivalence = identity requester)
+      (exception.return (dictionary.put [artifact extension] content state))
+      (exception.throw ..invalid-identity [requester]))))
+
+(def: #export test
+  Test
+  (<| (_.covering /._)
+      (do {! random.monad}
+        [valid ..identity
+         invalid (random.filter (|>> (:: identity-equivalence = valid) not)
+                                ..identity)]
+        ($_ _.and
+            (_.with-cover [/.mock /.Simulation]
+              ($/.spec valid (..artifact "1.2.3-YES")
+                       invalid (..artifact "4.5.6-NO")
+                       (/.mock (..simulation valid) ..empty)))
+            ))))
diff --git a/stdlib/source/test/lux/data/collection/set/ordered.lux b/stdlib/source/test/lux/data/collection/set/ordered.lux
index 335eb0226..7257a7f7b 100644
--- a/stdlib/source/test/lux/data/collection/set/ordered.lux
+++ b/stdlib/source/test/lux/data/collection/set/ordered.lux
@@ -1,6 +1,5 @@
 (.module:
   [lux #*
-   ["%" data/text/format (#+ format)]
    ["_" test (#+ Test)]
    [abstract
     [monad (#+ do)]
@@ -9,105 +8,170 @@
      [/
       ["$." equivalence]]}]
    [data
+    ["." bit ("#@." equivalence)]
     [number
      ["n" nat]]
     [collection
      ["." list]]]
    [math
-    ["r" random (#+ Random) ("#@." monad)]]]
+    ["." random (#+ Random) ("#@." monad)]]]
   {1
    ["." / (#+ Set)
     ["." //]]})
 
-(def: gen-nat
-  (r.Random Nat)
-  (|> r.nat
-      (:: r.monad map (n.% 100))))
+(def: size
+  (random.Random Nat)
+  (:: random.monad map (n.% 100) random.nat))
 
-(def: #export (set &order gen-value size)
-  (All [a] (-> (Order a) (Random a) Nat (Random (Set a))))
+(def: #export (random size &order gen-value)
+  (All [a] (-> Nat (Order a) (Random a) (Random (Set a))))
   (case size
     0
-    (r@wrap (/.new &order))
+    (random@wrap (/.new &order))
 
     _
-    (do r.monad
-      [partial (set &order gen-value (dec size))
-       value (r.filter (|>> (/.member? partial) not)
-                       gen-value)]
+    (do random.monad
+      [partial (random (dec size) &order gen-value)
+       value (random.filter (|>> (/.member? partial) not)
+                            gen-value)]
       (wrap (/.add value partial)))))
 
 (def: #export test
   Test
-  (<| (_.context (%.name (name-of /.Set)))
-      ($_ _.and
-          (do r.monad
-            [size gen-nat]
-            ($_ _.and
-                ($equivalence.spec /.equivalence (..set n.order r.nat size))
-                ))
-          (do {! r.monad}
-            [sizeL gen-nat
-             sizeR gen-nat
-             listL (|> (r.set n.hash sizeL gen-nat) (:: ! map //.to-list))
-             listR (|> (r.set n.hash sizeR gen-nat) (:: ! map //.to-list))
-             #let [(^open "/@.") /.equivalence
-                   setL (/.from-list n.order listL)
-                   setR (/.from-list n.order listR)
-                   sortedL (list.sort n.< listL)
-                   minL (list.head sortedL)
-                   maxL (list.last sortedL)]]
-            ($_ _.and
-                (_.test "I can query the size of a set."
-                        (n.= sizeL (/.size setL)))
-                (_.test "Can query minimum value."
-                        (case [(/.min setL) minL]
-                          [#.None #.None]
-                          true
-
-                          [(#.Some reference) (#.Some sample)]
-                          (n.= reference sample)
-
-                          _
-                          false))
-                (_.test "Can query maximum value."
-                        (case [(/.max setL) maxL]
-                          [#.None #.None]
-                          true
-
-                          [(#.Some reference) (#.Some sample)]
-                          (n.= reference sample)
-
-                          _
-                          false))
-                (_.test "Converting sets to/from lists can't change their values."
-                        (|> setL
-                            /.to-list (/.from-list n.order)
-                            (/@= setL)))
-                (_.test "Order is preserved."
-                        (let [listL (/.to-list setL)
-                              (^open "list@.") (list.equivalence n.equivalence)]
-                          (list@= listL
-                                  (list.sort n.< listL))))
-                (_.test "Every set is a sub-set of the union of itself with another."
-                        (let [setLR (/.union setL setR)]
-                          (and (/.sub? setLR setL)
-                               (/.sub? setLR setR))))
-                (_.test "Every set is a super-set of the intersection of itself with another."
-                        (let [setLR (/.intersection setL setR)]
-                          (and (/.super? setLR setL)
-                               (/.super? setLR setR))))
-                (_.test "Union with the empty set leaves a set unchanged."
-                        (/@= setL
-                             (/.union (/.new n.order)
-                                      setL)))
-                (_.test "Intersection with the empty set results in the empty set."
-                        (let [empty-set (/.new n.order)]
-                          (/@= empty-set
-                               (/.intersection empty-set setL))))
-                (_.test "After substracting a set A from another B, no member of A can be a member of B."
-                        (let [sub (/.difference setR setL)]
-                          (not (list.any? (/.member? sub) (/.to-list setR)))))
-                (_.test "Every member of a set must be identifiable."
-                        (list.every? (/.member? setL) (/.to-list setL)))
+  (<| (_.covering /._)
+      (_.with-cover [/.Set])
+      (do {! random.monad}
+        [sizeL ..size
+         sizeR ..size
+         usetL (random.set n.hash sizeL random.nat)
+         non-memberL (random.filter (|>> (//.member? usetL) not)
+                                    random.nat)
+         #let [listL (//.to-list usetL)]
+         listR (|> (random.set n.hash sizeR random.nat) (:: ! map //.to-list))
+         #let [(^open "/@.") /.equivalence
+               setL (/.from-list n.order listL)
+               setR (/.from-list n.order listR)
+               empty (/.new n.order)]]
+        (`` ($_ _.and
+                (_.with-cover [/.equivalence]
+                  ($equivalence.spec /.equivalence (..random sizeL n.order random.nat)))
+
+                (_.cover [/.size]
+                         (n.= sizeL (/.size setL)))
+                (_.cover [/.empty?]
+                         (bit@= (n.= 0 (/.size setL))
+                                (/.empty? setL)))
+                (_.cover [/.new]
+                         (/.empty? (/.new n.order)))
+                (_.cover [/.to-list]
+                         (:: (list.equivalence n.equivalence) =
+                             (/.to-list (/.from-list n.order listL))
+                             (list.sort (:: n.order <) listL)))
+                (_.cover [/.from-list]
+                         (|> setL
+                             /.to-list (/.from-list n.order)
+                             (/@= setL)))
+                (~~ (template [<coverage> <comparison>]
+                      [(_.cover [<coverage>]
+                                (case (<coverage> setL)
+                                  (#.Some value)
+                                  (|> setL /.to-list (list.every? (<comparison> value)))
+
+                                  #.None
+                                  (/.empty? setL)))]
+
+                      [/.min n.>=]
+                      [/.max n.<=]
+                      ))
+                (_.cover [/.member?]
+                         (let [members-are-identified!
+                               (list.every? (/.member? setL) (/.to-list setL))
+
+                               non-members-are-not-identified!
+                               (not (/.member? setL non-memberL))]
+                           (and members-are-identified!
+                                non-members-are-not-identified!)))
+                (_.cover [/.add]
+                         (let [setL+ (/.add non-memberL setL)]
+                           (and (not (/.member? setL non-memberL))
+                                (/.member? setL+ non-memberL)
+                                (n.= (inc (/.size setL))
+                                     (/.size setL+)))))
+                (_.cover [/.remove]
+                         (|> setL
+                             (/.add non-memberL)
+                             (/.remove non-memberL)
+                             (:: /.equivalence = setL)))
+                (_.cover [/.sub?]
+                         (let [self!
+                               (/.sub? setL setL)
+
+                               empty!
+                               (/.sub? setL empty)]
+                           (and self!
+                                empty!)))
+                (_.cover [/.super?]
+                         (let [self!
+                               (/.super? setL setL)
+
+                               empty!
+                               (/.super? empty setL)
+
+                               symmetry!
+                               (bit@= (/.super? setL setR)
+                                      (/.sub? setR setL))]
+                           (and self!
+                                empty!
+                                symmetry!)))
+                (~~ (template [<coverage> <relation> <empty?>]
+                      [(_.cover [<coverage>]
+                                (let [self!
+                                      (:: /.equivalence =
+                                          setL
+                                          (<coverage> setL setL))
+
+                                      super!
+                                      (and (<relation> (<coverage> setL setR) setL)
+                                           (<relation> (<coverage> setL setR) setR))
+
+                                      empty!
+                                      (:: /.equivalence =
+                                          (if <empty?> empty setL)
+                                          (<coverage> setL empty))
+
+                                      idempotence!
+                                      (:: /.equivalence =
+                                          (<coverage> setL (<coverage> setL setR))
+                                          (<coverage> setR (<coverage> setL setR)))]
+                                  (and self!
+                                       super!
+                                       empty!
+                                       idempotence!)))]
+
+                      [/.union /.sub? false]
+                      [/.intersection /.super? true]
+                      ))
+                (_.cover [/.difference]
+                         (let [self!
+                               (|> setL
+                                   (/.difference setL)
+                                   (:: /.equivalence = empty))
+
+                               empty!
+                               (|> setL
+                                   (/.difference empty)
+                                   (:: /.equivalence = setL))
+
+                               difference!
+                               (not (list.any? (/.member? (/.difference setL setR))
+                                               (/.to-list setL)))
+
+                               idempotence!
+                               (:: /.equivalence =
+                                   (/.difference setL setR)
+                                   (/.difference setL (/.difference setL setR)))]
+                           (and self!
+                                empty!
+                                difference!
+                                idempotence!)))
                 )))))
diff --git a/stdlib/source/test/lux/meta/annotation.lux b/stdlib/source/test/lux/meta/annotation.lux
index f0ff06160..a3c2dae7f 100644
--- a/stdlib/source/test/lux/meta/annotation.lux
+++ b/stdlib/source/test/lux/meta/annotation.lux
@@ -74,7 +74,7 @@
                   [/.nat random.nat code.nat nat.equivalence]
                   [/.int random.int code.int int.equivalence]
                   [/.rev random.rev code.rev rev.equivalence]
-                  [/.frac random.frac code.frac frac.equivalence]
+                  [/.frac random.safe-frac code.frac frac.equivalence]
                   [/.text (random.ascii/alpha 1) code.text text.equivalence]
                   [/.identifier ..random-key code.identifier name.equivalence]
                   [/.tag ..random-key code.tag name.equivalence]
diff --git a/stdlib/source/test/lux/world/console.lux b/stdlib/source/test/lux/world/console.lux
index d17559cec..6e1ce67b3 100644
--- a/stdlib/source/test/lux/world/console.lux
+++ b/stdlib/source/test/lux/world/console.lux
@@ -4,6 +4,7 @@
    [abstract
     [monad (#+ do)]]
    [control
+    ["." io]
     ["." try (#+ Try)]
     ["." exception (#+ exception:)]]]
   {1
@@ -40,4 +41,4 @@
   Test
   (<| (_.covering /._)
       (_.with-cover [/.mock /.Simulation]
-        ($/.spec (/.mock ..simulation false)))))
+        ($/.spec (io.io (/.mock ..simulation false))))))