aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/bit.lux4
-rw-r--r--stdlib/source/lux/data/color.lux164
-rw-r--r--stdlib/source/lux/data/number/frac.lux14
-rw-r--r--stdlib/source/lux/time/date.lux100
-rw-r--r--stdlib/source/lux/time/year.lux97
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux149
-rw-r--r--stdlib/source/test/lux/data/bit.lux35
-rw-r--r--stdlib/source/test/lux/data/color.lux231
8 files changed, 508 insertions, 286 deletions
diff --git a/stdlib/source/lux/data/bit.lux b/stdlib/source/lux/data/bit.lux
index 3c1bcc02d..fee6eba92 100644
--- a/stdlib/source/lux/data/bit.lux
+++ b/stdlib/source/lux/data/bit.lux
@@ -37,7 +37,9 @@
[conjunction #1 and]
)
-(structure: #export codec (Codec Text Bit)
+(structure: #export codec
+ (Codec Text Bit)
+
(def: (encode x)
(if x
"#1"
diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux
index 36b9fdf6d..4334e7f41 100644
--- a/stdlib/source/lux/data/color.lux
+++ b/stdlib/source/lux/data/color.lux
@@ -1,23 +1,24 @@
(.module:
[lux #*
[abstract
- [equivalence (#+ Equivalence)]]
+ [equivalence (#+ Equivalence)]
+ [monoid (#+ Monoid)]]
[data
[number
["n" nat]
["." int]
- ["." rev ("#;." interval)]
+ ["." rev ("#@." interval)]
["f" frac]]
[collection
- ["." list ("#;." functor)]]]
+ ["." list ("#@." functor)]]]
["." math]
[type
abstract]])
-(def: rgb Nat 256)
-(def: top Nat (dec rgb))
+(def: rgb 256)
+(def: top (dec rgb))
-(def: rgb-factor Frac (|> top .int int.frac))
+(def: rgb-factor (|> top .int int.frac))
(def: scale-down
(-> Nat Frac)
@@ -49,21 +50,68 @@
(def: #export (from-rgb [red green blue])
(-> RGB Color)
- (:abstraction {#red (n.% rgb red)
- #green (n.% rgb green)
- #blue (n.% rgb blue)}))
+ (:abstraction {#red (n.% ..rgb red)
+ #green (n.% ..rgb green)
+ #blue (n.% ..rgb blue)}))
(def: #export to-rgb
(-> Color RGB)
(|>> :representation))
- (structure: #export equivalence (Equivalence Color)
+ (structure: #export equivalence
+ (Equivalence Color)
+
(def: (= reference sample)
(let [[rr rg rb] (:representation reference)
[sr sg sb] (:representation sample)]
(and (n.= rr sr)
(n.= rg sg)
(n.= rb sb)))))
+
+ (def: #export black
+ (..from-rgb {#red 0
+ #green 0
+ #blue 0}))
+
+ (def: #export white
+ (..from-rgb {#red ..top
+ #green ..top
+ #blue ..top}))
+
+ (structure: #export addition
+ (Monoid Color)
+
+ (def: identity ..black)
+
+ (def: (compose left right)
+ (let [[lR lG lB] (:representation left)
+ [rR rG rB] (:representation right)]
+ (:abstraction {#red (n.max lR rR)
+ #green (n.max lG rG)
+ #blue (n.max lB rB)}))))
+
+ (def: (complement' value)
+ (-> Nat Nat)
+ (|> ..top (n.- value)))
+
+ (def: #export (complement color)
+ (-> Color Color)
+ (let [[red green blue] (:representation color)]
+ (:abstraction {#red (complement' red)
+ #green (complement' green)
+ #blue (complement' blue)})))
+
+ (structure: #export subtraction
+ (Monoid Color)
+
+ (def: identity ..white)
+
+ (def: (compose left right)
+ (let [[lR lG lB] (:representation (..complement left))
+ [rR rG rB] (:representation right)]
+ (:abstraction {#red (n.min lR rR)
+ #green (n.min lG rG)
+ #blue (n.min lB rB)}))))
)
(def: #export (to-hsl color)
@@ -227,14 +275,14 @@
(f.% +1.0 ratio)
(f.< +0.0 ratio)
- (|> +1.0 (f.+ (f.% +1.0 ratio)))
+ (|> ratio (f.% +1.0) (f.+ +1.0))
## else
ratio))
(def: #export (interpolate ratio end start)
(-> Frac Color Color Color)
- (let [dS (normalize ratio)
+ (let [dS (..normalize ratio)
dE (|> +1.0 (f.- dS))
interpolate' (: (-> Nat Nat Nat)
(function (_ end start)
@@ -248,37 +296,22 @@
#green (interpolate' greenE greenS)
#blue (interpolate' blueE blueS)})))
-(def: #export black (from-rgb {#red 0
- #green 0
- #blue 0}))
-(def: #export white (from-rgb {#red top
- #green top
- #blue top}))
-
(template [<name> <target>]
[(def: #export (<name> ratio color)
(-> Frac Color Color)
- (interpolate ratio <target> color))]
+ (..interpolate ratio <target> color))]
[darker black]
[brighter white]
)
-(def: #export (complement color)
- (-> Color Color)
- (let [[red green blue] (to-rgb color)
- adjust (function (_ value) (|> top (n.- value)))]
- (from-rgb {#red (adjust red)
- #green (adjust green)
- #blue (adjust blue)})))
-
(template [<name> <op>]
[(def: #export (<name> ratio color)
(-> Frac Color Color)
(let [[hue saturation luminance] (to-hsl color)]
(from-hsl [hue
(|> saturation
- (f.* (|> +1.0 (<op> (normalize ratio))))
+ (f.* (|> +1.0 (<op> (..normalize ratio))))
(f.min +1.0))
luminance])))]
@@ -298,10 +331,10 @@
(-> Color [Color Color Color])
(let [[hue saturation luminance] (to-hsl color)]
[color
- (from-hsl [(|> hue (f.+ <1>) normalize)
+ (from-hsl [(|> hue (f.+ <1>) ..normalize)
saturation
luminance])
- (from-hsl [(|> hue (f.+ <2>) normalize)
+ (from-hsl [(|> hue (f.+ <2>) ..normalize)
saturation
luminance])]))]
@@ -313,15 +346,15 @@
(template [<name> <1> <2> <3>]
[(def: #export (<name> color)
(-> Color [Color Color Color Color])
- (let [[hue saturation luminance] (to-hsl color)]
+ (let [[hue saturation luminance] (to-hsb color)]
[color
- (from-hsl [(|> hue (f.+ <1>) normalize)
+ (from-hsb [(|> hue (f.+ <1>) ..normalize)
saturation
luminance])
- (from-hsl [(|> hue (f.+ <2>) normalize)
+ (from-hsb [(|> hue (f.+ <2>) ..normalize)
saturation
luminance])
- (from-hsl [(|> hue (f.+ <3>) normalize)
+ (from-hsb [(|> hue (f.+ <3>) ..normalize)
saturation
luminance])]))]
@@ -329,37 +362,40 @@
[tetradic (|> +2.0 (f./ +12.0)) (|> +6.0 (f./ +12.0)) (|> +8.0 (f./ +12.0))]
)
-(def: #export (analogous results slice color)
- (-> Nat Frac Color (List Color))
- (if (n.= 0 results)
- (list)
- (let [[hue saturation luminance] (to-hsl color)
- slice (normalize slice)]
- (list;map (function (_ idx)
- (from-hsl [(|> idx .int int.frac (f.* slice) (f.+ hue) normalize)
- saturation
- luminance]))
- (list.indices results)))))
-
-(def: #export (monochromatic results color)
- (-> Nat Color (List Color))
- (if (n.= 0 results)
- (list)
- (let [[hue saturation brightness] (to-hsb color)
- slice (|> +1.0 (f./ (|> results .int int.frac)))]
- (|> (list.indices results)
- (list;map (|>> .int int.frac
- (f.* slice)
- (f.+ brightness)
- normalize
- [hue saturation]
- from-hsb))))))
-
-(type: #export Alpha Rev)
+(type: #export Spread
+ Frac)
+
+(type: #export Palette
+ (-> Spread Nat Color (List Color)))
+
+(def: #export (analogous spread variations color)
+ (-> Spread Nat Color (List Color))
+ (let [[hue saturation brightness] (to-hsb color)
+ spread (..normalize spread)]
+ (list@map (function (_ idx)
+ (from-hsb [(|> idx inc .int int.frac (f.* spread) (f.+ hue) ..normalize)
+ saturation
+ brightness]))
+ (list.indices variations))))
+
+(def: #export (monochromatic spread variations color)
+ (-> Spread Nat Color (List Color))
+ (let [[hue saturation brightness] (to-hsb color)
+ spread (..normalize spread)]
+ (|> (list.indices variations)
+ (list@map (|>> inc .int int.frac
+ (f.* spread)
+ (f.+ brightness)
+ ..normalize
+ [hue saturation]
+ from-hsb)))))
+
+(type: #export Alpha
+ Rev)
(def: #export transparent
Alpha
- rev;bottom)
+ rev@bottom)
(def: #export translucent
Alpha
@@ -367,7 +403,7 @@
(def: #export opaque
Alpha
- rev;top)
+ rev@top)
(type: #export Pigment
{#color Color
diff --git a/stdlib/source/lux/data/number/frac.lux b/stdlib/source/lux/data/number/frac.lux
index 22a8e5372..47ad25f30 100644
--- a/stdlib/source/lux/data/number/frac.lux
+++ b/stdlib/source/lux/data/number/frac.lux
@@ -9,7 +9,8 @@
[control
["." try (#+ Try)]]
[data
- ["." maybe]]
+ ["." maybe]
+ ["." text]]
["." math]]
["." // #_
["#." i64]
@@ -160,9 +161,14 @@
(Codec Text Frac)
(def: (encode x)
- (if (..< +0.0 x)
- ("lux f64 encode" x)
- ("lux text concat" "+" ("lux f64 encode" x))))
+ (case x
+ -0.0 (let [output ("lux f64 encode" x)]
+ (if (text.starts-with? "-" output)
+ output
+ ("lux text concat" "+" output)))
+ _ (if (..< +0.0 x)
+ ("lux f64 encode" x)
+ ("lux text concat" "+" ("lux f64 encode" x)))))
(def: (decode input)
(case ("lux f64 decode" [input])
diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux
index 455176de6..aadd8199b 100644
--- a/stdlib/source/lux/time/date.lux
+++ b/stdlib/source/lux/time/date.lux
@@ -16,7 +16,7 @@
["." text ("#@." monoid)]
[number
["n" nat ("#@." decimal)]
- ["i" int ("#@." decimal)]]
+ ["i" int]]
[collection
["." list ("#@." fold)]
["." dictionary (#+ Dictionary)]]]
@@ -53,21 +53,9 @@
["Value" (n@encode day)]
["Minimum" (n@encode ..minimum-day)]
["Maximum" (n@encode (..month-days year month))]
- ["Year" (i@encode year)]
+ ["Year" (:: //year.codec encode year)]
["Month" (n@encode (//month.number month))]))
-(def: (internal-year year)
- (-> Year Year)
- (if (i.< +0 year)
- (inc year)
- year))
-
-(def: (external-year year)
- (-> Year Year)
- (if (i.> +0 year)
- year
- (dec year)))
-
(def: (pad value)
(-> Nat Text)
(let [digits (n@encode value)]
@@ -85,25 +73,22 @@
(def: #export (date year month day)
(-> Year Month Nat (Try Date))
- (case year
- +0 (exception.throw ..there-is-no-year-0 [])
- _ (let [year (..internal-year year)]
- (if (..day-is-within-limits? year month day)
- (#try.Success
- (:abstraction
- {#year year
- #month month
- #day day}))
- (exception.throw ..invalid-day [year month day])))))
-
- (template [<name> <type> <field> <post-processing>]
+ (if (..day-is-within-limits? year month day)
+ (#try.Success
+ (:abstraction
+ {#year year
+ #month month
+ #day day}))
+ (exception.throw ..invalid-day [year month day])))
+
+ (template [<name> <type> <field>]
[(def: #export <name>
(-> Date <type>)
- (|>> :representation (get@ <field>) <post-processing>))]
+ (|>> :representation (get@ <field>)))]
- [year Year #year ..external-year]
- [month Month #month (|>)]
- [day-of-month Nat #day (|>)]
+ [year Year #year]
+ [month Month #month]
+ [day-of-month Nat #day]
)
(structure: #export equivalence
@@ -112,8 +97,9 @@
(def: (= reference sample)
(let [reference (:representation reference)
sample (:representation sample)]
- (and (i.= (get@ #year reference)
- (get@ #year sample))
+ (and (:: //year.equivalence =
+ (get@ #year reference)
+ (get@ #year sample))
(:: //month.equivalence =
(get@ #month reference)
(get@ #month sample))
@@ -128,10 +114,12 @@
(def: (< reference sample)
(let [reference (:representation reference)
sample (:representation sample)]
- (or (i.< (get@ #year reference)
- (get@ #year sample))
- (and (i.= (get@ #year reference)
- (get@ #year sample))
+ (or (:: //year.order <
+ (get@ #year reference)
+ (get@ #year sample))
+ (and (:: //year.equivalence =
+ (get@ #year reference)
+ (get@ #year sample))
(or (:: //month.order <
(get@ #month reference)
(get@ #month sample))
@@ -142,16 +130,6 @@
(get@ #day sample)))))))))
)
-(def: parse-year
- (Parser Year)
- (do {@ <>.monad}
- [sign (<>.or (<t>.this "-") (wrap []))
- digits (<t>.many <t>.decimal)
- raw-year (<>.codec i.decimal (wrap (text@compose "+" digits)))]
- (wrap (case sign
- (#.Left _) (i.* -1 raw-year)
- (#.Right _) raw-year))))
-
(def: parse-section
(Parser Nat)
(<>.codec n.decimal (<t>.exactly 2 <t>.decimal)))
@@ -185,7 +163,7 @@
(def: #export parser
(Parser Date)
(do <>.monad
- [utc-year ..parse-year
+ [utc-year //year.parser
_ (<t>.this ..separator)
utc-month ..parse-month
_ (<t>.this ..separator)
@@ -195,13 +173,10 @@
(def: (encode value)
(-> Date Text)
- (let [year (..year value)]
- ($_ text@compose
- (if (i.< +0 year)
- (i@encode year)
- (n@encode (.nat year)))
- ..separator (..pad (|> value ..month //month.number))
- ..separator (..pad (..day-of-month value)))))
+ ($_ text@compose
+ (:: //year.codec encode (..year value))
+ ..separator (..pad (|> value ..month //month.number))
+ ..separator (..pad (..day-of-month value))))
(structure: #export codec
{#.doc (doc "Based on ISO 8601."
@@ -292,7 +267,8 @@
(def: (civil-year utc-month utc-year)
(-> Nat Year Int)
- (let [utc-year (..internal-year utc-year)]
+ (let [## Coercing, because the year is already in external form.
+ utc-year (:coerce Int utc-year)]
(if (n.< ..first-month-of-civil-year utc-month)
(dec utc-year)
utc-year)))
@@ -349,6 +325,18 @@
year (if (n.< ..first-month-of-civil-year month)
(inc year)
year)]
- (try.assume (..date (..external-year year)
+ ## Coercing, because the year is already in internal form.
+ (try.assume (..date (:coerce Year year)
(maybe.assume (dictionary.get month ..month-by-number))
day))))
+
+(structure: #export enum
+ (Enum Date)
+
+ (def: &order ..order)
+
+ (def: succ
+ (|>> ..days inc ..from-days))
+
+ (def: pred
+ (|>> ..days dec ..from-days)))
diff --git a/stdlib/source/lux/time/year.lux b/stdlib/source/lux/time/year.lux
index 0ba2025c6..43e2181ab 100644
--- a/stdlib/source/lux/time/year.lux
+++ b/stdlib/source/lux/time/year.lux
@@ -1,19 +1,57 @@
(.module:
[lux #*
+ [abstract
+ [monad (#+ do)]
+ [codec (#+ Codec)]
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<t>" text (#+ Parser)]]]
[data
+ ["." text ("#@." monoid)]
[number
- ["n" nat]
- ["i" int]]]])
+ ["n" nat ("#@." decimal)]
+ ["i" int ("#@." decimal)]]]
+ [type
+ abstract]])
-(type: #export Year
- Int)
+(def: (internal year)
+ (-> Int Int)
+ (if (i.< +0 year)
+ (inc year)
+ year))
+
+(def: (external year)
+ (-> Int Int)
+ (if (i.> +0 year)
+ year
+ (dec year)))
+
+(exception: #export there-is-no-year-0)
+
+(abstract: #export Year
+ Int
+
+ (def: #export (year value)
+ (-> Int (Try Year))
+ (case value
+ +0 (exception.throw ..there-is-no-year-0 [])
+ _ (#try.Success (:abstraction (..internal value)))))
+
+ (def: #export value
+ (-> Year Int)
+ (|>> :representation ..external))
+ )
(def: #export days
365)
(def: #export epoch
Year
- +1970)
+ (try.assume (..year +1970)))
(type: #export Period
Nat)
@@ -35,9 +73,10 @@
## https://en.wikipedia.org/wiki/Leap_year#Algorithm
(def: #export (leap? year)
(-> Year Bit)
- (and (..divisible? (.int ..leap) year)
- (or (not (..divisible? (.int ..century) year))
- (..divisible? (.int ..era) year))))
+ (let [year (|> year ..value ..internal)]
+ (and (..divisible? (.int ..leap) year)
+ (or (not (..divisible? (.int ..century) year))
+ (..divisible? (.int ..era) year)))))
(def: (with-year-0-leap year days)
(let [after-year-0? (i.> +0 year)]
@@ -47,7 +86,8 @@
(def: #export (leaps year)
(-> Year Int)
- (let [limit (if (i.> +0 year)
+ (let [year (|> year ..value ..internal)
+ limit (if (i.> +0 year)
(dec year)
(inc year))]
(`` (|> +0
@@ -59,3 +99,42 @@
[i.+ ..era]
))
(..with-year-0-leap year)))))
+
+(def: (encode year)
+ (-> Year Text)
+ (let [year (..value year)]
+ (if (i.< +0 year)
+ (i@encode year)
+ (n@encode (.nat year)))))
+
+(def: #export parser
+ (Parser Year)
+ (do {@ <>.monad}
+ [sign (<>.or (<t>.this "-") (wrap []))
+ digits (<t>.many <t>.decimal)
+ raw-year (<>.codec i.decimal (wrap (text@compose "+" digits)))]
+ (<>.lift (..year (case sign
+ (#.Left _) (i.* -1 raw-year)
+ (#.Right _) raw-year)))))
+
+(structure: #export codec
+ {#.doc (doc "Based on ISO 8601."
+ "For example: 2017")}
+ (Codec Text Year)
+
+ (def: encode ..encode)
+ (def: decode (<t>.run ..parser)))
+
+(structure: #export equivalence
+ (Equivalence Year)
+
+ (def: (= reference subject)
+ (i.= (..value reference) (..value subject))))
+
+(structure: #export order
+ (Order Year)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< reference subject)
+ (i.< (..value reference) (..value subject))))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 0580372c1..2d005d450 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -6,6 +6,7 @@
["." monad (#+ Monad do)]]
[control
["." try (#+ Try)]
+ ["." exception (#+ exception:)]
[concurrency
["." promise (#+ Promise Resolver) ("#@." monad)]
["." stm (#+ Var STM)]]]
@@ -13,7 +14,7 @@
["." binary (#+ Binary)]
["." bit]
["." product]
- ["." text
+ ["." text ("#@." equivalence)
["%" format (#+ format)]]
[collection
["." dictionary (#+ Dictionary)]
@@ -362,6 +363,16 @@
try.assume
product.left))
+ (exception: #export (module-cannot-import-itself {module Module})
+ (exception.report
+ ["Module" (%.text module)]))
+
+ (def: (verify-no-self-import! module dependencies)
+ (-> Module (List Module) (Try Any))
+ (if (list.any? (text@= module) dependencies)
+ (exception.throw ..module-cannot-import-itself [module])
+ (#try.Success [])))
+
(def: #export (compile import static expander platform compilation context)
(All [<type-vars>]
(-> Import Static Expander <Platform> Compilation <Context> <Return>))
@@ -371,75 +382,75 @@
context}
{(///.Compiler <State+> .Module Any)
(:assume
- ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))})]
- (do (try.with promise.monad)
- [#let [compiler (..parallel
- context
- (function (_ import! module-id [archive state] module)
- (do (try.with promise.monad)
- [#let [state (..set-current-module module state)]
- input (context.read (get@ #&file-system platform)
- import
- compilation-sources
- (get@ #static.host-module-extension static)
- module)]
- (loop [[archive state] [archive state]
- compilation (base-compiler (:coerce ///.Input input))
- all-dependencies (: (List Module)
- (list))]
- (do {@ (try.with promise.monad)}
- [#let [new-dependencies (get@ #///.dependencies compilation)
- all-dependencies (list@compose new-dependencies all-dependencies)
- continue! (:share [<type-vars>]
- {<Platform>
- platform}
- {(-> <Context> (///.Compilation <State+> .Module Any) (List Module)
- (Action [Archive <State+>]))
- (:assume
- recur)})]
- [archive state] (case new-dependencies
- #.Nil
- (wrap [archive state])
+ ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))})
+ compiler (..parallel
+ context
+ (function (_ import! module-id [archive state] module)
+ (do {@ (try.with promise.monad)}
+ [#let [state (..set-current-module module state)]
+ input (context.read (get@ #&file-system platform)
+ import
+ compilation-sources
+ (get@ #static.host-module-extension static)
+ module)]
+ (loop [[archive state] [archive state]
+ compilation (base-compiler (:coerce ///.Input input))
+ all-dependencies (: (List Module)
+ (list))]
+ (let [new-dependencies (get@ #///.dependencies compilation)
+ all-dependencies (list@compose new-dependencies all-dependencies)
+ continue! (:share [<type-vars>]
+ {<Platform>
+ platform}
+ {(-> <Context> (///.Compilation <State+> .Module Any) (List Module)
+ (Action [Archive <State+>]))
+ (:assume
+ recur)})]
+ (do @
+ [[archive state] (case new-dependencies
+ #.Nil
+ (wrap [archive state])
- (#.Cons _)
- (do @
- [archive,document+ (|> new-dependencies
- (list@map import!)
- (monad.seq ..monad))
- #let [archive (|> archive,document+
- (list@map product.left)
- (list@fold archive.merge archive))]]
- (wrap [archive (try.assume
- (..updated-state archive state))])))]
- (case ((get@ #///.process compilation)
- ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
- ## TODO: The context shouldn't need to be re-set either.
- (|> (///directive.set-current-module module)
- (///phase.run' state)
- try.assume
- product.left)
- archive)
- (#try.Success [state more|done])
- (case more|done
- (#.Left more)
- (continue! [archive state] more all-dependencies)
+ (#.Cons _)
+ (do @
+ [_ (:: promise.monad wrap (verify-no-self-import! module new-dependencies))
+ archive,document+ (|> new-dependencies
+ (list@map import!)
+ (monad.seq ..monad))
+ #let [archive (|> archive,document+
+ (list@map product.left)
+ (list@fold archive.merge archive))]]
+ (wrap [archive (try.assume
+ (..updated-state archive state))])))]
+ (case ((get@ #///.process compilation)
+ ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
+ ## TODO: The context shouldn't need to be re-set either.
+ (|> (///directive.set-current-module module)
+ (///phase.run' state)
+ try.assume
+ product.left)
+ archive)
+ (#try.Success [state more|done])
+ (case more|done
+ (#.Left more)
+ (continue! [archive state] more all-dependencies)
- (#.Right [[descriptor document] output])
- (do (try.with promise.monad)
- [#let [_ (log! (..module-compilation-log state))
- descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
- _ (..cache-module static platform module-id [[descriptor document] output])]
- (case (archive.add module [descriptor document] archive)
- (#try.Success archive)
- (wrap [archive
- (..with-reset-log state)])
-
- (#try.Failure error)
- (promise@wrap (#try.Failure error)))))
+ (#.Right [[descriptor document] output])
+ (do @
+ [#let [_ (log! (..module-compilation-log state))
+ descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
+ _ (..cache-module static platform module-id [[descriptor document] output])]
+ (case (archive.add module [descriptor document] archive)
+ (#try.Success archive)
+ (wrap [archive
+ (..with-reset-log state)])
+
+ (#try.Failure error)
+ (promise@wrap (#try.Failure error)))))
- (#try.Failure error)
- (do (try.with promise.monad)
- [_ (ioW.freeze (get@ #&file-system platform) static archive)]
- (promise@wrap (#try.Failure error)))))))))]]
- (compiler compilation-module))))
+ (#try.Failure error)
+ (do @
+ [_ (ioW.freeze (get@ #&file-system platform) static archive)]
+ (promise@wrap (#try.Failure error))))))))))]
+ (compiler compilation-module)))
))
diff --git a/stdlib/source/test/lux/data/bit.lux b/stdlib/source/test/lux/data/bit.lux
index 6f281818d..0be42e466 100644
--- a/stdlib/source/test/lux/data/bit.lux
+++ b/stdlib/source/test/lux/data/bit.lux
@@ -1,8 +1,8 @@
(.module:
[lux #*
- ["%" data/text/format (#+ format)]
["_" test (#+ Test)]
- ["r" math/random]
+ [math
+ ["." random]]
[abstract
[monad (#+ do)]
{[0 #spec]
@@ -17,21 +17,20 @@
(def: #export test
Test
- (<| (_.context (%.name (name-of .Bit)))
- (do r.monad
- [value r.bit]
+ (<| (_.covering /._)
+ (do random.monad
+ [value random.bit]
($_ _.and
- ($equivalence.spec /.equivalence r.bit)
- ($codec.spec /.equivalence /.codec r.bit)
- (<| (_.context "Disjunction.")
- ($monoid.spec /.equivalence /.disjunction r.bit))
- (<| (_.context "Conjunction.")
- ($monoid.spec /.equivalence /.conjunction r.bit))
- (_.test "A value cannot be true and false at the same time."
- (not (and value (not value))))
- (_.test "A value must be either true or false at any time."
- (or value (not value)))
- (_.test "Can create the complement of a predicate."
- (and (not (:: /.equivalence = value ((/.complement function.identity) value)))
- (:: /.equivalence = value ((/.complement not) value))))
+ (_.with-cover [/.equivalence]
+ ($equivalence.spec /.equivalence random.bit))
+ (_.with-cover [/.disjunction]
+ ($monoid.spec /.equivalence /.disjunction random.bit))
+ (_.with-cover [/.conjunction]
+ ($monoid.spec /.equivalence /.conjunction random.bit))
+ (_.with-cover [/.codec]
+ ($codec.spec /.equivalence /.codec random.bit))
+
+ (_.cover [/.complement]
+ (and (not (:: /.equivalence = value ((/.complement function.identity) value)))
+ (:: /.equivalence = value ((/.complement not) value))))
))))
diff --git a/stdlib/source/test/lux/data/color.lux b/stdlib/source/test/lux/data/color.lux
index a7b5c0088..388b49d93 100644
--- a/stdlib/source/test/lux/data/color.lux
+++ b/stdlib/source/test/lux/data/color.lux
@@ -5,41 +5,53 @@
[monad (#+ do)]
{[0 #spec]
[/
- ["$." equivalence]]}]
+ ["$." equivalence]
+ ["$." monoid]]}]
[data
- ["%" text/format (#+ format)]
[number
+ ["n" nat]
["." int]
- ["f" frac]]]
+ ["f" frac]
+ ["r" rev]]
+ [collection
+ ["." list]]]
+ [macro
+ ["." template]]
["." math
- ["r" random (#+ Random)]]]
+ ["." random (#+ Random)]]]
{1
- ["." / (#+ Color)]})
+ ["." / (#+ Color)
+ ["." named]]})
(def: #export color
(Random Color)
- (|> ($_ r.and r.nat r.nat r.nat)
- (:: r.monad map /.from-rgb)))
+ (|> ($_ random.and random.nat random.nat random.nat)
+ (:: random.monad map /.from-rgb)))
(def: scale
(-> Nat Frac)
(|>> .int int.frac))
(def: square (-> Frac Frac) (math.pow +2.0))
+(def: square-root (-> Frac Frac) (math.pow +0.5))
-(def: (distance from to)
+(def: (distance/1 from to)
+ (-> Frac Frac Frac)
+ (square-root
+ (square
+ (f.- from to))))
+
+(def: (distance/3 from to)
(-> Color Color Frac)
(let [[fr fg fb] (/.to-rgb from)
[tr tg tb] (/.to-rgb to)]
- (math.pow +0.5 ($_ f.+
- (|> (scale tr) (f.- (scale fr)) square)
- (|> (scale tg) (f.- (scale fg)) square)
- (|> (scale tb) (f.- (scale fb)) square)))))
-
-(def: error-margin Frac +1.8)
+ (square-root
+ ($_ f.+
+ (|> (scale tr) (f.- (scale fr)) square)
+ (|> (scale tg) (f.- (scale fg)) square)
+ (|> (scale tb) (f.- (scale fb)) square)))))
-(def: black (/.from-rgb [0 0 0]))
-(def: white (/.from-rgb [255 255 255]))
+(def: rgb-error-margin +1.8)
(template [<field>]
[(def: (<field> color)
@@ -51,56 +63,145 @@
[luminance]
)
+(def: (encoding expected)
+ (-> /.Color Test)
+ ($_ _.and
+ (_.cover [/.RGB /.to-rgb /.from-rgb]
+ (|> expected /.to-rgb /.from-rgb
+ (:: /.equivalence = expected)))
+ (_.cover [/.HSL /.to-hsl /.from-hsl]
+ (|> expected /.to-hsl /.from-hsl
+ (distance/3 expected)
+ (f.<= ..rgb-error-margin)))
+ (_.cover [/.HSB /.to-hsb /.from-hsb]
+ (|> expected /.to-hsb /.from-hsb
+ (distance/3 expected)
+ (f.<= ..rgb-error-margin)))
+ (_.cover [/.CMYK /.to-cmyk /.from-cmyk]
+ (|> expected /.to-cmyk /.from-cmyk
+ (distance/3 expected)
+ (f.<= ..rgb-error-margin)))
+ ))
+
+(def: transformation
+ Test
+ (do random.monad
+ [colorful (|> ..color
+ (random.filter (function (_ color) (|> (distance/3 color /.black) (f.>= +100.0))))
+ (random.filter (function (_ color) (|> (distance/3 color /.white) (f.>= +100.0)))))
+ mediocre (|> ..color
+ (random.filter (|>> saturation
+ ((function (_ saturation)
+ (and (f.>= +0.25 saturation)
+ (f.<= +0.75 saturation)))))))
+ ratio (|> random.safe-frac (random.filter (f.>= +0.5)))]
+ ($_ _.and
+ (_.cover [/.darker /.brighter]
+ (and (f.<= (distance/3 colorful /.black)
+ (distance/3 (/.darker ratio colorful) /.black))
+ (f.<= (distance/3 colorful /.white)
+ (distance/3 (/.brighter ratio colorful) /.white))))
+ (_.cover [/.interpolate]
+ (and (f.<= (distance/3 colorful /.black)
+ (distance/3 (/.interpolate ratio /.black colorful) /.black))
+ (f.<= (distance/3 colorful /.white)
+ (distance/3 (/.interpolate ratio /.white colorful) /.white))))
+ (_.cover [/.saturate]
+ (f.> (saturation mediocre)
+ (saturation (/.saturate ratio mediocre))))
+ (_.cover [/.de-saturate]
+ (f.< (saturation mediocre)
+ (saturation (/.de-saturate ratio mediocre))))
+ (_.cover [/.gray-scale]
+ (let [gray'ed (/.gray-scale mediocre)]
+ (and (f.= +0.0
+ (saturation gray'ed))
+ (|> (luminance gray'ed)
+ (f.- (luminance mediocre))
+ f.abs
+ (f.<= ..rgb-error-margin)))))
+ )))
+
+(def: palette
+ Test
+ (_.with-cover [/.Spread /.Palette]
+ (do {@ random.monad}
+ [eH (:: @ map (|>> f.abs (f.% +0.9) (f.+ +0.05))
+ random.safe-frac)
+ #let [eS +0.5]
+ variations (:: @ map (|>> (n.% 3) (n.+ 2)) random.nat)
+ #let [max-spread (f./ (|> variations inc .int int.frac)
+ +1.0)
+ min-spread (f./ +2.0 max-spread)
+ spread-space (f.- min-spread max-spread)]
+ spread (:: @ map (|>> f.abs (f.% spread-space) (f.+ min-spread))
+ random.safe-frac)]
+ (`` ($_ _.and
+ (~~ (template [<brightness> <palette>]
+ [(_.cover [<palette>]
+ (let [eB <brightness>
+ expected (/.from-hsb [eH eS eB])
+ palette (<palette> spread variations expected)]
+ (and (n.= variations (list.size palette))
+ (not (list.any? (:: /.equivalence = expected) palette)))))]
+ [+1.0 /.analogous]
+ [+0.5 /.monochromatic]
+ ))
+ (~~ (template [<palette>]
+ [(_.cover [<palette>]
+ (let [expected (/.from-hsb [eH eS +0.5])
+ [c0 c1 c2] (<palette> expected)]
+ (and (:: /.equivalence = expected c0)
+ (not (:: /.equivalence = expected c1))
+ (not (:: /.equivalence = expected c2)))))]
+
+ [/.triad]
+ [/.clash]
+ [/.split-complement]))
+ (~~ (template [<palette>]
+ [(_.cover [<palette>]
+ (let [expected (/.from-hsb [eH eS +0.5])
+ [c0 c1 c2 c3] (<palette> expected)]
+ (and (:: /.equivalence = expected c0)
+ (not (:: /.equivalence = expected c1))
+ (not (:: /.equivalence = expected c2))
+ (not (:: /.equivalence = expected c3)))))]
+
+ [/.square]
+ [/.tetradic]))
+ )))))
+
(def: #export test
Test
- (<| (_.context (%.name (name-of /._)))
- (do r.monad
- [any ..color
- colorful (|> color
- (r.filter (function (_ color) (|> (distance color black) (f.>= +100.0))))
- (r.filter (function (_ color) (|> (distance color white) (f.>= +100.0)))))
- mediocre (|> color
- (r.filter (|>> saturation
- ((function (_ saturation)
- (and (f.>= +0.25 saturation)
- (f.<= +0.75 saturation)))))))
- ratio (|> r.safe-frac (r.filter (f.>= +0.5)))]
+ (<| (_.covering /._)
+ (_.with-cover [/.Color])
+ (do {@ random.monad}
+ [expected ..color]
($_ _.and
- ($equivalence.spec /.equivalence ..color)
- (_.test "Can convert to/from HSL."
- (|> any /.to-hsl /.from-hsl
- (distance any)
- (f.<= error-margin)))
- (_.test "Can convert to/from HSB."
- (|> any /.to-hsb /.from-hsb
- (distance any)
- (f.<= error-margin)))
- (_.test "Can convert to/from CMYK."
- (|> any /.to-cmyk /.from-cmyk
- (distance any)
- (f.<= error-margin)))
- (_.test "Can interpolate between 2 colors."
- (and (f.<= (distance colorful black)
- (distance (/.darker ratio colorful) black))
- (f.<= (distance colorful white)
- (distance (/.brighter ratio colorful) white))))
- (_.test "Can calculate complement."
- (let [~any (/.complement any)
- (^open "/@.") /.equivalence]
- (and (not (/@= any ~any))
- (/@= any (/.complement ~any)))))
- (_.test "Can saturate color."
- (f.> (saturation mediocre)
- (saturation (/.saturate ratio mediocre))))
- (_.test "Can de-saturate color."
- (f.< (saturation mediocre)
- (saturation (/.de-saturate ratio mediocre))))
- (_.test "Can gray-scale color."
- (let [gray'ed (/.gray-scale mediocre)]
- (and (f.= +0.0
- (saturation gray'ed))
- (|> (luminance gray'ed)
- (f.- (luminance mediocre))
- f.abs
- (f.<= error-margin)))))
+ (_.with-cover [/.equivalence]
+ ($equivalence.spec /.equivalence ..color))
+ (_.with-cover [/.addition]
+ ($monoid.spec /.equivalence /.addition ..color))
+ (_.with-cover [/.subtraction]
+ ($monoid.spec /.equivalence /.addition ..color))
+
+ (..encoding expected)
+ (_.cover [/.complement]
+ (let [~expected (/.complement expected)
+ (^open "/@.") /.equivalence]
+ (and (not (/@= expected ~expected))
+ (/@= expected (/.complement ~expected)))))
+ (_.cover [/.black /.white]
+ (and (:: /.equivalence = /.white (/.complement /.black))
+ (:: /.equivalence = /.black (/.complement /.white))))
+ ..transformation
+ ..palette
+ (_.with-cover [/.Alpha /.Pigment]
+ ($_ _.and
+ (_.cover [/.transparent /.opaque]
+ (and (r.= /.opaque (dec /.transparent))
+ (r.= /.transparent (inc /.opaque))))
+ (_.cover [/.translucent]
+ (r.= /.transparent (r.+ /.translucent /.translucent)))
+ ))
))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 10:35:01 +0000