diff options
Diffstat (limited to 'stdlib/source')
20 files changed, 640 insertions, 389 deletions
diff --git a/stdlib/source/format/lux/data/text.lux b/stdlib/source/format/lux/data/text.lux index d998310ae..e4adae6f7 100644 --- a/stdlib/source/format/lux/data/text.lux +++ b/stdlib/source/format/lux/data/text.lux @@ -87,6 +87,26 @@ [json json.JSON (of json.codec encoded)] ) +(with_template [<suffix> <name>] + [(def .public <name> + (Format Frac) + (|>> ((template.symbol [frac._] [<name>])) + frac.int + ..int + (text.suffix <suffix>)))] + + ["%" percentage] + + ... https://en.wikipedia.org/wiki/Degree_symbol + ["°" degree] + + ... https://en.wikipedia.org/wiki/Per_mille + ["‰" permille] + + ... https://en.wikipedia.org/wiki/Basis_point + ["‱" permyriad] + ) + (with_template [<type> <format>,<codec>] [(`` (with_template [<format> <codec>] [(def .public <format> diff --git a/stdlib/source/library/lux/control/parser.lux b/stdlib/source/library/lux/control/parser.lux index 207e486de..cd25b8bbf 100644 --- a/stdlib/source/library/lux/control/parser.lux +++ b/stdlib/source/library/lux/control/parser.lux @@ -99,31 +99,6 @@ (Try [state of]))) (parser input)) -(def .public (and left right) - (All (_ state left right) - (-> (Parser state left) (Parser state right) - (Parser state (And left right)))) - (do [! ..monad] - [head left] - (of ! each (|>> [head]) right))) - -(def .public (or left right) - (All (_ state left right) - (-> (Parser state left) (Parser state right) - (Parser state (Or left right)))) - (function (_ tokens) - (when (left tokens) - {try.#Success [tokens' output]} - {try.#Success [tokens' {0 #0 output}]} - - {try.#Failure _} - (when (right tokens) - {try.#Success [tokens' output]} - {try.#Success [tokens' {0 #1 output}]} - - {try.#Failure error} - {try.#Failure error})))) - (def .public (either this that) (All (_ state of) (-> (Parser state of) (Parser state of) @@ -136,27 +111,137 @@ success success))) -(def .public (some parser) - (All (_ state of) - (-> (Parser state of) - (Parser state (List of)))) - (function (_ input) - (when (parser input) - {try.#Success [input' head]} - (..result (of ..monad each (|>> (list.partial head)) - (some parser)) - input') - - {try.#Failure _} - {try.#Success [input (list)]}))) - -(def .public (many parser) - (All (_ state of) - (-> (Parser state of) - (Parser state (List of)))) - (|> (..some parser) - (..and parser) - (of ..monad each (|>> {.#Item})))) +(with_expansions [<failure> {try.#Failure error} + <handle_failure!> (these <failure> + <failure>)] + (def .public (and left right) + (All (_ state left right) + (-> (Parser state left) (Parser state right) + (Parser state (And left right)))) + (function (_ state) + (when (left state) + {try.#Success [state left]} + (when (right state) + {try.#Success [state right]} + {try.#Success [state [left right]]} + + + <handle_failure!>) + + <handle_failure!>))) + + (def .public (or left right) + (All (_ state left right) + (-> (Parser state left) (Parser state right) + (Parser state (Or left right)))) + (function (_ tokens) + (when (left tokens) + {try.#Success [tokens' output]} + {try.#Success [tokens' {0 #0 output}]} + + {try.#Failure _} + (when (right tokens) + {try.#Success [tokens' output]} + {try.#Success [tokens' {0 #1 output}]} + + <handle_failure!>)))) + + (def .public (some it) + (All (_ state of) + (-> (Parser state of) + (Parser state (List of)))) + (function (_ state) + (loop (next [state state + output (list)]) + (when (it state) + {try.#Success [state head]} + (next state (list.partial head output)) + + {try.#Failure _} + {try.#Success [state (list.reversed output)]})))) + + (def .public (many parser) + (All (_ state of) + (-> (Parser state of) + (Parser state (List of)))) + (function (_ state) + (when (parser state) + {try.#Success [state head]} + (when (..some parser state) + {try.#Success [state tail]} + {try.#Success [state {.#Item head tail}]} + + <handle_failure!>) + + <handle_failure!>))) + + (def .public (after parameter it) + (All (_ state _ of) + (-> (Parser state _) (Parser state of) + (Parser state of))) + (function (_ state) + (when (parameter state) + {try.#Success [state _]} + (when (it state) + <handle_failure!> + + success + success) + + <handle_failure!>))) + + (def .public (before parameter it) + (All (_ state _ of) + (-> (Parser state _) (Parser state of) + (Parser state of))) + (function (_ state) + (when (it state) + {try.#Success [state it]} + (when (parameter state) + {try.#Success [state _]} + {try.#Success [state it]} + + <handle_failure!>) + + <handle_failure!>))) + + (def .public (of_try operation) + (All (_ state of) + (-> (Try of) + (Parser state of))) + (function (_ input) + (when operation + {try.#Success output} + {try.#Success [input output]} + + <handle_failure!>))) + + (def .public (parses parser) + (All (_ state of) + (-> (Parser state of) + (Parser state Any))) + (function (_ input) + (when (parser input) + {try.#Success [input' _]} + {try.#Success [input' []]} + + <handle_failure!>))) + + (def .public (codec codec parser) + (All (_ state medium of) + (-> (Codec medium of) (Parser state medium) + (Parser state of))) + (function (_ input) + (when (parser input) + {try.#Success [input' to_decode]} + (when (of codec decoded to_decode) + {try.#Success value} + {try.#Success [input' value]} + + <handle_failure!>) + + <handle_failure!>))) + ) (def .public (exactly amount parser) (All (_ state of) @@ -240,18 +325,6 @@ (function (_ input) {try.#Failure message})) -(def .public (of_try operation) - (All (_ state of) - (-> (Try of) - (Parser state of))) - (function (_ input) - (when operation - {try.#Success output} - {try.#Success [input output]} - - {try.#Failure error} - {try.#Failure error}))) - (def .public (else value parser) (All (_ state of) (-> of (Parser state of) @@ -276,24 +349,8 @@ (Parser state of)) (Parser state of))) (function (_ inputs) - (..result (parser (rec parser)) inputs))) - -(def .public (after param subject) - (All (_ state _ of) - (-> (Parser state _) (Parser state of) - (Parser state of))) - (do ..monad - [_ param] - subject)) - -(def .public (before param subject) - (All (_ state _ of) - (-> (Parser state _) (Parser state of) - (Parser state of))) - (do ..monad - [output subject - _ param] - (in output))) + (..result (parser (rec parser)) + inputs))) (def .public (only test parser) (All (_ state of) @@ -316,18 +373,6 @@ {try.#Failure error} {try.#Success [input false]}))) -(def .public (parses parser) - (All (_ state of) - (-> (Parser state of) - (Parser state Any))) - (function (_ input) - (when (parser input) - {try.#Success [input' _]} - {try.#Success [input' []]} - - {try.#Failure error} - {try.#Failure error}))) - (def .public (speculative parser) (All (_ state of) (-> (Parser state of) @@ -339,20 +384,3 @@ failure failure))) - -(def .public (codec codec parser) - (All (_ state medium of) - (-> (Codec medium of) (Parser state medium) - (Parser state of))) - (function (_ input) - (when (parser input) - {try.#Success [input' to_decode]} - (when (of codec decoded to_decode) - {try.#Success value} - {try.#Success [input' value]} - - {try.#Failure error} - {try.#Failure error}) - - {try.#Failure error} - {try.#Failure error}))) diff --git a/stdlib/source/library/lux/data/color/hsb.lux b/stdlib/source/library/lux/data/color/hsb.lux index 9bf403cf2..87d03137f 100644 --- a/stdlib/source/library/lux/data/color/hsb.lux +++ b/stdlib/source/library/lux/data/color/hsb.lux @@ -9,13 +9,19 @@ [control [function [predicate (.only Predicate)]]] + [data + [text + ["%" \\format]]] [math [number ["f" frac] + ["[0]" nat] ["[0]" int]]] [meta [type - ["[0]" nominal]]]]] + ["[0]" nominal]] + ["[0]" macro + ["[1]" local]]]]] [// ["[0]" rgb (.only RGB)]]) @@ -90,7 +96,7 @@ (def down (-> Nat Frac) - (|>> .int int.frac (f./ rgb_factor))) + (|>> nat.frac (f./ rgb_factor))) (def up (-> Frac @@ -111,37 +117,33 @@ saturation (if (f.= +0.0 brightness) +0.0 (|> chroma (f./ brightness)))] - (nominal.abstraction - [#hue (cond (f.= +0.0 chroma) - ... Achromatic - +0.0 - ... Chromatic - (and (f.= brightness red) - (not (f.= red blue))) - (|> green (f.- blue) - (f./ chroma) - (f.+ +0.0) - (f./ +6.0)) - - (f.= brightness green) - (|> blue (f.- red) - (f./ chroma) - (f.+ +2.0) - (f./ +6.0)) - - ... (f.= brightness blue) - (|> red (f.- green) - (f./ chroma) - (f.+ +4.0) - (f./ +6.0))) - #saturation saturation - #brightness brightness]))) + (macro.let [hue_of (template (_ <base> <shift> <adjustment>) + [(|> <base> (f.- <shift>) + (f./ chroma) + <adjustment> + (f./ +6.0))])] + (nominal.abstraction + [#hue (cond (f.= +0.0 chroma) + ... Achromatic + +0.0 + ... Chromatic + (f.= brightness red) + (hue_of green blue (f.mod +6.0)) + + (f.= brightness green) + (hue_of blue red (f.+ +2.0)) + + ... (f.= brightness blue) + (hue_of red green (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)) @@ -156,4 +158,13 @@ (rgb.rgb (..up red) (..up green) (..up blue)))) + + (def .public (format it) + (%.Format HSB) + (let [it (nominal.representation it)] + (%.format "hsb(" + (%.nat (f.nat (f.degree (the #hue it)))) + " " (%.nat (f.nat (f.percentage (the #saturation it)))) "%" + " " (%.nat (f.nat (f.percentage (the #brightness it)))) "%" + ")"))) ) diff --git a/stdlib/source/library/lux/data/color/hsl.lux b/stdlib/source/library/lux/data/color/hsl.lux index a47ef0d2f..07366f0e9 100644 --- a/stdlib/source/library/lux/data/color/hsl.lux +++ b/stdlib/source/library/lux/data/color/hsl.lux @@ -10,6 +10,9 @@ [control [function [predicate (.only Predicate)]]] + [data + [text + ["%" \\format]]] [math [number ["i" int] @@ -187,3 +190,11 @@ (|>> (the #luminance) (..hsl +0.0 +0.0))) + +(def .public (format it) + (%.Format HSL) + (%.format "hsl(" + (%.nat (f.nat (f.degree (the #hue it)))) + " " (%.nat (f.nat (f.percentage (the #saturation it)))) "%" + " " (%.nat (f.nat (f.percentage (the #luminance it)))) "%" + ")")) diff --git a/stdlib/source/library/lux/data/color/rgb.lux b/stdlib/source/library/lux/data/color/rgb.lux index c930451af..ace3f6f70 100644 --- a/stdlib/source/library/lux/data/color/rgb.lux +++ b/stdlib/source/library/lux/data/color/rgb.lux @@ -13,7 +13,9 @@ [function [predicate (.only Predicate)]]] [data - ["[0]" product]] + ["[0]" product] + [text + ["%" \\format]]] [math [number ["n" nat] @@ -161,3 +163,11 @@ [darker ..black] [brighter ..white] ) + +(def .public (format it) + (%.Format RGB) + (%.format "rgb(" + (%.nat (the #red it)) + "," (%.nat (the #green it)) + "," (%.nat (the #blue it)) + ")")) diff --git a/stdlib/source/library/lux/data/format/tar.lux b/stdlib/source/library/lux/data/format/tar.lux index 2f3aaa42e..b5627f0b2 100644 --- a/stdlib/source/library/lux/data/format/tar.lux +++ b/stdlib/source/library/lux/data/format/tar.lux @@ -35,7 +35,8 @@ ["[0]" i64]]] [meta [macro - ["^" pattern]] + ["^" pattern] + ["[0]" template]] [type ["[0]" nominal (.except def #name)]]] [world @@ -52,7 +53,8 @@ 8) (def (octal_padding max_size number) - (-> Size Text Text) + (-> Size Text + Text) (let [padding_size (n.- (text.size number) max_size) padding (|> "0" @@ -86,13 +88,15 @@ Nat (def .public (<in> value) - (-> Nat (Try <type>)) + (-> Nat + (Try <type>)) (if (n.< <limit> value) {try.#Success (abstraction value)} (exception.except <exception> [value]))) (def .public <out> - (-> <type> Nat) + (-> <type> + Nat) (|>> representation)) (def <format> @@ -107,7 +111,8 @@ (!binary.segment padded_size)))) (def <coercion> - (-> Nat <type>) + (-> Nat + <type>) (|>> (n.% <limit>) abstraction)) )] @@ -128,50 +133,59 @@ (list ["Expected" (%.nat expected)] ["Actual" (%.nat actual)]))) +(def parsed + (template (_ <state> <binding> <parser> <body>) + [(when (<parser> <state>) + {try.#Success [<state> <binding>]} + <body> + + {try.#Failure error} + {try.#Failure error})])) + (def small_suffix (Parser Any) - (do <>.monad - [pre_end ?binary.bits_8 - _ (let [expected (`` (char (,, (static ..blank))))] - (<>.assertion (exception.error ..wrong_character [expected pre_end]) - (n.= expected pre_end))) - - end ?binary.bits_8 - _ (let [expected (`` (char (,, (static ..null))))] - (<>.assertion (exception.error ..wrong_character [expected end]) - (n.= expected end)))] - (in []))) + (<| (function (_ state)) + (parsed state pre_end ?binary.bits_8) + (let [expected (`` (char (,, (static ..blank))))]) + (if (not (n.= expected pre_end)) + (exception.except ..wrong_character [expected pre_end])) + (parsed state end ?binary.bits_8) + (let [expected (`` (char (,, (static ..null))))]) + (if (not (n.= expected end)) + (exception.except ..wrong_character [expected end])) + {try.#Success [state []]})) (def small_parser (Parser Small) - (do <>.monad - [digits (?binary.segment ..small_size) - digits (<>.of_try (of utf8.codec decoded digits)) - _ ..small_suffix] - (<>.of_try - (do [! try.monad] - [value (of n.octal decoded digits)] - (..small value))))) + (<| (function (_ state)) + (parsed state digits (?binary.segment ..small_size)) + (parsed state digits (<>.of_try (of utf8.codec decoded digits))) + (parsed state _ ..small_suffix) + (do [! try.monad] + [value (of n.octal decoded digits) + value (..small value)] + (in [state value])))) (def big_parser (Parser Big) - (do <>.monad - [digits (?binary.segment ..big_size) - digits (<>.of_try (of utf8.codec decoded digits)) - end ?binary.bits_8 - _ (let [expected (`` (char (,, (static ..blank))))] - (<>.assertion (exception.error ..wrong_character [expected end]) - (n.= expected end)))] - (<>.of_try - (do [! try.monad] - [value (of n.octal decoded digits)] - (..big value))))) + (<| (function (_ state)) + (parsed state digits (?binary.segment ..big_size)) + (parsed state digits (<>.of_try (of utf8.codec decoded digits))) + (parsed state end ?binary.bits_8) + (let [expected (`` (char (,, (static ..blank))))]) + (if (not (n.= expected end)) + (exception.except ..wrong_character [expected end])) + (do [! try.monad] + [value (of n.octal decoded digits) + value (..big value)] + (in [state value])))) (nominal.def Checksum Text (def from_checksum - (-> Checksum Text) + (-> Checksum + Text) (|>> representation)) (def dummy_checksum @@ -182,7 +196,8 @@ (%.format ..blank ..null)) (def checksum - (-> Binary Nat) + (-> Binary + Nat) (binary.mix n.+ 0)) (def checksum_checksum @@ -192,7 +207,8 @@ ..checksum)) (def checksum_code - (-> Binary Checksum) + (-> Binary + Checksum) (|>> ..checksum ..as_small ..from_small @@ -211,14 +227,14 @@ (def checksum_parser (Parser [Nat Checksum]) - (do <>.monad - [ascii (?binary.segment ..small_size) - digits (<>.of_try (of utf8.codec decoded ascii)) - _ ..small_suffix - value (<>.of_try - (of n.octal decoded digits))] - (in [value - (abstraction (%.format digits ..checksum_suffix))]))) + (<| (function (_ state)) + (parsed state ascii (?binary.segment ..small_size)) + (parsed state digits (<>.of_try (of utf8.codec decoded ascii))) + (parsed state _ ..small_suffix) + (parsed state value (<>.of_try + (of n.octal decoded digits))) + {try.#Success [state [value + (abstraction (%.format digits ..checksum_suffix))]]})) ) (def last_ascii @@ -226,7 +242,8 @@ (number.hex "007F")) (def ascii? - (-> Text Bit) + (-> Text + Bit) (|>> (of utf8.codec encoded) (binary.mix (function (_ char verdict) (.and verdict @@ -242,7 +259,8 @@ (def .public path_size Size 99) (def (un_padded string) - (-> Binary Binary) + (-> Binary + Binary) (when (binary!.size string) 0 string @@ -271,7 +289,8 @@ ["Maximum" (%.nat <size>)]))) (def .public (<in> value) - (-> <representation> (Try <type>)) + (-> <representation> + (Try <type>)) (if (..ascii? value) (if (|> value (of utf8.codec encoded) @@ -282,7 +301,8 @@ (exception.except ..not_ascii [value]))) (def .public <out> - (-> <type> <representation>) + (-> <type> + <representation>) (|>> representation)) (def <format> @@ -296,16 +316,16 @@ (def <parser> (Parser <type>) - (do <>.monad - [string (?binary.segment <size>) - end ?binary.bits_8 - .let [expected (`` (char (,, (static ..null))))] - _ (<>.assertion (exception.error ..wrong_character [expected end]) - (n.= expected end))] - (<>.of_try - (do [! try.monad] - [text (of utf8.codec decoded (..un_padded string))] - (<in> text))))) + (<| (function (_ state)) + (parsed state string (?binary.segment <size>)) + (parsed state end ?binary.bits_8) + (let [expected (`` (char (,, (static ..null))))]) + (if (not (n.= expected end)) + (exception.except ..wrong_character [expected end])) + (do [! try.monad] + [text (of utf8.codec decoded (..un_padded string)) + it (<in> text)] + (in [state it])))) (def .public <none> <type> @@ -325,7 +345,8 @@ (abstraction "ustar ")) (def from_magic - (-> Magic Text) + (-> Magic + Text) (|>> representation)) (def magic_format @@ -338,15 +359,14 @@ (def magic_parser (Parser Magic) - (do <>.monad - [string (?binary.segment ..magic_size) - end ?binary.bits_8 - .let [expected (`` (char (,, (static ..null))))] - _ (<>.assertion (exception.error ..wrong_character [expected end]) - (n.= expected end))] - (<>.of_try - (of try.monad each (|>> abstraction) - (of utf8.codec decoded string))))) + (<| (function (_ state)) + (parsed state string (?binary.segment ..magic_size)) + (parsed state end ?binary.bits_8) + (let [expected (`` (char (,, (static ..null))))]) + (if (not (n.= expected end)) + (exception.except ..wrong_character [expected end])) + (of try.monad each (|>> abstraction [state]) + (of utf8.codec decoded string)))) ) (def block_size Size 512) @@ -363,15 +383,18 @@ (def device_size Size ..small_size) (def small_number - (-> Size Size) + (-> Size + Size) (|>> (all n.+ ..blank_size ..null_size))) (def big_number - (-> Size Size) + (-> Size + Size) (|>> (all n.+ ..blank_size))) (def string - (-> Size Size) + (-> Size + Size) (|>> (all n.+ ..null_size))) (def header_size @@ -409,7 +432,8 @@ Char (def link_flag - (-> Link_Flag Char) + (-> Link_Flag + Char) (|>> representation)) (def link_flag_format @@ -441,28 +465,30 @@ (def link_flag_parser (Parser Link_Flag) - (do <>.monad - [it ?binary.bits_8] - (when (.nat it) - (^.with_template [<value> <link_flag>] - [<value> - (in <link_flag>)]) - (<options>) - - _ - (<>.of_try - (exception.except ..invalid_link_flag [(.nat it)])))))) + (<| (function (_ state)) + (parsed state it ?binary.bits_8) + (when (.nat it) + (^.with_template [<value> <link_flag>] + [<value> + {try.#Success [state <link_flag>]}]) + (<options>) + + _ + (exception.except ..invalid_link_flag [(.nat it)])))) + ) ) (nominal.def .public Mode Nat (def .public mode - (-> Mode Nat) + (-> Mode + Nat) (|>> representation)) (def .public (and left right) - (-> Mode Mode Mode) + (-> Mode Mode + Mode) (abstraction (i64.or (representation left) (representation right)))) @@ -526,13 +552,14 @@ (def mode_parser (Parser Mode) - (do [! <>.monad] - [value (of ! each ..from_small ..small_parser)] - (if (n.> (representation ..maximum_mode) - value) - (<>.of_try - (exception.except ..invalid_mode [value])) - (in (abstraction value)))))) + (<| (function (_ state)) + (parsed state value ..small_parser) + (let [value (..from_small value)]) + (if (n.> (representation ..maximum_mode) + value) + (exception.except ..invalid_mode [value]) + {try.#Success [state (abstraction value)]}))) + ) ) (def maximum_content_size @@ -545,18 +572,22 @@ [Big Binary] (def .public (content it) - (-> Binary (Try Content)) + (-> Binary + (Try Content)) (do try.monad [size (..big (binary!.size it))] (in (abstraction [size it])))) (def from_content - (-> Content [Big Binary]) + (-> Content + [Big Binary]) (|>> representation)) (def .public data - (-> Content Binary) - (|>> representation product.right)) + (-> Content + Binary) + (|>> representation + product.right)) ) (type .public ID @@ -639,7 +670,8 @@ (exception.except ..unknown_file [expected]))) (def (blocks size) - (-> Big Nat) + (-> Big + Nat) (n.+ (n./ ..block_size (..from_big size)) (when (n.% ..block_size (..from_big size)) @@ -647,7 +679,8 @@ _ 1))) (def rounded_content_size - (-> Big Nat) + (-> Big + Nat) (|>> ..blocks (n.* ..block_size))) @@ -699,14 +732,16 @@ (!binary.segment ..block_size)))) (def modification_time - (-> Instant Big) + (-> Instant + Big) (|>> instant.relative (duration.ticks duration.second) .nat ..as_big)) (def (file_format link_flag) - (-> Link_Flag (Format File)) + (-> Link_Flag + (Format File)) (function (_ [path modification_time mode ownership content]) (let [[size content] (..from_content content) format (all !binary.and @@ -810,7 +845,8 @@ ... To correct for this, it is necessary to calculate the checksum of just the checksum field, subtract that, and then ... add-in the checksum of the spaces. (def (expected_checksum checksum header) - (-> Checksum Binary Nat) + (-> Checksum Binary + Nat) (let [|checksum| (|> checksum ..from_checksum (of utf8.codec encoded) @@ -821,81 +857,105 @@ (def header_parser (Parser Header) - (do <>.monad - [binary_header (<>.speculative (?binary.segment block_size)) - path ..path_parser - mode ..mode_parser - user_id ..small_parser - group_id ..small_parser - size ..big_parser - modification_time ..big_parser - [actual checksum_code] ..checksum_parser - _ (let [expected (expected_checksum checksum_code binary_header)] - (<>.of_try - (exception.assertion ..wrong_checksum [expected actual] - (n.= expected actual)))) - link_flag ..link_flag_parser - link_name ..path_parser - magic ..magic_parser - user_name ..name_parser - group_name ..name_parser - major_device ..small_parser - minor_device ..small_parser - _ (?binary.segment ..header_padding_size)] - (in [#path path - #mode mode - #user_id user_id - #group_id group_id - #size size - #modification_time modification_time - #checksum checksum_code - #link_flag link_flag - #link_name link_name - #magic magic - #user_name user_name - #group_name group_name - #major_device major_device - #minor_device minor_device]))) + (function (_ state) + (`` (<| (,, (with_template [<binding> <parser>] + [(parsed state <binding> <parser>)] + + [binary_header (<>.speculative (?binary.segment block_size))] + [path ..path_parser] + [mode ..mode_parser] + [user_id ..small_parser] + [group_id ..small_parser] + [size ..big_parser] + [modification_time ..big_parser] + [[actual checksum_code] ..checksum_parser] + )) + (let [expected (expected_checksum checksum_code binary_header)]) + (if (not (n.= expected actual)) + (exception.except ..wrong_checksum [expected actual])) + (,, (with_template [<binding> <parser>] + [(parsed state <binding> <parser>)] + + [link_flag ..link_flag_parser] + [link_name ..path_parser] + [magic ..magic_parser] + [user_name ..name_parser] + [group_name ..name_parser] + [major_device ..small_parser] + [minor_device ..small_parser] + [_ (?binary.segment ..header_padding_size)] + )) + {try.#Success [state [#path path + #mode mode + #user_id user_id + #group_id group_id + #size size + #modification_time modification_time + #checksum checksum_code + #link_flag link_flag + #link_name link_name + #magic magic + #user_name user_name + #group_name group_name + #major_device major_device + #minor_device minor_device]]})))) (def (file_parser header) - (-> Header (Parser File)) - (do <>.monad - [.let [size (the #size header) - rounded_size (..rounded_content_size size)] - content (?binary.segment (..from_big size)) - content (<>.of_try (..content content)) - _ (?binary.segment (n.- (..from_big size) rounded_size))] - (in [(the #path header) - (|> header - (the #modification_time) - ..from_big - .int - duration.of_millis - (duration.up (|> duration.second duration.millis .nat)) - instant.absolute) - (the #mode header) - [#user [#name (the #user_name header) - #id (the #user_id header)] - #group [#name (the #group_name header) - #id (the #group_id header)]] - content]))) + (-> Header + (Parser File)) + (function (_ state) + (`` (<| (let [size (the #size header) + rounded_size (..rounded_content_size size)]) + (,, (with_template [<binding> <parser>] + [(parsed state <binding> <parser>)] + + [content (?binary.segment (..from_big size))] + [content (<>.of_try (..content content))] + [_ (?binary.segment (n.- (..from_big size) rounded_size))] + )) + {try.#Success [state [(the #path header) + (|> header + (the #modification_time) + ..from_big + .int + duration.of_millis + (duration.up (|> duration.second duration.millis .nat)) + instant.absolute) + (the #mode header) + [#user [#name (the #user_name header) + #id (the #user_id header)] + #group [#name (the #group_name header) + #id (the #group_id header)]] + content]]})))) (def entry_parser (Parser Entry) - (do [! <>.monad] - [header ..header_parser] - (cond (same? ..contiguous (the #link_flag header)) - (of ! each (|>> {..#Contiguous}) (..file_parser header)) - - (same? ..symbolic_link (the #link_flag header)) - (in {..#Symbolic_Link (the #link_name header)}) - - (same? ..directory (the #link_flag header)) - (in {..#Directory (the #path header)}) - - ... (or (same? ..normal (the #link_flag header)) - ... (same? ..old_normal (the #link_flag header))) - (of ! each (|>> {..#Normal}) (..file_parser header))))) + (function (_ state) + (when (..header_parser state) + {try.#Success [state header]} + (template.let [(of_file <tag>) + [(when (..file_parser header state) + {try.#Success [state it]} + {try.#Success [state {<tag> it}]} + + {try.#Failure error} + {try.#Failure error})] + + (of_other <flag> <tag> <slot>) + [(same? <flag> (the #link_flag header)) + {try.#Success [state {<tag> (the <slot> header)}]}]] + (`` (cond (or (same? ..normal (the #link_flag header)) + (same? ..old_normal (the #link_flag header))) + (,, (of_file ..#Normal)) + + (,, (of_other ..symbolic_link ..#Symbolic_Link #link_name)) + (,, (of_other ..directory ..#Directory #path)) + + ... (same? ..contiguous (the #link_flag header)) + (,, (of_file ..#Contiguous))))) + + {try.#Failure error} + {try.#Failure error}))) ... It's safe to implement the parser this way because the range of values for Nat is 2^64 ... Whereas the maximum possible value for the checksum of a 512 block is (256 × 512) = 131,072 diff --git a/stdlib/source/library/lux/ffi.lux b/stdlib/source/library/lux/ffi.lux index f76ab1675..632fc1c3f 100644 --- a/stdlib/source/library/lux/ffi.lux +++ b/stdlib/source/library/lux/ffi.lux @@ -216,7 +216,8 @@ (def .public undefined? (template (undefined? <it>) - [(.as .Bit (.is .Any (undefined?|analysis <it>)))])) + [(.as .Bit + (..undefined?|analysis <it>))])) (translation undefined|translation [phase archive state] @@ -232,7 +233,8 @@ (def .public undefined (template (_) - [(.is ..Undefined (undefined|analysis))])) + [(.is ..Undefined + (..undefined|analysis))])) (def (pairs it) (All (_ a) (-> (List a) (List [a a]))) @@ -298,7 +300,7 @@ (def .public object (syntax (_ [it (<>.some <code>.any)]) (in (list (` (.as (..Object .Any) - (object|analysis (,* it)))))))) + (..object|analysis (,* it)))))))) (translation set|translation [phase archive state] @@ -334,7 +336,8 @@ (syntax (_ [field <code>.any value <code>.any object <code>.any]) - (in (list (` (.as .Any (set|analysis (, field) (, value) (, object)))))))) + (in (list (` (.as .Any + (..set|analysis (, field) (, value) (, object)))))))) ) ... else (these)) diff --git a/stdlib/source/library/lux/ffi/export.js.lux b/stdlib/source/library/lux/ffi/export.js.lux index e13051cb4..6b1cff03f 100644 --- a/stdlib/source/library/lux/ffi/export.js.lux +++ b/stdlib/source/library/lux/ffi/export.js.lux @@ -21,9 +21,9 @@ [macro [syntax (.only syntax)] ["[0]" expansion]] - [target - ["/" js]] [compiler + [target + ["/" js]] [meta [cache ["[0]" dependency @@ -56,9 +56,10 @@ type.inferring (next archive term)) + lux (declaration.of_analysis meta.compiler_state) next declaration.synthesis term (declaration.of_synthesis - (next archive term)) + (next lux archive term)) dependencies (declaration.of_translation (dependency.dependencies archive term)) @@ -66,7 +67,7 @@ next declaration.translation [interim_artifacts term] (declaration.of_translation (translation.with_interim_artifacts archive - (next archive term))) + (next lux archive term))) _ (declaration.of_translation (do ! diff --git a/stdlib/source/library/lux/ffi/export.py.lux b/stdlib/source/library/lux/ffi/export.py.lux index 66b0d1478..d9e729a8a 100644 --- a/stdlib/source/library/lux/ffi/export.py.lux +++ b/stdlib/source/library/lux/ffi/export.py.lux @@ -21,9 +21,9 @@ [macro [syntax (.only syntax)] ["[0]" expansion]] - [target - ["/" python]] [compiler + [target + ["/" python]] [meta [cache ["[0]" dependency @@ -37,7 +37,8 @@ ["[0]" type]]]]]]]]) (def definition - (-> Code (Meta [Text Code])) + (-> Code + (Meta [Text Code])) (|>> (list) (<code>.result (<| <code>.form (<>.after (<code>.this_symbol (symbol .def#))) diff --git a/stdlib/source/library/lux/math/number/frac.lux b/stdlib/source/library/lux/math/number/frac.lux index 87e4958ab..a2148b973 100644 --- a/stdlib/source/library/lux/math/number/frac.lux +++ b/stdlib/source/library/lux/math/number/frac.lux @@ -919,3 +919,19 @@ (..< +0.0 remainder))) (..+ divisor remainder) remainder))) + +(with_template [<factor> <name>] + [(def .public <name> + (-> Frac + Frac) + (|>> (* <factor>)))] + + [+100.0 percentage] + [+360.0 degree] + + ... https://en.wikipedia.org/wiki/Per_mille + [+01,000.0 permille] + + ... https://en.wikipedia.org/wiki/Basis_point + [+10,000.0 permyriad] + ) diff --git a/stdlib/source/library/lux/meta.lux b/stdlib/source/library/lux/meta.lux index 3a45da32d..87987c272 100644 --- a/stdlib/source/library/lux/meta.lux +++ b/stdlib/source/library/lux/meta.lux @@ -26,8 +26,9 @@ ["[0]" symbol (.use "[1]#[0]" absolute equivalence)] ["[0]" code]]) -... (.type (Meta a) -... (-> Lux (Try [Lux a]))) +... (.type (Meta of) +... (-> Lux +... (Try [Lux of]))) (def .public functor (Functor Meta) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/runtime.lux index 0d2b79c43..2effaf905 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/runtime.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/js/runtime.lux @@ -558,10 +558,10 @@ (_.define r00 (ll parameter)) (_.define x00 (_.* l00 r00)) - (_.define x16 (high_16 x00)) + (_.define x16 (|> (high_16 x00) + (_.+ (_.* l16 r00)))) (_.statement (_.set x00 (low_16 x00))) - (_.statement (_.set x16 (|> x16 (_.+ (_.* l16 r00))))) (_.define x32 (high_16 x16)) (_.statement (_.set x16 (|> x16 low_16 (_.+ (_.* l00 r16))))) (_.statement (_.set x32 (|> x32 (_.+ (high_16 x16))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/apply.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/apply.lux index c18822e3c..b2ecca205 100644 --- a/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/apply.lux +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/apply.lux @@ -43,7 +43,6 @@ ["[1][0]" foreign]]] ["/[1]" // ["[1][0]" runtime] - ["[1][0]" value] ["[1][0]" reference] [//// [analysis (.only Environment)] diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index d0620d344..64ac888ac 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -1120,7 +1120,11 @@ (def for_meta Test (all _.and - (_.coverage [/.Mode /.Info] + (_.coverage [/.Info + /.#target /.#version /.#mode /.#configuration + + /.Mode + /.#Build /.#Eval /.#Interpreter] (for_meta|Info)) (_.coverage [/.Module_State /.#Active /.#Compiled /.#Cached] diff --git a/stdlib/source/test/lux/meta.lux b/stdlib/source/test/lux/meta.lux index b13f9097c..2fdf791c4 100644 --- a/stdlib/source/test/lux/meta.lux +++ b/stdlib/source/test/lux/meta.lux @@ -50,10 +50,7 @@ ["[1][0]" static] ["[1][0]" extension] ["[1][0]" global] - ["[1][0]" compiler - ... ["[1]/[0]" phase] - ] - ]) + ["[1][0]" compiler]]) (def !expect (template (_ <pattern> <value>) @@ -1052,6 +1049,5 @@ (,, (for @.old (,, (these)) (,, (these /extension.test)))) /global.test - /compiler.test ))))) diff --git a/stdlib/source/test/lux/meta/compiler/language/lux/phase.lux b/stdlib/source/test/lux/meta/compiler/language/lux/phase.lux index 35e683c48..c3b774b5e 100644 --- a/stdlib/source/test/lux/meta/compiler/language/lux/phase.lux +++ b/stdlib/source/test/lux/meta/compiler/language/lux/phase.lux @@ -1,44 +1,52 @@ ... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. ... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. -(.require - [library - [lux (.except) - [abstract - ["[0]" monad (.only do) - ["[1]T" \\test]] - ["[0]" functor - ["[1]T" \\test (.only Injection Comparison)]]] - [control - ["[0]" pipe] - ["[0]" try (.use "[1]#[0]" functor)] - ["[0]" exception]] - [data - ["[0]" text (.use "[1]#[0]" equivalence) - ["%" \\format (.only format)]]] - [math - ["[0]" random] - [number - ["n" nat] - ["i" int]]] - [test - ["_" property (.only Test)]]]] - [\\library - ["[0]" / (.only) - [//// - [meta - ["[0]" archive]]]]] - ["[0]" / - ["[1][0]" translation - ["[1]/[0]" jvm - ["[1]/[0]" host] - ["[1]/[0]" primitive] - ["[1]/[0]" type] - ["[1]/[0]" value] - ["[1]/[0]" runtime] - ["[1]/[0]" complex] - ["[1]/[0]" function] - ["[1]/[0]" reference]]]]) +(.`` (.`` (.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do) + ["[1]T" \\test]] + ["[0]" functor + ["[1]T" \\test (.only Injection Comparison)]]] + [control + ["[0]" pipe] + ["[0]" try (.use "[1]#[0]" functor)] + ["[0]" exception]] + [data + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]]] + [math + ["[0]" random] + [number + ["n" nat] + ["i" int]]] + [meta + [compiler + ["@" target]]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" / (.only) + [//// + [meta + ["[0]" archive]]]]] + [/ + [translation + (.,, (.for "JVM" (.,, (.these ["[0]" jvm + ["[1]/[0]" host] + ["[1]/[0]" primitive] + ["[1]/[0]" type] + ["[1]/[0]" value] + ["[1]/[0]" runtime] + ["[1]/[0]" complex] + ["[1]/[0]" function] + ["[1]/[0]" reference]])) + ... "JavaScript" (.,, (.these ["[1]/[0]" js])) + ... "Lua" (.,, (.these ["[1]/[0]" lua])) + ... "Python" (.,, (.these ["[1]/[0]" python])) + ... "Ruby" (.,, (.these ["[1]/[0]" ruby])) + (.,, (.these))))]]))) (def (injection value) (All (_ of) @@ -215,19 +223,24 @@ (def .public test Test - (<| (_.covering /._) - (all _.and - (_.for [/.Operation] - ..test|operation) - (_.for [/.Phase] - ..test|phase) - - /translation/jvm/host.test - /translation/jvm/primitive.test - /translation/jvm/type.test - /translation/jvm/value.test - /translation/jvm/runtime.test - /translation/jvm/complex.test - /translation/jvm/function.test - /translation/jvm/reference.test - ))) + (`` (`` (<| (_.covering /._) + (all _.and + (_.for [/.Operation] + ..test|operation) + (_.for [/.Phase] + ..test|phase) + + (,, (.for @.jvm (,, (.these jvm/host.test + jvm/primitive.test + jvm/type.test + jvm/value.test + jvm/runtime.test + jvm/complex.test + jvm/function.test + jvm/reference.test)) + ... "JavaScript" (,, (.these ["[1]/[0]" js])) + ... "Lua" (,, (.these ["[1]/[0]" lua])) + ... "Python" (,, (.these ["[1]/[0]" python])) + ... "Ruby" (,, (.these ["[1]/[0]" ruby])) + (,, (.these)))) + ))))) diff --git a/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method.lux b/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method.lux index 3e3ec7a84..b5c3e53bc 100644 --- a/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method.lux +++ b/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method.lux @@ -20,7 +20,8 @@ ["[0]" /]] ["[0]" / ["[1][0]" implementation] - ["[1][0]" reset]]) + ["[1][0]" reset] + ["[1][0]" apply]]) (def (valid_modifier? it) (-> (Modifier Method) @@ -40,4 +41,5 @@ (/implementation.test valid_modifier?) /reset.test + /apply.test ))) diff --git a/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/apply.lux b/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/apply.lux new file mode 100644 index 000000000..b3672ca01 --- /dev/null +++ b/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/apply.lux @@ -0,0 +1,75 @@ +... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. + +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" io] + ["[0]" try (.use "[1]#[0]" functor)]] + [math + ["[0]" random (.only Random)] + [number + ["[0]" i64 (.use "[1]#[0]" equivalence)]]] + [meta + [compiler + [meta + ["[0]" archive]]]] + [test + ["_" property (.only Test)]]]] + [\\library + ["[0]" / (.only) + [/// + ["[0]" // (.only) + ["[0]" host] + ["[0]" runtime] + [/// + ["[0]" extension] + [// + ["[0]" phase] + ["[0]" synthesis] + ["[0]" translation]]]]]]] + [//// + ["[0]T" complex]]) + +(def .public test + Test + (<| (_.covering /._) + (do [! random.monad] + [module (random.lower_cased 1) + + dummy_i64 random.i64 + expected_i64 (random.only (|>> (i64#= dummy_i64) not) + random.i64) + + .let [extender (is extension.Extender + (function (_ _) + (undefined))) + next (//.translate extender complexT.lux) + @ [module 0 0]]]) + (all _.and + (_.coverage [/.method] + (|> (do try.monad + [[_ archive] (archive.reserve "" archive.empty) + [_ archive] (archive.reserve module archive) + .let [[_ host] (io.run! host.host) + state (is runtime.State + (translation.state host module))]] + (<| (phase.result state) + (do phase.monad + [_ (translation.set_buffer translation.empty_buffer) + parameter (next archive (synthesis.i64 @ expected_i64)) + actual (next archive (<| (synthesis.function/apply @) + [(synthesis.function/abstraction @ [(list) 2 (synthesis.variable/local @ 1)]) + (list (synthesis.i64 @ expected_i64) + (synthesis.i64 @ dummy_i64))]))] + (in (|> actual + [{.#None}] + (of host evaluate) + (try#each (|>> (as I64) + (i64#= expected_i64))) + (try.else false)))))) + (try.else false))) + ))) diff --git a/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/reset.lux b/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/reset.lux index 105161cd1..8680035f3 100644 --- a/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/reset.lux +++ b/stdlib/source/test/lux/meta/compiler/language/lux/phase/translation/jvm/function/method/reset.lux @@ -105,12 +105,12 @@ ((as (-> I64 I64) it) expected_i64)))) - (try.else false) - ) + (try.else false)) can_reset! (|> (do !.monad - [_ partially_applied_function] + [_ partially_applied_function + _ (!.checkcast class)] (/.call class 2)) [{.#None}] (of host evaluate) @@ -120,8 +120,7 @@ it) expected_i64 expected_i64)))) - (try.else false) - )]] + (try.else false))]] (in (and what_happens_when_its_not_reset! can_reset!))))) (try.else false))) diff --git a/stdlib/source/test/lux/meta/compiler/meta/cache/dependency/module.lux b/stdlib/source/test/lux/meta/compiler/meta/cache/dependency/module.lux index 854328124..8644da07e 100644 --- a/stdlib/source/test/lux/meta/compiler/meta/cache/dependency/module.lux +++ b/stdlib/source/test/lux/meta/compiler/meta/cache/dependency/module.lux @@ -45,7 +45,8 @@ (set.of_list text.hash))] (set#= expected actual))) )) - (<| (_.for [/.Dependency]) + (<| (_.for [/.Dependency + /.#module /.#imports]) (all _.and (_.coverage [/.graph] (let [expected (set.of_list text.hash (list module/0 module/1 module/2)) |