diff options
| author | Eduardo Julian | 2022-02-16 02:32:09 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2022-02-16 02:32:09 -0400 |
| commit | b68f2b6aead6224c14902c80fc00c27705eece6c (patch) | |
| tree | 69fae48b3cf5ad137ea3ad1e03d490a445f4ef91 /stdlib | |
| parent | 8b6d474dd5d2b323d1dba29359460af4708402ea (diff) | |
FIXED generating artifact IDs in the context of "lux in-module".
Diffstat (limited to 'stdlib')
14 files changed, 1099 insertions, 565 deletions
diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux index 75575ebe4..69f555fee 100644 --- a/stdlib/source/library/lux.lux +++ b/stdlib/source/library/lux.lux @@ -676,7 +676,7 @@ .public) ... Base functions & macros -("lux def" in_meta +("lux def" meta#in ("lux type check" {#UnivQ {#End} {#Function {#Parameter 1} @@ -706,7 +706,7 @@ ("lux macro" ([_ tokens] ({{#Item lhs {#Item rhs {#Item body {#End}}}} - (in_meta {#Item (form$ {#Item (variant$ {#Item lhs {#Item body {#End}}}) + (meta#in {#Item (form$ {#Item (variant$ {#Item lhs {#Item body {#End}}}) {#Item rhs {#End}}}) {#End}}) @@ -719,7 +719,7 @@ ("lux macro" ([_ tokens] ({{#Item [_ {#Tuple {#Item arg args'}}] {#Item body {#End}}} - (in_meta {#Item (_ann {#Form {#Item (_ann {#Tuple {#Item (_ann {#Symbol ["" ""]}) + (meta#in {#Item (_ann {#Form {#Item (_ann {#Tuple {#Item (_ann {#Symbol ["" ""]}) {#Item arg {#End}}}}) {#Item ({{#End} body @@ -733,7 +733,7 @@ {#End}}) {#Item [_ {#Symbol ["" self]}] {#Item [_ {#Tuple {#Item arg args'}}] {#Item body {#End}}}} - (in_meta {#Item (_ann {#Form {#Item (_ann {#Tuple {#Item (_ann {#Symbol ["" self]}) + (meta#in {#Item (_ann {#Form {#Item (_ann {#Tuple {#Item (_ann {#Symbol ["" self]}) {#Item arg {#End}}}}) {#Item ({{#End} body @@ -786,13 +786,13 @@ ({{#Item [export_policy {#Item [[_ {#Form {#Item [name args]}}] {#Item [type {#Item [body {#End}]}]}]}]} - (in_meta {#Item [(as_def name + (meta#in {#Item [(as_def name (as_checked type (as_function name args body)) export_policy) {#End}]}) {#Item [export_policy {#Item [name {#Item [type {#Item [body {#End}]}]}]}]} - (in_meta {#Item [(as_def name (as_checked type body) + (meta#in {#Item [(as_def name (as_checked type body) export_policy) {#End}]}) @@ -805,7 +805,7 @@ ("lux macro" (function'' [tokens] ({{#Item export_policy {#Item [_ {#Form {#Item name args}}] {#Item body {#End}}}} - (in_meta {#Item (as_def name (as_macro (as_function name args body)) + (meta#in {#Item (as_def name (as_macro (as_function name args body)) export_policy) {#End}}) @@ -815,14 +815,14 @@ #0) (macro:' .public (comment tokens) - (in_meta {#End})) + (meta#in {#End})) (macro:' .private ($' tokens) ({{#Item x {#End}} - (in_meta tokens) + (meta#in tokens) {#Item x {#Item y xs}} - (in_meta {#Item (form$ {#Item (symbol$ [..prelude_module "$'"]) + (meta#in {#Item (form$ {#Item (symbol$ [..prelude_module "$'"]) {#Item (variant$ {#Item (symbol$ [..prelude_module "#Apply"]) {#Item y {#Item x {#End}}}}) xs}}) @@ -1147,7 +1147,7 @@ (macro:' .public (-> tokens) ({{#Item output inputs} - (in_meta {#Item (list#mix ("lux type check" {#Function Code {#Function Code Code}} + (meta#in {#Item (list#mix ("lux type check" {#Function Code {#Function Code Code}} (function'' [i o] (variant$ {#Item (symbol$ [..prelude_module "#Function"]) {#Item i {#Item o {#End}}}}))) output inputs) @@ -1158,12 +1158,12 @@ (list#reversed tokens))) (macro:' .public (list xs) - (in_meta {#Item (list#mix |#Item| |#End| (list#reversed xs)) + (meta#in {#Item (list#mix |#Item| |#End| (list#reversed xs)) {#End}})) (macro:' .public (list& xs) ({{#Item last init} - (in_meta (list (list#mix |#Item| last init))) + (meta#in (list (list#mix |#Item| last init))) _ (failure "Wrong syntax for list&")} @@ -1171,20 +1171,20 @@ (macro:' .public (Union tokens) ({{#End} - (in_meta (list (symbol$ [..prelude_module "Nothing"]))) + (meta#in (list (symbol$ [..prelude_module "Nothing"]))) {#Item last prevs} - (in_meta (list (list#mix (function'' [left right] (variant$ (list (symbol$ [..prelude_module "#Sum"]) left right))) + (meta#in (list (list#mix (function'' [left right] (variant$ (list (symbol$ [..prelude_module "#Sum"]) left right))) last prevs)))} (list#reversed tokens))) (macro:' .public (Tuple tokens) ({{#End} - (in_meta (list (symbol$ [..prelude_module "Any"]))) + (meta#in (list (symbol$ [..prelude_module "Any"]))) {#Item last prevs} - (in_meta (list (list#mix (function'' [left right] (variant$ (list (symbol$ [..prelude_module "#Product"]) left right))) + (meta#in (list (list#mix (function'' [left right] (variant$ (list (symbol$ [..prelude_module "#Product"]) left right))) last prevs)))} (list#reversed tokens))) @@ -1201,7 +1201,7 @@ (failure "function' requires a non-empty arguments tuple.") {#Item [harg targs]} - (in_meta (list (form$ (list (tuple$ (list (local_symbol$ name) + (meta#in (list (form$ (list (tuple$ (list (local_symbol$ name) harg)) (list#mix (function'' [arg body'] (form$ (list (tuple$ (list (local_symbol$ "") @@ -1219,7 +1219,7 @@ ({{#Item [export_policy {#Item [[_ {#Form {#Item [name args]}}] {#Item [type {#Item [body {#End}]}]}]}]} - (in_meta (list (form$ (list (text$ "lux def") + (meta#in (list (form$ (list (text$ "lux def") name (form$ (list (text$ "lux type check") type @@ -1230,7 +1230,7 @@ export_policy)))) {#Item [export_policy {#Item [name {#Item [type {#Item [body {#End}]}]}]}]} - (in_meta (list (form$ (list (text$ "lux def") + (meta#in (list (form$ (list (text$ "lux def") name (form$ (list (text$ "lux type check") type @@ -1269,7 +1269,7 @@ (macro:' .private (let' tokens) ({{#Item [_ {#Tuple bindings}] {#Item body {#End}}} ({{#Some bindings} - (in_meta (list (list#mix ("lux type check" (-> (Tuple Code Code) Code + (meta#in (list (list#mix ("lux type check" (-> (Tuple Code Code) Code Code) (function' [binding body] ({[label value] @@ -1336,7 +1336,7 @@ (macro:' .public (_$ tokens) ({{#Item op tokens'} ({{#Item first nexts} - (in_meta (list (list#mix (function#flipped (right_associativity op)) first nexts))) + (meta#in (list (list#mix (function#flipped (right_associativity op)) first nexts))) _ (failure "Wrong syntax for _$")} @@ -1349,7 +1349,7 @@ (macro:' .public ($_ tokens) ({{#Item op tokens'} ({{#Item last prevs} - (in_meta (list (list#mix (right_associativity op) last prevs))) + (meta#in (list (list#mix (right_associativity op) last prevs))) _ (failure "Wrong syntax for $_")} @@ -1431,7 +1431,7 @@ var)))) body (list#reversed bindings))] - (in_meta (list (form$ (list (variant$ (list (tuple$ (list (symbol$ [..prelude_module "#in"]) g!in + (meta#in (list (form$ (list (variant$ (list (tuple$ (list (symbol$ [..prelude_module "#in"]) g!in (symbol$ [..prelude_module "#then"]) g!then)) body')) monad))))) @@ -1480,7 +1480,7 @@ (macro:' .public (if tokens) ({{#Item test {#Item then {#Item else {#End}}}} - (in_meta (list (form$ (list (variant$ (list (bit$ #1) then + (meta#in (list (form$ (list (variant$ (list (bit$ #1) then (bit$ #0) else)) test)))) @@ -1567,7 +1567,7 @@ (def:''' .private (spliced replace? untemplated elems) (-> Bit (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code)) ({[#1] ({{#End} - (in_meta |#End|) + (meta#in |#End|) {#Item lastI inits} (do meta_monad @@ -1607,22 +1607,22 @@ (def:''' .private (untemplated replace? subst token) (-> Bit Text Code ($' Meta Code)) ({[_ [_ {#Bit value}]] - (in_meta (with_location (variant$ (list (symbol$ [..prelude_module "#Bit"]) (bit$ value))))) + (meta#in (with_location (variant$ (list (symbol$ [..prelude_module "#Bit"]) (bit$ value))))) [_ [_ {#Nat value}]] - (in_meta (with_location (variant$ (list (symbol$ [..prelude_module "#Nat"]) (nat$ value))))) + (meta#in (with_location (variant$ (list (symbol$ [..prelude_module "#Nat"]) (nat$ value))))) [_ [_ {#Int value}]] - (in_meta (with_location (variant$ (list (symbol$ [..prelude_module "#Int"]) (int$ value))))) + (meta#in (with_location (variant$ (list (symbol$ [..prelude_module "#Int"]) (int$ value))))) [_ [_ {#Rev value}]] - (in_meta (with_location (variant$ (list (symbol$ [..prelude_module "#Rev"]) (rev$ value))))) + (meta#in (with_location (variant$ (list (symbol$ [..prelude_module "#Rev"]) (rev$ value))))) [_ [_ {#Frac value}]] - (in_meta (with_location (variant$ (list (symbol$ [..prelude_module "#Frac"]) (frac$ value))))) + (meta#in (with_location (variant$ (list (symbol$ [..prelude_module "#Frac"]) (frac$ value))))) [_ [_ {#Text value}]] - (in_meta (untemplated_text value)) + (meta#in (untemplated_text value)) [#1 [_ {#Symbol [module name]}]] (do meta_monad @@ -1635,13 +1635,13 @@ (in [module name])} module) .let' [[module name] real_name]] - (in_meta (with_location (variant$ (list (symbol$ [..prelude_module "#Symbol"]) (tuple$ (list (text$ module) (text$ name)))))))) + (meta#in (with_location (variant$ (list (symbol$ [..prelude_module "#Symbol"]) (tuple$ (list (text$ module) (text$ name)))))))) [#0 [_ {#Symbol [module name]}]] - (in_meta (with_location (variant$ (list (symbol$ [..prelude_module "#Symbol"]) (tuple$ (list (text$ module) (text$ name))))))) + (meta#in (with_location (variant$ (list (symbol$ [..prelude_module "#Symbol"]) (tuple$ (list (text$ module) (text$ name))))))) [#1 [_ {#Form {#Item [[_ {#Symbol ["" "~"]}] {#Item [unquoted {#End}]}]}}]] - (in_meta (form$ (list (text$ "lux type check") + (meta#in (form$ (list (text$ "lux type check") (symbol$ [..prelude_module "Code"]) unquoted))) @@ -1677,10 +1677,10 @@ (macro:' .public (Primitive tokens) ({{#Item [_ {#Text class_name}] {#End}} - (in_meta (list (variant$ (list (symbol$ [..prelude_module "#Primitive"]) (text$ class_name) |#End|)))) + (meta#in (list (variant$ (list (symbol$ [..prelude_module "#Primitive"]) (text$ class_name) |#End|)))) {#Item [_ {#Text class_name}] {#Item [_ {#Tuple params}] {#End}}} - (in_meta (list (variant$ (list (symbol$ [..prelude_module "#Primitive"]) (text$ class_name) (untemplated_list params))))) + (meta#in (list (variant$ (list (symbol$ [..prelude_module "#Primitive"]) (text$ class_name) (untemplated_list params))))) _ (failure "Wrong syntax for Primitive")} @@ -1735,7 +1735,7 @@ (macro:' .public (|> tokens) ({{#Item [init apps]} - (in_meta (list (list#mix ("lux type check" (-> Code Code Code) + (meta#in (list (list#mix ("lux type check" (-> Code Code Code) (function' [app acc] ({[_ {#Variant parts}] (variant$ (list#composite parts (list acc))) @@ -1758,7 +1758,7 @@ (macro:' .public (<| tokens) ({{#Item [init apps]} - (in_meta (list (list#mix ("lux type check" (-> Code Code Code) + (meta#in (list (list#mix ("lux type check" (-> Code Code Code) (function' [app acc] ({[_ {#Variant parts}] (variant$ (list#composite parts (list acc))) @@ -1879,7 +1879,7 @@ (|> data' (list#each (function#composite apply (replacement_environment bindings'))) list#conjoint - in_meta) + meta#in) (failure "Irregular arguments tuples for template."))) _ @@ -2026,7 +2026,7 @@ (in [module_name name])) _ - (in_meta name)} + (meta#in name)} name)) (def:''' .private (macro' full_name) @@ -2079,7 +2079,7 @@ ?macro)) _ - (in_meta (list token))} + (meta#in (list token))} token)) (def:''' .private (expansion token) @@ -2099,7 +2099,7 @@ ?macro)) _ - (in_meta (list token))} + (meta#in (list token))} token)) (def:''' .private (full_expansion' full_expansion name args) @@ -2192,7 +2192,7 @@ (in (list (tuple$ (list#conjoint members'))))) _ - (in_meta (list syntax))} + (meta#in (list syntax))} syntax))) (def:''' .private (text#encoded original) @@ -2310,7 +2310,7 @@ (macro:' .public (: tokens) ({{#Item type {#Item value {#End}}} - (in_meta (list (` ("lux type check" + (meta#in (list (` ("lux type check" (..type (~ type)) (~ value))))) @@ -2320,7 +2320,7 @@ (macro:' .public (:as tokens) ({{#Item type {#Item value {#End}}} - (in_meta (list (` ("lux type as" + (meta#in (list (` ("lux type as" (..type (~ type)) (~ value))))) @@ -2363,7 +2363,7 @@ (macro:' .public (exec tokens) ({{#Item value actions} (let' [dummy (local_symbol$ "")] - (in_meta (list (list#mix ("lux type check" (-> Code Code Code) + (meta#in (list (list#mix ("lux type check" (-> Code Code Code) (function' [pre post] (` ({(~ dummy) (~ post)} (~ pre))))) value @@ -2403,7 +2403,7 @@ {#None} body'} ?type)] - (in_meta (list (` ("lux def" (~ name) + (meta#in (list (` ("lux def" (~ name) (~ body'') (~ export_policy)))))) @@ -2480,7 +2480,7 @@ (let' [pairs (|> patterns (list#each (function' [pattern] (list pattern body))) (list#conjoint))] - (in_meta (list#composite pairs branches)))) + (meta#in (list#composite pairs branches)))) _ (failure "Wrong syntax for ^or"))) @@ -2508,7 +2508,7 @@ (` (case (~ r) (~ l) (~ body'))))))) body) list - in_meta) + meta#in) {#None} (failure "let requires an even number of parts")) @@ -2533,7 +2533,7 @@ (` ([(~ g!name) (~ arg)] (~ body'))) (` ([(~ g!name) (~ g!blank)] (.case (~ g!blank) (~ arg) (~ body'))))))))] - (in_meta (list (nest (..local_symbol$ g!name) head + (meta#in (list (nest (..local_symbol$ g!name) head (list#mix (nest g!blank) body (list#reversed tail)))))) {#None} @@ -2741,7 +2741,7 @@ {#None} body)] - (in_meta (list (` ("lux def" (~ (..local_symbol$ name)) + (meta#in (list (` ("lux def" (~ (..local_symbol$ name)) (~ body) (~ export_policy)))))) @@ -2769,7 +2769,7 @@ _ (` ("lux macro" (function ((~ name) (~+ (list#each local_symbol$ args))) (~ body)))))] - (in_meta (list (` ("lux def" (~ name) + (meta#in (list (` ("lux def" (~ name) (~ body) (~ export_policy)))))) @@ -2795,7 +2795,7 @@ [(macro: .public (<name> tokens) (case (list#reversed tokens) (^ (list& last init)) - (in_meta (list (list#mix (: (-> Code Code Code) + (meta#in (list (list#mix (: (-> Code Code Code) (function (_ pre post) (` <form>))) last init))) @@ -2999,7 +2999,7 @@ ..#module_state _] =module]] (case (plist#value name definitions) {#Some {#Slot [exported type group index]}} - (in_meta [index + (meta#in [index (list#each (function (_ slot) [module slot]) group) @@ -3033,18 +3033,18 @@ {#Some {#Type [exported? {#Named _ _type} {#Right slots}]}} (case (interface_methods _type) {#Some members} - (in_meta {#Some [(list#each (function (_ slot) [module slot]) + (meta#in {#Some [(list#each (function (_ slot) [module slot]) {#Item slots}) members]}) _ - (in_meta {#None})) + (meta#in {#None})) _ (record_slots unnamed))) _ - (in_meta {#None}))) + (meta#in {#None}))) (def: expected_type (Meta Type) @@ -3114,7 +3114,7 @@ tags (: (Meta (List Symbol)) (case tags+type {#Some [tags _]} - (in_meta tags) + (meta#in tags) _ (failure ($_ text#composite @@ -3182,7 +3182,7 @@ _ (` ((~ (local_symbol$ name)) (~+ args))))] - (in_meta (list (` (..def: (~ export_policy) (~ usage) + (meta#in (list (` (..def: (~ export_policy) (~ usage) (~ type) (..implementation (~+ definitions))))))) @@ -3230,7 +3230,7 @@ (macro: .public (Variant tokens) (case (everyP caseP tokens) {#Some cases} - (in_meta (list (` (..Union (~+ (list#each product#right cases)))) + (meta#in (list (` (..Union (~+ (list#each product#right cases)))) (variant$ (list#each (function (_ case) (text$ (product#left case))) cases)))) @@ -3252,7 +3252,7 @@ (^ (list [_ {#Tuple record}])) (case (everyP slotP record) {#Some slots} - (in_meta (list (` (..Tuple (~+ (list#each product#right slots)))) + (meta#in (list (` (..Tuple (~+ (list#each product#right slots)))) (tuple$ (list#each (function (_ slot) (text$ (product#left slot))) slots)))) @@ -3291,7 +3291,7 @@ (^ (list type [_ {#Variant tags}])) (case (everyP textP tags) {#Some tags} - (in_meta [type {#Some {#Left tags}}]) + (meta#in [type {#Some {#Left tags}}]) {#None} (failure "Improper type-definition syntax")) @@ -3299,19 +3299,19 @@ (^ (list type [_ {#Tuple slots}])) (case (everyP textP slots) {#Some slots} - (in_meta [type {#Some {#Right slots}}]) + (meta#in [type {#Some {#Right slots}}]) {#None} (failure "Improper type-definition syntax")) (^ (list type)) - (in_meta [it {#None}]) + (meta#in [it {#None}]) _ (failure "Improper type-definition syntax"))) type - (in_meta [type {#None}])} + (meta#in [type {#None}])} it)) (macro: .public (type: tokens) @@ -3335,7 +3335,7 @@ (let [typeC (` {.#Named [(~ (text$ module_name)) (~ (text$ name))] (.type (~ type''))})] - (in_meta (list (case labels?? + (meta#in (list (case labels?? {#Some labels} (` ("lux def type tagged" (~ type_name) (~ typeC) @@ -3399,7 +3399,7 @@ (function (_ def) (case def [_ {#Symbol ["" name]}] - (in_meta name) + (meta#in name) _ (failure "only/+ and exclude/- require symbols.")))) @@ -3422,20 +3422,20 @@ (^or (^ (list& [_ {#Text "*"}] tokens')) (^ (list& [_ {#Text "all"}] tokens'))) - (in_meta [{#All} tokens']) + (meta#in [{#All} tokens']) (^or (^ (list& [_ {#Text "_"}] tokens')) (^ (list& [_ {#Text "ignore"}] tokens'))) - (in_meta [{#Ignore} tokens']) + (meta#in [{#Ignore} tokens']) _ - (in_meta [{#Nothing} tokens]))) + (meta#in [{#Nothing} tokens]))) (def: (openings_parser parts) (-> (List Code) (Meta [(List Openings) (List Code)])) (case parts {#End} - (in_meta [{#End} {#End}]) + (meta#in [{#End} {#End}]) (^ (list& [_ {#Form (list& [_ {#Text prefix}] structs)}] parts')) (do meta_monad @@ -3443,18 +3443,18 @@ (function (_ struct) (case struct [_ {#Symbol ["" struct_name]}] - (in_meta struct_name) + (meta#in struct_name) _ (failure "Expected all implementations of opening form to be symbols."))) structs) next+remainder (openings_parser parts')] (let [[next remainder] next+remainder] - (in_meta [{#Item [prefix structs'] next} + (meta#in [{#Item [prefix structs'] next} remainder]))) _ - (in_meta [{#End} parts]))) + (meta#in [{#End} parts]))) (def: (text#split_at' at x) (-> Nat Text [Text Text]) @@ -3546,7 +3546,7 @@ (-> Bit Text Text (Meta Text)) (case (relative_ups 0 module) 0 - (in_meta (if nested? + (meta#in (if nested? ($_ "lux text concat" relative_root ..module_separator module) module)) @@ -3563,7 +3563,7 @@ output (case ("lux text size" clean) 0 prefix _ ($_ text#composite prefix ..module_separator clean))] - (in_meta output)) + (meta#in output)) (failure ($_ "lux text concat" "Cannot climb the module hierarchy..." \n "Importing module: " module \n @@ -3939,10 +3939,10 @@ (^ (list& else branches')) (case (pairs branches') {#Some branches'} - (in_meta (list (list#mix (: (-> [Code Code] Code Code) + (meta#in (list (list#mix (: (-> [Code Code] Code Code) (function (_ branch else) - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) + (let [[then ?] branch] + (` (if (~ ?) (~ then) (~ else)))))) else branches'))) @@ -3987,13 +3987,13 @@ g!_))))) list#conjoint tuple$)] - (in_meta (list (` ({(~ pattern) (~ g!output)} (~ record)))))) + (meta#in (list (` ({(~ pattern) (~ g!output)} (~ record)))))) _ (failure "value@ can only use records."))) (^ (list [_ {#Tuple slots}] record)) - (in_meta (list (list#mix (: (-> Code Code Code) + (meta#in (list (list#mix (: (-> Code Code Code) (function (_ slot inner) (` (..value@ (~ slot) (~ inner))))) record @@ -4030,10 +4030,10 @@ (function (_ [sub_tag_index sname stype]) (open_declaration alias tags' sub_tag_index sname source+ stype))) (enumeration (zipped/2 tags' members')))] - (in_meta (list#conjoint decls'))) + (meta#in (list#conjoint decls'))) _ - (in_meta (list (` ("lux def" (~ (local_symbol$ (..module_alias (list short) alias))) + (meta#in (list (` ("lux def" (~ (local_symbol$ (..module_alias (list short) alias))) (~ source+) #0))))))) @@ -4053,7 +4053,7 @@ (function (_ [tag_index sname stype]) (open_declaration alias tags tag_index sname source stype))) (enumeration (zipped/2 tags members)))] - (in_meta (list#conjoint decls'))) + (meta#in (list#conjoint decls'))) _ (failure (text#composite "Can only 'open:' structs: " (type#encoded struct_type))))) @@ -4061,7 +4061,7 @@ _ (do meta_monad [g!struct (..generated_symbol "struct")] - (in_meta (list (` ("lux def" (~ g!struct) (~ struct) #0)) + (meta#in (list (` ("lux def" (~ g!struct) (~ struct) #0)) (` (..open: (~ (text$ alias)) (~ g!struct))))))) _ @@ -4071,13 +4071,13 @@ (do meta_monad [g!_ (..generated_symbol "_") g!arg (..generated_symbol "arg")] - (in_meta (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens)))))))) + (meta#in (list (` (function ((~ g!_) (~ g!arg)) (|> (~ g!arg) (~+ tokens)))))))) (macro: .public (<<| tokens) (do meta_monad [g!_ (..generated_symbol "_") g!arg (..generated_symbol "arg")] - (in_meta (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg)))))))) + (meta#in (list (` (function ((~ g!_) (~ g!arg)) (<| (~+ tokens) (~ g!arg)))))))) (def: (imported_by? import_name module_name) (-> Text Text (Meta Bit)) @@ -4116,7 +4116,7 @@ (: (-> Text (Meta Any)) (function (_ _def) (if (is_member? all_defs _def) - (in_meta []) + (meta#in []) (failure ($_ text#composite _def " is not defined in module " module_name " @ " current_module))))) referred_defs)))] defs' (case r_defs @@ -4193,11 +4193,11 @@ (macro: .public (# tokens) (case tokens (^ (list struct [_ {#Symbol member}])) - (in_meta (list (` (let [(^open (~ (text$ (alias_stand_in 0)))) (~ struct)] + (meta#in (list (` (let [(^open (~ (text$ (alias_stand_in 0)))) (~ struct)] (~ (symbol$ member)))))) (^ (list& struct member args)) - (in_meta (list (` ((..# (~ struct) (~ member)) (~+ args))))) + (meta#in (list (` ((..# (~ struct) (~ member)) (~+ args))))) _ (failure "Wrong syntax for #"))) @@ -4217,7 +4217,7 @@ (function (_ [r_slot_name [r_idx r_type]]) (do meta_monad [g!slot (..generated_symbol "")] - (in_meta [r_slot_name r_idx g!slot])))) + (meta#in [r_slot_name r_idx g!slot])))) (zipped/2 tags (enumeration members)))] (let [pattern (|> pattern' (list#each (: (-> [Symbol Nat Code] (List Code)) @@ -4235,7 +4235,7 @@ r_var))))) list#conjoint tuple$)] - (in_meta (list (` ({(~ pattern) (~ output)} (~ record))))))) + (meta#in (list (` ({(~ pattern) (~ output)} (~ record))))))) _ (failure "with@ can only use records."))) @@ -4300,7 +4300,7 @@ (function (_ [r_slot_name [r_idx r_type]]) (do meta_monad [g!slot (..generated_symbol "")] - (in_meta [r_slot_name r_idx g!slot])))) + (meta#in [r_slot_name r_idx g!slot])))) (zipped/2 tags (enumeration members)))] (let [pattern (|> pattern' (list#each (: (-> [Symbol Nat Code] (List Code)) @@ -4318,7 +4318,7 @@ r_var))))) list#conjoint tuple$)] - (in_meta (list (` ({(~ pattern) (~ output)} (~ record))))))) + (meta#in (list (` ({(~ pattern) (~ output)} (~ record))))))) _ (failure "revised@ can only use records."))) @@ -4375,7 +4375,7 @@ in)) {#None})))) {#Some output} - (in_meta (list#composite output branches)) + (meta#in (list#composite output branches)) {#None} (failure "Wrong syntax for ^template")) @@ -4459,11 +4459,11 @@ (do meta_monad [inits' (: (Meta (List Symbol)) (case (monad#each maybe_monad symbol_name inits) - {#Some inits'} (in_meta inits') + {#Some inits'} (meta#in inits') {#None} (failure "Wrong syntax for loop"))) init_types (monad#each meta_monad type_definition inits') expected ..expected_type] - (in_meta (list (` (("lux type check" + (meta#in (list (` (("lux type check" (-> (~+ (list#each type_code init_types)) (~ (type_code expected))) (function ((~ name) (~+ vars)) @@ -4474,7 +4474,7 @@ (: (-> Code (Meta Code)) (function (_ _) (..generated_symbol ""))) inits)] - (in_meta (list (` (let [(~+ (..interleaved aliases inits))] + (meta#in (list (` (let [(~+ (..interleaved aliases inits))] (.loop (~ name) [(~+ (..interleaved vars aliases))] (~ body))))))))) @@ -4594,7 +4594,7 @@ [#Tuple]) _ - (in_meta token) + (meta#in token) ... TODO: Figure out why this doesn't work: ... (# meta_monad in token) )) @@ -4616,10 +4616,10 @@ (-> Code (Meta [Code Code])) (case level (^ [_ {#Tuple (list expr binding)}]) - (in_meta [expr binding]) + (meta#in [expr binding]) _ - (in_meta [level (` #1)]) + (meta#in [level (` #1)]) )) (def: (multi_level_case^ levels) @@ -4696,7 +4696,7 @@ (macro: .public (symbol tokens) (case tokens (^ (list [_ {#Symbol [module name]}])) - (in_meta (list (` [(~ (text$ module)) (~ (text$ name))]))) + (meta#in (list (` [(~ (text$ module)) (~ (text$ name))]))) _ (failure (..wrong_syntax_error [..prelude_module "symbol"])))) @@ -4710,7 +4710,7 @@ (case tokens (^ (list& [_meta {#Form (list [_ {#Symbol ["" name]}] pattern)}] body branches)) (let [g!whole (local_symbol$ name)] - (in_meta (list& g!whole + (meta#in (list& g!whole (` (case (~ g!whole) (~ pattern) (~ body))) branches))) @@ -4721,7 +4721,7 @@ (case tokens (^ (list& [_meta {#Form (list [_ {#Symbol ["" name]}] [_ {#Tuple steps}])}] body branches)) (let [g!name (local_symbol$ name)] - (in_meta (list& g!name + (meta#in (list& g!name (` (let [(~ g!name) (|> (~ g!name) (~+ steps))] (~ body))) branches))) @@ -4833,7 +4833,7 @@ (-> Code (Meta Text)) (case choice [_ {#Text platform}] - (..in_meta platform) + (..meta#in platform) [_ {#Symbol symbol}] (do meta_monad @@ -4864,13 +4864,13 @@ (failure ($_ text#composite "No code for target platform: " target)) {#Some default} - (in_meta (list default))) + (meta#in (list default))) {#Item [key pick] options'} (do meta_monad [platform (..platform_name key)] (if (text#= target platform) - (in_meta (list pick)) + (meta#in (list pick)) (target_pick target options' default))))) (macro: .public (for tokens) @@ -4966,7 +4966,7 @@ [#Tuple]) _ - (in_meta [(list) code]))) + (meta#in [(list) code]))) (macro: .public (`` tokens) (case tokens @@ -5033,7 +5033,7 @@ [.#Symbol name$]) [_ {#Form {#Item [[_ {#Symbol ["" "~"]}] {#Item [unquoted {#End}]}]}}] - (in_meta unquoted) + (meta#in unquoted) [_ {#Form {#Item [[_ {#Symbol ["" "~+"]}] {#Item [spliced {#End}]}]}}] (failure "Cannot use (~+) inside of ^code unless it is the last element in a form or a tuple.") @@ -5074,7 +5074,7 @@ (^ (list [_ {#Tuple bindings}] bodyT)) (case (..pairs bindings) {#Some bindings} - (in_meta (list (` (..with_expansions [(~+ (|> bindings + (meta#in (list (` (..with_expansions [(~+ (|> bindings (list#each (function (_ [localT valueT]) (list localT (` (..as_is (~ valueT)))))) (list#mix list#composite (list))))] diff --git a/stdlib/source/library/lux/data/binary.lux b/stdlib/source/library/lux/data/binary.lux index 479c7d7a1..8df174ce5 100644 --- a/stdlib/source/library/lux/data/binary.lux +++ b/stdlib/source/library/lux/data/binary.lux @@ -78,9 +78,9 @@ (def: (= reference sample) (/.= reference sample))) -(exception: .public (cannot_copy_bytes [bytes Nat - source_input Nat - target_output Nat]) +(exception: .public (cannot_copy [bytes Nat + source_input Nat + target_output Nat]) (exception.report ["Bytes" (%.nat bytes)] ["Source input space" (%.nat source_input)] @@ -88,10 +88,11 @@ (def: .public (copy bytes source_offset source target_offset target) (-> Nat Nat Binary Nat Binary (Try Binary)) - (let [source_input (n.- source_offset (/.size source))] - (if (n.< bytes source_input) - (let [target_output (n.- target_offset (/.size target))] - (exception.except ..cannot_copy_bytes [bytes source_input target_output])) + (let [source_input (n.- source_offset (/.size source)) + target_output (n.- target_offset (/.size target))] + (if (or (n.< bytes source_input) + (n.< bytes target_output)) + (exception.except ..cannot_copy [bytes source_input target_output]) {try.#Success (/.copy! bytes source_offset source target_offset target)}))) (exception: .public (slice_out_of_bounds [size Nat @@ -115,11 +116,11 @@ (cond (n.= 0 bytes) binary - (n.< bytes (/.size binary)) - (/.empty 0) + (n.< (/.size binary) bytes) + (/.slice bytes (n.- bytes (/.size binary)) binary) ... else - (/.slice bytes (n.- bytes (/.size binary)) binary))) + (/.empty 0))) (implementation: .public monoid (Monoid Binary) diff --git a/stdlib/source/library/lux/math/number/frac.lux b/stdlib/source/library/lux/math/number/frac.lux index bf73a6491..ac528ad6d 100644 --- a/stdlib/source/library/lux/math/number/frac.lux +++ b/stdlib/source/library/lux/math/number/frac.lux @@ -1,26 +1,26 @@ (.using - [library - [lux {"-" nat int rev} - ["@" target] - [abstract - [hash {"+" Hash}] - [monoid {"+" Monoid}] - [equivalence {"+" Equivalence}] - [codec {"+" Codec}] - [predicate {"+" Predicate}] - [order {"+" Order}] - [monad {"+" do}]] - [control - ["[0]" maybe] - ["[0]" try {"+" Try}]] - [data - ["[0]" text]]]] - ["[0]" // "_" - ["[1][0]" i64] - ["[1][0]" nat] - ["[1][0]" int] - ["[1][0]" rev] - ["/[1]" //]]) + [library + [lux {"-" nat int rev} + ["@" target] + [abstract + [hash {"+" Hash}] + [monoid {"+" Monoid}] + [equivalence {"+" Equivalence}] + [codec {"+" Codec}] + [predicate {"+" Predicate}] + [order {"+" Order}] + [monad {"+" do}]] + [control + ["[0]" maybe] + ["[0]" try {"+" Try}]] + [data + ["[0]" text]]]] + ["[0]" // "_" + ["[1][0]" i64] + ["[1][0]" nat] + ["[1][0]" int] + ["[1][0]" rev] + ["/[1]" //]]) (def: .public (= reference sample) (-> Frac Frac Bit) @@ -126,10 +126,36 @@ "lux f64 i64" ("lux i64 left-shift" ..exponent_size))) +(template [<name> <numerator>] + [(def: .public <name> + Frac + (../ +0.0 <numerator>))] + + [not_a_number +0.0] + [positive_infinity +1.0] + ) + +(def: .public negative_infinity + Frac + (..* -1.0 ..positive_infinity)) + +(def: .public (not_a_number? it) + (-> Frac Bit) + (not (..= it it))) + +(def: .public (number? it) + (-> Frac Bit) + (not (or (..not_a_number? it) + (..= ..positive_infinity it) + (..= ..negative_infinity it)))) + (implementation: .public equivalence (Equivalence Frac) - (def: = ..=)) + (def: (= left right) + (or (..= left right) + (and (..not_a_number? left) + (..not_a_number? right))))) (implementation: .public order (Order Frac) @@ -163,29 +189,6 @@ [maximum ..max (..* -1.0 ..biggest)] ) -(template [<name> <numerator>] - [(def: .public <name> - Frac - (../ +0.0 <numerator>))] - - [not_a_number +0.0] - [positive_infinity +1.0] - ) - -(def: .public negative_infinity - Frac - (..* -1.0 ..positive_infinity)) - -(def: .public (not_a_number? it) - (-> Frac Bit) - (not (..= it it))) - -(def: .public (number? it) - (-> Frac Bit) - (not (or (..not_a_number? it) - (..= ..positive_infinity it) - (..= ..negative_infinity it)))) - (implementation: .public decimal (Codec Text Frac) diff --git a/stdlib/source/library/lux/target/jvm/loader.lux b/stdlib/source/library/lux/target/jvm/loader.lux index 9e391c554..99a4573bc 100644 --- a/stdlib/source/library/lux/target/jvm/loader.lux +++ b/stdlib/source/library/lux/target/jvm/loader.lux @@ -1,23 +1,23 @@ (.using - [library - [lux "*" - ["@" target] - ["[0]" ffi {"+" import: object do_to}] - [abstract - [monad {"+" do}]] - [control - ["[0]" try {"+" Try}] - ["[0]" exception {"+" exception:}] - ["[0]" io {"+" IO}] - [concurrency - ["[0]" atom {"+" Atom}]]] - [data - ["[0]" binary {"+" Binary}] - ["[0]" text - ["%" format {"+" format}]] - [collection - ["[0]" array] - ["[0]" dictionary {"+" Dictionary}]]]]]) + [library + [lux "*" + ["@" target] + ["[0]" ffi {"+" import: object do_to}] + [abstract + [monad {"+" do}]] + [control + ["[0]" try {"+" Try}] + ["[0]" exception {"+" exception:}] + ["[0]" io {"+" IO}] + [concurrency + ["[0]" atom {"+" Atom}]]] + [data + ["[0]" binary {"+" Binary}] + ["[0]" text + ["%" format {"+" format}]] + [collection + ["[0]" array] + ["[0]" dictionary {"+" Dictionary}]]]]]) (type: .public Library (Atom (Dictionary Text Binary))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux index 65b191979..5ac2fda49 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux @@ -8,7 +8,7 @@ [control ["[0]" function] ["[0]" maybe] - ["[0]" try] + ["[0]" try {"+" Try}] ["[0]" exception {"+" Exception}] [parser ["<[0]>" code]]] @@ -280,7 +280,7 @@ failure failure))))) -(def: (locate_error location error) +(def: (located location error) (-> Location Text Text) (%.format (%.location location) text.new_line error)) @@ -288,7 +288,17 @@ (def: .public (failure error) (-> Text Operation) (function (_ [bundle state]) - {try.#Failure (locate_error (value@ .#location state) error)})) + {try.#Failure (located (value@ .#location state) error)})) + +(def: .public (of_try it) + (All (_ a) (-> (Try a) (Operation a))) + (function (_ [bundle state]) + (.case it + {try.#Failure error} + {try.#Failure (located (value@ .#location state) error)} + + {try.#Success it} + {try.#Success [[bundle state] it]}))) (def: .public (except exception parameters) (All (_ e) (-> (Exception e) e Operation)) @@ -307,7 +317,7 @@ (action bundle,state)) {try.#Failure error} (let [[bundle state] bundle,state] - {try.#Failure (locate_error (value@ .#location state) error)}) + {try.#Failure (located (value@ .#location state) error)}) success success))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/coverage.lux index 7ec92c76b..71bc09f77 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/coverage.lux @@ -1,46 +1,33 @@ (.using [library - [lux "*" + [lux {"-" Variant} [abstract equivalence ["[0]" monad {"+" do}]] [control - ["[0]" maybe] - ["[0]" try {"+" Try} ("[1]#[0]" monad)] + ["[0]" maybe ("[1]#[0]" monoid monad)] + ["[0]" try {"+" Try}] ["[0]" exception {"+" exception:}]] [data ["[0]" bit ("[1]#[0]" equivalence)] ["[0]" text - ["%" format {"+" Format format}]] + ["%" format]] [collection ["[0]" list ("[1]#[0]" functor mix)] ["[0]" dictionary {"+" Dictionary}] - ["[0]" set {"+" Set}]]] + ["[0]" set {"+" Set} ("[1]#[0]" equivalence)]]] + [macro + ["[0]" template]] [math [number - ["n" nat] + ["n" nat ("[1]#[0]" interval)] ["i" int] ["r" rev] ["f" frac]]]]] - ["[0]" //// "_" - [// - ["/" analysis {"+" Operation} - ["[1][0]" simple] - ["[1][0]" complex] - ["[1][0]" pattern {"+" Pattern}]] - [/// - ["[1]" phase ("[1]#[0]" monad)]]]]) - -(exception: .public invalid_tuple_pattern - "Tuple size must be >= 2") - -(def: cases - (-> (Maybe Nat) Nat) - (|>> (maybe.else 0))) - -(def: known_cases? - (-> Nat Bit) - (n.> 0)) + ["[0]" // "_" + ["[1][0]" simple] + ["[1][0]" complex] + ["[1][0]" pattern {"+" Pattern}]]) ... The coverage of a pattern-matching expression summarizes how well ... all the possible values of an input are being covered by the @@ -51,36 +38,92 @@ ... Every other coverage is considered partial, and it would be valued ... as insuficient (since it could lead to runtime errors due to values ... not being handled by any pattern). -(type: .public Coverage - (Rec Coverage - (Variant - {#Bit Bit} - {#Nat (Set Nat)} - {#Int (Set Int)} - {#Rev (Set Rev)} - {#Frac (Set Frac)} - {#Text (Set Text)} - {#Variant (Maybe Nat) (Dictionary Nat Coverage)} - {#Seq Coverage Coverage} - {#Alt Coverage Coverage} - {#Exhaustive}))) - -(def: .public (exhaustive? coverage) - (-> Coverage Bit) +(template.let [(Variant' @) + [[(Maybe Nat) (Dictionary Nat @)]]] + (as_is (type: .public Coverage + (Rec @ + (.Variant + {#Exhaustive} + {#Bit Bit} + {#Nat (Set Nat)} + {#Int (Set Int)} + {#Rev (Set Rev)} + {#Frac (Set Frac)} + {#Text (Set Text)} + {#Variant (Variant' @)} + {#Seq @ @} + {#Alt @ @}))) + + (type: .public Variant + (Variant' Coverage)))) + +(def: .public (minimum [max cases]) + (-> Variant Nat) + (maybe.else (|> cases + dictionary.keys + (list#mix n.max 0) + ++) + max)) + +(def: .public (maximum [max cases]) + (-> Variant Nat) + (maybe.else n#top max)) + +(def: (alternatives coverage) + (-> Coverage (List Coverage)) (case coverage - {#Exhaustive _} - #1 + {#Alt left right} + (list& left (alternatives right)) _ - #0)) + (list coverage))) -(def: .public (%coverage value) - (Format Coverage) +(implementation: .public equivalence + (Equivalence Coverage) + + (def: (= reference sample) + (case [reference sample] + [{#Exhaustive} {#Exhaustive}] + #1 + + [{#Bit sideR} {#Bit sideS}] + (bit#= sideR sideS) + + (^template [<tag>] + [[{<tag> partialR} {<tag> partialS}] + (set#= partialR partialS)]) + ([#Nat] + [#Int] + [#Rev] + [#Frac] + [#Text]) + + [{#Variant allR casesR} {#Variant allS casesS}] + (and (# (maybe.equivalence n.equivalence) = allR allS) + (# (dictionary.equivalence =) = casesR casesS)) + + [{#Seq leftR rightR} {#Seq leftS rightS}] + (and (= leftR leftS) + (= rightR rightS)) + + [{#Alt _} {#Alt _}] + (let [flatR (alternatives reference) + flatS (alternatives sample)] + (and (n.= (list.size flatR) (list.size flatS)) + (list.every? (function (_ [coverageR coverageS]) + (= coverageR coverageS)) + (list.zipped/2 flatR flatS)))) + + _ + #0))) + +(open: "/#[0]" ..equivalence) + +(def: .public (format value) + (%.Format Coverage) (case value - {#Bit value'} - (|> value' - %.bit - (text.enclosed ["{#Bit " "}"])) + {#Bit it} + (%.bit it) (^template [<tag> <format>] [{<tag> it} @@ -88,7 +131,7 @@ set.list (list#each <format>) (text.interposed " ") - (text.enclosed [(format "{" (%.symbol (symbol <tag>)) " ") "}"]))]) + (text.enclosed ["[" "]"]))]) ([#Nat %.nat] [#Int %.int] [#Rev %.rev] @@ -98,60 +141,64 @@ {#Variant ?max_cases cases} (|> cases dictionary.entries - (list#each (function (_ [idx coverage]) - (format (%.nat idx) " " (%coverage coverage)))) + (list#each (function (_ [tag it]) + (%.format (%.nat tag) " " (format it)))) (text.interposed " ") - (text.enclosed ["{" "}"]) - (format (%.nat (..cases ?max_cases)) " ") - (text.enclosed ["{#Variant " "}"])) + (%.format (maybe.else "?" (maybe#each %.nat ?max_cases)) " ") + (text.enclosed ["{" "}"])) {#Seq left right} - (format "{#Seq " (%coverage left) " " (%coverage right) "}") + (%.format "(& " (format left) " " (format right) ")") {#Alt left right} - (format "{#Alt " (%coverage left) " " (%coverage right) "}") + (%.format "(| " (format left) " " (format right) ")") {#Exhaustive} - "#Exhaustive")) + "*")) -(def: .public (determine pattern) - (-> Pattern (Operation Coverage)) +(exception: .public (invalid_tuple [size Nat]) + (exception.report + ["Expected size" ">= 2"] + ["Actual size" (%.nat size)])) + +(def: .public (coverage pattern) + (-> Pattern (Try Coverage)) (case pattern - (^or {/pattern.#Simple {/simple.#Unit}} - {/pattern.#Bind _}) - (////#in {#Exhaustive}) + (^or {//pattern.#Simple {//simple.#Unit}} + {//pattern.#Bind _}) + {try.#Success {#Exhaustive}} - ... Simple patterns always have partial coverage because there + ... Simple patterns (other than unit/[]) always have partial coverage because there ... are too many possibilities as far as values go. (^template [<from> <to> <hash>] - [{/pattern.#Simple {<from> it}} - (////#in {<to> (set.of_list <hash> (list it))})]) - ([/simple.#Nat #Nat n.hash] - [/simple.#Int #Int i.hash] - [/simple.#Rev #Rev r.hash] - [/simple.#Frac #Frac f.hash] - [/simple.#Text #Text text.hash]) + [{//pattern.#Simple {<from> it}} + {try.#Success {<to> (set.of_list <hash> (list it))}}]) + ([//simple.#Nat #Nat n.hash] + [//simple.#Int #Int i.hash] + [//simple.#Rev #Rev r.hash] + [//simple.#Frac #Frac f.hash] + [//simple.#Text #Text text.hash]) ... Bits are the exception, since there is only "#1" and ... "#0", which means it is possible for bit ... pattern-matching to become exhaustive if complementary parts meet. - {/pattern.#Simple {/simple.#Bit value}} - (////#in {#Bit value}) + {//pattern.#Simple {//simple.#Bit value}} + {try.#Success {#Bit value}} ... Tuple patterns can be exhaustive if there is exhaustiveness for all of ... their sub-patterns. - {/pattern.#Complex {/complex.#Tuple membersP+}} + {//pattern.#Complex {//complex.#Tuple membersP+}} (case (list.reversed membersP+) - (^or {.#End} {.#Item _ {.#End}}) - (/.except ..invalid_tuple_pattern []) + (^or (^ (list)) (^ (list _))) + (exception.except ..invalid_tuple [(list.size membersP+)]) {.#Item lastP prevsP+} - (do ////.monad - [lastC (determine lastP)] - (monad.mix ////.monad + (do [! try.monad] + [lastC (coverage lastP)] + (monad.mix ! (function (_ leftP rightC) - (do ////.monad - [leftC (determine leftP)] + (do ! + [leftC (coverage leftP)] (case rightC {#Exhaustive} (in leftC) @@ -162,14 +209,14 @@ ... Variant patterns can be shown to be exhaustive if all the possible ... cases are handled exhaustively. - {/pattern.#Complex {/complex.#Variant [lefts right? value]}} - (do ////.monad - [value_coverage (determine value) + {//pattern.#Complex {//complex.#Variant [lefts right? value]}} + (do try.monad + [value_coverage (coverage value) .let [idx (if right? (++ lefts) lefts)]] (in {#Variant (if right? - {.#Some idx} + {.#Some (++ idx)} {.#None}) (|> (dictionary.empty n.hash) (dictionary.has idx value_coverage))})))) @@ -185,102 +232,70 @@ ... always be a pattern prior to them that would match the input. ... Because of that, the presence of redundant patterns is assumed to ... be a bug, likely due to programmer carelessness. -(exception: .public (redundant_pattern [so_far Coverage - addition Coverage]) +(exception: .public (redundancy [so_far Coverage + addition Coverage]) (exception.report - ["Coverage so-far" (%coverage so_far)] - ["Coverage addition" (%coverage addition)])) + ["Coverage so-far" (format so_far)] + ["Additional coverage" (format addition)])) -(def: (flat_alt coverage) - (-> Coverage (List Coverage)) +(exception: .public (variant_mismatch [expected Nat + mismatched Nat]) + (exception.report + ["Expected cases" (%.nat expected)] + ["Mismatched cases" (%.nat mismatched)])) + +(def: .public (exhaustive? coverage) + (-> Coverage Bit) (case coverage - {#Alt left right} - (list& left (flat_alt right)) + {#Exhaustive} + #1 _ - (list coverage))) - -(implementation: equivalence - (Equivalence Coverage) - - (def: (= reference sample) - (case [reference sample] - [{#Exhaustive} {#Exhaustive}] - #1 - - [{#Bit sideR} {#Bit sideS}] - (bit#= sideR sideS) - - (^template [<tag>] - [[{<tag> partialR} {<tag> partialS}] - (# set.equivalence = partialR partialS)]) - ([#Nat] - [#Int] - [#Rev] - [#Frac] - [#Text]) - - [{#Variant allR casesR} {#Variant allS casesS}] - (and (n.= (cases allR) - (cases allS)) - (# (dictionary.equivalence =) = casesR casesS)) - - [{#Seq leftR rightR} {#Seq leftS rightS}] - (and (= leftR leftS) - (= rightR rightS)) - - [{#Alt _} {#Alt _}] - (let [flatR (flat_alt reference) - flatS (flat_alt sample)] - (and (n.= (list.size flatR) (list.size flatS)) - (list.every? (function (_ [coverageR coverageS]) - (= coverageR coverageS)) - (list.zipped/2 flatR flatS)))) - - _ - #0))) - -(open: "coverage#[0]" ..equivalence) - -(exception: .public (variants_do_not_match [addition_cases Nat - so_far_cases Nat]) - (exception.report - ["So-far Cases" (%.nat so_far_cases)] - ["Addition Cases" (%.nat addition_cases)])) + #0)) ... After determining the coverage of each individual pattern, it is ... necessary to merge them all to figure out if the entire ... pattern-matching expression is exhaustive and whether it contains ... redundant patterns. -(def: .public (merged addition so_far) +(def: .public (composite addition so_far) (-> Coverage Coverage (Try Coverage)) - (with_expansions [<redundancy> (exception.except ..redundant_pattern [so_far addition])] + (with_expansions [<redundancy> (exception.except ..redundancy [so_far addition]) + <alternatively> {try.#Success {#Alt addition so_far}} + <otherwise> (if (/#= so_far addition) + ... The addition cannot possibly improve the coverage. + <redundancy> + ... There are now 2 alternative paths. + <alternatively>)] (case [addition so_far] ... 2 bit coverages are exhaustive if they complement one another. [{#Bit sideA} {#Bit sideSF}] (if (xor sideA sideSF) - (try#in {#Exhaustive}) + {try.#Success {#Exhaustive}} <redundancy>) (^template [<tag>] [[{<tag> partialA} {<tag> partialSF}] - (let [common (set.intersection partialA partialSF)] - (if (set.empty? common) - (try#in {<tag> (set.union partialA partialSF)}) - <redundancy>))]) + (if (set.empty? (set.intersection partialA partialSF)) + {try.#Success {<tag> (set.union partialA partialSF)}} + <redundancy>)]) ([#Nat] [#Int] [#Rev] [#Frac] [#Text]) - [{#Variant allA casesA} {#Variant allSF casesSF}] - (let [addition_cases (cases allSF) - so_far_cases (cases allA)] - (cond (and (known_cases? addition_cases) - (known_cases? so_far_cases) - (not (n.= addition_cases so_far_cases))) - (exception.except ..variants_do_not_match [addition_cases so_far_cases]) + [{#Variant addition'} {#Variant so_far'}] + (let [[allA casesA] addition' + [allSF casesSF] so_far' + addition_cases (..maximum addition') + so_far_cases (..maximum so_far')] + (cond (template.let [(known_cases? it) + [(n.< n#top it)]] + (and (known_cases? so_far_cases) + (if (known_cases? addition_cases) + (not (n.= so_far_cases addition_cases)) + (n.> so_far_cases (..minimum addition'))))) + (exception.except ..variant_mismatch [so_far_cases addition_cases]) (# (dictionary.equivalence ..equivalence) = casesSF casesA) <redundancy> @@ -292,48 +307,41 @@ (case (dictionary.value tagA casesSF') {.#Some coverageSF} (do ! - [coverageM (merged coverageA coverageSF)] + [coverageM (composite coverageA coverageSF)] (in (dictionary.has tagA coverageM casesSF'))) {.#None} (in (dictionary.has tagA coverageA casesSF')))) - casesSF (dictionary.entries casesA))] - (in (if (and (or (known_cases? addition_cases) - (known_cases? so_far_cases)) - (n.= (++ (n.max addition_cases so_far_cases)) + casesSF + (dictionary.entries casesA))] + (in (if (and (n.= (n.min addition_cases so_far_cases) (dictionary.size casesM)) - (list.every? exhaustive? (dictionary.values casesM))) + (list.every? ..exhaustive? (dictionary.values casesM))) {#Exhaustive} - {#Variant (case allSF - {.#Some _} - allSF - - _ - allA) - casesM}))))) + {#Variant (maybe#composite allA allSF) casesM}))))) [{#Seq leftA rightA} {#Seq leftSF rightSF}] - (case [(coverage#= leftSF leftA) (coverage#= rightSF rightA)] + (case [(/#= leftSF leftA) (/#= rightSF rightA)] ... Same prefix [#1 #0] (do try.monad - [rightM (merged rightA rightSF)] - (if (exhaustive? rightM) - ... If all that follows is exhaustive, then it can be safely dropped - ... (since only the "left" part would influence whether the - ... merged coverage is exhaustive or not). - (in leftSF) - (in {#Seq leftSF rightM}))) + [rightM (composite rightA rightSF)] + (in (if (..exhaustive? rightM) + ... If all that follows is exhaustive, then it can be safely dropped + ... (since only the "left" part would influence whether the + ... composite coverage is exhaustive or not). + leftSF + {#Seq leftSF rightM}))) ... Same suffix [#0 #1] (do try.monad - [leftM (merged leftA leftSF)] + [leftM (composite leftA leftSF)] (in {#Seq leftM rightA})) ... The 2 sequences cannot possibly be merged. [#0 #0] - (try#in {#Alt so_far addition}) + <alternatively> ... There is nothing the addition adds to the coverage. [#1 #1] @@ -345,18 +353,8 @@ ... The addition completes the coverage. [{#Exhaustive} _] - (try#in {#Exhaustive}) + {try.#Success {#Exhaustive}} - ... The left part will always match, so the addition is redundant. - (^multi [{#Seq left right} single] - (coverage#= left single)) - <redundancy> - - ... The right part is not necessary, since it can always match the left. - (^multi [single {#Seq left right}] - (coverage#= left single)) - (try#in single) - ... When merging a new coverage against one based on Alt, it may be ... that one of the many coverages in the Alt is complementary to ... the new one, so effort must be made to fuse carefully, to match @@ -378,8 +376,8 @@ (in [{.#None} (list coverageA)]) {.#Item altSF altsSF'} - (case (merged coverageA altSF) - {try.#Success altMSF} + (do ! + [altMSF (composite coverageA altSF)] (case altMSF {#Alt _} (do ! @@ -387,33 +385,36 @@ (in [success {.#Item altSF altsSF+}])) _ - (in [{.#Some altMSF} altsSF'])) - - {try.#Failure error} - {try.#Failure error}) - ))))] - [successA possibilitiesSF] (fuse_once addition (flat_alt so_far))] - (loop [successA successA - possibilitiesSF possibilitiesSF] - (case successA - {.#Some coverageA'} - (do ! - [[successA' possibilitiesSF'] (fuse_once coverageA' possibilitiesSF)] - (again successA' possibilitiesSF')) - - {.#None} - (case (list.reversed possibilitiesSF) - {.#Item last prevs} - (in (list#mix (function (_ left right) {#Alt left right}) - last - prevs)) - - {.#End} - (undefined))))) + (in [{.#Some altMSF} altsSF'])))))))]] + (loop [addition addition + possibilitiesSF (alternatives so_far)] + (do ! + [[addition' possibilitiesSF'] (fuse_once addition possibilitiesSF)] + (case addition' + {.#Some addition'} + (again addition' possibilitiesSF') + + {.#None} + (case (list.reversed possibilitiesSF') + {.#Item last prevs} + (in (list#mix (function (_ left right) {#Alt left right}) + last + prevs)) + + {.#End} + (undefined)))))) - _ - (if (coverage#= so_far addition) - ... The addition cannot possibly improve the coverage. + ... The left part will always match, so the addition is redundant. + [{#Seq left right} single] + (if (/#= left single) <redundancy> - ... There are now 2 alternative paths. - (try#in {#Alt so_far addition}))))) + <otherwise>) + + ... The right part is not necessary, since it can always match the left. + [single {#Seq left right}] + (if (/#= left single) + {try.#Success single} + <otherwise>) + + _ + <otherwise>))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux index d27d54fe7..7b8181b9c 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux @@ -1,18 +1,22 @@ (.using [library [lux "*" + [type {"+" :sharing}] ["[0]" meta] [abstract [monad {"+" do}]] [control - ["[0]" try {"+" Try}]] + ["[0]" maybe] + ["[0]" try] + ["[0]" io] + [concurrency + ["[0]" atom {"+" Atom}]]] [data - [text - ["%" format]]] + [collection + ["[0]" dictionary {"+" Dictionary}]]] [math - [number {"+" hex} - ["n" nat] - ["[0]" i64]]]]] + [number + ["n" nat]]]]] ["[0]" // {"+" Operation} [macro {"+" Expander}] ["[1][0]" type] @@ -28,11 +32,16 @@ [/// ["[0]" phase] [meta - ["[0]" archive {"+" Archive}]]]]]]]) + ["[0]" archive {"+" Archive} + ["[0]" module]]]]]]]]) (type: .public Eval (-> Archive Type Code (Operation Any))) +(def: evals + (Atom (Dictionary module.ID Nat)) + (atom.atom (dictionary.empty n.hash))) + (def: .public (evaluator expander synthesis_state generation_state generate) (All (_ anchor expression artifact) (-> Expander @@ -43,9 +52,7 @@ (let [analyze (analysisP.phase expander)] (function (eval archive type exprC) (do phase.monad - [count (extensionP.lifted - meta.seed) - exprA (<| (//type.expecting type) + [exprA (<| (//type.expecting type) //scope.reset (analyze archive exprC)) module (extensionP.lifted @@ -54,11 +61,18 @@ (do try.monad [exprS (|> exprA (synthesisP.phase archive) (phase.result synthesis_state))]) (phase.result generation_state) - (let [shift (|> count - (i64.left_shifted 32) - (i64.or (hex "FF,FF,FF,FF")))]) (do phase.monad - [exprO (generation.with_registry_shift shift - (generate archive exprS)) - module_id (generation.module_id module archive)] - (generation.evaluate! [module_id count] exprO))))))) + [@module (:sharing [anchor expression artifact] + (generation.Phase anchor expression artifact) + generate + + (generation.Operation anchor expression artifact module.ID) + (generation.module_id module archive)) + .let [[evals _] (io.run! (atom.update! (dictionary.revised' @module 0 ++) ..evals)) + @eval (maybe.else 0 (dictionary.value @module evals))] + exprO (<| (generation.with_registry_shift (|> @module + ("lux i64 left-shift" 16) + ("lux i64 or" @eval) + ("lux i64 left-shift" 32))) + (generate archive exprS))] + (generation.evaluate! [@module @eval] exprO))))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/pattern.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/pattern.lux index 21b6218ba..cfce834d0 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/analysis/pattern.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/pattern.lux @@ -5,7 +5,7 @@ [equivalence {"+" Equivalence}]] [data [text - ["%" format {"+" Format}]]] + ["%" format]]] [math [number ["n" nat]]]]] @@ -41,7 +41,7 @@ false))) (def: .public (format it) - (Format Pattern) + (%.Format Pattern) (case it {#Simple it} (//simple.format it) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux index e1b1a8c07..3e81c08b8 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux @@ -22,7 +22,6 @@ ["[0]" type ["[0]" check]]]] ["[0]" / "_" - ["[1][0]" coverage {"+" Coverage}] ["/[1]" // "_" ["[1][0]" complex] ["/[1]" // "_" @@ -33,7 +32,8 @@ ["[1][0]" complex] ["[1][0]" pattern {"+" Pattern}] ["[1][0]" type] - ["[1][0]" scope]] + ["[1][0]" scope] + ["[1][0]" coverage {"+" Coverage}]] [/// ["[1]" phase]]]]]]) @@ -64,7 +64,7 @@ (list#each (function (_ [slot value]) (list slot value))) list#conjoint)))] - ["Coverage" (/coverage.%coverage coverage)])) + ["Coverage" (/coverage.format coverage)])) (exception: .public (cannot_have_empty_branches [message Text]) message) @@ -337,11 +337,11 @@ (function (_ [patternT bodyT]) (analyse_pattern {.#None} inputT patternT (analyse archive bodyT))) branchesT) - outputHC (|> outputH product.left /coverage.determine) - outputTC (monad.each ! (|>> product.left /coverage.determine) outputT) - _ (.case (monad.mix try.monad /coverage.merged outputHC outputTC) + outputHC (|> outputH product.left /coverage.coverage /.of_try) + outputTC (monad.each ! (|>> product.left /coverage.coverage /.of_try) outputT) + _ (.case (monad.mix try.monad /coverage.composite outputHC outputTC) {try.#Success coverage} - (///.assertion non_exhaustive_pattern_matching [inputC branches coverage] + (///.assertion ..non_exhaustive_pattern_matching [inputC branches coverage] (/coverage.exhaustive? coverage)) {try.#Failure error} diff --git a/stdlib/source/test/lux/data/binary.lux b/stdlib/source/test/lux/data/binary.lux index 0a354092d..c9e821229 100644 --- a/stdlib/source/test/lux/data/binary.lux +++ b/stdlib/source/test/lux/data/binary.lux @@ -19,8 +19,8 @@ [math ["[0]" random {"+" Random}] [number - ["[0]" i64] - ["n" nat]]]]] + ["n" nat] + ["[0]" i64]]]]] [\\library ["[0]" / ["!" \\unsafe]]]) @@ -204,6 +204,7 @@ (_.cover [/.after] (and (# /.equivalence = sample (/.after 0 sample)) (# /.equivalence = (/.empty 0) (/.after size sample)) + (n.= (n.- offset size) (/.size (/.after offset sample))) (case (list.reversed (..as_list sample)) {.#End} false @@ -227,6 +228,15 @@ copy/1 (/.read/8! 1 copy)] (in (and (n.= sample/0 copy/0) (n.= 0 copy/1))))))) + (_.cover [/.cannot_copy] + (and (not (throws? /.cannot_copy + (/.copy size 0 sample 0 (/.empty size)))) + (throws? /.cannot_copy + (/.copy (n.+ offset size) 0 sample 0 (/.empty size))) + (throws? /.cannot_copy + (/.copy size offset sample 0 (/.empty size))) + (throws? /.cannot_copy + (/.copy size 0 sample offset (/.empty size))))) ..test|unsafe )))) diff --git a/stdlib/source/test/lux/math/number/int.lux b/stdlib/source/test/lux/math/number/int.lux index 394c34c15..2c47ee6d1 100644 --- a/stdlib/source/test/lux/math/number/int.lux +++ b/stdlib/source/test/lux/math/number/int.lux @@ -36,15 +36,15 @@ ($enum.spec /.enum random.int)) (_.for [/.interval] ($interval.spec /.interval random.int)) - (~~ (template [<composite> <monoid>] - [(_.for [<monoid> <composite>] + (~~ (template [<monoid>] + [(_.for [<monoid>] ($monoid.spec /.equivalence <monoid> random.int))] - [/.+ /.addition] - [/.* /.multiplication] + [/.addition] + [/.multiplication] - [/.min /.minimum] - [/.max /.maximum] + [/.minimum] + [/.maximum] )) (~~ (template [<codec>] [(_.for [<codec>] @@ -77,24 +77,55 @@ Test (<| (_.covering /._) (_.for [.Int]) + (let [(^open "/#[0]") /.interval]) ($_ _.and (do random.monad - [sample random.int] + [sample random.int + left random.int + right random.int] ($_ _.and + (_.cover [/.+] + (and (/.= (/.+ left right) + (/.+ right left)) + (/.= sample (/.+ +0 sample)))) (_.cover [/.-] (and (/.= +0 (/.- sample sample)) (/.= sample (/.- +0 sample)) (/.= (/.opposite sample) - (/.- sample +0)))) + (/.- sample +0)) + (/.= /#bottom + (/.- /#bottom +0)))) + (_.cover [/.*] + (and (/.= (/.* left right) + (/.* right left)) + (/.= sample (/.* +1 sample)) + (/.= /#bottom + (/.* -1 /#bottom)))) (_.cover [/./] (and (/.= +1 (/./ sample sample)) - (/.= sample (/./ +1 sample)))) + (/.= sample (/./ +1 sample)) + (/.= /#bottom + (/./ -1 /#bottom)))) (_.cover [/.abs] (bit#= (/.> sample (/.abs sample)) (/.negative? sample))) (_.cover [/.signum] (/.= (/.abs sample) (/.* (/.signum sample) sample))) + (_.cover [/.min] + (and (/.= (/.min left right) + (/.min right left)) + (/.= sample + (/.min /#top sample)) + (/.= /#bottom + (/.min /#bottom sample)))) + (_.cover [/.max] + (and (/.= (/.max left right) + (/.max right left)) + (/.= /#top + (/.max /#top sample)) + (/.= sample + (/.max /#bottom sample)))) )) (do random.monad [left random.int diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/test/lux/tool/compiler/language/lux/analysis.lux index 858a294ae..75f0d5d1c 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/analysis.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/analysis.lux @@ -33,6 +33,7 @@ ["[1][0]" scope] ["[1][0]" simple] ["[1][0]" type] + ["[1][0]" coverage] [//// ["[1][0]" reference ["[2][0]" variable]] @@ -474,4 +475,5 @@ /scope.test /simple.test /type.test + /coverage.test )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/coverage.lux b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/coverage.lux new file mode 100644 index 000000000..ab856f9a1 --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/coverage.lux @@ -0,0 +1,453 @@ +(.using + [library + [lux "*" + ["_" test {"+" Test}] + [abstract + ["[0]" monad {"+" do}] + ["[0]" predicate] + [\\specification + ["$[0]" equivalence]]] + [control + [pipe {"+" case>}] + ["[0]" try {"+" Try} ("[1]#[0]" functor)] + ["[0]" exception {"+" Exception}]] + [data + ["[0]" product] + ["[0]" bit ("[1]#[0]" equivalence)] + ["[0]" text ("[1]#[0]" equivalence) + ["%" format]] + [collection + ["[0]" set] + ["[0]" dictionary] + ["[0]" list ("[1]#[0]" functor mix)]]] + [math + ["[0]" random {"+" Random} ("[1]#[0]" monad)] + [number + ["n" nat ("[1]#[0]" interval)] + ["i" int] + ["r" rev] + ["f" frac]]]]] + [\\library + ["[0]" / + ["/[1]" // "_" + ["[1][0]" simple] + ["[1][0]" complex] + ["[1][0]" pattern {"+" Pattern}]]]]) + +(def: spread 16) + +(def: random_tag + (Random Nat) + (random#each (n.% ..spread) random.nat)) + +(def: .public random + (Random /.Coverage) + (<| random.rec + (function (_ again)) + ($_ random.or + (random#in []) + random.bit + (random.set n.hash ..spread random.nat) + (random.set i.hash ..spread random.int) + (random.set r.hash ..spread random.rev) + (random.set f.hash ..spread random.frac) + (random.set text.hash ..spread (random.unicode 1)) + ($_ random.and + (random.maybe (random#in ..spread)) + (do [! random.monad] + [cases ..random_tag + cases (random.set n.hash cases ..random_tag)] + (|> cases + set.list + (monad.each ! (function (_ case) (# ! each (|>> [case]) again))) + (# ! each (dictionary.of_list n.hash)))) + ) + (random.and again again) + (random.and again again) + ))) + +(def: (ranged min range) + (-> Nat Nat (Random Nat)) + (random#each (|>> (n.% (++ range)) (n.+ min)) + random.nat)) + +(def: random_pattern + (Random [/.Coverage Pattern]) + (<| random.rec + (function (_ again)) + (`` ($_ random.either + (random#in [{/.#Exhaustive} + {//pattern.#Simple {//simple.#Unit}}]) + (do random.monad + [it random.bit] + (in [{/.#Bit it} + {//pattern.#Simple {//simple.#Bit it}}])) + (~~ (template [<random> <hash> <coverage> <pattern>] + [(do random.monad + [it <random>] + (in [{<coverage> (set.of_list <hash> (list it))} + {//pattern.#Simple {<pattern> it}}]))] + + [random.nat n.hash /.#Nat //simple.#Nat] + [random.int i.hash /.#Int //simple.#Int] + [random.rev r.hash /.#Rev //simple.#Rev] + [random.frac f.hash /.#Frac //simple.#Frac] + [(random.unicode 1) text.hash /.#Text //simple.#Text] + )) + + (do [! random.monad] + [tag (# ! each ++ ..random_tag) + right? random.bit + .let [lefts (//complex.lefts right? tag)] + [sub_coverage sub_pattern] again] + (in [{/.#Variant (if right? {.#Some tag} {.#None}) + (dictionary.of_list n.hash (list [tag sub_coverage]))} + {//pattern.#Complex + {//complex.#Variant + [//complex.#lefts lefts + //complex.#right? right? + //complex.#value sub_pattern]}}])) + + (do [! random.monad] + [arity (..ranged 2 (n.- 2 ..spread)) + it (random.list arity again) + .let [coverages (list#each product.left it) + patterns (list#each product.right it)]] + (in [(|> coverages + (list.only (|>> /.exhaustive? not)) + list.reversed + (case> {.#End} + {/.#Exhaustive} + + {.#Item last prevs} + (list#mix (function (_ left right) + {/.#Seq left right}) + last + prevs))) + {//pattern.#Complex {//complex.#Tuple patterns}}])) + + (do random.monad + [register random.nat] + (in [{/.#Exhaustive} + {//pattern.#Bind register}])) + )))) + +(def: (failure? exception it) + (All (_ a) (-> (Exception a) (Try /.Coverage) Bit)) + (case it + {try.#Failure error} + (exception.match? exception error) + + _ + false)) + +(def: test|value + Test + (<| (let [(^open "/#[0]") /.equivalence]) + (do [! random.monad] + [left ..random + right ..random] + ($_ _.and + (_.for [/.equivalence] + ($equivalence.spec /.equivalence ..random)) + + (_.cover [/.exhaustive?] + (bit#= (/#= {/.#Exhaustive} left) + (/.exhaustive? left))) + (_.cover [/.format] + (bit#= (/#= left right) + (text#= (/.format left) (/.format right)))) + )))) + +(def: test|coverage + Test + (<| (let [(^open "/#[0]") /.equivalence]) + (do [! random.monad] + [[expected pattern] ..random_pattern] + ($_ _.and + (_.cover [/.coverage] + (|> pattern + /.coverage + (try#each (/#= expected)) + (try.else false))) + (_.cover [/.invalid_tuple] + (let [invalid? (..failure? /.invalid_tuple)] + (and (|> (list) + {//complex.#Tuple} + {//pattern.#Complex} + /.coverage + invalid?) + (|> (list pattern) + {//complex.#Tuple} + {//pattern.#Complex} + /.coverage + invalid?) + (|> (list pattern pattern) + {//complex.#Tuple} + {//pattern.#Complex} + /.coverage + invalid? + not)))) + )))) + +(def: random_partial_pattern + (Random [/.Coverage Pattern]) + (random.only (|>> product.left /.exhaustive? not) + ..random_pattern)) + +(def: test|variant + Test + (<| (let [(^open "/#[0]") /.equivalence]) + (do [! random.monad] + [[expected/0 pattern/0] ..random_partial_pattern + [expected/1 pattern/1] (random.only (|>> product.left (/#= expected/0) not) + ..random_partial_pattern) + expected_maximum (# ! each (n.+ 2) ..random_tag) + .let [random_tag (random#each (n.% expected_maximum) random.nat)] + tag/0 random_tag + tag/1 (random.only (|>> (n.= tag/0) not) random_tag) + .let [cases (dictionary.of_list n.hash (list [tag/0 expected/0] + [tag/1 expected/1])) + expected_minimum (++ (n.max tag/0 tag/1))]] + ($_ _.and + (_.cover [/.minimum] + (and (n.= expected_minimum (/.minimum [{.#None} cases])) + (n.= expected_maximum (/.minimum [{.#Some expected_maximum} cases])))) + (_.cover [/.maximum] + (and (n.= n#top (/.maximum [{.#None} cases])) + (n.= expected_maximum (/.maximum [{.#Some expected_maximum} cases])))) + )))) + +(def: test|composite + Test + (<| (let [(^open "/#[0]") /.equivalence]) + (do [! random.monad] + [[expected/0 pattern/0] ..random_partial_pattern + [expected/1 pattern/1] (random.only (|>> product.left (/#= expected/0) not) + ..random_partial_pattern) + [expected/2 pattern/2] (random.only ($_ predicate.and + (|>> product.left (/#= expected/0) not) + (|>> product.left (/#= expected/1) not) + (|>> product.left (case> {/.#Variant _} false _ true))) + ..random_partial_pattern) + + bit random.bit + nat random.nat + int random.int + rev random.rev + frac random.frac + text (random.unicode 1) + + arity (# ! each (n.+ 2) ..random_tag) + .let [random_tag (random#each (n.% arity) random.nat)] + tag/0 random_tag + tag/1 (random.only (|>> (n.= tag/0) not) random_tag)] + ($_ _.and + (_.cover [/.composite] + (let [composes_simples! + (`` (and (|> (/.composite {/.#Bit bit} {/.#Bit (not bit)}) + (try#each (/#= {/.#Exhaustive})) + (try.else false)) + (|> {/.#Bit bit} + (/.composite {/.#Exhaustive}) + (try#each (/#= {/.#Exhaustive})) + (try.else false)) + (~~ (template [<tag> <hash> <value> <next>] + [(|> (/.composite {<tag> (set.of_list <hash> (list <value>))} + {<tag> (set.of_list <hash> (list (|> <value> <next>)))}) + (try#each (/#= {<tag> (set.of_list <hash> (list <value> (|> <value> <next>)))})) + (try.else false)) + (|> {<tag> (set.of_list <hash> (list <value>))} + (/.composite {/.#Exhaustive}) + (try#each (/#= {/.#Exhaustive})) + (try.else false))] + + [/.#Nat n.hash nat ++] + [/.#Int i.hash int ++] + [/.#Rev r.hash rev ++] + [/.#Frac f.hash frac (f.+ frac)] + [/.#Text text.hash text (%.format text)] + )))) + + composes_variants! + (let [composes_different_variants! + (let [composes? (: (-> (Maybe Nat) (Maybe Nat) (Maybe Nat) Bit) + (function (_ left right both) + (|> (/.composite {/.#Variant left (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant right (dictionary.of_list n.hash (list [tag/1 expected/1]))}) + (try#each (/#= {/.#Variant both (dictionary.of_list n.hash (list [tag/0 expected/0] + [tag/1 expected/1]))})) + (try.else false))))] + (and (composes? {.#None} {.#None} {.#None}) + (composes? {.#Some arity} {.#None} {.#Some arity}) + (composes? {.#None} {.#Some arity} {.#Some arity}) + (composes? {.#Some arity} {.#Some arity} {.#Some arity}))) + + composes_same_variants! + (let [composes? (: (-> (Maybe Nat) (Maybe Nat) (Maybe Nat) Bit) + (function (_ left right both) + (|> (do try.monad + [variant (/.composite {/.#Variant left (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant right (dictionary.of_list n.hash (list [tag/0 expected/1]))}) + expected (/.composite expected/0 expected/1)] + (in (/#= {/.#Variant both (dictionary.of_list n.hash (list [tag/0 expected]))} + variant))) + (try.else false))))] + (and (composes? {.#None} {.#None} {.#None}) + (composes? {.#Some arity} {.#None} {.#Some arity}) + (composes? {.#None} {.#Some arity} {.#Some arity}) + (composes? {.#Some arity} {.#Some arity} {.#Some arity})))] + (and composes_different_variants! + composes_same_variants! + (and (|> {/.#Variant {.#None} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + (/.composite {/.#Exhaustive}) + (try#each (/#= {/.#Exhaustive})) + (try.else false)) + (|> {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + (/.composite {/.#Exhaustive}) + (try#each (/#= {/.#Exhaustive})) + (try.else false))))) + + composes_sequences! + (and (|> (/.composite {/.#Seq expected/0 expected/1} + {/.#Seq expected/1 expected/0}) + (try#each (/#= {/.#Alt {/.#Seq expected/0 expected/1} + {/.#Seq expected/1 expected/0}})) + (try.else false)) + (|> (do try.monad + [seq (/.composite {/.#Seq expected/0 expected/0} + {/.#Seq expected/0 expected/1}) + expected (/.composite expected/0 expected/1)] + (in (/#= (if (/.exhaustive? expected) + expected/0 + {/.#Seq expected/0 expected}) + seq))) + (try.else false)) + (|> (do try.monad + [seq (/.composite {/.#Seq expected/0 expected/0} + {/.#Seq expected/1 expected/0}) + expected (/.composite expected/0 expected/1)] + (in (/#= {/.#Seq expected expected/0} + seq))) + (try.else false)) + (|> (/.composite {/.#Seq expected/0 expected/1} + expected/1) + (try#each (/#= {/.#Alt {/.#Seq expected/0 expected/1} + expected/1})) + (try.else false)) + (|> (/.composite expected/1 + {/.#Seq expected/0 expected/1}) + (try#each (/#= {/.#Alt expected/1 + {/.#Seq expected/0 expected/1}})) + (try.else false)) + (|> (/.composite expected/0 + {/.#Seq expected/0 expected/1}) + (try#each (/#= expected/0)) + (try.else false))) + + composes_alts! + (and (|> (do try.monad + [alt (/.composite {/.#Exhaustive} + {/.#Alt expected/0 + expected/1})] + (in (/#= {/.#Exhaustive} + alt))) + (try.else false)) + (|> (do try.monad + [alt (/.composite {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 {/.#Exhaustive}]))} + {/.#Alt {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/1]))}})] + (in (/#= {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 {/.#Exhaustive}]))} + alt))) + (try.else false)) + (|> (do try.monad + [alt (/.composite {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 {/.#Exhaustive}]))} + {/.#Alt {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))}})] + (in (/#= {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 {/.#Exhaustive}] + [tag/1 expected/1]))} + alt))) + (try.else false)) + (|> (do try.monad + [alt (/.composite {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/2]))} + {/.#Alt {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))}}) + expected (/.composite expected/2 expected/0)] + (in (/#= {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected] + [tag/1 expected/1]))} + alt))) + (try.else false)) + (|> (do try.monad + [alt (/.composite {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/2]))} + {/.#Alt {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))}}) + expected (/.composite expected/2 expected/1)] + (in (/#= {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0] + [tag/1 expected]))} + alt))) + (try.else false)) + (|> (do try.monad + [alt (/.composite {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))} + {/.#Alt {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + expected/2})] + (in (/#= {/.#Alt expected/2 + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0] + [tag/1 expected/1]))}} + alt))) + (try.else false)))] + (and composes_simples! + composes_variants! + composes_sequences! + composes_alts!))) + (_.cover [/.redundancy] + (let [redundant? (..failure? /.redundancy)] + (`` (and (redundant? (/.composite {/.#Exhaustive} {/.#Exhaustive})) + (~~ (template [<it>] + [(redundant? (/.composite <it> <it>)) + (redundant? (/.composite <it> {/.#Exhaustive}))] + + [{/.#Bit bit}] + [{/.#Nat (set.of_list n.hash (list nat))}] + [{/.#Int (set.of_list i.hash (list int))}] + [{/.#Rev (set.of_list r.hash (list rev))}] + [{/.#Frac (set.of_list f.hash (list frac))}] + [{/.#Text (set.of_list text.hash (list text))}] + [{/.#Variant {.#None} (dictionary.of_list n.hash (list [tag/0 expected/0]))}] + [{/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))}] + [{/.#Seq expected/0 expected/1}] + )) + (redundant? (/.composite {/.#Seq expected/0 expected/1} expected/0)))))) + (_.cover [/.variant_mismatch] + (let [mismatch? (..failure? /.variant_mismatch)] + (and (not (mismatch? (/.composite {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))}))) + + (mismatch? (/.composite {/.#Variant {.#Some (++ arity)} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))})) + (mismatch? (/.composite {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some (++ arity)} (dictionary.of_list n.hash (list [tag/1 expected/1]))})) + + (mismatch? (/.composite {/.#Variant {.#Some (-- arity)} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))})) + (mismatch? (/.composite {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some (-- arity)} (dictionary.of_list n.hash (list [tag/1 expected/1]))})) + + (not (mismatch? (/.composite {/.#Variant {.#None} (dictionary.of_list n.hash (list [tag/0 expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))}))) + (mismatch? (/.composite {/.#Variant {.#None} (dictionary.of_list n.hash (list [arity expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))})) + (not (mismatch? (/.composite {/.#Variant {.#None} (dictionary.of_list n.hash (list [(-- arity) expected/0]))} + {/.#Variant {.#Some arity} (dictionary.of_list n.hash (list [tag/1 expected/1]))})))))) + )))) + +(def: .public test + Test + (<| (_.covering /._) + (_.for [/.Coverage]) + ($_ _.and + ..test|value + ..test|coverage + (_.for [/.Variant] + ..test|variant) + ..test|composite + ))) diff --git a/stdlib/source/unsafe/lux/data/binary.lux b/stdlib/source/unsafe/lux/data/binary.lux index 868dd82f3..d91893c38 100644 --- a/stdlib/source/unsafe/lux/data/binary.lux +++ b/stdlib/source/unsafe/lux/data/binary.lux @@ -59,12 +59,11 @@ (type: .public Binary (array.Array (I64 Any))))) -(template: .public (empty size) - [(with_expansions [<size> (: Nat size) - <jvm> (|> <size> - (ffi.array byte) - (: ..Binary))] - (: ..Binary +(with_expansions [<size> (: Nat size) + <jvm> (ffi.array byte <size>) + <jvm> (: ..Binary <jvm>)] + (template: .public (empty size) + [(: ..Binary (for [@.old <jvm> @.jvm <jvm> @@ -84,12 +83,12 @@ (..make-bytevector <size>)] ... Default - (array.empty <size>))))]) + (array.empty <size>)))])) -(template: .public (size it) - [(with_expansions [<it> (: ..Binary it) - <jvm> (ffi.length <it>)] - (: Nat +(with_expansions [<it> (: ..Binary it) + <jvm> (ffi.length <it>)] + (template: .public (size it) + [(: Nat (for [@.old <jvm> @.jvm <jvm> @@ -109,47 +108,47 @@ (..bytevector-length [<it>])] ... Default - (array.size <it>))))]) + (array.size <it>)))])) (def: byte_mask Nat (i64.mask i64.bits_per_byte)) -(with_expansions [<byte_mask> (.static ..byte_mask)] +(with_expansions [<byte_mask> (.static ..byte_mask) + <it> (: ..Binary it) + <index> (: Nat index) + <jvm> (ffi.read! <index> <it>) + <jvm> (ffi.byte_to_long <jvm>) + <jvm> (|> <jvm> + (:as I64) + ("lux i64 and" <byte_mask>))] (template: .public (bytes/1 index it) - [(with_expansions [<it> (: ..Binary it) - <index> (: Nat index) - <jvm> (|> <it> - (ffi.read! <index>) - ffi.byte_to_long - (:as I64) - ("lux i64 and" <byte_mask>))] - (: I64 - (`` (for [@.old (~~ <jvm>) - @.jvm (~~ <jvm>) - - @.js - (|> <it> - (:as (array.Array .Frac)) - ("js array read" <index>) - "lux f64 i64" - .i64) - - @.python - (|> <it> - (:as (array.Array .I64)) - ("python array read" <index>)) - - @.scheme - (..bytevector-u8-ref [<it> <index>])] - - ... Default - (.case (array.read! <index> <it>) - {.#Some it} - it - - {.#None} - (.i64 (: (I64 Any) 0)))))))])) + [(: I64 + (`` (for [@.old (~~ <jvm>) + @.jvm (~~ <jvm>) + + @.js + (|> <it> + (:as (array.Array .Frac)) + ("js array read" <index>) + "lux f64 i64" + .i64) + + @.python + (|> <it> + (:as (array.Array .I64)) + ("python array read" <index>)) + + @.scheme + (..bytevector-u8-ref [<it> <index>])] + + ... Default + (.case (array.read! <index> <it>) + {.#Some it} + it + + {.#None} + (.i64 (: (I64 Any) 0))))))])) (template: .public (bytes/2 index' it') [(let [index (: Nat index') @@ -183,48 +182,49 @@ ("lux i64 left-shift" 8 (..bytes/1 ("lux i64 +" 6 index) it)) (..bytes/1 ("lux i64 +" 7 index) it))))]) -(with_expansions [<byte> (hex "FF")] +(with_expansions [<byte> (hex "FF") + <it> (: ..Binary it) + <index> (: Nat index) + <value> (: (I64 Any) value) + <jvm_value> (for [@.old + (:as Int <value>) + + @.jvm + (:as (Primitive "java.lang.Long") <value>)] + <value>) + <jvm_value> (ffi.long_to_byte <jvm_value>) + <jvm> (ffi.write! <index> <jvm_value> <it>)] (template: .public (with/1! index value it) - [(with_expansions [<it> (: ..Binary it) - <index> (: Nat index) - <value> (: (I64 Any) value) - <value> (for [@.old - (|> <value> (:as Int) ffi.long_to_byte) - - @.jvm - (|> <value> (:as (Primitive "java.lang.Long")) ffi.long_to_byte)] - <value>) - <jvm> (ffi.write! <index> <value> <it>)] - (: ..Binary - (for [@.old <jvm> - @.jvm <jvm> - - @.js - (|> <it> - (: ..Binary) - (:as (array.Array .Frac)) - ("js array write" <index> - (|> <value> - .int - ("lux i64 and" (.int <byte>)) - "lux i64 f64")) - (:as ..Binary)) - - @.python - (|> <it> - (: ..Binary) - (:as (array.Array (I64 Any))) - ("python array write" <index> (|> <value> ("lux i64 and" <byte>) (: (I64 Any)))) - (:as ..Binary)) - - @.scheme - (let [it' <it>] - (exec - (..bytevector-u8-set! [it' <index> <value>]) - it'))] - - ... Default - (array.write! <index> (|> <value> .int ("lux i64 and" (.int <byte>))) <it>))))])) + [(: ..Binary + (for [@.old <jvm> + @.jvm <jvm> + + @.js + (|> <it> + (: ..Binary) + (:as (array.Array .Frac)) + ("js array write" <index> + (|> <value> + .int + ("lux i64 and" (.int <byte>)) + "lux i64 f64")) + (:as ..Binary)) + + @.python + (|> <it> + (: ..Binary) + (:as (array.Array (I64 Any))) + ("python array write" <index> (|> <value> ("lux i64 and" <byte>) (: (I64 Any)))) + (:as ..Binary)) + + @.scheme + (let [it' <it>] + (exec + (..bytevector-u8-set! [it' <index> <value>]) + it'))] + + ... Default + (array.write! <index> (|> <value> .int ("lux i64 and" (.int <byte>))) <it>)))])) (template: .public (with/2! index' value' it) [(let [index (: Nat index') @@ -268,28 +268,33 @@ (..with/1! ("lux i64 +" 6 index) ("lux i64 right-shift" 8 value)) (..with/1! ("lux i64 +" 7 index) value))))]) -(def: .public (= reference sample) - (-> ..Binary ..Binary Bit) - (with_expansions [<jvm> (java/util/Arrays::equals reference sample)] - (for [@.old <jvm> - @.jvm <jvm>] - (let [limit (..size reference)] - (and ("lux i64 =" limit (..size sample)) - (loop [index 0] - (if ("lux i64 =" limit index) - (and ("lux i64 =" - (..bytes/1 index reference) - (..bytes/1 index sample)) - (again (++ index))) - true))))))) - -(def: .public (copy! bytes source_offset source target_offset target) +(with_expansions [<reference> (: ..Binary reference') + <sample> (: ..Binary sample') + <jvm> (java/util/Arrays::equals <reference> <sample>)] + (template: .public (= reference' sample') + [(for [@.old <jvm> + @.jvm <jvm>] + (let [reference <reference> + sample <sample> + limit (..size reference)] + (and ("lux i64 =" limit (..size sample)) + (loop [index 0] + (if ("lux i64 =" limit index) + (and ("lux i64 =" + (..bytes/1 index reference) + (..bytes/1 index sample)) + (again (++ index))) + true)))))])) + +... TODO: Turn into a template ASAP. +(inline: .public (copy! bytes source_offset source target_offset target) (-> Nat Nat ..Binary Nat ..Binary ..Binary) - (with_expansions [<jvm> (as_is (exec - (java/lang/System::arraycopy source (.int source_offset) - target (.int target_offset) - (.int bytes)) - target))] + (with_expansions [<jvm> (java/lang/System::arraycopy source (.int source_offset) + target (.int target_offset) + (.int bytes)) + <jvm> (exec + <jvm> + target)] (for [@.old <jvm> @.jvm <jvm>] @@ -303,12 +308,16 @@ (again (++ index))) target))))) -(def: .public (slice offset size binary) - (-> Nat Nat ..Binary ..Binary) - (let [limit ("lux i64 +" size offset)] - (with_expansions [<jvm> (as_is (java/util/Arrays::copyOfRange binary (.int offset) (.int limit)))] - (for [@.old <jvm> - @.jvm <jvm>] - - ... Default - (..copy! size offset binary 0 (..empty size)))))) +... TODO: Turn into a template ASAP. +(with_expansions [<jvm> (java/util/Arrays::copyOfRange binary + (.int offset) + (.int limit)) + <jvm> (let [limit ("lux i64 +" size offset)] + <jvm>)] + (inline: .public (slice offset size binary) + (-> Nat Nat ..Binary ..Binary) + (for [@.old <jvm> + @.jvm <jvm>] + + ... Default + (..copy! size offset binary 0 (..empty size))))) |