diff options
Diffstat (limited to '')
15 files changed, 896 insertions, 393 deletions
diff --git a/stdlib/source/library/lux/control/parser/type.lux b/stdlib/source/library/lux/control/parser/type.lux index 03483c788..3f4da5ee2 100644 --- a/stdlib/source/library/lux/control/parser/type.lux +++ b/stdlib/source/library/lux/control/parser/type.lux @@ -1,26 +1,26 @@ (.using - [library - [lux {"-" function local} - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" try {"+" Try}] - ["[0]" exception {"+" exception:}] - ["[0]" function]] - [data - ["[0]" text ("[1]#[0]" monoid) - ["%" format {"+" format}]] - [collection - ["[0]" list ("[1]#[0]" functor)] - ["[0]" dictionary {"+" Dictionary}]]] - [macro - ["[0]" code]] - [math - [number - ["n" nat ("[1]#[0]" decimal)]]] - ["[0]" type ("[1]#[0]" equivalence) - ["[0]" check]]]] - ["[0]" //]) + [library + [lux {"-" function local} + [abstract + ["[0]" monad {"+" do}]] + [control + ["[0]" try {"+" Try}] + ["[0]" exception {"+" exception:}] + ["[0]" function]] + [data + ["[0]" text ("[1]#[0]" monoid) + ["%" format {"+" format}]] + [collection + ["[0]" list ("[1]#[0]" functor)] + ["[0]" dictionary {"+" Dictionary}]]] + [macro + ["[0]" code]] + [math + [number + ["n" nat ("[1]#[0]" decimal)]]] + ["[0]" type ("[1]#[0]" equivalence) + ["[0]" check]]]] + ["[0]" //]) (template: (|recursion_dummy|) [{.#Primitive "" {.#End}}]) @@ -245,7 +245,7 @@ [super (function.flipped check.subsumes?)] ) -(def: .public (adjusted_idx env idx) +(def: .public (argument env idx) (-> Env Nat Nat) (let [env_level (n./ 2 (dictionary.size env)) parameter_level (n./ 2 idx) @@ -259,7 +259,7 @@ headT any] (case headT {.#Parameter idx} - (case (dictionary.value (adjusted_idx env idx) env) + (case (dictionary.value (..argument env idx) env) {.#Some [poly_type poly_code]} (in poly_code) @@ -276,7 +276,7 @@ headT any] (case headT {.#Parameter idx} - (if (n.= id (adjusted_idx env idx)) + (if (n.= id (..argument env idx)) (in []) (//.failure (exception.error ..wrong_parameter [{.#Parameter id} headT]))) @@ -328,7 +328,7 @@ headT any] (case (type.anonymous headT) (^multi (^ {.#Apply (|recursion_dummy|) {.#Parameter funcT_idx}}) - (n.= 0 (adjusted_idx env funcT_idx)) + (n.= 0 (..argument env funcT_idx)) [(dictionary.value 0 env) {.#Some [self_type self_call]}]) (in self_call) diff --git a/stdlib/source/library/lux/target/python.lux b/stdlib/source/library/lux/target/python.lux index b574b6688..1e0d3a59b 100644 --- a/stdlib/source/library/lux/target/python.lux +++ b/stdlib/source/library/lux/target/python.lux @@ -211,13 +211,13 @@ ) (def: .public (slice from to list) - (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (-> (Expression Any) (Expression Any) (Expression Any) Access) (<| :abstraction ... ..expression (format (:representation list) "[" (:representation from) ":" (:representation to) "]"))) (def: .public (slice_from from list) - (-> (Expression Any) (Expression Any) (Computation Any)) + (-> (Expression Any) (Expression Any) Access) (<| :abstraction ... ..expression (format (:representation list) "[" (:representation from) ":]"))) 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 3e81c08b8..2c957abe7 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 @@ -20,7 +20,7 @@ [macro ["[0]" code]] ["[0]" type - ["[0]" check]]]] + ["[0]" check {"+" Check}]]]] ["[0]" / "_" ["/[1]" // "_" ["[1][0]" complex] @@ -37,8 +37,8 @@ [/// ["[1]" phase]]]]]]) -(exception: .public (cannot_match_with_pattern [type Type - pattern Code]) +(exception: .public (mismatch [type Type + pattern Code]) (exception.report ["Type" (%.type type)] ["Pattern" (%.code pattern)])) @@ -49,15 +49,15 @@ ["Case" (%.nat case)] ["Type" (%.type type)])) -(exception: .public (not_a_pattern [code Code]) - (exception.report ["Code" (%.code code)])) +(exception: .public (invalid [it Code]) + (exception.report ["Pattern" (%.code it)])) -(exception: .public (cannot_simplify_for_pattern_matching [type Type]) +(exception: .public (non_tuple [type Type]) (exception.report ["Type" (%.type type)])) -(exception: .public (non_exhaustive_pattern_matching [input Code - branches (List [Code Code]) - coverage Coverage]) +(exception: .public (non_exhaustive [input Code + branches (List [Code Code]) + coverage Coverage]) (exception.report ["Input" (%.code input)] ["Branches" (%.code (code.tuple (|> branches @@ -66,17 +66,16 @@ list#conjoint)))] ["Coverage" (/coverage.format coverage)])) -(exception: .public (cannot_have_empty_branches [message Text]) - message) +(exception: .public empty_branches) -(def: (re_quantify envs baseT) +(def: (quantified envs baseT) (-> (List (List Type)) Type Type) (.case envs {.#End} baseT {.#Item head tail} - (re_quantify tail {.#UnivQ head baseT}))) + (quantified tail {.#UnivQ head baseT}))) ... Type-checking on the input value is done during the analysis of a ... "case" expression, to ensure that the patterns being used make @@ -85,21 +84,21 @@ ... type-variables or quantifications. ... This function makes it easier for "case" analysis to properly ... type-check the input with respect to the patterns. -(def: (simplify_case caseT) - (-> Type (Operation Type)) +(def: .public (tuple :it:) + (-> Type (Check [(List check.Var) Type])) (loop [envs (: (List (List Type)) (list)) - caseT caseT] - (.case caseT + :it: :it:] + (.case :it: {.#Var id} - (do ///.monad - [?caseT' (/type.check (check.peek id))] - (.case ?caseT' - {.#Some caseT'} - (again envs caseT') + (do check.monad + [?:it:' (check.peek id)] + (.case ?:it:' + {.#Some :it:'} + (again envs :it:') _ - (/.except ..cannot_simplify_for_pattern_matching caseT))) + (check.except ..non_tuple :it:))) {.#Named name unnamedT} (again envs unnamedT) @@ -108,44 +107,46 @@ (again {.#Item env envs} unquantifiedT) {.#ExQ _} - (do ///.monad - [[var_id varT] (/type.check check.var)] - (again envs (maybe.trusted (type.applied (list varT) caseT)))) - - {.#Apply inputT funcT} - (.case funcT - {.#Var funcT_id} - (do ///.monad - [funcT' (/type.check - (do check.monad - [?funct' (check.peek funcT_id)] - (.case ?funct' - {.#Some funct'} - (in funct') - - _ - (check.except ..cannot_simplify_for_pattern_matching caseT))))] - (again envs {.#Apply inputT funcT'})) - - _ - (.case (type.applied (list inputT) funcT) - {.#Some outputT} - (again envs outputT) + (do check.monad + [[@head :head:] check.var + [tail :tuple:] (again envs (maybe.trusted (type.applied (list :head:) :it:)))] + (in [(list& @head tail) :tuple:])) + + {.#Apply _} + (do [! check.monad] + [.let [[:abstraction: :parameters:] (type.flat_application :it:)] + :abstraction: (.case :abstraction: + {.#Var @abstraction} + (do ! + [?:abstraction: (check.peek @abstraction)] + (.case ?:abstraction: + {.#Some :abstraction:} + (in :abstraction:) + + _ + (check.except ..non_tuple :it:))) + + _ + (in :abstraction:))] + (.case (type.applied :parameters: :abstraction:) + {.#Some :it:} + (again envs :it:) {.#None} - (/.except ..cannot_simplify_for_pattern_matching caseT))) + (check.except ..non_tuple :it:))) {.#Product _} - (|> caseT + (|> :it: type.flat_tuple - (list#each (re_quantify envs)) + (list#each (..quantified envs)) type.tuple - (# ///.monad in)) + [(list)] + (# check.monad in)) _ - (# ///.monad in (re_quantify envs caseT))))) + (# check.monad in [(list) (..quantified envs :it:)])))) -(def: (analyse_simple type inputT location output next) +(def: (simple_pattern_analysis type inputT location output next) (All (_ a) (-> Type Type Location Pattern (Operation a) (Operation [Pattern a]))) (/.with_location location (do ///.monad @@ -153,12 +154,12 @@ outputA next] (in [output outputA])))) -(def: (analyse_tuple_pattern analyse_pattern inputT sub_patterns next) +(def: (tuple_pattern_analysis pattern_analysis inputT sub_patterns next) (All (_ a) (-> (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])) Type (List Code) (Operation a) (Operation [Pattern a]))) (do [! ///.monad] - [inputT' (simplify_case inputT)] + [[@ex_var+ inputT'] (/type.check (..tuple inputT))] (.case inputT' {.#Product _} (let [matches (loop [types (type.flat_tuple inputT') @@ -190,18 +191,19 @@ (function (_ [memberT memberC] then) (do ! [[memberP [memberP+ thenA]] ((:as (All (_ a) (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) - analyse_pattern) + pattern_analysis) {.#None} memberT memberC then)] (in [(list& memberP memberP+) thenA])))) (do ! [nextA next] (in [(list) nextA])) - matches)] + matches) + _ (/type.check (monad.each check.monad check.forget! @ex_var+))] (in [(/pattern.tuple memberP+) thenA]))) _ - (/.except ..cannot_match_with_pattern [inputT' (code.tuple sub_patterns)])))) + (/.except ..mismatch [inputT' (code.tuple sub_patterns)])))) ... This function handles several concerns at once, but it must be that ... way because those concerns are interleaved when doing @@ -219,7 +221,7 @@ ... body expressions. ... That is why the body must be analysed in the context of the ... pattern, and not separately. -(def: (analyse_pattern num_tags inputT pattern next) +(def: (pattern_analysis num_tags inputT pattern next) (All (_ a) (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) (.case pattern [location {.#Symbol ["" name]}] @@ -232,7 +234,7 @@ (^template [<type> <input> <output>] [[location <input>] - (analyse_simple <type> inputT location {/pattern.#Simple <output>} next)]) + (simple_pattern_analysis <type> inputT location {/pattern.#Simple <output>} next)]) ([Bit {.#Bit pattern_value} {/simple.#Bit pattern_value}] [Nat {.#Nat pattern_value} {/simple.#Nat pattern_value}] [Int {.#Int pattern_value} {/simple.#Int pattern_value}] @@ -242,12 +244,12 @@ [Any {.#Tuple {.#End}} {/simple.#Unit}]) (^ [location {.#Tuple (list singleton)}]) - (analyse_pattern {.#None} inputT singleton next) + (pattern_analysis {.#None} inputT singleton next) [location {.#Tuple sub_patterns}] (/.with_location location (do [! ///.monad] - [record (//complex.normal sub_patterns) + [record (//complex.normal true sub_patterns) record_size,members,recordT (: (Operation (Maybe [Nat (List Code) Type])) (.case record {.#Some record} @@ -266,18 +268,18 @@ (in []))] (.case members (^ (list singleton)) - (analyse_pattern {.#None} inputT singleton next) + (pattern_analysis {.#None} inputT singleton next) _ - (analyse_tuple_pattern analyse_pattern inputT members next))) + (..tuple_pattern_analysis pattern_analysis inputT members next))) {.#None} - (analyse_tuple_pattern analyse_pattern inputT sub_patterns next)))) + (..tuple_pattern_analysis pattern_analysis inputT sub_patterns next)))) (^ [location {.#Variant (list& [_ {.#Nat lefts}] [_ {.#Bit right?}] values)}]) (/.with_location location (do ///.monad - [inputT' (simplify_case inputT)] + [[@ex_var+ inputT'] (/type.check (..tuple inputT))] (.case inputT' {.#Sum _} (let [flat_sum (type.flat_variant inputT') @@ -290,11 +292,12 @@ (do ///.monad [[testP nextA] (if (and (n.> num_cases size_sum) (n.= (-- num_cases) idx)) - (analyse_pattern {.#None} - (type.variant (list.after (-- num_cases) flat_sum)) - (` [(~+ values)]) - next) - (analyse_pattern {.#None} caseT (` [(~+ values)]) next))] + (pattern_analysis {.#None} + (type.variant (list.after (-- num_cases) flat_sum)) + (` [(~+ values)]) + next) + (pattern_analysis {.#None} caseT (` [(~+ values)]) next)) + _ (/type.check (monad.each check.monad check.forget! @ex_var+))] (in [(/pattern.variant [lefts right? testP]) nextA])) @@ -303,14 +306,16 @@ {.#UnivQ _} (do ///.monad - [[ex_id exT] (/type.check check.existential)] - (analyse_pattern num_tags - (maybe.trusted (type.applied (list exT) inputT')) - pattern - next)) + [[ex_id exT] (/type.check check.existential) + it (pattern_analysis num_tags + (maybe.trusted (type.applied (list exT) inputT')) + pattern + next) + _ (/type.check (monad.each check.monad check.forget! @ex_var+))] + (in it)) _ - (/.except ..cannot_match_with_pattern [inputT' pattern])))) + (/.except ..mismatch [inputT' pattern])))) (^ [location {.#Variant (list& [_ {.#Symbol tag}] values)}]) (/.with_location location @@ -319,10 +324,10 @@ [idx group variantT] (///extension.lifted (meta.tag tag)) _ (/type.check (check.check inputT variantT)) .let [[lefts right?] (/complex.choice (list.size group) idx)]] - (analyse_pattern {.#Some (list.size group)} inputT (` {(~ (code.nat lefts)) (~ (code.bit right?)) (~+ values)}) next))) + (pattern_analysis {.#Some (list.size group)} inputT (` {(~ (code.nat lefts)) (~ (code.bit right?)) (~+ values)}) next))) _ - (/.except ..not_a_pattern pattern) + (/.except ..invalid [pattern]) )) (def: .public (case analyse branches archive inputC) @@ -332,16 +337,16 @@ (do [! ///.monad] [[inputT inputA] (/type.inferring (analyse archive inputC)) - outputH (analyse_pattern {.#None} inputT patternH (analyse archive bodyH)) + outputH (pattern_analysis {.#None} inputT patternH (analyse archive bodyH)) outputT (monad.each ! (function (_ [patternT bodyT]) - (analyse_pattern {.#None} inputT patternT (analyse archive bodyT))) + (pattern_analysis {.#None} inputT patternT (analyse archive bodyT))) branchesT) 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 [inputC branches coverage] (/coverage.exhaustive? coverage)) {try.#Failure error} @@ -349,4 +354,4 @@ (in {/.#Case inputA [outputH outputT]})) {.#End} - (/.except ..cannot_have_empty_branches ""))) + (/.except ..empty_branches []))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux index cce7b1f00..1bf6a48b9 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux @@ -286,12 +286,19 @@ ... records, so they must be normalized for further analysis. ... Normalization just means that all the tags get resolved to their ... canonical form (with their corresponding module identified). -(def: .public (normal record) - (-> (List Code) (Operation (Maybe (List [Symbol Code])))) +(def: .public (normal pattern_matching? record) + (-> Bit (List Code) (Operation (Maybe (List [Symbol Code])))) (loop [input record output (: (List [Symbol Code]) {.#End})] (case input + (^ (list& [_ {.#Symbol ["" slotH]}] valueH tail)) + (if pattern_matching? + (///#in {.#None}) + (do ///.monad + [slotH (///extension.lifted (meta.normal ["" slotH]))] + (again tail {.#Item [slotH valueH] output}))) + (^ (list& [_ {.#Symbol slotH}] valueH tail)) (do ///.monad [slotH (///extension.lifted (meta.normal slotH))] @@ -398,7 +405,7 @@ _ (do [! ///.monad] - [?members (normal members)] + [?members (..normal false members)] (case ?members {.#None} (..product analyse archive members) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index 2338824c4..540e38eb0 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -142,7 +142,9 @@ (getDeclaredField [java/lang/String] "try" java/lang/reflect/Field) (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)]) (getDeclaredMethods [] [java/lang/reflect/Method]) - (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation]) + (getSuperclass [] "?" (java/lang/Class java/lang/Object)) + (getInterfaces [] [(java/lang/Class java/lang/Object)])]) (template [<name>] [(exception: .public (<name> [class External @@ -456,15 +458,16 @@ (function (_ extension_name analyse archive args) (case args (^ (list arrayC)) - (do phase.monad - [_ (typeA.inference ..int) - [var_id varT] (typeA.check check.var) - arrayA (<| (typeA.expecting (.type (array.Array varT))) - (analyse archive arrayC)) - varT (typeA.check (check.clean (list) varT)) - arrayJT (jvm_array_type (.type (array.Array varT)))] - (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) - arrayA)})) + (<| typeA.with_var + (function (_ [@var :var:])) + (do phase.monad + [_ (typeA.inference ..int) + arrayA (<| (typeA.expecting (.type (array.Array :var:))) + (analyse archive arrayC)) + :var: (typeA.check (check.clean (list) :var:)) + arrayJT (jvm_array_type (.type (array.Array :var:)))] + (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) + arrayA)}))) _ (/////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) @@ -662,18 +665,19 @@ (function (_ extension_name analyse archive args) (case args (^ (list idxC arrayC)) - (do phase.monad - [[var_id varT] (typeA.check check.var) - _ (typeA.inference varT) - arrayA (<| (typeA.expecting (.type (array.Array varT))) - (analyse archive arrayC)) - varT (typeA.check (check.clean (list) varT)) - arrayJT (jvm_array_type (.type (array.Array varT))) - idxA (<| (typeA.expecting ..int) - (analyse archive idxC))] - (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) - idxA - arrayA)})) + (<| typeA.with_var + (function (_ [@var :var:])) + (do phase.monad + [_ (typeA.inference :var:) + arrayA (<| (typeA.expecting (.type (array.Array :var:))) + (analyse archive arrayC)) + :var: (typeA.check (check.clean (list) :var:)) + arrayJT (jvm_array_type (.type (array.Array :var:))) + idxA (<| (typeA.expecting ..int) + (analyse archive idxC))] + (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) + idxA + arrayA)}))) _ (/////analysis.except ///.incorrect_arity [extension_name 2 (list.size args)])))) @@ -705,21 +709,22 @@ (function (_ extension_name analyse archive args) (case args (^ (list idxC valueC arrayC)) - (do phase.monad - [[var_id varT] (typeA.check check.var) - _ (typeA.inference (.type (array.Array varT))) - arrayA (<| (typeA.expecting (.type (array.Array varT))) - (analyse archive arrayC)) - varT (typeA.check (check.clean (list) varT)) - arrayJT (jvm_array_type (.type (array.Array varT))) - idxA (<| (typeA.expecting ..int) - (analyse archive idxC)) - valueA (<| (typeA.expecting varT) - (analyse archive valueC))] - (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) - idxA - valueA - arrayA)})) + (<| typeA.with_var + (function (_ [@var :var:])) + (do phase.monad + [_ (typeA.inference (.type (array.Array :var:))) + arrayA (<| (typeA.expecting (.type (array.Array :var:))) + (analyse archive arrayC)) + :var: (typeA.check (check.clean (list) :var:)) + arrayJT (jvm_array_type (.type (array.Array :var:))) + idxA (<| (typeA.expecting ..int) + (analyse archive idxC)) + valueA (<| (typeA.expecting :var:) + (analyse archive valueC))] + (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) + idxA + valueA + arrayA)}))) _ (/////analysis.except ///.incorrect_arity [extension_name 3 (list.size args)])))) @@ -1608,13 +1613,45 @@ (list (/////analysis.text argument) (value_analysis argumentJT)))) -(template [<name> <only>] +(def: (family_tree' it) + (-> (java/lang/Class java/lang/Object) + (List (java/lang/Class java/lang/Object))) + (let [interfaces (array.list {.#None} (java/lang/Class::getInterfaces it)) + supers (case (java/lang/Class::getSuperclass it) + {.#Some class} + (list& class interfaces) + + {.#None} + interfaces)] + (|> supers + (list#each family_tree') + list#conjoint + (list& it)))) + +(def: family_tree + (-> (java/lang/Class java/lang/Object) + (List (java/lang/Class java/lang/Object))) + (|>> ..family_tree' + ... De-duplication + (list#mix (function (_ class all) + (dictionary.has (java/lang/Class::getName class) class all)) + (dictionary.empty text.hash)) + dictionary.values)) + +(def: (all_declared_methods it) + (-> (java/lang/Class java/lang/Object) + (List java/lang/reflect/Method)) + (|> it + ..family_tree + (list#each (|>> java/lang/Class::getDeclaredMethods (array.list {.#None}))) + list#conjoint)) + +(template [<name> <only> <methods>] [(def: (<name> [type class]) (-> [(Type Class) (java/lang/Class java/lang/Object)] (Try (List [(Type Class) Text (Type Method)]))) (|> class - java/lang/Class::getDeclaredMethods - (array.list {.#None}) + <methods> (list.only (|>> java/lang/reflect/Method::getModifiers (predicate.or (|>> java/lang/reflect/Modifier::isPublic) (|>> java/lang/reflect/Modifier::isProtected)))) @@ -1640,8 +1677,10 @@ concrete_exceptions generic_exceptions)])]))))))] - [abstract_methods (list.only (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))] - [methods (<|)] + [abstract_methods (list.only (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract)) + (<| (array.list {.#None}) java/lang/Class::getDeclaredMethods)] + [methods (<|) + ..all_declared_methods] ) (def: jvm_package_separator ".") @@ -2089,8 +2128,8 @@ [[_ exT] (typeA.check check.existential)] (in [var exT]))) vars)] - (in (list#mix (function (_ [varJ varT] mapping) - (dictionary.has (parser.name varJ) varT mapping)) + (in (list#mix (function (_ [varJ :var:] mapping) + (dictionary.has (parser.name varJ) :var: mapping)) mapping pairings)))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux index 4b4956d82..23a64f59c 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux @@ -4,7 +4,7 @@ [abstract ["[0]" monad {"+" do}]] [control - ["[0]" maybe] + ["[0]" maybe ("[1]#[0]" functor)] ["[0]" exception {"+" exception:}] ["<>" parser ["<[0]>" text] @@ -917,14 +917,24 @@ [//////synthesis.#Seq]) (^template [<tag>] - [(^ {<tag> _}) + [{<tag> _} path]) ([//////synthesis.#Pop] [//////synthesis.#Bind] [//////synthesis.#Access]) - _ - (undefined)))) + {//////synthesis.#Bit_Fork when then else} + {//////synthesis.#Bit_Fork when (again then) (maybe#each again else)} + + (^template [<tag>] + [{<tag> [[exampleH nextH] tail]} + {<tag> [[exampleH (again nextH)] + (list#each (function (_ [example next]) + [example (again next)]) + tail)]}]) + ([//////synthesis.#I64_Fork] + [//////synthesis.#F64_Fork] + [//////synthesis.#Text_Fork])))) (type: Mapping (Dictionary Synthesis Variable)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux index ebe9f4e75..7449d550b 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux @@ -174,7 +174,7 @@ (runtime: (lux::exec code globals) ($_ _.then - (_.exec code {.#Some globals}) + (_.exec {.#Some globals} code) (_.return ..unit))) (def: runtime::lux diff --git a/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux index 67b7250c3..5843f0670 100644 --- a/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux +++ b/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux @@ -17,9 +17,6 @@ ["[0]" sequence] ["[0]" set {"+" Set}] ["[0]" list ("[1]#[0]" functor)]]]]] - [program - [compositor - ["[0]" static {"+" Static}]]] ["[0]" // {"+" Packager} [// ["[0]" archive {"+" Output} diff --git a/stdlib/source/library/lux/type/poly.lux b/stdlib/source/library/lux/type/poly.lux index 10070fc6a..f2cecab1e 100644 --- a/stdlib/source/library/lux/type/poly.lux +++ b/stdlib/source/library/lux/type/poly.lux @@ -1,27 +1,27 @@ (.using - [library - [lux "*" - ["[0]" meta] - ["[0]" type] - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" maybe] - ["<>" parser ("[1]#[0]" monad) - ["<[0]>" type {"+" Env}] - ["<[0]>" code {"+" Parser}]]] - [data - ["[0]" product] - ["[0]" text] - [collection - ["[0]" list ("[1]#[0]" functor)] - ["[0]" dictionary]]] - [macro {"+" with_symbols} - ["[0]" code] - [syntax {"+" syntax:}]] - [math - [number - ["n" nat]]]]]) + [library + [lux "*" + ["[0]" meta] + ["[0]" type] + [abstract + ["[0]" monad {"+" do}]] + [control + ["[0]" maybe] + ["<>" parser ("[1]#[0]" monad) + ["<[0]>" type {"+" Env}] + ["<[0]>" code {"+" Parser}]]] + [data + ["[0]" product] + ["[0]" text] + [collection + ["[0]" list ("[1]#[0]" functor)] + ["[0]" dictionary]]] + [macro {"+" with_symbols} + ["[0]" code] + [syntax {"+" syntax:}]] + [math + [number + ["n" nat]]]]]) (def: polyP (Parser [Code Text Code]) @@ -61,14 +61,14 @@ ([.#Var] [.#Ex]) {.#Parameter idx} - (let [idx (<type>.adjusted_idx env idx)] + (let [idx (<type>.argument env idx)] (if (n.= 0 idx) (|> (dictionary.value idx env) maybe.trusted product.left (code env)) (` (.$ (~ (code.nat (-- idx))))))) {.#Apply {.#Primitive "" {.#End}} {.#Parameter idx}} - (case (<type>.adjusted_idx env idx) + (case (<type>.argument env idx) 0 (|> env (dictionary.value 0) maybe.trusted product.left (code env)) idx (undefined)) diff --git a/stdlib/source/test/lux/control/parser/type.lux b/stdlib/source/test/lux/control/parser/type.lux index 39656a32c..6476f9e30 100644 --- a/stdlib/source/test/lux/control/parser/type.lux +++ b/stdlib/source/test/lux/control/parser/type.lux @@ -6,6 +6,7 @@ [abstract [monad {"+" do}]] [control + [pipe {"+" case>}] ["[0]" try] ["[0]" exception]] [data @@ -150,6 +151,23 @@ /.parameter) {.#Parameter 0}) (!expect {try.#Success [quantification##binding argument##binding _]}))) + (_.cover [/.argument] + (let [argument? (: (-> Nat Nat Bit) + (function (_ @ expected) + (|> (/.result (<| (/.with_extension quantification) + (/.with_extension argument) + (/.with_extension quantification) + (/.with_extension argument) + (do //.monad + [env /.env + _ /.any] + (in (/.argument env @)))) + not_parameter) + (!expect (^multi {try.#Success [_ _ _ _ actual]} + (n.= expected actual))))))] + (and (argument? 0 2) + (argument? 1 3) + (argument? 2 0)))) (_.cover [/.wrong_parameter] (|> (/.result (<| (/.with_extension quantification) (/.with_extension argument) diff --git a/stdlib/source/test/lux/tool.lux b/stdlib/source/test/lux/tool.lux index 07824362b..22267936f 100644 --- a/stdlib/source/test/lux/tool.lux +++ b/stdlib/source/test/lux/tool.lux @@ -18,7 +18,8 @@ ["[1]/[0]" simple] ["[1]/[0]" complex] ["[1]/[0]" reference] - ["[1]/[0]" function]] + ["[1]/[0]" function] + ["[1]/[0]" case]] ... ["[1]/[0]" synthesis] ]]] ["[1][0]" meta "_" @@ -47,6 +48,7 @@ /phase/analysis/complex.test /phase/analysis/reference.test /phase/analysis/function.test + /phase/analysis/case.test ... /syntax.test ... /synthesis.test )) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux index c85e3896e..8ade96d8a 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux @@ -1,210 +1,636 @@ (.using + [library [lux "*" - [abstract - ["[0]" monad {"+" do}]] - [data - ["%" text/format {"+" format}]] - ["r" math/random {"+" Random} ("[1]#[0]" monad)] ["_" test {"+" Test}] + [abstract + [monad {"+" do}]] [control - pipe - ["[0]" maybe]] + [pipe {"+" case>}] + ["[0]" try {"+" Try} ("[1]#[0]" functor)] + ["[0]" exception]] [data ["[0]" product] - ["[0]" text ("[1]#[0]" equivalence)] - [number - ["n" nat]] - [collection - ["[0]" list ("[1]#[0]" monad)] - ["[0]" set]]] - ["[0]" type - ["[0]" check]] + ["[0]" text + ["%" format]]] [macro ["[0]" code]] - [meta - ["[0]" symbol]]] - [// - ["_[0]" primitive] - ["_[0]" structure]] - [\\ - ["[0]" / - ["/[1]" // - ["[1][0]" module] - ["[1][0]" type] - ["/[1]" // "_" - ["/[1]" // - ["[1][0]" analysis {"+" Analysis Variant Tag Operation}] - [/// - ["[0]" phase] - [meta - ["[0]" archive]]]]]]]]) - -(def: (exhaustive_weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - {.#End} - {.#End} - - {.#Item head+ {.#End}} - (list#each (|>> list) head+) - - {.#Item head+ tail++} - (do list.monad - [tail+ (exhaustive_weaving tail++) - head head+] - (in {.#Item head tail+})))) - -(def: .public (exhaustive_branches allow_literals? variantTC inputC) - (-> Bit (List [Code Code]) Code (Random (List Code))) - (case inputC - [_ {.#Bit _}] - (r#in (list (' #0) (' #1))) - - (^template [<tag> <gen> <wrapper>] - [[_ {<tag> _}] - (if allow_literals? - (do [! r.monad] - [?sample (r.maybe <gen>)] - (case ?sample - {.#Some sample} - (do ! - [else (exhaustive_branches allow_literals? variantTC inputC)] - (in (list& (<wrapper> sample) else))) - - {.#None} - (in (list (' _))))) - (r#in (list (' _))))]) - ([.#Nat r.nat code.nat] - [.#Int r.int code.int] - [.#Rev r.rev code.rev] - [.#Frac r.frac code.frac] - [.#Text (r.unicode 5) code.text]) - - (^ [_ {.#Tuple (list)}]) - (r#in (list (' []))) - - [_ {.#Tuple members}] - (do [! r.monad] - [member_wise_patterns (monad.each ! (exhaustive_branches allow_literals? variantTC) members)] - (in (|> member_wise_patterns - exhaustive_weaving - (list#each code.tuple)))) - - (^ [_ {.#Record (list)}]) - (r#in (list (' {}))) - - [_ {.#Record kvs}] - (do [! r.monad] - [.let [ks (list#each product.left kvs) - vs (list#each product.right kvs)] - member_wise_patterns (monad.each ! (exhaustive_branches allow_literals? variantTC) vs)] - (in (|> member_wise_patterns - exhaustive_weaving - (list#each (|>> (list.zipped/2 ks) code.record))))) - - (^ [_ {.#Form (list [_ {.#Tag _}] _)}]) - (do [! r.monad] - [bundles (monad.each ! - (function (_ [_tag _code]) - (do ! - [v_branches (exhaustive_branches allow_literals? variantTC _code)] - (in (list#each (function (_ pattern) (` ((~ _tag) (~ pattern)))) - v_branches)))) - variantTC)] - (in (list#conjoint bundles))) - - _ - (r#in (list)) - )) - -(def: .public (input variant_tags record_tags primitivesC) - (-> (List Code) (List Code) (List Code) (Random Code)) - (r.rec - (function (_ input) - ($_ r.either - (r#each product.right _primitive.primitive) - (do [! r.monad] - [choice (|> r.nat (# ! each (n.% (list.size variant_tags)))) - .let [choiceT (maybe.trusted (list.item choice variant_tags)) - choiceC (maybe.trusted (list.item choice primitivesC))]] - (in (` ((~ choiceT) (~ choiceC))))) - (do [! r.monad] - [size (|> r.nat (# ! each (n.% 3))) - elems (r.list size input)] - (in (code.tuple elems))) - (r#in (code.record (list.zipped/2 record_tags primitivesC))) - )))) - -(def: (branch body pattern) - (-> Code Code [Code Code]) - [pattern body]) + [math + ["[0]" random]] + ["[0]" type ("[1]#[0]" equivalence) + ["[0]" check]]]] + [\\library + ["[0]" / + ["/[1]" // + [// + ["[1][0]" extension + ["[1]/[0]" analysis "_" + ["[1]" lux]]] + [// + ["[1][0]" analysis + [evaluation {"+" Eval}] + ["[2][0]" macro] + ["[2][0]" scope] + ["[2][0]" module] + ["[2][0]" coverage] + ["[2][0]" type + ["$[1]" \\test]] + ["[2][0]" inference "_" + ["$[1]" \\test]]] + [/// + ["[1][0]" phase ("[1]#[0]" monad)] + [meta + ["[0]" archive]]]]]]]]) + +(def: (eval archive type term) + Eval + (//phase#in [])) + +(def: (expander macro inputs state) + //macro.Expander + {try.#Success ((.macro macro) inputs state)}) + +(def: analysis + //analysis.Phase + (//.phase ..expander)) + +(def: test|tuple + Test + (do [! random.monad] + [lux $//type.random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + module/0 (random.ascii/lower 1) + name/0 (# ! each (|>> [module/0]) (random.ascii/lower 2)) + [input/0 simple/0] $//inference.simple_parameter + [input/1 simple/1] $//inference.simple_parameter + [input/2 simple/2] $//inference.simple_parameter + $binding/0 (# ! each code.local_symbol (random.ascii/lower 3)) + $binding/1 (# ! each code.local_symbol (random.ascii/lower 4)) + $binding/2 (# ! each code.local_symbol (random.ascii/lower 5))] + ($_ _.and + (_.cover [/.tuple] + (let [tuple? (: (-> Type Type Bit) + (function (_ :input: :expected:) + (and (|> :input: + /.tuple + (check.result check.fresh_context) + (try#each (|>> product.right (type#= :expected:))) + (try.else false)) + (|> (do check.monad + [[@var :var:] check.var + _ (check.check :var: :input:)] + (/.tuple :var:)) + (check.result check.fresh_context) + (try#each (|>> product.right (type#= :expected:))) + (try.else false)))))] + (and (tuple? input/0 + (type.anonymous input/0)) + (tuple? (Tuple input/0 input/1 input/2) + (Tuple input/0 input/1 input/2)) + (tuple? {.#Named name/0 (Tuple input/0 input/1 input/2)} + (Tuple input/0 input/1 input/2)) + (tuple? (All (_ a b c) (Tuple input/0 input/1 input/2)) + (Tuple (All (_ a b c) input/0) + (All (_ a b c) input/1) + (All (_ a b c) input/2))) + (tuple? (type ((All (_ a b c) (Tuple a b c)) input/0 input/1 input/2)) + (Tuple input/0 input/1 input/2)) + (|> (do check.monad + [[@var :var:] check.var + _ (check.bind (All (_ a b c) (Tuple a b c)) @var)] + (/.tuple (type (:var: input/0 input/1 input/2)))) + (check.result check.fresh_context) + (try#each (|>> product.right (type#= (Tuple input/0 input/1 input/2)))) + (try.else false)) + (|> (do check.monad + [[@0 :0:] check.existential + [@1 :1:] check.existential + [_ :tuple:] (/.tuple (Ex (_ a b c) (Tuple a input/1 c))) + context check.context + _ (check.with context) + _ (check.check (Tuple :0: input/1 :1:) :tuple:) + _ (check.with context) + _ (check.check :tuple: (Tuple :0: input/1 :1:))] + (in true)) + (check.result check.fresh_context) + (try.else false))))) + (_.cover [/.non_tuple] + (and (|> (do check.monad + [[@var :var:] check.var + _ (/.tuple :var:)] + (in false)) + (check.result check.fresh_context) + (exception.otherwise (text.contains? (value@ exception.#label /.non_tuple)))) + (|> (do check.monad + [[@var :var:] check.var + _ (/.tuple (type (:var: input/0 input/1 input/2)))] + (in false)) + (check.result check.fresh_context) + (exception.otherwise (text.contains? (value@ exception.#label /.non_tuple)))) + (|> (do check.monad + [_ (/.tuple (type (input/0 input/1 input/2)))] + (in false)) + (check.result check.fresh_context) + (exception.otherwise (text.contains? (value@ exception.#label /.non_tuple)))) + (|> (do check.monad + [[@var :var:] check.var + _ (check.bind input/0 @var) + _ (/.tuple (type (:var: input/1 input/2)))] + (in false)) + (check.result check.fresh_context) + (exception.otherwise (text.contains? (value@ exception.#label /.non_tuple)))))) + ))) + +(def: (test|case lux [module/0 name/0] [input/0 simple/0] [input/1 simple/1] [input/2 simple/2] [$binding/0 $binding/1 $binding/2] [output/0 body/0] [output/1 body/1] [bit/0 nat/0]) + (-> Lux Symbol [Type Code] [Type Code] [Type Code] [Code Code Code] [Type Code] [Type Code] [Bit Nat] Bit) + (let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux] + case? (: (-> Code (List [Code Code]) Bit) + (function (_ input branches) + (|> (do //phase.monad + [analysis (|> (/.case ..analysis branches archive.empty input) + (//type.expecting output/0))] + (in true)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try.else false)))) + + body_types_mismatch! + (and (not (case? (code.bit bit/0) (list [(` #0) body/1] + [(` #1) body/1]))) + (not (case? (code.bit bit/0) (list [(` #0) body/0] + [(` #1) body/1])))) + + input_types_mismatch! + (and (not (case? (code.nat nat/0) (list [(` #0) body/0] + [(` #1) body/0]))) + (not (case? (code.bit bit/0) (list [(code.nat nat/0) body/0] + [$binding/0 body/0])))) + + handles_singletons! + (and (case? simple/0 (list [(` [(~ $binding/0)]) body/0])) + (case? simple/0 (list [(` [(~ simple/0)]) body/0] + [(` [(~ $binding/0)]) body/0])) + (case? (code.bit bit/0) (list [(` [#0]) body/0] + [(` [#1]) body/0]))) + + can_infer_body! + (|> (do //phase.monad + [[:actual: analysis] (|> (code.bit bit/0) + (/.case ..analysis + (list [(` #0) body/0] + [(` #1) body/0]) + archive.empty) + //type.inferring)] + (in (type#= output/0 :actual:))) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try.else false)) + + ensures_consistent_bodies! + (|> (do //phase.monad + [[:actual: analysis] (|> (code.bit bit/0) + (/.case ..analysis + (list [(` #0) body/0] + [(` #1) body/1]) + archive.empty) + //type.inferring)] + (in false)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try.else true))] + (and body_types_mismatch! + input_types_mismatch! + handles_singletons! + can_infer_body! + ensures_consistent_bodies! + + (case? (` []) + (list [(` []) body/0])) + (case? (` []) + (list [$binding/0 body/0])) + + (case? (code.bit bit/0) (list [(` #0) body/0] + [(` #1) body/0])) + (case? (code.bit bit/0) (list [(` #1) body/0] + [(` #0) body/0])) + + (case? simple/0 (list [$binding/0 body/0])) + (case? simple/0 (list [simple/0 body/0] + [$binding/0 body/0])) + + (case? (` [(~ simple/0) (~ simple/1) (~ simple/2)]) + (list [$binding/0 body/0])) + (case? (` [(~ simple/0) (~ simple/1) (~ simple/2)]) + (list [(` [(~ $binding/0) (~ $binding/1)]) body/0])) + (case? (` [(~ simple/0) (~ simple/1) (~ simple/2)]) + (list [(` [(~ simple/0) (~ simple/1) (~ simple/2)]) body/0] + ... 000 + [(` [(~ $binding/0) (~ simple/1) (~ simple/2)]) body/0] + ... 001 + [(` [(~ simple/0) (~ $binding/1) (~ simple/2)]) body/0] + ... 010 + [(` [(~ $binding/0) (~ $binding/1) (~ simple/2)]) body/0] + ... 011 + [(` [(~ simple/0) (~ simple/1) (~ $binding/2)]) body/0] + ... 100 + [(` [(~ $binding/0) (~ simple/1) (~ $binding/2)]) body/0] + ... 101 + [(` [(~ simple/0) (~ $binding/1) (~ $binding/2)]) body/0] + ... 110 + [(` [(~ $binding/0) (~ $binding/1) (~ $binding/2)]) body/0] + ... 111 + ))))) + +(def: (test|redundancy lux [module/0 name/0] [input/0 simple/0] [input/1 simple/1] [input/2 simple/2] [$binding/0 $binding/1 $binding/2] [output/0 body/0] bit/0) + (-> Lux Symbol [Type Code] [Type Code] [Type Code] [Code Code Code] [Type Code] Bit Bit) + (let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux] + redundant? (: (-> Code (List [Code Code]) Bit) + (function (_ input branches) + (|> (do //phase.monad + [analysis (|> (/.case ..analysis branches archive.empty input) + (//type.expecting output/0))] + (in true)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (exception.otherwise (text.contains? (value@ exception.#label //coverage.redundancy))))))] + (and (redundant? (` []) + (list [(` []) body/0] + [(` []) body/0])) + (redundant? (` []) + (list [$binding/0 body/0] + [$binding/0 body/0])) + (redundant? (code.bit bit/0) (list [(` #0) body/0] + [(` #1) body/0] + [(` #0) body/0])) + (redundant? (code.bit bit/0) (list [(` #0) body/0] + [(` #1) body/0] + [(` #1) body/0])) + (redundant? (code.bit bit/0) (list [(` #0) body/0] + [(` #1) body/0] + [$binding/0 body/0])) + (redundant? simple/0 (list [$binding/0 body/0] + [$binding/0 body/0])) + (redundant? simple/0 (list [simple/0 body/0] + [$binding/0 body/0] + [$binding/0 body/0])) + (redundant? simple/0 (list [$binding/0 body/0] + [simple/0 body/0])) + (redundant? (` [(~ simple/0) (~ simple/1) (~ simple/2)]) + (list [$binding/0 body/0] + [$binding/0 body/0])) + (redundant? (` [(~ simple/0) (~ simple/1) (~ simple/2)]) + (list [(` [(~ $binding/0) (~ $binding/1)]) body/0] + [(` [(~ $binding/0) (~ $binding/1)]) body/0])) + (redundant? (` [(~ simple/0) (~ simple/1) (~ simple/2)]) + (list [(` [(~ $binding/0) (~ $binding/1)]) body/0] + [$binding/0 body/0])) + (redundant? (` [(~ simple/0) (~ simple/1) (~ simple/2)]) + (list [$binding/0 body/0] + [(` [(~ $binding/0) (~ $binding/1)]) body/0]))))) + +(def: (test|variant lux [module/0 name/0] [input/0 simple/0] [input/1 simple/1] [input/2 simple/2] [$binding/0 $binding/1 $binding/2] [output/0 body/0] [output/1 body/1] [bit/0 nat/0]) + (-> Lux Symbol [Type Code] [Type Code] [Type Code] [Code Code Code] [Type Code] [Type Code] [Bit Nat] Bit) + (let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux] + + tag/0 (%.code $binding/0) + tag/1 (%.code $binding/1) + tag/2 (%.code $binding/2) + + tags/* (list tag/0 tag/1 tag/2) + :variant: {.#Named [module/0 name/0] (type.variant (list input/0 input/1 input/2))} + + tag/0 (code.symbol [module/0 tag/0]) + tag/1 (code.symbol [module/0 tag/1]) + tag/2 (code.symbol [module/0 tag/2]) + + variant? (: (-> Code (List [Code Code]) Bit) + (function (_ input branches) + (|> (do //phase.monad + [_ (//module.declare_labels false tags/* false :variant:) + analysis (|> (/.case ..analysis branches archive.empty input) + (//type.expecting output/0))] + (in true)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try.else false)))) + + can_bind! + (and (variant? (` {(~ tag/0) (~ simple/0)}) + (list [$binding/0 body/0])) + (variant? (` {(~ tag/1) (~ simple/1)}) + (list [$binding/0 body/0])) + (variant? (` {(~ tag/2) (~ simple/2)}) + (list [$binding/0 body/0]))) + + can_bind_variant! + (variant? (` {(~ tag/0) (~ simple/0)}) + (list [(` {(~ tag/0) (~ $binding/0)}) body/0] + [(` {(~ tag/1) (~ $binding/1)}) body/0] + [(` {(~ tag/2) (~ $binding/2)}) body/0])) + + can_bind_sum! + (variant? (` {(~ tag/0) (~ simple/0)}) + (list [(` {0 #0 (~ $binding/0)}) body/0] + [(` {1 #0 (~ $binding/1)}) body/0] + [(` {1 #1 (~ $binding/2)}) body/0])) + + can_check_exhaustiveness! + (variant? (` {(~ tag/0) (~ simple/0)}) + (list [(` {(~ tag/0) (~ simple/0)}) body/0] + [(` {(~ tag/0) (~ $binding/0)}) body/0] + + [(` {(~ tag/1) (~ simple/1)}) body/0] + [(` {(~ tag/1) (~ $binding/1)}) body/0] + + [(` {(~ tag/2) (~ simple/2)}) body/0] + [(` {(~ tag/2) (~ $binding/2)}) body/0])) + + can_bind_partial_variant! + (variant? (` {(~ tag/0) (~ simple/0)}) + (list [(` {(~ tag/0) (~ $binding/0)}) body/0] + [(` {0 #1 (~ $binding/1)}) body/0]))] + (and can_bind! + can_bind_variant! + can_bind_sum! + can_check_exhaustiveness! + can_bind_partial_variant! + ))) + +(def: (test|record lux [module/0 name/0] [input/0 simple/0] [input/1 simple/1] [input/2 simple/2] [$binding/0 $binding/1 $binding/2] [output/0 body/0] [output/1 body/1] [bit/0 nat/0]) + (-> Lux Symbol [Type Code] [Type Code] [Type Code] [Code Code Code] [Type Code] [Type Code] [Bit Nat] Bit) + (let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux] + + slot/0 (%.code $binding/0) + slot/1 (%.code $binding/1) + slot/2 (%.code $binding/2) + + slots/* (list slot/0 slot/1 slot/2) + :record: {.#Named [module/0 name/0] (type.tuple (list input/0 input/1 input/2))} + + slot/0 (code.symbol [module/0 slot/0]) + slot/1 (code.symbol [module/0 slot/1]) + slot/2 (code.symbol [module/0 slot/2]) + + record? (: (-> Code (List [Code Code]) Bit) + (function (_ input branches) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/* false :record:) + analysis (|> (/.case ..analysis branches archive.empty input) + (//type.expecting output/0))] + (in true)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try.else false)))) + + can_bind! + (record? (` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) + (list [$binding/0 body/0])) + + can_bind_record! + (record? (` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) + (list [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ $binding/1) + (~ slot/2) (~ $binding/2)]) body/0])) + + can_bind_tuple! + (record? (` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) + (list [(` [(~ $binding/0) (~ $binding/1) (~ $binding/2)]) body/0])) + + can_deduce_record! + (record? (` [(~ simple/0) + (~ simple/1) + (~ simple/2)]) + (list [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ $binding/1) + (~ slot/2) (~ $binding/2)]) body/0])) + + can_check_exhaustiveness! + (record? (` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) + (list [(` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) body/0] + ... 000 + [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) body/0] + ... 001 + [(` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ $binding/1) + (~ slot/2) (~ simple/2)]) body/0] + ... 010 + [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ $binding/1) + (~ slot/2) (~ simple/2)]) body/0] + ... 011 + [(` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ $binding/2)]) body/0] + ... 100 + [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ $binding/2)]) body/0] + ... 101 + [(` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ $binding/1) + (~ slot/2) (~ $binding/2)]) body/0] + ... 110 + [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ $binding/1) + (~ slot/2) (~ $binding/2)]) body/0] + ... 111 + )) + + cannot_repeat_slot! + (not (record? (` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) + (list [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ $binding/1) + (~ slot/2) (~ $binding/2) + (~ slot/2) (~ $binding/2)]) body/0]))) + + cannot_omit_slot! + (not (record? (` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) + (list [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ $binding/1)]) body/0]))) + + can_bind_partial_tuple! + (record? (` [(~ slot/0) (~ simple/0) + (~ slot/1) (~ simple/1) + (~ slot/2) (~ simple/2)]) + (list [(` [(~ $binding/0) (~ $binding/1)]) body/0]))] + (and can_bind! + can_bind_record! + can_bind_tuple! + can_deduce_record! + can_check_exhaustiveness! + cannot_repeat_slot! + cannot_omit_slot! + can_bind_partial_tuple!))) (def: .public test - (<| (_.context (symbol.module (symbol /._))) - (do [! r.monad] - [module_name (r.unicode 5) - variant_name (r.unicode 5) - record_name (|> (r.unicode 5) (r.only (|>> (text#= variant_name) not))) - size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - variant_tags (|> (r.set text.hash size (r.unicode 5)) (# ! each set.list)) - record_tags (|> (r.set text.hash size (r.unicode 5)) (# ! each set.list)) - primitivesTC (r.list size _primitive.primitive) - .let [primitivesT (list#each product.left primitivesTC) - primitivesC (list#each product.right primitivesTC) - code_tag (|>> [module_name] code.tag) - variant_tags+ (list#each code_tag variant_tags) - record_tags+ (list#each code_tag record_tags) - variantTC (list.zipped/2 variant_tags+ primitivesC)] - inputC (input variant_tags+ record_tags+ primitivesC) - [outputT outputC] (r.only (|>> product.left (same? Any) not) - _primitive.primitive) - .let [analyse_pm (function (_ branches) - (|> (/.case _primitive.phase branches archive.empty inputC) - (//type.with_type outputT) - ////analysis.with_scope - (do phase.monad - [_ (//module.declare_tags variant_tags false - {.#Named [module_name variant_name] - (type.variant primitivesT)}) - _ (//module.declare_tags record_tags false - {.#Named [module_name record_name] - (type.tuple primitivesT)})]) - (//module.with_module 0 module_name)))] - exhaustive_patterns (exhaustive_branches true variantTC inputC) - .let [exhaustive_branchesC (list#each (branch outputC) - exhaustive_patterns)]] + Test + (<| (_.covering /._) + (do [! random.monad] + [lux $//type.random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + module/0 (random.ascii/lower 1) + name/0 (random.ascii/lower 2) + [input/0 simple/0] $//inference.simple_parameter + [input/1 simple/1] $//inference.simple_parameter + [input/2 simple/2] $//inference.simple_parameter + [output/0 body/0] $//inference.simple_parameter + [output/1 body/1] (random.only (|>> product.left (same? output/0) not) + $//inference.simple_parameter) + $binding/0 (# ! each code.local_symbol (random.ascii/lower 3)) + $binding/1 (# ! each code.local_symbol (random.ascii/lower 4)) + $binding/2 (# ! each code.local_symbol (random.ascii/lower 5)) + extension/0 (# ! each code.text (random.ascii/lower 6)) + bit/0 random.bit + nat/0 random.nat] ($_ _.and - (_.test "Will reject empty pattern-matching (no branches)." - (|> (analyse_pm (list)) - _structure.check_fails)) - (_.test "Can analyse exhaustive pattern-matching." - (|> (analyse_pm exhaustive_branchesC) - _structure.check_succeeds)) - (let [non_exhaustive_branchesC (list.first (-- (list.size exhaustive_branchesC)) - exhaustive_branchesC)] - (_.test "Will reject non-exhaustive pattern-matching." - (|> (analyse_pm non_exhaustive_branchesC) - _structure.check_fails))) - (do ! - [redundant_patterns (exhaustive_branches false variantTC inputC) - redundancy_idx (|> r.nat (# ! each (n.% (list.size redundant_patterns)))) - .let [redundant_branchesC (<| (list!each (branch outputC)) - list.together - (list (list.first redundancy_idx redundant_patterns) - (list (maybe.trusted (list.item redundancy_idx redundant_patterns))) - (list.after redundancy_idx redundant_patterns)))]] - (_.test "Will reject redundant pattern-matching." - (|> (analyse_pm redundant_branchesC) - _structure.check_fails))) - (do ! - [[heterogeneousT heterogeneousC] (r.only (|>> product.left (check.subsumes? outputT) not) - _primitive.primitive) - heterogeneous_idx (|> r.nat (# ! each (n.% (list.size exhaustive_patterns)))) - .let [heterogeneous_branchesC (list.together (list (list.first heterogeneous_idx exhaustive_branchesC) - (list (let [[_pattern _body] (maybe.trusted (list.item heterogeneous_idx exhaustive_branchesC))] - [_pattern heterogeneousC])) - (list.after (++ heterogeneous_idx) exhaustive_branchesC)))]] - (_.test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (analyse_pm heterogeneous_branchesC) - _structure.check_fails))) + (_.cover [/.case] + (and (test|case lux [module/0 name/0] [input/0 simple/0] [input/1 simple/1] [input/2 simple/2] [$binding/0 $binding/1 $binding/2] [output/0 body/0] [output/1 body/1] [bit/0 nat/0]) + (test|redundancy lux [module/0 name/0] [input/0 simple/0] [input/1 simple/1] [input/2 simple/1] [$binding/0 $binding/1 $binding/2] [output/0 body/0] [bit/0]) + (test|variant lux [module/0 name/0] [input/0 simple/0] [input/1 simple/1] [input/2 simple/2] [$binding/0 $binding/1 $binding/2] [output/0 body/0] [output/1 body/1] [bit/0 nat/0]) + (test|record lux [module/0 name/0] [input/0 simple/0] [input/1 simple/1] [input/2 simple/2] [$binding/0 $binding/1 $binding/2] [output/0 body/0] [output/1 body/1] [bit/0 nat/0]))) + (_.cover [/.empty_branches] + (|> (do //phase.monad + [analysis (|> (/.case ..analysis (list) archive.empty simple/0) + (//type.expecting output/0))] + (in false)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (exception.otherwise (text.contains? (value@ exception.#label /.empty_branches))))) + (_.cover [/.non_exhaustive] + (let [non_exhaustive? (: (-> (List [Code Code]) Bit) + (function (_ branches) + (|> (do //phase.monad + [analysis (|> (/.case ..analysis branches archive.empty simple/0) + (//type.expecting output/0))] + (in false)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (exception.otherwise (text.contains? (value@ exception.#label /.non_exhaustive))))))] + (and (non_exhaustive? (list [simple/0 body/0])) + (not (non_exhaustive? (list [simple/0 body/0] + [$binding/0 body/0])))))) + (_.cover [/.invalid] + (let [invalid? (: (-> (List [Code Code]) Bit) + (function (_ branches) + (|> (do //phase.monad + [analysis (|> (/.case ..analysis branches archive.empty simple/0) + (//type.expecting output/0))] + (in false)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (exception.otherwise (text.contains? (value@ exception.#label /.invalid))))))] + (and (invalid? (list [(` ((~ extension/0) (~ $binding/0) (~ $binding/1) (~ $binding/2))) + body/0])) + (invalid? (list [(` {(~ extension/0) (~ $binding/0) (~ $binding/1) (~ $binding/2)}) + body/0])) + (invalid? (list [(` {[] (~ $binding/0) (~ $binding/1) (~ $binding/2)}) + body/0]))))) + (_.cover [/.sum_has_no_case] + (let [tag/0 (%.code $binding/0) + tag/1 (%.code $binding/1) + tag/2 (%.code $binding/2) + + tags/* (list tag/0 tag/1 tag/2) + :variant: {.#Named [module/0 name/0] (type.variant (list input/0 input/1 input/2))} + + tag/0 (code.symbol [module/0 tag/0]) + tag/1 (code.symbol [module/0 tag/1]) + tag/2 (code.symbol [module/0 tag/2])] + (|> (do //phase.monad + [_ (//module.declare_labels false tags/* false :variant:) + analysis (|> (` {(~ tag/0) (~ simple/0)}) + (/.case ..analysis + (list [(` {0 #0 (~ $binding/0)}) body/0] + [(` {1 #0 (~ $binding/1)}) body/0] + [(` {2 #0 (~ $binding/2)}) body/0] + [(` {2 #1 (~ $binding/2)}) body/0]) + archive.empty) + (//type.expecting output/0))] + (in false)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (exception.otherwise (text.contains? (value@ exception.#label /.sum_has_no_case)))))) + (_.cover [/.mismatch] + (let [slot/0 (%.code $binding/0) + slot/1 (%.code $binding/1) + slot/2 (%.code $binding/2) + + slots/* (list slot/0 slot/1 slot/2) + :record: {.#Named [module/0 name/0] (type.tuple (list input/0 input/1 input/2))} + + slot/0 (code.symbol [module/0 slot/0]) + slot/1 (code.symbol [module/0 slot/1]) + slot/2 (code.symbol [module/0 slot/2])] + (and (|> (do //phase.monad + [analysis (|> (` (~ simple/0)) + (/.case ..analysis + (list [(` {0 #0 (~ $binding/0)}) body/0] + [(` {1 #0 (~ $binding/1)}) body/0] + [(` {1 #1 (~ $binding/2)}) body/0]) + archive.empty) + (//type.expecting output/0))] + (in false)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (exception.otherwise (text.contains? (value@ exception.#label /.mismatch)))) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/* false :record:) + analysis (|> (` (~ simple/0)) + (/.case ..analysis + (list [(` [(~ slot/0) (~ $binding/0) + (~ slot/1) (~ $binding/1) + (~ slot/2) (~ $binding/2)]) body/0]) + archive.empty) + (//type.expecting output/0))] + (in false)) + //scope.with + (//module.with 0 module/0) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (exception.otherwise (text.contains? (value@ exception.#label /.mismatch))))))) + + ..test|tuple )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux index ed111c5e4..21813bb01 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux @@ -471,7 +471,7 @@ (function (_ expected input) (|> (do //phase.monad [_ (//module.declare_labels true slots/0 false :record:)] - (/.normal input)) + (/.normal false input)) (//module.with 0 module) (//phase#each product.right) (//phase.result state) @@ -484,7 +484,7 @@ (and (normal? (list) (list)) (normal? expected_record global_record) (normal? expected_record local_record) - (|> (/.normal tuple) + (|> (/.normal false tuple) (//phase.result state) (case> {try.#Success {.#None}} true diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux index b5f2e4fc4..a5f5953e6 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux @@ -38,7 +38,6 @@ ["[1][0]" analysis {"+" Analysis} [evaluation {"+" Eval}] ["[2][0]" macro] - ["[2][0]" scope] ["[2][0]" module] ["[2][0]" type ["$[1]" \\test]] diff --git a/stdlib/source/test/lux/tool/compiler/meta/archive/module/document.lux b/stdlib/source/test/lux/tool/compiler/meta/archive/module/document.lux index a73bf751d..a99e8eccf 100644 --- a/stdlib/source/test/lux/tool/compiler/meta/archive/module/document.lux +++ b/stdlib/source/test/lux/tool/compiler/meta/archive/module/document.lux @@ -80,7 +80,7 @@ (|> expected (/.document key/0) (binaryF.result (/.writer binaryF.nat)) - (<binary>.result (/.parser <binary>.nat)) + (<binary>.result (/.parser key/0 <binary>.nat)) (case> {try.#Success it} (and (/signature#= signature/0 (/.signature it)) (|> it |