From 842aba98d9213b26df3f0b37c5293d18922cf7fa Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 10 Jul 2018 21:26:11 -0400 Subject: - Re-named path "lux/lang/*" to "lux/language/*". --- .../test/test/lux/lang/compiler/analysis/case.lux | 194 -------- .../test/lux/lang/compiler/analysis/function.lux | 112 ----- .../test/lux/lang/compiler/analysis/primitive.lux | 86 ---- .../lang/compiler/analysis/procedure/common.lux | 310 ------------ .../lang/compiler/analysis/procedure/host.jvm.lux | 541 --------------------- .../test/lux/lang/compiler/analysis/reference.lux | 102 ---- .../test/lux/lang/compiler/analysis/structure.lux | 292 ----------- .../test/test/lux/lang/compiler/synthesis/case.lux | 82 ---- .../test/lux/lang/compiler/synthesis/function.lux | 168 ------- .../test/lux/lang/compiler/synthesis/primitive.lux | 92 ---- .../test/lux/lang/compiler/synthesis/structure.lux | 57 --- stdlib/test/test/lux/lang/syntax.lux | 242 --------- stdlib/test/test/lux/lang/type.lux | 163 ------- stdlib/test/test/lux/lang/type/check.lux | 262 ---------- .../test/lux/language/compiler/analysis/case.lux | 194 ++++++++ .../lux/language/compiler/analysis/function.lux | 112 +++++ .../lux/language/compiler/analysis/primitive.lux | 86 ++++ .../compiler/analysis/procedure/common.lux | 310 ++++++++++++ .../compiler/analysis/procedure/host.jvm.lux | 541 +++++++++++++++++++++ .../lux/language/compiler/analysis/reference.lux | 102 ++++ .../lux/language/compiler/analysis/structure.lux | 292 +++++++++++ .../test/lux/language/compiler/synthesis/case.lux | 82 ++++ .../lux/language/compiler/synthesis/function.lux | 168 +++++++ .../lux/language/compiler/synthesis/primitive.lux | 92 ++++ .../lux/language/compiler/synthesis/structure.lux | 57 +++ stdlib/test/test/lux/language/syntax.lux | 242 +++++++++ stdlib/test/test/lux/language/type.lux | 163 +++++++ stdlib/test/test/lux/language/type/check.lux | 262 ++++++++++ stdlib/test/test/lux/math/modular.lux | 2 +- 29 files changed, 2704 insertions(+), 2704 deletions(-) delete mode 100644 stdlib/test/test/lux/lang/compiler/analysis/case.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/analysis/function.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/analysis/primitive.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/analysis/reference.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/analysis/structure.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/case.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/function.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux delete mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/structure.lux delete mode 100644 stdlib/test/test/lux/lang/syntax.lux delete mode 100644 stdlib/test/test/lux/lang/type.lux delete mode 100644 stdlib/test/test/lux/lang/type/check.lux create mode 100644 stdlib/test/test/lux/language/compiler/analysis/case.lux create mode 100644 stdlib/test/test/lux/language/compiler/analysis/function.lux create mode 100644 stdlib/test/test/lux/language/compiler/analysis/primitive.lux create mode 100644 stdlib/test/test/lux/language/compiler/analysis/procedure/common.lux create mode 100644 stdlib/test/test/lux/language/compiler/analysis/procedure/host.jvm.lux create mode 100644 stdlib/test/test/lux/language/compiler/analysis/reference.lux create mode 100644 stdlib/test/test/lux/language/compiler/analysis/structure.lux create mode 100644 stdlib/test/test/lux/language/compiler/synthesis/case.lux create mode 100644 stdlib/test/test/lux/language/compiler/synthesis/function.lux create mode 100644 stdlib/test/test/lux/language/compiler/synthesis/primitive.lux create mode 100644 stdlib/test/test/lux/language/compiler/synthesis/structure.lux create mode 100644 stdlib/test/test/lux/language/syntax.lux create mode 100644 stdlib/test/test/lux/language/type.lux create mode 100644 stdlib/test/test/lux/language/type/check.lux (limited to 'stdlib/test') diff --git a/stdlib/test/test/lux/lang/compiler/analysis/case.lux b/stdlib/test/test/lux/lang/compiler/analysis/case.lux deleted file mode 100644 index 5baf47fc0..000000000 --- a/stdlib/test/test/lux/lang/compiler/analysis/case.lux +++ /dev/null @@ -1,194 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "B/" Equivalence] - ["R" error] - [product] - [maybe] - [text "T/" Equivalence] - text/format - (collection [list "list/" Monad] - [set])) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - (lang [type "type/" Equivalence] - (type ["tc" check]) - [".L" module] - (compiler [analysis] - (analysis [".A" type] - ["/" case]))) - test) - (// ["_." primitive] - ["_." structure])) - -(def: (exhaustive-weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - #.Nil - #.Nil - - (#.Cons head+ #.Nil) - (list/map (|>> list) head+) - - (#.Cons head+ tail++) - (do list.Monad - [tail+ (exhaustive-weaving tail++) - head head+] - (wrap (#.Cons head tail+))))) - -(def: #export (exhaustive-branches allow-literals? variantTC inputC) - (-> Bool (List [Code Code]) Code (r.Random (List Code))) - (case inputC - [_ (#.Bool _)] - (r/wrap (list (' true) (' false))) - - (^template [ ] - [_ ( _)] - (if allow-literals? - (do r.Monad - [?sample (r.maybe )] - (case ?sample - (#.Some sample) - (do @ - [else (exhaustive-branches allow-literals? variantTC inputC)] - (wrap (list& ( sample) else))) - - #.None - (wrap (list (' _))))) - (r/wrap (list (' _))))) - ([#.Nat r.nat code.nat] - [#.Int r.int code.int] - [#.Rev r.rev code.rev] - [#.Frac r.frac code.frac] - [#.Text (r.unicode +5) code.text]) - - (^ [_ (#.Tuple (list))]) - (r/wrap (list (' []))) - - (^ [_ (#.Record (list))]) - (r/wrap (list (' {}))) - - [_ (#.Tuple members)] - (do r.Monad - [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list/map code.tuple)))) - - [_ (#.Record kvs)] - (do r.Monad - [#let [ks (list/map product.left kvs) - vs (list/map product.right kvs)] - member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list/map (|>> (list.zip2 ks) code.record))))) - - (^ [_ (#.Form (list [_ (#.Tag _)] _))]) - (do r.Monad - [bundles (monad.map @ - (function (_ [_tag _code]) - (do @ - [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (list/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) - v-branches)))) - variantTC)] - (wrap (list/join bundles))) - - _ - (r/wrap (list)) - )) - -(def: #export (input variant-tags record-tags primitivesC) - (-> (List Code) (List Code) (List Code) (r.Random Code)) - (r.rec - (function (_ input) - ($_ r.either - (r/map product.right _primitive.primitive) - (do r.Monad - [choice (|> r.nat (:: @ map (n/% (list.size variant-tags)))) - #let [choiceT (maybe.assume (list.nth choice variant-tags)) - choiceC (maybe.assume (list.nth choice primitivesC))]] - (wrap (` ((~ choiceT) (~ choiceC))))) - (do r.Monad - [size (|> r.nat (:: @ map (n/% +3))) - elems (r.list size input)] - (wrap (code.tuple elems))) - (r/wrap (code.record (list.zip2 record-tags primitivesC))) - )))) - -(def: (branch body pattern) - (-> Code Code [Code Code]) - [pattern body]) - -(context: "Pattern-matching." - ## #seed +9253409297339902486 - ## #seed +3793366152923578600 - (<| (seed +5004137551292836565) - ## (times +100) - (do @ - [module-name (r.unicode +5) - variant-name (r.unicode +5) - record-name (|> (r.unicode +5) (r.filter (|>> (T/= variant-name) not))) - size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - variant-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - record-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - primitivesTC (r.list size _primitive.primitive) - #let [primitivesT (list/map product.left primitivesTC) - primitivesC (list/map product.right primitivesTC) - code-tag (|>> [module-name] code.tag) - variant-tags+ (list/map code-tag variant-tags) - record-tags+ (list/map code-tag record-tags) - variantTC (list.zip2 variant-tags+ primitivesC)] - inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] _primitive.primitive - [heterogeneousT heterogeneousC] (r.filter (|>> product.left (tc.checks? outputT) not) - _primitive.primitive) - exhaustive-patterns (exhaustive-branches true variantTC inputC) - redundant-patterns (exhaustive-branches false variantTC inputC) - redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) - heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns)))) - #let [exhaustive-branchesC (list/map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) - exhaustive-branchesC) - redundant-branchesC (<| (list/map (branch outputC)) - list.concat - (list (list.take redundancy-idx redundant-patterns) - (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) - (list.drop redundancy-idx redundant-patterns))) - heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] - [_pattern heterogeneousC])) - (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) - analyse-pm (|>> (/.case _primitive.analyse inputC) - (typeA.with-type outputT) - analysis.with-scope - (do Monad - [_ (moduleL.declare-tags variant-tags false - (#.Named [module-name variant-name] - (type.variant primitivesT))) - _ (moduleL.declare-tags record-tags false - (#.Named [module-name record-name] - (type.tuple primitivesT)))]) - (moduleL.with-module +0 module-name))]] - ($_ seq - (test "Will reject empty pattern-matching (no branches)." - (|> (analyse-pm (list)) - _structure.check-fails)) - (test "Can analyse exhaustive pattern-matching." - (|> (analyse-pm exhaustive-branchesC) - _structure.check-succeeds)) - (test "Will reject non-exhaustive pattern-matching." - (|> (analyse-pm non-exhaustive-branchesC) - _structure.check-fails)) - (test "Will reject redundant pattern-matching." - (|> (analyse-pm redundant-branchesC) - _structure.check-fails)) - (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (analyse-pm heterogeneous-branchesC) - _structure.check-fails))) - ))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/function.lux b/stdlib/test/test/lux/lang/compiler/analysis/function.lux deleted file mode 100644 index 315972d28..000000000 --- a/stdlib/test/test/lux/lang/compiler/analysis/function.lux +++ /dev/null @@ -1,112 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [maybe] - [product] - [text "text/" Equivalence] - text/format - (collection [list "list/" Functor])) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [type "type/" Equivalence] - [".L" reference] - (compiler [".L" init] - [".L" analysis #+ Analysis] - (analysis [".A" type] - [".A" expression] - ["/" function]))) - test) - (// ["_." primitive] - ["_." structure])) - -(def: analyse (expressionA.analyser (:coerce lang.Eval []))) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Meta Analysis) Bool) - (|> analysis - (typeA.with-type expectedT) - (macro.run (initL.compiler [])) - (case> (#e.Success applyA) - (let [[funcA argsA] (analysisL.application applyA)] - (n/= num-args (list.size argsA))) - - (#e.Error error) - false))) - -(context: "Function definition." - (<| (times +100) - (do @ - [func-name (r.unicode +5) - arg-name (|> (r.unicode +5) (r.filter (|>> (text/= func-name) not))) - [outputT outputC] _primitive.primitive - [inputT _] _primitive.primitive - #let [g!arg (code.local-symbol arg-name)]] - ($_ seq - (test "Can analyse function." - (and (|> (typeA.with-type (All [a] (-> a outputT)) - (/.function ..analyse func-name arg-name outputC)) - _structure.check-succeeds) - (|> (typeA.with-type (All [a] (-> a a)) - (/.function ..analyse func-name arg-name g!arg)) - _structure.check-succeeds))) - (test "Generic functions can always be specialized." - (and (|> (typeA.with-type (-> inputT outputT) - (/.function ..analyse func-name arg-name outputC)) - _structure.check-succeeds) - (|> (typeA.with-type (-> inputT inputT) - (/.function ..analyse func-name arg-name g!arg)) - _structure.check-succeeds))) - (test "The function's name is bound to the function's type." - (|> (typeA.with-type (Rec self (-> inputT self)) - (/.function ..analyse func-name arg-name (code.local-symbol func-name))) - _structure.check-succeeds)) - )))) - -(context: "Function application." - (<| (times +100) - (do @ - [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - partial-args (|> r.nat (:: @ map (n/% full-args))) - var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1)))) - inputsTC (r.list full-args _primitive.primitive) - #let [inputsT (list/map product.left inputsTC) - inputsC (list/map product.right inputsTC)] - [outputT outputC] _primitive.primitive - #let [funcT (type.function inputsT outputT) - partialT (type.function (list.drop partial-args inputsT) outputT) - varT (#.Parameter +1) - polyT (<| (type.univ-q +1) - (type.function (list.concat (list (list.take var-idx inputsT) - (list varT) - (list.drop (inc var-idx) inputsT)))) - varT) - poly-inputT (maybe.assume (list.nth var-idx inputsT)) - partial-poly-inputsT (list.drop (inc var-idx) inputsT) - partial-polyT1 (<| (type.function partial-poly-inputsT) - poly-inputT) - partial-polyT2 (<| (type.univ-q +1) - (type.function (#.Cons varT partial-poly-inputsT)) - varT) - dummy-function (#analysisL.Function (list) (#analysisL.Reference (referenceL.local +1)))]] - ($_ seq - (test "Can analyse monomorphic type application." - (|> (/.apply ..analyse funcT dummy-function inputsC) - (check-apply outputT full-args))) - (test "Can partially apply functions." - (|> (/.apply ..analyse funcT dummy-function (list.take partial-args inputsC)) - (check-apply partialT partial-args))) - (test "Can apply polymorphic functions." - (|> (/.apply ..analyse polyT dummy-function inputsC) - (check-apply poly-inputT full-args))) - (test "Polymorphic partial application propagates found type-vars." - (|> (/.apply ..analyse polyT dummy-function (list.take (inc var-idx) inputsC)) - (check-apply partial-polyT1 (inc var-idx)))) - (test "Polymorphic partial application preserves quantification for type-vars." - (|> (/.apply ..analyse polyT dummy-function (list.take var-idx inputsC)) - (check-apply partial-polyT2 var-idx))) - )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux b/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux deleted file mode 100644 index cf98a71ff..000000000 --- a/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux +++ /dev/null @@ -1,86 +0,0 @@ -(.module: - [lux #- primitive] - (lux [io] - (control [monad #+ do] - pipe - ["ex" exception #+ exception:]) - (data (text format) - ["e" error]) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [".L" type "type/" Equivalence] - (compiler [".L" init] - [analysis #+ Analysis] - (analysis [".A" type] - [".A" expression]))) - test)) - -(def: #export analyse (expressionA.analyser (:coerce lang.Eval []))) - -(def: unit - (r.Random Code) - (r/wrap (' []))) - -(def: #export primitive - (r.Random [Type Code]) - (`` ($_ r.either - (~~ (do-template [ ] - [(r.seq (r/wrap ) (r/map ))] - - [Any code.tuple (r.list +0 ..unit)] - [Bool code.bool r.bool] - [Nat code.nat r.nat] - [Int code.int r.int] - [Rev code.rev r.rev] - [Frac code.frac r.frac] - [Text code.text (r.unicode +5)] - ))))) - -(exception: (wrong-inference {expected Type} {inferred Type}) - (ex.report ["Expected" (%type expected)] - ["Inferred" (%type inferred)])) - -(def: (infer-primitive expected-type analysis) - (-> Type (Meta Analysis) (e.Error Analysis)) - (|> (typeA.with-inference - analysis) - (macro.run (initL.compiler [])) - (case> (#e.Success [inferred-type output]) - (if (is? expected-type inferred-type) - (#e.Success output) - (ex.throw wrong-inference [expected-type inferred-type])) - - (#e.Error error) - (#e.Error error)))) - -(context: "Primitives" - ($_ seq - (test "Can analyse unit." - (|> (infer-primitive Any (..analyse (' []))) - (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output)))) - (is? [] output) - - _ - false))) - (<| (times +100) - (`` ($_ seq - (~~ (do-template [ ] - [(do @ - [sample ] - (test (format "Can analyse " ".") - (|> (infer-primitive (..analyse ( sample))) - (case> (#e.Success (#analysis.Primitive ( output))) - (is? sample output) - - _ - false))))] - - ["bool" Bool #analysis.Bool r.bool code.bool] - ["nat" Nat #analysis.Nat r.nat code.nat] - ["int" Int #analysis.Int r.int code.int] - ["rev" Rev #analysis.Rev r.rev code.rev] - ["frac" Frac #analysis.Frac r.frac code.frac] - ["text" Text #analysis.Text (r.unicode +5) code.text] - ))))))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux deleted file mode 100644 index 377a48478..000000000 --- a/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux +++ /dev/null @@ -1,310 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data text/format - ["e" error] - [product] - (collection [array])) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type "type/" Equivalence] - [".L" scope] - (compiler [".L" init] - (analysis [".A" type]))) - test) - (/// ["_." primitive])) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (scopeL.with-scope "" - (typeA.with-type output-type - (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [check-success+ true false] - [check-failure+ false true] - ) - -(context: "Lux procedures" - (<| (times +100) - (do @ - [[primT primC] _primitive.primitive - [antiT antiC] (|> _primitive.primitive - (r.filter (|>> product.left (type/= primT) not)))] - ($_ seq - (test "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bool)) - (test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bool)) - (test "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ([(~' _) (~' _)] (~ primC)))) - (type (Either Text primT)))) - )))) - -(context: "Bit procedures" - (<| (times +100) - (do @ - [subjectC (|> r.nat (:: @ map code.nat)) - signedC (|> r.int (:: @ map code.int)) - paramC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can perform bit 'and'." - (check-success+ "lux bit and" (list subjectC paramC) Nat)) - (test "Can perform bit 'or'." - (check-success+ "lux bit or" (list subjectC paramC) Nat)) - (test "Can perform bit 'xor'." - (check-success+ "lux bit xor" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the left." - (check-success+ "lux bit left-shift" (list subjectC paramC) Nat)) - (test "Can shift bit pattern to the right." - (check-success+ "lux bit logical-right-shift" (list subjectC paramC) Nat)) - (test "Can shift signed bit pattern to the right." - (check-success+ "lux bit arithmetic-right-shift" (list signedC paramC) Int)) - )))) - -(context: "Int procedures" - (<| (times +100) - (do @ - [subjectC (|> r.int (:: @ map code.int)) - paramC (|> r.int (:: @ map code.int))] - ($_ seq - (test "Can add integers." - (check-success+ "lux int +" (list subjectC paramC) Int)) - (test "Can subtract integers." - (check-success+ "lux int -" (list subjectC paramC) Int)) - (test "Can multiply integers." - (check-success+ "lux int *" (list subjectC paramC) Int)) - (test "Can divide integers." - (check-success+ "lux int /" (list subjectC paramC) Int)) - (test "Can calculate remainder of integers." - (check-success+ "lux int %" (list subjectC paramC) Int)) - (test "Can test equivalence of integers." - (check-success+ "lux int =" (list subjectC paramC) Bool)) - (test "Can compare integers." - (check-success+ "lux int <" (list subjectC paramC) Bool)) - (test "Can obtain minimum integer." - (check-success+ "lux int min" (list) Int)) - (test "Can obtain maximum integer." - (check-success+ "lux int max" (list) Int)) - (test "Can convert integer to natural number." - (check-success+ "lux int to-nat" (list subjectC) Nat)) - (test "Can convert integer to frac number." - (check-success+ "lux int to-frac" (list subjectC) Frac)) - (test "Can convert integer to text." - (check-success+ "lux int char" (list subjectC) Text)) - )))) - -(context: "Frac procedures" - (<| (times +100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac)) - encodedC (|> (r.unicode +5) (:: @ map code.text))] - ($_ seq - (test "Can add frac numbers." - (check-success+ "lux frac +" (list subjectC paramC) Frac)) - (test "Can subtract frac numbers." - (check-success+ "lux frac -" (list subjectC paramC) Frac)) - (test "Can multiply frac numbers." - (check-success+ "lux frac *" (list subjectC paramC) Frac)) - (test "Can divide frac numbers." - (check-success+ "lux frac /" (list subjectC paramC) Frac)) - (test "Can calculate remainder of frac numbers." - (check-success+ "lux frac %" (list subjectC paramC) Frac)) - (test "Can test equivalence of frac numbers." - (check-success+ "lux frac =" (list subjectC paramC) Bool)) - (test "Can compare frac numbers." - (check-success+ "lux frac <" (list subjectC paramC) Bool)) - (test "Can obtain minimum frac number." - (check-success+ "lux frac min" (list) Frac)) - (test "Can obtain maximum frac number." - (check-success+ "lux frac max" (list) Frac)) - (test "Can obtain smallest frac number." - (check-success+ "lux frac smallest" (list) Frac)) - (test "Can convert frac number to integer." - (check-success+ "lux frac to-int" (list subjectC) Int)) - (test "Can convert frac number to text." - (check-success+ "lux frac encode" (list subjectC) Text)) - (test "Can convert text to frac number." - (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac)))) - )))) - -(context: "Text procedures" - (<| (times +100) - (do @ - [subjectC (|> (r.unicode +5) (:: @ map code.text)) - paramC (|> (r.unicode +5) (:: @ map code.text)) - replacementC (|> (r.unicode +5) (:: @ map code.text)) - fromC (|> r.nat (:: @ map code.nat)) - toC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can test text equivalence." - (check-success+ "lux text =" (list subjectC paramC) Bool)) - (test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list subjectC paramC) Bool)) - (test "Can concatenate one text to another." - (check-success+ "lux text concat" (list subjectC paramC) Text)) - (test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) - (test "Can query the size/length of a text." - (check-success+ "lux text size" (list subjectC) Nat)) - (test "Can calculate a hash code for text." - (check-success+ "lux text hash" (list subjectC) Nat)) - (test "Can replace a text inside of a larger one (once)." - (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) - (test "Can replace a text inside of a larger one (all times)." - (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) - (test "Can obtain the character code of a text at a given index." - (check-success+ "lux text char" (list subjectC fromC) (type (Maybe Nat)))) - (test "Can clip a piece of text between 2 indices." - (check-success+ "lux text clip" (list subjectC fromC toC) (type (Maybe Text)))) - )))) - -(context: "Array procedures" - (<| (times +100) - (do @ - [[elemT elemC] _primitive.primitive - sizeC (|> r.nat (:: @ map code.nat)) - idxC (|> r.nat (:: @ map code.nat)) - var-name (r.unicode +5) - #let [arrayT (type (Array elemT)) - g!array (code.local-symbol var-name) - array-operation (function (_ output-type code) - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name arrayT] - (typeA.with-type output-type - (_primitive.analyse code)))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error error) - false)))]] - ($_ seq - (test "Can create arrays." - (check-success+ "lux array new" (list sizeC) arrayT)) - (test "Can get a value inside an array." - (array-operation (type (Maybe elemT)) - (` ("lux array get" (~ g!array) (~ idxC))))) - (test "Can put a value inside an array." - (array-operation arrayT - (` ("lux array put" (~ g!array) (~ idxC) (~ elemC))))) - (test "Can remove a value from an array." - (array-operation arrayT - (` ("lux array remove" (~ g!array) (~ idxC))))) - (test "Can query the size of an array." - (array-operation Nat - (` ("lux array size" (~ g!array))))) - )))) - -(context: "Math procedures" - (<| (times +100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac))] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC) Frac))] - - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"])) - (~~ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC paramC) Frac))] - - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"]))))))) - -(context: "Atom procedures" - (<| (times +100) - (do @ - [[elemT elemC] _primitive.primitive - sizeC (|> r.nat (:: @ map code.nat)) - idxC (|> r.nat (:: @ map code.nat)) - var-name (r.unicode +5) - #let [atomT (type (atom.Atom elemT))]] - ($_ seq - (test "Can create atomic reference." - (check-success+ "lux atom new" (list elemC) atomT)) - (test "Can read the value of an atomic reference." - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name atomT] - (typeA.with-type elemT - (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) - (test "Can swap the value of an atomic reference." - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name atomT] - (typeA.with-type Bool - (_primitive.analyse (` ("lux atom compare-and-swap" - (~ (code.symbol ["" var-name])) - (~ elemC) - (~ elemC))))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) - )))) - -(context: "Process procedures" - (<| (times +100) - (do @ - [[primT primC] _primitive.primitive - timeC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can query the level of concurrency." - (check-success+ "lux process parallelism-level" (list) Nat)) - (test "Can schedule an IO computation to run concurrently at some future time." - (check-success+ "lux process schedule" - (list timeC - (` ([(~' _) (~' _)] (~ primC)))) - Any)) - )))) - -(context: "IO procedures" - (<| (times +100) - (do @ - [logC (|> (r.unicode +5) (:: @ map code.text)) - exitC (|> r.int (:: @ map code.int))] - ($_ seq - (test "Can log messages to standard output." - (check-success+ "lux io log" (list logC) Any)) - (test "Can throw a run-time error." - (check-success+ "lux io error" (list logC) Nothing)) - (test "Can exit the program." - (check-success+ "lux io exit" (list exitC) Nothing)) - (test "Can query the current time (as milliseconds since epoch)." - (check-success+ "lux io current-time" (list) Int)) - )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux deleted file mode 100644 index 3d3dc41d5..000000000 --- a/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux +++ /dev/null @@ -1,541 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data ["e" error] - [product] - [maybe] - [text "text/" Equivalence] - text/format - (collection [array] - [list "list/" Fold] - ["dict" dictionary])) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type] - (compiler [".L" init] - (analysis [".A" type]) - (extension (analysis [".AE" host])))) - test) - (/// ["_." primitive])) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (do Monad - [## runtime-bytecode @runtime.translate - ] - (lang.with-scope - (typeA.with-type output-type - (_primitive.analyse (` ((~ (code.text procedure)) (~+ params))))))) - (lang.with-current-module "") - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [success true false] - [failure false true] - ) - -(do-template [ ] - [(def: ( syntax output-type) - (-> Code Type Bool) - (|> (do Monad - [## runtime-bytecode @runtime.translate - ] - (lang.with-scope - (typeA.with-type output-type - (_primitive.analyse syntax)))) - (lang.with-current-module "") - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [success' true false] - [failure' false true] - ) - -(context: "Conversions [double + float]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert double-to-float" "java.lang.Double" hostAE.Float] - ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer] - ["jvm convert double-to-long" "java.lang.Double" hostAE.Long] - ["jvm convert float-to-double" "java.lang.Float" hostAE.Double] - ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer] - ["jvm convert float-to-long" "java.lang.Float" hostAE.Long] - )] - ($_ seq - - ))) - -(context: "Conversions [int]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert int-to-byte" "java.lang.Integer" hostAE.Byte] - ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character] - ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double] - ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float] - ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long] - ["jvm convert int-to-short" "java.lang.Integer" hostAE.Short] - )] - ($_ seq - - ))) - -(context: "Conversions [long]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert long-to-double" "java.lang.Long" hostAE.Double] - ["jvm convert long-to-float" "java.lang.Long" hostAE.Float] - ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer] - ["jvm convert long-to-short" "java.lang.Long" hostAE.Short] - ["jvm convert long-to-byte" "java.lang.Long" hostAE.Byte] - )] - ($_ seq - - ))) - -(context: "Conversions [char + byte + short]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert char-to-byte" "java.lang.Character" hostAE.Byte] - ["jvm convert char-to-short" "java.lang.Character" hostAE.Short] - ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer] - ["jvm convert char-to-long" "java.lang.Character" hostAE.Long] - ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long] - ["jvm convert short-to-long" "java.lang.Short" hostAE.Long] - )] - ($_ seq - - ))) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - ))) - - (context: (format "Bitwise " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " and") ] - [(format "jvm " " or") ] - [(format "jvm " " xor") ] - [(format "jvm " " shl") "java.lang.Integer" ] - [(format "jvm " " shr") "java.lang.Integer" ] - [(format "jvm " " ushr") "java.lang.Integer" ] - )] - ($_ seq - - )))] - - - ["int" "java.lang.Integer" hostAE.Integer] - ["long" "java.lang.Long" hostAE.Long] - ) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - )))] - - - ["float" "java.lang.Float" hostAE.Float] - ["double" "java.lang.Double" hostAE.Double] - ) - -(do-template [ ] - [(context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - )))] - - - ["char" "java.lang.Character" hostAE.Character] - ) - -(def: array-type - (r.Random [Text Text]) - (let [entries (dict.entries hostAE.boxes) - num-entries (list.size entries)] - (do r.Monad - [choice (|> r.nat (:: @ map (n/% (inc num-entries)))) - #let [[unboxed boxed] (: [Text Text] - (|> entries - (list.nth choice) - (maybe.default ["java.lang.Object" "java.lang.Object"])))]] - (wrap [unboxed boxed])))) - -(context: "Array." - (<| (times +100) - (do @ - [#let [cap (|>> (n/% +10) (n/max +1))] - [unboxed boxed] array-type - size (|> r.nat (:: @ map cap)) - idx (|> r.nat (:: @ map (n/% size))) - level (|> r.nat (:: @ map cap)) - #let [unboxedT (#.Primitive unboxed (list)) - arrayT (#.Primitive "#Array" (list unboxedT)) - arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0))) - ("jvm array new" (~ (code.nat size))))) - boxedT (#.Primitive boxed (list)) - boxedTC (` (+0 (~ (code.text boxed)) (+0))) - multi-arrayT (list/fold (function (_ _ innerT) - (|> innerT (list) (#.Primitive "#Array"))) - boxedT - (list.n/range +1 level))]] - ($_ seq - (test "jvm array new" - (success "jvm array new" - (list (code.nat size)) - arrayT)) - (test "jvm array new (no nesting)" - (failure "jvm array new" - (list (code.nat size)) - unboxedT)) - (test "jvm array new (nested/multi-level)" - (success "jvm array new" - (list (code.nat size)) - multi-arrayT)) - (test "jvm array length" - (success "jvm array length" - (list arrayC) - Nat)) - (test "jvm array read" - (success' (` ("jvm object cast" - ("jvm array read" (~ arrayC) (~ (code.nat idx))))) - boxedT)) - (test "jvm array write" - (success "jvm array write" - (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) - arrayT)) - )))) - -(def: throwables - (List Text) - (list "java.lang.Throwable" - "java.lang.Error" - "java.io.IOError" - "java.lang.VirtualMachineError" - "java.lang.Exception" - "java.io.IOException" - "java.lang.RuntimeException")) - -(context: "Object." - (<| (times +100) - (do @ - [[unboxed boxed] array-type - [!unboxed !boxed] (|> array-type - (r.filter (function (_ [!unboxed !boxed]) - (not (text/= boxed !boxed))))) - #let [boxedT (#.Primitive boxed (list)) - boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0)) - ("jvm object null"))) - !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0)) - ("jvm object null"))) - unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) - ("jvm object null")))] - throwable (|> r.nat - (:: @ map (n/% (inc (list.size throwables)))) - (:: @ map (function (_ idx) - (|> throwables - (list.nth idx) - (maybe.default "java.lang.Object"))))) - #let [throwableC (`' ("lux check" (+0 (~ (code.text throwable)) (+0)) - ("jvm object null")))]] - ($_ seq - (test "jvm object null" - (success "jvm object null" - (list) - (#.Primitive boxed (list)))) - (test "jvm object null (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object null" - (list) - (#.Primitive unboxed (list))))) - (test "jvm object null?" - (success "jvm object null?" - (list boxedC) - Bool)) - (test "jvm object synchronized" - (success "jvm object synchronized" - (list boxedC boxedC) - boxedT)) - (test "jvm object synchronized (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object synchronized" - (list unboxedC boxedC) - boxedT))) - (test "jvm object throw" - (or (text/= "java.lang.Object" throwable) - (success "jvm object throw" - (list throwableC) - Nothing))) - (test "jvm object class" - (success "jvm object class" - (list (code.text boxed)) - (#.Primitive "java.lang.Class" (list boxedT)))) - (test "jvm object instance?" - (success "jvm object instance?" - (list (code.text boxed) - boxedC) - Bool)) - (test "jvm object instance? (lineage)" - (success "jvm object instance?" - (list (' "java.lang.Object") - boxedC) - Bool)) - (test "jvm object instance? (no lineage)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object instance?" - (list (code.text boxed) - !boxedC) - Bool))) - )))) - -(context: "Member [Static Field]." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code.text "java.lang.System") - (code.text "out")) - (#.Primitive "java.io.PrintStream" (list)))) - (test "jvm member static get (inheritance out)" - (success "jvm member static get" - (list (code.text "java.lang.System") - (code.text "out")) - (#.Primitive "java.lang.Object" (list)))) - (test "jvm member static put" - (success "jvm member static put" - (list (code.text "java.awt.datatransfer.DataFlavor") - (code.text "allHtmlFlavor") - (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) - ("jvm object null")))) - Any)) - (test "jvm member static put (final)" - (failure "jvm member static put" - (list (code.text "java.lang.System") - (code.text "out") - (`' ("lux check" (+0 "java.io.PrintStream" (+0)) - ("jvm object null")))) - Any)) - (test "jvm member static put (inheritance in)" - (success "jvm member static put" - (list (code.text "java.awt.datatransfer.DataFlavor") - (code.text "allHtmlFlavor") - (`' ("jvm object cast" - ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) - ("jvm object null"))))) - Any)) - )) - -(context: "Member [Virtual Field]." - ($_ seq - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.String" (list)))) - (test "jvm member virtual get (inheritance out)" - (success "jvm member virtual get" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.Object" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "java.lang.String" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (primitive "org.omg.CORBA.ValueMember"))) - (test "jvm member virtual put (final)" - (failure "jvm member virtual put" - (list (code.text "javax.swing.text.html.parser.DTD") - (code.text "applet") - (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) - ("jvm object null")))) - (primitive "javax.swing.text.html.parser.DTD"))) - (test "jvm member virtual put (inheritance in)" - (success "jvm member virtual put" - (list (code.text "java.awt.GridBagConstraints") - (code.text "insets") - (`' ("jvm object cast" - ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) - ("jvm object null")))) - (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) - ("jvm object null")))) - (primitive "java.awt.GridBagConstraints"))) - )) - -(context: "Boxing/Unboxing." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code.text "java.util.GregorianCalendar") - (code.text "AD")) - (#.Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code.text "javax.accessibility.AccessibleAttributeSequence") - (code.text "startIndex") - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code.text "javax.accessibility.AccessibleAttributeSequence") - (code.text "startIndex") - (`' ("jvm object cast" - ("lux check" (+0 "java.lang.Integer" (+0)) - ("jvm object null")))) - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (primitive "javax.accessibility.AccessibleAttributeSequence"))) - )) - -(context: "Member [Method]." - (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) - +123)) - intC (`' ("jvm convert long-to-int" (~ longC))) - stringC (' ("lux coerce" (+0 "java.lang.String" (+0)) - "YOLO")) - objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) - ("jvm member invoke constructor" "java.util.ArrayList" - ["int" ("jvm object cast" (~ intC))])))] - ($_ seq - (test "jvm member invoke static" - (success' (` ("jvm member invoke static" - "java.lang.Long" "decode" - ["java.lang.String" (~ stringC)])) - (#.Primitive "java.lang.Long" (list)))) - (test "jvm member invoke virtual" - (success' (` ("jvm object cast" - ("jvm member invoke virtual" - "java.lang.Object" "equals" - ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke special" - (success' (` ("jvm object cast" - ("jvm member invoke special" - "java.lang.Long" "equals" - ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke interface" - (success' (` ("jvm object cast" - ("jvm member invoke interface" - "java.util.Collection" "add" - ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke constructor" - (success' (` ("jvm member invoke constructor" - "java.util.ArrayList" - ["int" ("jvm object cast" (~ intC))])) - (All [a] (#.Primitive "java.util.ArrayList" (list a))))) - ))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/reference.lux b/stdlib/test/test/lux/lang/compiler/analysis/reference.lux deleted file mode 100644 index d1874bfee..000000000 --- a/stdlib/test/test/lux/lang/compiler/analysis/reference.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [ident "ident/" Equivalence] - [text "text/" Equivalence]) - ["r" math/random] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type "type/" Equivalence] - [".L" scope] - [".L" module] - [".L" reference] - (compiler [".L" init] - [".L" analysis] - (analysis [".A" type] - [".A" expression]))) - test) - (// ["_." primitive])) - -(def: analyse (expressionA.analyser (:coerce lang.Eval []))) - -(type: Check (-> (e.Error Any) Bool)) - -(do-template [ ] - [(def: - Check - (|>> (case> (#e.Success _) - - - (#e.Error _) - )))] - - [success? true false] - [failure? false true] - ) - -(def: (reach-test var-name [export? def-module] [import? dependent-module] check!) - (-> Text [Bool Text] [Bool Text] Check Bool) - (|> (do Monad - [_ (moduleL.with-module +0 def-module - (moduleL.define var-name [Any - (if export? - (' {#.export? true}) - (' {})) - []]))] - (moduleL.with-module +0 dependent-module - (do @ - [_ (if import? - (moduleL.import def-module) - (wrap []))] - (typeA.with-inference - (..analyse (code.symbol [def-module var-name])))))) - (macro.run (initL.compiler [])) - check!)) - -(context: "References" - (<| (times +100) - (do @ - [[expectedT _] _primitive.primitive - def-module (r.unicode +5) - scope-name (r.unicode +5) - var-name (r.unicode +5) - dependent-module (|> (r.unicode +5) - (r.filter (|>> (text/= def-module) not)))] - ($_ seq - (test "Can analyse variable." - (|> (scopeL.with-scope scope-name - (scopeL.with-local [var-name expectedT] - (typeA.with-inference - (..analyse (code.local-symbol var-name))))) - (macro.run (initL.compiler [])) - (case> (^ (#e.Success [inferredT (#analysisL.Reference (referenceL.local var))])) - (and (type/= expectedT inferredT) - (n/= +0 var)) - - _ - false))) - (test "Can analyse definition (in the same module)." - (let [def-name [def-module var-name]] - (|> (do Monad - [_ (moduleL.define var-name [expectedT (' {}) []])] - (typeA.with-inference - (..analyse (code.symbol def-name)))) - (moduleL.with-module +0 def-module) - (macro.run (initL.compiler [])) - (case> (^ (#e.Success [_ inferredT (#analysisL.Reference (referenceL.constant constant-name))])) - (and (type/= expectedT inferredT) - (ident/= def-name constant-name)) - - _ - false)))) - (test "Can analyse definition (if exported from imported module)." - (reach-test var-name [true def-module] [true dependent-module] success?)) - (test "Cannot analyse definition (if not exported from imported module)." - (reach-test var-name [false def-module] [true dependent-module] failure?)) - (test "Cannot analyse definition (if exported from non-imported module)." - (reach-test var-name [true def-module] [false dependent-module] failure?)) - )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/structure.lux b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux deleted file mode 100644 index 4b43d150f..000000000 --- a/stdlib/test/test/lux/lang/compiler/analysis/structure.lux +++ /dev/null @@ -1,292 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Equivalence] - ["e" error] - [product] - [maybe] - [text] - text/format - (collection [list "list/" Functor] - [set])) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [type "type/" Equivalence] - (type ["tc" check]) - [".L" module] - (compiler [".L" init] - [".L" analysis #+ Analysis Variant Tag] - (analysis [".A" type] - ["/" structure] - [".A" expression]))) - test) - (// ["_." primitive])) - -(def: analyse (expressionA.analyser (:coerce lang.Eval []))) - -(do-template [ ] - [(def: #export - (All [a] (-> (Meta a) Bool)) - (|>> (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - _ - )))] - - [check-succeeds true false] - [check-fails false true] - ) - -(def: (check-sum' size tag variant) - (-> Nat Tag (Variant Analysis) Bool) - (let [variant-tag (if (get@ #analysisL.right? variant) - (inc (get@ #analysisL.lefts variant)) - (get@ #analysisL.lefts variant))] - (|> size dec (n/= tag) - (bool/= (get@ #analysisL.right? variant)) - (and (n/= tag variant-tag))))) - -(def: (check-sum type size tag analysis) - (-> Type Nat Tag (Meta Analysis) Bool) - (|> analysis - (typeA.with-type type) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success sumA) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size tag variant) - - _ - false))) - -(def: (tagged module tags type) - (All [a] (-> Text (List moduleL.Tag) Type (Meta a) (Meta [Module a]))) - (|>> (do macro.Monad - [_ (moduleL.declare-tags tags false type)]) - (moduleL.with-module +0 module))) - -(def: (check-variant module tags type size tag analysis) - (-> Text (List moduleL.Tag) Type Nat Tag (Meta Analysis) Bool) - (|> analysis - (tagged module tags type) - (typeA.with-type type) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success [_ sumA]) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size tag variant) - - _ - false))) - -(def: (right-size? size) - (-> Nat (-> Analysis Bool)) - (|>> analysisL.tuple list.size (n/= size))) - -(def: (check-record-inference module tags type size analysis) - (-> Text (List moduleL.Tag) Type Nat (Meta [Type Analysis]) Bool) - (|> analysis - (tagged module tags type) - (macro.run (initL.compiler [])) - (case> (#e.Success [_ productT productA]) - (and (type/= type productT) - (right-size? size productA)) - - _ - false))) - -(context: "Sums" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - choice (|> r.nat (:: @ map (n/% size))) - primitives (r.list size _primitive.primitive) - +choice (|> r.nat (:: @ map (n/% (inc size)))) - [_ +valueC] _primitive.primitive - #let [variantT (type.variant (list/map product.left primitives)) - [valueT valueC] (maybe.assume (list.nth choice primitives)) - +size (inc size) - +primitives (list.concat (list (list.take choice primitives) - (list [(#.Parameter +1) +valueC]) - (list.drop choice primitives))) - [+valueT +valueC] (maybe.assume (list.nth +choice +primitives)) - +variantT (type.variant (list/map product.left +primitives))]] - ($_ seq - (test "Can analyse sum." - (check-sum variantT size choice - (/.sum ..analyse choice valueC))) - (test "Can analyse sum through bound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var) - _ (typeA.with-env - (tc.check varT variantT))] - (typeA.with-type varT - (/.sum ..analyse choice valueC))) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success sumA) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size choice variant) - - _ - false))) - (test "Cannot analyse sum through unbound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var)] - (typeA.with-type varT - (/.sum ..analyse choice valueC))) - check-fails)) - (test "Can analyse sum through existential quantification." - (|> (typeA.with-type (type.ex-q +1 +variantT) - (/.sum ..analyse +choice +valueC)) - check-succeeds)) - (test "Can analyse sum through universal quantification." - (let [check-outcome (if (not (n/= choice +choice)) - check-succeeds - check-fails)] - (|> (typeA.with-type (type.univ-q +1 +variantT) - (/.sum ..analyse +choice +valueC)) - check-outcome))) - )))) - -(context: "Products" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - primitives (r.list size _primitive.primitive) - choice (|> r.nat (:: @ map (n/% size))) - [_ +valueC] _primitive.primitive - #let [tupleT (type.tuple (list/map product.left primitives)) - [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) - +primitives (list.concat (list (list.take choice primitives) - (list [(#.Parameter +1) +valueC]) - (list.drop choice primitives))) - +tupleT (type.tuple (list/map product.left +primitives))]] - ($_ seq - (test "Can analyse product." - (|> (typeA.with-type tupleT - (/.product ..analyse (list/map product.right primitives))) - (macro.run (initL.compiler [])) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - false))) - (test "Can infer product." - (|> (typeA.with-inference - (/.product ..analyse (list/map product.right primitives))) - (macro.run (initL.compiler [])) - (case> (#e.Success [_type tupleA]) - (and (type/= tupleT _type) - (right-size? size tupleA)) - - _ - false))) - (test "Can analyse pseudo-product (singleton tuple)" - (|> (typeA.with-type singletonT - (..analyse (` [(~ singletonC)]))) - check-succeeds)) - (test "Can analyse product through bound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var) - _ (typeA.with-env - (tc.check varT (type.tuple (list/map product.left primitives))))] - (typeA.with-type varT - (/.product ..analyse (list/map product.right primitives)))) - (macro.run (initL.compiler [])) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - false))) - (test "Can analyse product through existential quantification." - (|> (typeA.with-type (type.ex-q +1 +tupleT) - (/.product ..analyse (list/map product.right +primitives))) - check-succeeds)) - (test "Cannot analyse product through universal quantification." - (|> (typeA.with-type (type.univ-q +1 +tupleT) - (/.product ..analyse (list/map product.right +primitives))) - check-fails)) - )))) - -(context: "Tagged Sums" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - choice (|> r.nat (:: @ map (n/% size))) - other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not))) - primitives (r.list size _primitive.primitive) - module-name (r.unicode +5) - type-name (r.unicode +5) - #let [varT (#.Parameter +1) - primitivesT (list/map product.left primitives) - [choiceT choiceC] (maybe.assume (list.nth choice primitives)) - [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives)) - variantT (type.variant primitivesT) - namedT (#.Named [module-name type-name] variantT) - named-polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) - (list varT) - (list.drop (inc choice) primitivesT)))) - (type.univ-q +1) - (#.Named [module-name type-name])) - choice-tag (maybe.assume (list.nth choice tags)) - other-choice-tag (maybe.assume (list.nth other-choice tags))]] - ($_ seq - (test "Can infer tagged sum." - (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) - (check-variant module-name tags namedT choice size))) - (test "Tagged sums specialize when type-vars get bound." - (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) - (check-variant module-name tags named-polyT choice size))) - (test "Tagged sum inference retains universal quantification when type-vars are not bound." - (|> (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC) - (check-variant module-name tags named-polyT other-choice size))) - (test "Can specialize generic tagged sums." - (|> (typeA.with-type variantT - (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC)) - (check-variant module-name tags named-polyT other-choice size))) - )))) - -(context: "Records" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - primitives (r.list size _primitive.primitive) - module-name (r.unicode +5) - type-name (r.unicode +5) - choice (|> r.nat (:: @ map (n/% size))) - #let [varT (#.Parameter +1) - tagsC (list/map (|>> [module-name] code.tag) tags) - primitivesT (list/map product.left primitives) - primitivesC (list/map product.right primitives) - tupleT (type.tuple primitivesT) - namedT (#.Named [module-name type-name] tupleT) - recordC (list.zip2 tagsC primitivesC) - named-polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) - (list varT) - (list.drop (inc choice) primitivesT)))) - (type.univ-q +1) - (#.Named [module-name type-name]))]] - ($_ seq - (test "Can infer record." - (|> (typeA.with-inference - (/.record ..analyse recordC)) - (check-record-inference module-name tags namedT size))) - (test "Records specialize when type-vars get bound." - (|> (typeA.with-inference - (/.record ..analyse recordC)) - (check-record-inference module-name tags named-polyT size))) - (test "Can specialize generic records." - (|> (do macro.Monad - [recordA (typeA.with-type tupleT - (/.record ..analyse recordC))] - (wrap [tupleT recordA])) - (check-record-inference module-name tags named-polyT size))) - )))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/case.lux b/stdlib/test/test/lux/lang/compiler/synthesis/case.lux deleted file mode 100644 index 228ed2920..000000000 --- a/stdlib/test/test/lux/lang/compiler/synthesis/case.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - pipe) - (data [error "error/" Functor]) - (lang ["///." reference] - ["///." compiler] - [".L" analysis #+ Branch Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random "r/" Monad] - test) - [//primitive]) - -(context: "Dummy variables." - (<| (times +100) - (do @ - [maskedA //primitive.primitive - temp (|> r.nat (:: @ map (n/% +100))) - #let [maskA (analysisL.control/case - [maskedA - [[(#analysisL.Bind temp) - (#analysisL.Reference (///reference.local temp))] - (list)]])]] - (test "Dummy variables created to mask expressions get eliminated during synthesis." - (|> maskA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (error/map (//primitive.corresponds? maskedA)) - (error.default false)))))) - -(context: "Let expressions." - (<| (times +100) - (do @ - [registerA r.nat - inputA //primitive.primitive - outputA //primitive.primitive - #let [letA (analysisL.control/case - [inputA - [[(#analysisL.Bind registerA) - outputA] - (list)]])]] - (test "Can detect and reify simple 'let' expressions." - (|> letA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) - (and (n/= registerA registerS) - (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? outputA outputS)) - - _ - false)))))) - -(context: "If expressions." - (<| (times +100) - (do @ - [then|else r.bool - inputA //primitive.primitive - thenA //primitive.primitive - elseA //primitive.primitive - #let [thenB (: Branch - [(#analysisL.Simple (#analysisL.Bool true)) - thenA]) - elseB (: Branch - [(#analysisL.Simple (#analysisL.Bool false)) - elseA]) - ifA (if then|else - (analysisL.control/case [inputA [thenB (list elseB)]]) - (analysisL.control/case [inputA [elseB (list thenB)]]))]] - (test "Can detect and reify simple 'if' expressions." - (|> ifA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) - (and (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? thenA thenS) - (//primitive.corresponds? elseA elseS)) - - _ - false)))))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/function.lux b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux deleted file mode 100644 index 008062e5e..000000000 --- a/stdlib/test/test/lux/lang/compiler/synthesis/function.lux +++ /dev/null @@ -1,168 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [product] - [maybe] - [error] - [number] - text/format - (collection [list "list/" Functor Fold] - ["dict" dictionary #+ Dictionary] - [set])) - (lang ["///." reference #+ Variable "variable/" Equivalence] - ["///." compiler] - [".L" analysis #+ Arity Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random] - test) - [//primitive]) - -(def: constant-function - (r.Random [Arity Analysis Analysis]) - (r.rec - (function (_ constant-function) - (do r.Monad - [function? r.bool] - (if function? - (do @ - [[arity bodyA predictionA] constant-function] - (wrap [(inc arity) - (#analysisL.Function (list) bodyA) - predictionA])) - (do @ - [predictionA //primitive.primitive] - (wrap [+0 predictionA predictionA]))))))) - -(def: (pick scope-size) - (-> Nat (r.Random Nat)) - (|> r.nat (:: r.Monad map (n/% scope-size)))) - -(def: function-with-environment - (r.Random [Arity Analysis Variable]) - (do r.Monad - [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10)))) - #let [indices (list.n/range +0 (dec num-locals)) - local-env (list/map (|>> #///reference.Local) indices) - foreign-env (list/map (|>> #///reference.Foreign) indices)] - [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable]) - (loop [arity +1 - current-env foreign-env] - (let [current-env/size (list.size current-env) - resolver (list/fold (function (_ [idx var] resolver) - (dict.put idx var resolver)) - (: (Dictionary Nat Variable) - (dict.new number.Hash)) - (list.enumerate current-env))] - (do @ - [nest? r.bool] - (if nest? - (do @ - [num-picks (:: @ map (n/max +1) (pick (inc current-env/size))) - picks (|> (r.set number.Hash num-picks (pick current-env/size)) - (:: @ map set.to-list)) - [arity bodyA predictionA] (recur (inc arity) - (list/map (function (_ pick) - (maybe.assume (list.nth pick current-env))) - picks)) - #let [picked-env (list/map (|>> #///reference.Foreign) picks)]] - (wrap [arity - (#analysisL.Function picked-env bodyA) - predictionA])) - (do @ - [chosen (pick (list.size current-env))] - (wrap [arity - (#analysisL.Reference (///reference.foreign chosen)) - (maybe.assume (dict.get chosen resolver))])))))))] - (wrap [arity - (#analysisL.Function local-env bodyA) - predictionA]))) - -(def: local-function - (r.Random [Arity Analysis Variable]) - (loop [arity +0 - nest? true] - (if nest? - (do r.Monad - [nest?' r.bool - [arity' bodyA predictionA] (recur (inc arity) nest?')] - (wrap [arity' - (#analysisL.Function (list) bodyA) - predictionA])) - (do r.Monad - [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] - (wrap [arity - (#analysisL.Reference (///reference.local chosen)) - (|> chosen (n/+ (dec arity)) #///reference.Local)]))))) - -(context: "Function definition." - (<| (seed +13007429814532219492) - ## (times +100) - (do @ - [[arity//constant function//constant prediction//constant] constant-function - [arity//environment function//environment prediction//environment] function-with-environment - [arity//local function//local prediction//local] local-function] - ($_ seq - (test "Nested functions will get folded together." - (|> function//constant - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity output]))) - (and (n/= arity//constant arity) - (//primitive.corresponds? prediction//constant output)) - - _ - (n/= +0 arity//constant)))) - (test "Folded functions provide direct access to environment variables." - (|> function//environment - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) - (and (n/= arity//environment arity) - (variable/= prediction//environment output)) - - _ - false))) - (test "Folded functions properly offset local variables." - (|> function//local - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) - (and (n/= arity//local arity) - (variable/= prediction//local output)) - - _ - false))) - )))) - -(context: "Function application." - (<| (times +100) - (do @ - [arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1)))) - funcA //primitive.primitive - argsA (r.list arity //primitive.primitive)] - ($_ seq - (test "Can synthesize function application." - (|> (analysisL.apply [funcA argsA]) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/apply [funcS argsS]))) - (and (//primitive.corresponds? funcA funcS) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 argsA argsS))) - - _ - false))) - (test "Function application on no arguments just synthesizes to the function itself." - (|> (analysisL.apply [funcA (list)]) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success funcS) - (//primitive.corresponds? funcA funcS) - - _ - false))) - )))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux b/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux deleted file mode 100644 index 0fd4d58c1..000000000 --- a/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux +++ /dev/null @@ -1,92 +0,0 @@ -(.module: - [lux #- primitive] - (lux [io] - (control [monad #+ do] - pipe) - (data [error] - text/format) - [lang] - (lang [".L" extension] - ["///." compiler] - [".L" analysis #+ Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression])) - ["r" math/random] - test)) - -(def: #export primitive - (r.Random Analysis) - (do r.Monad - [primitive (: (r.Random analysisL.Primitive) - ($_ r.alt - (wrap []) - r.bool - r.nat - r.int - r.rev - r.frac - (r.unicode +5)))] - (wrap (#analysisL.Primitive primitive)))) - -(def: #export (corresponds? analysis synthesis) - (-> Analysis Synthesis Bool) - (case [synthesis analysis] - [(#//.Primitive (#//.Text valueS)) - (#analysisL.Primitive (#analysisL.Unit valueA))] - (is? valueS (:coerce Text valueA)) - - [(#//.Primitive (#//.Bool valueS)) - (#analysisL.Primitive (#analysisL.Bool valueA))] - (is? valueS valueA) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Nat valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Int valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Rev valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.F64 valueS)) - (#analysisL.Primitive (#analysisL.Frac valueA))] - (is? valueS valueA) - - [(#//.Primitive (#//.Text valueS)) - (#analysisL.Primitive (#analysisL.Text valueA))] - (is? valueS valueA) - - _ - false)) - -(context: "Primitives." - (<| (times +100) - (do @ - [%bool% r.bool - %nat% r.nat - %int% r.int - %rev% r.rev - %frac% r.frac - %text% (r.unicode +5)] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format "Can synthesize " ".") - (|> (#analysisL.Primitive ( )) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Primitive ( value))) - (is? value) - - _ - false)))] - - ["unit" #analysisL.Unit #//.Text //.unit] - ["bool" #analysisL.Bool #//.Bool %bool%] - ["nat" #analysisL.Nat #//.I64 (.i64 %nat%)] - ["int" #analysisL.Int #//.I64 (.i64 %int%)] - ["rev" #analysisL.Rev #//.I64 (.i64 %rev%)] - ["frac" #analysisL.Frac #//.F64 %frac%] - ["text" #analysisL.Text #//.Text %text%]))))))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux deleted file mode 100644 index b3e4d6b67..000000000 --- a/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux +++ /dev/null @@ -1,57 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Equivalence] - [product] - [error] - (collection [list])) - (lang ["///." compiler] - [".L" analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random "r/" Monad] - test) - [//primitive]) - -(context: "Variants" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/+ +2)))) - tagA (|> r.nat (:: @ map (n/% size))) - memberA //primitive.primitive] - ($_ seq - (test "Can synthesize variants." - (|> (analysisL.sum-analysis size tagA memberA) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS]))) - (let [tagS (if right?S (inc leftsS) leftsS)] - (and (n/= tagA tagS) - (|> tagS (n/= (dec size)) (bool/= right?S)) - (//primitive.corresponds? memberA valueS))) - - _ - false))) - )))) - -(context: "Tuples" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - membersA (r.list size //primitive.primitive)] - ($_ seq - (test "Can synthesize tuple." - (|> (analysisL.product-analysis membersA) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Structure (#//.Tuple membersS))) - (and (n/= size (list.size membersS)) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 membersA membersS))) - - _ - false))) - )))) diff --git a/stdlib/test/test/lux/lang/syntax.lux b/stdlib/test/test/lux/lang/syntax.lux deleted file mode 100644 index 9c2be5dd2..000000000 --- a/stdlib/test/test/lux/lang/syntax.lux +++ /dev/null @@ -1,242 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do]) - (data [number] - ["e" error] - [text] - (text format - ["l" lexer]) - (collection [list] - ["dict" dictionary #+ Dictionary])) - ["r" math/random "r/" Monad] - (macro [code]) - (lang ["&" syntax]) - test)) - -(def: default-cursor - Cursor - {#.module "" - #.line +0 - #.column +0}) - -(def: ident-part^ - (r.Random Text) - (do r.Monad - [#let [digits "0123456789" - delimiters "()[]{}#.\"" - space "\t\v \n\r\f" - invalid-range (format digits delimiters space) - char-gen (|> r.nat - (:: @ map (|>> (n/% +256) (n/max +1))) - (r.filter (function (_ sample) - (not (text.contains? (text.from-code sample) - invalid-range)))))] - size (|> r.nat (:: @ map (|>> (n/% +20) (n/max +1))))] - (r.text char-gen size))) - -(def: ident^ - (r.Random Ident) - (r.seq ident-part^ ident-part^)) - -(def: code^ - (r.Random Code) - (let [numeric^ (: (r.Random Code) - ($_ r.either - (|> r.bool (r/map code.bool)) - (|> r.nat (r/map code.nat)) - (|> r.int (r/map code.int)) - (|> r.rev (r/map code.rev)) - (|> r.frac (r/map code.frac)))) - textual^ (: (r.Random Code) - ($_ r.either - (do r.Monad - [size (|> r.nat (r/map (n/% +20)))] - (|> (r.unicode size) (r/map code.text))) - (|> ident^ (r/map code.symbol)) - (|> ident^ (r/map code.tag)))) - simple^ (: (r.Random Code) - ($_ r.either - numeric^ - textual^))] - (r.rec - (function (_ code^) - (let [multi^ (do r.Monad - [size (|> r.nat (r/map (n/% +3)))] - (r.list size code^)) - composite^ (: (r.Random Code) - ($_ r.either - (|> multi^ (r/map code.form)) - (|> multi^ (r/map code.tuple)) - (do r.Monad - [size (|> r.nat (r/map (n/% +3)))] - (|> (r.list size (r.seq code^ code^)) - (r/map code.record)))))] - (r.either simple^ - composite^)))))) - -(context: "Lux code syntax." - (<| (times +100) - (do @ - [sample code^ - other code^] - ($_ seq - (test "Can parse Lux code." - (case (&.read "" (dict.new text.Hash) - [default-cursor +0 (code.to-text sample)]) - (#e.Error error) - false - - (#e.Success [_ parsed]) - (:: code.Equivalence = parsed sample))) - (test "Can parse Lux multiple code nodes." - (case (&.read "" (dict.new text.Hash) - [default-cursor +0 (format (code.to-text sample) " " - (code.to-text other))]) - (#e.Error error) - false - - (#e.Success [remaining =sample]) - (case (&.read "" (dict.new text.Hash) - remaining) - (#e.Error error) - false - - (#e.Success [_ =other]) - (and (:: code.Equivalence = sample =sample) - (:: code.Equivalence = other =other))))) - )))) - -(context: "Frac special syntax." - (<| (times +100) - (do @ - [numerator (|> r.nat (:: @ map (|>> (n/% +100) .int int-to-frac))) - denominator (|> r.nat (:: @ map (|>> (n/% +100) (n/max +1) .int int-to-frac))) - signed? r.bool - #let [expected (|> numerator (f// denominator) (f/* (if signed? -1.0 1.0)))]] - (test "Can parse frac ratio syntax." - (case (&.read "" (dict.new text.Hash) - [default-cursor +0 - (format (if signed? "-" "") - (%i (frac-to-int numerator)) - "/" - (%i (frac-to-int denominator)))]) - (#e.Success [_ [_ (#.Frac actual)]]) - (f/= expected actual) - - _ - false) - )))) - -(context: "Nat special syntax." - (<| (times +100) - (do @ - [expected (|> r.nat (:: @ map (n/% +1_000)))] - (test "Can parse nat char syntax." - (case (&.read "" (dict.new text.Hash) - [default-cursor +0 - (format "#" (%t (text.from-code expected)) "")]) - (#e.Success [_ [_ (#.Nat actual)]]) - (n/= expected actual) - - _ - false) - )))) - -(def: comment-text^ - (r.Random Text) - (let [char-gen (|> r.nat (r.filter (function (_ value) - (not (or (text.space? value) - (n/= (char "#") value) - (n/= (char "(") value) - (n/= (char ")") value))))))] - (do r.Monad - [size (|> r.nat (r/map (n/% +20)))] - (r.text char-gen size)))) - -(def: comment^ - (r.Random Text) - (r.either (do r.Monad - [comment comment-text^] - (wrap (format "## " comment "\n"))) - (r.rec (function (_ nested^) - (do r.Monad - [comment (r.either comment-text^ - nested^)] - (wrap (format "#( " comment " )#"))))))) - -(context: "Multi-line text & comments." - (<| (seed +12137892244981970631) - ## (times +100) - (do @ - [#let [char-gen (|> r.nat (r.filter (function (_ value) - (not (or (text.space? value) - (n/= (char "\"") value))))))] - x char-gen - y char-gen - z char-gen - offset-size (|> r.nat (r/map (|>> (n/% +10) (n/max +1)))) - #let [offset (text.join-with "" (list.repeat offset-size " "))] - sample code^ - comment comment^ - unbalanced-comment comment-text^] - ($_ seq - (test "Will reject invalid multi-line text." - (let [bad-match (format (text.from-code x) "\n" - (text.from-code y) "\n" - (text.from-code z))] - (case (&.read "" (dict.new text.Hash) - [default-cursor +0 - (format "\"" bad-match "\"")]) - (#e.Error error) - true - - (#e.Success [_ parsed]) - false))) - (test "Will accept valid multi-line text" - (let [good-input (format (text.from-code x) "\n" - offset (text.from-code y) "\n" - offset (text.from-code z)) - good-output (format (text.from-code x) "\n" - (text.from-code y) "\n" - (text.from-code z))] - (case (&.read "" (dict.new text.Hash) - [(|> default-cursor (update@ #.column (n/+ (dec offset-size)))) - +0 - (format "\"" good-input "\"")]) - (#e.Error error) - false - - (#e.Success [_ parsed]) - (:: code.Equivalence = - parsed - (code.text good-output))))) - (test "Can handle comments." - (case (&.read "" (dict.new text.Hash) - [default-cursor +0 - (format comment (code.to-text sample))]) - (#e.Error error) - false - - (#e.Success [_ parsed]) - (:: code.Equivalence = parsed sample))) - (test "Will reject unbalanced multi-line comments." - (and (case (&.read "" (dict.new text.Hash) - [default-cursor +0 - (format "#(" "#(" unbalanced-comment ")#" - (code.to-text sample))]) - (#e.Error error) - true - - (#e.Success [_ parsed]) - false) - (case (&.read "" (dict.new text.Hash) - [default-cursor +0 - (format "#(" unbalanced-comment ")#" ")#" - (code.to-text sample))]) - (#e.Error error) - true - - (#e.Success [_ parsed]) - false))) - )))) diff --git a/stdlib/test/test/lux/lang/type.lux b/stdlib/test/test/lux/lang/type.lux deleted file mode 100644 index 0a5b42461..000000000 --- a/stdlib/test/test/lux/lang/type.lux +++ /dev/null @@ -1,163 +0,0 @@ -(.module: - lux - (lux [io] - (control ["M" monad #+ do Monad] - pipe) - (data [text "Text/" Monoid] - text/format - [number] - [maybe] - (collection [list])) - ["r" math/random] - (lang ["&" type])) - lux/test) - -## [Utils] -(def: gen-name - (r.Random Text) - (do r.Monad - [size (|> r.nat (:: @ map (n/% +10)))] - (r.unicode size))) - -(def: gen-ident - (r.Random Ident) - (r.seq gen-name gen-name)) - -(def: gen-type - (r.Random Type) - (let [(^open "R/") r.Monad] - (r.rec (function (_ gen-type) - ($_ r.alt - (r.seq gen-name (R/wrap (list))) - (r.seq gen-type gen-type) - (r.seq gen-type gen-type) - (r.seq gen-type gen-type) - r.nat - r.nat - r.nat - (r.seq (R/wrap (list)) gen-type) - (r.seq (R/wrap (list)) gen-type) - (r.seq gen-type gen-type) - (r.seq gen-ident gen-type) - ))))) - -## [Tests] -(context: "Types" - (<| (times +100) - (do @ - [sample gen-type] - (test "Every type is equal to itself." - (:: &.Equivalence = sample sample))))) - -(context: "Type application" - (test "Can apply quantified types (universal and existential quantification)." - (and (maybe.default false - (do maybe.Monad - [partial (&.apply (list Bool) Ann) - full (&.apply (list Int) partial)] - (wrap (:: &.Equivalence = full (#.Product Bool Int))))) - (|> (&.apply (list Bool) Text) - (case> #.None true _ false))))) - -(context: "Naming" - (let [base (#.Named ["" "a"] (#.Product Bool Int)) - aliased (#.Named ["" "c"] - (#.Named ["" "b"] - base))] - ($_ seq - (test "Can remove aliases from an already-named type." - (:: &.Equivalence = - base - (&.un-alias aliased))) - - (test "Can remove all names from a type." - (and (not (:: &.Equivalence = - base - (&.un-name aliased))) - (:: &.Equivalence = - (&.un-name base) - (&.un-name aliased))))))) - -(context: "Type construction [structs]" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (n/% +3))) - members (|> gen-type - (r.filter (function (_ type) - (case type - (^or (#.Sum _) (#.Product _)) - false - - _ - true))) - (list.repeat size) - (M.seq @)) - #let [(^open "&/") &.Equivalence - (^open "L/") (list.Equivalence &.Equivalence)]] - (with-expansions - [ (do-template [ ] - [(test (format "Can build and tear-down " " types.") - (let [flat (|> members )] - (or (L/= members flat) - (and (L/= (list) members) - (L/= (list ) flat)))))] - - ["variant" &.variant &.flatten-variant Nothing] - ["tuple" &.tuple &.flatten-tuple Any] - )] - ($_ seq - - ))))) - -(context: "Type construction [parameterized]" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (n/% +3))) - members (M.seq @ (list.repeat size gen-type)) - extra (|> gen-type - (r.filter (function (_ type) - (case type - (^or (#.Function _) (#.Apply _)) - false - - _ - true)))) - #let [(^open "&/") &.Equivalence - (^open "L/") (list.Equivalence &.Equivalence)]] - ($_ seq - (test "Can build and tear-down function types." - (let [[inputs output] (|> (&.function members extra) &.flatten-function)] - (and (L/= members inputs) - (&/= extra output)))) - - (test "Can build and tear-down application types." - (let [[tfunc tparams] (|> extra (&.application members) &.flatten-application)] - (n/= (list.size members) (list.size tparams)))) - )))) - -(context: "Type construction [higher order]" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (n/% +3))) - extra (|> gen-type - (r.filter (function (_ type) - (case type - (^or (#.UnivQ _) (#.ExQ _)) - false - - _ - true)))) - #let [(^open "&/") &.Equivalence]] - (with-expansions - [ (do-template [ ] - [(test (format "Can build and tear-down " " types.") - (let [[flat-size flat-body] (|> extra ( size) )] - (and (n/= size flat-size) - (&/= extra flat-body))))] - - ["universally-quantified" &.univ-q &.flatten-univ-q] - ["existentially-quantified" &.ex-q &.flatten-ex-q] - )] - ($_ seq - - ))))) diff --git a/stdlib/test/test/lux/lang/type/check.lux b/stdlib/test/test/lux/lang/type/check.lux deleted file mode 100644 index 889f05bd8..000000000 --- a/stdlib/test/test/lux/lang/type/check.lux +++ /dev/null @@ -1,262 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do Monad] - [pipe #+ case>]) - (data [product] - [maybe] - [number] - [text "text/" Monoid Equivalence] - text/format - (collection [list "list/" Functor] - [set])) - ["r" math/random] - (lang [type "type/" Equivalence] - ["@" type/check])) - lux/test) - -## [Utils] -(def: gen-name - (r.Random Text) - (do r.Monad - [size (|> r.nat (:: @ map (n/% +10)))] - (r.unicode size))) - -(def: gen-ident - (r.Random Ident) - (r.seq gen-name gen-name)) - -(def: gen-type - (r.Random Type) - (let [(^open "r/") r.Monad] - (r.rec (function (_ gen-type) - ($_ r.alt - (r.seq gen-name (r/wrap (list))) - (r.seq gen-type gen-type) - (r.seq gen-type gen-type) - (r.seq gen-type gen-type) - r.nat - r.nat - r.nat - (r.seq (r/wrap (list)) gen-type) - (r.seq (r/wrap (list)) gen-type) - (r.seq gen-type gen-type) - (r.seq gen-ident gen-type) - ))))) - -(def: (valid-type? type) - (-> Type Bool) - (case type - (#.Primitive name params) - (list.every? valid-type? params) - - (#.Ex id) - true - - (^template [] - ( left right) - (and (valid-type? left) (valid-type? right))) - ([#.Sum] [#.Product] [#.Function]) - - (#.Named name type') - (valid-type? type') - - _ - false)) - -(def: (type-checks? input) - (-> (@.Check []) Bool) - (case (@.run @.fresh-context input) - (#.Right []) - true - - (#.Left error) - false)) - -## [Tests] -(context: "Any and Nothing." - (<| (times +100) - (do @ - [sample (|> gen-type (r.filter valid-type?))] - ($_ seq - (test "Any is the super-type of everything." - (@.checks? Any sample)) - - (test "Nothing is the sub-type of everything." - (@.checks? sample Nothing)) - )))) - -(context: "Simple type-checking." - ($_ seq - (test "Any and Nothing match themselves." - (and (@.checks? Nothing Nothing) - (@.checks? Any Any))) - - (test "Existential types only match with themselves." - (and (type-checks? (do @.Monad - [[_ exT] @.existential] - (@.check exT exT))) - (not (type-checks? (do @.Monad - [[_ exTL] @.existential - [_ exTR] @.existential] - (@.check exTL exTR)))))) - - (test "Names do not affect type-checking." - (and (type-checks? (do @.Monad - [[_ exT] @.existential] - (@.check (#.Named ["module" "name"] exT) - exT))) - (type-checks? (do @.Monad - [[_ exT] @.existential] - (@.check exT - (#.Named ["module" "name"] exT)))) - (type-checks? (do @.Monad - [[_ exT] @.existential] - (@.check (#.Named ["module" "name"] exT) - (#.Named ["module" "name"] exT)))))) - - (test "Functions are covariant on inputs and contravariant on outputs." - (and (@.checks? (#.Function Nothing Any) - (#.Function Any Nothing)) - (not (@.checks? (#.Function Any Nothing) - (#.Function Nothing Any))))) - )) - -(context: "Type application." - (<| (times +100) - (do @ - [meta gen-type - data gen-type] - (test "Can type-check type application." - (and (@.checks? (|> Ann (#.Apply meta) (#.Apply data)) - (type.tuple (list meta data))) - (@.checks? (type.tuple (list meta data)) - (|> Ann (#.Apply meta) (#.Apply data)))))))) - -(context: "Primitive types." - (<| (times +100) - (do @ - [nameL gen-name - nameR (|> gen-name (r.filter (|>> (text/= nameL) not))) - paramL gen-type - paramR (|> gen-type (r.filter (|>> (@.checks? paramL) not)))] - ($_ seq - (test "Primitive types match when they have the same name and the same parameters." - (@.checks? (#.Primitive nameL (list paramL)) - (#.Primitive nameL (list paramL)))) - - (test "Names matter to primitive types." - (not (@.checks? (#.Primitive nameL (list paramL)) - (#.Primitive nameR (list paramL))))) - - (test "Parameters matter to primitive types." - (not (@.checks? (#.Primitive nameL (list paramL)) - (#.Primitive nameL (list paramR))))) - )))) - -(context: "Type variables." - ($_ seq - (test "Type-vars check against themselves." - (type-checks? (do @.Monad - [[id var] @.var] - (@.check var var)))) - - (test "Can bind unbound type-vars by type-checking against them." - (and (type-checks? (do @.Monad - [[id var] @.var] - (@.check var .Any))) - (type-checks? (do @.Monad - [[id var] @.var] - (@.check .Any var))))) - - (test "Cannot rebind already bound type-vars." - (not (type-checks? (do @.Monad - [[id var] @.var - _ (@.check var .Bool)] - (@.check var .Nat))))) - - (test "If the type bound to a var is a super-type to another, then the var is also a super-type." - (type-checks? (do @.Monad - [[id var] @.var - _ (@.check var Any)] - (@.check var .Bool)))) - - (test "If the type bound to a var is a sub-type of another, then the var is also a sub-type." - (type-checks? (do @.Monad - [[id var] @.var - _ (@.check var Nothing)] - (@.check .Bool var)))) - )) - -(def: (build-ring num-connections) - (-> Nat (@.Check [[Nat Type] (List [Nat Type]) [Nat Type]])) - (do @.Monad - [[head-id head-type] @.var - ids+types (monad.seq @ (list.repeat num-connections @.var)) - [tail-id tail-type] (monad.fold @ (function (_ [tail-id tail-type] [_head-id _head-type]) - (do @ - [_ (@.check head-type tail-type)] - (wrap [tail-id tail-type]))) - [head-id head-type] - ids+types)] - (wrap [[head-id head-type] ids+types [tail-id tail-type]]))) - -(context: "Rings of type variables." - (<| (times +100) - (do @ - [num-connections (|> r.nat (:: @ map (n/% +100))) - boundT (|> gen-type (r.filter (|>> (case> (#.Var _) false _ true)))) - pick-pcg (r.seq r.nat r.nat)] - ($_ seq - (test "Can create rings of variables." - (type-checks? (do @.Monad - [[[head-id head-type] ids+types [tail-id tail-type]] (build-ring num-connections) - #let [ids (list/map product.left ids+types)] - headR (@.ring head-id) - tailR (@.ring tail-id)] - (@.assert "" - (let [same-rings? (:: set.Equivalence = headR tailR) - expected-size? (n/= (inc num-connections) (set.size headR)) - same-vars? (|> (set.to-list headR) - (list.sort n/<) - (:: (list.Equivalence number.Equivalence) = (list.sort n/< (#.Cons head-id ids))))] - (and same-rings? - expected-size? - same-vars?)))))) - (test "When a var in a ring is bound, all the ring is bound." - (type-checks? (do @.Monad - [[[head-id headT] ids+types tailT] (build-ring num-connections) - #let [ids (list/map product.left ids+types)] - _ (@.check headT boundT) - head-bound (@.read head-id) - tail-bound (monad.map @ @.read ids) - headR (@.ring head-id) - tailR+ (monad.map @ @.ring ids)] - (let [rings-were-erased? (and (set.empty? headR) - (list.every? set.empty? tailR+)) - same-types? (list.every? (type/= boundT) (list& (maybe.default headT head-bound) - (list/map (function (_ [tail-id ?tailT]) - (maybe.default (#.Var tail-id) ?tailT)) - (list.zip2 ids tail-bound))))] - (@.assert "" - (and rings-were-erased? - same-types?)))))) - (test "Can merge multiple rings of variables." - (type-checks? (do @.Monad - [[[head-idL headTL] ids+typesL [tail-idL tailTL]] (build-ring num-connections) - [[head-idR headTR] ids+typesR [tail-idR tailTR]] (build-ring num-connections) - headRL-pre (@.ring head-idL) - headRR-pre (@.ring head-idR) - _ (@.check headTL headTR) - headRL-post (@.ring head-idL) - headRR-post (@.ring head-idR)] - (@.assert "" - (let [same-rings? (:: set.Equivalence = headRL-post headRR-post) - expected-size? (n/= (n/* +2 (inc num-connections)) - (set.size headRL-post)) - union? (:: set.Equivalence = headRL-post (set.union headRL-pre headRR-pre))] - (and same-rings? - expected-size? - union?)))))) - )) - )) diff --git a/stdlib/test/test/lux/language/compiler/analysis/case.lux b/stdlib/test/test/lux/language/compiler/analysis/case.lux new file mode 100644 index 000000000..ef54a66c1 --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/analysis/case.lux @@ -0,0 +1,194 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "B/" Equivalence] + ["R" error] + [product] + [maybe] + [text "T/" Equivalence] + text/format + (collection [list "list/" Monad] + [set])) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + (language [type "type/" Equivalence] + (type ["tc" check]) + [".L" module] + (compiler [analysis] + (analysis [".A" type] + ["/" case]))) + test) + (// ["_." primitive] + ["_." structure])) + +(def: (exhaustive-weaving branchings) + (-> (List (List Code)) (List (List Code))) + (case branchings + #.Nil + #.Nil + + (#.Cons head+ #.Nil) + (list/map (|>> list) head+) + + (#.Cons head+ tail++) + (do list.Monad + [tail+ (exhaustive-weaving tail++) + head head+] + (wrap (#.Cons head tail+))))) + +(def: #export (exhaustive-branches allow-literals? variantTC inputC) + (-> Bool (List [Code Code]) Code (r.Random (List Code))) + (case inputC + [_ (#.Bool _)] + (r/wrap (list (' true) (' false))) + + (^template [ ] + [_ ( _)] + (if allow-literals? + (do r.Monad + [?sample (r.maybe )] + (case ?sample + (#.Some sample) + (do @ + [else (exhaustive-branches allow-literals? variantTC inputC)] + (wrap (list& ( sample) else))) + + #.None + (wrap (list (' _))))) + (r/wrap (list (' _))))) + ([#.Nat r.nat code.nat] + [#.Int r.int code.int] + [#.Rev r.rev code.rev] + [#.Frac r.frac code.frac] + [#.Text (r.unicode +5) code.text]) + + (^ [_ (#.Tuple (list))]) + (r/wrap (list (' []))) + + (^ [_ (#.Record (list))]) + (r/wrap (list (' {}))) + + [_ (#.Tuple members)] + (do r.Monad + [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (list/map code.tuple)))) + + [_ (#.Record kvs)] + (do r.Monad + [#let [ks (list/map product.left kvs) + vs (list/map product.right kvs)] + member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (list/map (|>> (list.zip2 ks) code.record))))) + + (^ [_ (#.Form (list [_ (#.Tag _)] _))]) + (do r.Monad + [bundles (monad.map @ + (function (_ [_tag _code]) + (do @ + [v-branches (exhaustive-branches allow-literals? variantTC _code)] + (wrap (list/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) + v-branches)))) + variantTC)] + (wrap (list/join bundles))) + + _ + (r/wrap (list)) + )) + +(def: #export (input variant-tags record-tags primitivesC) + (-> (List Code) (List Code) (List Code) (r.Random Code)) + (r.rec + (function (_ input) + ($_ r.either + (r/map product.right _primitive.primitive) + (do r.Monad + [choice (|> r.nat (:: @ map (n/% (list.size variant-tags)))) + #let [choiceT (maybe.assume (list.nth choice variant-tags)) + choiceC (maybe.assume (list.nth choice primitivesC))]] + (wrap (` ((~ choiceT) (~ choiceC))))) + (do r.Monad + [size (|> r.nat (:: @ map (n/% +3))) + elems (r.list size input)] + (wrap (code.tuple elems))) + (r/wrap (code.record (list.zip2 record-tags primitivesC))) + )))) + +(def: (branch body pattern) + (-> Code Code [Code Code]) + [pattern body]) + +(context: "Pattern-matching." + ## #seed +9253409297339902486 + ## #seed +3793366152923578600 + (<| (seed +5004137551292836565) + ## (times +100) + (do @ + [module-name (r.unicode +5) + variant-name (r.unicode +5) + record-name (|> (r.unicode +5) (r.filter (|>> (T/= variant-name) not))) + size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + variant-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + record-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + primitivesTC (r.list size _primitive.primitive) + #let [primitivesT (list/map product.left primitivesTC) + primitivesC (list/map product.right primitivesTC) + code-tag (|>> [module-name] code.tag) + variant-tags+ (list/map code-tag variant-tags) + record-tags+ (list/map code-tag record-tags) + variantTC (list.zip2 variant-tags+ primitivesC)] + inputC (input variant-tags+ record-tags+ primitivesC) + [outputT outputC] _primitive.primitive + [heterogeneousT heterogeneousC] (r.filter (|>> product.left (tc.checks? outputT) not) + _primitive.primitive) + exhaustive-patterns (exhaustive-branches true variantTC inputC) + redundant-patterns (exhaustive-branches false variantTC inputC) + redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) + heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns)))) + #let [exhaustive-branchesC (list/map (branch outputC) + exhaustive-patterns) + non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) + exhaustive-branchesC) + redundant-branchesC (<| (list/map (branch outputC)) + list.concat + (list (list.take redundancy-idx redundant-patterns) + (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) + (list.drop redundancy-idx redundant-patterns))) + heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) + (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] + [_pattern heterogeneousC])) + (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) + analyse-pm (|>> (/.case _primitive.analyse inputC) + (typeA.with-type outputT) + analysis.with-scope + (do Monad + [_ (moduleL.declare-tags variant-tags false + (#.Named [module-name variant-name] + (type.variant primitivesT))) + _ (moduleL.declare-tags record-tags false + (#.Named [module-name record-name] + (type.tuple primitivesT)))]) + (moduleL.with-module +0 module-name))]] + ($_ seq + (test "Will reject empty pattern-matching (no branches)." + (|> (analyse-pm (list)) + _structure.check-fails)) + (test "Can analyse exhaustive pattern-matching." + (|> (analyse-pm exhaustive-branchesC) + _structure.check-succeeds)) + (test "Will reject non-exhaustive pattern-matching." + (|> (analyse-pm non-exhaustive-branchesC) + _structure.check-fails)) + (test "Will reject redundant pattern-matching." + (|> (analyse-pm redundant-branchesC) + _structure.check-fails)) + (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." + (|> (analyse-pm heterogeneous-branchesC) + _structure.check-fails))) + ))) diff --git a/stdlib/test/test/lux/language/compiler/analysis/function.lux b/stdlib/test/test/lux/language/compiler/analysis/function.lux new file mode 100644 index 000000000..e751f5e27 --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/analysis/function.lux @@ -0,0 +1,112 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [maybe] + [product] + [text "text/" Equivalence] + text/format + (collection [list "list/" Functor])) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [language] + (language [type "type/" Equivalence] + [".L" reference] + (compiler [".L" init] + [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" expression] + ["/" function]))) + test) + (// ["_." primitive] + ["_." structure])) + +(def: analyse (expressionA.analyser (:coerce language.Eval []))) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Meta Analysis) Bool) + (|> analysis + (typeA.with-type expectedT) + (macro.run (initL.compiler [])) + (case> (#e.Success applyA) + (let [[funcA argsA] (analysisL.application applyA)] + (n/= num-args (list.size argsA))) + + (#e.Error error) + false))) + +(context: "Function definition." + (<| (times +100) + (do @ + [func-name (r.unicode +5) + arg-name (|> (r.unicode +5) (r.filter (|>> (text/= func-name) not))) + [outputT outputC] _primitive.primitive + [inputT _] _primitive.primitive + #let [g!arg (code.local-symbol arg-name)]] + ($_ seq + (test "Can analyse function." + (and (|> (typeA.with-type (All [a] (-> a outputT)) + (/.function ..analyse func-name arg-name outputC)) + _structure.check-succeeds) + (|> (typeA.with-type (All [a] (-> a a)) + (/.function ..analyse func-name arg-name g!arg)) + _structure.check-succeeds))) + (test "Generic functions can always be specialized." + (and (|> (typeA.with-type (-> inputT outputT) + (/.function ..analyse func-name arg-name outputC)) + _structure.check-succeeds) + (|> (typeA.with-type (-> inputT inputT) + (/.function ..analyse func-name arg-name g!arg)) + _structure.check-succeeds))) + (test "The function's name is bound to the function's type." + (|> (typeA.with-type (Rec self (-> inputT self)) + (/.function ..analyse func-name arg-name (code.local-symbol func-name))) + _structure.check-succeeds)) + )))) + +(context: "Function application." + (<| (times +100) + (do @ + [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + partial-args (|> r.nat (:: @ map (n/% full-args))) + var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1)))) + inputsTC (r.list full-args _primitive.primitive) + #let [inputsT (list/map product.left inputsTC) + inputsC (list/map product.right inputsTC)] + [outputT outputC] _primitive.primitive + #let [funcT (type.function inputsT outputT) + partialT (type.function (list.drop partial-args inputsT) outputT) + varT (#.Parameter +1) + polyT (<| (type.univ-q +1) + (type.function (list.concat (list (list.take var-idx inputsT) + (list varT) + (list.drop (inc var-idx) inputsT)))) + varT) + poly-inputT (maybe.assume (list.nth var-idx inputsT)) + partial-poly-inputsT (list.drop (inc var-idx) inputsT) + partial-polyT1 (<| (type.function partial-poly-inputsT) + poly-inputT) + partial-polyT2 (<| (type.univ-q +1) + (type.function (#.Cons varT partial-poly-inputsT)) + varT) + dummy-function (#analysisL.Function (list) (#analysisL.Reference (referenceL.local +1)))]] + ($_ seq + (test "Can analyse monomorphic type application." + (|> (/.apply ..analyse funcT dummy-function inputsC) + (check-apply outputT full-args))) + (test "Can partially apply functions." + (|> (/.apply ..analyse funcT dummy-function (list.take partial-args inputsC)) + (check-apply partialT partial-args))) + (test "Can apply polymorphic functions." + (|> (/.apply ..analyse polyT dummy-function inputsC) + (check-apply poly-inputT full-args))) + (test "Polymorphic partial application propagates found type-vars." + (|> (/.apply ..analyse polyT dummy-function (list.take (inc var-idx) inputsC)) + (check-apply partial-polyT1 (inc var-idx)))) + (test "Polymorphic partial application preserves quantification for type-vars." + (|> (/.apply ..analyse polyT dummy-function (list.take var-idx inputsC)) + (check-apply partial-polyT2 var-idx))) + )))) diff --git a/stdlib/test/test/lux/language/compiler/analysis/primitive.lux b/stdlib/test/test/lux/language/compiler/analysis/primitive.lux new file mode 100644 index 000000000..5e19dd4e8 --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/analysis/primitive.lux @@ -0,0 +1,86 @@ +(.module: + [lux #- primitive] + (lux [io] + (control [monad #+ do] + pipe + ["ex" exception #+ exception:]) + (data (text format) + ["e" error]) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [language] + (language [".L" type "type/" Equivalence] + (compiler [".L" init] + [analysis #+ Analysis] + (analysis [".A" type] + [".A" expression]))) + test)) + +(def: #export analyse (expressionA.analyser (:coerce language.Eval []))) + +(def: unit + (r.Random Code) + (r/wrap (' []))) + +(def: #export primitive + (r.Random [Type Code]) + (`` ($_ r.either + (~~ (do-template [ ] + [(r.seq (r/wrap ) (r/map ))] + + [Any code.tuple (r.list +0 ..unit)] + [Bool code.bool r.bool] + [Nat code.nat r.nat] + [Int code.int r.int] + [Rev code.rev r.rev] + [Frac code.frac r.frac] + [Text code.text (r.unicode +5)] + ))))) + +(exception: (wrong-inference {expected Type} {inferred Type}) + (ex.report ["Expected" (%type expected)] + ["Inferred" (%type inferred)])) + +(def: (infer-primitive expected-type analysis) + (-> Type (Meta Analysis) (e.Error Analysis)) + (|> (typeA.with-inference + analysis) + (macro.run (initL.compiler [])) + (case> (#e.Success [inferred-type output]) + (if (is? expected-type inferred-type) + (#e.Success output) + (ex.throw wrong-inference [expected-type inferred-type])) + + (#e.Error error) + (#e.Error error)))) + +(context: "Primitives" + ($_ seq + (test "Can analyse unit." + (|> (infer-primitive Any (..analyse (' []))) + (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output)))) + (is? [] output) + + _ + false))) + (<| (times +100) + (`` ($_ seq + (~~ (do-template [ ] + [(do @ + [sample ] + (test (format "Can analyse " ".") + (|> (infer-primitive (..analyse ( sample))) + (case> (#e.Success (#analysis.Primitive ( output))) + (is? sample output) + + _ + false))))] + + ["bool" Bool #analysis.Bool r.bool code.bool] + ["nat" Nat #analysis.Nat r.nat code.nat] + ["int" Int #analysis.Int r.int code.int] + ["rev" Rev #analysis.Rev r.rev code.rev] + ["frac" Frac #analysis.Frac r.frac code.frac] + ["text" Text #analysis.Text (r.unicode +5) code.text] + ))))))) diff --git a/stdlib/test/test/lux/language/compiler/analysis/procedure/common.lux b/stdlib/test/test/lux/language/compiler/analysis/procedure/common.lux new file mode 100644 index 000000000..743c4194c --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/analysis/procedure/common.lux @@ -0,0 +1,310 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data text/format + ["e" error] + [product] + (collection [array])) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [language] + (language [type "type/" Equivalence] + [".L" scope] + (compiler [".L" init] + (analysis [".A" type]))) + test) + (/// ["_." primitive])) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (scopeL.with-scope "" + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(context: "Lux procedures" + (<| (times +100) + (do @ + [[primT primC] _primitive.primitive + [antiT antiC] (|> _primitive.primitive + (r.filter (|>> product.left (type/= primT) not)))] + ($_ seq + (test "Can test for reference equality." + (check-success+ "lux is" (list primC primC) Bool)) + (test "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bool)) + (test "Can 'try' risky IO computations." + (check-success+ "lux try" + (list (` ([(~' _) (~' _)] (~ primC)))) + (type (Either Text primT)))) + )))) + +(context: "Bit procedures" + (<| (times +100) + (do @ + [subjectC (|> r.nat (:: @ map code.nat)) + signedC (|> r.int (:: @ map code.int)) + paramC (|> r.nat (:: @ map code.nat))] + ($_ seq + (test "Can perform bit 'and'." + (check-success+ "lux bit and" (list subjectC paramC) Nat)) + (test "Can perform bit 'or'." + (check-success+ "lux bit or" (list subjectC paramC) Nat)) + (test "Can perform bit 'xor'." + (check-success+ "lux bit xor" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the left." + (check-success+ "lux bit left-shift" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the right." + (check-success+ "lux bit logical-right-shift" (list subjectC paramC) Nat)) + (test "Can shift signed bit pattern to the right." + (check-success+ "lux bit arithmetic-right-shift" (list signedC paramC) Int)) + )))) + +(context: "Int procedures" + (<| (times +100) + (do @ + [subjectC (|> r.int (:: @ map code.int)) + paramC (|> r.int (:: @ map code.int))] + ($_ seq + (test "Can add integers." + (check-success+ "lux int +" (list subjectC paramC) Int)) + (test "Can subtract integers." + (check-success+ "lux int -" (list subjectC paramC) Int)) + (test "Can multiply integers." + (check-success+ "lux int *" (list subjectC paramC) Int)) + (test "Can divide integers." + (check-success+ "lux int /" (list subjectC paramC) Int)) + (test "Can calculate remainder of integers." + (check-success+ "lux int %" (list subjectC paramC) Int)) + (test "Can test equivalence of integers." + (check-success+ "lux int =" (list subjectC paramC) Bool)) + (test "Can compare integers." + (check-success+ "lux int <" (list subjectC paramC) Bool)) + (test "Can obtain minimum integer." + (check-success+ "lux int min" (list) Int)) + (test "Can obtain maximum integer." + (check-success+ "lux int max" (list) Int)) + (test "Can convert integer to natural number." + (check-success+ "lux int to-nat" (list subjectC) Nat)) + (test "Can convert integer to frac number." + (check-success+ "lux int to-frac" (list subjectC) Frac)) + (test "Can convert integer to text." + (check-success+ "lux int char" (list subjectC) Text)) + )))) + +(context: "Frac procedures" + (<| (times +100) + (do @ + [subjectC (|> r.frac (:: @ map code.frac)) + paramC (|> r.frac (:: @ map code.frac)) + encodedC (|> (r.unicode +5) (:: @ map code.text))] + ($_ seq + (test "Can add frac numbers." + (check-success+ "lux frac +" (list subjectC paramC) Frac)) + (test "Can subtract frac numbers." + (check-success+ "lux frac -" (list subjectC paramC) Frac)) + (test "Can multiply frac numbers." + (check-success+ "lux frac *" (list subjectC paramC) Frac)) + (test "Can divide frac numbers." + (check-success+ "lux frac /" (list subjectC paramC) Frac)) + (test "Can calculate remainder of frac numbers." + (check-success+ "lux frac %" (list subjectC paramC) Frac)) + (test "Can test equivalence of frac numbers." + (check-success+ "lux frac =" (list subjectC paramC) Bool)) + (test "Can compare frac numbers." + (check-success+ "lux frac <" (list subjectC paramC) Bool)) + (test "Can obtain minimum frac number." + (check-success+ "lux frac min" (list) Frac)) + (test "Can obtain maximum frac number." + (check-success+ "lux frac max" (list) Frac)) + (test "Can obtain smallest frac number." + (check-success+ "lux frac smallest" (list) Frac)) + (test "Can convert frac number to integer." + (check-success+ "lux frac to-int" (list subjectC) Int)) + (test "Can convert frac number to text." + (check-success+ "lux frac encode" (list subjectC) Text)) + (test "Can convert text to frac number." + (check-success+ "lux frac decode" (list encodedC) (type (Maybe Frac)))) + )))) + +(context: "Text procedures" + (<| (times +100) + (do @ + [subjectC (|> (r.unicode +5) (:: @ map code.text)) + paramC (|> (r.unicode +5) (:: @ map code.text)) + replacementC (|> (r.unicode +5) (:: @ map code.text)) + fromC (|> r.nat (:: @ map code.nat)) + toC (|> r.nat (:: @ map code.nat))] + ($_ seq + (test "Can test text equivalence." + (check-success+ "lux text =" (list subjectC paramC) Bool)) + (test "Compare texts in lexicographical order." + (check-success+ "lux text <" (list subjectC paramC) Bool)) + (test "Can concatenate one text to another." + (check-success+ "lux text concat" (list subjectC paramC) Text)) + (test "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) + (test "Can query the size/length of a text." + (check-success+ "lux text size" (list subjectC) Nat)) + (test "Can calculate a hash code for text." + (check-success+ "lux text hash" (list subjectC) Nat)) + (test "Can replace a text inside of a larger one (once)." + (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) + (test "Can replace a text inside of a larger one (all times)." + (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) + (test "Can obtain the character code of a text at a given index." + (check-success+ "lux text char" (list subjectC fromC) (type (Maybe Nat)))) + (test "Can clip a piece of text between 2 indices." + (check-success+ "lux text clip" (list subjectC fromC toC) (type (Maybe Text)))) + )))) + +(context: "Array procedures" + (<| (times +100) + (do @ + [[elemT elemC] _primitive.primitive + sizeC (|> r.nat (:: @ map code.nat)) + idxC (|> r.nat (:: @ map code.nat)) + var-name (r.unicode +5) + #let [arrayT (type (Array elemT)) + g!array (code.local-symbol var-name) + array-operation (function (_ output-type code) + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name arrayT] + (typeA.with-type output-type + (_primitive.analyse code)))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error error) + false)))]] + ($_ seq + (test "Can create arrays." + (check-success+ "lux array new" (list sizeC) arrayT)) + (test "Can get a value inside an array." + (array-operation (type (Maybe elemT)) + (` ("lux array get" (~ g!array) (~ idxC))))) + (test "Can put a value inside an array." + (array-operation arrayT + (` ("lux array put" (~ g!array) (~ idxC) (~ elemC))))) + (test "Can remove a value from an array." + (array-operation arrayT + (` ("lux array remove" (~ g!array) (~ idxC))))) + (test "Can query the size of an array." + (array-operation Nat + (` ("lux array size" (~ g!array))))) + )))) + +(context: "Math procedures" + (<| (times +100) + (do @ + [subjectC (|> r.frac (:: @ map code.frac)) + paramC (|> r.frac (:: @ map code.frac))] + (`` ($_ seq + (~~ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC) Frac))] + + ["lux math cos" "cosine"] + ["lux math sin" "sine"] + ["lux math tan" "tangent"] + ["lux math acos" "inverse/arc cosine"] + ["lux math asin" "inverse/arc sine"] + ["lux math atan" "inverse/arc tangent"] + ["lux math cosh" "hyperbolic cosine"] + ["lux math sinh" "hyperbolic sine"] + ["lux math tanh" "hyperbolic tangent"] + ["lux math exp" "exponentiation"] + ["lux math log" "logarithm"] + ["lux math ceil" "ceiling"] + ["lux math floor" "floor"] + ["lux math round" "rounding"])) + (~~ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC paramC) Frac))] + + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"]))))))) + +(context: "Atom procedures" + (<| (times +100) + (do @ + [[elemT elemC] _primitive.primitive + sizeC (|> r.nat (:: @ map code.nat)) + idxC (|> r.nat (:: @ map code.nat)) + var-name (r.unicode +5) + #let [atomT (type (atom.Atom elemT))]] + ($_ seq + (test "Can create atomic reference." + (check-success+ "lux atom new" (list elemC) atomT)) + (test "Can read the value of an atomic reference." + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type elemT + (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error _) + false))) + (test "Can swap the value of an atomic reference." + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type Bool + (_primitive.analyse (` ("lux atom compare-and-swap" + (~ (code.symbol ["" var-name])) + (~ elemC) + (~ elemC))))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error _) + false))) + )))) + +(context: "Process procedures" + (<| (times +100) + (do @ + [[primT primC] _primitive.primitive + timeC (|> r.nat (:: @ map code.nat))] + ($_ seq + (test "Can query the level of concurrency." + (check-success+ "lux process parallelism-level" (list) Nat)) + (test "Can schedule an IO computation to run concurrently at some future time." + (check-success+ "lux process schedule" + (list timeC + (` ([(~' _) (~' _)] (~ primC)))) + Any)) + )))) + +(context: "IO procedures" + (<| (times +100) + (do @ + [logC (|> (r.unicode +5) (:: @ map code.text)) + exitC (|> r.int (:: @ map code.int))] + ($_ seq + (test "Can log messages to standard output." + (check-success+ "lux io log" (list logC) Any)) + (test "Can throw a run-time error." + (check-success+ "lux io error" (list logC) Nothing)) + (test "Can exit the program." + (check-success+ "lux io exit" (list exitC) Nothing)) + (test "Can query the current time (as milliseconds since epoch)." + (check-success+ "lux io current-time" (list) Int)) + )))) diff --git a/stdlib/test/test/lux/language/compiler/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/language/compiler/analysis/procedure/host.jvm.lux new file mode 100644 index 000000000..bbe4c0170 --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/analysis/procedure/host.jvm.lux @@ -0,0 +1,541 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data ["e" error] + [product] + [maybe] + [text "text/" Equivalence] + text/format + (collection [array] + [list "list/" Fold] + ["dict" dictionary])) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [language] + (language [type] + (compiler [".L" init] + (analysis [".A" type]) + (extension (analysis [".AE" host])))) + test) + (/// ["_." primitive])) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (do Monad + [## runtime-bytecode @runtime.translate + ] + (language.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params))))))) + (language.with-current-module "") + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [success true false] + [failure false true] + ) + +(do-template [ ] + [(def: ( syntax output-type) + (-> Code Type Bool) + (|> (do Monad + [## runtime-bytecode @runtime.translate + ] + (language.with-scope + (typeA.with-type output-type + (_primitive.analyse syntax)))) + (language.with-current-module "") + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [success' true false] + [failure' false true] + ) + +(context: "Conversions [double + float]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert double-to-float" "java.lang.Double" hostAE.Float] + ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer] + ["jvm convert double-to-long" "java.lang.Double" hostAE.Long] + ["jvm convert float-to-double" "java.lang.Float" hostAE.Double] + ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer] + ["jvm convert float-to-long" "java.lang.Float" hostAE.Long] + )] + ($_ seq + + ))) + +(context: "Conversions [int]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert int-to-byte" "java.lang.Integer" hostAE.Byte] + ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character] + ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double] + ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float] + ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long] + ["jvm convert int-to-short" "java.lang.Integer" hostAE.Short] + )] + ($_ seq + + ))) + +(context: "Conversions [long]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert long-to-double" "java.lang.Long" hostAE.Double] + ["jvm convert long-to-float" "java.lang.Long" hostAE.Float] + ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer] + ["jvm convert long-to-short" "java.lang.Long" hostAE.Short] + ["jvm convert long-to-byte" "java.lang.Long" hostAE.Byte] + )] + ($_ seq + + ))) + +(context: "Conversions [char + byte + short]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert char-to-byte" "java.lang.Character" hostAE.Byte] + ["jvm convert char-to-short" "java.lang.Character" hostAE.Short] + ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer] + ["jvm convert char-to-long" "java.lang.Character" hostAE.Long] + ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long] + ["jvm convert short-to-long" "java.lang.Short" hostAE.Long] + )] + ($_ seq + + ))) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + ))) + + (context: (format "Bitwise " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " and") ] + [(format "jvm " " or") ] + [(format "jvm " " xor") ] + [(format "jvm " " shl") "java.lang.Integer" ] + [(format "jvm " " shr") "java.lang.Integer" ] + [(format "jvm " " ushr") "java.lang.Integer" ] + )] + ($_ seq + + )))] + + + ["int" "java.lang.Integer" hostAE.Integer] + ["long" "java.lang.Long" hostAE.Long] + ) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + )))] + + + ["float" "java.lang.Float" hostAE.Float] + ["double" "java.lang.Double" hostAE.Double] + ) + +(do-template [ ] + [(context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + )))] + + + ["char" "java.lang.Character" hostAE.Character] + ) + +(def: array-type + (r.Random [Text Text]) + (let [entries (dict.entries hostAE.boxes) + num-entries (list.size entries)] + (do r.Monad + [choice (|> r.nat (:: @ map (n/% (inc num-entries)))) + #let [[unboxed boxed] (: [Text Text] + (|> entries + (list.nth choice) + (maybe.default ["java.lang.Object" "java.lang.Object"])))]] + (wrap [unboxed boxed])))) + +(context: "Array." + (<| (times +100) + (do @ + [#let [cap (|>> (n/% +10) (n/max +1))] + [unboxed boxed] array-type + size (|> r.nat (:: @ map cap)) + idx (|> r.nat (:: @ map (n/% size))) + level (|> r.nat (:: @ map cap)) + #let [unboxedT (#.Primitive unboxed (list)) + arrayT (#.Primitive "#Array" (list unboxedT)) + arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0))) + ("jvm array new" (~ (code.nat size))))) + boxedT (#.Primitive boxed (list)) + boxedTC (` (+0 (~ (code.text boxed)) (+0))) + multi-arrayT (list/fold (function (_ _ innerT) + (|> innerT (list) (#.Primitive "#Array"))) + boxedT + (list.n/range +1 level))]] + ($_ seq + (test "jvm array new" + (success "jvm array new" + (list (code.nat size)) + arrayT)) + (test "jvm array new (no nesting)" + (failure "jvm array new" + (list (code.nat size)) + unboxedT)) + (test "jvm array new (nested/multi-level)" + (success "jvm array new" + (list (code.nat size)) + multi-arrayT)) + (test "jvm array length" + (success "jvm array length" + (list arrayC) + Nat)) + (test "jvm array read" + (success' (` ("jvm object cast" + ("jvm array read" (~ arrayC) (~ (code.nat idx))))) + boxedT)) + (test "jvm array write" + (success "jvm array write" + (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) + arrayT)) + )))) + +(def: throwables + (List Text) + (list "java.lang.Throwable" + "java.lang.Error" + "java.io.IOError" + "java.lang.VirtualMachineError" + "java.lang.Exception" + "java.io.IOException" + "java.lang.RuntimeException")) + +(context: "Object." + (<| (times +100) + (do @ + [[unboxed boxed] array-type + [!unboxed !boxed] (|> array-type + (r.filter (function (_ [!unboxed !boxed]) + (not (text/= boxed !boxed))))) + #let [boxedT (#.Primitive boxed (list)) + boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0)) + ("jvm object null"))) + !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0)) + ("jvm object null"))) + unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) + ("jvm object null")))] + throwable (|> r.nat + (:: @ map (n/% (inc (list.size throwables)))) + (:: @ map (function (_ idx) + (|> throwables + (list.nth idx) + (maybe.default "java.lang.Object"))))) + #let [throwableC (`' ("lux check" (+0 (~ (code.text throwable)) (+0)) + ("jvm object null")))]] + ($_ seq + (test "jvm object null" + (success "jvm object null" + (list) + (#.Primitive boxed (list)))) + (test "jvm object null (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object null" + (list) + (#.Primitive unboxed (list))))) + (test "jvm object null?" + (success "jvm object null?" + (list boxedC) + Bool)) + (test "jvm object synchronized" + (success "jvm object synchronized" + (list boxedC boxedC) + boxedT)) + (test "jvm object synchronized (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object synchronized" + (list unboxedC boxedC) + boxedT))) + (test "jvm object throw" + (or (text/= "java.lang.Object" throwable) + (success "jvm object throw" + (list throwableC) + Nothing))) + (test "jvm object class" + (success "jvm object class" + (list (code.text boxed)) + (#.Primitive "java.lang.Class" (list boxedT)))) + (test "jvm object instance?" + (success "jvm object instance?" + (list (code.text boxed) + boxedC) + Bool)) + (test "jvm object instance? (lineage)" + (success "jvm object instance?" + (list (' "java.lang.Object") + boxedC) + Bool)) + (test "jvm object instance? (no lineage)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object instance?" + (list (code.text boxed) + !boxedC) + Bool))) + )))) + +(context: "Member [Static Field]." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code.text "java.lang.System") + (code.text "out")) + (#.Primitive "java.io.PrintStream" (list)))) + (test "jvm member static get (inheritance out)" + (success "jvm member static get" + (list (code.text "java.lang.System") + (code.text "out")) + (#.Primitive "java.lang.Object" (list)))) + (test "jvm member static put" + (success "jvm member static put" + (list (code.text "java.awt.datatransfer.DataFlavor") + (code.text "allHtmlFlavor") + (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) + ("jvm object null")))) + Any)) + (test "jvm member static put (final)" + (failure "jvm member static put" + (list (code.text "java.lang.System") + (code.text "out") + (`' ("lux check" (+0 "java.io.PrintStream" (+0)) + ("jvm object null")))) + Any)) + (test "jvm member static put (inheritance in)" + (success "jvm member static put" + (list (code.text "java.awt.datatransfer.DataFlavor") + (code.text "allHtmlFlavor") + (`' ("jvm object cast" + ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) + ("jvm object null"))))) + Any)) + )) + +(context: "Member [Virtual Field]." + ($_ seq + (test "jvm member virtual get" + (success "jvm member virtual get" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.String" (list)))) + (test "jvm member virtual get (inheritance out)" + (success "jvm member virtual get" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.Object" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "java.lang.String" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (primitive "org.omg.CORBA.ValueMember"))) + (test "jvm member virtual put (final)" + (failure "jvm member virtual put" + (list (code.text "javax.swing.text.html.parser.DTD") + (code.text "applet") + (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) + ("jvm object null")))) + (primitive "javax.swing.text.html.parser.DTD"))) + (test "jvm member virtual put (inheritance in)" + (success "jvm member virtual put" + (list (code.text "java.awt.GridBagConstraints") + (code.text "insets") + (`' ("jvm object cast" + ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) + ("jvm object null")))) + (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) + ("jvm object null")))) + (primitive "java.awt.GridBagConstraints"))) + )) + +(context: "Boxing/Unboxing." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code.text "java.util.GregorianCalendar") + (code.text "AD")) + (#.Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual get" + (success "jvm member virtual get" + (list (code.text "javax.accessibility.AccessibleAttributeSequence") + (code.text "startIndex") + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code.text "javax.accessibility.AccessibleAttributeSequence") + (code.text "startIndex") + (`' ("jvm object cast" + ("lux check" (+0 "java.lang.Integer" (+0)) + ("jvm object null")))) + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (primitive "javax.accessibility.AccessibleAttributeSequence"))) + )) + +(context: "Member [Method]." + (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) + +123)) + intC (`' ("jvm convert long-to-int" (~ longC))) + stringC (' ("lux coerce" (+0 "java.lang.String" (+0)) + "YOLO")) + objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) + ("jvm member invoke constructor" "java.util.ArrayList" + ["int" ("jvm object cast" (~ intC))])))] + ($_ seq + (test "jvm member invoke static" + (success' (` ("jvm member invoke static" + "java.lang.Long" "decode" + ["java.lang.String" (~ stringC)])) + (#.Primitive "java.lang.Long" (list)))) + (test "jvm member invoke virtual" + (success' (` ("jvm object cast" + ("jvm member invoke virtual" + "java.lang.Object" "equals" + ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke special" + (success' (` ("jvm object cast" + ("jvm member invoke special" + "java.lang.Long" "equals" + ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke interface" + (success' (` ("jvm object cast" + ("jvm member invoke interface" + "java.util.Collection" "add" + ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke constructor" + (success' (` ("jvm member invoke constructor" + "java.util.ArrayList" + ["int" ("jvm object cast" (~ intC))])) + (All [a] (#.Primitive "java.util.ArrayList" (list a))))) + ))) diff --git a/stdlib/test/test/lux/language/compiler/analysis/reference.lux b/stdlib/test/test/lux/language/compiler/analysis/reference.lux new file mode 100644 index 000000000..7016c3181 --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/analysis/reference.lux @@ -0,0 +1,102 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [ident "ident/" Equivalence] + [text "text/" Equivalence]) + ["r" math/random] + [macro #+ Monad] + (macro [code]) + [language] + (language [type "type/" Equivalence] + [".L" scope] + [".L" module] + [".L" reference] + (compiler [".L" init] + [".L" analysis] + (analysis [".A" type] + [".A" expression]))) + test) + (// ["_." primitive])) + +(def: analyse (expressionA.analyser (:coerce language.Eval []))) + +(type: Check (-> (e.Error Any) Bool)) + +(do-template [ ] + [(def: + Check + (|>> (case> (#e.Success _) + + + (#e.Error _) + )))] + + [success? true false] + [failure? false true] + ) + +(def: (reach-test var-name [export? def-module] [import? dependent-module] check!) + (-> Text [Bool Text] [Bool Text] Check Bool) + (|> (do Monad + [_ (moduleL.with-module +0 def-module + (moduleL.define var-name [Any + (if export? + (' {#.export? true}) + (' {})) + []]))] + (moduleL.with-module +0 dependent-module + (do @ + [_ (if import? + (moduleL.import def-module) + (wrap []))] + (typeA.with-inference + (..analyse (code.symbol [def-module var-name])))))) + (macro.run (initL.compiler [])) + check!)) + +(context: "References" + (<| (times +100) + (do @ + [[expectedT _] _primitive.primitive + def-module (r.unicode +5) + scope-name (r.unicode +5) + var-name (r.unicode +5) + dependent-module (|> (r.unicode +5) + (r.filter (|>> (text/= def-module) not)))] + ($_ seq + (test "Can analyse variable." + (|> (scopeL.with-scope scope-name + (scopeL.with-local [var-name expectedT] + (typeA.with-inference + (..analyse (code.local-symbol var-name))))) + (macro.run (initL.compiler [])) + (case> (^ (#e.Success [inferredT (#analysisL.Reference (referenceL.local var))])) + (and (type/= expectedT inferredT) + (n/= +0 var)) + + _ + false))) + (test "Can analyse definition (in the same module)." + (let [def-name [def-module var-name]] + (|> (do Monad + [_ (moduleL.define var-name [expectedT (' {}) []])] + (typeA.with-inference + (..analyse (code.symbol def-name)))) + (moduleL.with-module +0 def-module) + (macro.run (initL.compiler [])) + (case> (^ (#e.Success [_ inferredT (#analysisL.Reference (referenceL.constant constant-name))])) + (and (type/= expectedT inferredT) + (ident/= def-name constant-name)) + + _ + false)))) + (test "Can analyse definition (if exported from imported module)." + (reach-test var-name [true def-module] [true dependent-module] success?)) + (test "Cannot analyse definition (if not exported from imported module)." + (reach-test var-name [false def-module] [true dependent-module] failure?)) + (test "Cannot analyse definition (if exported from non-imported module)." + (reach-test var-name [true def-module] [false dependent-module] failure?)) + )))) diff --git a/stdlib/test/test/lux/language/compiler/analysis/structure.lux b/stdlib/test/test/lux/language/compiler/analysis/structure.lux new file mode 100644 index 000000000..177e84e52 --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/analysis/structure.lux @@ -0,0 +1,292 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Equivalence] + ["e" error] + [product] + [maybe] + [text] + text/format + (collection [list "list/" Functor] + [set])) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [language] + (language [type "type/" Equivalence] + (type ["tc" check]) + [".L" module] + (compiler [".L" init] + [".L" analysis #+ Analysis Variant Tag] + (analysis [".A" type] + ["/" structure] + [".A" expression]))) + test) + (// ["_." primitive])) + +(def: analyse (expressionA.analyser (:coerce language.Eval []))) + +(do-template [ ] + [(def: #export + (All [a] (-> (Meta a) Bool)) + (|>> (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + _ + )))] + + [check-succeeds true false] + [check-fails false true] + ) + +(def: (check-sum' size tag variant) + (-> Nat Tag (Variant Analysis) Bool) + (let [variant-tag (if (get@ #analysisL.right? variant) + (inc (get@ #analysisL.lefts variant)) + (get@ #analysisL.lefts variant))] + (|> size dec (n/= tag) + (bool/= (get@ #analysisL.right? variant)) + (and (n/= tag variant-tag))))) + +(def: (check-sum type size tag analysis) + (-> Type Nat Tag (Meta Analysis) Bool) + (|> analysis + (typeA.with-type type) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success sumA) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + false))) + +(def: (tagged module tags type) + (All [a] (-> Text (List moduleL.Tag) Type (Meta a) (Meta [Module a]))) + (|>> (do macro.Monad + [_ (moduleL.declare-tags tags false type)]) + (moduleL.with-module +0 module))) + +(def: (check-variant module tags type size tag analysis) + (-> Text (List moduleL.Tag) Type Nat Tag (Meta Analysis) Bool) + (|> analysis + (tagged module tags type) + (typeA.with-type type) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success [_ sumA]) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + false))) + +(def: (right-size? size) + (-> Nat (-> Analysis Bool)) + (|>> analysisL.tuple list.size (n/= size))) + +(def: (check-record-inference module tags type size analysis) + (-> Text (List moduleL.Tag) Type Nat (Meta [Type Analysis]) Bool) + (|> analysis + (tagged module tags type) + (macro.run (initL.compiler [])) + (case> (#e.Success [_ productT productA]) + (and (type/= type productT) + (right-size? size productA)) + + _ + false))) + +(context: "Sums" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + choice (|> r.nat (:: @ map (n/% size))) + primitives (r.list size _primitive.primitive) + +choice (|> r.nat (:: @ map (n/% (inc size)))) + [_ +valueC] _primitive.primitive + #let [variantT (type.variant (list/map product.left primitives)) + [valueT valueC] (maybe.assume (list.nth choice primitives)) + +size (inc size) + +primitives (list.concat (list (list.take choice primitives) + (list [(#.Parameter +1) +valueC]) + (list.drop choice primitives))) + [+valueT +valueC] (maybe.assume (list.nth +choice +primitives)) + +variantT (type.variant (list/map product.left +primitives))]] + ($_ seq + (test "Can analyse sum." + (check-sum variantT size choice + (/.sum ..analyse choice valueC))) + (test "Can analyse sum through bound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var) + _ (typeA.with-env + (tc.check varT variantT))] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success sumA) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size choice variant) + + _ + false))) + (test "Cannot analyse sum through unbound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var)] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + check-fails)) + (test "Can analyse sum through existential quantification." + (|> (typeA.with-type (type.ex-q +1 +variantT) + (/.sum ..analyse +choice +valueC)) + check-succeeds)) + (test "Can analyse sum through universal quantification." + (let [check-outcome (if (not (n/= choice +choice)) + check-succeeds + check-fails)] + (|> (typeA.with-type (type.univ-q +1 +variantT) + (/.sum ..analyse +choice +valueC)) + check-outcome))) + )))) + +(context: "Products" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + primitives (r.list size _primitive.primitive) + choice (|> r.nat (:: @ map (n/% size))) + [_ +valueC] _primitive.primitive + #let [tupleT (type.tuple (list/map product.left primitives)) + [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) + +primitives (list.concat (list (list.take choice primitives) + (list [(#.Parameter +1) +valueC]) + (list.drop choice primitives))) + +tupleT (type.tuple (list/map product.left +primitives))]] + ($_ seq + (test "Can analyse product." + (|> (typeA.with-type tupleT + (/.product ..analyse (list/map product.right primitives))) + (macro.run (initL.compiler [])) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + false))) + (test "Can infer product." + (|> (typeA.with-inference + (/.product ..analyse (list/map product.right primitives))) + (macro.run (initL.compiler [])) + (case> (#e.Success [_type tupleA]) + (and (type/= tupleT _type) + (right-size? size tupleA)) + + _ + false))) + (test "Can analyse pseudo-product (singleton tuple)" + (|> (typeA.with-type singletonT + (..analyse (` [(~ singletonC)]))) + check-succeeds)) + (test "Can analyse product through bound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var) + _ (typeA.with-env + (tc.check varT (type.tuple (list/map product.left primitives))))] + (typeA.with-type varT + (/.product ..analyse (list/map product.right primitives)))) + (macro.run (initL.compiler [])) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + false))) + (test "Can analyse product through existential quantification." + (|> (typeA.with-type (type.ex-q +1 +tupleT) + (/.product ..analyse (list/map product.right +primitives))) + check-succeeds)) + (test "Cannot analyse product through universal quantification." + (|> (typeA.with-type (type.univ-q +1 +tupleT) + (/.product ..analyse (list/map product.right +primitives))) + check-fails)) + )))) + +(context: "Tagged Sums" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + choice (|> r.nat (:: @ map (n/% size))) + other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not))) + primitives (r.list size _primitive.primitive) + module-name (r.unicode +5) + type-name (r.unicode +5) + #let [varT (#.Parameter +1) + primitivesT (list/map product.left primitives) + [choiceT choiceC] (maybe.assume (list.nth choice primitives)) + [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives)) + variantT (type.variant primitivesT) + namedT (#.Named [module-name type-name] variantT) + named-polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q +1) + (#.Named [module-name type-name])) + choice-tag (maybe.assume (list.nth choice tags)) + other-choice-tag (maybe.assume (list.nth other-choice tags))]] + ($_ seq + (test "Can infer tagged sum." + (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) + (check-variant module-name tags namedT choice size))) + (test "Tagged sums specialize when type-vars get bound." + (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) + (check-variant module-name tags named-polyT choice size))) + (test "Tagged sum inference retains universal quantification when type-vars are not bound." + (|> (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC) + (check-variant module-name tags named-polyT other-choice size))) + (test "Can specialize generic tagged sums." + (|> (typeA.with-type variantT + (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC)) + (check-variant module-name tags named-polyT other-choice size))) + )))) + +(context: "Records" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + primitives (r.list size _primitive.primitive) + module-name (r.unicode +5) + type-name (r.unicode +5) + choice (|> r.nat (:: @ map (n/% size))) + #let [varT (#.Parameter +1) + tagsC (list/map (|>> [module-name] code.tag) tags) + primitivesT (list/map product.left primitives) + primitivesC (list/map product.right primitives) + tupleT (type.tuple primitivesT) + namedT (#.Named [module-name type-name] tupleT) + recordC (list.zip2 tagsC primitivesC) + named-polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q +1) + (#.Named [module-name type-name]))]] + ($_ seq + (test "Can infer record." + (|> (typeA.with-inference + (/.record ..analyse recordC)) + (check-record-inference module-name tags namedT size))) + (test "Records specialize when type-vars get bound." + (|> (typeA.with-inference + (/.record ..analyse recordC)) + (check-record-inference module-name tags named-polyT size))) + (test "Can specialize generic records." + (|> (do macro.Monad + [recordA (typeA.with-type tupleT + (/.record ..analyse recordC))] + (wrap [tupleT recordA])) + (check-record-inference module-name tags named-polyT size))) + )))) diff --git a/stdlib/test/test/lux/language/compiler/synthesis/case.lux b/stdlib/test/test/lux/language/compiler/synthesis/case.lux new file mode 100644 index 000000000..92051fcb4 --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/synthesis/case.lux @@ -0,0 +1,82 @@ +(.module: + lux + (lux (control [monad #+ do] + pipe) + (data [error "error/" Functor]) + (language ["///." reference] + ["///." compiler] + [".L" analysis #+ Branch Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random "r/" Monad] + test) + [//primitive]) + +(context: "Dummy variables." + (<| (times +100) + (do @ + [maskedA //primitive.primitive + temp (|> r.nat (:: @ map (n/% +100))) + #let [maskA (analysisL.control/case + [maskedA + [[(#analysisL.Bind temp) + (#analysisL.Reference (///reference.local temp))] + (list)]])]] + (test "Dummy variables created to mask expressions get eliminated during synthesis." + (|> maskA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (error/map (//primitive.corresponds? maskedA)) + (error.default false)))))) + +(context: "Let expressions." + (<| (times +100) + (do @ + [registerA r.nat + inputA //primitive.primitive + outputA //primitive.primitive + #let [letA (analysisL.control/case + [inputA + [[(#analysisL.Bind registerA) + outputA] + (list)]])]] + (test "Can detect and reify simple 'let' expressions." + (|> letA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) + (and (n/= registerA registerS) + (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? outputA outputS)) + + _ + false)))))) + +(context: "If expressions." + (<| (times +100) + (do @ + [then|else r.bool + inputA //primitive.primitive + thenA //primitive.primitive + elseA //primitive.primitive + #let [thenB (: Branch + [(#analysisL.Simple (#analysisL.Bool true)) + thenA]) + elseB (: Branch + [(#analysisL.Simple (#analysisL.Bool false)) + elseA]) + ifA (if then|else + (analysisL.control/case [inputA [thenB (list elseB)]]) + (analysisL.control/case [inputA [elseB (list thenB)]]))]] + (test "Can detect and reify simple 'if' expressions." + (|> ifA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) + (and (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? thenA thenS) + (//primitive.corresponds? elseA elseS)) + + _ + false)))))) diff --git a/stdlib/test/test/lux/language/compiler/synthesis/function.lux b/stdlib/test/test/lux/language/compiler/synthesis/function.lux new file mode 100644 index 000000000..bd6c4c7a9 --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/synthesis/function.lux @@ -0,0 +1,168 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [product] + [maybe] + [error] + [number] + text/format + (collection [list "list/" Functor Fold] + ["dict" dictionary #+ Dictionary] + [set])) + (language ["///." reference #+ Variable "variable/" Equivalence] + ["///." compiler] + [".L" analysis #+ Arity Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random] + test) + [//primitive]) + +(def: constant-function + (r.Random [Arity Analysis Analysis]) + (r.rec + (function (_ constant-function) + (do r.Monad + [function? r.bool] + (if function? + (do @ + [[arity bodyA predictionA] constant-function] + (wrap [(inc arity) + (#analysisL.Function (list) bodyA) + predictionA])) + (do @ + [predictionA //primitive.primitive] + (wrap [+0 predictionA predictionA]))))))) + +(def: (pick scope-size) + (-> Nat (r.Random Nat)) + (|> r.nat (:: r.Monad map (n/% scope-size)))) + +(def: function-with-environment + (r.Random [Arity Analysis Variable]) + (do r.Monad + [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10)))) + #let [indices (list.n/range +0 (dec num-locals)) + local-env (list/map (|>> #///reference.Local) indices) + foreign-env (list/map (|>> #///reference.Foreign) indices)] + [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable]) + (loop [arity +1 + current-env foreign-env] + (let [current-env/size (list.size current-env) + resolver (list/fold (function (_ [idx var] resolver) + (dict.put idx var resolver)) + (: (Dictionary Nat Variable) + (dict.new number.Hash)) + (list.enumerate current-env))] + (do @ + [nest? r.bool] + (if nest? + (do @ + [num-picks (:: @ map (n/max +1) (pick (inc current-env/size))) + picks (|> (r.set number.Hash num-picks (pick current-env/size)) + (:: @ map set.to-list)) + [arity bodyA predictionA] (recur (inc arity) + (list/map (function (_ pick) + (maybe.assume (list.nth pick current-env))) + picks)) + #let [picked-env (list/map (|>> #///reference.Foreign) picks)]] + (wrap [arity + (#analysisL.Function picked-env bodyA) + predictionA])) + (do @ + [chosen (pick (list.size current-env))] + (wrap [arity + (#analysisL.Reference (///reference.foreign chosen)) + (maybe.assume (dict.get chosen resolver))])))))))] + (wrap [arity + (#analysisL.Function local-env bodyA) + predictionA]))) + +(def: local-function + (r.Random [Arity Analysis Variable]) + (loop [arity +0 + nest? true] + (if nest? + (do r.Monad + [nest?' r.bool + [arity' bodyA predictionA] (recur (inc arity) nest?')] + (wrap [arity' + (#analysisL.Function (list) bodyA) + predictionA])) + (do r.Monad + [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] + (wrap [arity + (#analysisL.Reference (///reference.local chosen)) + (|> chosen (n/+ (dec arity)) #///reference.Local)]))))) + +(context: "Function definition." + (<| (seed +13007429814532219492) + ## (times +100) + (do @ + [[arity//constant function//constant prediction//constant] constant-function + [arity//environment function//environment prediction//environment] function-with-environment + [arity//local function//local prediction//local] local-function] + ($_ seq + (test "Nested functions will get folded together." + (|> function//constant + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity output]))) + (and (n/= arity//constant arity) + (//primitive.corresponds? prediction//constant output)) + + _ + (n/= +0 arity//constant)))) + (test "Folded functions provide direct access to environment variables." + (|> function//environment + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) + (and (n/= arity//environment arity) + (variable/= prediction//environment output)) + + _ + false))) + (test "Folded functions properly offset local variables." + (|> function//local + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) + (and (n/= arity//local arity) + (variable/= prediction//local output)) + + _ + false))) + )))) + +(context: "Function application." + (<| (times +100) + (do @ + [arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1)))) + funcA //primitive.primitive + argsA (r.list arity //primitive.primitive)] + ($_ seq + (test "Can synthesize function application." + (|> (analysisL.apply [funcA argsA]) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/apply [funcS argsS]))) + (and (//primitive.corresponds? funcA funcS) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 argsA argsS))) + + _ + false))) + (test "Function application on no arguments just synthesizes to the function itself." + (|> (analysisL.apply [funcA (list)]) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success funcS) + (//primitive.corresponds? funcA funcS) + + _ + false))) + )))) diff --git a/stdlib/test/test/lux/language/compiler/synthesis/primitive.lux b/stdlib/test/test/lux/language/compiler/synthesis/primitive.lux new file mode 100644 index 000000000..04e8b4dec --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/synthesis/primitive.lux @@ -0,0 +1,92 @@ +(.module: + [lux #- primitive] + (lux [io] + (control [monad #+ do] + pipe) + (data [error] + text/format) + [language] + (language [".L" extension] + ["///." compiler] + [".L" analysis #+ Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression])) + ["r" math/random] + test)) + +(def: #export primitive + (r.Random Analysis) + (do r.Monad + [primitive (: (r.Random analysisL.Primitive) + ($_ r.alt + (wrap []) + r.bool + r.nat + r.int + r.rev + r.frac + (r.unicode +5)))] + (wrap (#analysisL.Primitive primitive)))) + +(def: #export (corresponds? analysis synthesis) + (-> Analysis Synthesis Bool) + (case [synthesis analysis] + [(#//.Primitive (#//.Text valueS)) + (#analysisL.Primitive (#analysisL.Unit valueA))] + (is? valueS (:coerce Text valueA)) + + [(#//.Primitive (#//.Bool valueS)) + (#analysisL.Primitive (#analysisL.Bool valueA))] + (is? valueS valueA) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Nat valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Int valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Rev valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.F64 valueS)) + (#analysisL.Primitive (#analysisL.Frac valueA))] + (is? valueS valueA) + + [(#//.Primitive (#//.Text valueS)) + (#analysisL.Primitive (#analysisL.Text valueA))] + (is? valueS valueA) + + _ + false)) + +(context: "Primitives." + (<| (times +100) + (do @ + [%bool% r.bool + %nat% r.nat + %int% r.int + %rev% r.rev + %frac% r.frac + %text% (r.unicode +5)] + (`` ($_ seq + (~~ (do-template [ ] + [(test (format "Can synthesize " ".") + (|> (#analysisL.Primitive ( )) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Primitive ( value))) + (is? value) + + _ + false)))] + + ["unit" #analysisL.Unit #//.Text //.unit] + ["bool" #analysisL.Bool #//.Bool %bool%] + ["nat" #analysisL.Nat #//.I64 (.i64 %nat%)] + ["int" #analysisL.Int #//.I64 (.i64 %int%)] + ["rev" #analysisL.Rev #//.I64 (.i64 %rev%)] + ["frac" #analysisL.Frac #//.F64 %frac%] + ["text" #analysisL.Text #//.Text %text%]))))))) diff --git a/stdlib/test/test/lux/language/compiler/synthesis/structure.lux b/stdlib/test/test/lux/language/compiler/synthesis/structure.lux new file mode 100644 index 000000000..e3351158e --- /dev/null +++ b/stdlib/test/test/lux/language/compiler/synthesis/structure.lux @@ -0,0 +1,57 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Equivalence] + [product] + [error] + (collection [list])) + (language ["///." compiler] + [".L" analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random "r/" Monad] + test) + [//primitive]) + +(context: "Variants" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/+ +2)))) + tagA (|> r.nat (:: @ map (n/% size))) + memberA //primitive.primitive] + ($_ seq + (test "Can synthesize variants." + (|> (analysisL.sum-analysis size tagA memberA) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS]))) + (let [tagS (if right?S (inc leftsS) leftsS)] + (and (n/= tagA tagS) + (|> tagS (n/= (dec size)) (bool/= right?S)) + (//primitive.corresponds? memberA valueS))) + + _ + false))) + )))) + +(context: "Tuples" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + membersA (r.list size //primitive.primitive)] + ($_ seq + (test "Can synthesize tuple." + (|> (analysisL.product-analysis membersA) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Structure (#//.Tuple membersS))) + (and (n/= size (list.size membersS)) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 membersA membersS))) + + _ + false))) + )))) diff --git a/stdlib/test/test/lux/language/syntax.lux b/stdlib/test/test/lux/language/syntax.lux new file mode 100644 index 000000000..9df62a608 --- /dev/null +++ b/stdlib/test/test/lux/language/syntax.lux @@ -0,0 +1,242 @@ +(.module: + lux + (lux [io] + (control [monad #+ do]) + (data [number] + ["e" error] + [text] + (text format + ["l" lexer]) + (collection [list] + ["dict" dictionary #+ Dictionary])) + ["r" math/random "r/" Monad] + (macro [code]) + (language ["&" syntax]) + test)) + +(def: default-cursor + Cursor + {#.module "" + #.line +0 + #.column +0}) + +(def: ident-part^ + (r.Random Text) + (do r.Monad + [#let [digits "0123456789" + delimiters "()[]{}#.\"" + space "\t\v \n\r\f" + invalid-range (format digits delimiters space) + char-gen (|> r.nat + (:: @ map (|>> (n/% +256) (n/max +1))) + (r.filter (function (_ sample) + (not (text.contains? (text.from-code sample) + invalid-range)))))] + size (|> r.nat (:: @ map (|>> (n/% +20) (n/max +1))))] + (r.text char-gen size))) + +(def: ident^ + (r.Random Ident) + (r.seq ident-part^ ident-part^)) + +(def: code^ + (r.Random Code) + (let [numeric^ (: (r.Random Code) + ($_ r.either + (|> r.bool (r/map code.bool)) + (|> r.nat (r/map code.nat)) + (|> r.int (r/map code.int)) + (|> r.rev (r/map code.rev)) + (|> r.frac (r/map code.frac)))) + textual^ (: (r.Random Code) + ($_ r.either + (do r.Monad + [size (|> r.nat (r/map (n/% +20)))] + (|> (r.unicode size) (r/map code.text))) + (|> ident^ (r/map code.symbol)) + (|> ident^ (r/map code.tag)))) + simple^ (: (r.Random Code) + ($_ r.either + numeric^ + textual^))] + (r.rec + (function (_ code^) + (let [multi^ (do r.Monad + [size (|> r.nat (r/map (n/% +3)))] + (r.list size code^)) + composite^ (: (r.Random Code) + ($_ r.either + (|> multi^ (r/map code.form)) + (|> multi^ (r/map code.tuple)) + (do r.Monad + [size (|> r.nat (r/map (n/% +3)))] + (|> (r.list size (r.seq code^ code^)) + (r/map code.record)))))] + (r.either simple^ + composite^)))))) + +(context: "Lux code syntax." + (<| (times +100) + (do @ + [sample code^ + other code^] + ($_ seq + (test "Can parse Lux code." + (case (&.read "" (dict.new text.Hash) + [default-cursor +0 (code.to-text sample)]) + (#e.Error error) + false + + (#e.Success [_ parsed]) + (:: code.Equivalence = parsed sample))) + (test "Can parse Lux multiple code nodes." + (case (&.read "" (dict.new text.Hash) + [default-cursor +0 (format (code.to-text sample) " " + (code.to-text other))]) + (#e.Error error) + false + + (#e.Success [remaining =sample]) + (case (&.read "" (dict.new text.Hash) + remaining) + (#e.Error error) + false + + (#e.Success [_ =other]) + (and (:: code.Equivalence = sample =sample) + (:: code.Equivalence = other =other))))) + )))) + +(context: "Frac special syntax." + (<| (times +100) + (do @ + [numerator (|> r.nat (:: @ map (|>> (n/% +100) .int int-to-frac))) + denominator (|> r.nat (:: @ map (|>> (n/% +100) (n/max +1) .int int-to-frac))) + signed? r.bool + #let [expected (|> numerator (f// denominator) (f/* (if signed? -1.0 1.0)))]] + (test "Can parse frac ratio syntax." + (case (&.read "" (dict.new text.Hash) + [default-cursor +0 + (format (if signed? "-" "") + (%i (frac-to-int numerator)) + "/" + (%i (frac-to-int denominator)))]) + (#e.Success [_ [_ (#.Frac actual)]]) + (f/= expected actual) + + _ + false) + )))) + +(context: "Nat special syntax." + (<| (times +100) + (do @ + [expected (|> r.nat (:: @ map (n/% +1_000)))] + (test "Can parse nat char syntax." + (case (&.read "" (dict.new text.Hash) + [default-cursor +0 + (format "#" (%t (text.from-code expected)) "")]) + (#e.Success [_ [_ (#.Nat actual)]]) + (n/= expected actual) + + _ + false) + )))) + +(def: comment-text^ + (r.Random Text) + (let [char-gen (|> r.nat (r.filter (function (_ value) + (not (or (text.space? value) + (n/= (char "#") value) + (n/= (char "(") value) + (n/= (char ")") value))))))] + (do r.Monad + [size (|> r.nat (r/map (n/% +20)))] + (r.text char-gen size)))) + +(def: comment^ + (r.Random Text) + (r.either (do r.Monad + [comment comment-text^] + (wrap (format "## " comment "\n"))) + (r.rec (function (_ nested^) + (do r.Monad + [comment (r.either comment-text^ + nested^)] + (wrap (format "#( " comment " )#"))))))) + +(context: "Multi-line text & comments." + (<| (seed +12137892244981970631) + ## (times +100) + (do @ + [#let [char-gen (|> r.nat (r.filter (function (_ value) + (not (or (text.space? value) + (n/= (char "\"") value))))))] + x char-gen + y char-gen + z char-gen + offset-size (|> r.nat (r/map (|>> (n/% +10) (n/max +1)))) + #let [offset (text.join-with "" (list.repeat offset-size " "))] + sample code^ + comment comment^ + unbalanced-comment comment-text^] + ($_ seq + (test "Will reject invalid multi-line text." + (let [bad-match (format (text.from-code x) "\n" + (text.from-code y) "\n" + (text.from-code z))] + (case (&.read "" (dict.new text.Hash) + [default-cursor +0 + (format "\"" bad-match "\"")]) + (#e.Error error) + true + + (#e.Success [_ parsed]) + false))) + (test "Will accept valid multi-line text" + (let [good-input (format (text.from-code x) "\n" + offset (text.from-code y) "\n" + offset (text.from-code z)) + good-output (format (text.from-code x) "\n" + (text.from-code y) "\n" + (text.from-code z))] + (case (&.read "" (dict.new text.Hash) + [(|> default-cursor (update@ #.column (n/+ (dec offset-size)))) + +0 + (format "\"" good-input "\"")]) + (#e.Error error) + false + + (#e.Success [_ parsed]) + (:: code.Equivalence = + parsed + (code.text good-output))))) + (test "Can handle comments." + (case (&.read "" (dict.new text.Hash) + [default-cursor +0 + (format comment (code.to-text sample))]) + (#e.Error error) + false + + (#e.Success [_ parsed]) + (:: code.Equivalence = parsed sample))) + (test "Will reject unbalanced multi-line comments." + (and (case (&.read "" (dict.new text.Hash) + [default-cursor +0 + (format "#(" "#(" unbalanced-comment ")#" + (code.to-text sample))]) + (#e.Error error) + true + + (#e.Success [_ parsed]) + false) + (case (&.read "" (dict.new text.Hash) + [default-cursor +0 + (format "#(" unbalanced-comment ")#" ")#" + (code.to-text sample))]) + (#e.Error error) + true + + (#e.Success [_ parsed]) + false))) + )))) diff --git a/stdlib/test/test/lux/language/type.lux b/stdlib/test/test/lux/language/type.lux new file mode 100644 index 000000000..ee53dd542 --- /dev/null +++ b/stdlib/test/test/lux/language/type.lux @@ -0,0 +1,163 @@ +(.module: + lux + (lux [io] + (control ["M" monad #+ do Monad] + pipe) + (data [text "Text/" Monoid] + text/format + [number] + [maybe] + (collection [list])) + ["r" math/random] + (language ["&" type])) + lux/test) + +## [Utils] +(def: gen-name + (r.Random Text) + (do r.Monad + [size (|> r.nat (:: @ map (n/% +10)))] + (r.unicode size))) + +(def: gen-ident + (r.Random Ident) + (r.seq gen-name gen-name)) + +(def: gen-type + (r.Random Type) + (let [(^open "R/") r.Monad] + (r.rec (function (_ gen-type) + ($_ r.alt + (r.seq gen-name (R/wrap (list))) + (r.seq gen-type gen-type) + (r.seq gen-type gen-type) + (r.seq gen-type gen-type) + r.nat + r.nat + r.nat + (r.seq (R/wrap (list)) gen-type) + (r.seq (R/wrap (list)) gen-type) + (r.seq gen-type gen-type) + (r.seq gen-ident gen-type) + ))))) + +## [Tests] +(context: "Types" + (<| (times +100) + (do @ + [sample gen-type] + (test "Every type is equal to itself." + (:: &.Equivalence = sample sample))))) + +(context: "Type application" + (test "Can apply quantified types (universal and existential quantification)." + (and (maybe.default false + (do maybe.Monad + [partial (&.apply (list Bool) Ann) + full (&.apply (list Int) partial)] + (wrap (:: &.Equivalence = full (#.Product Bool Int))))) + (|> (&.apply (list Bool) Text) + (case> #.None true _ false))))) + +(context: "Naming" + (let [base (#.Named ["" "a"] (#.Product Bool Int)) + aliased (#.Named ["" "c"] + (#.Named ["" "b"] + base))] + ($_ seq + (test "Can remove aliases from an already-named type." + (:: &.Equivalence = + base + (&.un-alias aliased))) + + (test "Can remove all names from a type." + (and (not (:: &.Equivalence = + base + (&.un-name aliased))) + (:: &.Equivalence = + (&.un-name base) + (&.un-name aliased))))))) + +(context: "Type construction [structs]" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (n/% +3))) + members (|> gen-type + (r.filter (function (_ type) + (case type + (^or (#.Sum _) (#.Product _)) + false + + _ + true))) + (list.repeat size) + (M.seq @)) + #let [(^open "&/") &.Equivalence + (^open "L/") (list.Equivalence &.Equivalence)]] + (with-expansions + [ (do-template [ ] + [(test (format "Can build and tear-down " " types.") + (let [flat (|> members )] + (or (L/= members flat) + (and (L/= (list) members) + (L/= (list ) flat)))))] + + ["variant" &.variant &.flatten-variant Nothing] + ["tuple" &.tuple &.flatten-tuple Any] + )] + ($_ seq + + ))))) + +(context: "Type construction [parameterized]" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (n/% +3))) + members (M.seq @ (list.repeat size gen-type)) + extra (|> gen-type + (r.filter (function (_ type) + (case type + (^or (#.Function _) (#.Apply _)) + false + + _ + true)))) + #let [(^open "&/") &.Equivalence + (^open "L/") (list.Equivalence &.Equivalence)]] + ($_ seq + (test "Can build and tear-down function types." + (let [[inputs output] (|> (&.function members extra) &.flatten-function)] + (and (L/= members inputs) + (&/= extra output)))) + + (test "Can build and tear-down application types." + (let [[tfunc tparams] (|> extra (&.application members) &.flatten-application)] + (n/= (list.size members) (list.size tparams)))) + )))) + +(context: "Type construction [higher order]" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (n/% +3))) + extra (|> gen-type + (r.filter (function (_ type) + (case type + (^or (#.UnivQ _) (#.ExQ _)) + false + + _ + true)))) + #let [(^open "&/") &.Equivalence]] + (with-expansions + [ (do-template [ ] + [(test (format "Can build and tear-down " " types.") + (let [[flat-size flat-body] (|> extra ( size) )] + (and (n/= size flat-size) + (&/= extra flat-body))))] + + ["universally-quantified" &.univ-q &.flatten-univ-q] + ["existentially-quantified" &.ex-q &.flatten-ex-q] + )] + ($_ seq + + ))))) diff --git a/stdlib/test/test/lux/language/type/check.lux b/stdlib/test/test/lux/language/type/check.lux new file mode 100644 index 000000000..7b24d0f91 --- /dev/null +++ b/stdlib/test/test/lux/language/type/check.lux @@ -0,0 +1,262 @@ +(.module: + lux + (lux [io] + (control [monad #+ do Monad] + [pipe #+ case>]) + (data [product] + [maybe] + [number] + [text "text/" Monoid Equivalence] + text/format + (collection [list "list/" Functor] + [set])) + ["r" math/random] + (language [type "type/" Equivalence] + (type ["@" check]))) + lux/test) + +## [Utils] +(def: gen-name + (r.Random Text) + (do r.Monad + [size (|> r.nat (:: @ map (n/% +10)))] + (r.unicode size))) + +(def: gen-ident + (r.Random Ident) + (r.seq gen-name gen-name)) + +(def: gen-type + (r.Random Type) + (let [(^open "r/") r.Monad] + (r.rec (function (_ gen-type) + ($_ r.alt + (r.seq gen-name (r/wrap (list))) + (r.seq gen-type gen-type) + (r.seq gen-type gen-type) + (r.seq gen-type gen-type) + r.nat + r.nat + r.nat + (r.seq (r/wrap (list)) gen-type) + (r.seq (r/wrap (list)) gen-type) + (r.seq gen-type gen-type) + (r.seq gen-ident gen-type) + ))))) + +(def: (valid-type? type) + (-> Type Bool) + (case type + (#.Primitive name params) + (list.every? valid-type? params) + + (#.Ex id) + true + + (^template [] + ( left right) + (and (valid-type? left) (valid-type? right))) + ([#.Sum] [#.Product] [#.Function]) + + (#.Named name type') + (valid-type? type') + + _ + false)) + +(def: (type-checks? input) + (-> (@.Check []) Bool) + (case (@.run @.fresh-context input) + (#.Right []) + true + + (#.Left error) + false)) + +## [Tests] +(context: "Any and Nothing." + (<| (times +100) + (do @ + [sample (|> gen-type (r.filter valid-type?))] + ($_ seq + (test "Any is the super-type of everything." + (@.checks? Any sample)) + + (test "Nothing is the sub-type of everything." + (@.checks? sample Nothing)) + )))) + +(context: "Simple type-checking." + ($_ seq + (test "Any and Nothing match themselves." + (and (@.checks? Nothing Nothing) + (@.checks? Any Any))) + + (test "Existential types only match with themselves." + (and (type-checks? (do @.Monad + [[_ exT] @.existential] + (@.check exT exT))) + (not (type-checks? (do @.Monad + [[_ exTL] @.existential + [_ exTR] @.existential] + (@.check exTL exTR)))))) + + (test "Names do not affect type-checking." + (and (type-checks? (do @.Monad + [[_ exT] @.existential] + (@.check (#.Named ["module" "name"] exT) + exT))) + (type-checks? (do @.Monad + [[_ exT] @.existential] + (@.check exT + (#.Named ["module" "name"] exT)))) + (type-checks? (do @.Monad + [[_ exT] @.existential] + (@.check (#.Named ["module" "name"] exT) + (#.Named ["module" "name"] exT)))))) + + (test "Functions are covariant on inputs and contravariant on outputs." + (and (@.checks? (#.Function Nothing Any) + (#.Function Any Nothing)) + (not (@.checks? (#.Function Any Nothing) + (#.Function Nothing Any))))) + )) + +(context: "Type application." + (<| (times +100) + (do @ + [meta gen-type + data gen-type] + (test "Can type-check type application." + (and (@.checks? (|> Ann (#.Apply meta) (#.Apply data)) + (type.tuple (list meta data))) + (@.checks? (type.tuple (list meta data)) + (|> Ann (#.Apply meta) (#.Apply data)))))))) + +(context: "Primitive types." + (<| (times +100) + (do @ + [nameL gen-name + nameR (|> gen-name (r.filter (|>> (text/= nameL) not))) + paramL gen-type + paramR (|> gen-type (r.filter (|>> (@.checks? paramL) not)))] + ($_ seq + (test "Primitive types match when they have the same name and the same parameters." + (@.checks? (#.Primitive nameL (list paramL)) + (#.Primitive nameL (list paramL)))) + + (test "Names matter to primitive types." + (not (@.checks? (#.Primitive nameL (list paramL)) + (#.Primitive nameR (list paramL))))) + + (test "Parameters matter to primitive types." + (not (@.checks? (#.Primitive nameL (list paramL)) + (#.Primitive nameL (list paramR))))) + )))) + +(context: "Type variables." + ($_ seq + (test "Type-vars check against themselves." + (type-checks? (do @.Monad + [[id var] @.var] + (@.check var var)))) + + (test "Can bind unbound type-vars by type-checking against them." + (and (type-checks? (do @.Monad + [[id var] @.var] + (@.check var .Any))) + (type-checks? (do @.Monad + [[id var] @.var] + (@.check .Any var))))) + + (test "Cannot rebind already bound type-vars." + (not (type-checks? (do @.Monad + [[id var] @.var + _ (@.check var .Bool)] + (@.check var .Nat))))) + + (test "If the type bound to a var is a super-type to another, then the var is also a super-type." + (type-checks? (do @.Monad + [[id var] @.var + _ (@.check var Any)] + (@.check var .Bool)))) + + (test "If the type bound to a var is a sub-type of another, then the var is also a sub-type." + (type-checks? (do @.Monad + [[id var] @.var + _ (@.check var Nothing)] + (@.check .Bool var)))) + )) + +(def: (build-ring num-connections) + (-> Nat (@.Check [[Nat Type] (List [Nat Type]) [Nat Type]])) + (do @.Monad + [[head-id head-type] @.var + ids+types (monad.seq @ (list.repeat num-connections @.var)) + [tail-id tail-type] (monad.fold @ (function (_ [tail-id tail-type] [_head-id _head-type]) + (do @ + [_ (@.check head-type tail-type)] + (wrap [tail-id tail-type]))) + [head-id head-type] + ids+types)] + (wrap [[head-id head-type] ids+types [tail-id tail-type]]))) + +(context: "Rings of type variables." + (<| (times +100) + (do @ + [num-connections (|> r.nat (:: @ map (n/% +100))) + boundT (|> gen-type (r.filter (|>> (case> (#.Var _) false _ true)))) + pick-pcg (r.seq r.nat r.nat)] + ($_ seq + (test "Can create rings of variables." + (type-checks? (do @.Monad + [[[head-id head-type] ids+types [tail-id tail-type]] (build-ring num-connections) + #let [ids (list/map product.left ids+types)] + headR (@.ring head-id) + tailR (@.ring tail-id)] + (@.assert "" + (let [same-rings? (:: set.Equivalence = headR tailR) + expected-size? (n/= (inc num-connections) (set.size headR)) + same-vars? (|> (set.to-list headR) + (list.sort n/<) + (:: (list.Equivalence number.Equivalence) = (list.sort n/< (#.Cons head-id ids))))] + (and same-rings? + expected-size? + same-vars?)))))) + (test "When a var in a ring is bound, all the ring is bound." + (type-checks? (do @.Monad + [[[head-id headT] ids+types tailT] (build-ring num-connections) + #let [ids (list/map product.left ids+types)] + _ (@.check headT boundT) + head-bound (@.read head-id) + tail-bound (monad.map @ @.read ids) + headR (@.ring head-id) + tailR+ (monad.map @ @.ring ids)] + (let [rings-were-erased? (and (set.empty? headR) + (list.every? set.empty? tailR+)) + same-types? (list.every? (type/= boundT) (list& (maybe.default headT head-bound) + (list/map (function (_ [tail-id ?tailT]) + (maybe.default (#.Var tail-id) ?tailT)) + (list.zip2 ids tail-bound))))] + (@.assert "" + (and rings-were-erased? + same-types?)))))) + (test "Can merge multiple rings of variables." + (type-checks? (do @.Monad + [[[head-idL headTL] ids+typesL [tail-idL tailTL]] (build-ring num-connections) + [[head-idR headTR] ids+typesR [tail-idR tailTR]] (build-ring num-connections) + headRL-pre (@.ring head-idL) + headRR-pre (@.ring head-idR) + _ (@.check headTL headTR) + headRL-post (@.ring head-idL) + headRR-post (@.ring head-idR)] + (@.assert "" + (let [same-rings? (:: set.Equivalence = headRL-post headRR-post) + expected-size? (n/= (n/* +2 (inc num-connections)) + (set.size headRL-post)) + union? (:: set.Equivalence = headRL-post (set.union headRL-pre headRR-pre))] + (and same-rings? + expected-size? + union?)))))) + )) + )) diff --git a/stdlib/test/test/lux/math/modular.lux b/stdlib/test/test/lux/math/modular.lux index dcfdb4e11..dc0d89c40 100644 --- a/stdlib/test/test/lux/math/modular.lux +++ b/stdlib/test/test/lux/math/modular.lux @@ -7,7 +7,7 @@ text/format) (math ["r" random] ["/" modular]) - (lang [type "type/" Equivalence])) + (language [type "type/" Equivalence])) lux/test) (def: %3 (/.modulus 3)) -- cgit v1.2.3