diff options
Diffstat (limited to 'stdlib/source/test')
| -rw-r--r-- | stdlib/source/test/lux.lux | 183 | ||||
| -rw-r--r-- | stdlib/source/test/lux/extension.lux | 15 | ||||
| -rw-r--r-- | stdlib/source/test/lux/target/lua.lux | 12 | ||||
| -rw-r--r-- | stdlib/source/test/lux/tool.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux | 16 | ||||
| -rw-r--r-- | stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux | 650 | ||||
| -rw-r--r-- | stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux | 311 |
7 files changed, 775 insertions, 416 deletions
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 - ))) |