From e4bc4d0e2cd14a955530160c4fc7859e6c46874e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 3 Feb 2022 05:55:42 -0400 Subject: Fixes for the pure-Lux JVM compiler machinery. [Part 13 / Done!] --- stdlib/source/library/lux/math/number/i32.lux | 22 +- stdlib/source/library/lux/target/jvm/bytecode.lux | 9 +- .../library/lux/target/jvm/encoding/signed.lux | 13 +- .../tool/compiler/language/lux/phase/analysis.lux | 12 +- .../compiler/language/lux/phase/analysis/case.lux | 6 +- .../language/lux/phase/analysis/complex.lux | 424 ++++++++++++++ .../language/lux/phase/analysis/structure.lux | 428 -------------- .../language/lux/phase/extension/analysis/jvm.lux | 19 +- .../language/lux/phase/extension/analysis/lua.lux | 156 +++-- .../language/lux/phase/generation/lua/function.lux | 14 +- .../language/lux/phase/generation/lua/loop.lux | 7 +- .../language/lux/phase/generation/lua/runtime.lux | 7 +- .../lux/phase/generation/lua/structure.lux | 2 +- stdlib/source/test/lux.lux | 183 +++--- stdlib/source/test/lux/extension.lux | 15 +- stdlib/source/test/lux/target/lua.lux | 12 + stdlib/source/test/lux/tool.lux | 4 +- .../compiler/language/lux/analysis/inference.lux | 16 +- .../language/lux/phase/analysis/complex.lux | 650 +++++++++++++++++++++ .../language/lux/phase/analysis/structure.lux | 311 ---------- 20 files changed, 1336 insertions(+), 974 deletions(-) create mode 100644 stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux delete mode 100644 stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux (limited to 'stdlib/source') 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 [ <+> <->] + (template [ <+> <->] [(with_expansions [ (template.symbol [ "'"])] (abstract: Any) (type: .public (Signed ))) @@ -57,6 +57,11 @@ (def: .public (|> (n.* i64.bits_per_byte) -- i64.mask :abstraction)) + + (def: .public + + (let [it (:representation )] + (:abstraction (-- (i.- it +0))))) (def: .public (-> Int (Try )) @@ -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 [ ] 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/complex.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux new file mode 100644 index 000000000..678a626da --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux @@ -0,0 +1,424 @@ +(.using + [library + [lux "*" + ["[0]" meta] + [abstract + ["[0]" monad {"+" do}]] + [control + ["[0]" maybe] + ["[0]" try] + ["[0]" exception {"+" exception:}] + ["[0]" state]] + [data + ["[0]" product] + ["[0]" text ("[1]#[0]" equivalence) + ["%" format {"+" format}]] + [collection + ["[0]" list ("[1]#[0]" monad)] + ["[0]" dictionary {"+" Dictionary}]]] + [macro + ["[0]" code]] + [math + [number + ["n" nat]]] + [meta + ["[0]" symbol]] + ["[0]" type + ["[0]" check]]]] + ["[0]" // "_" + ["[1][0]" simple] + ["/[1]" // "_" + ["[1][0]" extension] + [// + ["/" analysis {"+" Analysis Operation Phase} + ["[1][0]" complex {"+" Tag}] + ["[1][0]" type] + ["[1][0]" inference]] + [/// + ["[1]" phase ("[1]#[0]" monad)] + [meta + [archive {"+" Archive}]]]]]]) + +(exception: .public (not_a_quantified_type [type Type]) + (exception.report + ["Type" (%.type type)])) + +(template [] + [(exception: .public ( [type Type + members (List Code)]) + (exception.report + ["Type" (%.type type)] + ["Expression" (%.code (` [(~+ members)]))]))] + + [invalid_tuple_type] + [cannot_analyse_tuple] + ) + +(template [] + [(exception: .public ( [type Type + lefts Nat + right? Bit + code Code]) + (exception.report + ["Type" (%.type type)] + ["Lefts" (%.nat lefts)] + ["Right?" (%.bit right?)] + ["Expression" (%.code code)]))] + + [invalid_variant_type] + [cannot_analyse_variant] + [cannot_infer_sum] + ) + +(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]) + (exception.report + ["Slot" (%.code (code.symbol key))] + ["Type" (%.type type)])) + +(exception: .public (record_size_mismatch [expected Nat + actual Nat + type Type + record (List [Symbol Code])]) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)] + ["Type" (%.type type)] + ["Expression" (%.code (|> record + (list#each (function (_ [keyI valueC]) + (list (code.symbol keyI) valueC))) + list#conjoint + code.tuple))])) + +(def: .public (sum analyse lefts right? archive) + (-> Phase Nat Bit Phase) + (let [tag (/complex.tag right? lefts)] + (function (again valueC) + (do [! ///.monad] + [expectedT (///extension.lifted meta.expected_type) + expectedT' (/type.check (check.clean expectedT))] + (/.with_stack ..cannot_analyse_variant [expectedT' lefts right? valueC] + (case expectedT + {.#Sum _} + (|> (analyse archive valueC) + (# ! each (|>> [lefts right?] /.variant)) + (/type.expecting (|> expectedT + type.flat_variant + (list.item tag) + (maybe.else .Nothing)))) + + {.#Named name unnamedT} + (<| (/type.expecting unnamedT) + (again valueC)) + + {.#Var id} + (do ! + [?expectedT' (/type.check (check.peek id))] + (case ?expectedT' + {.#Some expectedT'} + (<| (/type.expecting expectedT') + (again valueC)) + + ... Cannot do inference when the tag is numeric. + ... This is because there is no way of knowing how many + ... cases the inferred sum type would have. + _ + (/.except ..cannot_infer_sum [expectedT lefts right? valueC]))) + + (^template [ ] + [{ _} + (do ! + [[@instance :instance:] (/type.check )] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (again valueC)))]) + ([.#UnivQ check.existential] + [.#ExQ check.var]) + + {.#Apply inputT funT} + (case funT + {.#Var funT_id} + (do ! + [?funT' (/type.check (check.peek funT_id))] + (case ?funT' + {.#Some funT'} + (<| (/type.expecting {.#Apply inputT funT'}) + (again valueC)) + + _ + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))) + + _ + (case (type.applied (list inputT) funT) + {.#Some outputT} + (<| (/type.expecting outputT) + (again valueC)) + + {.#None} + (/.except ..not_a_quantified_type [funT]))) + + _ + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))))))) + +(def: .public (variant 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)))) + +(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 analyse expectedT archive membersC) + + {.#Named name unnamedT} + (<| (/type.expecting unnamedT) + (product analyse archive membersC)) + + {.#Var id} + (do ! + [?expectedT' (/type.check (check.peek id))] + (case ?expectedT' + {.#Some expectedT'} + (<| (/type.expecting expectedT') + (product analyse archive membersC)) + + _ + ... Must infer... + (do ! + [membersTA (monad.each ! (|>> (analyse archive) /type.inferring) + membersC) + _ (/type.check (check.check expectedT + (type.tuple (list#each product.left membersTA))))] + (in (/.tuple (list#each product.right membersTA)))))) + + (^template [ ] + [{ _} + (do ! + [[@instance :instance:] (/type.check )] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (product analyse archive membersC)))]) + ([.#UnivQ check.existential] + [.#ExQ check.var]) + + {.#Apply inputT funT} + (case funT + {.#Var funT_id} + (do ! + [?funT' (/type.check (check.peek funT_id))] + (case ?funT' + {.#Some funT'} + (<| (/type.expecting {.#Apply inputT funT'}) + (product analyse archive membersC)) + + _ + (/.except ..invalid_tuple_type [expectedT membersC]))) + + _ + (case (type.applied (list inputT) funT) + {.#Some outputT} + (<| (/type.expecting outputT) + (product analyse archive membersC)) + + {.#None} + (/.except ..not_a_quantified_type funT))) + + _ + (/.except ..invalid_tuple_type [expectedT membersC]) + )))) + +... 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 +... canonical form (with their corresponding module identified). +(def: .public (normal record) + (-> (List Code) (Operation (Maybe (List [Symbol Code])))) + (loop [input record + output (: (List [Symbol Code]) + {.#End})] + (case input + (^ (list& [_ {.#Symbol slotH}] valueH tail)) + (do ///.monad + [slotH (///extension.lifted (meta.normal slotH))] + (again tail {.#Item [slotH valueH] output})) + + {.#End} + (///#in {.#Some output}) + + _ + (///#in {.#None})))) + +(def: (local_binding? name) + (-> Text (Meta Bit)) + (# meta.monad each + (list.any? (list.any? (|>> product.left (text#= name)))) + meta.locals)) + +... Lux already possesses the means to analyse tuples, so +... re-implementing the same functionality for records makes no sense. +... Records, thus, get transformed into tuples by ordering the elements. +(def: (order' head_k record) + (-> Symbol (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) + (do [! ///.monad] + [slotH' (///extension.lifted + (do meta.monad + [head_k (meta.normal head_k)] + (meta.try (meta.slot head_k))))] + (case slotH' + {try.#Success [_ slot_set recordT]} + (do ! + [.let [size_record (list.size record) + size_ts (list.size slot_set)] + _ (if (n.= size_ts size_record) + (in []) + (/.except ..record_size_mismatch [size_ts size_record recordT record])) + .let [tuple_range (list.indices size_ts) + tag->idx (dictionary.of_list symbol.hash (list.zipped/2 slot_set tuple_range))] + idx->val (monad.mix ! + (function (_ [key val] idx->val) + (do ! + [key (///extension.lifted (meta.normal key))] + (case (dictionary.value key tag->idx) + {.#Some idx} + (if (dictionary.key? idx->val idx) + (/.except ..cannot_repeat_slot [key record]) + (in (dictionary.has idx val idx->val))) + + {.#None} + (/.except ..slot_does_not_belong_to_record [key recordT])))) + (: (Dictionary Nat Code) + (dictionary.empty n.hash)) + record) + .let [ordered_tuple (list#each (function (_ idx) + (maybe.trusted (dictionary.value idx idx->val))) + tuple_range)]] + (in {.#Some [size_ts ordered_tuple recordT]})) + + {try.#Failure error} + (in {.#None})))) + +(def: .public (order pattern_matching? record) + (-> Bit (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) + (case record + ... empty_record = empty_tuple = unit/any = [] + {.#End} + (///#in {.#Some [0 (list) .Any]}) + + {.#Item [head_k head_v] _} + (case head_k + ["" head_k'] + (if pattern_matching? + (///#in {.#None}) + (do ///.monad + [local_binding? (///extension.lifted + (..local_binding? head_k'))] + (if local_binding? + (in {.#None}) + (order' head_k record)))) + + _ + (order' head_k record)))) + +(def: .public (record analyse archive members) + (-> Phase Archive (List Code) (Operation Analysis)) + (case members + (^ (list)) + //simple.unit + + (^ (list singletonC)) + (analyse archive singletonC) + + (^ (list [_ {.#Symbol pseudo_slot}] singletonC)) + (do [! ///.monad] + [head_k (///extension.lifted (meta.normal pseudo_slot)) + slot (///extension.lifted (meta.try (meta.slot head_k)))] + (case slot + {try.#Success [_ slot_set recordT]} + (case (list.size slot_set) + 1 (analyse archive singletonC) + _ (..product analyse archive members)) + + _ + (..product analyse archive members))) + + _ + (do [! ///.monad] + [?members (normal members)] + (case ?members + {.#None} + (..product analyse archive members) + + {.#Some slots} + (do ! + [record_size,membersC,recordT (..order false slots)] + (case record_size,membersC,recordT + {.#None} + (..product analyse archive members) + + {.#Some [record_size membersC recordT]} + (do ! + [expectedT (///extension.lifted meta.expected_type)] + (case expectedT + {.#Var _} + (do ! + [inferenceT (/inference.record record_size recordT) + [inferredT membersA] (/inference.general archive analyse inferenceT membersC)] + (in (/.tuple membersA))) + + _ + (..product analyse archive membersC))))))))) 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/structure.lux deleted file mode 100644 index cdf65a6ad..000000000 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ /dev/null @@ -1,428 +0,0 @@ -(.using - [library - [lux "*" - ["[0]" meta] - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" maybe] - ["[0]" try] - ["[0]" exception {"+" exception:}] - ["[0]" state]] - [data - ["[0]" product] - ["[0]" text ("[1]#[0]" equivalence) - ["%" format {"+" format}]] - [collection - ["[0]" list ("[1]#[0]" monad)] - ["[0]" dictionary {"+" Dictionary}]]] - [macro - ["[0]" code]] - [math - [number - ["n" nat]]] - [meta - ["[0]" symbol]] - ["[0]" type - ["[0]" check]]]] - ["[0]" // "_" - ["[1][0]" simple] - ["/[1]" // "_" - ["[1][0]" extension] - [// - ["/" analysis {"+" Analysis Operation Phase} - ["[1][0]" complex {"+" Tag}] - ["[1][0]" type] - ["[1][0]" inference]] - [/// - ["[1]" phase] - [meta - [archive {"+" Archive}]]]]]]) - -(template [] - [(exception: .public ( [type Type - members (List Code)]) - (exception.report - ["Type" (%.type type)] - ["Expression" (%.code (` [(~+ members)]))]))] - - [invalid_tuple_type] - [cannot_analyse_tuple] - ) - -(exception: .public (not_a_quantified_type [type Type]) - (exception.report - ["Type" (%.type type)])) - -(template [] - [(exception: .public ( [type Type - tag Tag - code Code]) - (exception.report - ["Type" (%.type type)] - ["Tag" (%.nat tag)] - ["Expression" (%.code code)]))] - - [invalid_variant_type] - [cannot_analyse_variant] - [cannot_infer_numeric_tag] - ) - -(template [] - [(exception: .public ( [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 (slot_does_not_belong_to_record [key Symbol - type Type]) - (exception.report - ["Slot" (%.code (code.symbol key))] - ["Type" (%.type type)])) - -(exception: .public (record_size_mismatch [expected Nat - actual Nat - type Type - record (List [Symbol Code])]) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)] - ["Type" (%.type type)] - ["Expression" (%.code (|> record - (list#each (function (_ [keyI valueC]) - (list (code.symbol keyI) valueC))) - list#conjoint - code.tuple))])) - -(def: .public (sum analyse lefts right? archive) - (-> Phase Nat Bit Phase) - (let [tag (/complex.tag right? lefts)] - (function (again valueC) - (do [! ///.monad] - [expectedT (///extension.lifted meta.expected_type) - expectedT' (/type.check (check.clean expectedT))] - (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC] - (case expectedT - {.#Sum _} - (|> (analyse archive valueC) - (# ! each (|>> [lefts right?] /.variant)) - (/type.expecting (|> expectedT - type.flat_variant - (list.item tag) - (maybe.else .Nothing)))) - - {.#Named name unnamedT} - (<| (/type.expecting unnamedT) - (again valueC)) - - {.#Var id} - (do ! - [?expectedT' (/type.check (check.peek id))] - (case ?expectedT' - {.#Some expectedT'} - (<| (/type.expecting expectedT') - (again valueC)) - - ... Cannot do inference when the tag is numeric. - ... 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]))) - - (^template [ ] - [{ _} - (do ! - [[instance_id instanceT] (/type.check )] - (<| (/type.expecting (maybe.trusted (type.applied (list instanceT) expectedT))) - (again valueC)))]) - ([.#UnivQ check.existential] - [.#ExQ check.var]) - - {.#Apply inputT funT} - (case funT - {.#Var funT_id} - (do ! - [?funT' (/type.check (check.peek funT_id))] - (case ?funT' - {.#Some funT'} - (<| (/type.expecting {.#Apply inputT funT'}) - (again valueC)) - - _ - (/.except ..invalid_variant_type [expectedT tag valueC]))) - - _ - (case (type.applied (list inputT) funT) - {.#Some outputT} - (<| (/type.expecting outputT) - (again valueC)) - - {.#None} - (/.except ..not_a_quantified_type funT))) - - _ - (/.except ..invalid_variant_type [expectedT tag valueC]))))))) - -(def: (typed_product archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) - (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)) - (do [! ///.monad] - [expectedT (///extension.lifted meta.expected_type)] - (/.with_stack ..cannot_analyse_tuple [expectedT membersC] - (case expectedT - {.#Product _} - (..typed_product archive analyse membersC) - - {.#Named name unnamedT} - (<| (/type.expecting unnamedT) - (product archive analyse membersC)) - - {.#Var id} - (do ! - [?expectedT' (/type.check (check.peek id))] - (case ?expectedT' - {.#Some expectedT'} - (<| (/type.expecting expectedT') - (product archive analyse membersC)) - - _ - ... Must do inference... - (do ! - [membersTA (monad.each ! (|>> (analyse archive) /type.inferring) - membersC) - _ (/type.check (check.check expectedT - (type.tuple (list#each product.left membersTA))))] - (in (/.tuple (list#each product.right membersTA)))))) - - (^template [ ] - [{ _} - (do ! - [[instance_id instanceT] (/type.check )] - (<| (/type.expecting (maybe.trusted (type.applied (list instanceT) expectedT))) - (product archive analyse membersC)))]) - ([.#UnivQ check.existential] - [.#ExQ check.var]) - - {.#Apply inputT funT} - (case funT - {.#Var funT_id} - (do ! - [?funT' (/type.check (check.peek funT_id))] - (case ?funT' - {.#Some funT'} - (<| (/type.expecting {.#Apply inputT funT'}) - (product archive analyse membersC)) - - _ - (/.except ..invalid_tuple_type [expectedT membersC]))) - - _ - (case (type.applied (list inputT) funT) - {.#Some outputT} - (<| (/type.expecting outputT) - (product archive analyse membersC)) - - {.#None} - (/.except ..not_a_quantified_type funT))) - - _ - (/.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 -... canonical form (with their corresponding module identified). -(def: .public (normal record) - (-> (List Code) (Operation (Maybe (List [Symbol Code])))) - (loop [input record - output (: (List [Symbol Code]) - {.#End})] - (case input - (^ (list& [_ {.#Symbol slotH}] valueH tail)) - (do ///.monad - [slotH (///extension.lifted (meta.normal slotH))] - (again tail {.#Item [slotH valueH] output})) - - {.#End} - (# ///.monad in {.#Some output}) - - _ - (# ///.monad in {.#None})))) - -(def: (local_binding? name) - (-> Text (Meta Bit)) - (# meta.monad each - (list.any? (list.any? (|>> product.left (text#= name)))) - meta.locals)) - -... Lux already possesses the means to analyse tuples, so -... re-implementing the same functionality for records makes no sense. -... Records, thus, get transformed into tuples by ordering the elements. -(def: (order' head_k record) - (-> Symbol (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) - (do [! ///.monad] - [slotH' (///extension.lifted - (do meta.monad - [head_k (meta.normal head_k)] - (meta.try (meta.slot head_k))))] - (case slotH' - {try.#Success [_ slot_set recordT]} - (do ! - [.let [size_record (list.size record) - size_ts (list.size slot_set)] - _ (if (n.= size_ts size_record) - (in []) - (/.except ..record_size_mismatch [size_ts size_record recordT record])) - .let [tuple_range (list.indices size_ts) - tag->idx (dictionary.of_list symbol.hash (list.zipped/2 slot_set tuple_range))] - idx->val (monad.mix ! - (function (_ [key val] idx->val) - (do ! - [key (///extension.lifted (meta.normal key))] - (case (dictionary.value key tag->idx) - {.#Some idx} - (if (dictionary.key? idx->val idx) - (/.except ..cannot_repeat_slot [key record]) - (in (dictionary.has idx val idx->val))) - - {.#None} - (/.except ..slot_does_not_belong_to_record [key recordT])))) - (: (Dictionary Nat Code) - (dictionary.empty n.hash)) - record) - .let [ordered_tuple (list#each (function (_ idx) - (maybe.trusted (dictionary.value idx idx->val))) - tuple_range)]] - (in {.#Some [size_ts ordered_tuple recordT]})) - - {try.#Failure error} - (in {.#None})))) - -(def: .public (order pattern_matching? record) - (-> Bit (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) - (case record - ... empty_record = empty_tuple = unit/any = [] - {.#End} - (# ///.monad in {.#Some [0 (list) Any]}) - - {.#Item [head_k head_v] _} - (case head_k - ["" head_k'] - (if pattern_matching? - (# ///.monad in {.#None}) - (do ///.monad - [local_binding? (///extension.lifted - (local_binding? head_k'))] - (if local_binding? - (order' head_k record) - (in {.#None})))) - - _ - (order' head_k record)))) - -(def: .public (record archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) - (case members - (^ (list)) - //simple.unit - - (^ (list singletonC)) - (analyse archive singletonC) - - (^ (list [_ {.#Symbol pseudo_slot}] singletonC)) - (do [! ///.monad] - [head_k (///extension.lifted (meta.normal pseudo_slot)) - slot (///extension.lifted (meta.try (meta.slot head_k)))] - (case slot - {try.#Success [_ slot_set recordT]} - (case (list.size slot_set) - 1 (analyse archive singletonC) - _ (..product archive analyse members)) - - _ - (..product archive analyse members))) - - _ - (do [! ///.monad] - [?members (normal members)] - (case ?members - {.#None} - (..product archive analyse members) - - {.#Some slots} - (do ! - [record_size,membersC,recordT (..order false slots)] - (case record_size,membersC,recordT - {.#None} - (..product archive analyse members) - - {.#Some [record_size membersC recordT]} - (do ! - [expectedT (///extension.lifted meta.expected_type)] - (case expectedT - {.#Var _} - (do ! - [inferenceT (/inference.record record_size recordT) - [inferredT membersA] (/inference.general archive analyse inferenceT membersC)] - (in (/.tuple membersA))) - - _ - (..product archive analyse 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 @@ [.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 @@ [.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 .any .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 .any .any .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 .any .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 .text .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 .text .any (<>.some .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 @@ [.any (function (_ extension phase archive inputC) (do [! phase.monad] - [inputA (analysis/type.with_type (type ) - (phase archive inputC)) - _ (analysis/type.infer (type ))] + [inputA (analysis/type.expecting (type ) + (phase archive inputC)) + _ (analysis/type.inference (type ))] (in {analysis.#Extension extension (list inputA)})))]))] [utf8::encode Text (array.Array (I64 Any))] @@ -185,7 +183,7 @@ [.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 .any (<>.some .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 .any .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 @@ [.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 [ ] [(type: .public @@ -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 [ ("lux in-module" "library/lux" library/lux.refer) - (static.random code.text (random.ascii/lower 1)) - (static.random code.local_symbol (random.ascii/lower 1)) - (static.random code.text (random.ascii/lower 2)) - ' (template.symbol []) - (static.random code.text (random.ascii/lower 3)) - ' (template.symbol []) - (static.random code.text (random.ascii/lower 4)) - ' (template.symbol []) - (template.text [ "/" ]) - (template.text [// ']) - ' (template.symbol []) - <\\> (template.text [\\ ']) - <\\>' (template.symbol [<\\>]) - (template.text [ "/" ]) - (template.text [ "/" ]) - (template.text [ "/" "/" ]) - (template.text [ "#[0]"])] - (and (~~ (template [ ] - [(with_expansions [' (macro.final )] - (case (' [']) - (^code ) - true - - _ - false))] - - [(.using [']) - [("lux def module" [])]] - - [(.using [ ' "*"]) - [("lux def module" [[ ]]) - ( "*")]] - - [(.using [ ' {"+" }]) - [("lux def module" [[ ]]) - ( {"+" })]] - - [(.using [ ' {"-" }]) - [("lux def module" [[ ]]) - ( {"-" })]] - - [(.using [ ' "_"]) - [("lux def module" [])]] - - [(.using [' - [ ']]) - [("lux def module" [[ ]]) - ( )]] - - [(.using ["[0]" ' - ["[0]" ']]) - [("lux def module" [[ ] - [ ]]) - ( ) - ( )]] - - [(.using ["[0]" ' "_" - ["[1]" ']]) - [("lux def module" [[ ]]) - ( )]] - - [(.using ["[0]" ' "_" - ["[1]" ' "_" - ["[2]" ']]]) - [("lux def module" [[ ]]) - ( )]] - - [(.using [' - ["[0]" ' - ["[0]" ']]]) - [("lux def module" [[ ] - [ ]]) - ( ) - ( )]] - - [(.using ["[0]" ' - [' - ["[0]" <\\>']]]) - [("lux def module" [[ ] - [ <\\>]]) - ( ) - ( )]] - - [(.using ["[0]" ' ("[1]#[0]" )]) - [("lux def module" [[ ]]) - ( ( ))]] - ))))) + (`` (with_expansions [ ("lux in-module" "library/lux" library/lux.refer) + (static.random code.text (random.ascii/lower 1)) + (static.random code.local_symbol (random.ascii/lower 1)) + (static.random code.text (random.ascii/lower 2)) + ' (template.symbol []) + (static.random code.text (random.ascii/lower 3)) + ' (template.symbol []) + (static.random code.text (random.ascii/lower 4)) + ' (template.symbol []) + (template.text [ "/" ]) + (template.text [// ']) + ' (template.symbol []) + <\\> (template.text [\\ ']) + <\\>' (template.symbol [<\\>]) + (template.text [ "/" ]) + (template.text [ "/" ]) + (template.text [ "/" "/" ]) + (template.text [ "#[0]"])] + (and (~~ (template [ ] + [(with_expansions [' (macro.final )] + (let [scenario (: (-> Any Bit) + (function (_ _) + (case (' [']) + (^code ) + true + + _ + false)))] + (scenario [])))] + + [(.using [']) + [("lux def module" [])]] + + [(.using [ ' "*"]) + [("lux def module" [[ ]]) + ( "*")]] + + [(.using [ ' {"+" }]) + [("lux def module" [[ ]]) + ( {"+" })]] + + [(.using [ ' {"-" }]) + [("lux def module" [[ ]]) + ( {"-" })]] + + [(.using [ ' "_"]) + [("lux def module" [])]] + + [(.using [' + [ ']]) + [("lux def module" [[ ]]) + ( )]] + + [(.using ["[0]" ' + ["[0]" ']]) + [("lux def module" [[ ] + [ ]]) + ( ) + ( )]] + + [(.using ["[0]" ' "_" + ["[1]" ']]) + [("lux def module" [[ ]]) + ( )]] + + [(.using ["[0]" ' "_" + ["[1]" ' "_" + ["[2]" ']]]) + [("lux def module" [[ ]]) + ( )]] + + [(.using [' + ["[0]" ' + ["[0]" ']]]) + [("lux def module" [[ ] + [ ]]) + ( ) + ( )]] + + [(.using ["[0]" ' + [' + ["[0]" <\\>']]]) + [("lux def module" [[ ] + [ <\\>]]) + ( ) + ( )]] + + [(.using ["[0]" ' ("[1]#[0]" )]) + [("lux def module" [[ ]]) + ( ( ))]] + )))))) )))))) (/.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 .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 [ ] + [(random#each (|>> []) )] + + [.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)]) + (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 [ ] - [(def: .public - (All (_ a) (-> (Operation a) Bit)) - (|>> (phase.result _primitive.state) - (case> {try.#Success _} - - - _ - )))] - - [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 - ))) -- cgit v1.2.3