aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--stdlib/source/library/lux/data/color.lux135
-rw-r--r--stdlib/source/library/lux/data/color/hsb.lux152
-rw-r--r--stdlib/source/library/lux/data/color/hsl.lux39
-rw-r--r--stdlib/source/library/lux/math/number/i16.lux30
-rw-r--r--stdlib/source/library/lux/math/number/i32.lux34
-rw-r--r--stdlib/source/library/lux/math/number/i8.lux30
-rw-r--r--stdlib/source/library/lux/meta/type/quotient.lux86
-rw-r--r--stdlib/source/library/lux/meta/type/refinement.lux101
-rw-r--r--stdlib/source/library/lux/test/benchmark.lux54
-rw-r--r--stdlib/source/library/lux/world/money/currency.lux37
-rw-r--r--stdlib/source/library/lux/world/time/duration.lux4
-rw-r--r--stdlib/source/test/lux/data/color/hsb.lux88
-rw-r--r--stdlib/source/test/lux/data/color/hsl.lux55
-rw-r--r--stdlib/source/test/lux/math/number/complex.lux3
-rw-r--r--stdlib/source/test/lux/test.lux4
-rw-r--r--stdlib/source/test/lux/test/benchmark.lux68
16 files changed, 619 insertions, 301 deletions
diff --git a/stdlib/source/library/lux/data/color.lux b/stdlib/source/library/lux/data/color.lux
index 23388a61c..fc79bb0db 100644
--- a/stdlib/source/library/lux/data/color.lux
+++ b/stdlib/source/library/lux/data/color.lux
@@ -22,24 +22,8 @@
["[0]" nominal]]]]]
[/
["[0]" rgb (.only RGB)]
- ["[0]" hsl]])
-
-(def top
- (-- rgb.limit))
-
-(def rgb_factor
- (|> top .int int.frac))
-
-(def down
- (-> Nat Frac)
- (|>> .int int.frac (f./ rgb_factor)))
-
-(def up
- (-> Frac Nat)
- (|>> (f.* rgb_factor) f.int .nat))
-
-(type .public HSB
- [Frac Frac Frac])
+ ["[0]" hsl]
+ ["[0]" hsb]])
(nominal.def .public Color
RGB
@@ -94,57 +78,6 @@
nominal.abstraction))
)
-(def .public (hsb color)
- (-> Color HSB)
- (let [[red green blue] (rgb color)
- red (..down (rgb.number red))
- green (..down (rgb.number green))
- blue (..down (rgb.number blue))
- max (all f.max red green blue)
- min (all f.min red green blue)
- brightness max
- diff (|> max (f.- min))
- saturation (if (f.= +0.0 max)
- +0.0
- (|> diff (f./ max)))]
- (if (f.= max min)
- ... Achromatic
- [+0.0 saturation brightness]
- ... Chromatic
- (let [hue (cond (f.= red max)
- (|> green (f.- blue) (f./ diff)
- (f.+ (if (f.< blue green) +6.0 +0.0)))
-
- (f.= green max)
- (|> blue (f.- red) (f./ diff)
- (f.+ +2.0))
-
- ... (f.= blue max)
- (|> red (f.- green) (f./ diff)
- (f.+ +4.0)))]
- [(|> hue (f./ +6.0))
- saturation
- brightness]))))
-
-(def .public (of_hsb [hue saturation brightness])
- (-> HSB Color)
- (let [hue (|> hue (f.* +6.0))
- i (f.floor hue)
- f (|> hue (f.- i))
- p (|> +1.0 (f.- saturation) (f.* brightness))
- q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness))
- t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness))
- v brightness
- mod (|> i (f.% +6.0) f.int .nat)
- red (when mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined))
- green (when mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined))
- blue (when mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))]
- (|> (rgb.rgb (..up red)
- (..up green)
- (..up blue))
- try.trusted
- of_rgb)))
-
(def (normal ratio)
(-> Frac Frac)
(cond (f.> +1.0 ratio)
@@ -184,16 +117,15 @@
)
(with_template [<op> <name>]
- [(def .public (<name> ratio color)
+ [(def .public (<name> ratio it)
(-> Frac Color Color)
- (let [color (hsl.of_rgb (rgb color))]
- (|> (hsl.hsl (hsl.hue color)
- (|> color
+ (let [it (hsl.of_rgb (rgb it))]
+ (|> (hsl.hsl (hsl.hue it)
+ (|> it
hsl.saturation
(f.* (|> +1.0 (<op> (..normal ratio))))
(f.min +1.0))
- (hsl.luminance color))
- try.trusted
+ (hsl.luminance it))
hsl.rgb
of_rgb)))]
@@ -207,7 +139,6 @@
(|> (hsl.hsl +0.0
+0.0
(hsl.luminance color))
- try.trusted
hsl.rgb
of_rgb)))
@@ -222,13 +153,11 @@
(|> (hsl.hsl (|> hue (f.+ <1>) ..normal)
saturation
luminance)
- try.trusted
hsl.rgb
of_rgb)
(|> (hsl.hsl (|> hue (f.+ <2>) ..normal)
saturation
luminance)
- try.trusted
hsl.rgb
of_rgb)])))]
@@ -240,17 +169,20 @@
(with_template [<name> <1> <2> <3>]
[(`` (def .public (<name> color)
(-> Color [Color Color Color Color])
- (let [[hue saturation luminance] (hsb color)]
+ (let [it (hsl.of_rgb (..rgb color))
+ hue (hsl.hue it)
+ saturation (hsl.saturation it)
+ luminance (hsl.luminance it)
+ of_hue (is (-> hsl.Value
+ Color)
+ (function (_ hue)
+ (|> (hsl.hsl hue saturation luminance)
+ hsl.rgb
+ ..of_rgb)))]
[color
- (of_hsb [(|> hue (f.+ <1>) ..normal)
- saturation
- luminance])
- (of_hsb [(|> hue (f.+ <2>) ..normal)
- saturation
- luminance])
- (of_hsb [(|> hue (f.+ <3>) ..normal)
- saturation
- luminance])])))]
+ (|> hue (f.+ <1>) ..normal of_hue)
+ (|> hue (f.+ <2>) ..normal of_hue)
+ (|> hue (f.+ <3>) ..normal of_hue)])))]
[square (|> +1.0 (f./ +4.0)) (|> +2.0 (f./ +4.0)) (|> +3.0 (f./ +4.0))]
[tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))]
@@ -262,27 +194,36 @@
(type .public Palette
(-> Spread Nat Color (List Color)))
-(def .public (analogous spread variations color)
+(def .public (analogous spread variations it)
Palette
- (let [[hue saturation brightness] (hsb color)
+ (let [it (hsl.of_rgb (..rgb it))
+ hue (hsl.hue it)
+ saturation (hsl.saturation it)
+ luminance (hsl.luminance it)
spread (..normal spread)]
(list#each (function (_ idx)
- (of_hsb [(|> idx ++ .int int.frac (f.* spread) (f.+ hue) ..normal)
- saturation
- brightness]))
+ (|> (hsl.hsl (|> idx ++ .int int.frac (f.* spread) (f.+ hue) ..normal)
+ saturation
+ luminance)
+ hsl.rgb
+ ..of_rgb))
(list.indices variations))))
-(def .public (monochromatic spread variations color)
+(def .public (monochromatic spread variations it)
Palette
- (let [[hue saturation brightness] (hsb color)
+ (let [it (hsb.of_rgb (..rgb it))
+ hue (hsb.hue it)
+ saturation (hsb.saturation it)
+ brightness (hsb.brightness it)
spread (..normal spread)]
(|> (list.indices variations)
(list#each (|>> ++ .int int.frac
(f.* spread)
(f.+ brightness)
..normal
- [hue saturation]
- of_hsb)))))
+ (hsb.hsb hue saturation)
+ hsb.rgb
+ ..of_rgb)))))
(type .public Alpha
Rev)
diff --git a/stdlib/source/library/lux/data/color/hsb.lux b/stdlib/source/library/lux/data/color/hsb.lux
new file mode 100644
index 000000000..9f07a50eb
--- /dev/null
+++ b/stdlib/source/library/lux/data/color/hsb.lux
@@ -0,0 +1,152 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [equivalence (.only Equivalence)]]
+ [control
+ ["[0]" try]
+ [function
+ [predicate (.only Predicate)]]]
+ [math
+ [number
+ ["f" frac]
+ ["[0]" int]]]
+ [meta
+ [type
+ ["[0]" nominal]]]]]
+ [//
+ ["[0]" rgb (.only RGB)]])
+
+(type .public Value
+ Frac)
+
+(with_template [<value> <name>]
+ [(def .public <name>
+ Value
+ <value>)]
+
+ [+0.0 least]
+ [+1.0 most]
+ )
+
+(def .public (value? it)
+ (Predicate Frac)
+ (not (or (f.< ..least it)
+ (f.> ..most it))))
+
+(def .public value
+ (-> Frac
+ Value)
+ (|>> (f.max ..least)
+ (f.min ..most)))
+
+(nominal.def .public HSB
+ (Record
+ [#hue Value
+ #saturation Value
+ #brightness Value])
+
+ (def .public equivalence
+ (Equivalence HSB)
+ (implementation
+ (def (= left right)
+ (`` (and (,, (with_template [<slot>]
+ [(f.= (the <slot> (nominal.representation left))
+ (the <slot> (nominal.representation right)))]
+
+ [#hue]
+ [#saturation]
+ [#brightness]
+ )))))))
+
+ (with_template [<name> <slot>]
+ [(def .public <name>
+ (-> HSB
+ Value)
+ (|>> nominal.representation
+ (the <slot>)))]
+
+ [hue #hue]
+ [saturation #saturation]
+ [brightness #brightness]
+ )
+
+ (def .public (hsb hue saturation brightness)
+ (-> Frac Frac Frac
+ HSB)
+ (nominal.abstraction
+ [#hue (..value hue)
+ #saturation (..value saturation)
+ #brightness (..value brightness)]))
+
+ (def top
+ (-- rgb.limit))
+
+ (def rgb_factor
+ (|> top .int int.frac))
+
+ (def down
+ (-> Nat
+ Frac)
+ (|>> .int int.frac (f./ rgb_factor)))
+
+ (def up
+ (-> Frac
+ Nat)
+ (|>> (f.* rgb_factor) f.int .nat))
+
+ (def .public (of_rgb it)
+ (-> RGB
+ HSB)
+ (let [red (..down (rgb.number (the rgb.#red it)))
+ green (..down (rgb.number (the rgb.#green it)))
+ blue (..down (rgb.number (the rgb.#blue it)))
+
+ max (all f.max red green blue)
+ min (all f.min red green blue)
+
+ brightness max
+ diff (|> max (f.- min))
+ saturation (if (f.= +0.0 max)
+ +0.0
+ (|> diff (f./ max)))]
+ (nominal.abstraction
+ [#hue (if (f.= max min)
+ ... Achromatic
+ +0.0
+ ... Chromatic
+ (cond (f.= max red)
+ (|> green (f.- blue) (f./ diff)
+ (f.+ (if (f.< blue green) +6.0 +0.0)))
+
+ (f.= max green)
+ (|> blue (f.- red) (f./ diff)
+ (f.+ +2.0))
+
+ ... (f.= max blue)
+ (|> red (f.- green) (f./ diff)
+ (f.+ +4.0))))
+ #saturation saturation
+ #brightness brightness])))
+
+ (def .public (rgb it)
+ (-> HSB
+ RGB)
+ (let [[hue saturation brightness] (nominal.representation it)
+ hue (|> hue (f.* +6.0))
+ i (f.floor hue)
+ f (|> hue (f.- i))
+ p (|> +1.0 (f.- saturation) (f.* brightness))
+ q (|> +1.0 (f.- (f.* f saturation)) (f.* brightness))
+ t (|> +1.0 (f.- (|> +1.0 (f.- f) (f.* saturation))) (f.* brightness))
+ v brightness
+ mod (|> i (f.% +6.0) f.int .nat)
+
+ red (when mod 0 v 1 q 2 p 3 p 4 t 5 v _ (undefined))
+ green (when mod 0 t 1 v 2 v 3 q 4 p 5 p _ (undefined))
+ blue (when mod 0 p 1 p 2 t 3 v 4 v 5 q _ (undefined))]
+ (try.trusted
+ (rgb.rgb (..up red)
+ (..up green)
+ (..up blue)))))
+ )
diff --git a/stdlib/source/library/lux/data/color/hsl.lux b/stdlib/source/library/lux/data/color/hsl.lux
index dd2155f2f..4a4c13097 100644
--- a/stdlib/source/library/lux/data/color/hsl.lux
+++ b/stdlib/source/library/lux/data/color/hsl.lux
@@ -5,8 +5,9 @@
[equivalence (.only Equivalence)]
[monad (.only do)]]
[control
- ["[0]" try (.only Try)]
- ["[0]" exception (.only Exception)]]
+ ["[0]" try]
+ [function
+ [predicate (.only Predicate)]]]
[data
[text
["%" \\format]]]
@@ -48,20 +49,16 @@
[+1.0 most]
)
-(exception.def .public (invalid value)
- (Exception Frac)
- (exception.report
- (list ["Value" (%.frac value)]
- ["Minimum" (%.frac ..least)]
- ["Maximum" (%.frac ..most)])))
+(def .public (value? it)
+ (Predicate Frac)
+ (not (or (f.< ..least it)
+ (f.> ..most it))))
-(def .public (value it)
+(def .public value
(-> Frac
- (Try Value))
- (if (or (f.< ..least it)
- (f.> ..most it))
- (exception.except ..invalid [it])
- {try.#Success it}))
+ Value)
+ (|>> (f.max ..least)
+ (f.min ..most)))
(nominal.def .public HSL
(Record
@@ -96,15 +93,11 @@
(def .public (hsl hue saturation luminance)
(-> Frac Frac Frac
- (Try HSL))
- (do try.monad
- [hue (..value hue)
- saturation (..value saturation)
- luminance (..value luminance)]
- (in (nominal.abstraction
- [#hue hue
- #saturation saturation
- #luminance luminance]))))
+ HSL)
+ (nominal.abstraction
+ [#hue (..value hue)
+ #saturation (..value saturation)
+ #luminance (..value luminance)]))
(def .public (of_rgb it)
(-> RGB
diff --git a/stdlib/source/library/lux/math/number/i16.lux b/stdlib/source/library/lux/math/number/i16.lux
index 53c71f68f..04ee87a9e 100644
--- a/stdlib/source/library/lux/math/number/i16.lux
+++ b/stdlib/source/library/lux/math/number/i16.lux
@@ -4,29 +4,25 @@
[abstract
[equivalence (.only Equivalence)]]
[control
- ["[0]" maybe]]
+ ["?" parser]
+ ["[0]" maybe]
+ ["[0]" try]]
[meta
- [type (.only by_example)]]]]
+ ["[0]" static]
+ ["[0]" type (.only)
+ ["?[1]" \\parser]]]]]
[//
- ["[0]" i64 (.only Sub)]])
+ ["[0]" i64]])
(def sub
(maybe.trusted (i64.sub 16)))
-(def .public I16
- Type
- ... TODO: Switch to the cleaner approach ASAP.
- (when (type_of ..sub)
- {.#Apply :size: :sub:}
- (type_literal (I64 :size:))
-
- _
- (undefined))
- ... (by_example [size]
- ... (is (Sub size)
- ... ..sub)
- ... (I64 size))
- )
+(`` (type .public I16
+ (I64 (,, (|> (type_of ..sub)
+ (?type.result (?type.applied (?.after (?type.exactly i64.Sub)
+ ?type.any)))
+ try.trusted
+ (static.literal type.code))))))
(def .public equivalence (Equivalence I16) (at ..sub sub_equivalence))
(def .public width Nat (at ..sub bits))
diff --git a/stdlib/source/library/lux/math/number/i32.lux b/stdlib/source/library/lux/math/number/i32.lux
index af4d6d592..e2bce4938 100644
--- a/stdlib/source/library/lux/math/number/i32.lux
+++ b/stdlib/source/library/lux/math/number/i32.lux
@@ -4,31 +4,25 @@
[abstract
[equivalence (.only Equivalence)]]
[control
- ["[0]" maybe]]
+ ["?" parser]
+ ["[0]" maybe]
+ ["[0]" try]]
[meta
- [type (.only by_example)]]]]
+ ["[0]" static]
+ ["[0]" type (.only)
+ ["?[1]" \\parser]]]]]
[//
- ["[0]" i64 (.only Sub)]])
+ ["[0]" i64]])
(def sub
- ... TODO: Stop needing this coercion.
- (as (Sub (I64 (Nominal "#I32")))
- (maybe.trusted (i64.sub 32))))
+ (maybe.trusted (i64.sub 32)))
-(def .public I32
- Type
- ... TODO: Switch to the cleaner approach ASAP.
- (when (type_of ..sub)
- {.#Apply :size: :sub:}
- (type_literal (I64 :size:))
-
- _
- (undefined))
- ... (by_example [size]
- ... (is (Sub size)
- ... ..sub)
- ... (I64 size))
- )
+(`` (type .public I32
+ (I64 (,, (|> (type_of ..sub)
+ (?type.result (?type.applied (?.after (?type.exactly i64.Sub)
+ ?type.any)))
+ try.trusted
+ (static.literal type.code))))))
(def .public equivalence (Equivalence I32) (at ..sub sub_equivalence))
(def .public width Nat (at ..sub bits))
diff --git a/stdlib/source/library/lux/math/number/i8.lux b/stdlib/source/library/lux/math/number/i8.lux
index d4ac05aaf..5a36246c6 100644
--- a/stdlib/source/library/lux/math/number/i8.lux
+++ b/stdlib/source/library/lux/math/number/i8.lux
@@ -4,29 +4,25 @@
[abstract
[equivalence (.only Equivalence)]]
[control
- ["[0]" maybe]]
+ ["?" parser]
+ ["[0]" maybe]
+ ["[0]" try]]
[meta
- [type (.only by_example)]]]]
+ ["[0]" static]
+ ["[0]" type (.only)
+ ["?[1]" \\parser]]]]]
[//
- ["[0]" i64 (.only Sub)]])
+ ["[0]" i64]])
(def sub
(maybe.trusted (i64.sub 8)))
-(def .public I8
- Type
- ... TODO: Switch to the cleaner approach ASAP.
- (when (type_of ..sub)
- {.#Apply :size: :sub:}
- (type_literal (I64 :size:))
-
- _
- (undefined))
- ... (by_example [size]
- ... (is (Sub size)
- ... ..sub)
- ... (I64 size))
- )
+(`` (type .public I8
+ (I64 (,, (|> (type_of ..sub)
+ (?type.result (?type.applied (?.after (?type.exactly i64.Sub)
+ ?type.any)))
+ try.trusted
+ (static.literal type.code))))))
(def .public equivalence (Equivalence I8) (at ..sub sub_equivalence))
(def .public width Nat (at ..sub bits))
diff --git a/stdlib/source/library/lux/meta/type/quotient.lux b/stdlib/source/library/lux/meta/type/quotient.lux
index ab043d3ff..57b3ec811 100644
--- a/stdlib/source/library/lux/meta/type/quotient.lux
+++ b/stdlib/source/library/lux/meta/type/quotient.lux
@@ -2,69 +2,79 @@
[library
[lux (.except type)
[abstract
- [equivalence (only Equivalence)]]
- [meta
+ [equivalence (.only Equivalence)]
+ [monad (.only do)]]
+ [control
+ ["?" parser]]
+ ["[0]" meta (.only)
["[0]" code
["<[1]>" \\parser]]
- [macro (.only with_symbols)
+ ["[0]" macro (.only)
[syntax (.only syntax)]]]]]
["[0]" // (.only)
+ ["?[1]" \\parser]
["[0]" nominal (.except def)]])
-(nominal.def .public (Class t c %)
- (-> t c)
+(nominal.def .public (Class super sub %)
+ (-> super
+ sub)
(def .public class
- (All (_ t c)
+ (All (_ super sub)
(Ex (_ %)
- (-> (-> t c) (Class t c %))))
+ (-> (-> super sub)
+ (Class super sub %))))
(|>> abstraction))
- (nominal.def .public (Quotient t c %)
+ (nominal.def .public (Quotient super sub %)
(Record
- [#value t
- #label c])
+ [#value super
+ #label sub])
(def .public (quotient class value)
- (All (_ t c %)
- (-> (Class t c %) t
- (Quotient t c %)))
+ (All (_ super sub %)
+ (-> (Class super sub %) super
+ (Quotient super sub %)))
(abstraction [#value value
#label ((representation Class class) value)]))
- (with_template [<name> <output> <slot>]
+ (with_template [<name> <slot> <output>]
[(def .public <name>
- (All (_ t c %) (-> (Quotient t c %) <output>))
- (|>> representation (the <slot>)))]
+ (All (_ super sub %)
+ (-> (Quotient super sub %)
+ <output>))
+ (|>> representation
+ (the <slot>)))]
- [value t #value]
- [label c #label]
+ [value #value super]
+ [label #label sub]
)
)
)
(def .public type
- (syntax (_ [class <code>.any])
- ... TODO: Switch to the cleaner approach ASAP.
- (with_symbols [g!t g!c g!% g!_ g!:quotient:]
- (in (list (` (let [ ... (, g!_) (.is (.Ex ((, g!_) (, g!t) (, g!c) (, g!%))
- ... (..Class (, g!t) (, g!c) (, g!%)))
- ... (, class))
- ]
- (.when (.type_of (, class))
- {.#Apply (, g!%) {.#Apply (, g!c) {.#Apply (, g!t) (, g!:quotient:)}}}
- (.type_literal (..Quotient (, g!t) (, g!c) (, g!%)))
-
- (, g!_)
- (.undefined))))
- ... (` (//.by_example [(, g!t) (, g!c) (, g!%)]
- ... (is (..Class (, g!t) (, g!c) (, g!%))
- ... (, class))
- ... (..Quotient (, g!t) (, g!c) (, g!%))))
- )))))
+ (syntax (_ [it <code>.any])
+ (macro.with_symbols ['_ 'super 'sub '%]
+ (do meta.monad
+ [it (meta.eval Type (` (.type_of ((is (All ((, '_) (, 'super) (, 'sub) (, '%))
+ (-> (..Class (, 'super) (, 'sub) (, '%))
+ (..Class (, 'super) (, 'sub) (, '%))))
+ (|>>))
+ (, it)))))
+ [super sub %] (|> (as Type it)
+ (?//.result (?//.applied (?.after (?//.exactly ..Class)
+ (all ?.and ?//.any ?//.any ?//.any))))
+ meta.of_try)]
+ (in (list (` (.type_literal (..Quotient (, (//.code super))
+ (, (//.code sub))
+ (, (//.code %)))))))))))
(def .public (equivalence super)
- (All (_ t c %) (-> (Equivalence c) (Equivalence (..Quotient t c %))))
+ (All (_ super sub %)
+ (-> (Equivalence sub)
+ (Equivalence (..Quotient super sub %))))
(implementation
(def (= reference sample)
- (at super = (..label reference) (..label sample)))))
+ (at super =
+ (..label reference)
+ (..label sample)))))
diff --git a/stdlib/source/library/lux/meta/type/refinement.lux b/stdlib/source/library/lux/meta/type/refinement.lux
index f1778d1b1..f886f175c 100644
--- a/stdlib/source/library/lux/meta/type/refinement.lux
+++ b/stdlib/source/library/lux/meta/type/refinement.lux
@@ -1,48 +1,58 @@
(.require
[library
[lux (.except only type)
+ [abstract
+ [monad (.only do)]]
[control
+ ["?" parser]
[function
[predicate (.only Predicate)]]]
- [meta
+ ["[0]" meta (.only)
["[0]" code
["<[1]>" \\parser]]
["[0]" macro (.only)
[syntax (.only syntax)]]]]]
["[0]" // (.only)
+ ["?[1]" \\parser]
["[0]" nominal (.except def)]])
-(nominal.def .public (Refined t %)
+(nominal.def .public (Refined super %)
(Record
- [#value t
- #predicate (Predicate t)])
+ [#value super
+ #predicate (Predicate super)])
- (.type .public (Refiner t %)
- (-> t (Maybe (Refined t %))))
+ (.type .public (Refiner super %)
+ (-> super
+ (Maybe (Refined super %))))
(def .public (refiner predicate)
- (All (_ t)
+ (All (_ super)
(Ex (_ %)
- (-> (Predicate t) (Refiner t %))))
+ (-> (Predicate super)
+ (Refiner super %))))
(function (_ value)
(if (predicate value)
{.#Some (abstraction [#value value
#predicate predicate])}
{.#None})))
- (with_template [<name> <output> <slot>]
+ (with_template [<name> <slot> <output>]
[(def .public <name>
- (All (_ t %) (-> (Refined t %) <output>))
- (|>> representation (the <slot>)))]
+ (All (_ super %)
+ (-> (Refined super %)
+ <output>))
+ (|>> representation
+ (the <slot>)))]
- [value t #value]
- [predicate (Predicate t) #predicate]
+ [value #value super]
+ [predicate #predicate (Predicate super)]
)
(def .public (lifted transform)
- (All (_ t %)
- (-> (-> t t)
- (-> (Refined t %) (Maybe (Refined t %)))))
+ (All (_ super %)
+ (-> (-> super super)
+ (-> (Refined super %)
+ (Maybe (Refined super %)))))
(function (_ refined)
(let [(open "_[0]") (representation refined)
value' (transform _#value)]
@@ -53,27 +63,27 @@
)
(def .public (only refiner values)
- (All (_ t %)
- (-> (Refiner t %) (List t) (List (Refined t %))))
+ (All (_ super %)
+ (-> (Refiner super %) (List super)
+ (List (Refined super %))))
(when values
- {.#End}
- {.#End}
-
{.#Item head tail}
(when (refiner head)
{.#Some refined}
{.#Item refined (only refiner tail)}
{.#None}
- (only refiner tail))))
+ (only refiner tail))
-(def .public (partition refiner values)
- (All (_ t %)
- (-> (Refiner t %) (List t) [(List (Refined t %)) (List t)]))
- (when values
{.#End}
- [{.#End} {.#End}]
+ {.#End}))
+(def .public (partition refiner values)
+ (All (_ super %)
+ (-> (Refiner super %) (List super)
+ [(List (Refined super %))
+ (List super)]))
+ (when values
{.#Item head tail}
(let [[yes no] (partition refiner tail)]
(when (refiner head)
@@ -83,24 +93,23 @@
{.#None}
[yes
- {.#Item head no}]))))
+ {.#Item head no}]))
-(def .public type
- (syntax (_ [refiner <code>.any])
- ... TODO: Switch to the cleaner approach ASAP.
- (macro.with_symbols [g!t g!% g!_ g!:refiner:]
- (in (list (` (let [ ... (, g!_) (.is (.Ex ((, g!_) (, g!t) (, g!%))
- ... (..Refined (, g!t) (, g!%)))
- ... (, refiner))
- ]
- (.when (.type_of (, refiner))
- {.#Apply (, g!%) {.#Apply (, g!t) (, g!:refiner:)}}
- (.type_literal (..Refined (, g!t) (, g!%)))
+ {.#End}
+ [{.#End} {.#End}]))
- (, g!_)
- (.undefined))))
- ... (` (//.by_example [(, g!t) (, g!%)]
- ... (is (..Refiner (, g!t) (, g!%))
- ... (, refiner))
- ... (..Refined (, g!t) (, g!%))))
- )))))
+(def .public type
+ (syntax (_ [it <code>.any])
+ (macro.with_symbols ['_ 'super '%]
+ (do meta.monad
+ [it (meta.eval Type (` (.type_of ((is (All ((, '_) (, 'super) (, '%))
+ (-> (..Refiner (, 'super) (, '%))
+ (..Refiner (, 'super) (, '%))))
+ (|>>))
+ (, it)))))
+ [super %] (|> (as Type it)
+ (?//.result (?//.applied (?.after (?//.exactly ..Refiner)
+ (all ?.and ?//.any ?//.any))))
+ meta.of_try)]
+ (in (list (` (.type_literal (..Refined (, (//.code super))
+ (, (//.code %)))))))))))
diff --git a/stdlib/source/library/lux/test/benchmark.lux b/stdlib/source/library/lux/test/benchmark.lux
new file mode 100644
index 000000000..427e62822
--- /dev/null
+++ b/stdlib/source/library/lux/test/benchmark.lux
@@ -0,0 +1,54 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ ["[0]" monad (.only do)]
+ ["[0]" order]]
+ [control
+ ["[0]" io (.only IO) (.use "[1]#[0]" monad)]]
+ [data
+ [collection
+ ["[0]" list (.use "[1]#[0]" mix)]]]
+ [world
+ [time
+ ["[0]" instant]
+ ["[0]" duration (.only Duration)]]]]])
+
+(def .public (time subject)
+ (-> (IO Any)
+ (IO Duration))
+ (do io.monad
+ [before instant.now
+ _ subject
+ after instant.now]
+ (in (instant.span before after))))
+
+(type .public Benchmark
+ (Record
+ [#times Nat
+ #minimum Duration
+ #maximum Duration
+ #average Duration]))
+
+(def empty
+ Benchmark
+ [#times 0
+ #minimum duration.empty
+ #maximum duration.empty
+ #average duration.empty])
+
+(def .public (test times subject)
+ (-> Nat (IO Any)
+ (IO Benchmark))
+ (when times
+ 0 (io#in ..empty)
+ _ (do [! io.monad]
+ [durations (|> subject
+ (list.repeated times)
+ (monad.each ! ..time))]
+ (in [#times times
+ #minimum (list#mix (order.min duration.order) duration.empty durations)
+ #maximum (list#mix (order.max duration.order) duration.empty durations)
+ #average (|> durations
+ (list#mix duration.composite duration.empty)
+ (duration.down times))]))))
diff --git a/stdlib/source/library/lux/world/money/currency.lux b/stdlib/source/library/lux/world/money/currency.lux
index fdb3ef16b..9b4abccda 100644
--- a/stdlib/source/library/lux/world/money/currency.lux
+++ b/stdlib/source/library/lux/world/money/currency.lux
@@ -3,15 +3,23 @@
[library
[lux (.except type all try)
[abstract
- ["[0]" equivalence (.only Equivalence)]]
+ ["[0]" equivalence (.only Equivalence)]
+ [monad (.only do)]]
+ [control
+ ["?" parser]]
[data
["[0]" product]
["[0]" text]]
[math
[number
["n" nat]]]
- [meta
- [type
+ ["[0]" meta (.only)
+ ["[0]" macro (.only)
+ [syntax (.only syntax)]]
+ ["[0]" code
+ ["?[1]" \\parser]]
+ ["[0]" type (.only)
+ ["?[1]" \\parser]
["[0]" nominal]]]]])
(nominal.def .public (Currency of)
@@ -54,16 +62,19 @@
)
(def .public type
- (template (_ <currency>)
- ... TODO: Switch to the cleaner approach ASAP.
- [(when (type_of <currency>)
- {.#Apply it currency?}
- (if (same? Currency currency?)
- it
- (undefined))
-
- _
- (undefined))]))
+ (syntax (_ [it ?code.any])
+ (macro.with_symbols ['_ 'of]
+ (do meta.monad
+ [it (meta.eval Type (` (.type_of ((is (All ((, '_) (, 'of))
+ (-> (..Currency (, 'of))
+ (..Currency (, 'of))))
+ (|>>))
+ (, it)))))
+ of (|> (as Type it)
+ (?type.result (?type.applied (?.after (?type.exactly ..Currency)
+ ?type.any)))
+ meta.of_try)]
+ (in (list (type.code of)))))))
(def (power parameter subject)
(-> Nat Nat
diff --git a/stdlib/source/library/lux/world/time/duration.lux b/stdlib/source/library/lux/world/time/duration.lux
index 627348295..fec1db917 100644
--- a/stdlib/source/library/lux/world/time/duration.lux
+++ b/stdlib/source/library/lux/world/time/duration.lux
@@ -86,13 +86,16 @@
)
(def .public empty
+ Duration
(..of_millis +0))
(def .public milli_second
+ Duration
(..of_millis +1))
(with_template [<name> <scale> <base>]
[(def .public <name>
+ Duration
(..up <scale> <base>))]
[second 1,000 milli_second]
@@ -105,6 +108,7 @@
)
(def .public leap_year
+ Duration
(..composite ..day ..normal_year))
(def .public monoid
diff --git a/stdlib/source/test/lux/data/color/hsb.lux b/stdlib/source/test/lux/data/color/hsb.lux
new file mode 100644
index 000000000..16f6d9dfb
--- /dev/null
+++ b/stdlib/source/test/lux/data/color/hsb.lux
@@ -0,0 +1,88 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [monad (.only do)]
+ [\\specification
+ ["[0]S" equivalence]]]
+ [math
+ ["[0]" random (.only Random) (.use "[1]#[0]" monad)]
+ [number
+ ["f" frac]]]
+ [test
+ ["_" property (.only Test)]]]]
+ [\\library
+ ["[0]" / (.only)
+ [//
+ ["[0]" rgb]]]]
+ [//
+ ["[0]T" rgb]])
+
+(def .public value
+ (Random /.Value)
+ (random#each /.value random.safe_frac))
+
+(def .public random
+ (Random /.HSB)
+ (do random.monad
+ [hue ..value
+ saturation ..value
+ brightness ..value]
+ (in (/.hsb hue saturation brightness))))
+
+(def .public test
+ Test
+ (<| (_.covering /._)
+ (do [! random.monad]
+ [expected_value ..value
+ expected_rgb rgbT.random
+ expected_hsb ..random
+
+ possible_value random.frac])
+ (all _.and
+ (_.for [/.Value]
+ (all _.and
+ (_.coverage [/.value?]
+ (and (/.value? expected_value)
+ (not (/.value? (f.+ f.smallest /.most)))
+ (not (/.value? (f.- f.smallest /.least)))))
+ (_.coverage [/.value]
+ (if (/.value? possible_value)
+ (|> possible_value
+ /.value
+ (f.= possible_value))
+ (or (f.= /.least (/.value possible_value))
+ (f.= /.most (/.value possible_value)))))
+ (_.coverage [/.least]
+ (and (f.< /.most
+ /.least)
+ (/.value? /.least)
+ (/.value? (f.+ f.smallest /.least))
+ (not (/.value? (f.- f.smallest /.least)))))
+ (_.coverage [/.most]
+ (and (f.> /.least
+ /.most)
+ (/.value? /.most)
+ (/.value? (f.- f.smallest /.most))
+ (not (/.value? (f.+ f.smallest /.most)))))
+ ))
+ (_.for [/.HSB]
+ (all _.and
+ (_.for [/.equivalence]
+ (equivalenceS.spec /.equivalence ..random))
+
+ (_.coverage [/.hsb
+ /.hue /.saturation /.brightness]
+ (|> (/.hsb (/.hue expected_hsb) (/.saturation expected_hsb) (/.brightness expected_hsb))
+ (at /.equivalence = expected_hsb)))
+ (_.coverage [/.of_rgb /.rgb]
+ (and (|> expected_rgb
+ /.of_rgb
+ /.rgb
+ (at rgb.equivalence = expected_rgb))
+ (|> expected_hsb
+ /.rgb
+ /.of_rgb
+ (at /.equivalence = expected_hsb))))
+ ))
+ )))
diff --git a/stdlib/source/test/lux/data/color/hsl.lux b/stdlib/source/test/lux/data/color/hsl.lux
index b3221e03b..a0524d2b1 100644
--- a/stdlib/source/test/lux/data/color/hsl.lux
+++ b/stdlib/source/test/lux/data/color/hsl.lux
@@ -5,11 +5,8 @@
[monad (.only do)]
[\\specification
["[0]S" equivalence]]]
- [control
- ["[0]" try (.use "[1]#[0]" functor)]
- ["[0]" exception]]
[math
- ["[0]" random (.only Random)]
+ ["[0]" random (.only Random) (.use "[1]#[0]" monad)]
[number
["f" frac]]]
[test
@@ -23,8 +20,7 @@
(def .public value
(Random /.Value)
- (random.one (|>> /.value try.maybe)
- random.safe_frac))
+ (random#each /.value random.safe_frac))
(def .public random
(Random /.HSL)
@@ -32,8 +28,7 @@
[hue ..value
saturation ..value
luminance ..value]
- (random.one (|>> try.maybe)
- (in (/.hsl hue saturation luminance)))))
+ (in (/.hsl hue saturation luminance))))
(def .public test
Test
@@ -41,30 +36,35 @@
(do [! random.monad]
[expected_value ..value
expected_rgb rgbT.random
- expected_hsl ..random])
+ expected_hsl ..random
+
+ possible_value random.frac])
(all _.and
(_.for [/.Value]
(all _.and
+ (_.coverage [/.value?]
+ (and (/.value? expected_value)
+ (not (/.value? (f.+ f.smallest /.most)))
+ (not (/.value? (f.- f.smallest /.least)))))
(_.coverage [/.value]
- (|> expected_value
- /.value
- (try#each (f.= expected_value))
- (try.else false)))
+ (if (/.value? possible_value)
+ (|> possible_value
+ /.value
+ (f.= possible_value))
+ (or (f.= /.least (/.value possible_value))
+ (f.= /.most (/.value possible_value)))))
(_.coverage [/.least]
- (when (/.value (f.+ +0.001 /.least))
- {try.#Failure _} false
- {try.#Success _} true))
+ (and (f.< /.most
+ /.least)
+ (/.value? /.least)
+ (/.value? (f.+ f.smallest /.least))
+ (not (/.value? (f.- f.smallest /.least)))))
(_.coverage [/.most]
- (when (/.value (f.- +0.001 /.most))
- {try.#Failure _} false
- {try.#Success _} true))
- (_.coverage [/.invalid]
- (and (when (/.value (f.- +0.001 /.least))
- {try.#Failure it} (exception.match? /.invalid it)
- {try.#Success _} false)
- (when (/.value (f.+ +0.001 /.most))
- {try.#Failure it} (exception.match? /.invalid it)
- {try.#Success _} false)))
+ (and (f.> /.least
+ /.most)
+ (/.value? /.most)
+ (/.value? (f.- f.smallest /.most))
+ (not (/.value? (f.+ f.smallest /.most)))))
))
(_.for [/.HSL]
(all _.and
@@ -74,8 +74,7 @@
(_.coverage [/.hsl
/.hue /.saturation /.luminance]
(|> (/.hsl (/.hue expected_hsl) (/.saturation expected_hsl) (/.luminance expected_hsl))
- (try#each (at /.equivalence = expected_hsl))
- (try.else false)))
+ (at /.equivalence = expected_hsl)))
(_.coverage [/.of_rgb /.rgb]
(and (|> expected_rgb
/.of_rgb
diff --git a/stdlib/source/test/lux/math/number/complex.lux b/stdlib/source/test/lux/math/number/complex.lux
index 18fbdd28e..501d01cd0 100644
--- a/stdlib/source/test/lux/math/number/complex.lux
+++ b/stdlib/source/test/lux/math/number/complex.lux
@@ -270,7 +270,8 @@
(def .public test
Test
(<| (_.covering /._)
- (_.for [/.Complex])
+ (_.for [/.Complex
+ /.#imaginary /.#real])
(all _.and
(_.for [/.= /.equivalence]
($equivalence.spec /.equivalence ..random))
diff --git a/stdlib/source/test/lux/test.lux b/stdlib/source/test/lux/test.lux
index 34891bf65..fd206f642 100644
--- a/stdlib/source/test/lux/test.lux
+++ b/stdlib/source/test/lux/test.lux
@@ -8,7 +8,8 @@
["[1][0]" tally]
["[1][0]" unit]
["[1][0]" property]
- ["[1][0]" inline]])
+ ["[1][0]" inline]
+ ["[1][0]" benchmark]])
(def .public test
Test
@@ -18,4 +19,5 @@
/unit.test
/property.test
/inline.test
+ /benchmark.test
))
diff --git a/stdlib/source/test/lux/test/benchmark.lux b/stdlib/source/test/lux/test/benchmark.lux
new file mode 100644
index 000000000..740d444cf
--- /dev/null
+++ b/stdlib/source/test/lux/test/benchmark.lux
@@ -0,0 +1,68 @@
+(.require
+ [library
+ [lux (.except)
+ [abstract
+ [monad (.only do)]
+ ["[0]" order]]
+ [control
+ ["[0]" io (.only IO)]]
+ [math
+ ["[0]" random (.only Random)]
+ [number
+ ["n" nat]
+ ["f" frac]]]
+ [world
+ [time
+ ["[0]" duration]]]
+ [test
+ ["_" property (.only Test)]]]]
+ [\\library
+ ["[0]" /]])
+
+(def .public test
+ Test
+ (<| (_.covering /._)
+ (do [! random.monad]
+ [angle random.safe_frac
+
+ times (at ! each (n.% 10) random.nat)
+
+ .let [computation (is (IO Frac)
+ (io.io (|> angle
+ f.cos f.acos
+ f.sin f.asin
+ f.tan f.atan
+ f.exp f.log)))]])
+ (all _.and
+ (_.coverage [/.time]
+ (io.run!
+ (do io.monad
+ [duration (/.time computation)]
+ (in (duration.positive? duration)))))
+ (<| (_.for [/.Benchmark
+ /.#times /.#minimum /.#maximum /.#average])
+ (all _.and
+ (_.coverage [/.test]
+ (io.run!
+ (do io.monad
+ [it (/.test times computation)]
+ (in (and (n.= times (the /.#times it))
+ (when times
+ 0 (and (duration.neutral? (the /.#minimum it))
+ (duration.neutral? (the /.#maximum it))
+ (duration.neutral? (the /.#average it)))
+ _ (and (duration.positive? (the /.#minimum it))
+ (duration.positive? (the /.#maximum it))
+ (duration.positive? (the /.#average it))
+
+ (order.<= duration.order
+ (the /.#maximum it)
+ (the /.#minimum it))
+ (order.<= duration.order
+ (the /.#maximum it)
+ (the /.#average it))
+ (order.>= duration.order
+ (the /.#minimum it)
+ (the /.#average it)))))))))
+ ))
+ )))