diff options
Diffstat (limited to '')
30 files changed, 735 insertions, 487 deletions
diff --git a/stdlib/source/lux/abstract/hash.lux b/stdlib/source/lux/abstract/hash.lux index f22bdc62a..fe994497b 100644 --- a/stdlib/source/lux/abstract/hash.lux +++ b/stdlib/source/lux/abstract/hash.lux @@ -18,13 +18,12 @@ (equivalence.sum (\ left &equivalence) (\ right &equivalence))) (def: (hash value) - (<| (:coerce Nat) - (case value - (#.Left value) - ("lux i64 *" +2 (:coerce Int (\ left hash value))) + (case value + (#.Left value) + (\ left hash value) - (#.Right value) - ("lux i64 *" +3 (:coerce Int (\ right hash value)))))))) + (#.Right value) + (\ right hash value))))) (def: #export (product left right) (All [l r] (-> (Hash l) (Hash r) (Hash (& l r)))) @@ -33,7 +32,6 @@ (equivalence.product (\ left &equivalence) (\ right &equivalence))) (def: (hash [leftV rightV]) - (:coerce Nat - ("lux i64 +" - (:coerce Int (\ left hash leftV)) - (:coerce Int (\ right hash rightV))))))) + ("lux i64 +" + (\ left hash leftV) + (\ right hash rightV))))) diff --git a/stdlib/source/lux/control/io.lux b/stdlib/source/lux/control/io.lux index 442cf0a1c..679e534c3 100644 --- a/stdlib/source/lux/control/io.lux +++ b/stdlib/source/lux/control/io.lux @@ -42,10 +42,6 @@ (wrap (list (` ((~! ..label) (function ((~ g!func) (~ g!arg)) (~ computation)))))))) - (def: #export (exit code) - (-> Int (IO Nothing)) - (!io ("lux io exit" code))) - (def: #export run {#.doc "A way to execute IO computations and perform their side-effects."} (All [a] (-> (IO a) a)) diff --git a/stdlib/source/lux/control/parser/environment.lux b/stdlib/source/lux/control/parser/environment.lux index fbe256c24..509369d68 100644 --- a/stdlib/source/lux/control/parser/environment.lux +++ b/stdlib/source/lux/control/parser/environment.lux @@ -8,20 +8,24 @@ ["." text ["%" format (#+ format)]] [collection - ["." dictionary (#+ Dictionary)]]] - [world - ["/" environment]]] + ["." dictionary (#+ Dictionary)]]]] ["." //]) -(exception: #export (unknown {property /.Property}) +(type: #export Property + Text) + +(type: #export Environment + (Dictionary Property Text)) + +(exception: #export (unknown {property Property}) (exception.report ["Property" (%.text property)])) (type: #export (Parser a) - (//.Parser /.Environment a)) + (//.Parser Environment a)) (def: #export empty - /.Environment + Environment (dictionary.new text.hash)) (def: #export (property name) @@ -35,5 +39,5 @@ (exception.throw ..unknown name)))) (def: #export (run parser environment) - (All [a] (-> (Parser a) /.Environment (Try a))) + (All [a] (-> (Parser a) Environment (Try a))) (\ try.monad map product.right (parser environment))) diff --git a/stdlib/source/lux/data/collection/dictionary/ordered.lux b/stdlib/source/lux/data/collection/dictionary/ordered.lux index c558a7669..49886a459 100644 --- a/stdlib/source/lux/data/collection/dictionary/ordered.lux +++ b/stdlib/source/lux/data/collection/dictionary/ordered.lux @@ -115,21 +115,16 @@ [max #right] ) -(template [<name> <op>] - [(def: #export (<name> dict) - (All [k v] (-> (Dictionary k v) Nat)) - (loop [node (get@ #root dict)] - (case node - #.None - 0 - - (#.Some node) - (inc (<op> (recur (get@ #left node)) - (recur (get@ #right node)))))))] +(def: #export (size dict) + (All [k v] (-> (Dictionary k v) Nat)) + (loop [node (get@ #root dict)] + (case node + #.None + 0 - [size n.+] - [depth n.max] - ) + (#.Some node) + (inc (n.+ (recur (get@ #left node)) + (recur (get@ #right node))))))) (def: #export empty? (All [k v] (-> (Dictionary k v) Bit)) diff --git a/stdlib/source/lux/data/collection/set/ordered.lux b/stdlib/source/lux/data/collection/set/ordered.lux index 7a2584227..68449daa3 100644 --- a/stdlib/source/lux/data/collection/set/ordered.lux +++ b/stdlib/source/lux/data/collection/set/ordered.lux @@ -29,10 +29,7 @@ [(Maybe a) min /.min] [(Maybe a) max /.max] - [Nat size /.size] - [Nat depth /.depth] - [Bit empty? /.empty?] ) diff --git a/stdlib/source/lux/data/number/frac.lux b/stdlib/source/lux/data/number/frac.lux index 34b2d6532..858fa2980 100644 --- a/stdlib/source/lux/data/number/frac.lux +++ b/stdlib/source/lux/data/number/frac.lux @@ -93,7 +93,7 @@ +1.0)) (def: min-exponent -1022) -(def: max-exponent +1023) +(def: max-exponent (//int.frac +1023)) (template [<name> <test> <doc>] [(def: #export (<name> left right) @@ -150,7 +150,7 @@ (def: #export biggest Frac (let [f2^-52 (math.pow (//nat.frac (//nat.- ..mantissa-size 0)) +2.0) - f2^+1023 (math.pow (//int.frac ..max-exponent) +2.0)] + f2^+1023 (math.pow ..max-exponent +2.0)] (|> +2.0 (..- f2^-52) (..* f2^+1023)))) @@ -223,6 +223,72 @@ (def: exponent-offset ..mantissa-size) (def: sign-offset (//nat.+ ..exponent-size ..exponent-offset)) +(template [<cast> <hex> <name>] + [(def: <name> (|> <hex> (\ //nat.hex decode) try.assume <cast>))] + + [.i64 "FFF8000000000000" not-a-number-bits] + [.i64 "7FF0000000000000" positive-infinity-bits] + [.i64 "FFF0000000000000" negative-infinity-bits] + [.i64 "0000000000000000" positive-zero-bits] + [.i64 "8000000000000000" negative-zero-bits] + [.nat "7FF" special-exponent-bits] + ) + +(def: smallest-exponent + (..log/2 ..smallest)) + +(def: #export (to-bits input) + (-> Frac I64) + (.i64 (cond (..not-a-number? input) + ..not-a-number-bits + + (..= positive-infinity input) + ..positive-infinity-bits + + (..= negative-infinity input) + ..negative-infinity-bits + + (..= +0.0 input) + (let [reciprocal (../ input +1.0)] + (if (..= positive-infinity reciprocal) + ## Positive zero + ..positive-zero-bits + ## Negative zero + ..negative-zero-bits)) + + ## else + (let [sign-bit (if (..< -0.0 input) + 1 + 0) + input (..abs input) + exponent (|> input + ..log/2 + math.floor + (..min ..max-exponent)) + min-gap (..- (//int.frac ..min-exponent) exponent) + power (|> (//nat.frac ..mantissa-size) + (..+ (..min +0.0 min-gap)) + (..- exponent)) + max-gap (..- ..max-exponent power) + mantissa (|> input + (..* (math.pow (..min ..max-exponent power) +2.0)) + (..* (if (..> +0.0 max-gap) + (math.pow max-gap +2.0) + +1.0))) + exponent-bits (|> (if (..< +0.0 min-gap) + (|> (..int exponent) + (//int.- (..int min-gap)) + dec) + (..int exponent)) + (//int.+ (.int ..double-bias)) + (//i64.and ..exponent-mask)) + mantissa-bits (..int mantissa)] + ($_ //i64.or + (//i64.left-shift ..sign-offset sign-bit) + (//i64.left-shift ..exponent-offset exponent-bits) + (//i64.clear ..mantissa-size mantissa-bits))) + ))) + (template [<getter> <size> <offset>] [(def: <getter> (-> (I64 Any) I64) @@ -234,102 +300,44 @@ [sign 1 ..sign-offset] ) -(template [<hex> <name>] - [(def: <name> (|> <hex> (\ //nat.hex decode) try.assume .i64))] - - ["7FF7FFFFFFFFFFFF" not-a-number-bits] - ["7FF0000000000000" positive-infinity-bits] - ["FFF0000000000000" negative-infinity-bits] - ["0000000000000000" positive-zero-bits] - ["8000000000000000" negative-zero-bits] - ["7FF" special-exponent-bits] - ) - -(def: normal - (math.pow (//nat.frac ..mantissa-size) +2.0)) - -(def: smallest-exponent - (..log/2 ..smallest)) - -(def: #export (to-bits input) - (-> Frac I64) - (i64 (cond (not-a-number? input) - ..not-a-number-bits - - (..= positive-infinity input) - ..positive-infinity-bits - - (..= negative-infinity input) - ..negative-infinity-bits - - (..= +0.0 input) - (let [reciprocal (../ input +1.0)] - (if (..= positive-infinity reciprocal) - ## Positive zero - ..positive-zero-bits - ## Negative zero - ..negative-zero-bits)) - - ## else - (let [sign-bit (if (..= -1.0 (..signum input)) - 1 - 0) - input (..abs input) - exponent (|> (math.floor (..log/2 input)) - (..min (//int.frac ..max-exponent))) - tiny? (..= ..smallest-exponent exponent) - mantissa (..* (math.pow (if tiny? - (|> exponent ..abs (..- (//nat.frac ..mantissa-size))) - (..- exponent (//nat.frac ..mantissa-size))) - +2.0) - input) - exponent-bits (|> (if tiny? - (|> (..int exponent) - (//int.+ (.int ..mantissa-size)) - dec) - (..int exponent)) - (//int.+ (.int ..double-bias)) - (//i64.and ..exponent-mask)) - mantissa-bits (if tiny? - (|> mantissa (..* ..normal) ..int .nat) - (|> mantissa ..int .nat))] - ($_ //i64.or - (//i64.left-shift ..sign-offset sign-bit) - (//i64.left-shift ..exponent-offset exponent-bits) - (//i64.clear ..mantissa-size mantissa-bits))) - ))) - (def: #export (from-bits input) (-> I64 Frac) - (let [S (..sign input) - positive? (//nat.= 0 S) - E (..exponent input) - M (..mantissa input)] - (cond (//nat.= ..special-exponent-bits E) - (if (//nat.= 0 M) - (if positive? - ..positive-infinity - ..negative-infinity) - ..not-a-number) - - (and (//nat.= 0 E) (//nat.= 0 M)) - (if positive? - +0.0 - (..* -1.0 +0.0)) - - ## else - (let [numerator (|> M (//i64.set ..mantissa-size) - .int (//int.* (if positive? - +1 - -1))) - denominator ..normal - power (math.pow (//int.frac (if (//nat.= 0 (.nat E)) - (|> E (//nat.- ..double-bias) (//nat.- ..mantissa-size) inc .int) - (|> E (//nat.- ..double-bias) .int))) - +2.0)] - (|> (//int.frac numerator) - (../ denominator) - (..* power)))))) + (case [(: Nat (..exponent input)) + (: Nat (..mantissa input)) + (: Nat (..sign input))] + (^ [(static ..special-exponent-bits) 0 0]) + ..positive-infinity + + (^ [(static ..special-exponent-bits) 0 1]) + ..negative-infinity + + (^ [(static ..special-exponent-bits) _ _]) + ..not-a-number + + ## Positive zero + [0 0 0] +0.0 + ## Negative zero + [0 0 1] (..* -1.0 +0.0) + + [E M S] + (let [sign (if (//nat.= 0 S) + +1.0 + -1.0) + [mantissa power] (if (//nat.< ..mantissa-size E) + [(if (//nat.= 0 E) + M + (//i64.set ..mantissa-size M)) + (|> E + (//nat.- ..double-bias) + .int + (//int.max ..min-exponent) + (//int.- (.int ..mantissa-size)))] + [(//i64.set ..mantissa-size M) + (|> E (//nat.- ..double-bias) (//nat.- ..mantissa-size) .int)]) + exponent (math.pow (//int.frac power) +2.0)] + (|> (//nat.frac mantissa) + (..* exponent) + (..* sign))))) (def: (split-exponent codec representation) (-> (Codec Text Nat) Text (Try [Text Int])) @@ -420,8 +428,10 @@ (def: #export (mod divisor dividend) (All [m] (-> Frac Frac Frac)) - (if (..= (..signum divisor) (..signum dividend)) - (..% divisor dividend) - (case (..% divisor dividend) - +0.0 +0.0 - rem (..+ divisor rem)))) + (let [remainder (..% divisor dividend)] + (if (or (and (..< +0.0 divisor) + (..> +0.0 remainder)) + (and (..> +0.0 divisor) + (..< +0.0 remainder))) + (..+ divisor remainder) + remainder))) diff --git a/stdlib/source/lux/data/number/int.lux b/stdlib/source/lux/data/number/int.lux index 087302b8d..ea942bde5 100644 --- a/stdlib/source/lux/data/number/int.lux +++ b/stdlib/source/lux/data/number/int.lux @@ -106,11 +106,13 @@ (def: #export (mod divisor dividend) (All [m] (-> Int Int Int)) - (if (..= (..signum divisor) (..signum dividend)) - (..% divisor dividend) - (case (..% divisor dividend) - +0 +0 - rem (..+ divisor rem)))) + (let [remainder (..% divisor dividend)] + (if (or (and (..< +0 divisor) + (..> +0 remainder)) + (and (..> +0 divisor) + (..< +0 remainder))) + (..+ divisor remainder) + remainder))) (def: #export even? (-> Int Bit) @@ -190,70 +192,39 @@ (def: -sign "-") (def: +sign "+") -(def: (sign!! value) - (-> Int Text) - (if (..< +0 value) - ..-sign - ..+sign)) - -(def: (sign?? representation) - (-> Text (Maybe Int)) - (`` (case ("lux text char" 0 representation) - (^ (char (~~ (static ..-sign)))) - (#.Some -1) - - (^ (char (~~ (static ..+sign)))) - (#.Some +1) - - _ - #.None))) - -(def: (int-decode-loop input-size repr sign <base> <to-value> <error>) - (-> Nat Text Int Int (-> Char (Maybe Nat)) Text (Try Int)) - (loop [idx 1 - output +0] - (if (//nat.< input-size idx) - (case (<to-value> ("lux text char" idx repr)) - #.None - (#try.Failure <error>) - - (#.Some digit-value) - (recur (inc idx) - (|> output (..* <base>) (..+ (.int digit-value))))) - (#try.Success (..* sign output))))) - -(template [<base> <struct> <to-character> <to-value> <error>] +(template [<struct> <codec> <error>] [(structure: #export <struct> (Codec Text Int) (def: (encode value) - (if (..= +0 value) - "+0" - (loop [input (|> value (../ <base>) ..abs) - output (|> value (..% <base>) ..abs .nat - <to-character> - maybe.assume)] - (if (..= +0 input) - ("lux text concat" (sign!! value) output) - (let [digit (maybe.assume (<to-character> (.nat (..% <base> input))))] - (recur (../ <base> input) - ("lux text concat" digit output))))))) + (if (..< +0 value) + (|> value inc ..negate .nat inc (\ <codec> encode) ("lux text concat" ..-sign)) + (|> value .nat (\ <codec> encode) ("lux text concat" ..+sign)))) (def: (decode repr) (let [input-size ("lux text size" repr)] (if (//nat.> 1 input-size) - (case (sign?? repr) - (#.Some sign) - (int-decode-loop input-size repr sign <base> <to-value> <error>) - - #.None + (case ("lux text clip" 0 1 repr) + (^ (static ..+sign)) + (|> repr + ("lux text clip" 1 input-size) + (\ <codec> decode) + (\ try.functor map .int)) + + (^ (static ..-sign)) + (|> repr + ("lux text clip" 1 input-size) + (\ <codec> decode) + (\ try.functor map (|>> dec .int ..negate dec))) + + _ (#try.Failure <error>)) (#try.Failure <error>)))))] - [+02 binary //nat.binary-character //nat.binary-value "Invalid binary syntax for Int: "] - [+08 octal //nat.octal-character //nat.octal-value "Invalid octal syntax for Int: "] - [+10 decimal //nat.decimal-character //nat.decimal-value "Invalid syntax for Int: "] - [+16 hex //nat.hexadecimal-character //nat.hexadecimal-value "Invalid hexadecimal syntax for Int: "] + [binary //nat.binary "Invalid binary syntax for Int: "] + [octal //nat.octal "Invalid octal syntax for Int: "] + [decimal //nat.decimal "Invalid syntax for Int: "] + [hex //nat.hex "Invalid hexadecimal syntax for Int: "] ) (structure: #export hash diff --git a/stdlib/source/lux/data/number/nat.lux b/stdlib/source/lux/data/number/nat.lux index f6d5fa19c..b1504f048 100644 --- a/stdlib/source/lux/data/number/nat.lux +++ b/stdlib/source/lux/data/number/nat.lux @@ -122,17 +122,12 @@ ("lux coerce" Int (../ parameter subject)))] ("lux i64 -" flat subject))) -(def: #export (mod parameter subject) - (-> Nat Nat Nat) - (let [exact (|> subject (../ parameter) (..* parameter))] - (|> subject (..- exact)))) - (def: #export (gcd a b) {#.doc "Greatest Common Divisor."} (-> Nat Nat Nat) (case b 0 a - _ (gcd b (..mod b a)))) + _ (gcd b (..% b a)))) (def: #export (lcm a b) {#.doc "Least Common Multiple."} @@ -142,8 +137,7 @@ 0 _ - (|> a (../ (..gcd a b)) (..* b)) - )) + (|> a (../ (..gcd a b)) (..* b)))) (def: #export even? (-> Nat Bit) @@ -195,21 +189,21 @@ [maximum ..max (\ ..interval bottom)] ) -(def: #export (binary-character value) +(def: (binary-character value) (-> Nat (Maybe Text)) (case value 0 (#.Some "0") 1 (#.Some "1") _ #.None)) -(def: #export (binary-value digit) +(def: (binary-value digit) (-> Nat (Maybe Nat)) (case digit (^ (char "0")) (#.Some 0) (^ (char "1")) (#.Some 1) _ #.None)) -(def: #export (octal-character value) +(def: (octal-character value) (-> Nat (Maybe Text)) (case value 0 (#.Some "0") @@ -222,7 +216,7 @@ 7 (#.Some "7") _ #.None)) -(def: #export (octal-value digit) +(def: (octal-value digit) (-> Nat (Maybe Nat)) (case digit (^ (char "0")) (#.Some 0) @@ -235,7 +229,7 @@ (^ (char "7")) (#.Some 7) _ #.None)) -(def: #export (decimal-character value) +(def: (decimal-character value) (-> Nat (Maybe Text)) (case value 0 (#.Some "0") @@ -250,7 +244,7 @@ 9 (#.Some "9") _ #.None)) -(def: #export (decimal-value digit) +(def: (decimal-value digit) (-> Nat (Maybe Nat)) (case digit (^ (char "0")) (#.Some 0) @@ -265,7 +259,7 @@ (^ (char "9")) (#.Some 9) _ #.None)) -(def: #export (hexadecimal-character value) +(def: (hexadecimal-character value) (-> Nat (Maybe Text)) (case value 0 (#.Some "0") @@ -286,7 +280,7 @@ 15 (#.Some "F") _ #.None)) -(def: #export (hexadecimal-value digit) +(def: (hexadecimal-value digit) (-> Nat (Maybe Nat)) (case digit (^ (char "0")) (#.Some 0) @@ -307,7 +301,7 @@ (^or (^ (char "f")) (^ (char "F"))) (#.Some 15) _ #.None)) -(template [<struct> <base> <to-character> <to-value> <error>] +(template [<base> <struct> <to-character> <to-value> <error>] [(structure: #export <struct> (Codec Text Nat) @@ -339,10 +333,10 @@ (#try.Success output))) (#try.Failure ("lux text concat" <error> repr))))))] - [binary 2 binary-character binary-value "Invalid binary syntax for Nat: "] - [octal 8 octal-character octal-value "Invalid octal syntax for Nat: "] - [decimal 10 decimal-character decimal-value "Invalid decimal syntax for Nat: "] - [hex 16 hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "] + [02 binary binary-character binary-value "Invalid binary syntax for Nat: "] + [08 octal octal-character octal-value "Invalid octal syntax for Nat: "] + [10 decimal decimal-character decimal-value "Invalid decimal syntax for Nat: "] + [16 hex hexadecimal-character hexadecimal-value "Invalid hexadecimal syntax for Nat: "] ) (structure: #export hash diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 44bded416..bb2362d62 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -250,8 +250,8 @@ (wrap (<plus> x xs))) (\ ..monad wrap <zero>)))] - [list List (.list) #.Cons] - [row Row row.empty row.add] + [list List (.list) #.Cons] + [row Row row.empty row.add] ) (template [<name> <type> <ctor>] @@ -338,21 +338,27 @@ (All [a] (-> PRNG (Random a) [PRNG a])) (calc prng)) -(def: pcg-32-magic Nat 6364136223846793005) +(def: #export (prng update return) + (All [a] (-> (-> a a) (-> a I64) (-> a PRNG))) + (function (recur state) + (function (_ _) + [(recur (update state)) + (return state)]))) (def: #export (pcg-32 [increase seed]) {#.doc (doc "An implementation of the PCG32 algorithm." "For more information, please see: http://www.pcg-random.org/")} (-> [(I64 Any) (I64 Any)] PRNG) - (function (_ _) - [(|> seed .nat (n.* ..pcg-32-magic) ("lux i64 +" increase) [increase] pcg-32) - (let [rot (|> seed .i64 (i64.logic-right-shift 59))] - (|> seed - (i64.logic-right-shift 18) - (i64.xor seed) - (i64.logic-right-shift 27) - (i64.rotate-right rot) - .i64))])) + (let [magic 6364136223846793005] + (function (_ _) + [(|> seed .nat (n.* magic) ("lux i64 +" increase) [increase] pcg-32) + (let [rot (|> seed .i64 (i64.logic-right-shift 59))] + (|> seed + (i64.logic-right-shift 18) + (i64.xor seed) + (i64.logic-right-shift 27) + (i64.rotate-right rot) + .i64))]))) (def: #export (xoroshiro-128+ [s0 s1]) {#.doc (doc "An implementation of the Xoroshiro128+ algorithm." @@ -366,3 +372,22 @@ (i64.xor (i64.left-shift 14 s01))) (i64.rotate-left 36 s01)])) ("lux i64 +" s0 s1)])) + +## https://en.wikipedia.org/wiki/Xorshift#Initialization +## http://xorshift.di.unimi.it/splitmix64.c +(def: #export split-mix-64 + {#.doc (doc "An implementation of the SplitMix64 algorithm.")} + (-> Nat PRNG) + (let [twist (: (-> Nat Nat Nat) + (function (_ shift value) + (i64.xor (i64.logic-right-shift shift value) value))) + mix n.*] + (..prng (n.+ (hex "9E,37,79,B9,7F,4A,7C,15")) + (|>> (twist 30) + (mix (hex "BF,58,47,6D,1C,E4,E5,B9")) + + (twist 27) + (mix (hex "94,D0,49,BB,13,31,11,EB")) + + (twist 31) + .i64)))) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 7da6195f4..80df67812 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -30,7 +30,9 @@ ["." meta] [macro [syntax (#+ syntax:)] - ["." code]]]) + ["." code]] + [world + ["." program]]]) (type: #export Counters {#successes Nat @@ -232,9 +234,10 @@ _ (log! (format documentation text.new-line text.new-line (tally duration counters) text.new-line))]] - (promise.future (io.exit (case (get@ #failures counters) - 0 ..success-exit-code - _ ..failure-exit-code))))) + (promise.future (\ program.default exit + (case (get@ #failures counters) + 0 ..success-exit-code + _ ..failure-exit-code))))) (def: (|cover'| coverage condition) (-> (List Name) Bit Assertion) diff --git a/stdlib/source/lux/world/environment.lux b/stdlib/source/lux/world/environment.lux deleted file mode 100644 index f86b0c262..000000000 --- a/stdlib/source/lux/world/environment.lux +++ /dev/null @@ -1,67 +0,0 @@ -(.module: - [lux #* - ["@" target] - [host (#+ import:)] - [control - ["." io (#+ IO)]] - [data - ["." text] - [collection - ["." dictionary (#+ Dictionary)]]]]) - -(type: #export Property - Text) - -(type: #export Environment - (Dictionary Property Text)) - -## Do not trust the values of environment variables -## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables - -(with-expansions [<jvm> (as-is (import: java/lang/String) - - (import: (java/util/Map$Entry k v) - ["#::." - (getKey [] k) - (getValue [] v)]) - - (import: (java/util/Iterator a) - ["#::." - (hasNext [] boolean) - (next [] a)]) - - (import: (java/util/Set a) - ["#::." - (iterator [] (java/util/Iterator a))]) - - (import: (java/util/Map k v) - ["#::." - (entrySet [] (java/util/Set (java/util/Map$Entry k v)))]) - - (import: java/lang/System - ["#::." - (#static getenv [] (java/util/Map java/lang/String java/lang/String))]) - - (def: (consume f iterator) - (All [a b] (-> (-> a b) (java/util/Iterator a) (List b))) - (if (java/util/Iterator::hasNext iterator) - (#.Cons (f (java/util/Iterator::next iterator)) - (consume f iterator)) - #.Nil)) - - (def: (to-kv entry) - (All [k v] (-> (java/util/Map$Entry k v) [k v])) - [(java/util/Map$Entry::getKey entry) - (java/util/Map$Entry::getValue entry)]))] - (for {@.old (as-is <jvm>) - @.jvm (as-is <jvm>)})) - -(def: #export read - (IO Environment) - (with-expansions [<jvm> (as-is (io.io (|> (java/lang/System::getenv) - java/util/Map::entrySet - java/util/Set::iterator - (..consume ..to-kv) - (dictionary.from-list text.hash))))] - (for {@.old <jvm> - @.jvm <jvm>}))) diff --git a/stdlib/source/lux/world/program.lux b/stdlib/source/lux/world/program.lux new file mode 100644 index 000000000..486e5b7b6 --- /dev/null +++ b/stdlib/source/lux/world/program.lux @@ -0,0 +1,128 @@ +(.module: + [lux #* + ["@" target] + [host (#+ import:)] + [abstract + [monad (#+ do)]] + [control + ["." function] + ["." io (#+ IO)] + [concurrency + ["." atom] + ["." promise (#+ Promise)]] + [parser + [environment (#+ Environment)]]] + [data + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." dictionary (#+ Dictionary)]]]] + [// + [file (#+ Path)] + [shell (#+ Exit)]]) + +(signature: #export (Program !) + (: (-> Any (! Environment)) + environment) + (: (-> Any (! Path)) + directory) + (: (-> Exit (! Nothing)) + exit)) + +(def: #export (async program) + (-> (Program IO) (Program Promise)) + (structure + (def: environment + (|>> (\ program environment) promise.future)) + (def: directory + (|>> (\ program directory) promise.future)) + (def: exit + (|>> (\ program exit) promise.future)))) + +(def: #export (mock environment directory) + (-> Environment Path (Program IO)) + (let [@dead? (atom.atom false)] + (structure + (def: environment + (function.constant (io.io environment))) + (def: directory + (function.constant (io.io directory))) + (def: (exit code) + (io.io (error! (%.int code))))))) + +## Do not trust the values of environment variables +## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables + +(with-expansions [<jvm> (as-is (import: java/lang/String) + + (import: (java/util/Map$Entry k v) + ["#::." + (getKey [] k) + (getValue [] v)]) + + (import: (java/util/Iterator a) + ["#::." + (hasNext [] boolean) + (next [] a)]) + + (import: (java/util/Set a) + ["#::." + (iterator [] (java/util/Iterator a))]) + + (import: (java/util/Map k v) + ["#::." + (entrySet [] (java/util/Set (java/util/Map$Entry k v)))]) + + (import: java/lang/System + ["#::." + (#static getenv [] (java/util/Map java/lang/String java/lang/String)) + (#static exit [int] #io void)]) + + (def: (jvm\\consume f iterator) + (All [a b] (-> (-> a b) (java/util/Iterator a) (List b))) + (if (java/util/Iterator::hasNext iterator) + (#.Cons (f (java/util/Iterator::next iterator)) + (jvm\\consume f iterator)) + #.Nil)) + + (def: (jvm\\to-kv entry) + (All [k v] (-> (java/util/Map$Entry k v) [k v])) + [(java/util/Map$Entry::getKey entry) + (java/util/Map$Entry::getValue entry)]) + + (def: jvm\\environment + (IO Environment) + (with-expansions [<jvm> (as-is (io.io (|> (java/lang/System::getenv) + java/util/Map::entrySet + java/util/Set::iterator + (..jvm\\consume ..jvm\\to-kv) + (dictionary.from-list text.hash))))] + (for {@.old <jvm> + @.jvm <jvm>}))) + )] + (for {@.old (as-is <jvm>) + @.jvm (as-is <jvm>)})) + +(structure: #export default + (Program IO) + + (def: (environment _) + (with-expansions [<jvm> ..jvm\\environment] + (for {@.old <jvm> + @.jvm <jvm>}))) + + (def: (directory _) + (with-expansions [<jvm> (\ io.monad map + (|>> (dictionary.get "user.dir") + (maybe.default "")) + ..jvm\\environment)] + (for {@.old <jvm> + @.jvm <jvm>}))) + + (def: (exit code) + (with-expansions [<jvm> (do io.monad + [_ (java/lang/System::exit code)] + (wrap (undefined)))] + (for {@.old <jvm> + @.jvm <jvm>})))) diff --git a/stdlib/source/lux/world/shell.lux b/stdlib/source/lux/world/shell.lux index 142fb54e4..b3826f21f 100644 --- a/stdlib/source/lux/world/shell.lux +++ b/stdlib/source/lux/world/shell.lux @@ -13,7 +13,9 @@ ["?" policy (#+ Context Safety Safe)]] [concurrency ["." stm (#+ Var STM)] - ["." promise (#+ Promise) ("#\." monad)]]] + ["." promise (#+ Promise) ("#\." monad)]] + [parser + [environment (#+ Environment)]]] [data ["." product] [number (#+ hex) @@ -26,7 +28,6 @@ ["." list ("#\." fold functor)] ["." dictionary]]]] [// - [environment (#+ Environment)] [file (#+ Path)]]) (capability: #export (Can-Read !) diff --git a/stdlib/source/program/licentia.lux b/stdlib/source/program/licentia.lux index e95c261a9..032269af3 100644 --- a/stdlib/source/program/licentia.lux +++ b/stdlib/source/program/licentia.lux @@ -13,12 +13,16 @@ (.module: [lux #* + [host (#+ import:)] [abstract [monad (#+ do)]] [control [remember (#+ to-do)] + ["." io (#+ IO) ("#\." monad)] ["." try (#+ Try)] - ["." parser] + ["." parser + ["." cli (#+ program:)] + ["<.>" json]] [security ["!" capability]]] [data @@ -28,21 +32,19 @@ ["." encoding]] [format ["." json]]] - ["." cli (#+ program:)] - ["." io (#+ IO) ("#\." monad)] [world - ["." file (#+ Path File)]] - [host (#+ import:)]] + ["." file (#+ Path File)]]] ["." / #_ ["#." input] ["#." output]]) -(with-expansions [<expiry> "2019-04-01"] +(with-expansions [<expiry> "2021-04-01"] (to-do <expiry> "Replace _.work with _.covered-work or _.licensed-work") (to-do <expiry> "Create a short notice to add as a comment to each file in the _.work")) (import: java/lang/String - (trim [] java/lang/String)) + ["#::." + (trim [] java/lang/String)]) (def: default-output-file "LICENSE") @@ -57,23 +59,24 @@ (do io.monad [?done (: (IO (Try Any)) (do (try.with io.monad) - [file (!.use (\ file.default file) input) + [file (!.use (\ file.default file) [input]) blob (!.use (\ file content) []) - document (io\wrap (do try.monad + document (io\wrap (do {! try.monad} [raw-json (encoding.from-utf8 blob) json (|> raw-json (:coerce java/lang/String) java/lang/String::trim (:coerce Text) - (\ json.codec decode)) - license (json.run json /input.license)] - (wrap (/output.license license)))) + (\ json.codec decode))] + (|> json + (<json>.run /input.license) + (\ ! map /output.license)))) output-file (: (IO (Try (File IO))) (file.get-file io.monad file.default output))] (!.use (\ output-file over-write) (encoding.to-utf8 document))))] - (case ?done - (#try.Success _) - (wrap (log! (success-message output))) + (wrap (log! (case ?done + (#try.Success _) + (success-message output) - (#try.Failure message) - (wrap (log! message))))) + (#try.Failure message) + message))))) diff --git a/stdlib/source/program/licentia/input.lux b/stdlib/source/program/licentia/input.lux index 7d2192fe1..48617f045 100644 --- a/stdlib/source/program/licentia/input.lux +++ b/stdlib/source/program/licentia/input.lux @@ -1,14 +1,14 @@ (.module: [lux #* + [abstract + [monad (#+ do)]] [control - [monad (#+ do)] - ["ex" exception (#+ exception:)] - ["." parser]] + ["." exception (#+ exception:)] + ["." parser + ["." json (#+ Parser)]]] [data [text ["%" format (#+ format)]] - [format - ["." json (#+ Reader)]] [number ["n" nat] ["i" int] @@ -27,55 +27,58 @@ ["." copyright]]]) (def: identification - (Reader Identification) + (Parser Identification) (json.object ($_ parser.and (json.field "name" json.string) (json.field "version" json.string)))) (exception: #export (cannot-use-fractional-amount {amount Frac}) - (ex.report ["Amount" (%.frac amount)])) + (exception.report + ["Amount" (%.frac amount)])) (exception: #export (cannot-use-negative-amount {amount Int}) - (ex.report ["Amount" (%.int amount)])) + (exception.report + ["Amount" (%.int amount)])) (def: amount - (Reader Nat) + (Parser Nat) (do parser.monad [amountF json.number #let [amountI (f.int amountF)] - _ (parser.assert (ex.construct cannot-use-fractional-amount amountF) + _ (parser.assert (exception.construct cannot-use-fractional-amount amountF) (f.= amountF (i.frac amountI))) - _ (parser.assert (ex.construct cannot-use-negative-amount amountI) + _ (parser.assert (exception.construct cannot-use-negative-amount amountI) (i.> +0 amountI))] (wrap (.nat amountI)))) (exception: #export (invalid-period {period (Period Nat)}) - (ex.report ["Start" (%.nat (get@ #time.start period))] - ["End" (%.nat (get@ #time.end period))])) + (exception.report + ["Start" (%.nat (get@ #time.start period))] + ["End" (%.nat (get@ #time.end period))])) (def: period - (Reader (Period Nat)) + (Parser (Period Nat)) (json.object (do parser.monad [start (json.field "start" ..amount) end (json.field "end" ..amount) #let [period {#time.start start #time.end end}] - _ (parser.assert (ex.construct invalid-period period) + _ (parser.assert (exception.construct invalid-period period) (n.<= end start))] (wrap period)))) (def: copyright-holder - (Reader copyright.Holder) + (Parser copyright.Holder) (json.object ($_ parser.and (json.field "name" json.string) (json.field "period" ..period)))) (def: termination - (Reader Termination) + (Parser Termination) (json.object ($_ parser.and (json.field "patent retaliation?" json.boolean) @@ -83,21 +86,21 @@ (json.field "grace period" ..amount)))) (def: liability - (Reader Liability) + (Parser Liability) (json.object ($_ parser.and (json.field "can accept?" json.boolean) (json.field "disclaim high risk?" json.boolean)))) (def: distribution - (Reader Distribution) + (Parser Distribution) (json.object ($_ parser.and (json.field "can re-license?" json.boolean) (json.field "can multi-license?" json.boolean)))) (def: commercial - (Reader Commercial) + (Parser Commercial) (json.object ($_ parser.and (json.field "can sell?" json.boolean) @@ -105,7 +108,7 @@ (json.field "allow contributor endorsement?" json.boolean)))) (def: extension - (Reader Extension) + (Parser Extension) (json.object ($_ parser.and (json.field "same license?" json.boolean) @@ -114,22 +117,22 @@ (json.field "must describe modifications?" json.boolean)))) (def: entity - (Reader Entity) + (Parser Entity) json.string) (def: black-list - (Reader Black-List) + (Parser Black-List) (json.object ($_ parser.and (json.field "justification" (json.nullable json.string)) (json.field "entities" (json.array (parser.many ..entity)))))) (def: url - (Reader URL) + (Parser URL) json.string) (def: attribution - (Reader Attribution) + (Parser Attribution) (json.object ($_ parser.and (json.field "copyright-notice" json.string) @@ -138,7 +141,7 @@ (json.field "image" (json.nullable ..url))))) (def: #export license - (Reader License) + (Parser License) (json.object ($_ parser.and (json.field "copyright-holders" (json.array (parser.many ..copyright-holder))) diff --git a/stdlib/source/program/licentia/license.lux b/stdlib/source/program/licentia/license.lux index 375ed8c12..c62c8419d 100644 --- a/stdlib/source/program/licentia/license.lux +++ b/stdlib/source/program/licentia/license.lux @@ -46,6 +46,9 @@ #url URL #image (Maybe URL)}) +(type: #export Addendum + {#commons-clause? Bit}) + (type: #export License {#copyright-holders (List /copyright.Holder) #identification (Maybe Identification) @@ -55,4 +58,5 @@ #commercial Commercial #extension Extension #black-lists (List Black-List) - #attribution (Maybe Attribution)}) + #attribution (Maybe Attribution) + #addendum Addendum}) diff --git a/stdlib/source/program/licentia/license/addendum.lux b/stdlib/source/program/licentia/license/addendum.lux new file mode 100644 index 000000000..7e467c630 --- /dev/null +++ b/stdlib/source/program/licentia/license/addendum.lux @@ -0,0 +1,28 @@ +(.module: + [lux #* + [data + [text + ["%" format (#+ format)]]]] + ["." // (#+ Addendum) + [// + ["$" document]]]) + +## https://commonsclause.com/ +(def: #export commons-clause + Text + (format ($.block "The Software is provided to you by the Licensor under the License, as defined below, subject to the following condition.") + ($.block "Without limiting other conditions in the License, the grant of rights under the License will not include, and the License does not grant to you, the right to Sell the Software.") + ($.block "For purposes of the foregoing, “Sell” means practicing any or all of the rights granted to you under the License to provide to third parties, for a fee or other consideration (including without limitation fees for hosting or consulting/ support services related to the Software), a product or service whose value derives, entirely or substantially, from the functionality of the Software. Any license notice or attribution required by the License must also include this Commons Clause License Condition notice."))) + +(def: #export (output value) + (-> Addendum Text) + (`` (format (~~ (template [<title> <condition> <content>] + [(if <condition> + ($.block ($.section {#$.title <title> + #$.content <content>})) + "")] + + ["“Commons Clause” License Condition v1.0" + (get@ #//.commons-clause? value) + ..commons-clause] + ))))) diff --git a/stdlib/source/program/licentia/output.lux b/stdlib/source/program/licentia/output.lux index 5d3899170..fdbd9accd 100644 --- a/stdlib/source/program/licentia/output.lux +++ b/stdlib/source/program/licentia/output.lux @@ -29,7 +29,8 @@ ["." miscellaneous] ["." black-list] ["." notice] - ["_" term]] + ["_" term] + ["." addendum]] ["$" document]]) (def: #export (definition value) @@ -301,6 +302,8 @@ (maybe.default "")) (..miscellaneous identified?) + + (addendum.output (get@ #license.addendum value)) notice.end-of-license )))) diff --git a/stdlib/source/spec/lux/world/program.lux b/stdlib/source/spec/lux/world/program.lux new file mode 100644 index 000000000..1d09908bf --- /dev/null +++ b/stdlib/source/spec/lux/world/program.lux @@ -0,0 +1,31 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + [concurrency + ["." promise (#+ Promise)]]] + [data + ["." text] + [collection + ["." dictionary] + ["." list]]] + [math + ["." random]]] + {1 + ["." /]}) + +(def: #export (spec subject) + (-> (/.Program Promise) Test) + (do random.monad + [exit random.int] + (wrap (do promise.monad + [environment (\ subject environment []) + directory (\ subject directory [])] + (_.cover' [/.Program] + (and (not (dictionary.empty? environment)) + (list.every? (|>> text.empty? not) + (dictionary.keys environment)) + (not (text.empty? directory)))))))) diff --git a/stdlib/source/spec/lux/world/shell.lux b/stdlib/source/spec/lux/world/shell.lux index 27ccf321c..b6aa282d4 100644 --- a/stdlib/source/spec/lux/world/shell.lux +++ b/stdlib/source/spec/lux/world/shell.lux @@ -10,7 +10,7 @@ [concurrency ["." promise (#+ Promise)]] [parser - ["." environment]]] + ["." environment (#+ Environment)]]] [data ["." product] ["." text ("#\." equivalence) @@ -23,7 +23,6 @@ {1 ["." / [// - [environment (#+ Environment)] [file (#+ Path)]]]}) (template [<name> <command> <type> <prep>] diff --git a/stdlib/source/test/licentia.lux b/stdlib/source/test/licentia.lux index 92b43b20c..af03062cb 100644 --- a/stdlib/source/test/licentia.lux +++ b/stdlib/source/test/licentia.lux @@ -1,9 +1,12 @@ (.module: [lux #* - [cli (#+ program:)] ["_" test (#+ Test)] - [abstract/monad (#+ do)] - [io (#+ io)] + [abstract + [monad (#+ do)]] + [control + [io (#+ io)] + [parser + [cli (#+ program:)]]] [data ["." bit ("#\." equivalence)] ["." maybe ("#\." functor)] @@ -13,7 +16,7 @@ [collection ["." list ("#\." functor)]]] [math - ["r" random (#+ Random)]]] + ["." random (#+ Random)]]] {#program [/ ["." license (#+ Identification @@ -24,6 +27,7 @@ Extension Entity Black-List URL Attribution + Addendum License) ["." time (#+ Period)] ["." copyright] @@ -37,108 +41,117 @@ ["." commercial] ["." extension] ["." miscellaneous] - ["." black-list]] + ["." black-list] + ["." addendum]] ["." output]]}) (def: period (Random (Period Nat)) - (do {! r.monad} - [start (r.filter (|>> (n.= n\top) not) - r.nat) + (do {! random.monad} + [start (random.filter (|>> (n.= n\top) not) + random.nat) #let [wiggle-room (n.- start n\top)] end (\ ! map (|>> (n.% wiggle-room) (n.max 1)) - r.nat)] + random.nat)] (wrap {#time.start start #time.end end}))) (def: copyright-holder (Random copyright.Holder) - ($_ r.and - (r.ascii 10) + ($_ random.and + (random.ascii 10) ..period)) (def: identification (Random Identification) - ($_ r.and - (r.ascii 10) - (r.ascii 10))) + ($_ random.and + (random.ascii 10) + (random.ascii 10))) (def: termination (Random Termination) - ($_ r.and - r.bit - r.nat - r.nat)) + ($_ random.and + random.bit + random.nat + random.nat)) (def: liability (Random Liability) - ($_ r.and - r.bit - r.bit)) + ($_ random.and + random.bit + random.bit)) (def: distribution (Random Distribution) - ($_ r.and - r.bit - r.bit)) + ($_ random.and + random.bit + random.bit)) (def: commercial (Random Commercial) - ($_ r.and - r.bit - r.bit - r.bit)) + ($_ random.and + random.bit + random.bit + random.bit)) (def: extension (Random Extension) - ($_ r.and - r.bit - r.bit - (r.maybe ..period) - r.bit)) + ($_ random.and + random.bit + random.bit + (random.maybe ..period) + random.bit)) (def: entity (Random Entity) - (r.ascii 10)) + (random.ascii 10)) (def: (variable-list max-size gen-element) (All [a] (-> Nat (Random a) (Random (List a)))) - (do {! r.monad} + (do {! random.monad} [amount (\ ! map (n.% (n.max 1 max-size)) - r.nat)] - (r.list amount gen-element))) + random.nat)] + (random.list amount gen-element))) (def: black-list (Random Black-List) - ($_ r.and - (r.maybe (r.ascii 10)) + ($_ random.and + (random.maybe (random.ascii 10)) (variable-list 10 ..entity))) (def: url (Random URL) - (r.ascii 10)) + (random.ascii 10)) (def: attribution (Random Attribution) - ($_ r.and - (r.ascii 10) - (r.maybe (r.ascii 10)) + ($_ random.and + (random.ascii 10) + (random.maybe (random.ascii 10)) ..url - (r.maybe ..url))) + (random.maybe ..url))) + +(def: addendum + (Random Addendum) + ($_ random.and + random.bit + )) (def: license (Random License) - ($_ r.and - (r.list 2 ..copyright-holder) - (r.maybe ..identification) + ($_ random.and + (random.list 2 ..copyright-holder) + (random.maybe ..identification) ..termination ..liability ..distribution ..commercial ..extension (variable-list 3 ..black-list) - (r.maybe attribution))) + (random.maybe attribution) + ..addendum + )) (type: (Concern a) (-> (-> Text Bit) a Test)) @@ -263,9 +276,17 @@ (present? miscellaneous.export-restrictions)) )) +(def: (about-addendum present? value) + (Concern Addendum) + ($_ _.and + (_.test "Commons clause" + (bit\= (get@ #license.commons-clause? value) + (present? addendum.commons-clause))) + )) + (def: test Test - (do r.monad + (do random.monad [license ..license #let [writ (output.license license) present? (: (-> Text Bit) @@ -337,6 +358,8 @@ (..about-miscellaneous present?) + (..about-addendum present? (get@ #license.addendum license)) + (_.test "License ending footer is present." (present? notice.end-of-license)) ))) diff --git a/stdlib/source/test/lux/control/io.lux b/stdlib/source/test/lux/control/io.lux index 4855e8c3f..596f29b11 100644 --- a/stdlib/source/test/lux/control/io.lux +++ b/stdlib/source/test/lux/control/io.lux @@ -45,8 +45,4 @@ (_.cover [/.run /.io] (n.= sample (/.run (/.io sample)))) - (_.cover [/.exit] - ## The /.exit is not actually executed because it would immediately - ## terminate the program/tests. - (exec (/.exit exit-code) - true)))))) + )))) diff --git a/stdlib/source/test/lux/data/number/frac.lux b/stdlib/source/test/lux/data/number/frac.lux index 193b4a960..08fcef498 100644 --- a/stdlib/source/test/lux/data/number/frac.lux +++ b/stdlib/source/test/lux/data/number/frac.lux @@ -183,11 +183,19 @@ (/.mod left right)))))) )) (with-expansions [<jvm> ($_ _.and - (do random.monad - [expected random.frac] - (_.cover [/.to-bits] - (n.= (.nat (java/lang/Double::doubleToRawLongBits expected)) - (/.to-bits expected)))) + (let [test (: (-> Frac Bit) + (function (_ value) + (n.= (.nat (java/lang/Double::doubleToRawLongBits value)) + (/.to-bits value))))] + (do random.monad + [sample random.frac] + (_.cover [/.to-bits] + (and (test sample) + (test /.biggest) + (test /.smallest) + (test /.not-a-number) + (test /.positive-infinity) + (test /.negative-infinity))))) (do random.monad [sample random.i64] (_.cover [/.from-bits] @@ -199,13 +207,21 @@ )] (for {@.old <jvm> @.jvm <jvm>} - (do random.monad - [expected random.frac] - (_.cover [/.to-bits /.from-bits] - (let [actual (|> expected /.to-bits /.from-bits)] - (or (/.= expected actual) - (and (/.not-a-number? expected) - (/.not-a-number? actual)))))))) + (let [test (: (-> Frac Bit) + (function (_ expected) + (let [actual (|> expected /.to-bits /.from-bits)] + (or (/.= expected actual) + (and (/.not-a-number? expected) + (/.not-a-number? actual))))))] + (do random.monad + [sample random.frac] + (_.cover [/.to-bits /.from-bits] + (and (test sample) + (test /.biggest) + (test /.smallest) + (test /.not-a-number) + (test /.positive-infinity) + (test /.negative-infinity))))))) (do random.monad [expected random.safe-frac] (_.cover [/.negate] diff --git a/stdlib/source/test/lux/data/number/int.lux b/stdlib/source/test/lux/data/number/int.lux index 31b732b88..16c23246a 100644 --- a/stdlib/source/test/lux/data/number/int.lux +++ b/stdlib/source/test/lux/data/number/int.lux @@ -17,7 +17,7 @@ ["f" frac] ["." i64 ("#\." hash)]]] [math - ["." random]]] + ["." random (#+ Random)]]] {1 ["." /]}) @@ -53,8 +53,7 @@ (def: predicate Test (do {! random.monad} - [sample random.int - shift (\ ! map /.abs random.int)] + [sample random.int] ($_ _.and (_.cover [/.negative?] (bit\= (/.negative? sample) @@ -132,7 +131,9 @@ (/.mod left right)))))) )) (do {! random.monad} - [#let [random (\ ! map (/.% +1,000) random.int)] + [#let [random (|> random.int + (\ ! map (/.% +1,000)) + (random.filter (|>> (/.= +0) not)))] left random right random] ($_ _.and diff --git a/stdlib/source/test/lux/data/number/nat.lux b/stdlib/source/test/lux/data/number/nat.lux index e07f584b1..6e027eab1 100644 --- a/stdlib/source/test/lux/data/number/nat.lux +++ b/stdlib/source/test/lux/data/number/nat.lux @@ -1,6 +1,5 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract [monad (#+ do)] @@ -12,38 +11,120 @@ ["$." interval] ["$." monoid] ["$." codec]]}] + [data + ["." bit ("#\." equivalence)] + [number + ["f" frac] + ["." i64 ("#\." hash)]]] [math - ["r" random]]] + ["." random]]] {1 - ["." / - //]}) + ["." /]}) -(def: #export test +(def: signature Test - (<| (_.context (%.name (name-of /._))) - (`` ($_ _.and - ($equivalence.spec /.equivalence r.nat) - ($order.spec /.order r.nat) - ($enum.spec /.enum r.nat) - ($interval.spec /.interval r.nat) - (~~ (template [<monoid>] - [(<| (_.context (%.name (name-of <monoid>))) - ($monoid.spec /.equivalence <monoid> r.nat))] + (`` ($_ _.and + (_.with-cover [/.equivalence /.=] + ($equivalence.spec /.equivalence random.nat)) + (_.with-cover [/.order /.<] + ($order.spec /.order random.nat)) + (_.with-cover [/.enum] + ($enum.spec /.enum random.nat)) + (_.with-cover [/.interval] + ($interval.spec /.interval random.nat)) + (~~ (template [<compose> <monoid>] + [(_.with-cover [<monoid> <compose>] + ($monoid.spec /.equivalence <monoid> random.nat))] + + [/.+ /.addition] + [/.* /.multiplication] + + [/.min /.minimum] + [/.max /.maximum] + )) + (~~ (template [<codec>] + [(_.with-cover [<codec>] + ($codec.spec /.equivalence <codec> random.nat))] + + [/.binary] [/.octal] [/.decimal] [/.hex] + )) + ))) - [/.addition] [/.multiplication] [/.minimum] [/.maximum] - )) - (~~ (template [<codec>] - [(<| (_.context (%.name (name-of /.binary))) - ($codec.spec /.equivalence <codec> r.nat))] +(def: predicate + Test + (do {! random.monad} + [sample random.nat] + ($_ _.and + (_.cover [/.even? /.odd?] + (bit\= (/.even? sample) + (not (/.odd? sample)))) + ))) - [/.binary] [/.octal] [/.decimal] [/.hex] - )) +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [.Nat]) + ($_ _.and + (do random.monad + [sample random.nat] + ($_ _.and + (_.cover [/.-] + (and (/.= 0 (/.- sample sample)) + (/.= sample (/.- 0 sample)))) + (_.cover [/./] + (and (/.= 1 (/./ sample sample)) + (/.= sample (/./ 1 sample)))) + )) + (do random.monad + [left random.nat + right random.nat] + ($_ _.and + (_.cover [/.>] + (bit\= (/.> left right) + (/.< right left))) + (_.cover [/.<= /.>=] + (bit\= (/.<= left right) + (/.>= right left))) + )) + (do random.monad + [left (random.filter (|>> (/.= 0) not) + random.nat) + right random.nat] + ($_ _.and + (_.cover [/.%] + (let [rem (/.% left right) + div (|> right (/.- rem) (/./ left))] + (/.= right + (|> div (/.* left) (/.+ rem))))) + (_.cover [/./%] + (let [[div rem] (/./% left right)] + (and (/.= div (/./ left right)) + (/.= rem (/.% left right))))) + )) + (do {! random.monad} + [#let [random (\ ! map (|>> (/.% 1,000) inc) random.nat)] + left random + right random] + ($_ _.and + (_.cover [/.gcd] + (let [gcd (/.gcd left right)] + (and (/.= 0 (/.% gcd left)) + (/.= 0 (/.% gcd right))))) + (_.cover [/.lcm] + (let [lcm (/.lcm left right)] + (and (/.= 0 (/.% left lcm)) + (/.= 0 (/.% right lcm))))) + )) + (do {! random.monad} + [expected (\ ! map (/.% 1,000,000) random.nat)] + (_.cover [/.frac] + (|> expected /.frac f.nat (/.= expected)))) + (do random.monad + [sample random.nat] + (_.cover [/.hash] + (i64\= (i64\hash sample) + (\ /.hash hash sample)))) - (_.test "Alternate notations." - (and (/.= (bin "11001001") - (bin "11,00,10,01")) - (/.= (oct "615243") - (oct "615,243")) - (/.= (hex "deadBEEF") - (hex "dead,BEEF")))) - )))) + ..predicate + ..signature + ))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux index dccabcea7..4041ceaba 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux @@ -187,8 +187,6 @@ (check-success+ "lux io log" (list logC) Any)) (_.test "Can throw a run-time error." (check-success+ "lux io error" (list logC) Nothing)) - (_.test "Can exit the program." - (check-success+ "lux io exit" (list exitC) Nothing)) (_.test "Can query the current time (as milliseconds since epoch)." (check-success+ "lux io current-time" (list) Int)) ))) diff --git a/stdlib/source/test/lux/world.lux b/stdlib/source/test/lux/world.lux index e7aa38aa1..0405ef7ee 100644 --- a/stdlib/source/test/lux/world.lux +++ b/stdlib/source/test/lux/world.lux @@ -2,16 +2,16 @@ [lux #* ["_" test (#+ Test)]] ["." / #_ - ["#." environment] ["#." file] ["#." shell] - ["#." console]]) + ["#." console] + ["#." program]]) (def: #export test Test ($_ _.and - /environment.test /file.test /shell.test /console.test + /program.test )) diff --git a/stdlib/source/test/lux/world/environment.lux b/stdlib/source/test/lux/world/environment.lux deleted file mode 100644 index 28bcfc377..000000000 --- a/stdlib/source/test/lux/world/environment.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - [lux #* - ["_" test (#+ Test)] - [abstract - [monad (#+ do)]] - [control - [concurrency - ["." promise]]] - [data - ["." text] - [collection - ["." dictionary] - ["." list]]] - [math - ["." random]]] - {1 - ["." /]}) - -(def: #export test - Test - (<| (_.covering /._) - (_.with-cover [/.Environment /.Property]) - (do random.monad - [_ (wrap [])] - (wrap (do promise.monad - [environment (promise.future /.read)] - (_.cover' [/.read] - (and (not (dictionary.empty? environment)) - (|> environment - dictionary.keys - (list.every? (|>> text.empty? not)))))))))) diff --git a/stdlib/source/test/lux/world/program.lux b/stdlib/source/test/lux/world/program.lux new file mode 100644 index 000000000..5dcf6270a --- /dev/null +++ b/stdlib/source/test/lux/world/program.lux @@ -0,0 +1,39 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + [parser + [environment (#+ Environment)]]] + [data + ["." text]] + [math + ["." random (#+ Random)]]] + {1 + ["." / + [// + [file (#+ Path)]]]} + {[1 #spec] + ["$." /]}) + +(def: environment + (Random Environment) + (random.dictionary text.hash 5 + (random.ascii/alpha 5) + (random.ascii/alpha 5))) + +(def: directory + (Random Path) + (random.ascii/alpha 5)) + +(def: #export test + Test + (<| (_.covering /._) + (do random.monad + [environment ..environment + directory ..directory] + ($_ _.and + (_.with-cover [/.mock /.async] + ($/.spec (/.async (/.mock environment directory)))) + )))) diff --git a/stdlib/source/test/lux/world/shell.lux b/stdlib/source/test/lux/world/shell.lux index e9d844141..cf349e225 100644 --- a/stdlib/source/test/lux/world/shell.lux +++ b/stdlib/source/test/lux/world/shell.lux @@ -13,7 +13,7 @@ [security ["!" capability]] [parser - ["." environment]]] + ["." environment (#+ Environment)]]] [data ["." text ("#\." equivalence)] [number @@ -26,7 +26,6 @@ {1 ["." / [// - [environment (#+ Environment)] [file (#+ Path)]]]} {[1 #spec] ["$." /]}) |