diff options
Diffstat (limited to 'stdlib/source')
19 files changed, 1010 insertions, 648 deletions
diff --git a/stdlib/source/library/lux/math/number/i32.lux b/stdlib/source/library/lux/math/number/i32.lux index c08f261b1..e8967c412 100644 --- a/stdlib/source/library/lux/math/number/i32.lux +++ b/stdlib/source/library/lux/math/number/i32.lux @@ -1,16 +1,18 @@ (.using - [library - [lux {"-" i64} - [type {"+" :by_example}] - [abstract - [equivalence {"+" Equivalence}]] - [control - ["[0]" maybe]]]] - [// - ["[0]" i64 {"+" Sub}]]) + [library + [lux {"-" i64} + [type {"+" :by_example}] + [abstract + [equivalence {"+" Equivalence}]] + [control + ["[0]" maybe]]]] + [// + ["[0]" i64 {"+" Sub}]]) (def: sub - (maybe.trusted (i64.sub 32))) + ... TODO: Stop needing this coercion. + (:as (Sub (I64 (Primitive "#I32"))) + (maybe.trusted (i64.sub 32)))) (def: .public I32 Type diff --git a/stdlib/source/library/lux/target/jvm/bytecode.lux b/stdlib/source/library/lux/target/jvm/bytecode.lux index d7a29db73..17f2dd229 100644 --- a/stdlib/source/library/lux/target/jvm/bytecode.lux +++ b/stdlib/source/library/lux/target/jvm/bytecode.lux @@ -750,11 +750,10 @@ (do [! try.monad] [jump (# ! each //signed.value (/address.jump @from @to))] - (let [big? (n.> (//unsigned.value //unsigned.maximum/2) - (.nat (i.* (if (i.< +0 jump) - -1 - +1) - jump)))] + (let [big? (or (i.> (//signed.value //signed.maximum/2) + jump) + (i.< (//signed.value //signed.minimum/2) + jump))] (if big? (# ! each (|>> {.#Left}) (//signed.s4 jump)) (# ! each (|>> {.#Right}) (//signed.s2 jump)))))) diff --git a/stdlib/source/library/lux/target/jvm/encoding/signed.lux b/stdlib/source/library/lux/target/jvm/encoding/signed.lux index f4f664878..d33321b60 100644 --- a/stdlib/source/library/lux/target/jvm/encoding/signed.lux +++ b/stdlib/source/library/lux/target/jvm/encoding/signed.lux @@ -47,7 +47,7 @@ ["Value" (%.int value)] ["Scope (in bytes)" (%.nat scope)])) - (template [<bytes> <name> <size> <constructor> <maximum> <+> <->] + (template [<bytes> <name> <size> <constructor> <maximum> <minimum> <+> <->] [(with_expansions [<raw> (template.symbol [<name> "'"])] (abstract: <raw> Any) (type: .public <name> (Signed <raw>))) @@ -57,6 +57,11 @@ (def: .public <maximum> <name> (|> <bytes> (n.* i64.bits_per_byte) -- i64.mask :abstraction)) + + (def: .public <minimum> + <name> + (let [it (:representation <maximum>)] + (:abstraction (-- (i.- it +0))))) (def: .public <constructor> (-> Int (Try <name>)) @@ -81,9 +86,9 @@ [<-> i.-] )] - [1 S1 bytes/1 s1 maximum/1 +/1 -/1] - [2 S2 bytes/2 s2 maximum/2 +/2 -/2] - [4 S4 bytes/4 s4 maximum/4 +/4 -/4] + [1 S1 bytes/1 s1 maximum/1 minimum/1 +/1 -/1] + [2 S2 bytes/2 s2 maximum/2 minimum/2 +/2 -/2] + [4 S4 bytes/4 s4 maximum/4 minimum/4 +/4 -/4] ) (template [<name> <from> <to>] diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux index d4f217dd0..657096c10 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux @@ -17,7 +17,7 @@ ["[0]" location]]]] ["[0]" / "_" ["[1][0]" simple] - ["[1][0]" structure] + ["[1][0]" complex] ["[1][0]" reference] ["[1][0]" case] ["[1][0]" function] @@ -60,22 +60,22 @@ values)}) (case values {.#Item value {.#End}} - (/structure.tagged_sum compile tag archive value) + (/complex.variant compile tag archive value) _ - (/structure.tagged_sum compile tag archive (` [(~+ values)]))) + (/complex.variant compile tag archive (` [(~+ values)]))) (^ {.#Variant (list& [_ {.#Nat lefts}] [_ {.#Bit right?}] values)}) (case values {.#Item value {.#End}} - (/structure.sum compile lefts right? archive value) + (/complex.sum compile lefts right? archive value) _ - (/structure.sum compile lefts right? archive (` [(~+ values)]))) + (/complex.sum compile lefts right? archive (` [(~+ values)]))) (^ {.#Tuple elems}) - (/structure.record archive compile elems) + (/complex.record compile archive elems) _ (else code'))) 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 2b99be974..3eab189d4 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 @@ -25,7 +25,7 @@ ["[1][0]" coverage {"+" Coverage}] ["/[1]" // "_" ["[1][0]" scope] - ["[1][0]" structure] + ["[1][0]" complex] ["/[1]" // "_" ["[1][0]" extension] [// @@ -247,11 +247,11 @@ [location {.#Tuple sub_patterns}] (/.with_location location (do [! ///.monad] - [record (//structure.normal sub_patterns) + [record (//complex.normal sub_patterns) record_size,members,recordT (: (Operation (Maybe [Nat (List Code) Type])) (.case record {.#Some record} - (//structure.order true record) + (//complex.order true record) {.#None} (in {.#None})))] diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux index cdf65a6ad..678a626da 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux @@ -35,10 +35,14 @@ ["[1][0]" type] ["[1][0]" inference]] [/// - ["[1]" phase] + ["[1]" phase ("[1]#[0]" monad)] [meta [archive {"+" Archive}]]]]]]) +(exception: .public (not_a_quantified_type [type Type]) + (exception.report + ["Type" (%.type type)])) + (template [<name>] [(exception: .public (<name> [type Type members (List Code)]) @@ -50,36 +54,30 @@ [cannot_analyse_tuple] ) -(exception: .public (not_a_quantified_type [type Type]) - (exception.report - ["Type" (%.type type)])) - (template [<name>] [(exception: .public (<name> [type Type - tag Tag + lefts Nat + right? Bit code Code]) (exception.report ["Type" (%.type type)] - ["Tag" (%.nat tag)] + ["Lefts" (%.nat lefts)] + ["Right?" (%.bit right?)] ["Expression" (%.code code)]))] [invalid_variant_type] [cannot_analyse_variant] - [cannot_infer_numeric_tag] + [cannot_infer_sum] ) -(template [<name>] - [(exception: .public (<name> [key Symbol - record (List [Symbol Code])]) - (exception.report - ["Slot" (%.code (code.symbol key))] - ["Record" (%.code (code.tuple (|> record - (list#each (function (_ [keyI valC]) - (list (code.symbol keyI) valC))) - list#conjoint)))]))] - - [cannot_repeat_slot] - ) +(exception: .public (cannot_repeat_slot [key Symbol + record (List [Symbol Code])]) + (exception.report + ["Slot" (%.code (code.symbol key))] + ["Record" (%.code (code.tuple (|> record + (list#each (function (_ [keyI valC]) + (list (code.symbol keyI) valC))) + list#conjoint)))])) (exception: .public (slot_does_not_belong_to_record [key Symbol type Type]) @@ -108,7 +106,7 @@ (do [! ///.monad] [expectedT (///extension.lifted meta.expected_type) expectedT' (/type.check (check.clean expectedT))] - (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC] + (/.with_stack ..cannot_analyse_variant [expectedT' lefts right? valueC] (case expectedT {.#Sum _} (|> (analyse archive valueC) @@ -134,13 +132,13 @@ ... This is because there is no way of knowing how many ... cases the inferred sum type would have. _ - (/.except ..cannot_infer_numeric_tag [expectedT tag valueC]))) + (/.except ..cannot_infer_sum [expectedT lefts right? valueC]))) (^template [<tag> <instancer>] [{<tag> _} (do ! - [[instance_id instanceT] (/type.check <instancer>)] - (<| (/type.expecting (maybe.trusted (type.applied (list instanceT) expectedT))) + [[@instance :instance:] (/type.check <instancer>)] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) (again valueC)))]) ([.#UnivQ check.existential] [.#ExQ check.var]) @@ -156,7 +154,7 @@ (again valueC)) _ - (/.except ..invalid_variant_type [expectedT tag valueC]))) + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))) _ (case (type.applied (list inputT) funT) @@ -165,56 +163,72 @@ (again valueC)) {.#None} - (/.except ..not_a_quantified_type funT))) + (/.except ..not_a_quantified_type [funT]))) _ - (/.except ..invalid_variant_type [expectedT tag valueC]))))))) + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))))))) -(def: (typed_product archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) +(def: .public (variant analyse tag archive valueC) + (-> Phase Symbol Phase) (do [! ///.monad] - [expectedT (///extension.lifted meta.expected_type) - membersA+ (: (Operation (List Analysis)) - (loop [membersT+ (type.flat_tuple expectedT) - membersC+ members] - (case [membersT+ membersC+] - [{.#Item memberT {.#End}} {.#Item memberC {.#End}}] - (do ! - [memberA (<| (/type.expecting memberT) - (analyse archive memberC))] - (in (list memberA))) - - [{.#Item memberT {.#End}} _] - (<| (/type.expecting memberT) - (# ! each (|>> list) (analyse archive (code.tuple membersC+)))) - - [_ {.#Item memberC {.#End}}] - (<| (/type.expecting (type.tuple membersT+)) - (# ! each (|>> list) (analyse archive memberC))) - - [{.#Item memberT membersT+'} {.#Item memberC membersC+'}] - (do ! - [memberA (<| (/type.expecting memberT) - (analyse archive memberC)) - memberA+ (again membersT+' membersC+')] - (in {.#Item memberA memberA+})) - - _ - (/.except ..cannot_analyse_tuple [expectedT members]))))] - (in (/.tuple membersA+)))) - -(def: .public (product archive analyse membersC) - (-> Archive Phase (List Code) (Operation Analysis)) + [tag (///extension.lifted (meta.normal tag)) + [idx group variantT] (///extension.lifted (meta.tag tag)) + .let [case_size (list.size group) + [lefts right?] (/complex.choice case_size idx)] + expectedT (///extension.lifted meta.expected_type)] + (case expectedT + {.#Var _} + (do ! + [inferenceT (/inference.variant lefts right? variantT) + [inferredT valueA+] (/inference.general archive analyse inferenceT (list valueC))] + (in (/.variant [lefts right? (|> valueA+ list.head maybe.trusted)]))) + + _ + (..sum analyse lefts right? archive valueC)))) + +(def: (typed_product analyse expectedT archive members) + (-> Phase Type Archive (List Code) (Operation Analysis)) + (<| (let [! ///.monad]) + (# ! each (|>> /.tuple)) + (: (Operation (List Analysis))) + (loop [membersT+ (type.flat_tuple expectedT) + membersC+ members] + (case [membersT+ membersC+] + [{.#Item memberT {.#End}} {.#Item memberC {.#End}}] + (<| (# ! each (|>> list)) + (/type.expecting memberT) + (analyse archive memberC)) + + [{.#Item memberT {.#End}} _] + (<| (/type.expecting memberT) + (# ! each (|>> list) (analyse archive (code.tuple membersC+)))) + + [_ {.#Item memberC {.#End}}] + (<| (/type.expecting (type.tuple membersT+)) + (# ! each (|>> list) (analyse archive memberC))) + + [{.#Item memberT membersT+'} {.#Item memberC membersC+'}] + (do ! + [memberA (<| (/type.expecting memberT) + (analyse archive memberC)) + memberA+ (again membersT+' membersC+')] + (in {.#Item memberA memberA+})) + + _ + (/.except ..cannot_analyse_tuple [expectedT members]))))) + +(def: .public (product analyse archive membersC) + (-> Phase Archive (List Code) (Operation Analysis)) (do [! ///.monad] [expectedT (///extension.lifted meta.expected_type)] (/.with_stack ..cannot_analyse_tuple [expectedT membersC] (case expectedT {.#Product _} - (..typed_product archive analyse membersC) + (..typed_product analyse expectedT archive membersC) {.#Named name unnamedT} (<| (/type.expecting unnamedT) - (product archive analyse membersC)) + (product analyse archive membersC)) {.#Var id} (do ! @@ -222,10 +236,10 @@ (case ?expectedT' {.#Some expectedT'} (<| (/type.expecting expectedT') - (product archive analyse membersC)) + (product analyse archive membersC)) _ - ... Must do inference... + ... Must infer... (do ! [membersTA (monad.each ! (|>> (analyse archive) /type.inferring) membersC) @@ -236,9 +250,9 @@ (^template [<tag> <instancer>] [{<tag> _} (do ! - [[instance_id instanceT] (/type.check <instancer>)] - (<| (/type.expecting (maybe.trusted (type.applied (list instanceT) expectedT))) - (product archive analyse membersC)))]) + [[@instance :instance:] (/type.check <instancer>)] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (product analyse archive membersC)))]) ([.#UnivQ check.existential] [.#ExQ check.var]) @@ -250,7 +264,7 @@ (case ?funT' {.#Some funT'} (<| (/type.expecting {.#Apply inputT funT'}) - (product archive analyse membersC)) + (product analyse archive membersC)) _ (/.except ..invalid_tuple_type [expectedT membersC]))) @@ -259,7 +273,7 @@ (case (type.applied (list inputT) funT) {.#Some outputT} (<| (/type.expecting outputT) - (product archive analyse membersC)) + (product analyse archive membersC)) {.#None} (/.except ..not_a_quantified_type funT))) @@ -268,24 +282,6 @@ (/.except ..invalid_tuple_type [expectedT membersC]) )))) -(def: .public (tagged_sum analyse tag archive valueC) - (-> Phase Symbol Phase) - (do [! ///.monad] - [tag (///extension.lifted (meta.normal tag)) - [idx group variantT] (///extension.lifted (meta.tag tag)) - .let [case_size (list.size group) - [lefts right?] (/complex.choice case_size idx)] - expectedT (///extension.lifted meta.expected_type)] - (case expectedT - {.#Var _} - (do ! - [inferenceT (/inference.variant lefts right? variantT) - [inferredT valueA+] (/inference.general archive analyse inferenceT (list valueC))] - (in (/.variant [lefts right? (|> valueA+ list.head maybe.trusted)]))) - - _ - (..sum analyse lefts right? archive valueC)))) - ... There cannot be any ambiguity or improper syntax when analysing ... records, so they must be normalized for further analysis. ... Normalization just means that all the tags get resolved to their @@ -302,10 +298,10 @@ (again tail {.#Item [slotH valueH] output})) {.#End} - (# ///.monad in {.#Some output}) + (///#in {.#Some output}) _ - (# ///.monad in {.#None})))) + (///#in {.#None})))) (def: (local_binding? name) (-> Text (Meta Bit)) @@ -361,25 +357,25 @@ (case record ... empty_record = empty_tuple = unit/any = [] {.#End} - (# ///.monad in {.#Some [0 (list) Any]}) + (///#in {.#Some [0 (list) .Any]}) {.#Item [head_k head_v] _} (case head_k ["" head_k'] (if pattern_matching? - (# ///.monad in {.#None}) + (///#in {.#None}) (do ///.monad [local_binding? (///extension.lifted - (local_binding? head_k'))] + (..local_binding? head_k'))] (if local_binding? - (order' head_k record) - (in {.#None})))) + (in {.#None}) + (order' head_k record)))) _ (order' head_k record)))) -(def: .public (record archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) +(def: .public (record analyse archive members) + (-> Phase Archive (List Code) (Operation Analysis)) (case members (^ (list)) //simple.unit @@ -395,24 +391,24 @@ {try.#Success [_ slot_set recordT]} (case (list.size slot_set) 1 (analyse archive singletonC) - _ (..product archive analyse members)) + _ (..product analyse archive members)) _ - (..product archive analyse members))) + (..product analyse archive members))) _ (do [! ///.monad] [?members (normal members)] (case ?members {.#None} - (..product archive analyse members) + (..product analyse archive members) {.#Some slots} (do ! [record_size,membersC,recordT (..order false slots)] (case record_size,membersC,recordT {.#None} - (..product archive analyse members) + (..product analyse archive members) {.#Some [record_size membersC recordT]} (do ! @@ -425,4 +421,4 @@ (in (/.tuple membersA))) _ - (..product archive analyse membersC))))))))) + (..product analyse archive membersC))))))))) 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 2b146414f..4d6c7e712 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 @@ -2180,19 +2180,18 @@ [[_ parameterT] check.existential] (in [parameterJ parameterT]))))) +(def: (matched? [sub sub_method subJT] [super super_method superJT]) + (-> [(Type Class) Text (Type Method)] [(Type Class) Text (Type Method)] Bit) + (and (# descriptor.equivalence = (jvm.descriptor super) (jvm.descriptor sub)) + (text#= super_method sub_method) + (jvm#= superJT subJT))) + (def: (mismatched_methods super_set sub_set) (-> (List [(Type Class) Text (Type Method)]) (List [(Type Class) Text (Type Method)]) (List [(Type Class) Text (Type Method)])) - (list.only (function (_ [sub sub_name subJT]) - (|> super_set - (list.only (function (_ [super super_name superJT]) - (and (jvm#= super sub) - (text#= super_name sub_name) - (jvm#= superJT subJT)))) - list.size - (n.= 1) - not)) + (list.only (function (_ sub) + (not (list.any? (matched? sub) super_set))) sub_set)) (exception: .public (class_parameter_mismatch [name Text @@ -2254,7 +2253,7 @@ methods) .let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods) invalid_overriden_methods (mismatched_methods available_methods overriden_methods)] - _ (phase.assertion ..missing_abstract_methods [required_abstract_methods missing_abstract_methods] + _ (phase.assertion ..missing_abstract_methods [required_abstract_methods overriden_methods] (list.empty? missing_abstract_methods)) _ (phase.assertion ..invalid_overriden_methods [available_methods invalid_overriden_methods] (list.empty? invalid_overriden_methods))] diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux index e6953ac59..7e286955e 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux @@ -1,32 +1,30 @@ (.using - [library - [lux "*" - ["[0]" ffi] - [abstract - ["[0]" monad {"+" do}]] - [control - ["<>" parser - ["<[0]>" code {"+" Parser}]]] - [data - [collection - ["[0]" array {"+" Array}] - ["[0]" dictionary] - ["[0]" list]]] - ["[0]" type - ["[0]" check]] - ["@" target - ["_" lua]]]] + [library + [lux "*" + ["[0]" ffi] + [abstract + ["[0]" monad {"+" do}]] + [control + ["<>" parser + ["<[0]>" code {"+" Parser}]]] + [data + [collection + ["[0]" array {"+" Array}] + ["[0]" dictionary] + ["[0]" list]]] + ["[0]" type + ["[0]" check]] + ["@" target + ["_" lua]]]] + [// + ["/" lux {"+" custom}] [// - ["/" lux {"+" custom}] - [// - ["[0]" bundle] - [// - ["[0]" analysis "_" - ["[1]/[0]" type]] - [// - ["[0]" analysis {"+" Analysis Operation Phase Handler Bundle}] - [/// - ["[0]" phase]]]]]]) + ["[0]" bundle] + [/// + ["[0]" analysis {"+" Analysis Operation Phase Handler Bundle} + ["[1]/[0]" type]] + [/// + ["[0]" phase]]]]]) (def: Nil (for [@.lua ffi.Nil] @@ -46,10 +44,10 @@ [<code>.any (function (_ extension phase archive lengthC) (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] + [lengthA (analysis/type.expecting Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.check check.var) + _ (analysis/type.inference (type (Array varT)))] (in {analysis.#Extension extension (list lengthA)})))])) (def: array::length @@ -58,10 +56,10 @@ [<code>.any (function (_ extension phase archive arrayC) (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] + [[var_id varT] (analysis/type.check check.var) + arrayA (analysis/type.expecting (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.inference Nat)] (in {analysis.#Extension extension (list arrayA)})))])) (def: array::read @@ -70,12 +68,12 @@ [(<>.and <code>.any <code>.any) (function (_ extension phase archive [indexC arrayC]) (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + [var_id varT] (analysis/type.check check.var) + arrayA (analysis/type.expecting (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.inference varT)] (in {analysis.#Extension extension (list indexA arrayA)})))])) (def: array::write @@ -84,14 +82,14 @@ [($_ <>.and <code>.any <code>.any <code>.any) (function (_ extension phase archive [indexC valueC arrayC]) (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + [var_id varT] (analysis/type.check check.var) + valueA (analysis/type.expecting varT + (phase archive valueC)) + arrayA (analysis/type.expecting (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.inference (type (Array varT)))] (in {analysis.#Extension extension (list indexA valueA arrayA)})))])) (def: array::delete @@ -100,12 +98,12 @@ [($_ <>.and <code>.any <code>.any) (function (_ extension phase archive [indexC arrayC]) (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + [var_id varT] (analysis/type.check check.var) + arrayA (analysis/type.expecting (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.inference (type (Array varT)))] (in {analysis.#Extension extension (list indexA arrayA)})))])) (def: bundle::array @@ -125,9 +123,9 @@ [($_ <>.and <code>.text <code>.any) (function (_ extension phase archive [fieldC objectC]) (do phase.monad - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - _ (analysis/type.infer .Any)] + [objectA (analysis/type.expecting ..Object + (phase archive objectC)) + _ (analysis/type.inference .Any)] (in {analysis.#Extension extension (list (analysis.text fieldC) objectA)})))])) @@ -137,10 +135,10 @@ [($_ <>.and <code>.text <code>.any (<>.some <code>.any)) (function (_ extension phase archive [methodC objectC inputsC]) (do [! phase.monad] - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - inputsA (monad.each ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] + [objectA (analysis/type.expecting ..Object + (phase archive objectC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference .Any)] (in {analysis.#Extension extension (list& (analysis.text methodC) objectA inputsA)})))])) @@ -162,9 +160,9 @@ [<code>.any (function (_ extension phase archive inputC) (do [! phase.monad] - [inputA (analysis/type.with_type (type <fromT>) - (phase archive inputC)) - _ (analysis/type.infer (type <toT>))] + [inputA (analysis/type.expecting (type <fromT>) + (phase archive inputC)) + _ (analysis/type.inference (type <toT>))] (in {analysis.#Extension extension (list inputA)})))]))] [utf8::encode Text (array.Array (I64 Any))] @@ -185,7 +183,7 @@ [<code>.text (function (_ extension phase archive name) (do phase.monad - [_ (analysis/type.infer Any)] + [_ (analysis/type.inference Any)] (in {analysis.#Extension extension (list (analysis.text name))})))])) (def: lua::apply @@ -194,10 +192,10 @@ [($_ <>.and <code>.any (<>.some <code>.any)) (function (_ extension phase archive [abstractionC inputsC]) (do [! phase.monad] - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.each ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] + [abstractionA (analysis/type.expecting ..Function + (phase archive abstractionC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference Any)] (in {analysis.#Extension extension (list& abstractionA inputsA)})))])) (def: lua::power @@ -206,11 +204,11 @@ [($_ <>.and <code>.any <code>.any) (function (_ extension phase archive [powerC baseC]) (do [! phase.monad] - [powerA (analysis/type.with_type Frac - (phase archive powerC)) - baseA (analysis/type.with_type Frac - (phase archive baseC)) - _ (analysis/type.infer Frac)] + [powerA (analysis/type.expecting Frac + (phase archive powerC)) + baseA (analysis/type.expecting Frac + (phase archive baseC)) + _ (analysis/type.inference Frac)] (in {analysis.#Extension extension (list powerA baseA)})))])) (def: lua::import @@ -219,7 +217,7 @@ [<code>.text (function (_ extension phase archive name) (do phase.monad - [_ (analysis/type.infer ..Object)] + [_ (analysis/type.inference ..Object)] (in {analysis.#Extension extension (list (analysis.text name))})))])) (def: lua::function @@ -229,9 +227,9 @@ (function (_ extension phase archive [arity abstractionC]) (do phase.monad [.let [inputT (type.tuple (list.repeated arity Any))] - abstractionA (analysis/type.with_type (-> inputT Any) - (phase archive abstractionC)) - _ (analysis/type.infer ..Function)] + abstractionA (analysis/type.expecting (-> inputT Any) + (phase archive abstractionC)) + _ (analysis/type.inference ..Function)] (in {analysis.#Extension extension (list (analysis.nat arity) abstractionA)})))])) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux index b5899731b..e2ed832c1 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux @@ -20,20 +20,22 @@ ["/[1]" // "_" ["[1][0]" reference] ["//[1]" /// "_" - [analysis {"+" Abstraction Application Analysis}] + [analysis {"+" Abstraction Reification Analysis}] [synthesis {"+" Synthesis}] - ["[1][0]" generation {"+" Context}] + ["[1][0]" generation] ["//[1]" /// "_" [arity {"+" Arity}] ["[1][0]" phase ("[1]#[0]" monad)] [meta [archive - ["[0]" dependency]]] + ["[0]" unit]] + ["[0]" cache "_" + ["[1]" artifact]]] [reference [variable {"+" Register Variable}]]]]]]) (def: .public (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) + (Generator (Reification Synthesis)) (do [! ///////phase.monad] [functionO (expression archive functionS) argsO+ (monad.each ! (expression archive) argsS+)] @@ -63,13 +65,13 @@ (|>> ++ //case.register)) (def: (@scope function_name) - (-> Context Label) + (-> unit.ID Label) (_.label (format (///reference.artifact function_name) "_scope"))) (def: .public (function statement expression archive [environment arity bodyS]) (-> Phase! (Generator (Abstraction Synthesis))) (do [! ///////phase.monad] - [dependencies (dependency.dependencies archive bodyS) + [dependencies (cache.dependencies archive bodyS) [function_name body!] (/////generation.with_new_context archive dependencies (do ! [@scope (# ! each ..@scope diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux index 06135b240..59d88e612 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux @@ -26,8 +26,9 @@ ["//[1]" /// "_" ["[1][0]" phase] [meta - [archive {"+" Archive} - ["[0]" dependency]]] + [archive {"+" Archive}] + ["[0]" cache "_" + ["[1]" artifact]]] [reference [variable {"+" Register}]]]]]]) @@ -82,7 +83,7 @@ ... true loop _ (do [! ///////phase.monad] - [dependencies (dependency.dependencies archive bodyS) + [dependencies (cache.dependencies archive bodyS) [[artifact_module artifact_id] [initsO+ scope!]] (/////generation.with_new_context archive dependencies (scope! statement expression archive true [start initsS+ bodyS])) .let [@loop (_.var (///reference.artifact [artifact_module artifact_id])) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux index 40525dd00..794bc1fd7 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux @@ -36,7 +36,8 @@ [variable {"+" Register}]] [meta [archive {"+" Output Archive} - ["[0]" artifact {"+" Registry}]]]]]]) + ["[0]" registry {"+" Registry}] + ["[0]" unit]]]]]]) (template [<name> <base>] [(type: .public <name> @@ -425,8 +426,8 @@ (do ///////phase.monad [_ (/////generation.execute! ..runtime) _ (/////generation.save! ..module_id {.#None} ..runtime)] - (in [(|> artifact.empty - (artifact.resource true artifact.no_dependencies) + (in [(|> registry.empty + (registry.resource true unit.none) product.right) (sequence.sequence [..module_id {.#None} diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux index 97784804e..80028d75e 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux @@ -11,7 +11,7 @@ ["///[1]" //// "_" ["[1][0]" synthesis {"+" Synthesis}] [analysis - [composite {"+" Variant Tuple}]] + [complex {"+" Variant Tuple}]] ["//[1]" /// "_" ["[1][0]" phase ("[1]#[0]" monad)]]]]) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 2b72f6dad..b859f456f 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -431,94 +431,97 @@ (n.= (..sum n/0 n/1 n/1) (..sum' n/0 n/1 n/1)))) (_.cover [/.using] - (with_expansions [<referral> ("lux in-module" "library/lux" library/lux.refer) - <alias> (static.random code.text (random.ascii/lower 1)) - <definition> (static.random code.local_symbol (random.ascii/lower 1)) - <module/0> (static.random code.text (random.ascii/lower 2)) - <module/0>' (template.symbol [<module/0>]) - <module/1> (static.random code.text (random.ascii/lower 3)) - <module/1>' (template.symbol [<module/1>]) - <module/2> (static.random code.text (random.ascii/lower 4)) - <module/2>' (template.symbol [<module/2>]) - <m0/1> (template.text [<module/0> "/" <module/1>]) - <//> (template.text [// <module/2>']) - <//>' (template.symbol [<//>]) - <\\> (template.text [\\ <module/2>']) - <\\>' (template.symbol [<\\>]) - <m0/2> (template.text [<module/0> "/" <module/2>]) - <m2/1> (template.text [<module/2> "/" <module/1>]) - <m0/1/2> (template.text [<module/0> "/" <module/1> "/" <module/2>]) - <open/0> (template.text [<module/0> "#[0]"])] - (and (~~ (template [<input> <pattern>] - [(with_expansions [<input>' (macro.final <input>)] - (case (' [<input>']) - (^code <pattern>) - true - - _ - false))] - - [(.using [<module/0>']) - [("lux def module" [])]] - - [(.using [<alias> <module/0>' "*"]) - [("lux def module" [[<module/0> <alias>]]) - (<referral> <module/0> "*")]] - - [(.using [<alias> <module/0>' {"+" <definition>}]) - [("lux def module" [[<module/0> <alias>]]) - (<referral> <module/0> {"+" <definition>})]] - - [(.using [<alias> <module/0>' {"-" <definition>}]) - [("lux def module" [[<module/0> <alias>]]) - (<referral> <module/0> {"-" <definition>})]] - - [(.using [<alias> <module/0>' "_"]) - [("lux def module" [])]] - - [(.using [<module/0>' - [<alias> <module/1>']]) - [("lux def module" [[<m0/1> <alias>]]) - (<referral> <m0/1>)]] - - [(.using ["[0]" <module/0>' - ["[0]" <module/1>']]) - [("lux def module" [[<module/0> <module/0>] - [<m0/1> <module/1>]]) - (<referral> <module/0>) - (<referral> <m0/1>)]] - - [(.using ["[0]" <module/0>' "_" - ["[1]" <module/1>']]) - [("lux def module" [[<m0/1> <module/0>]]) - (<referral> <m0/1>)]] - - [(.using ["[0]" <module/0>' "_" - ["[1]" <module/1>' "_" - ["[2]" <module/2>']]]) - [("lux def module" [[<m0/1/2> <module/0>]]) - (<referral> <m0/1/2>)]] - - [(.using [<module/0>' - ["[0]" <module/1>' - ["[0]" <//>']]]) - [("lux def module" [[<m0/1> <module/1>] - [<m0/2> <//>]]) - (<referral> <m0/1>) - (<referral> <m0/2>)]] - - [(.using ["[0]" <module/0>' - [<module/1>' - ["[0]" <\\>']]]) - [("lux def module" [[<module/0> <module/0>] - [<m2/1> <\\>]]) - (<referral> <module/0>) - (<referral> <m2/1>)]] - - [(.using ["[0]" <module/0>' ("[1]#[0]" <definition>)]) - [("lux def module" [[<module/0> <module/0>]]) - (<referral> <module/0> (<open/0> <definition>))]] - ))))) + (`` (with_expansions [<referral> ("lux in-module" "library/lux" library/lux.refer) + <alias> (static.random code.text (random.ascii/lower 1)) + <definition> (static.random code.local_symbol (random.ascii/lower 1)) + <module/0> (static.random code.text (random.ascii/lower 2)) + <module/0>' (template.symbol [<module/0>]) + <module/1> (static.random code.text (random.ascii/lower 3)) + <module/1>' (template.symbol [<module/1>]) + <module/2> (static.random code.text (random.ascii/lower 4)) + <module/2>' (template.symbol [<module/2>]) + <m0/1> (template.text [<module/0> "/" <module/1>]) + <//> (template.text [// <module/2>']) + <//>' (template.symbol [<//>]) + <\\> (template.text [\\ <module/2>']) + <\\>' (template.symbol [<\\>]) + <m0/2> (template.text [<module/0> "/" <module/2>]) + <m2/1> (template.text [<module/2> "/" <module/1>]) + <m0/1/2> (template.text [<module/0> "/" <module/1> "/" <module/2>]) + <open/0> (template.text [<module/0> "#[0]"])] + (and (~~ (template [<input> <pattern>] + [(with_expansions [<input>' (macro.final <input>)] + (let [scenario (: (-> Any Bit) + (function (_ _) + (case (' [<input>']) + (^code <pattern>) + true + + _ + false)))] + (scenario [])))] + + [(.using [<module/0>']) + [("lux def module" [])]] + + [(.using [<alias> <module/0>' "*"]) + [("lux def module" [[<module/0> <alias>]]) + (<referral> <module/0> "*")]] + + [(.using [<alias> <module/0>' {"+" <definition>}]) + [("lux def module" [[<module/0> <alias>]]) + (<referral> <module/0> {"+" <definition>})]] + + [(.using [<alias> <module/0>' {"-" <definition>}]) + [("lux def module" [[<module/0> <alias>]]) + (<referral> <module/0> {"-" <definition>})]] + + [(.using [<alias> <module/0>' "_"]) + [("lux def module" [])]] + + [(.using [<module/0>' + [<alias> <module/1>']]) + [("lux def module" [[<m0/1> <alias>]]) + (<referral> <m0/1>)]] + + [(.using ["[0]" <module/0>' + ["[0]" <module/1>']]) + [("lux def module" [[<module/0> <module/0>] + [<m0/1> <module/1>]]) + (<referral> <module/0>) + (<referral> <m0/1>)]] + + [(.using ["[0]" <module/0>' "_" + ["[1]" <module/1>']]) + [("lux def module" [[<m0/1> <module/0>]]) + (<referral> <m0/1>)]] + + [(.using ["[0]" <module/0>' "_" + ["[1]" <module/1>' "_" + ["[2]" <module/2>']]]) + [("lux def module" [[<m0/1/2> <module/0>]]) + (<referral> <m0/1/2>)]] + + [(.using [<module/0>' + ["[0]" <module/1>' + ["[0]" <//>']]]) + [("lux def module" [[<m0/1> <module/1>] + [<m0/2> <//>]]) + (<referral> <m0/1>) + (<referral> <m0/2>)]] + + [(.using ["[0]" <module/0>' + [<module/1>' + ["[0]" <\\>']]]) + [("lux def module" [[<module/0> <module/0>] + [<m2/1> <\\>]]) + (<referral> <module/0>) + (<referral> <m2/1>)]] + + [(.using ["[0]" <module/0>' ("[1]#[0]" <definition>)]) + [("lux def module" [[<module/0> <module/0>]]) + (<referral> <module/0> (<open/0> <definition>))]] + )))))) )))))) (/.type: for_type/variant @@ -1278,7 +1281,7 @@ (<| (_.covering /._) (`` (`` (_.in_parallel (list ..test|lux - + /abstract.test /control.test /data.test @@ -1288,7 +1291,7 @@ /locale.test /macro.test /math.test - + /meta.test /program.test /static.test diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index 63cb46691..4c923924b 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -9,8 +9,9 @@ ["[0]" ruby] ["[0]" php] ["[0]" scheme] - ["[0]" jvm - (~~ (.for ["JVM" (~~ (.as_is ["[0]" class] + ["[0]" jvm "_" + (~~ (.for ["JVM" (~~ (.as_is ["[1]" bytecode] + ["[0]" class] ["[0]" version] [encoding ["[0]" name]]))] @@ -113,9 +114,10 @@ (# ! each (|>> {synthesis.#Extension self}))))) (generation: (..generation self phase archive [pass_through <synthesis>.any]) - (for [@.jvm - (# phase.monad each (|>> {jvm.#Embedded} sequence.sequence) - (phase archive pass_through))] + (for [... @.jvm + ... (# phase.monad each (|>> {jvm.#Embedded} sequence.sequence) + ... (phase archive pass_through)) + ] (phase archive pass_through))) (analysis: (..dummy_generation self phase archive []) @@ -127,7 +129,8 @@ (generation: (..dummy_generation self phase archive []) (# phase.monad in (for [@.jvm - (sequence.sequence {jvm.#Constant {jvm.#LDC {jvm.#String self}}}) + (jvm.string self) + ... (sequence.sequence {jvm.#Constant {jvm.#LDC {jvm.#String self}}}) @.js (js.string self) @.python (python.unicode self) diff --git a/stdlib/source/test/lux/target/lua.lux b/stdlib/source/test/lux/target/lua.lux index 2558f41c8..0bee11310 100644 --- a/stdlib/source/test/lux/target/lua.lux +++ b/stdlib/source/test/lux/target/lua.lux @@ -584,6 +584,18 @@ (/.return $outcome))) (/.closure (list)) (/.apply (list))))) + (_.cover [/.error/2] + (expression (|>> (:as Frac) (f.= expected)) + (|> ($_ /.then + (/.let (list $verdict $outcome) (/.pcall/1 (/.closure (list) + ($_ /.then + (/.statement (/.error/2 (/.float expected) (/.int +2))) + (/.return (/.float dummy)))))) + (/.if $verdict + (/.return (/.float dummy)) + (/.return $outcome))) + (/.closure (list)) + (/.apply (list))))) ))) (def: test|function diff --git a/stdlib/source/test/lux/tool.lux b/stdlib/source/test/lux/tool.lux index 82e92e097..6fa62a7da 100644 --- a/stdlib/source/test/lux/tool.lux +++ b/stdlib/source/test/lux/tool.lux @@ -15,7 +15,8 @@ ["[1][0]" phase "_" ["[1]/[0]" extension] ["[1]/[0]" analysis "_" - ["[1]/[0]" simple]] + ["[1]/[0]" simple] + ["[1]/[0]" complex]] ... ["[1]/[0]" synthesis] ]]] ["[1][0]" meta "_" @@ -33,6 +34,7 @@ /meta/archive.test /phase/extension.test /phase/analysis/simple.test + /phase/analysis/complex.test ... /syntax.test ... /synthesis.test )) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux index 672a8f25a..1a5ece06a 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux @@ -37,7 +37,7 @@ [phase ["[2][0]" analysis] ["[2][0]" extension - ["[1]/[0]"analysis "_" + ["[1]/[0]" analysis "_" ["[1]" lux]]]] [/// ["[2][0]" phase ("[1]#[0]" monad)] @@ -205,14 +205,14 @@ [type/0 term/0] ..simple_parameter [type/1 term/1] (random.only (|>> product.left (same? type/0) not) ..simple_parameter) - types/*,terms,* (random.list arity ..simple_parameter) + types/*,terms/* (random.list arity ..simple_parameter) tag (# ! each (n.% arity) random.nat) .let [[lefts right?] (//complex.choice arity tag)] arbitrary_right? random.bit] ($_ _.and (_.cover [/.variant] - (let [variantT (type.variant (list#each product.left types/*,terms,*)) - [tagT tagC] (|> types/*,terms,* + (let [variantT (type.variant (list#each product.left types/*,terms/*)) + [tagT tagC] (|> types/*,terms/* (list.item tag) (maybe.else [Any (' [])])) variant?' (: (-> Type (Maybe Type) Nat Bit Code Bit) @@ -295,7 +295,7 @@ existential_types_affect_dependent_cases! ))) (_.cover [/.not_a_variant] - (let [[tagT tagC] (|> types/*,terms,* + (let [[tagT tagC] (|> types/*,terms/* (list.item tag) (maybe.else [Any (' [])]))] (|> (/.variant lefts right? tagT) @@ -314,7 +314,7 @@ [type/0 term/0] ..simple_parameter [type/1 term/1] (random.only (|>> product.left (same? type/0) not) ..simple_parameter) - types/*,terms,* (random.list arity ..simple_parameter) + types/*,terms/* (random.list arity ..simple_parameter) .let [record? (: (-> Type (Maybe Type) Nat (List Code) Bit) (function (_ record expected arity terms) (|> (do /phase.monad @@ -335,8 +335,8 @@ (/phase#each product.right) (/phase.result state) (try.else false)))) - record (type.tuple (list#each product.left types/*,terms,*)) - terms (list#each product.right types/*,terms,*)]] + record (type.tuple (list#each product.left types/*,terms/*)) + terms (list#each product.right types/*,terms/*)]] ($_ _.and (_.cover [/.record] (let [can_infer_record! 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 new file mode 100644 index 000000000..89c341c2a --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux @@ -0,0 +1,650 @@ +(.using + [library + [lux "*" + ["_" test {"+" Test}] + [abstract + [monad {"+" do}]] + [control + [pipe {"+" case>}] + ["[0]" maybe ("[1]#[0]" functor)] + ["[0]" try {"+" Try} ("[1]#[0]" functor)] + ["[0]" exception {"+" Exception}]] + [data + ["[0]" product] + ["[0]" bit ("[1]#[0]" equivalence)] + ["[0]" text + ["%" format {"+" format}]] + [collection + ["[0]" list ("[1]#[0]" monad monoid)] + ["[0]" set]]] + [macro + ["[0]" code]] + [math + ["[0]" random {"+" Random} ("[1]#[0]" monad)] + [number + ["n" nat] + ["f" frac]]] + [meta + ["[0]" symbol + ["$[1]" \\test]]] + ["[0]" type ("[1]#[0]" equivalence) + ["[0]" check]]]] + [\\library + ["[0]" / + ["/[1]" // + [// + ["[1][0]" extension + ["[1]/[0]" analysis "_" + ["[1]" lux]]] + [// + ["[1][0]" analysis {"+" Analysis} + [evaluation {"+" Eval}] + ["[2][0]" macro] + ["[2][0]" type] + ["[2][0]" module] + ["[2][0]" complex]] + [/// + ["[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: random_state + (Random Lux) + (do random.monad + [version random.nat + host (random.ascii/lower 1)] + (in (//analysis.state (//analysis.info version host))))) + +(def: primitive + (Random Type) + (do random.monad + [name (random.ascii/lower 1)] + (in {.#Primitive name (list)}))) + +(def: analysis + //analysis.Phase + (//.phase ..expander)) + +(def: (failure? exception try) + (All (_ e a) (-> (Exception e) (Try a) Bit)) + (case try + {try.#Success _} + false + + {try.#Failure error} + (text.contains? (value@ exception.#label exception) error))) + +(def: simple_parameter + (Random [Type Code]) + (`` ($_ random.either + (~~ (template [<type> <random> <code>] + [(random#each (|>> <code> [<type>]) <random>)] + + [.Bit random.bit code.bit] + [.Nat random.nat code.nat] + [.Int random.int code.int] + [.Rev random.rev code.rev] + [.Frac (random.only (|>> f.not_a_number? not) random.frac) code.frac] + [.Text (random.ascii/lower 1) code.text] + )) + ))) + +(def: (analysed? expected actual) + (-> Code Analysis Bit) + (case [expected actual] + (^ [[_ {.#Tuple (list)}] (//analysis.unit)]) + true + + (^ [[_ {.#Tuple expected}] (//analysis.tuple actual)]) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (analysed? expected actual)) + (list.zipped/2 expected actual))) + + (^template [<expected> <actual>] + [(^ [[_ {<expected> expected}] (<actual> actual)]) + (same? expected actual)]) + ([.#Bit //analysis.bit] + [.#Nat //analysis.nat] + [.#Int //analysis.int] + [.#Rev //analysis.rev] + [.#Frac //analysis.frac] + [.#Text //analysis.text]) + + _ + false)) + +(def: test|sum + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + name ($symbol.random 1 1) + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + types/*,terms/* (random.list arity ..simple_parameter) + tag (# ! each (n.% arity) random.nat) + .let [[lefts right?] (//complex.choice arity tag) + [tagT tagC] (|> types/*,terms/* + (list.item tag) + (maybe.else [Any (' [])]))]] + ($_ _.and + (_.cover [/.sum] + (let [variantT (type.variant (list#each product.left types/*,terms/*)) + sum? (: (-> Type Nat Bit Code Bit) + (function (_ type lefts right? code) + (|> (do //phase.monad + [analysis (|> (/.sum ..analysis lefts right? archive.empty code) + (//type.expecting type))] + (in (case analysis + (^ (//analysis.variant [lefts' right?' analysis])) + (and (n.= lefts lefts') + (bit#= right? right?') + (..analysed? code analysis)) + + _ + false))) + (//module.with_module 0 (product.left name)) + (//phase#each product.right) + (//phase.result state) + (try.else false))))] + (and (sum? variantT lefts right? tagC) + (sum? {.#Named name variantT} lefts right? tagC) + (|> (do //phase.monad + [[@var varT] (//type.check check.var) + _ (//type.check (check.check varT variantT)) + analysis (|> (/.sum ..analysis lefts right? archive.empty tagC) + (//type.expecting varT))] + (in (case analysis + (^ (//analysis.variant [lefts' right?' it])) + (and (n.= lefts lefts') + (bit#= right? right?') + (..analysed? tagC it)) + + _ + false))) + (//module.with_module 0 (product.left name)) + (//phase#each product.right) + (//phase.result state) + (try.else false)) + (and (sum? (type (Maybe tagT)) 0 #0 (` [])) + (sum? (type (Maybe tagT)) 0 #1 tagC)) + (and (sum? (type (All (_ a) (Maybe a))) 0 #0 (` [])) + (not (sum? (type (All (_ a) (Maybe a))) 0 #1 tagC))) + (and (sum? (type (Ex (_ a) (Maybe a))) 0 #0 (` [])) + (sum? (type (Ex (_ a) (Maybe a))) 0 #1 tagC))))) + (_.for [/.cannot_analyse_variant] + (let [failure? (: (All (_ a) (-> (Exception a) (//analysis.Operation Any) Bit)) + (function (_ exception analysis) + (let [it (//phase.result state analysis)] + (and (..failure? /.cannot_analyse_variant it) + (..failure? exception it)))))] + ($_ _.and + (_.cover [/.invalid_variant_type] + (and (|> (/.sum ..analysis lefts right? archive.empty tagC) + (//type.expecting tagT) + (failure? /.invalid_variant_type)) + (|> (do //phase.monad + [[@var varT] (//type.check check.var)] + (|> (/.sum ..analysis lefts right? archive.empty tagC) + (//type.expecting (type (varT tagT))))) + (failure? /.invalid_variant_type)))) + (_.cover [/.cannot_infer_sum] + (|> (do //phase.monad + [[@var varT] (//type.check check.var)] + (|> (/.sum ..analysis lefts right? archive.empty tagC) + (//type.expecting varT))) + (failure? /.cannot_infer_sum))) + ))) + ))) + +(def: test|variant + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + name ($symbol.random 1 1) + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + types/*,terms/* (random.list arity ..simple_parameter) + tag (# ! each (n.% arity) random.nat) + .let [[lefts right?] (//complex.choice arity tag)] + tags (|> (random.ascii/lower 1) + (random.set text.hash arity) + (# ! each set.list)) + .let [module (product.left name) + sumT (type.variant (list#each product.left types/*,terms/*)) + variantT {.#Named name sumT} + [tagT tagC] (|> types/*,terms/* + (list.item tag) + (maybe.else [Any (' [])])) + tag (|> tags + (list.item tag) + (maybe.else ""))]] + ($_ _.and + ..test|sum + (_.cover [/.variant] + (let [expected_variant? (: (-> Symbol Bit) + (function (_ tag) + (|> (do //phase.monad + [_ (//module.declare_labels false tags false variantT) + analysis (|> (/.variant ..analysis tag archive.empty tagC) + (//type.expecting variantT))] + (in (case analysis + (^ (//analysis.variant [lefts' right?' analysis])) + (and (n.= lefts lefts') + (bit#= right? right?') + (..analysed? tagC analysis)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false)))) + inferred_variant? (: (-> Symbol Bit) + (function (_ tag) + (|> (do //phase.monad + [_ (//module.declare_labels false tags false variantT) + [actualT analysis] (|> (/.variant ..analysis tag archive.empty tagC) + //type.inferring)] + (in (case analysis + (^ (//analysis.variant [lefts' right?' analysis])) + (and (n.= lefts lefts') + (bit#= right? right?') + (..analysed? tagC analysis) + (type#= variantT actualT)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false))))] + (and (expected_variant? [module tag]) + (expected_variant? ["" tag]) + (inferred_variant? [module tag]) + (inferred_variant? ["" tag]) + + ... TODO: Test what happens when tags are shadowed by local bindings. + ))) + ))) + +(type: (Triple a) + [a a a]) + +(def: test|product + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + name ($symbol.random 1 1) + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + types/*,terms/* (random.list arity ..simple_parameter) + [type/0 term/0] ..simple_parameter + [type/1 term/1] ..simple_parameter + [type/2 term/2] ..simple_parameter + .let [module (product.left name) + productT (type.tuple (list#each product.left types/*,terms/*)) + expected (list#each product.right types/*,terms/*)]] + ($_ _.and + (_.cover [/.product] + (let [product? (: (-> Type (List Code) Bit) + (function (_ type expected) + (|> (do //phase.monad + [analysis (|> expected + (/.product ..analysis archive.empty) + (//type.expecting type))] + (in (case analysis + (^ (//analysis.tuple actual)) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (..analysed? expected actual)) + (list.zipped/2 expected actual))) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false))))] + (and (product? productT expected) + (product? {.#Named name productT} expected) + (product? (type (Ex (_ a) [a a])) (list term/0 term/0)) + (not (product? (type (All (_ a) [a a])) (list term/0 term/0))) + (product? (type (Triple type/0)) (list term/0 term/0 term/0)) + (|> (do //phase.monad + [[@var varT] (//type.check check.var) + _ (//type.check (check.check varT productT)) + analysis (|> expected + (/.product ..analysis archive.empty) + (//type.expecting varT))] + (in (case analysis + (^ (//analysis.tuple actual)) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (..analysed? expected actual)) + (list.zipped/2 expected actual))) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false)) + (|> (do //phase.monad + [[:inferred: analysis] (|> expected + (/.product ..analysis archive.empty) + //type.inferring)] + (in (case analysis + (^ (//analysis.tuple actual)) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (..analysed? expected actual)) + (list.zipped/2 expected actual)) + (type#= productT :inferred:)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false)) + (|> (do [! //phase.monad] + [[@var varT] (//type.check check.var) + [:inferred: analysis] (//type.inferring + (do ! + [_ (//type.inference (Tuple type/0 type/1 varT))] + (/.product ..analysis archive.empty + (list term/0 term/1 term/2 term/2 term/2))))] + (in (case analysis + (^ (//analysis.tuple (list analysis/0 analysis/1 (//analysis.tuple (list analysis/2 analysis/3 analysis/4))))) + (and (type#= (Tuple type/0 type/1 type/2 type/2 type/2) + :inferred:) + (..analysed? term/0 analysis/0) + (..analysed? term/1 analysis/1) + (..analysed? term/2 analysis/2) + (..analysed? term/2 analysis/3) + (..analysed? term/2 analysis/4)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false)) + (|> (do [! //phase.monad] + [analysis (|> (list term/0 term/1 (code.tuple (list term/2 term/2 term/2))) + (/.product ..analysis archive.empty) + (//type.expecting (Tuple type/0 type/1 type/2 type/2 type/2)))] + (in (case analysis + (^ (//analysis.tuple (list analysis/0 analysis/1 (//analysis.tuple (list analysis/2 analysis/3 analysis/4))))) + (and (..analysed? term/0 analysis/0) + (..analysed? term/1 analysis/1) + (..analysed? term/2 analysis/2) + (..analysed? term/2 analysis/3) + (..analysed? term/2 analysis/4)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false))))) + (_.for [/.cannot_analyse_tuple] + (_.cover [/.invalid_tuple_type] + (let [failure? (: (All (_ a) (-> (Exception a) (//analysis.Operation Any) Bit)) + (function (_ exception operation) + (let [it (//phase.result state operation)] + (and (..failure? /.cannot_analyse_tuple it) + (..failure? exception it)))))] + (and (|> expected + (/.product ..analysis archive.empty) + (//type.expecting (|> types/*,terms/* + list.head + (maybe#each product.left) + (maybe.else .Any))) + (failure? /.invalid_tuple_type)) + (|> (do //phase.monad + [[@var varT] (//type.check check.var)] + (|> expected + (/.product ..analysis archive.empty) + (//type.expecting (type (varT type/0))))) + (failure? /.invalid_tuple_type)))))) + ))) + +(def: test|record + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + name ($symbol.random 1 1) + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + slice (# ! each (|>> (n.% (-- arity)) ++) random.nat) + [type/0 term/0] ..simple_parameter + slot/0 (random.ascii/lower 1) + types/*,terms/* (random.list arity ..simple_parameter) + slots/0 (|> (random.ascii/lower 1) + (random.set text.hash arity)) + slots/1 (|> (random.ascii/lower 1) + (random.only (|>> (set.member? slots/0) not)) + (random.set text.hash arity)) + .let [slots/0 (set.list slots/0) + slots/1 (set.list slots/1) + module (product.left name) + :record: {.#Named name (type.tuple (list#each product.left types/*,terms/*))} + tuple (list#each product.right types/*,terms/*) + local_record (|> tuple + (list.zipped/2 (list#each (|>> [""] code.symbol) slots/0)) + (list#each (function (_ [slot value]) + (list slot value))) + list#conjoint) + global_record (|> tuple + (list.zipped/2 (list#each (|>> [module] code.symbol) slots/0)) + (list#each (function (_ [slot value]) + (list slot value))) + list#conjoint) + expected_record (list.zipped/2 (list#each (|>> [module]) slots/0) + tuple) + head_slot/0 (|> slots/0 list.head maybe.trusted) + head_term/0 (|> types/*,terms/* list.head maybe.trusted product.right) + head_slot/1 (|> slots/1 list.head maybe.trusted) + slots/01 (case slots/1 + {.#Item _ tail} + {.#Item head_slot/0 tail} + + _ + slots/0)]] + ($_ _.and + (_.cover [/.normal] + (let [normal? (: (-> (List [Symbol Code]) (List Code) Bit) + (function (_ expected input) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (/.normal input)) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (case> {try.#Success {.#Some actual}} + (let [(^open "list#[0]") (list.equivalence (product.equivalence symbol.equivalence code.equivalence))] + (list#= expected (list.reversed actual))) + + _ + false))))] + (and (normal? (list) (list)) + (normal? expected_record global_record) + (normal? expected_record local_record) + (|> (/.normal tuple) + (//phase.result state) + (case> {try.#Success {.#None}} + true + + _ + false))))) + (_.cover [/.order] + (let [local_record (list.zipped/2 (list#each (|>> [""]) slots/0) tuple) + global_record (list.zipped/2 (list#each (|>> [module]) slots/0) tuple) + ordered? (: (-> Bit (List [Symbol Code]) Bit) + (function (_ pattern_matching? input) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (/.order pattern_matching? input)) + //analysis.with_scope + (//module.with_module 0 module) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (case> {try.#Success {.#Some [actual_arity actual_tuple actual_type]}} + (and (n.= arity actual_arity) + (# code.equivalence = (code.tuple tuple) (code.tuple actual_tuple)) + (type#= :record: actual_type)) + + _ + false)))) + unit? (: (-> Bit Bit) + (function (_ pattern_matching?) + (|> (/.order false (list)) + (//phase.result state) + (case> (^ {try.#Success {.#Some [0 (list) actual_type]}}) + (same? .Any actual_type) + + _ + false))))] + (and (ordered? false global_record) + (ordered? false (list.reversed global_record)) + (ordered? false local_record) + (ordered? false (list.reversed local_record)) + + (ordered? true global_record) + (ordered? true (list.reversed global_record)) + (not (ordered? true local_record)) + (not (ordered? true (list.reversed local_record))) + + (unit? false) + (unit? true) + + ... TODO: Test what happens when slots are shadowed by local bindings. + ))) + (_.cover [/.cannot_repeat_slot] + (let [repeated? (: (-> Bit Bit) + (function (_ pattern_matching?) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (/.order pattern_matching? (list.repeated arity [[module head_slot/0] head_term/0]))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (..failure? /.cannot_repeat_slot))))] + (and (repeated? false) + (repeated? true)))) + (_.cover [/.record_size_mismatch] + (let [local_record (list.zipped/2 (list#each (|>> [""]) slots/0) tuple) + global_record (list.zipped/2 (list#each (|>> [module]) slots/0) tuple) + mismatched? (: (-> Bit (List [Symbol Code]) Bit) + (function (_ pattern_matching? input) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (/.order pattern_matching? input)) + //analysis.with_scope + (//module.with_module 0 module) + (//phase.result state) + (..failure? /.record_size_mismatch))))] + (and (mismatched? false (list.first slice local_record)) + (mismatched? false (list#composite local_record (list.first slice local_record))) + + (mismatched? false (list.first slice global_record)) + (mismatched? true (list.first slice global_record)) + (mismatched? false (list#composite global_record (list.first slice global_record))) + (mismatched? true (list#composite global_record (list.first slice global_record)))))) + (_.cover [/.slot_does_not_belong_to_record] + (let [local_record (list.zipped/2 (list#each (|>> [""]) slots/01) tuple) + global_record (list.zipped/2 (list#each (|>> [module]) slots/01) tuple) + mismatched? (: (-> Bit (List [Symbol Code]) Bit) + (function (_ pattern_matching? input) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:) + _ (//module.declare_labels true slots/1 false :record:)] + (/.order pattern_matching? input)) + //analysis.with_scope + (//module.with_module 0 module) + (//phase.result state) + (..failure? /.slot_does_not_belong_to_record))))] + (and (mismatched? false local_record) + + (mismatched? false global_record) + (mismatched? true global_record)))) + (_.cover [/.record] + (let [record? (: (-> Type (List Text) (List Code) Code Bit) + (function (_ type slots tuple expected) + (|> (do //phase.monad + [_ (//module.declare_labels true slots false type)] + (/.record ..analysis archive.empty tuple)) + (//type.expecting type) + //analysis.with_scope + (//module.with_module 0 module) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try#each (analysed? expected)) + (try.else false)))) + inferred? (: (-> (List Code) Bit) + (function (_ record) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (//type.inferring + (/.record ..analysis archive.empty record))) + //analysis.with_scope + (//module.with_module 0 module) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try#each (function (_ [actual_type actual_term]) + (and (same? :record: actual_type) + (analysed? (code.tuple tuple) actual_term)))) + (try.else false))))] + (and (record? {.#Named name .Any} (list) (list) (' [])) + (record? {.#Named name type/0} (list) (list term/0) term/0) + (record? {.#Named name type/0} (list slot/0) (list term/0) term/0) + (record? :record: slots/0 tuple (code.tuple tuple)) + (record? :record: slots/0 local_record (code.tuple tuple)) + (record? :record: slots/0 global_record (code.tuple tuple)) + (inferred? local_record) + (inferred? global_record)))) + ))) + +(def: .public test + (<| (_.covering /._) + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + types/*,terms/* (random.list arity ..simple_parameter) + [type/0 term/0] ..simple_parameter + [type/1 term/1] ..simple_parameter + tag (# ! each (n.% arity) random.nat) + .let [[lefts right?] (//complex.choice arity tag)]] + ($_ _.and + ..test|sum + ..test|variant + ..test|product + ..test|record + (_.cover [/.not_a_quantified_type] + (and (|> (/.sum ..analysis lefts right? archive.empty term/0) + (//type.expecting (type (type/0 type/1))) + (//phase.result state) + (..failure? /.not_a_quantified_type)) + (|> types/*,terms/* + (list#each product.right) + (/.product ..analysis archive.empty) + (//type.expecting (type (type/0 type/1))) + (//phase.result state) + (..failure? /.not_a_quantified_type)))) + )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux deleted file mode 100644 index 7521d7878..000000000 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ /dev/null @@ -1,311 +0,0 @@ -(.using - [lux "*" - [abstract - ["[0]" monad {"+" do}]] - [data - ["%" text/format {"+" format}]] - ["r" math/random {"+" Random}] - ["_" test {"+" Test}] - [control - pipe - ["[0]" maybe] - ["[0]" try]] - [data - ["[0]" bit ("[1]#[0]" equivalence)] - ["[0]" product] - ["[0]" text] - [number - ["n" nat]] - [collection - ["[0]" list ("[1]#[0]" functor)] - ["[0]" set]]] - ["[0]" type - ["[0]" check]] - [macro - ["[0]" code]] - [meta - ["[0]" symbol]]] - [// - ["_[0]" primitive]] - [\\ - ["[0]" / - ["/[1]" // - ["[1][0]" module] - ["[1][0]" type] - ["/[1]" // "_" - ["/[1]" // - ["[1][0]" analysis {"+" Analysis Variant Tag Operation}] - [/// - ["[0]" phase] - [meta - ["[0]" archive]]]]]]]]) - -(template [<name> <on_success> <on_error>] - [(def: .public <name> - (All (_ a) (-> (Operation a) Bit)) - (|>> (phase.result _primitive.state) - (case> {try.#Success _} - <on_success> - - _ - <on_error>)))] - - [check_succeeds true false] - [check_fails false true] - ) - -(def: (check_sum' tag size variant) - (-> Tag Nat (Variant Analysis) Bit) - (let [expected//right? (n.= (-- size) tag) - expected//lefts (if expected//right? - (-- tag) - tag) - actual//right? (value@ ////analysis.#right? variant) - actual//lefts (value@ ////analysis.#lefts variant)] - (and (n.= expected//lefts - actual//lefts) - (bit#= expected//right? - actual//right?)))) - -(def: (check_sum type tag size analysis) - (-> Type Tag Nat (Operation Analysis) Bit) - (|> analysis - (//type.with_type type) - (phase.result _primitive.state) - (case> (^ {try.#Success (////analysis.variant variant)}) - (check_sum' tag size variant) - - _ - false))) - -(def: (with_tags module tags type) - (All (_ a) (-> Text (List //module.Tag) Type (Operation a) (Operation [Module a]))) - (|>> (do phase.monad - [_ (//module.declare_tags tags false type)]) - (//module.with_module 0 module))) - -(def: (check_variant module tags expectedT variantT tag analysis) - (-> Text (List //module.Tag) Type Type Tag (Operation Analysis) Bit) - (|> analysis - (with_tags module tags variantT) - (//type.with_type expectedT) - (phase.result _primitive.state) - (case> (^ {try.#Success [_ (////analysis.variant variant)]}) - (check_sum' tag (list.size tags) variant) - - _ - false))) - -(def: (correct_size? size) - (-> Nat (-> Analysis Bit)) - (|>> (case> (^ (////analysis.tuple elems)) - (|> elems - list.size - (n.= size)) - - _ - false))) - -(def: (check_record module tags expectedT recordT size analysis) - (-> Text (List //module.Tag) Type Type Nat (Operation Analysis) Bit) - (|> analysis - (with_tags module tags recordT) - (//type.with_type expectedT) - (phase.result _primitive.state) - (case> {try.#Success [_ productA]} - (correct_size? size productA) - - _ - false))) - -(def: sum - (do [! r.monad] - [size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - choice (|> r.nat (# ! each (n.% size))) - primitives (r.list size _primitive.primitive) - +choice (|> r.nat (# ! each (n.% (++ size)))) - [_ +valueC] _primitive.primitive - .let [variantT (type.variant (list#each product.left primitives)) - [valueT valueC] (maybe.trusted (list.item choice primitives)) - +size (++ size) - +primitives (list.together (list (list.first choice primitives) - (list [{.#Parameter 1} +valueC]) - (list.after choice primitives))) - [+valueT +valueC] (maybe.trusted (list.item +choice +primitives)) - +variantT (type.variant (list#each product.left +primitives))]] - (<| (_.context (%.symbol (symbol /.sum))) - ($_ _.and - (_.test "Can analyse." - (check_sum variantT choice size - (/.sum _primitive.phase choice archive.empty valueC))) - (_.test "Can analyse through bound type-vars." - (|> (do phase.monad - [[_ varT] (//type.with_env check.var) - _ (//type.with_env - (check.check varT variantT))] - (//type.with_type varT - (/.sum _primitive.phase choice archive.empty valueC))) - (phase.result _primitive.state) - (case> (^ {try.#Success (////analysis.variant variant)}) - (check_sum' choice size variant) - - _ - false))) - (_.test "Cannot analyse through unbound type-vars." - (|> (do phase.monad - [[_ varT] (//type.with_env check.var)] - (//type.with_type varT - (/.sum _primitive.phase choice archive.empty valueC))) - check_fails)) - (_.test "Can analyse through existential quantification." - (|> (//type.with_type (type.ex_q 1 +variantT) - (/.sum _primitive.phase +choice archive.empty +valueC)) - check_succeeds)) - (_.test "Can analyse through universal quantification." - (let [check_outcome (if (not (n.= choice +choice)) - check_succeeds - check_fails)] - (|> (//type.with_type (type.univ_q 1 +variantT) - (/.sum _primitive.phase +choice archive.empty +valueC)) - check_outcome))) - )))) - -(def: product - (do [! r.monad] - [size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - primitives (r.list size _primitive.primitive) - choice (|> r.nat (# ! each (n.% size))) - [_ +valueC] _primitive.primitive - .let [tupleT (type.tuple (list#each product.left primitives)) - [singletonT singletonC] (|> primitives (list.item choice) maybe.trusted) - +primitives (list.together (list (list.first choice primitives) - (list [{.#Parameter 1} +valueC]) - (list.after choice primitives))) - +tupleT (type.tuple (list#each product.left +primitives))]] - (<| (_.context (%.symbol (symbol /.product))) - ($_ _.and - (_.test "Can analyse." - (|> (//type.with_type tupleT - (/.product archive.empty _primitive.phase (list#each product.right primitives))) - (phase.result _primitive.state) - (case> {try.#Success tupleA} - (correct_size? size tupleA) - - _ - false))) - (_.test "Can infer." - (|> (//type.with_inference - (/.product archive.empty _primitive.phase (list#each product.right primitives))) - (phase.result _primitive.state) - (case> {try.#Success [_type tupleA]} - (and (check.subsumes? tupleT _type) - (correct_size? size tupleA)) - - _ - false))) - (_.test "Can analyse singleton." - (|> (//type.with_type singletonT - (_primitive.phase archive.empty (` [(~ singletonC)]))) - check_succeeds)) - (_.test "Can analyse through bound type-vars." - (|> (do phase.monad - [[_ varT] (//type.with_env check.var) - _ (//type.with_env - (check.check varT (type.tuple (list#each product.left primitives))))] - (//type.with_type varT - (/.product archive.empty _primitive.phase (list#each product.right primitives)))) - (phase.result _primitive.state) - (case> {try.#Success tupleA} - (correct_size? size tupleA) - - _ - false))) - (_.test "Can analyse through existential quantification." - (|> (//type.with_type (type.ex_q 1 +tupleT) - (/.product archive.empty _primitive.phase (list#each product.right +primitives))) - check_succeeds)) - (_.test "Cannot analyse through universal quantification." - (|> (//type.with_type (type.univ_q 1 +tupleT) - (/.product archive.empty _primitive.phase (list#each product.right +primitives))) - check_fails)) - )))) - -(def: variant - (do [! r.monad] - [size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - tags (|> (r.set text.hash size (r.unicode 5)) (# ! each set.list)) - choice (|> r.nat (# ! each (n.% size))) - other_choice (|> r.nat (# ! each (n.% size)) (r.only (|>> (n.= choice) not))) - primitives (r.list size _primitive.primitive) - module_name (r.unicode 5) - type_name (r.unicode 5) - .let [with_name (|>> {.#Named [module_name type_name]}) - varT {.#Parameter 1} - primitivesT (list#each product.left primitives) - [choiceT choiceC] (maybe.trusted (list.item choice primitives)) - [other_choiceT other_choiceC] (maybe.trusted (list.item other_choice primitives)) - monoT (type.variant primitivesT) - polyT (|> (type.variant (list.together (list (list.first choice primitivesT) - (list varT) - (list.after (++ choice) primitivesT)))) - (type.univ_q 1)) - choice_tag (maybe.trusted (list.item choice tags)) - other_choice_tag (maybe.trusted (list.item other_choice tags))]] - (<| (_.context (%.symbol (symbol /.tagged_sum))) - ($_ _.and - (_.test "Can infer." - (|> (/.tagged_sum _primitive.phase [module_name choice_tag] archive.empty choiceC) - (check_variant module_name tags - monoT (with_name monoT) - choice))) - (_.test "Inference retains universal quantification when type-vars are not bound." - (|> (/.tagged_sum _primitive.phase [module_name other_choice_tag] archive.empty other_choiceC) - (check_variant module_name tags - polyT (with_name polyT) - other_choice))) - (_.test "Can specialize." - (|> (//type.with_type monoT - (/.tagged_sum _primitive.phase [module_name other_choice_tag] archive.empty other_choiceC)) - (check_variant module_name tags - monoT (with_name polyT) - other_choice))) - (_.test "Specialization when type-vars get bound." - (|> (/.tagged_sum _primitive.phase [module_name choice_tag] archive.empty choiceC) - (check_variant module_name tags - monoT (with_name polyT) - choice))) - )))) - -(def: record - (do [! r.monad] - [size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - tags (|> (r.set text.hash size (r.unicode 5)) (# ! each set.list)) - primitives (r.list size _primitive.primitive) - module_name (r.unicode 5) - type_name (r.unicode 5) - choice (|> r.nat (# ! each (n.% size))) - .let [varT {.#Parameter 1} - tagsC (list#each (|>> [module_name] code.tag) tags) - primitivesT (list#each product.left primitives) - primitivesC (list#each product.right primitives) - monoT {.#Named [module_name type_name] (type.tuple primitivesT)} - recordC (list.zipped/2 tagsC primitivesC) - polyT (|> (type.tuple (list.together (list (list.first choice primitivesT) - (list varT) - (list.after (++ choice) primitivesT)))) - (type.univ_q 1) - {.#Named [module_name type_name]})]] - (<| (_.context (%.symbol (symbol /.record))) - (_.test "Can infer." - (|> (/.record archive.empty _primitive.phase recordC) - (check_record module_name tags monoT monoT size)))))) - -(def: .public test - Test - (<| (_.context (symbol.module (symbol /._))) - ($_ _.and - ..sum - ..product - ..variant - ..record - ))) |