diff options
Diffstat (limited to '')
-rw-r--r-- | stdlib/source/lux/data/bit.lux | 4 | ||||
-rw-r--r-- | stdlib/source/lux/data/color.lux | 164 | ||||
-rw-r--r-- | stdlib/source/lux/data/number/frac.lux | 14 | ||||
-rw-r--r-- | stdlib/source/lux/time/date.lux | 100 | ||||
-rw-r--r-- | stdlib/source/lux/time/year.lux | 97 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/default/platform.lux | 149 |
6 files changed, 325 insertions, 203 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))) )) |