From 660c7fe6af927c6e668a86e44fd2f0a9b1fb8b8b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 21 Jul 2018 02:10:54 -0400 Subject: - Re-named "Compiler" to "Phase". - Re-structured the compiler infrastructure. --- .../lux/compiler/default/phase/analysis/case.lux | 198 +++++++++++++ .../compiler/default/phase/analysis/function.lux | 120 ++++++++ .../compiler/default/phase/analysis/primitive.lux | 93 +++++++ .../default/phase/analysis/procedure/common.lux | 308 +++++++++++++++++++++ .../compiler/default/phase/analysis/reference.lux | 109 ++++++++ .../compiler/default/phase/analysis/structure.lux | 299 ++++++++++++++++++++ .../lux/compiler/default/phase/synthesis/case.lux | 88 ++++++ .../compiler/default/phase/synthesis/function.lux | 175 ++++++++++++ .../compiler/default/phase/synthesis/primitive.lux | 97 +++++++ .../compiler/default/phase/synthesis/structure.lux | 63 +++++ stdlib/test/test/lux/compiler/default/syntax.lux | 248 +++++++++++++++++ .../test/lux/language/compiler/analysis/case.lux | 197 ------------- .../lux/language/compiler/analysis/function.lux | 119 -------- .../lux/language/compiler/analysis/primitive.lux | 92 ------ .../compiler/analysis/procedure/common.lux | 307 -------------------- .../lux/language/compiler/analysis/reference.lux | 108 -------- .../lux/language/compiler/analysis/structure.lux | 298 -------------------- .../test/lux/language/compiler/synthesis/case.lux | 87 ------ .../lux/language/compiler/synthesis/function.lux | 174 ------------ .../lux/language/compiler/synthesis/primitive.lux | 96 ------- .../lux/language/compiler/synthesis/structure.lux | 62 ----- stdlib/test/test/lux/language/syntax.lux | 247 ----------------- stdlib/test/tests.lux | 80 +++--- 23 files changed, 1838 insertions(+), 1827 deletions(-) create mode 100644 stdlib/test/test/lux/compiler/default/phase/analysis/case.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/analysis/function.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/analysis/primitive.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/analysis/procedure/common.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/analysis/reference.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/analysis/structure.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/synthesis/case.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux create mode 100644 stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux create mode 100644 stdlib/test/test/lux/compiler/default/syntax.lux delete mode 100644 stdlib/test/test/lux/language/compiler/analysis/case.lux delete mode 100644 stdlib/test/test/lux/language/compiler/analysis/function.lux delete mode 100644 stdlib/test/test/lux/language/compiler/analysis/primitive.lux delete mode 100644 stdlib/test/test/lux/language/compiler/analysis/procedure/common.lux delete mode 100644 stdlib/test/test/lux/language/compiler/analysis/reference.lux delete mode 100644 stdlib/test/test/lux/language/compiler/analysis/structure.lux delete mode 100644 stdlib/test/test/lux/language/compiler/synthesis/case.lux delete mode 100644 stdlib/test/test/lux/language/compiler/synthesis/function.lux delete mode 100644 stdlib/test/test/lux/language/compiler/synthesis/primitive.lux delete mode 100644 stdlib/test/test/lux/language/compiler/synthesis/structure.lux delete mode 100644 stdlib/test/test/lux/language/syntax.lux (limited to 'stdlib/test') diff --git a/stdlib/test/test/lux/compiler/default/phase/analysis/case.lux b/stdlib/test/test/lux/compiler/default/phase/analysis/case.lux new file mode 100644 index 000000000..fd516d048 --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/analysis/case.lux @@ -0,0 +1,198 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + pipe] + [data + ["." product] + ["." maybe] + ["." text ("text/." Equivalence)] + [collection + ["." list ("list/." Monad)] + ["." set]]] + [math + ["r" random ("random/." Monad)]] + ["." type + ["." check]] + [macro + ["." code]] + [compiler + [default + ["." phase + ["." analysis + ["." module] + [".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) + (-> Bit (List [Code Code]) Code (r.Random (List Code))) + (case inputC + [_ (#.Bit _)] + (random/wrap (list (' #1) (' #0))) + + (^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 (' _))))) + (random/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))]) + (random/wrap (list (' []))) + + (^ [_ (#.Record (list))]) + (random/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))) + + _ + (random/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 + (random/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))) + (random/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 (|>> (text/= 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 (check.checks? outputT) not) + _primitive.primitive) + exhaustive-patterns (exhaustive-branches #1 variantTC inputC) + redundant-patterns (exhaustive-branches #0 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 phase.Monad + [_ (module.declare-tags variant-tags #0 + (#.Named [module-name variant-name] + (type.variant primitivesT))) + _ (module.declare-tags record-tags #0 + (#.Named [module-name record-name] + (type.tuple primitivesT)))]) + (module.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/compiler/default/phase/analysis/function.lux b/stdlib/test/test/lux/compiler/default/phase/analysis/function.lux new file mode 100644 index 000000000..b5140f782 --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/analysis/function.lux @@ -0,0 +1,120 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + pipe] + [data + ["e" error] + ["." maybe] + ["." product] + [text ("text/." Equivalence) + format] + [collection + ["." list ("list/." Functor)]]] + [math + ["r" random]] + ["." type] + ["." macro + ["." code]] + [compiler + ["." default + ["." reference] + ["." init] + ["." phase + ["." analysis (#+ Analysis Operation) + [".A" type] + ["." expression] + ["/" function]] + [extension + [".E" analysis]]]]] + test] + [// + ["_." primitive] + ["_." structure]]) + +(def: analyse (expression.analyser (:coerce default.Eval []))) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Operation Analysis) Bit) + (|> analysis + (typeA.with-type expectedT) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success applyA) + (let [[funcA argsA] (analysis.application applyA)] + (n/= num-args (list.size argsA))) + + (#e.Error error) + #0))) + +(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 (#analysis.Function (list) (#analysis.Reference (reference.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/compiler/default/phase/analysis/primitive.lux b/stdlib/test/test/lux/compiler/default/phase/analysis/primitive.lux new file mode 100644 index 000000000..ce34ff887 --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/analysis/primitive.lux @@ -0,0 +1,93 @@ +(.module: + [lux (#- primitive) + [control + [monad (#+ do)] + pipe + ["ex" exception (#+ exception:)]] + [data + ["e" error] + [text + format]] + [math + ["r" random ("random/." Monad)]] + [".L" type ("type/." Equivalence)] + [macro + ["." code]] + [compiler + ["." default + ["." init] + ["." phase + ["." analysis (#+ Analysis Operation) + [".A" type] + ["." expression]] + [extension + [".E" analysis]]]]] + test]) + +(def: #export analyse (expression.analyser (:coerce default.Eval []))) + +(def: unit + (r.Random Code) + (random/wrap (' []))) + +(def: #export primitive + (r.Random [Type Code]) + (`` ($_ r.either + (~~ (do-template [ ] + [(r.seq (random/wrap ) (random/map ))] + + [Any code.tuple (r.list +0 ..unit)] + [Bit code.bit r.bit] + [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 (Operation Analysis) (e.Error Analysis)) + (|> analysis + typeA.with-inference + (phase.run [analysisE.bundle (init.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) + + _ + #0))) + (<| (times +100) + (`` ($_ seq + (~~ (do-template [ ] + [(do @ + [sample ] + (test (format "Can analyse " ".") + (|> (infer-primitive (..analyse ( sample))) + (case> (#e.Success (#analysis.Primitive ( output))) + (is? sample output) + + _ + #0))))] + + ["bit" Bit #analysis.Bit r.bit code.bit] + ["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/compiler/default/phase/analysis/procedure/common.lux b/stdlib/test/test/lux/compiler/default/phase/analysis/procedure/common.lux new file mode 100644 index 000000000..70679e22a --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/analysis/procedure/common.lux @@ -0,0 +1,308 @@ +(.module: + [lux #* + [io] + [control + [monad (#+ do)] + pipe] + [concurrency + ["." atom]] + [data + ["e" error] + ["." product] + [text + format]] + [math + ["r" random]] + [type ("type/." Equivalence)] + [macro + ["." code]] + [compiler + [default + ["." init] + ["." phase + [analysis + ["." scope] + [".A" type]] + [extension + [".E" analysis]]]]] + test] + [/// + ["_." primitive]]) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bit) + (|> (scope.with-scope "" + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [check-success+ #1 #0] + [check-failure+ #0 #1] + ) + +(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) Bit)) + (test "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bit)) + (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) Bit)) + (test "Can compare integers." + (check-success+ "lux int <" (list subjectC paramC) Bit)) + (test "Can convert integer to fraction." + (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) Bit)) + (test "Can compare frac numbers." + (check-success+ "lux frac <" (list subjectC paramC) Bit)) + (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) Bit)) + (test "Compare texts in lexicographical order." + (check-success+ "lux text <" (list subjectC paramC) Bit)) + (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 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) + (|> (scope.with-scope "" + (scope.with-local [var-name arrayT] + (typeA.with-type output-type + (_primitive.analyse code)))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success _) + #1 + + (#e.Error error) + #0)))]] + ($_ 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." + (|> (scope.with-scope "" + (scope.with-local [var-name atomT] + (typeA.with-type elemT + (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success _) + #1 + + (#e.Error _) + #0))) + (test "Can swap the value of an atomic reference." + (|> (scope.with-scope "" + (scope.with-local [var-name atomT] + (typeA.with-type Bit + (_primitive.analyse (` ("lux atom compare-and-swap" + (~ (code.symbol ["" var-name])) + (~ elemC) + (~ elemC))))))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success _) + #1 + + (#e.Error _) + #0))) + )))) + +(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/compiler/default/phase/analysis/reference.lux b/stdlib/test/test/lux/compiler/default/phase/analysis/reference.lux new file mode 100644 index 000000000..6a103d155 --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/analysis/reference.lux @@ -0,0 +1,109 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + pipe] + [data + ["e" error] + [ident ("ident/." Equivalence)] + [text ("text/." Equivalence)]] + [math + ["r" random]] + [type ("type/." Equivalence)] + [macro + ["." code]] + [compiler + ["." default + ["." reference] + ["." init] + ["." phase + ["." analysis + ["." scope] + ["." module] + [".A" type] + ["." expression]] + [extension + [".E" analysis]]]]] + test] + [// + ["_." primitive]]) + +(def: analyse (expression.analyser (:coerce default.Eval []))) + +(type: Check (-> (e.Error Any) Bit)) + +(do-template [ ] + [(def: + Check + (|>> (case> (#e.Success _) + + + (#e.Error _) + )))] + + [success? #1 #0] + [failure? #0 #1] + ) + +(def: (reach-test var-name [export? def-module] [import? dependent-module] check!) + (-> Text [Bit Text] [Bit Text] Check Bit) + (|> (do phase.Monad + [_ (module.with-module +0 def-module + (module.define var-name [Any + (if export? + (' {#.export? #1}) + (' {})) + []]))] + (module.with-module +0 dependent-module + (do @ + [_ (if import? + (module.import def-module) + (wrap []))] + (typeA.with-inference + (..analyse (code.symbol [def-module var-name])))))) + (phase.run [analysisE.bundle (init.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." + (|> (scope.with-scope scope-name + (scope.with-local [var-name expectedT] + (typeA.with-inference + (..analyse (code.local-symbol var-name))))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (^ (#e.Success [inferredT (#analysis.Reference (reference.local var))])) + (and (type/= expectedT inferredT) + (n/= +0 var)) + + _ + #0))) + (test "Can analyse definition (in the same module)." + (let [def-name [def-module var-name]] + (|> (do phase.Monad + [_ (module.define var-name [expectedT (' {}) []])] + (typeA.with-inference + (..analyse (code.symbol def-name)))) + (module.with-module +0 def-module) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (^ (#e.Success [_ inferredT (#analysis.Reference (reference.constant constant-name))])) + (and (type/= expectedT inferredT) + (ident/= def-name constant-name)) + + _ + #0)))) + (test "Can analyse definition (if exported from imported module)." + (reach-test var-name [#1 def-module] [#1 dependent-module] success?)) + (test "Cannot analyse definition (if not exported from imported module)." + (reach-test var-name [#0 def-module] [#1 dependent-module] failure?)) + (test "Cannot analyse definition (if exported from non-imported module)." + (reach-test var-name [#1 def-module] [#0 dependent-module] failure?)) + )))) diff --git a/stdlib/test/test/lux/compiler/default/phase/analysis/structure.lux b/stdlib/test/test/lux/compiler/default/phase/analysis/structure.lux new file mode 100644 index 000000000..eb517be72 --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/analysis/structure.lux @@ -0,0 +1,299 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + pipe] + [data + [bit ("bit/." Equivalence)] + ["e" error] + ["." product] + ["." maybe] + ["." text] + [collection + ["." list ("list/." Functor)] + ["." set]]] + [math + ["r" random]] + ["." type ("type/." Equivalence) + ["." check]] + [macro + ["." code]] + [compiler + ["." default + ["." init] + ["." phase + ["." analysis (#+ Analysis Variant Tag Operation) + ["." module] + [".A" type] + ["/" structure] + ["." expression]] + [extension + [".E" analysis]]]]] + test] + [// + ["_." primitive]]) + +(def: analyse (expression.analyser (:coerce default.Eval []))) + +(do-template [ ] + [(def: #export + (All [a] (-> (Operation a) Bit)) + (|>> (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success _) + + + _ + )))] + + [check-succeeds #1 #0] + [check-fails #0 #1] + ) + +(def: (check-sum' size tag variant) + (-> Nat Tag (Variant Analysis) Bit) + (let [variant-tag (if (get@ #analysis.right? variant) + (inc (get@ #analysis.lefts variant)) + (get@ #analysis.lefts variant))] + (|> size dec (n/= tag) + (bit/= (get@ #analysis.right? variant)) + (and (n/= tag variant-tag))))) + +(def: (check-sum type size tag analysis) + (-> Type Nat Tag (Operation Analysis) Bit) + (|> analysis + (typeA.with-type type) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (^multi (#e.Success sumA) + [(analysis.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + #0))) + +(def: (tagged module tags type) + (All [a] (-> Text (List module.Tag) Type (Operation a) (Operation [Module a]))) + (|>> (do phase.Monad + [_ (module.declare-tags tags #0 type)]) + (module.with-module +0 module))) + +(def: (check-variant module tags type size tag analysis) + (-> Text (List module.Tag) Type Nat Tag (Operation Analysis) Bit) + (|> analysis + (tagged module tags type) + (typeA.with-type type) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (^multi (#e.Success [_ sumA]) + [(analysis.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + #0))) + +(def: (right-size? size) + (-> Nat (-> Analysis Bit)) + (|>> analysis.tuple list.size (n/= size))) + +(def: (check-record-inference module tags type size analysis) + (-> Text (List module.Tag) Type Nat (Operation [Type Analysis]) Bit) + (|> analysis + (tagged module tags type) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success [_ productT productA]) + (and (type/= type productT) + (right-size? size productA)) + + _ + #0))) + +(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 phase.Monad + [[_ varT] (typeA.with-env check.var) + _ (typeA.with-env + (check.check varT variantT))] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (^multi (#e.Success sumA) + [(analysis.variant sumA) + (#.Some variant)]) + (check-sum' size choice variant) + + _ + #0))) + (test "Cannot analyse sum through unbound type-vars." + (|> (do phase.Monad + [[_ varT] (typeA.with-env check.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))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + #0))) + (test "Can infer product." + (|> (typeA.with-inference + (/.product ..analyse (list/map product.right primitives))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success [_type tupleA]) + (and (type/= tupleT _type) + (right-size? size tupleA)) + + _ + #0))) + (test "Can analyse pseudo-product (singleton tuple)" + (|> (typeA.with-type singletonT + (..analyse (` [(~ singletonC)]))) + check-succeeds)) + (test "Can analyse product through bound type-vars." + (|> (do phase.Monad + [[_ varT] (typeA.with-env check.var) + _ (typeA.with-env + (check.check varT (type.tuple (list/map product.left primitives))))] + (typeA.with-type varT + (/.product ..analyse (list/map product.right primitives)))) + (phase.run [analysisE.bundle (init.compiler [])]) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + #0))) + (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 phase.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/compiler/default/phase/synthesis/case.lux b/stdlib/test/test/lux/compiler/default/phase/synthesis/case.lux new file mode 100644 index 000000000..ad0d5c60a --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/synthesis/case.lux @@ -0,0 +1,88 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + pipe] + [data + ["." error ("error/." Functor)]] + [compiler + [default + ["." reference] + ["." phase + ["." analysis (#+ Branch Analysis)] + ["//" synthesis (#+ Synthesis) + ["." expression]] + [extension + ["." bundle]]]]] + [math + ["r" random]] + test] + ["." //primitive]) + +(context: "Dummy variables." + (<| (times +100) + (do @ + [maskedA //primitive.primitive + temp (|> r.nat (:: @ map (n/% +100))) + #let [maskA (analysis.control/case + [maskedA + [[(#analysis.Bind temp) + (#analysis.Reference (reference.local temp))] + (list)]])]] + (test "Dummy variables created to mask expressions get eliminated during synthesis." + (|> maskA + expression.synthesize + (phase.run [bundle.empty //.init]) + (error/map (//primitive.corresponds? maskedA)) + (error.default #0)))))) + +(context: "Let expressions." + (<| (times +100) + (do @ + [registerA r.nat + inputA //primitive.primitive + outputA //primitive.primitive + #let [letA (analysis.control/case + [inputA + [[(#analysis.Bind registerA) + outputA] + (list)]])]] + (test "Can detect and reify simple 'let' expressions." + (|> letA + expression.synthesize + (phase.run [bundle.empty //.init]) + (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) + (and (n/= registerA registerS) + (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? outputA outputS)) + + _ + #0)))))) + +(context: "If expressions." + (<| (times +100) + (do @ + [then|else r.bit + inputA //primitive.primitive + thenA //primitive.primitive + elseA //primitive.primitive + #let [thenB (: Branch + [(#analysis.Simple (#analysis.Bit #1)) + thenA]) + elseB (: Branch + [(#analysis.Simple (#analysis.Bit #0)) + elseA]) + ifA (if then|else + (analysis.control/case [inputA [thenB (list elseB)]]) + (analysis.control/case [inputA [elseB (list thenB)]]))]] + (test "Can detect and reify simple 'if' expressions." + (|> ifA + expression.synthesize + (phase.run [bundle.empty //.init]) + (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) + (and (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? thenA thenS) + (//primitive.corresponds? elseA elseS)) + + _ + #0)))))) diff --git a/stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux b/stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux new file mode 100644 index 000000000..2249acca1 --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/synthesis/function.lux @@ -0,0 +1,175 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + pipe] + [data + ["." product] + ["." maybe] + ["." error] + ["." number] + [text + format] + [collection + ["." list ("list/." Functor Fold)] + ["dict" dictionary (#+ Dictionary)] + ["." set]]] + [compiler + [default + ["." reference (#+ Variable) ("variable/." Equivalence)] + ["." phase + ["." analysis (#+ Arity Analysis)] + ["//" synthesis (#+ Synthesis) + ["." expression]] + [extension + ["." bundle]]]]] + [math + ["r" random]] + test] + ["." //primitive]) + +(def: constant-function + (r.Random [Arity Analysis Analysis]) + (r.rec + (function (_ constant-function) + (do r.Monad + [function? r.bit] + (if function? + (do @ + [[arity bodyA predictionA] constant-function] + (wrap [(inc arity) + (#analysis.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.bit] + (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 + (#analysis.Function picked-env bodyA) + predictionA])) + (do @ + [chosen (pick (list.size current-env))] + (wrap [arity + (#analysis.Reference (reference.foreign chosen)) + (maybe.assume (dict.get chosen resolver))])))))))] + (wrap [arity + (#analysis.Function local-env bodyA) + predictionA]))) + +(def: local-function + (r.Random [Arity Analysis Variable]) + (loop [arity +0 + nest? #1] + (if nest? + (do r.Monad + [nest?' r.bit + [arity' bodyA predictionA] (recur (inc arity) nest?')] + (wrap [arity' + (#analysis.Function (list) bodyA) + predictionA])) + (do r.Monad + [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] + (wrap [arity + (#analysis.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 + expression.synthesize + (phase.run [bundle.empty //.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 + expression.synthesize + (phase.run [bundle.empty //.init]) + (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (reference.variable output))]))) + (and (n/= arity//environment arity) + (variable/= prediction//environment output)) + + _ + #0))) + (test "Folded functions properly offset local variables." + (|> function//local + expression.synthesize + (phase.run [bundle.empty //.init]) + (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (reference.variable output))]))) + (and (n/= arity//local arity) + (variable/= prediction//local output)) + + _ + #0))) + )))) + +(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." + (|> (analysis.apply [funcA argsA]) + expression.synthesize + (phase.run [bundle.empty //.init]) + (case> (^ (#error.Success (//.function/apply [funcS argsS]))) + (and (//primitive.corresponds? funcA funcS) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 argsA argsS))) + + _ + #0))) + (test "Function application on no arguments just synthesizes to the function itself." + (|> (analysis.apply [funcA (list)]) + expression.synthesize + (phase.run [bundle.empty //.init]) + (case> (#error.Success funcS) + (//primitive.corresponds? funcA funcS) + + _ + #0))) + )))) diff --git a/stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux b/stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux new file mode 100644 index 000000000..4312f2bae --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/synthesis/primitive.lux @@ -0,0 +1,97 @@ +(.module: + [lux (#- primitive) + [control + [monad (#+ do)] + pipe] + [data + ["." error] + [text + format]] + [compiler + [default + ["." phase + ["." analysis (#+ Analysis)] + ["//" synthesis (#+ Synthesis) + ["." expression]] + [extension + ["." bundle]]]]] + [math + ["r" random]] + test]) + +(def: #export primitive + (r.Random Analysis) + (do r.Monad + [primitive (: (r.Random analysis.Primitive) + ($_ r.alt + (wrap []) + r.bit + r.nat + r.int + r.rev + r.frac + (r.unicode +5)))] + (wrap (#analysis.Primitive primitive)))) + +(def: #export (corresponds? analysis synthesis) + (-> Analysis Synthesis Bit) + (case [synthesis analysis] + [(#//.Primitive (#//.Text valueS)) + (#analysis.Primitive (#analysis.Unit valueA))] + (is? valueS (:coerce Text valueA)) + + [(#//.Primitive (#//.Bit valueS)) + (#analysis.Primitive (#analysis.Bit valueA))] + (is? valueS valueA) + + [(#//.Primitive (#//.I64 valueS)) + (#analysis.Primitive (#analysis.Nat valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.I64 valueS)) + (#analysis.Primitive (#analysis.Int valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.I64 valueS)) + (#analysis.Primitive (#analysis.Rev valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.F64 valueS)) + (#analysis.Primitive (#analysis.Frac valueA))] + (is? valueS valueA) + + [(#//.Primitive (#//.Text valueS)) + (#analysis.Primitive (#analysis.Text valueA))] + (is? valueS valueA) + + _ + #0)) + +(context: "Primitives." + (<| (times +100) + (do @ + [|bit| r.bit + |nat| r.nat + |int| r.int + |rev| r.rev + |frac| r.frac + |text| (r.unicode +5)] + (`` ($_ seq + (~~ (do-template [ ] + [(test (format "Can synthesize " ".") + (|> (#analysis.Primitive ( )) + expression.synthesize + (phase.run [bundle.empty //.init]) + (case> (#error.Success (#//.Primitive ( value))) + (is? value) + + _ + #0)))] + + ["unit" #analysis.Unit #//.Text //.unit] + ["bit" #analysis.Bit #//.Bit |bit|] + ["nat" #analysis.Nat #//.I64 (.i64 |nat|)] + ["int" #analysis.Int #//.I64 (.i64 |int|)] + ["rev" #analysis.Rev #//.I64 (.i64 |rev|)] + ["frac" #analysis.Frac #//.F64 |frac|] + ["text" #analysis.Text #//.Text |text|]))))))) diff --git a/stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux b/stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux new file mode 100644 index 000000000..924a4126d --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/phase/synthesis/structure.lux @@ -0,0 +1,63 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + pipe] + [data + [bit ("bit/." Equivalence)] + ["." product] + ["." error] + [collection + ["." list]]] + [compiler + [default + ["." phase + ["." analysis] + ["//" synthesis (#+ Synthesis) + ["." expression]] + [extension + ["." bundle]]]]] + [math + ["r" random]] + 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." + (|> (analysis.sum-analysis size tagA memberA) + expression.synthesize + (phase.run [bundle.empty //.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)) (bit/= right?S)) + (//primitive.corresponds? memberA valueS))) + + _ + #0))) + )))) + +(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." + (|> (analysis.product-analysis membersA) + expression.synthesize + (phase.run [bundle.empty //.init]) + (case> (#error.Success (#//.Structure (#//.Tuple membersS))) + (and (n/= size (list.size membersS)) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 membersA membersS))) + + _ + #0))) + )))) diff --git a/stdlib/test/test/lux/compiler/default/syntax.lux b/stdlib/test/test/lux/compiler/default/syntax.lux new file mode 100644 index 000000000..42ae7f379 --- /dev/null +++ b/stdlib/test/test/lux/compiler/default/syntax.lux @@ -0,0 +1,248 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + [number] + ["e" error] + ["." text + format + ["l" lexer]] + [collection + ["." list] + ["dict" dictionary (#+ Dictionary)]]] + [math + ["r" random ("r/." Monad)]] + [macro + ["." code]] + [compiler + [default + ["&" 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.bit (r/map code.bit)) + (|> 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) + #0 + + (#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) + #0 + + (#e.Success [remaining =sample]) + (case (&.read "" (dict.new text.Hash) + remaining) + (#e.Error error) + #0 + + (#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.bit + #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) + + _ + #0) + )))) + +(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) + + _ + #0) + )))) + +(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) + #1 + + (#e.Success [_ parsed]) + #0))) + (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) + #0 + + (#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) + #0 + + (#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) + #1 + + (#e.Success [_ parsed]) + #0) + (case (&.read "" (dict.new text.Hash) + [default-cursor +0 + (format "#(" unbalanced-comment ")#" ")#" + (code.to-text sample))]) + (#e.Error error) + #1 + + (#e.Success [_ parsed]) + #0))) + )))) diff --git a/stdlib/test/test/lux/language/compiler/analysis/case.lux b/stdlib/test/test/lux/language/compiler/analysis/case.lux deleted file mode 100644 index 5956cc48e..000000000 --- a/stdlib/test/test/lux/language/compiler/analysis/case.lux +++ /dev/null @@ -1,197 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - pipe] - [data - ["." product] - ["." maybe] - ["." text ("text/." Equivalence)] - [collection - ["." list ("list/." Monad)] - ["." set]]] - [math - ["r" random ("random/." Monad)]] - ["." type - ["." check]] - [macro - ["." code]] - [language - ["." compiler - ["." analysis - ["." module] - [".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) - (-> Bit (List [Code Code]) Code (r.Random (List Code))) - (case inputC - [_ (#.Bit _)] - (random/wrap (list (' #1) (' #0))) - - (^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 (' _))))) - (random/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))]) - (random/wrap (list (' []))) - - (^ [_ (#.Record (list))]) - (random/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))) - - _ - (random/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 - (random/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))) - (random/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 (|>> (text/= 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 (check.checks? outputT) not) - _primitive.primitive) - exhaustive-patterns (exhaustive-branches #1 variantTC inputC) - redundant-patterns (exhaustive-branches #0 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 compiler.Monad - [_ (module.declare-tags variant-tags #0 - (#.Named [module-name variant-name] - (type.variant primitivesT))) - _ (module.declare-tags record-tags #0 - (#.Named [module-name record-name] - (type.tuple primitivesT)))]) - (module.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 deleted file mode 100644 index 22ff04213..000000000 --- a/stdlib/test/test/lux/language/compiler/analysis/function.lux +++ /dev/null @@ -1,119 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - ["e" error] - ["." maybe] - ["." product] - [text ("text/." Equivalence) - format] - [collection - ["." list ("list/." Functor)]]] - [math - ["r" random]] - ["." type] - ["." macro - ["." code]] - ["." language - ["." reference] - ["." compiler - ["." init] - ["." analysis (#+ Analysis Operation) - [".A" type] - ["." expression] - ["/" function]] - [extension - [".E" analysis]]]] - test] - [// - ["_." primitive] - ["_." structure]]) - -(def: analyse (expression.analyser (:coerce language.Eval []))) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Operation Analysis) Bit) - (|> analysis - (typeA.with-type expectedT) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success applyA) - (let [[funcA argsA] (analysis.application applyA)] - (n/= num-args (list.size argsA))) - - (#e.Error error) - #0))) - -(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 (#analysis.Function (list) (#analysis.Reference (reference.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 deleted file mode 100644 index adad90f18..000000000 --- a/stdlib/test/test/lux/language/compiler/analysis/primitive.lux +++ /dev/null @@ -1,92 +0,0 @@ -(.module: - [lux (#- primitive) - [control - [monad (#+ do)] - pipe - ["ex" exception (#+ exception:)]] - [data - ["e" error] - [text - format]] - [math - ["r" random ("random/." Monad)]] - [".L" type ("type/." Equivalence)] - [macro - ["." code]] - ["." language - ["." compiler - ["." init] - ["." analysis (#+ Analysis Operation) - [".A" type] - ["." expression]] - [extension - [".E" analysis]]]] - test]) - -(def: #export analyse (expression.analyser (:coerce language.Eval []))) - -(def: unit - (r.Random Code) - (random/wrap (' []))) - -(def: #export primitive - (r.Random [Type Code]) - (`` ($_ r.either - (~~ (do-template [ ] - [(r.seq (random/wrap ) (random/map ))] - - [Any code.tuple (r.list +0 ..unit)] - [Bit code.bit r.bit] - [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 (Operation Analysis) (e.Error Analysis)) - (|> analysis - typeA.with-inference - (compiler.run [analysisE.bundle (init.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) - - _ - #0))) - (<| (times +100) - (`` ($_ seq - (~~ (do-template [ ] - [(do @ - [sample ] - (test (format "Can analyse " ".") - (|> (infer-primitive (..analyse ( sample))) - (case> (#e.Success (#analysis.Primitive ( output))) - (is? sample output) - - _ - #0))))] - - ["bit" Bit #analysis.Bit r.bit code.bit] - ["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 deleted file mode 100644 index 2a5cc2ee3..000000000 --- a/stdlib/test/test/lux/language/compiler/analysis/procedure/common.lux +++ /dev/null @@ -1,307 +0,0 @@ -(.module: - [lux #* - [io] - [control - [monad (#+ do)] - pipe] - [concurrency - ["." atom]] - [data - ["e" error] - ["." product] - [text - format]] - [math - ["r" random]] - [type ("type/." Equivalence)] - [macro - ["." code]] - [language - ["." compiler - ["." init] - [analysis - ["." scope] - [".A" type]] - [extension - [".E" analysis]]]] - test] - [/// - ["_." primitive]]) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bit) - (|> (scope.with-scope "" - (typeA.with-type output-type - (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [check-success+ #1 #0] - [check-failure+ #0 #1] - ) - -(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) Bit)) - (test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bit)) - (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) Bit)) - (test "Can compare integers." - (check-success+ "lux int <" (list subjectC paramC) Bit)) - (test "Can convert integer to fraction." - (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) Bit)) - (test "Can compare frac numbers." - (check-success+ "lux frac <" (list subjectC paramC) Bit)) - (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) Bit)) - (test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list subjectC paramC) Bit)) - (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 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) - (|> (scope.with-scope "" - (scope.with-local [var-name arrayT] - (typeA.with-type output-type - (_primitive.analyse code)))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success _) - #1 - - (#e.Error error) - #0)))]] - ($_ 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." - (|> (scope.with-scope "" - (scope.with-local [var-name atomT] - (typeA.with-type elemT - (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success _) - #1 - - (#e.Error _) - #0))) - (test "Can swap the value of an atomic reference." - (|> (scope.with-scope "" - (scope.with-local [var-name atomT] - (typeA.with-type Bit - (_primitive.analyse (` ("lux atom compare-and-swap" - (~ (code.symbol ["" var-name])) - (~ elemC) - (~ elemC))))))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success _) - #1 - - (#e.Error _) - #0))) - )))) - -(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/reference.lux b/stdlib/test/test/lux/language/compiler/analysis/reference.lux deleted file mode 100644 index 66c990ef4..000000000 --- a/stdlib/test/test/lux/language/compiler/analysis/reference.lux +++ /dev/null @@ -1,108 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - ["e" error] - [ident ("ident/." Equivalence)] - [text ("text/." Equivalence)]] - [math - ["r" random]] - [type ("type/." Equivalence)] - [macro - ["." code]] - ["." language - ["." reference] - ["." compiler - ["." init] - ["." analysis - ["." scope] - ["." module] - [".A" type] - ["." expression]] - [extension - [".E" analysis]]]] - test] - [// - ["_." primitive]]) - -(def: analyse (expression.analyser (:coerce language.Eval []))) - -(type: Check (-> (e.Error Any) Bit)) - -(do-template [ ] - [(def: - Check - (|>> (case> (#e.Success _) - - - (#e.Error _) - )))] - - [success? #1 #0] - [failure? #0 #1] - ) - -(def: (reach-test var-name [export? def-module] [import? dependent-module] check!) - (-> Text [Bit Text] [Bit Text] Check Bit) - (|> (do compiler.Monad - [_ (module.with-module +0 def-module - (module.define var-name [Any - (if export? - (' {#.export? #1}) - (' {})) - []]))] - (module.with-module +0 dependent-module - (do @ - [_ (if import? - (module.import def-module) - (wrap []))] - (typeA.with-inference - (..analyse (code.symbol [def-module var-name])))))) - (compiler.run [analysisE.bundle (init.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." - (|> (scope.with-scope scope-name - (scope.with-local [var-name expectedT] - (typeA.with-inference - (..analyse (code.local-symbol var-name))))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (^ (#e.Success [inferredT (#analysis.Reference (reference.local var))])) - (and (type/= expectedT inferredT) - (n/= +0 var)) - - _ - #0))) - (test "Can analyse definition (in the same module)." - (let [def-name [def-module var-name]] - (|> (do compiler.Monad - [_ (module.define var-name [expectedT (' {}) []])] - (typeA.with-inference - (..analyse (code.symbol def-name)))) - (module.with-module +0 def-module) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (^ (#e.Success [_ inferredT (#analysis.Reference (reference.constant constant-name))])) - (and (type/= expectedT inferredT) - (ident/= def-name constant-name)) - - _ - #0)))) - (test "Can analyse definition (if exported from imported module)." - (reach-test var-name [#1 def-module] [#1 dependent-module] success?)) - (test "Cannot analyse definition (if not exported from imported module)." - (reach-test var-name [#0 def-module] [#1 dependent-module] failure?)) - (test "Cannot analyse definition (if exported from non-imported module)." - (reach-test var-name [#1 def-module] [#0 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 deleted file mode 100644 index 6dca4fb12..000000000 --- a/stdlib/test/test/lux/language/compiler/analysis/structure.lux +++ /dev/null @@ -1,298 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - [bit ("bit/." Equivalence)] - ["e" error] - ["." product] - ["." maybe] - ["." text] - [collection - ["." list ("list/." Functor)] - ["." set]]] - [math - ["r" random]] - ["." type ("type/." Equivalence) - ["." check]] - [macro - ["." code]] - ["." language - ["." compiler - ["." init] - ["." analysis (#+ Analysis Variant Tag Operation) - ["." module] - [".A" type] - ["/" structure] - ["." expression]] - [extension - [".E" analysis]]]] - test] - [// - ["_." primitive]]) - -(def: analyse (expression.analyser (:coerce language.Eval []))) - -(do-template [ ] - [(def: #export - (All [a] (-> (Operation a) Bit)) - (|>> (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success _) - - - _ - )))] - - [check-succeeds #1 #0] - [check-fails #0 #1] - ) - -(def: (check-sum' size tag variant) - (-> Nat Tag (Variant Analysis) Bit) - (let [variant-tag (if (get@ #analysis.right? variant) - (inc (get@ #analysis.lefts variant)) - (get@ #analysis.lefts variant))] - (|> size dec (n/= tag) - (bit/= (get@ #analysis.right? variant)) - (and (n/= tag variant-tag))))) - -(def: (check-sum type size tag analysis) - (-> Type Nat Tag (Operation Analysis) Bit) - (|> analysis - (typeA.with-type type) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (^multi (#e.Success sumA) - [(analysis.variant sumA) - (#.Some variant)]) - (check-sum' size tag variant) - - _ - #0))) - -(def: (tagged module tags type) - (All [a] (-> Text (List module.Tag) Type (Operation a) (Operation [Module a]))) - (|>> (do compiler.Monad - [_ (module.declare-tags tags #0 type)]) - (module.with-module +0 module))) - -(def: (check-variant module tags type size tag analysis) - (-> Text (List module.Tag) Type Nat Tag (Operation Analysis) Bit) - (|> analysis - (tagged module tags type) - (typeA.with-type type) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (^multi (#e.Success [_ sumA]) - [(analysis.variant sumA) - (#.Some variant)]) - (check-sum' size tag variant) - - _ - #0))) - -(def: (right-size? size) - (-> Nat (-> Analysis Bit)) - (|>> analysis.tuple list.size (n/= size))) - -(def: (check-record-inference module tags type size analysis) - (-> Text (List module.Tag) Type Nat (Operation [Type Analysis]) Bit) - (|> analysis - (tagged module tags type) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success [_ productT productA]) - (and (type/= type productT) - (right-size? size productA)) - - _ - #0))) - -(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 compiler.Monad - [[_ varT] (typeA.with-env check.var) - _ (typeA.with-env - (check.check varT variantT))] - (typeA.with-type varT - (/.sum ..analyse choice valueC))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (^multi (#e.Success sumA) - [(analysis.variant sumA) - (#.Some variant)]) - (check-sum' size choice variant) - - _ - #0))) - (test "Cannot analyse sum through unbound type-vars." - (|> (do compiler.Monad - [[_ varT] (typeA.with-env check.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))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - #0))) - (test "Can infer product." - (|> (typeA.with-inference - (/.product ..analyse (list/map product.right primitives))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success [_type tupleA]) - (and (type/= tupleT _type) - (right-size? size tupleA)) - - _ - #0))) - (test "Can analyse pseudo-product (singleton tuple)" - (|> (typeA.with-type singletonT - (..analyse (` [(~ singletonC)]))) - check-succeeds)) - (test "Can analyse product through bound type-vars." - (|> (do compiler.Monad - [[_ varT] (typeA.with-env check.var) - _ (typeA.with-env - (check.check varT (type.tuple (list/map product.left primitives))))] - (typeA.with-type varT - (/.product ..analyse (list/map product.right primitives)))) - (compiler.run [analysisE.bundle (init.compiler [])]) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - #0))) - (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 compiler.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 deleted file mode 100644 index 70e13af4b..000000000 --- a/stdlib/test/test/lux/language/compiler/synthesis/case.lux +++ /dev/null @@ -1,87 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - ["." error ("error/." Functor)]] - [language - ["." reference] - ["." compiler - ["." analysis (#+ Branch Analysis)] - ["//" synthesis (#+ Synthesis) - ["." expression]] - [extension - ["." bundle]]]] - [math - ["r" random]] - test] - ["." //primitive]) - -(context: "Dummy variables." - (<| (times +100) - (do @ - [maskedA //primitive.primitive - temp (|> r.nat (:: @ map (n/% +100))) - #let [maskA (analysis.control/case - [maskedA - [[(#analysis.Bind temp) - (#analysis.Reference (reference.local temp))] - (list)]])]] - (test "Dummy variables created to mask expressions get eliminated during synthesis." - (|> maskA - expression.synthesize - (compiler.run [bundle.empty //.init]) - (error/map (//primitive.corresponds? maskedA)) - (error.default #0)))))) - -(context: "Let expressions." - (<| (times +100) - (do @ - [registerA r.nat - inputA //primitive.primitive - outputA //primitive.primitive - #let [letA (analysis.control/case - [inputA - [[(#analysis.Bind registerA) - outputA] - (list)]])]] - (test "Can detect and reify simple 'let' expressions." - (|> letA - expression.synthesize - (compiler.run [bundle.empty //.init]) - (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) - (and (n/= registerA registerS) - (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? outputA outputS)) - - _ - #0)))))) - -(context: "If expressions." - (<| (times +100) - (do @ - [then|else r.bit - inputA //primitive.primitive - thenA //primitive.primitive - elseA //primitive.primitive - #let [thenB (: Branch - [(#analysis.Simple (#analysis.Bit #1)) - thenA]) - elseB (: Branch - [(#analysis.Simple (#analysis.Bit #0)) - elseA]) - ifA (if then|else - (analysis.control/case [inputA [thenB (list elseB)]]) - (analysis.control/case [inputA [elseB (list thenB)]]))]] - (test "Can detect and reify simple 'if' expressions." - (|> ifA - expression.synthesize - (compiler.run [bundle.empty //.init]) - (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) - (and (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? thenA thenS) - (//primitive.corresponds? elseA elseS)) - - _ - #0)))))) diff --git a/stdlib/test/test/lux/language/compiler/synthesis/function.lux b/stdlib/test/test/lux/language/compiler/synthesis/function.lux deleted file mode 100644 index 62d8c97a0..000000000 --- a/stdlib/test/test/lux/language/compiler/synthesis/function.lux +++ /dev/null @@ -1,174 +0,0 @@ -(.module: - [lux #* - [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 - ["." analysis (#+ Arity Analysis)] - ["//" synthesis (#+ Synthesis) - ["." expression]] - [extension - ["." bundle]]]] - [math - ["r" random]] - test] - ["." //primitive]) - -(def: constant-function - (r.Random [Arity Analysis Analysis]) - (r.rec - (function (_ constant-function) - (do r.Monad - [function? r.bit] - (if function? - (do @ - [[arity bodyA predictionA] constant-function] - (wrap [(inc arity) - (#analysis.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.bit] - (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 - (#analysis.Function picked-env bodyA) - predictionA])) - (do @ - [chosen (pick (list.size current-env))] - (wrap [arity - (#analysis.Reference (reference.foreign chosen)) - (maybe.assume (dict.get chosen resolver))])))))))] - (wrap [arity - (#analysis.Function local-env bodyA) - predictionA]))) - -(def: local-function - (r.Random [Arity Analysis Variable]) - (loop [arity +0 - nest? #1] - (if nest? - (do r.Monad - [nest?' r.bit - [arity' bodyA predictionA] (recur (inc arity) nest?')] - (wrap [arity' - (#analysis.Function (list) bodyA) - predictionA])) - (do r.Monad - [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] - (wrap [arity - (#analysis.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 - expression.synthesize - (compiler.run [bundle.empty //.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 - expression.synthesize - (compiler.run [bundle.empty //.init]) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (reference.variable output))]))) - (and (n/= arity//environment arity) - (variable/= prediction//environment output)) - - _ - #0))) - (test "Folded functions properly offset local variables." - (|> function//local - expression.synthesize - (compiler.run [bundle.empty //.init]) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (reference.variable output))]))) - (and (n/= arity//local arity) - (variable/= prediction//local output)) - - _ - #0))) - )))) - -(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." - (|> (analysis.apply [funcA argsA]) - expression.synthesize - (compiler.run [bundle.empty //.init]) - (case> (^ (#error.Success (//.function/apply [funcS argsS]))) - (and (//primitive.corresponds? funcA funcS) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 argsA argsS))) - - _ - #0))) - (test "Function application on no arguments just synthesizes to the function itself." - (|> (analysis.apply [funcA (list)]) - expression.synthesize - (compiler.run [bundle.empty //.init]) - (case> (#error.Success funcS) - (//primitive.corresponds? funcA funcS) - - _ - #0))) - )))) diff --git a/stdlib/test/test/lux/language/compiler/synthesis/primitive.lux b/stdlib/test/test/lux/language/compiler/synthesis/primitive.lux deleted file mode 100644 index c4cc940f1..000000000 --- a/stdlib/test/test/lux/language/compiler/synthesis/primitive.lux +++ /dev/null @@ -1,96 +0,0 @@ -(.module: - [lux (#- primitive) - [control - [monad (#+ do)] - pipe] - [data - ["." error] - [text - format]] - [language - ["." compiler - ["." analysis (#+ Analysis)] - ["//" synthesis (#+ Synthesis) - ["." expression]] - [extension - ["." bundle]]]] - [math - ["r" random]] - test]) - -(def: #export primitive - (r.Random Analysis) - (do r.Monad - [primitive (: (r.Random analysis.Primitive) - ($_ r.alt - (wrap []) - r.bit - r.nat - r.int - r.rev - r.frac - (r.unicode +5)))] - (wrap (#analysis.Primitive primitive)))) - -(def: #export (corresponds? analysis synthesis) - (-> Analysis Synthesis Bit) - (case [synthesis analysis] - [(#//.Primitive (#//.Text valueS)) - (#analysis.Primitive (#analysis.Unit valueA))] - (is? valueS (:coerce Text valueA)) - - [(#//.Primitive (#//.Bit valueS)) - (#analysis.Primitive (#analysis.Bit valueA))] - (is? valueS valueA) - - [(#//.Primitive (#//.I64 valueS)) - (#analysis.Primitive (#analysis.Nat valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.I64 valueS)) - (#analysis.Primitive (#analysis.Int valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.I64 valueS)) - (#analysis.Primitive (#analysis.Rev valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.F64 valueS)) - (#analysis.Primitive (#analysis.Frac valueA))] - (is? valueS valueA) - - [(#//.Primitive (#//.Text valueS)) - (#analysis.Primitive (#analysis.Text valueA))] - (is? valueS valueA) - - _ - #0)) - -(context: "Primitives." - (<| (times +100) - (do @ - [|bit| r.bit - |nat| r.nat - |int| r.int - |rev| r.rev - |frac| r.frac - |text| (r.unicode +5)] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format "Can synthesize " ".") - (|> (#analysis.Primitive ( )) - expression.synthesize - (compiler.run [bundle.empty //.init]) - (case> (#error.Success (#//.Primitive ( value))) - (is? value) - - _ - #0)))] - - ["unit" #analysis.Unit #//.Text //.unit] - ["bit" #analysis.Bit #//.Bit |bit|] - ["nat" #analysis.Nat #//.I64 (.i64 |nat|)] - ["int" #analysis.Int #//.I64 (.i64 |int|)] - ["rev" #analysis.Rev #//.I64 (.i64 |rev|)] - ["frac" #analysis.Frac #//.F64 |frac|] - ["text" #analysis.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 deleted file mode 100644 index dcec26fb9..000000000 --- a/stdlib/test/test/lux/language/compiler/synthesis/structure.lux +++ /dev/null @@ -1,62 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - [bit ("bit/." Equivalence)] - ["." product] - ["." error] - [collection - ["." list]]] - [language - ["." compiler - ["." analysis] - ["//" synthesis (#+ Synthesis) - ["." expression]] - [extension - ["." bundle]]]] - [math - ["r" random]] - 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." - (|> (analysis.sum-analysis size tagA memberA) - expression.synthesize - (compiler.run [bundle.empty //.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)) (bit/= right?S)) - (//primitive.corresponds? memberA valueS))) - - _ - #0))) - )))) - -(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." - (|> (analysis.product-analysis membersA) - expression.synthesize - (compiler.run [bundle.empty //.init]) - (case> (#error.Success (#//.Structure (#//.Tuple membersS))) - (and (n/= size (list.size membersS)) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 membersA membersS))) - - _ - #0))) - )))) diff --git a/stdlib/test/test/lux/language/syntax.lux b/stdlib/test/test/lux/language/syntax.lux deleted file mode 100644 index 469e07c10..000000000 --- a/stdlib/test/test/lux/language/syntax.lux +++ /dev/null @@ -1,247 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]] - [data - [number] - ["e" error] - ["." text - format - ["l" lexer]] - [collection - ["." list] - ["dict" dictionary (#+ Dictionary)]]] - [math - ["r" 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.bit (r/map code.bit)) - (|> 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) - #0 - - (#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) - #0 - - (#e.Success [remaining =sample]) - (case (&.read "" (dict.new text.Hash) - remaining) - (#e.Error error) - #0 - - (#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.bit - #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) - - _ - #0) - )))) - -(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) - - _ - #0) - )))) - -(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) - #1 - - (#e.Success [_ parsed]) - #0))) - (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) - #0 - - (#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) - #0 - - (#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) - #1 - - (#e.Success [_ parsed]) - #0) - (case (&.read "" (dict.new text.Hash) - [default-cursor +0 - (format "#(" unbalanced-comment ")#" ")#" - (code.to-text sample))]) - (#e.Error error) - #1 - - (#e.Success [_ parsed]) - #0))) - )))) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index bdd8ef0ab..e855220dd 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -39,32 +39,31 @@ [world ["._" environment] ["._" console]] - [language + [compiler [host [".H" scheme]] - [compiler - ["._" translation - [scheme - ["._scheme" primitive] - ["._scheme" structure] - ["._scheme" reference] - ["._scheme" function] - ["._scheme" loop] - ["._scheme" case] - ["._scheme" extension] - ["._scheme" extension/common] - ["._scheme" expression]]] - [default - [repl - ["._" type]]] - [meta - ["._meta" io - ["._meta_io" context] - ["._meta_io" archive]] - ["._meta" archive] - ["._meta" cache]] - [default - ["._default" cache]]]]] + [default + [phase + ["._" translation + [scheme + ["._scheme" primitive] + ["._scheme" structure] + ["._scheme" reference] + ["._scheme" function] + ["._scheme" loop] + ["._scheme" case] + ["._scheme" extension] + ["._scheme" extension/common] + ["._scheme" expression]]]] + ["._default" cache] + [repl + ["._" type]]] + [meta + ["._meta" io + ["._meta_io" context] + ["._meta_io" archive]] + ["._meta" archive] + ["._meta" cache]]]] [test ["_." lux] [lux @@ -150,22 +149,23 @@ [object ["_." interface] ["_." protocol]]] - [language - ["_language/." syntax] - [compiler - [analysis - ["_.A" primitive] - ["_.A" structure] - ["_.A" reference] - ["_.A" case] - ["_.A" function] - [procedure - ["_.A" common]]] - [synthesis - ["_.S" primitive] - ["_.S" structure] - ["_.S" case] - ["_.S" function]]]] + [compiler + [default + ["_default/." syntax] + [phase + [analysis + ["_.A" primitive] + ["_.A" structure] + ["_.A" reference] + ["_.A" case] + ["_.A" function] + [procedure + ["_.A" common]]] + [synthesis + ["_.S" primitive] + ["_.S" structure] + ["_.S" case] + ["_.S" function]]]]] [world ["_." binary] ## ["_." file] ## TODO: Specially troublesome... -- cgit v1.2.3