Tweaked how I64 masks are made.

8 files changed, 268 insertions, 72 deletions

diff --git a/stdlib/source/lux/data/number/i64.lux b/stdlib/source/lux/data/number/i64.lux
index 26bc0cdc9..79bf7632d 100644
--- a/stdlib/source/lux/data/number/i64.lux
+++ b/stdlib/source/lux/data/number/i64.lux
@@ -1,5 +1,5 @@
 (.module:
-  [lux (#- and or not)
+  [lux (#- and or not false true)
    [abstract
     [equivalence (#+ Equivalence)]
     [hash (#+ Hash)]
@@ -16,8 +16,8 @@
 
 (def: #export width
   Nat
-  (n.* bits-per-byte
-       bytes-per-i64))
+  (n.* ..bits-per-byte
+       ..bytes-per-i64))
 
 (template [<parameter-type> <name> <op> <doc>]
   [(def: #export (<name> parameter subject)
@@ -39,17 +39,32 @@
   (All [s] (-> (I64 s) (I64 s)))
   (xor (:coerce I64 -1)))
 
-(type: #export Mask I64)
+(type: #export Mask
+  I64)
 
-(def: #export (mask bits)
+(def: #export false
+  Mask
+  (.i64 0))
+
+(def: #export true
+  Mask
+  (..not ..false))
+
+(def: #export (mask amount-of-bits)
+  (-> Nat Mask)
+  (case amount-of-bits
+    0 ..false
+    bits (case (n.% ..width bits)
+           0 ..true
+           bits (|> 1 .i64 (..left-shift (n.% ..width bits)) .dec))))
+
+(def: #export (bit position)
   (-> Nat Mask)
-  (let [multiple-of-width? (.and (.not (n.= 0 bits))
-                                 (n.= 0 (n.% ..width bits)))]
-    (if multiple-of-width?
-      (.i64 -1)
-      (|> 1 .i64 (..left-shift (n.% ..width bits)) .dec))))
+  (|> 1 .i64 (..left-shift (n.% ..width position))))
 
-(def: #export sign Mask (|> 1 .i64 (..left-shift 63)))
+(def: #export sign
+  Mask
+  (..bit 63))
 
 (def: (add-shift shift value)
   (-> Nat Nat Nat)
@@ -68,20 +83,16 @@
         (add-shift 32)
         (..and 127))))
 
-(def: (flag idx)
-  (-> Nat I64)
-  (|> 1 (:coerce I64) (left-shift idx)))
-
 (def: #export (clear idx input)
   {#.doc "Clear bit at given index."}
   (All [s] (-> Nat (I64 s) (I64 s)))
-  (|> idx flag ..not (..and input)))
+  (|> idx ..bit ..not (..and input)))
 
 (template [<name> <op> <doc>]
   [(def: #export (<name> idx input)
      {#.doc <doc>}
      (All [s] (-> Nat (I64 s) (I64 s)))
-     (|> idx flag (<op> input)))]
+     (|> idx ..bit (<op> input)))]
 
   [set  ..or  "Set bit at given index."]
   [flip ..xor "Flip bit at given index."]
@@ -89,7 +100,7 @@
 
 (def: #export (set? idx input)
   (-> Nat (I64 Any) Bit)
-  (|> input (:coerce I64) (..and (flag idx)) (n.= 0) .not))
+  (|> input (:coerce I64) (..and (..bit idx)) (n.= 0) .not))
 
 (template [<name> <main> <comp>]
   [(def: #export (<name> distance input)
@@ -120,18 +131,16 @@
 
   (def: hash .nat))
 
-(structure: #export disjunction
-  (All [a] (Monoid (I64 a)))
-
-  (def: identity (.i64 0))
-  (def: compose ..or)
-  )
+(template [<monoid> <identity> <compose>]
+  [(structure: #export <monoid>
+     (All [a] (Monoid (I64 a)))
 
-(structure: #export conjunction
-  (All [a] (Monoid (I64 a)))
+     (def: identity <identity>)
+     (def: compose <compose>)
+     )]
 
-  (def: identity (.i64 (..not 0)))
-  (def: compose ..and)
+  [disjunction ..false ..or]
+  [conjunction ..true ..and]
   )
 
 (type: #export (Sub size)
@@ -145,7 +154,7 @@
             (n.< ..width width))
     (let [top (dec width)
           shift (n.- width ..width)
-          sign (: Mask (|> 1 .i64 (..left-shift top)))
+          sign (..bit top)
           number (..mask (dec width))]
       (#.Some {#narrow (function (narrow value)
                          (..or (|> value (..and ..sign) (..logic-right-shift shift))
diff --git a/stdlib/source/program/aedifex/project.lux b/stdlib/source/program/aedifex/project.lux
index 15abd9ee1..071f54b12 100644
--- a/stdlib/source/program/aedifex/project.lux
+++ b/stdlib/source/program/aedifex/project.lux
@@ -1,8 +1,9 @@
 (.module:
   [lux (#- Name)
    [abstract
-    ["." monad (#+ do)]
-    ["." equivalence (#+ Equivalence)]]
+    [equivalence (#+ Equivalence)]
+    [monoid (#+ Monoid)]
+    ["." monad (#+ do)]]
    [control
     ["." try (#+ Try)]
     ["." exception (#+ exception:)]]
@@ -19,13 +20,23 @@
 (type: #export Project
   (Dictionary Name Profile))
 
-(def: #export empty
-  (dictionary.from-list text.hash (list [//.default (:: //.monoid identity)])))
+(def: #export (project name profile)
+  (-> Name Profile Project)
+  (dictionary.from-list text.hash (list [name profile])))
 
 (def: #export equivalence
   (Equivalence Project)
   (dictionary.equivalence //.equivalence))
 
+(structure: #export monoid
+  (Monoid Project)
+
+  (def: identity
+    (dictionary.new text.hash))
+
+  (def: compose
+    (dictionary.merge-with (:: //.monoid compose))))
+
 (exception: #export (unknown-profile {name Name})
   (exception.report
    ["Name" (%.text name)]))
@@ -50,12 +61,12 @@
                             (get@ #//.parents profile))]
         (wrap (list@fold (function (_ parent child)
                            (:: //.monoid compose child parent))
-                         profile
+                         (set@ #//.parents (list) profile)
                          parents))))
     
     #.None
     (exception.throw ..unknown-profile [name])))
 
-(def: #export (profile project name)
-  (-> Project Name (Try Profile))
-  (profile' (set.new text.hash) project name))
+(def: #export (profile name project)
+  (-> Name Project (Try Profile))
+  (..profile' (set.new text.hash) project name))
diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux
index de52e6a9e..48ecc9189 100644
--- a/stdlib/source/test/aedifex.lux
+++ b/stdlib/source/test/aedifex.lux
@@ -8,6 +8,7 @@
   ["." / #_
    ["#." artifact]
    ["#." profile]
+   ["#." project]
    ["#." cli]
    ["#." parser]])
 
@@ -16,6 +17,7 @@
   ($_ _.and
       /artifact.test
       /profile.test
+      /project.test
       /cli.test
       /parser.test
       ))
diff --git a/stdlib/source/test/aedifex/parser.lux b/stdlib/source/test/aedifex/parser.lux
index 988883779..a171e694d 100644
--- a/stdlib/source/test/aedifex/parser.lux
+++ b/stdlib/source/test/aedifex/parser.lux
@@ -73,9 +73,7 @@
                 (case> (#try.Success actual)
                        (|> expected
                            ..with-default-sources
-                           [//.default]
-                           list
-                           (dictionary.from-list text.hash)
+                           (//project.project //.default)
                            (:: //project.equivalence = actual))
                        
                        (#try.Failure error)
@@ -84,7 +82,7 @@
 (def: (with-empty-profile project)
   (-> Project Project)
   (if (dictionary.empty? project)
-    //project.empty
+    (//project.project //.default (:: //.monoid identity))
     project))
 
 (def: multiple-profiles
@@ -102,7 +100,7 @@
                            dictionary.entries
                            (list@map (function (_ [name profile])
                                        [name (..with-default-sources profile)]))
-                           (dictionary.from-list text.hash)
+                           (dictionary.from-list text.hash) 
                            (:: //project.equivalence = actual))
                        
                        (#try.Failure error)
diff --git a/stdlib/source/test/aedifex/project.lux b/stdlib/source/test/aedifex/project.lux
new file mode 100644
index 000000000..f2c2917a2
--- /dev/null
+++ b/stdlib/source/test/aedifex/project.lux
@@ -0,0 +1,96 @@
+(.module:
+  [lux #*
+   ["_" test (#+ Test)]
+   [abstract
+    [monad (#+ do)]
+    {[0 #spec]
+     [/
+      ["$." equivalence]
+      ["$." monoid]]}]
+   [control
+    ["." try ("#@." functor)]
+    ["." exception]]
+   [data
+    ["." product]
+    ["." text ("#@." equivalence)]
+    [number
+     ["n" nat]]]
+   [math
+    ["." random (#+ Random) ("#@." monad)]]]
+  [//
+   ["@." profile]]
+  {#program
+   ["." /
+    ["/#" // #_
+     ["#" profile]]]})
+
+(def: profile
+  (Random [//.Name //.Profile])
+  (|> @profile.random
+      (random@map (set@ #//.parents (list)))
+      (random.and (random.ascii/alpha 1))))
+
+(def: #export random
+  (Random /.Project)
+  (do random.monad
+    [[name profile] ..profile]
+    (wrap (/.project name profile))))
+
+(def: #export test
+  Test
+  (<| (_.covering /._)
+      (_.with-cover [/.Project /.project]
+        ($_ _.and
+            (_.with-cover [/.equivalence]
+              ($equivalence.spec /.equivalence ..random))
+            (_.with-cover [/.monoid]
+              ($monoid.spec /.equivalence /.monoid ..random))
+
+            (do random.monad
+              [[super-name super-profile] ..profile
+               [dummy-name dummy-profile] (random.filter (|>> product.left (text@= super-name) not)
+                                                         ..profile)
+               [sub-name sub-profile] (random.filter (function (_ [name profile])
+                                                       (and (not (text@= super-name name))
+                                                            (not (text@= dummy-name name))))
+                                                     ..profile)
+               fake-name (random.filter (function (_ name)
+                                          (and (not (text@= super-name name))
+                                               (not (text@= dummy-name name))
+                                               (not (text@= sub-name name))))
+                                        (random.ascii/alpha 1))
+               #let [project ($_ (:: /.monoid compose)
+                                 (/.project super-name super-profile)
+                                 (/.project dummy-name dummy-profile)
+                                 (/.project sub-name (set@ #//.parents (list super-name) sub-profile)))
+                     circular ($_ (:: /.monoid compose)
+                                  (/.project super-name (set@ #//.parents (list sub-name) super-profile))
+                                  (/.project dummy-name dummy-profile)
+                                  (/.project sub-name (set@ #//.parents (list super-name) sub-profile)))]]
+              ($_ _.and
+                  (_.cover [/.profile]
+                           (and (|> (/.profile super-name project)
+                                    (try@map (:: //.equivalence = super-profile))
+                                    (try.default false))
+                                (|> (/.profile dummy-name project)
+                                    (try@map (:: //.equivalence = dummy-profile))
+                                    (try.default false))
+                                (|> (/.profile sub-name project)
+                                    (try@map (:: //.equivalence = (:: //.monoid compose sub-profile super-profile)))
+                                    (try.default false))))
+                  (_.cover [/.unknown-profile]
+                           (case (/.profile fake-name project)
+                             (#try.Success _)
+                             false
+
+                             (#try.Failure error)
+                             (exception.match? /.unknown-profile error)))
+                  (_.cover [/.circular-dependency]
+                           (case (/.profile sub-name circular)
+                             (#try.Success _)
+                             false
+
+                             (#try.Failure error)
+                             (exception.match? /.circular-dependency error)))
+                  ))
+            ))))
diff --git a/stdlib/source/test/lux/data/number/i64.lux b/stdlib/source/test/lux/data/number/i64.lux
index 390861169..592b5fe41 100644
--- a/stdlib/source/test/lux/data/number/i64.lux
+++ b/stdlib/source/test/lux/data/number/i64.lux
@@ -87,4 +87,22 @@
                       (if (i.< +0 value)
                         (i.< +0 (/.arithmetic-right-shift idx value))
                         (i.>= +0 (/.arithmetic-right-shift idx value)))))
+            (_.cover [/.mask]
+                     (let [mask (/.mask idx)
+                           idempotent? (:: /.equivalence =
+                                           (/.and mask pattern)
+                                           (/.and mask (/.and mask pattern)))
+
+                           limit (inc (.nat mask))
+                           below-limit? (if (//nat.< limit pattern)
+                                          (//nat.= pattern (/.and mask pattern))
+                                          (//nat.< limit (/.and mask pattern)))
+
+                           with-empty-mask? (//nat.= 0 (/.and (/.mask 0) pattern))
+                           with-full-mask? (//nat.= pattern (/.and (/.mask /.width) pattern))]
+                       (and idempotent?
+                            below-limit?
+
+                            with-empty-mask?
+                            with-full-mask?)))
             ))))
diff --git a/stdlib/source/test/lux/data/sum.lux b/stdlib/source/test/lux/data/sum.lux
index 7434d7509..972677361 100644
--- a/stdlib/source/test/lux/data/sum.lux
+++ b/stdlib/source/test/lux/data/sum.lux
@@ -1,7 +1,11 @@
 (.module:
   [lux #*
    ["_" test (#+ Test)]
-   ["%" data/text/format (#+ format)]
+   [abstract
+    [monad (#+ do)]
+    {[0 #spec]
+     [/
+      ["$." equivalence]]}]
    [control
     pipe]
    [data
@@ -9,33 +13,86 @@
     [number
      ["n" nat]]
     [collection
-     ["." list]]]]
+     ["." list ("#@." functor)]]]
+   [math
+    ["." random]]]
   {1
    ["." /]})
 
 (def: #export test
   Test
-  (<| (_.context (%.name (name-of .|)))
-      (let [(^open "list/.") (list.equivalence text.equivalence)]
-        ($_ _.and
-            (_.test "Can inject values into Either."
-                    (and (|> (/.left "Hello") (case> (0 #0 "Hello") #1 _ #0))
-                         (|> (/.right "World") (case> (0 #1 "World") #1 _ #0))))
-            (_.test "Can discriminate eithers based on their cases."
-                    (let [[_lefts _rights] (/.partition (: (List (| Text Text))
-                                                           (list (0 #0 "0") (0 #1 "1") (0 #0 "2"))))]
-                      (and (list/= _lefts
-                                   (/.lefts (: (List (| Text Text))
-                                               (list (0 #0 "0") (0 #1 "1") (0 #0 "2")))))
+  (<| (_.covering /._)
+      (do {@ random.monad}
+        [expected random.nat
+         shift random.nat])
+      ($_ _.and
+          (_.with-cover [/.equivalence]
+            ($equivalence.spec (/.equivalence n.equivalence n.equivalence)
+                               (random.or random.nat random.nat)))
 
-                           (list/= _rights
-                                   (/.rights (: (List (| Text Text))
-                                                (list (0 #0 "0") (0 #1 "1") (0 #0 "2"))))))))
-            (_.test "Can apply a function to an Either value depending on the case."
-                    (and (n.= 10 (/.either (function (_ _) 10)
-                                           (function (_ _) 20)
-                                           (: (| Text Text) (0 #0 ""))))
-                         (n.= 20 (/.either (function (_ _) 10)
-                                           (function (_ _) 20)
-                                           (: (| Text Text) (0 #1 ""))))))
-            ))))
+          (_.cover [/.left]
+                   (|> (/.left expected)
+                       (: (| Nat Nat))
+                       (case> (0 #0 actual) (n.= expected actual)
+                              _ false)))
+          (_.cover [/.right]
+                   (|> (/.right expected)
+                       (: (| Nat Nat))
+                       (case> (0 #1 actual) (n.= expected actual)
+                              _ false)))
+          (_.cover [/.either]
+                   (and (|> (/.left expected)
+                            (: (| Nat Nat))
+                            (/.either (n.+ shift) (n.- shift))
+                            (n.= (n.+ shift expected)))
+                        (|> (/.right expected)
+                            (: (| Nat Nat))
+                            (/.either (n.+ shift) (n.- shift))
+                            (n.= (n.- shift expected)))))
+          (_.cover [/.each]
+                   (and (|> (/.left expected)
+                            (: (| Nat Nat))
+                            (/.each (n.+ shift) (n.- shift))
+                            (case> (0 #0 actual) (n.= (n.+ shift expected) actual) _ false))
+                        (|> (/.right expected)
+                            (: (| Nat Nat))
+                            (/.each (n.+ shift) (n.- shift))
+                            (case> (0 #1 actual) (n.= (n.- shift expected) actual) _ false))))
+          (do @
+            [size (:: @ map (n.% 5) random.nat)
+             expected (random.list size random.nat)]
+            ($_ _.and
+                (_.cover [/.lefts]
+                         (let [actual (: (List (| Nat Nat))
+                                         (list@map /.left expected))]
+                           (and (:: (list.equivalence n.equivalence) =
+                                    expected
+                                    (/.lefts actual))
+                                (:: (list.equivalence n.equivalence) =
+                                    (list)
+                                    (/.rights actual)))))
+                (_.cover [/.rights]
+                         (let [actual (: (List (| Nat Nat))
+                                         (list@map /.right expected))]
+                           (and (:: (list.equivalence n.equivalence) =
+                                    expected
+                                    (/.rights actual))
+                                (:: (list.equivalence n.equivalence) =
+                                    (list)
+                                    (/.lefts actual)))))
+                (_.cover [/.partition]
+                         (let [[lefts rights] (|> expected
+                                                  (list@map (function (_ value)
+                                                              (if (n.even? value)
+                                                                (/.left value)
+                                                                (/.right value))))
+                                                  (: (List (| Nat Nat)))
+                                                  /.partition)]
+                           (and (:: (list.equivalence n.equivalence) =
+                                    (list.filter n.even? expected)
+                                    lefts)
+                                (:: (list.equivalence n.equivalence) =
+                                    (list.filter (|>> n.even? not) expected)
+                                    rights))))
+                ))
+          )))
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index 28ea97944..b9639a82f 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -251,6 +251,11 @@
    #random ..$Double::random
    #literal ..$Double::literal})
 
+(def: valid-double
+  (Random java/lang/Double)
+  (random.filter (|>> (:coerce Frac) f.not-a-number? not)
+                 ..$Double::random))
+
 (def: $Character
   (/type.class "java.lang.Character" (list)))
 (def: $Character::wrap
@@ -1192,15 +1197,15 @@
             (let [test (!::= java/lang/Double "jvm deq" "jvm double =")]
               ($_ _.and
                   (_.lift "DSTORE_0/DLOAD_0"
-                          (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [(function.constant /.dstore-0) (function.constant /.dload-0)] test))
+                          (store-and-load ..valid-double ..$Double::literal ..$Double::wrap [(function.constant /.dstore-0) (function.constant /.dload-0)] test))
                   (_.lift "DSTORE_1/DLOAD_1"
-                          (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [(function.constant /.dstore-1) (function.constant /.dload-1)] test))
+                          (store-and-load ..valid-double ..$Double::literal ..$Double::wrap [(function.constant /.dstore-1) (function.constant /.dload-1)] test))
                   (_.lift "DSTORE_2/DLOAD_2"
-                          (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [(function.constant /.dstore-2) (function.constant /.dload-2)] test))
+                          (store-and-load ..valid-double ..$Double::literal ..$Double::wrap [(function.constant /.dstore-2) (function.constant /.dload-2)] test))
                   (_.lift "DSTORE_3/DLOAD_3"
-                          (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [(function.constant /.dstore-3) (function.constant /.dload-3)] test))
+                          (store-and-load ..valid-double ..$Double::literal ..$Double::wrap [(function.constant /.dstore-3) (function.constant /.dload-3)] test))
                   (_.lift "DSTORE/DLOAD"
-                          (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [/.dstore /.dload] test)))))
+                          (store-and-load ..valid-double ..$Double::literal ..$Double::wrap [/.dstore /.dload] test)))))
         (<| (_.context "object")
             (let [test (: (-> java/lang/String Any Bit)
                           (function (_ expected actual)