aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/data/number/i64.lux67
-rw-r--r--stdlib/source/program/aedifex/project.lux27
-rw-r--r--stdlib/source/test/aedifex.lux2
-rw-r--r--stdlib/source/test/aedifex/parser.lux8
-rw-r--r--stdlib/source/test/aedifex/project.lux96
-rw-r--r--stdlib/source/test/lux/data/number/i64.lux18
-rw-r--r--stdlib/source/test/lux/data/sum.lux107
-rw-r--r--stdlib/source/test/lux/target/jvm.lux15
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)