From b7b0dd9bd952ede4710da157b40304d714229e04 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 17 Jun 2018 22:27:40 -0400 Subject: - Heavy refactoring to integrate extensions better with the rest of the compiler. --- stdlib/test/test/lux/lang/analysis/case.lux | 194 -------- stdlib/test/test/lux/lang/analysis/function.lux | 112 ----- stdlib/test/test/lux/lang/analysis/primitive.lux | 86 ---- .../test/lux/lang/analysis/procedure/common.lux | 316 ------------ .../test/lux/lang/analysis/procedure/host.jvm.lux | 541 --------------------- stdlib/test/test/lux/lang/analysis/reference.lux | 58 --- stdlib/test/test/lux/lang/analysis/structure.lux | 292 ----------- .../test/test/lux/lang/compiler/analysis/case.lux | 194 ++++++++ .../test/lux/lang/compiler/analysis/function.lux | 112 +++++ .../test/lux/lang/compiler/analysis/primitive.lux | 86 ++++ .../lang/compiler/analysis/procedure/common.lux | 316 ++++++++++++ .../lang/compiler/analysis/procedure/host.jvm.lux | 541 +++++++++++++++++++++ .../test/lux/lang/compiler/analysis/reference.lux | 58 +++ .../test/lux/lang/compiler/analysis/structure.lux | 292 +++++++++++ .../test/test/lux/lang/compiler/synthesis/case.lux | 82 ++++ .../test/lux/lang/compiler/synthesis/function.lux | 168 +++++++ .../test/lux/lang/compiler/synthesis/primitive.lux | 92 ++++ .../test/lux/lang/compiler/synthesis/structure.lux | 57 +++ stdlib/test/test/lux/lang/synthesis/case.lux | 82 ---- stdlib/test/test/lux/lang/synthesis/function.lux | 168 ------- stdlib/test/test/lux/lang/synthesis/primitive.lux | 92 ---- stdlib/test/test/lux/lang/synthesis/structure.lux | 57 --- 22 files changed, 1998 insertions(+), 1998 deletions(-) delete mode 100644 stdlib/test/test/lux/lang/analysis/case.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/function.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/primitive.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/procedure/common.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/reference.lux delete mode 100644 stdlib/test/test/lux/lang/analysis/structure.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/case.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/function.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/primitive.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/reference.lux create mode 100644 stdlib/test/test/lux/lang/compiler/analysis/structure.lux create mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/case.lux create mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/function.lux create mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux create mode 100644 stdlib/test/test/lux/lang/compiler/synthesis/structure.lux delete mode 100644 stdlib/test/test/lux/lang/synthesis/case.lux delete mode 100644 stdlib/test/test/lux/lang/synthesis/function.lux delete mode 100644 stdlib/test/test/lux/lang/synthesis/primitive.lux delete mode 100644 stdlib/test/test/lux/lang/synthesis/structure.lux (limited to 'stdlib/test') diff --git a/stdlib/test/test/lux/lang/analysis/case.lux b/stdlib/test/test/lux/lang/analysis/case.lux deleted file mode 100644 index 9e775f8a3..000000000 --- a/stdlib/test/test/lux/lang/analysis/case.lux +++ /dev/null @@ -1,194 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "B/" Eq] - ["R" error] - [product] - [maybe] - [text "T/" Eq] - text/format - (coll [list "list/" Monad] - (set ["set" unordered]))) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type "type/" Eq] - (type ["tc" check]) - [".L" module] - (analysis [".A" type] - ["/" case])) - test) - (// ["_." primitive] - ["_." structure])) - -(def: (exhaustive-weaving branchings) - (-> (List (List Code)) (List (List Code))) - (case branchings - #.Nil - #.Nil - - (#.Cons head+ #.Nil) - (list/map (|>> list) head+) - - (#.Cons head+ tail++) - (do list.Monad - [tail+ (exhaustive-weaving tail++) - head head+] - (wrap (#.Cons head tail+))))) - -(def: #export (exhaustive-branches allow-literals? variantTC inputC) - (-> Bool (List [Code Code]) Code (r.Random (List Code))) - (case inputC - [_ (#.Bool _)] - (r/wrap (list (' true) (' false))) - - (^template [ ] - [_ ( _)] - (if allow-literals? - (do r.Monad - [?sample (r.maybe )] - (case ?sample - (#.Some sample) - (do @ - [else (exhaustive-branches allow-literals? variantTC inputC)] - (wrap (list& ( sample) else))) - - #.None - (wrap (list (' _))))) - (r/wrap (list (' _))))) - ([#.Nat r.nat code.nat] - [#.Int r.int code.int] - [#.Deg r.deg code.deg] - [#.Frac r.frac code.frac] - [#.Text (r.unicode +5) code.text]) - - (^ [_ (#.Tuple (list))]) - (r/wrap (list (' []))) - - (^ [_ (#.Record (list))]) - (r/wrap (list (' {}))) - - [_ (#.Tuple members)] - (do r.Monad - [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list/map code.tuple)))) - - [_ (#.Record kvs)] - (do r.Monad - [#let [ks (list/map product.left kvs) - vs (list/map product.right kvs)] - member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] - (wrap (|> member-wise-patterns - exhaustive-weaving - (list/map (|>> (list.zip2 ks) code.record))))) - - (^ [_ (#.Form (list [_ (#.Tag _)] _))]) - (do r.Monad - [bundles (monad.map @ - (function (_ [_tag _code]) - (do @ - [v-branches (exhaustive-branches allow-literals? variantTC _code)] - (wrap (list/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) - v-branches)))) - variantTC)] - (wrap (list/join bundles))) - - _ - (r/wrap (list)) - )) - -(def: #export (input variant-tags record-tags primitivesC) - (-> (List Code) (List Code) (List Code) (r.Random Code)) - (r.rec - (function (_ input) - ($_ r.either - (r/map product.right _primitive.primitive) - (do r.Monad - [choice (|> r.nat (:: @ map (n/% (list.size variant-tags)))) - #let [choiceT (maybe.assume (list.nth choice variant-tags)) - choiceC (maybe.assume (list.nth choice primitivesC))]] - (wrap (` ((~ choiceT) (~ choiceC))))) - (do r.Monad - [size (|> r.nat (:: @ map (n/% +3))) - elems (r.list size input)] - (wrap (code.tuple elems))) - (r/wrap (code.record (list.zip2 record-tags primitivesC))) - )))) - -(def: (branch body pattern) - (-> Code Code [Code Code]) - [pattern body]) - -(context: "Pattern-matching." - ## #seed +9253409297339902486 - ## #seed +3793366152923578600 - (<| (seed +5004137551292836565) - ## (times +100) - (do @ - [module-name (r.unicode +5) - variant-name (r.unicode +5) - record-name (|> (r.unicode +5) (r.filter (|>> (T/= variant-name) not))) - size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - variant-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - record-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - primitivesTC (r.list size _primitive.primitive) - #let [primitivesT (list/map product.left primitivesTC) - primitivesC (list/map product.right primitivesTC) - code-tag (|>> [module-name] code.tag) - variant-tags+ (list/map code-tag variant-tags) - record-tags+ (list/map code-tag record-tags) - variantTC (list.zip2 variant-tags+ primitivesC)] - inputC (input variant-tags+ record-tags+ primitivesC) - [outputT outputC] _primitive.primitive - [heterogeneousT heterogeneousC] (|> _primitive.primitive - (r.filter (|>> product.left (tc.checks? outputT) not))) - exhaustive-patterns (exhaustive-branches true variantTC inputC) - redundant-patterns (exhaustive-branches false variantTC inputC) - redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) - heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns)))) - #let [exhaustive-branchesC (list/map (branch outputC) - exhaustive-patterns) - non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) - exhaustive-branchesC) - redundant-branchesC (<| (list/map (branch outputC)) - list.concat - (list (list.take redundancy-idx redundant-patterns) - (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) - (list.drop redundancy-idx redundant-patterns))) - heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) - (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] - [_pattern heterogeneousC])) - (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) - analyse-pm (|>> (/.case _primitive.analyse inputC) - (typeA.with-type outputT) - lang.with-scope - (do Monad - [_ (moduleL.declare-tags variant-tags false - (#.Named [module-name variant-name] - (type.variant primitivesT))) - _ (moduleL.declare-tags record-tags false - (#.Named [module-name record-name] - (type.tuple primitivesT)))]) - (moduleL.with-module +0 module-name))]] - ($_ seq - (test "Will reject empty pattern-matching (no branches)." - (|> (analyse-pm (list)) - _structure.check-fails)) - (test "Can analyse exhaustive pattern-matching." - (|> (analyse-pm exhaustive-branchesC) - _structure.check-succeeds)) - (test "Will reject non-exhaustive pattern-matching." - (|> (analyse-pm non-exhaustive-branchesC) - _structure.check-fails)) - (test "Will reject redundant pattern-matching." - (|> (analyse-pm redundant-branchesC) - _structure.check-fails)) - (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." - (|> (analyse-pm heterogeneous-branchesC) - _structure.check-fails)) - )))) diff --git a/stdlib/test/test/lux/lang/analysis/function.lux b/stdlib/test/test/lux/lang/analysis/function.lux deleted file mode 100644 index a99504045..000000000 --- a/stdlib/test/test/lux/lang/analysis/function.lux +++ /dev/null @@ -1,112 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [maybe] - [product] - [text "text/" Eq] - text/format - (coll [list "list/" Functor])) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [type "type/" Eq] - [".L" init] - [".L" reference] - [".L" analysis #+ Analysis] - (analysis [".A" type] - [".A" expression] - ["/" function])) - test) - (// ["_." primitive] - ["_." structure])) - -(def: analyse (expressionA.analyser (:! lang.Eval []))) - -(def: (check-apply expectedT num-args analysis) - (-> Type Nat (Meta Analysis) Bool) - (|> analysis - (typeA.with-type expectedT) - (macro.run (initL.compiler [])) - (case> (#e.Success applyA) - (let [[funcA argsA] (analysisL.application applyA)] - (n/= num-args (list.size argsA))) - - (#e.Error error) - false))) - -(context: "Function definition." - (<| (times +100) - (do @ - [func-name (r.unicode +5) - arg-name (|> (r.unicode +5) (r.filter (|>> (text/= func-name) not))) - [outputT outputC] _primitive.primitive - [inputT _] _primitive.primitive - #let [g!arg (code.local-symbol arg-name)]] - ($_ seq - (test "Can analyse function." - (and (|> (typeA.with-type (All [a] (-> a outputT)) - (/.function ..analyse func-name arg-name outputC)) - _structure.check-succeeds) - (|> (typeA.with-type (All [a] (-> a a)) - (/.function ..analyse func-name arg-name g!arg)) - _structure.check-succeeds))) - (test "Generic functions can always be specialized." - (and (|> (typeA.with-type (-> inputT outputT) - (/.function ..analyse func-name arg-name outputC)) - _structure.check-succeeds) - (|> (typeA.with-type (-> inputT inputT) - (/.function ..analyse func-name arg-name g!arg)) - _structure.check-succeeds))) - (test "The function's name is bound to the function's type." - (|> (typeA.with-type (Rec self (-> inputT self)) - (/.function ..analyse func-name arg-name (code.local-symbol func-name))) - _structure.check-succeeds)) - )))) - -(context: "Function application." - (<| (times +100) - (do @ - [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - partial-args (|> r.nat (:: @ map (n/% full-args))) - var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1)))) - inputsTC (r.list full-args _primitive.primitive) - #let [inputsT (list/map product.left inputsTC) - inputsC (list/map product.right inputsTC)] - [outputT outputC] _primitive.primitive - #let [funcT (type.function inputsT outputT) - partialT (type.function (list.drop partial-args inputsT) outputT) - varT (#.Bound +1) - polyT (<| (type.univ-q +1) - (type.function (list.concat (list (list.take var-idx inputsT) - (list varT) - (list.drop (inc var-idx) inputsT)))) - varT) - poly-inputT (maybe.assume (list.nth var-idx inputsT)) - partial-poly-inputsT (list.drop (inc var-idx) inputsT) - partial-polyT1 (<| (type.function partial-poly-inputsT) - poly-inputT) - partial-polyT2 (<| (type.univ-q +1) - (type.function (#.Cons varT partial-poly-inputsT)) - varT) - dummy-function (#analysisL.Function (list) (#analysisL.Reference (referenceL.local +1)))]] - ($_ seq - (test "Can analyse monomorphic type application." - (|> (/.apply ..analyse funcT dummy-function inputsC) - (check-apply outputT full-args))) - (test "Can partially apply functions." - (|> (/.apply ..analyse funcT dummy-function (list.take partial-args inputsC)) - (check-apply partialT partial-args))) - (test "Can apply polymorphic functions." - (|> (/.apply ..analyse polyT dummy-function inputsC) - (check-apply poly-inputT full-args))) - (test "Polymorphic partial application propagates found type-vars." - (|> (/.apply ..analyse polyT dummy-function (list.take (inc var-idx) inputsC)) - (check-apply partial-polyT1 (inc var-idx)))) - (test "Polymorphic partial application preserves quantification for type-vars." - (|> (/.apply ..analyse polyT dummy-function (list.take var-idx inputsC)) - (check-apply partial-polyT2 var-idx))) - )))) diff --git a/stdlib/test/test/lux/lang/analysis/primitive.lux b/stdlib/test/test/lux/lang/analysis/primitive.lux deleted file mode 100644 index 6e2a8aae9..000000000 --- a/stdlib/test/test/lux/lang/analysis/primitive.lux +++ /dev/null @@ -1,86 +0,0 @@ -(.module: - [lux #- primitive] - (lux [io] - (control [monad #+ do] - pipe - ["ex" exception #+ exception:]) - (data (text format) - ["e" error]) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [".L" type "type/" Eq] - [".L" init] - [analysis #+ Analysis] - (analysis [".A" type] - [".A" expression])) - test)) - -(def: #export analyse (expressionA.analyser (:! lang.Eval []))) - -(def: unit - (r.Random Code) - (r/wrap (' []))) - -(def: #export primitive - (r.Random [Type Code]) - (`` ($_ r.either - (~~ (do-template [ ] - [(r.seq (r/wrap ) (r/map ))] - - [Any code.tuple (r.list +0 ..unit)] - [Bool code.bool r.bool] - [Nat code.nat r.nat] - [Int code.int r.int] - [Deg code.deg r.deg] - [Frac code.frac r.frac] - [Text code.text (r.unicode +5)] - ))))) - -(exception: (wrong-inference {expected Type} {inferred Type}) - (ex.report ["Expected" (%type expected)] - ["Inferred" (%type inferred)])) - -(def: (infer-primitive expected-type analysis) - (-> Type (Meta Analysis) (e.Error Analysis)) - (|> (typeA.with-inference - analysis) - (macro.run (initL.compiler [])) - (case> (#e.Success [inferred-type output]) - (if (is? expected-type inferred-type) - (#e.Success output) - (ex.throw wrong-inference [expected-type inferred-type])) - - (#e.Error error) - (#e.Error error)))) - -(context: "Primitives" - ($_ seq - (test "Can analyse unit." - (|> (infer-primitive Any (..analyse (' []))) - (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output)))) - (is? [] output) - - _ - false))) - (<| (times +100) - (`` ($_ seq - (~~ (do-template [ ] - [(do @ - [sample ] - (test (format "Can analyse " ".") - (|> (infer-primitive (..analyse ( sample))) - (case> (#e.Success (#analysis.Primitive ( output))) - (is? sample output) - - _ - false))))] - - ["bool" Bool #analysis.Bool r.bool code.bool] - ["nat" Nat #analysis.Nat r.nat code.nat] - ["int" Int #analysis.Int r.int code.int] - ["deg" Deg #analysis.Deg r.deg code.deg] - ["frac" Frac #analysis.Frac r.frac code.frac] - ["text" Text #analysis.Text (r.unicode +5) code.text] - ))))))) diff --git a/stdlib/test/test/lux/lang/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/analysis/procedure/common.lux deleted file mode 100644 index 898376045..000000000 --- a/stdlib/test/test/lux/lang/analysis/procedure/common.lux +++ /dev/null @@ -1,316 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data text/format - ["e" error] - [product] - (coll [array])) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type "type/" Eq] - [".L" scope] - [".L" init] - (analysis [".A" type])) - test) - (/// ["_." primitive])) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (lang.with-scope - (typeA.with-type output-type - (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [check-success+ true false] - [check-failure+ false true] - ) - -(context: "Lux procedures" - (<| (times +100) - (do @ - [[primT primC] _primitive.primitive - [antiT antiC] (|> _primitive.primitive - (r.filter (|>> product.left (type/= primT) not)))] - ($_ seq - (test "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bool)) - (test "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bool)) - (test "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ("lux function" (~' _) (~' _) (~ 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 equality of integers." - (check-success+ "lux int =" (list subjectC paramC) Bool)) - (test "Can compare integers." - (check-success+ "lux int <" (list subjectC paramC) Bool)) - (test "Can obtain minimum integer." - (check-success+ "lux int min" (list) Int)) - (test "Can obtain maximum integer." - (check-success+ "lux int max" (list) Int)) - (test "Can convert integer to natural number." - (check-success+ "lux int to-nat" (list subjectC) Nat)) - (test "Can convert integer to frac number." - (check-success+ "lux int to-frac" (list subjectC) Frac)) - (test "Can convert integer to text." - (check-success+ "lux int char" (list subjectC) Text)) - )))) - -(context: "Frac procedures" - (<| (times +100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac)) - encodedC (|> (r.unicode +5) (:: @ map code.text))] - ($_ seq - (test "Can add frac numbers." - (check-success+ "lux frac +" (list subjectC paramC) Frac)) - (test "Can subtract frac numbers." - (check-success+ "lux frac -" (list subjectC paramC) Frac)) - (test "Can multiply frac numbers." - (check-success+ "lux frac *" (list subjectC paramC) Frac)) - (test "Can divide frac numbers." - (check-success+ "lux frac /" (list subjectC paramC) Frac)) - (test "Can calculate remainder of frac numbers." - (check-success+ "lux frac %" (list subjectC paramC) Frac)) - (test "Can test equality of frac numbers." - (check-success+ "lux frac =" (list subjectC paramC) Bool)) - (test "Can compare frac numbers." - (check-success+ "lux frac <" (list subjectC paramC) Bool)) - (test "Can obtain minimum frac number." - (check-success+ "lux frac min" (list) Frac)) - (test "Can obtain maximum frac number." - (check-success+ "lux frac max" (list) Frac)) - (test "Can obtain smallest frac number." - (check-success+ "lux frac smallest" (list) Frac)) - (test "Can obtain not-a-number." - (check-success+ "lux frac not-a-number" (list) Frac)) - (test "Can obtain positive infinity." - (check-success+ "lux frac positive-infinity" (list) Frac)) - (test "Can obtain negative infinity." - (check-success+ "lux frac negative-infinity" (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 equality." - (check-success+ "lux text =" (list subjectC paramC) Bool)) - (test "Compare texts in lexicographical order." - (check-success+ "lux text <" (list subjectC paramC) Bool)) - (test "Can concatenate one text to another." - (check-success+ "lux text concat" (list subjectC paramC) Text)) - (test "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) - (test "Can query the size/length of a text." - (check-success+ "lux text size" (list subjectC) Nat)) - (test "Can calculate a hash code for text." - (check-success+ "lux text hash" (list subjectC) Nat)) - (test "Can replace a text inside of a larger one (once)." - (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) - (test "Can replace a text inside of a larger one (all times)." - (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) - (test "Can obtain the character code of a text at a given index." - (check-success+ "lux text char" (list subjectC fromC) (type (Maybe Nat)))) - (test "Can clip a piece of text between 2 indices." - (check-success+ "lux text clip" (list subjectC fromC toC) (type (Maybe Text)))) - )))) - -(context: "Array procedures" - (<| (times +100) - (do @ - [[elemT elemC] _primitive.primitive - sizeC (|> r.nat (:: @ map code.nat)) - idxC (|> r.nat (:: @ map code.nat)) - var-name (r.unicode +5) - #let [arrayT (type (Array elemT)) - g!array (code.local-symbol var-name) - array-operation (function (_ output-type code) - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name arrayT] - (typeA.with-type output-type - (_primitive.analyse code)))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error error) - false)))]] - ($_ seq - (test "Can create arrays." - (check-success+ "lux array new" (list sizeC) arrayT)) - (test "Can get a value inside an array." - (array-operation (type (Maybe elemT)) - (` ("lux array get" (~ g!array) (~ idxC))))) - (test "Can put a value inside an array." - (array-operation arrayT - (` ("lux array put" (~ g!array) (~ idxC) (~ elemC))))) - (test "Can remove a value from an array." - (array-operation arrayT - (` ("lux array remove" (~ g!array) (~ idxC))))) - (test "Can query the size of an array." - (array-operation Nat - (` ("lux array size" (~ g!array))))) - )))) - -(context: "Math procedures" - (<| (times +100) - (do @ - [subjectC (|> r.frac (:: @ map code.frac)) - paramC (|> r.frac (:: @ map code.frac))] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC) Frac))] - - ["lux math cos" "cosine"] - ["lux math sin" "sine"] - ["lux math tan" "tangent"] - ["lux math acos" "inverse/arc cosine"] - ["lux math asin" "inverse/arc sine"] - ["lux math atan" "inverse/arc tangent"] - ["lux math cosh" "hyperbolic cosine"] - ["lux math sinh" "hyperbolic sine"] - ["lux math tanh" "hyperbolic tangent"] - ["lux math exp" "exponentiation"] - ["lux math log" "logarithm"] - ["lux math ceil" "ceiling"] - ["lux math floor" "floor"] - ["lux math round" "rounding"])) - (~~ (do-template [ ] - [(test (format "Can calculate " ".") - (check-success+ (list subjectC paramC) Frac))] - - ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] - ["lux math pow" "power"]))))))) - -(context: "Atom procedures" - (<| (times +100) - (do @ - [[elemT elemC] _primitive.primitive - sizeC (|> r.nat (:: @ map code.nat)) - idxC (|> r.nat (:: @ map code.nat)) - var-name (r.unicode +5) - #let [atomT (type (atom.Atom elemT))]] - ($_ seq - (test "Can create atomic reference." - (check-success+ "lux atom new" (list elemC) atomT)) - (test "Can read the value of an atomic reference." - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name atomT] - (typeA.with-type elemT - (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) - (test "Can swap the value of an atomic reference." - (|> (scopeL.with-scope "" - (scopeL.with-local [var-name atomT] - (typeA.with-type Bool - (_primitive.analyse (` ("lux atom compare-and-swap" - (~ (code.symbol ["" var-name])) - (~ elemC) - (~ elemC))))))) - (macro.run (initL.compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) - )))) - -(context: "Process procedures" - (<| (times +100) - (do @ - [[primT primC] _primitive.primitive - timeC (|> r.nat (:: @ map code.nat))] - ($_ seq - (test "Can query the level of concurrency." - (check-success+ "lux process parallelism-level" (list) Nat)) - (test "Can schedule an IO computation to run concurrently at some future time." - (check-success+ "lux process schedule" - (list timeC - (` ("lux function" (~' _) (~' _) (~ primC)))) - Any)) - )))) - -(context: "IO procedures" - (<| (times +100) - (do @ - [logC (|> (r.unicode +5) (:: @ map code.text)) - exitC (|> r.int (:: @ map code.int))] - ($_ seq - (test "Can log messages to standard output." - (check-success+ "lux io log" (list logC) Any)) - (test "Can throw a run-time error." - (check-success+ "lux io error" (list logC) Nothing)) - (test "Can exit the program." - (check-success+ "lux io exit" (list exitC) Nothing)) - (test "Can query the current time (as milliseconds since epoch)." - (check-success+ "lux io current-time" (list) Int)) - )))) diff --git a/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux deleted file mode 100644 index 0a60149d5..000000000 --- a/stdlib/test/test/lux/lang/analysis/procedure/host.jvm.lux +++ /dev/null @@ -1,541 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (concurrency [atom]) - (data ["e" error] - [product] - [maybe] - [text "text/" Eq] - text/format - (coll [array] - [list "list/" Fold] - (dictionary ["dict" unordered]))) - ["r" math/random "r/" Monad] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type] - [".L" init] - (analysis [".A" type]) - (extension (analysis [".AE" host]))) - test) - (/// ["_." primitive])) - -(do-template [ ] - [(def: ( procedure params output-type) - (-> Text (List Code) Type Bool) - (|> (do Monad - [## runtime-bytecode @runtime.translate - ] - (lang.with-scope - (typeA.with-type output-type - (_primitive.analyse (` ((~ (code.text procedure)) (~+ params))))))) - (lang.with-current-module "") - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [success true false] - [failure false true] - ) - -(do-template [ ] - [(def: ( syntax output-type) - (-> Code Type Bool) - (|> (do Monad - [## runtime-bytecode @runtime.translate - ] - (lang.with-scope - (typeA.with-type output-type - (_primitive.analyse syntax)))) - (lang.with-current-module "") - (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - (#e.Error error) - )))] - - [success' true false] - [failure' false true] - ) - -(context: "Conversions [double + float]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert double-to-float" "java.lang.Double" hostAE.Float] - ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer] - ["jvm convert double-to-long" "java.lang.Double" hostAE.Long] - ["jvm convert float-to-double" "java.lang.Float" hostAE.Double] - ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer] - ["jvm convert float-to-long" "java.lang.Float" hostAE.Long] - )] - ($_ seq - - ))) - -(context: "Conversions [int]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert int-to-byte" "java.lang.Integer" hostAE.Byte] - ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character] - ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double] - ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float] - ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long] - ["jvm convert int-to-short" "java.lang.Integer" hostAE.Short] - )] - ($_ seq - - ))) - -(context: "Conversions [long]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert long-to-double" "java.lang.Long" hostAE.Double] - ["jvm convert long-to-float" "java.lang.Long" hostAE.Float] - ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer] - ["jvm convert long-to-short" "java.lang.Long" hostAE.Short] - ["jvm convert long-to-byte" "java.lang.Long" hostAE.Byte] - )] - ($_ seq - - ))) - -(context: "Conversions [char + byte + short]." - (with-expansions [ (do-template [ ] - [(test (format " SUCCESS") - (success (list (' ("lux coerce" (+0 (+0)) []))) )) - (test (format " FAILURE") - (failure (list (' [])) ))] - - ["jvm convert char-to-byte" "java.lang.Character" hostAE.Byte] - ["jvm convert char-to-short" "java.lang.Character" hostAE.Short] - ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer] - ["jvm convert char-to-long" "java.lang.Character" hostAE.Long] - ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long] - ["jvm convert short-to-long" "java.lang.Short" hostAE.Long] - )] - ($_ seq - - ))) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - ))) - - (context: (format "Bitwise " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " and") ] - [(format "jvm " " or") ] - [(format "jvm " " xor") ] - [(format "jvm " " shl") "java.lang.Integer" ] - [(format "jvm " " shr") "java.lang.Integer" ] - [(format "jvm " " ushr") "java.lang.Integer" ] - )] - ($_ seq - - )))] - - - ["int" "java.lang.Integer" hostAE.Integer] - ["long" "java.lang.Long" hostAE.Long] - ) - -(do-template [ ] - [(context: (format "Arithmetic " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " +") ] - [(format "jvm " " -") ] - [(format "jvm " " *") ] - [(format "jvm " " /") ] - [(format "jvm " " %") ] - )] - ($_ seq - - ))) - - (context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - )))] - - - ["float" "java.lang.Float" hostAE.Float] - ["double" "java.lang.Double" hostAE.Double] - ) - -(do-template [ ] - [(context: (format "Order " "[" "].") - (with-expansions [ (do-template [ ] - [(test - (success - (list (' ("lux coerce" (+0 (+0)) [])) - (' ("lux coerce" (+0 (+0)) []))) - ))] - - [(format "jvm " " =") hostAE.Boolean] - [(format "jvm " " <") hostAE.Boolean] - )] - ($_ seq - - )))] - - - ["char" "java.lang.Character" hostAE.Character] - ) - -(def: array-type - (r.Random [Text Text]) - (let [entries (dict.entries hostAE.boxes) - num-entries (list.size entries)] - (do r.Monad - [choice (|> r.nat (:: @ map (n/% (inc num-entries)))) - #let [[unboxed boxed] (: [Text Text] - (|> entries - (list.nth choice) - (maybe.default ["java.lang.Object" "java.lang.Object"])))]] - (wrap [unboxed boxed])))) - -(context: "Array." - (<| (times +100) - (do @ - [#let [cap (|>> (n/% +10) (n/max +1))] - [unboxed boxed] array-type - size (|> r.nat (:: @ map cap)) - idx (|> r.nat (:: @ map (n/% size))) - level (|> r.nat (:: @ map cap)) - #let [unboxedT (#.Primitive unboxed (list)) - arrayT (#.Primitive "#Array" (list unboxedT)) - arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0))) - ("jvm array new" (~ (code.nat size))))) - boxedT (#.Primitive boxed (list)) - boxedTC (` (+0 (~ (code.text boxed)) (+0))) - multi-arrayT (list/fold (function (_ _ innerT) - (|> innerT (list) (#.Primitive "#Array"))) - boxedT - (list.n/range +1 level))]] - ($_ seq - (test "jvm array new" - (success "jvm array new" - (list (code.nat size)) - arrayT)) - (test "jvm array new (no nesting)" - (failure "jvm array new" - (list (code.nat size)) - unboxedT)) - (test "jvm array new (nested/multi-level)" - (success "jvm array new" - (list (code.nat size)) - multi-arrayT)) - (test "jvm array length" - (success "jvm array length" - (list arrayC) - Nat)) - (test "jvm array read" - (success' (` ("jvm object cast" - ("jvm array read" (~ arrayC) (~ (code.nat idx))))) - boxedT)) - (test "jvm array write" - (success "jvm array write" - (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) - arrayT)) - )))) - -(def: throwables - (List Text) - (list "java.lang.Throwable" - "java.lang.Error" - "java.io.IOError" - "java.lang.VirtualMachineError" - "java.lang.Exception" - "java.io.IOException" - "java.lang.RuntimeException")) - -(context: "Object." - (<| (times +100) - (do @ - [[unboxed boxed] array-type - [!unboxed !boxed] (|> array-type - (r.filter (function (_ [!unboxed !boxed]) - (not (text/= boxed !boxed))))) - #let [boxedT (#.Primitive boxed (list)) - boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0)) - ("jvm object null"))) - !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0)) - ("jvm object null"))) - unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) - ("jvm object null")))] - throwable (|> r.nat - (:: @ map (n/% (inc (list.size throwables)))) - (:: @ map (function (_ idx) - (|> throwables - (list.nth idx) - (maybe.default "java.lang.Object"))))) - #let [throwableC (`' ("lux check" (+0 (~ (code.text throwable)) (+0)) - ("jvm object null")))]] - ($_ seq - (test "jvm object null" - (success "jvm object null" - (list) - (#.Primitive boxed (list)))) - (test "jvm object null (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object null" - (list) - (#.Primitive unboxed (list))))) - (test "jvm object null?" - (success "jvm object null?" - (list boxedC) - Bool)) - (test "jvm object synchronized" - (success "jvm object synchronized" - (list boxedC boxedC) - boxedT)) - (test "jvm object synchronized (no primitives)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object synchronized" - (list unboxedC boxedC) - boxedT))) - (test "jvm object throw" - (or (text/= "java.lang.Object" throwable) - (success "jvm object throw" - (list throwableC) - Nothing))) - (test "jvm object class" - (success "jvm object class" - (list (code.text boxed)) - (#.Primitive "java.lang.Class" (list boxedT)))) - (test "jvm object instance?" - (success "jvm object instance?" - (list (code.text boxed) - boxedC) - Bool)) - (test "jvm object instance? (lineage)" - (success "jvm object instance?" - (list (' "java.lang.Object") - boxedC) - Bool)) - (test "jvm object instance? (no lineage)" - (or (text/= "java.lang.Object" boxed) - (failure "jvm object instance?" - (list (code.text boxed) - !boxedC) - Bool))) - )))) - -(context: "Member [Static Field]." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code.text "java.lang.System") - (code.text "out")) - (#.Primitive "java.io.PrintStream" (list)))) - (test "jvm member static get (inheritance out)" - (success "jvm member static get" - (list (code.text "java.lang.System") - (code.text "out")) - (#.Primitive "java.lang.Object" (list)))) - (test "jvm member static put" - (success "jvm member static put" - (list (code.text "java.awt.datatransfer.DataFlavor") - (code.text "allHtmlFlavor") - (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) - ("jvm object null")))) - Any)) - (test "jvm member static put (final)" - (failure "jvm member static put" - (list (code.text "java.lang.System") - (code.text "out") - (`' ("lux check" (+0 "java.io.PrintStream" (+0)) - ("jvm object null")))) - Any)) - (test "jvm member static put (inheritance in)" - (success "jvm member static put" - (list (code.text "java.awt.datatransfer.DataFlavor") - (code.text "allHtmlFlavor") - (`' ("jvm object cast" - ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) - ("jvm object null"))))) - Any)) - )) - -(context: "Member [Virtual Field]." - ($_ seq - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.String" (list)))) - (test "jvm member virtual get (inheritance out)" - (success "jvm member virtual get" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.Object" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code.text "org.omg.CORBA.ValueMember") - (code.text "id") - (`' ("lux check" (+0 "java.lang.String" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) - ("jvm object null")))) - (primitive "org.omg.CORBA.ValueMember"))) - (test "jvm member virtual put (final)" - (failure "jvm member virtual put" - (list (code.text "javax.swing.text.html.parser.DTD") - (code.text "applet") - (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) - ("jvm object null"))) - (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) - ("jvm object null")))) - (primitive "javax.swing.text.html.parser.DTD"))) - (test "jvm member virtual put (inheritance in)" - (success "jvm member virtual put" - (list (code.text "java.awt.GridBagConstraints") - (code.text "insets") - (`' ("jvm object cast" - ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) - ("jvm object null")))) - (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) - ("jvm object null")))) - (primitive "java.awt.GridBagConstraints"))) - )) - -(context: "Boxing/Unboxing." - ($_ seq - (test "jvm member static get" - (success "jvm member static get" - (list (code.text "java.util.GregorianCalendar") - (code.text "AD")) - (#.Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual get" - (success "jvm member virtual get" - (list (code.text "javax.accessibility.AccessibleAttributeSequence") - (code.text "startIndex") - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (#.Primitive "java.lang.Integer" (list)))) - (test "jvm member virtual put" - (success "jvm member virtual put" - (list (code.text "javax.accessibility.AccessibleAttributeSequence") - (code.text "startIndex") - (`' ("jvm object cast" - ("lux check" (+0 "java.lang.Integer" (+0)) - ("jvm object null")))) - (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) - ("jvm object null")))) - (primitive "javax.accessibility.AccessibleAttributeSequence"))) - )) - -(context: "Member [Method]." - (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) - +123)) - intC (`' ("jvm convert long-to-int" (~ longC))) - stringC (' ("lux coerce" (+0 "java.lang.String" (+0)) - "YOLO")) - objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) - ("jvm member invoke constructor" "java.util.ArrayList" - ["int" ("jvm object cast" (~ intC))])))] - ($_ seq - (test "jvm member invoke static" - (success' (` ("jvm member invoke static" - "java.lang.Long" "decode" - ["java.lang.String" (~ stringC)])) - (#.Primitive "java.lang.Long" (list)))) - (test "jvm member invoke virtual" - (success' (` ("jvm object cast" - ("jvm member invoke virtual" - "java.lang.Object" "equals" - ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke special" - (success' (` ("jvm object cast" - ("jvm member invoke special" - "java.lang.Long" "equals" - ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke interface" - (success' (` ("jvm object cast" - ("jvm member invoke interface" - "java.util.Collection" "add" - ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) - (#.Primitive "java.lang.Boolean" (list)))) - (test "jvm member invoke constructor" - (success' (` ("jvm member invoke constructor" - "java.util.ArrayList" - ["int" ("jvm object cast" (~ intC))])) - (All [a] (#.Primitive "java.util.ArrayList" (list a))))) - ))) diff --git a/stdlib/test/test/lux/lang/analysis/reference.lux b/stdlib/test/test/lux/lang/analysis/reference.lux deleted file mode 100644 index 6551e3cba..000000000 --- a/stdlib/test/test/lux/lang/analysis/reference.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data ["e" error] - [ident "ident/" Eq]) - ["r" math/random] - [macro #+ Monad] - (macro [code]) - [lang] - (lang [type "type/" Eq] - [".L" scope] - [".L" module] - [".L" init] - [".L" reference] - [".L" analysis] - (analysis [".A" type] - [".A" expression])) - test) - (// ["_." primitive])) - -(def: analyse (expressionA.analyser (:! lang.Eval []))) - -(context: "References" - (<| (times +100) - (do @ - [[expectedT _] _primitive.primitive - module-name (r.unicode +5) - scope-name (r.unicode +5) - var-name (r.unicode +5) - #let [def-name [module-name var-name]]] - ($_ seq - (test "Can analyse variable." - (|> (scopeL.with-scope scope-name - (scopeL.with-local [var-name expectedT] - (typeA.with-inference - (..analyse (code.local-symbol var-name))))) - (macro.run (initL.compiler [])) - (case> (^ (#e.Success [inferredT (#analysisL.Reference (referenceL.local var))])) - (and (type/= expectedT inferredT) - (n/= +0 var)) - - _ - false))) - (test "Can analyse definition." - (|> (do Monad - [_ (moduleL.define var-name [expectedT (' {}) []])] - (typeA.with-inference - (..analyse (code.symbol def-name)))) - (moduleL.with-module +0 module-name) - (macro.run (initL.compiler [])) - (case> (^ (#e.Success [_ inferredT (#analysisL.Reference (referenceL.constant constant-name))])) - (and (type/= expectedT inferredT) - (ident/= def-name constant-name)) - - _ - false))))))) diff --git a/stdlib/test/test/lux/lang/analysis/structure.lux b/stdlib/test/test/lux/lang/analysis/structure.lux deleted file mode 100644 index 20b911714..000000000 --- a/stdlib/test/test/lux/lang/analysis/structure.lux +++ /dev/null @@ -1,292 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Eq] - ["e" error] - [product] - [maybe] - [text] - text/format - (coll [list "list/" Functor] - (set ["set" unordered]))) - ["r" math/random "r/" Monad] - [macro] - (macro [code]) - [lang] - (lang [type "type/" Eq] - (type ["tc" check]) - [".L" module] - [".L" init] - [".L" analysis #+ Analysis Variant Tag] - (analysis [".A" type] - ["/" structure] - [".A" expression])) - test) - (// ["_." primitive])) - -(def: analyse (expressionA.analyser (:! lang.Eval []))) - -(do-template [ ] - [(def: #export - (All [a] (-> (Meta a) Bool)) - (|>> (macro.run (initL.compiler [])) - (case> (#e.Success _) - - - _ - )))] - - [check-succeeds true false] - [check-fails false true] - ) - -(def: (check-sum' size tag variant) - (-> Nat Tag (Variant Analysis) Bool) - (let [variant-tag (if (get@ #analysisL.right? variant) - (inc (get@ #analysisL.lefts variant)) - (get@ #analysisL.lefts variant))] - (|> size dec (n/= tag) - (bool/= (get@ #analysisL.right? variant)) - (and (n/= tag variant-tag))))) - -(def: (check-sum type size tag analysis) - (-> Type Nat Tag (Meta Analysis) Bool) - (|> analysis - (typeA.with-type type) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success sumA) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size tag variant) - - _ - false))) - -(def: (tagged module tags type) - (All [a] (-> Text (List moduleL.Tag) Type (Meta a) (Meta [Module a]))) - (|>> (do macro.Monad - [_ (moduleL.declare-tags tags false type)]) - (moduleL.with-module +0 module))) - -(def: (check-variant module tags type size tag analysis) - (-> Text (List moduleL.Tag) Type Nat Tag (Meta Analysis) Bool) - (|> analysis - (tagged module tags type) - (typeA.with-type type) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success [_ sumA]) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size tag variant) - - _ - false))) - -(def: (right-size? size) - (-> Nat (-> Analysis Bool)) - (|>> analysisL.tuple list.size (n/= size))) - -(def: (check-record-inference module tags type size analysis) - (-> Text (List moduleL.Tag) Type Nat (Meta [Type Analysis]) Bool) - (|> analysis - (tagged module tags type) - (macro.run (initL.compiler [])) - (case> (#e.Success [_ productT productA]) - (and (type/= type productT) - (right-size? size productA)) - - _ - false))) - -(context: "Sums" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - choice (|> r.nat (:: @ map (n/% size))) - primitives (r.list size _primitive.primitive) - +choice (|> r.nat (:: @ map (n/% (inc size)))) - [_ +valueC] _primitive.primitive - #let [variantT (type.variant (list/map product.left primitives)) - [valueT valueC] (maybe.assume (list.nth choice primitives)) - +size (inc size) - +primitives (list.concat (list (list.take choice primitives) - (list [(#.Bound +1) +valueC]) - (list.drop choice primitives))) - [+valueT +valueC] (maybe.assume (list.nth +choice +primitives)) - +variantT (type.variant (list/map product.left +primitives))]] - ($_ seq - (test "Can analyse sum." - (check-sum variantT size choice - (/.sum ..analyse choice valueC))) - (test "Can analyse sum through bound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var) - _ (typeA.with-env - (tc.check varT variantT))] - (typeA.with-type varT - (/.sum ..analyse choice valueC))) - (macro.run (initL.compiler [])) - (case> (^multi (#e.Success sumA) - [(analysisL.variant sumA) - (#.Some variant)]) - (check-sum' size choice variant) - - _ - false))) - (test "Cannot analyse sum through unbound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var)] - (typeA.with-type varT - (/.sum ..analyse choice valueC))) - check-fails)) - (test "Can analyse sum through existential quantification." - (|> (typeA.with-type (type.ex-q +1 +variantT) - (/.sum ..analyse +choice +valueC)) - check-succeeds)) - (test "Can analyse sum through universal quantification." - (let [check-outcome (if (not (n/= choice +choice)) - check-succeeds - check-fails)] - (|> (typeA.with-type (type.univ-q +1 +variantT) - (/.sum ..analyse +choice +valueC)) - check-outcome))) - )))) - -(context: "Products" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - primitives (r.list size _primitive.primitive) - choice (|> r.nat (:: @ map (n/% size))) - [_ +valueC] _primitive.primitive - #let [tupleT (type.tuple (list/map product.left primitives)) - [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) - +primitives (list.concat (list (list.take choice primitives) - (list [(#.Bound +1) +valueC]) - (list.drop choice primitives))) - +tupleT (type.tuple (list/map product.left +primitives))]] - ($_ seq - (test "Can analyse product." - (|> (typeA.with-type tupleT - (/.product ..analyse (list/map product.right primitives))) - (macro.run (initL.compiler [])) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - false))) - (test "Can infer product." - (|> (typeA.with-inference - (/.product ..analyse (list/map product.right primitives))) - (macro.run (initL.compiler [])) - (case> (#e.Success [_type tupleA]) - (and (type/= tupleT _type) - (right-size? size tupleA)) - - _ - false))) - (test "Can analyse pseudo-product (singleton tuple)" - (|> (typeA.with-type singletonT - (..analyse (` [(~ singletonC)]))) - check-succeeds)) - (test "Can analyse product through bound type-vars." - (|> (do macro.Monad - [[_ varT] (typeA.with-env tc.var) - _ (typeA.with-env - (tc.check varT (type.tuple (list/map product.left primitives))))] - (typeA.with-type varT - (/.product ..analyse (list/map product.right primitives)))) - (macro.run (initL.compiler [])) - (case> (#e.Success tupleA) - (right-size? size tupleA) - - _ - false))) - (test "Can analyse product through existential quantification." - (|> (typeA.with-type (type.ex-q +1 +tupleT) - (/.product ..analyse (list/map product.right +primitives))) - check-succeeds)) - (test "Cannot analyse product through universal quantification." - (|> (typeA.with-type (type.univ-q +1 +tupleT) - (/.product ..analyse (list/map product.right +primitives))) - check-fails)) - )))) - -(context: "Tagged Sums" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) - choice (|> r.nat (:: @ map (n/% size))) - other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not))) - primitives (r.list size _primitive.primitive) - module-name (r.unicode +5) - type-name (r.unicode +5) - #let [varT (#.Bound +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 (#.Bound +1) - tagsC (list/map (|>> [module-name] code.tag) tags) - primitivesT (list/map product.left primitives) - primitivesC (list/map product.right primitives) - tupleT (type.tuple primitivesT) - namedT (#.Named [module-name type-name] tupleT) - recordC (list.zip2 tagsC primitivesC) - named-polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) - (list varT) - (list.drop (inc choice) primitivesT)))) - (type.univ-q +1) - (#.Named [module-name type-name]))]] - ($_ seq - (test "Can infer record." - (|> (typeA.with-inference - (/.record ..analyse recordC)) - (check-record-inference module-name tags namedT size))) - (test "Records specialize when type-vars get bound." - (|> (typeA.with-inference - (/.record ..analyse recordC)) - (check-record-inference module-name tags named-polyT size))) - (test "Can specialize generic records." - (|> (do macro.Monad - [recordA (typeA.with-type tupleT - (/.record ..analyse recordC))] - (wrap [tupleT recordA])) - (check-record-inference module-name tags named-polyT size))) - )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/case.lux b/stdlib/test/test/lux/lang/compiler/analysis/case.lux new file mode 100644 index 000000000..d2836558e --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/case.lux @@ -0,0 +1,194 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "B/" Eq] + ["R" error] + [product] + [maybe] + [text "T/" Eq] + text/format + (coll [list "list/" Monad] + (set ["set" unordered]))) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + (lang [type "type/" Eq] + (type ["tc" check]) + [".L" module] + (compiler [analysis] + (analysis [".A" type] + ["/" case]))) + test) + (// ["_." primitive] + ["_." structure])) + +(def: (exhaustive-weaving branchings) + (-> (List (List Code)) (List (List Code))) + (case branchings + #.Nil + #.Nil + + (#.Cons head+ #.Nil) + (list/map (|>> list) head+) + + (#.Cons head+ tail++) + (do list.Monad + [tail+ (exhaustive-weaving tail++) + head head+] + (wrap (#.Cons head tail+))))) + +(def: #export (exhaustive-branches allow-literals? variantTC inputC) + (-> Bool (List [Code Code]) Code (r.Random (List Code))) + (case inputC + [_ (#.Bool _)] + (r/wrap (list (' true) (' false))) + + (^template [ ] + [_ ( _)] + (if allow-literals? + (do r.Monad + [?sample (r.maybe )] + (case ?sample + (#.Some sample) + (do @ + [else (exhaustive-branches allow-literals? variantTC inputC)] + (wrap (list& ( sample) else))) + + #.None + (wrap (list (' _))))) + (r/wrap (list (' _))))) + ([#.Nat r.nat code.nat] + [#.Int r.int code.int] + [#.Deg r.deg code.deg] + [#.Frac r.frac code.frac] + [#.Text (r.unicode +5) code.text]) + + (^ [_ (#.Tuple (list))]) + (r/wrap (list (' []))) + + (^ [_ (#.Record (list))]) + (r/wrap (list (' {}))) + + [_ (#.Tuple members)] + (do r.Monad + [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (list/map code.tuple)))) + + [_ (#.Record kvs)] + (do r.Monad + [#let [ks (list/map product.left kvs) + vs (list/map product.right kvs)] + member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] + (wrap (|> member-wise-patterns + exhaustive-weaving + (list/map (|>> (list.zip2 ks) code.record))))) + + (^ [_ (#.Form (list [_ (#.Tag _)] _))]) + (do r.Monad + [bundles (monad.map @ + (function (_ [_tag _code]) + (do @ + [v-branches (exhaustive-branches allow-literals? variantTC _code)] + (wrap (list/map (function (_ pattern) (` ((~ _tag) (~ pattern)))) + v-branches)))) + variantTC)] + (wrap (list/join bundles))) + + _ + (r/wrap (list)) + )) + +(def: #export (input variant-tags record-tags primitivesC) + (-> (List Code) (List Code) (List Code) (r.Random Code)) + (r.rec + (function (_ input) + ($_ r.either + (r/map product.right _primitive.primitive) + (do r.Monad + [choice (|> r.nat (:: @ map (n/% (list.size variant-tags)))) + #let [choiceT (maybe.assume (list.nth choice variant-tags)) + choiceC (maybe.assume (list.nth choice primitivesC))]] + (wrap (` ((~ choiceT) (~ choiceC))))) + (do r.Monad + [size (|> r.nat (:: @ map (n/% +3))) + elems (r.list size input)] + (wrap (code.tuple elems))) + (r/wrap (code.record (list.zip2 record-tags primitivesC))) + )))) + +(def: (branch body pattern) + (-> Code Code [Code Code]) + [pattern body]) + +(context: "Pattern-matching." + ## #seed +9253409297339902486 + ## #seed +3793366152923578600 + (<| (seed +5004137551292836565) + ## (times +100) + (do @ + [module-name (r.unicode +5) + variant-name (r.unicode +5) + record-name (|> (r.unicode +5) (r.filter (|>> (T/= variant-name) not))) + size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + variant-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + record-tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + primitivesTC (r.list size _primitive.primitive) + #let [primitivesT (list/map product.left primitivesTC) + primitivesC (list/map product.right primitivesTC) + code-tag (|>> [module-name] code.tag) + variant-tags+ (list/map code-tag variant-tags) + record-tags+ (list/map code-tag record-tags) + variantTC (list.zip2 variant-tags+ primitivesC)] + inputC (input variant-tags+ record-tags+ primitivesC) + [outputT outputC] _primitive.primitive + [heterogeneousT heterogeneousC] (r.filter (|>> product.left (tc.checks? outputT) not) + _primitive.primitive) + exhaustive-patterns (exhaustive-branches true variantTC inputC) + redundant-patterns (exhaustive-branches false variantTC inputC) + redundancy-idx (|> r.nat (:: @ map (n/% (list.size redundant-patterns)))) + heterogeneous-idx (|> r.nat (:: @ map (n/% (list.size exhaustive-patterns)))) + #let [exhaustive-branchesC (list/map (branch outputC) + exhaustive-patterns) + non-exhaustive-branchesC (list.take (dec (list.size exhaustive-branchesC)) + exhaustive-branchesC) + redundant-branchesC (<| (list/map (branch outputC)) + list.concat + (list (list.take redundancy-idx redundant-patterns) + (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) + (list.drop redundancy-idx redundant-patterns))) + heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) + (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] + [_pattern heterogeneousC])) + (list.drop (inc heterogeneous-idx) exhaustive-branchesC))) + analyse-pm (|>> (/.case _primitive.analyse inputC) + (typeA.with-type outputT) + analysis.with-scope + (do Monad + [_ (moduleL.declare-tags variant-tags false + (#.Named [module-name variant-name] + (type.variant primitivesT))) + _ (moduleL.declare-tags record-tags false + (#.Named [module-name record-name] + (type.tuple primitivesT)))]) + (moduleL.with-module +0 module-name))]] + ($_ seq + (test "Will reject empty pattern-matching (no branches)." + (|> (analyse-pm (list)) + _structure.check-fails)) + (test "Can analyse exhaustive pattern-matching." + (|> (analyse-pm exhaustive-branchesC) + _structure.check-succeeds)) + (test "Will reject non-exhaustive pattern-matching." + (|> (analyse-pm non-exhaustive-branchesC) + _structure.check-fails)) + (test "Will reject redundant pattern-matching." + (|> (analyse-pm redundant-branchesC) + _structure.check-fails)) + (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." + (|> (analyse-pm heterogeneous-branchesC) + _structure.check-fails))) + ))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/function.lux b/stdlib/test/test/lux/lang/compiler/analysis/function.lux new file mode 100644 index 000000000..147cbcc9e --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/function.lux @@ -0,0 +1,112 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [maybe] + [product] + [text "text/" Eq] + text/format + (coll [list "list/" Functor])) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [lang] + (lang [type "type/" Eq] + [".L" reference] + (compiler [".L" init] + [".L" analysis #+ Analysis] + (analysis [".A" type] + [".A" expression] + ["/" function]))) + test) + (// ["_." primitive] + ["_." structure])) + +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(def: (check-apply expectedT num-args analysis) + (-> Type Nat (Meta Analysis) Bool) + (|> analysis + (typeA.with-type expectedT) + (macro.run (initL.compiler [])) + (case> (#e.Success applyA) + (let [[funcA argsA] (analysisL.application applyA)] + (n/= num-args (list.size argsA))) + + (#e.Error error) + false))) + +(context: "Function definition." + (<| (times +100) + (do @ + [func-name (r.unicode +5) + arg-name (|> (r.unicode +5) (r.filter (|>> (text/= func-name) not))) + [outputT outputC] _primitive.primitive + [inputT _] _primitive.primitive + #let [g!arg (code.local-symbol arg-name)]] + ($_ seq + (test "Can analyse function." + (and (|> (typeA.with-type (All [a] (-> a outputT)) + (/.function ..analyse func-name arg-name outputC)) + _structure.check-succeeds) + (|> (typeA.with-type (All [a] (-> a a)) + (/.function ..analyse func-name arg-name g!arg)) + _structure.check-succeeds))) + (test "Generic functions can always be specialized." + (and (|> (typeA.with-type (-> inputT outputT) + (/.function ..analyse func-name arg-name outputC)) + _structure.check-succeeds) + (|> (typeA.with-type (-> inputT inputT) + (/.function ..analyse func-name arg-name g!arg)) + _structure.check-succeeds))) + (test "The function's name is bound to the function's type." + (|> (typeA.with-type (Rec self (-> inputT self)) + (/.function ..analyse func-name arg-name (code.local-symbol func-name))) + _structure.check-succeeds)) + )))) + +(context: "Function application." + (<| (times +100) + (do @ + [full-args (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + partial-args (|> r.nat (:: @ map (n/% full-args))) + var-idx (|> r.nat (:: @ map (|>> (n/% full-args) (n/max +1)))) + inputsTC (r.list full-args _primitive.primitive) + #let [inputsT (list/map product.left inputsTC) + inputsC (list/map product.right inputsTC)] + [outputT outputC] _primitive.primitive + #let [funcT (type.function inputsT outputT) + partialT (type.function (list.drop partial-args inputsT) outputT) + varT (#.Bound +1) + polyT (<| (type.univ-q +1) + (type.function (list.concat (list (list.take var-idx inputsT) + (list varT) + (list.drop (inc var-idx) inputsT)))) + varT) + poly-inputT (maybe.assume (list.nth var-idx inputsT)) + partial-poly-inputsT (list.drop (inc var-idx) inputsT) + partial-polyT1 (<| (type.function partial-poly-inputsT) + poly-inputT) + partial-polyT2 (<| (type.univ-q +1) + (type.function (#.Cons varT partial-poly-inputsT)) + varT) + dummy-function (#analysisL.Function (list) (#analysisL.Reference (referenceL.local +1)))]] + ($_ seq + (test "Can analyse monomorphic type application." + (|> (/.apply ..analyse funcT dummy-function inputsC) + (check-apply outputT full-args))) + (test "Can partially apply functions." + (|> (/.apply ..analyse funcT dummy-function (list.take partial-args inputsC)) + (check-apply partialT partial-args))) + (test "Can apply polymorphic functions." + (|> (/.apply ..analyse polyT dummy-function inputsC) + (check-apply poly-inputT full-args))) + (test "Polymorphic partial application propagates found type-vars." + (|> (/.apply ..analyse polyT dummy-function (list.take (inc var-idx) inputsC)) + (check-apply partial-polyT1 (inc var-idx)))) + (test "Polymorphic partial application preserves quantification for type-vars." + (|> (/.apply ..analyse polyT dummy-function (list.take var-idx inputsC)) + (check-apply partial-polyT2 var-idx))) + )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux b/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux new file mode 100644 index 000000000..18b8f6c46 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/primitive.lux @@ -0,0 +1,86 @@ +(.module: + [lux #- primitive] + (lux [io] + (control [monad #+ do] + pipe + ["ex" exception #+ exception:]) + (data (text format) + ["e" error]) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [lang] + (lang [".L" type "type/" Eq] + (compiler [".L" init] + [analysis #+ Analysis] + (analysis [".A" type] + [".A" expression]))) + test)) + +(def: #export analyse (expressionA.analyser (:! lang.Eval []))) + +(def: unit + (r.Random Code) + (r/wrap (' []))) + +(def: #export primitive + (r.Random [Type Code]) + (`` ($_ r.either + (~~ (do-template [ ] + [(r.seq (r/wrap ) (r/map ))] + + [Any code.tuple (r.list +0 ..unit)] + [Bool code.bool r.bool] + [Nat code.nat r.nat] + [Int code.int r.int] + [Deg code.deg r.deg] + [Frac code.frac r.frac] + [Text code.text (r.unicode +5)] + ))))) + +(exception: (wrong-inference {expected Type} {inferred Type}) + (ex.report ["Expected" (%type expected)] + ["Inferred" (%type inferred)])) + +(def: (infer-primitive expected-type analysis) + (-> Type (Meta Analysis) (e.Error Analysis)) + (|> (typeA.with-inference + analysis) + (macro.run (initL.compiler [])) + (case> (#e.Success [inferred-type output]) + (if (is? expected-type inferred-type) + (#e.Success output) + (ex.throw wrong-inference [expected-type inferred-type])) + + (#e.Error error) + (#e.Error error)))) + +(context: "Primitives" + ($_ seq + (test "Can analyse unit." + (|> (infer-primitive Any (..analyse (' []))) + (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output)))) + (is? [] output) + + _ + false))) + (<| (times +100) + (`` ($_ seq + (~~ (do-template [ ] + [(do @ + [sample ] + (test (format "Can analyse " ".") + (|> (infer-primitive (..analyse ( sample))) + (case> (#e.Success (#analysis.Primitive ( output))) + (is? sample output) + + _ + false))))] + + ["bool" Bool #analysis.Bool r.bool code.bool] + ["nat" Nat #analysis.Nat r.nat code.nat] + ["int" Int #analysis.Int r.int code.int] + ["deg" Deg #analysis.Deg r.deg code.deg] + ["frac" Frac #analysis.Frac r.frac code.frac] + ["text" Text #analysis.Text (r.unicode +5) code.text] + ))))))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux new file mode 100644 index 000000000..898376045 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/procedure/common.lux @@ -0,0 +1,316 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data text/format + ["e" error] + [product] + (coll [array])) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type "type/" Eq] + [".L" scope] + [".L" init] + (analysis [".A" type])) + test) + (/// ["_." primitive])) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params)))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [check-success+ true false] + [check-failure+ false true] + ) + +(context: "Lux procedures" + (<| (times +100) + (do @ + [[primT primC] _primitive.primitive + [antiT antiC] (|> _primitive.primitive + (r.filter (|>> product.left (type/= primT) not)))] + ($_ seq + (test "Can test for reference equality." + (check-success+ "lux is" (list primC primC) Bool)) + (test "Reference equality must be done with elements of the same type." + (check-failure+ "lux is" (list primC antiC) Bool)) + (test "Can 'try' risky IO computations." + (check-success+ "lux try" + (list (` ("lux function" (~' _) (~' _) (~ 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 equality of integers." + (check-success+ "lux int =" (list subjectC paramC) Bool)) + (test "Can compare integers." + (check-success+ "lux int <" (list subjectC paramC) Bool)) + (test "Can obtain minimum integer." + (check-success+ "lux int min" (list) Int)) + (test "Can obtain maximum integer." + (check-success+ "lux int max" (list) Int)) + (test "Can convert integer to natural number." + (check-success+ "lux int to-nat" (list subjectC) Nat)) + (test "Can convert integer to frac number." + (check-success+ "lux int to-frac" (list subjectC) Frac)) + (test "Can convert integer to text." + (check-success+ "lux int char" (list subjectC) Text)) + )))) + +(context: "Frac procedures" + (<| (times +100) + (do @ + [subjectC (|> r.frac (:: @ map code.frac)) + paramC (|> r.frac (:: @ map code.frac)) + encodedC (|> (r.unicode +5) (:: @ map code.text))] + ($_ seq + (test "Can add frac numbers." + (check-success+ "lux frac +" (list subjectC paramC) Frac)) + (test "Can subtract frac numbers." + (check-success+ "lux frac -" (list subjectC paramC) Frac)) + (test "Can multiply frac numbers." + (check-success+ "lux frac *" (list subjectC paramC) Frac)) + (test "Can divide frac numbers." + (check-success+ "lux frac /" (list subjectC paramC) Frac)) + (test "Can calculate remainder of frac numbers." + (check-success+ "lux frac %" (list subjectC paramC) Frac)) + (test "Can test equality of frac numbers." + (check-success+ "lux frac =" (list subjectC paramC) Bool)) + (test "Can compare frac numbers." + (check-success+ "lux frac <" (list subjectC paramC) Bool)) + (test "Can obtain minimum frac number." + (check-success+ "lux frac min" (list) Frac)) + (test "Can obtain maximum frac number." + (check-success+ "lux frac max" (list) Frac)) + (test "Can obtain smallest frac number." + (check-success+ "lux frac smallest" (list) Frac)) + (test "Can obtain not-a-number." + (check-success+ "lux frac not-a-number" (list) Frac)) + (test "Can obtain positive infinity." + (check-success+ "lux frac positive-infinity" (list) Frac)) + (test "Can obtain negative infinity." + (check-success+ "lux frac negative-infinity" (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 equality." + (check-success+ "lux text =" (list subjectC paramC) Bool)) + (test "Compare texts in lexicographical order." + (check-success+ "lux text <" (list subjectC paramC) Bool)) + (test "Can concatenate one text to another." + (check-success+ "lux text concat" (list subjectC paramC) Text)) + (test "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "lux text index" (list subjectC paramC fromC) (type (Maybe Nat)))) + (test "Can query the size/length of a text." + (check-success+ "lux text size" (list subjectC) Nat)) + (test "Can calculate a hash code for text." + (check-success+ "lux text hash" (list subjectC) Nat)) + (test "Can replace a text inside of a larger one (once)." + (check-success+ "lux text replace-once" (list subjectC paramC replacementC) Text)) + (test "Can replace a text inside of a larger one (all times)." + (check-success+ "lux text replace-all" (list subjectC paramC replacementC) Text)) + (test "Can obtain the character code of a text at a given index." + (check-success+ "lux text char" (list subjectC fromC) (type (Maybe Nat)))) + (test "Can clip a piece of text between 2 indices." + (check-success+ "lux text clip" (list subjectC fromC toC) (type (Maybe Text)))) + )))) + +(context: "Array procedures" + (<| (times +100) + (do @ + [[elemT elemC] _primitive.primitive + sizeC (|> r.nat (:: @ map code.nat)) + idxC (|> r.nat (:: @ map code.nat)) + var-name (r.unicode +5) + #let [arrayT (type (Array elemT)) + g!array (code.local-symbol var-name) + array-operation (function (_ output-type code) + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name arrayT] + (typeA.with-type output-type + (_primitive.analyse code)))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error error) + false)))]] + ($_ seq + (test "Can create arrays." + (check-success+ "lux array new" (list sizeC) arrayT)) + (test "Can get a value inside an array." + (array-operation (type (Maybe elemT)) + (` ("lux array get" (~ g!array) (~ idxC))))) + (test "Can put a value inside an array." + (array-operation arrayT + (` ("lux array put" (~ g!array) (~ idxC) (~ elemC))))) + (test "Can remove a value from an array." + (array-operation arrayT + (` ("lux array remove" (~ g!array) (~ idxC))))) + (test "Can query the size of an array." + (array-operation Nat + (` ("lux array size" (~ g!array))))) + )))) + +(context: "Math procedures" + (<| (times +100) + (do @ + [subjectC (|> r.frac (:: @ map code.frac)) + paramC (|> r.frac (:: @ map code.frac))] + (`` ($_ seq + (~~ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC) Frac))] + + ["lux math cos" "cosine"] + ["lux math sin" "sine"] + ["lux math tan" "tangent"] + ["lux math acos" "inverse/arc cosine"] + ["lux math asin" "inverse/arc sine"] + ["lux math atan" "inverse/arc tangent"] + ["lux math cosh" "hyperbolic cosine"] + ["lux math sinh" "hyperbolic sine"] + ["lux math tanh" "hyperbolic tangent"] + ["lux math exp" "exponentiation"] + ["lux math log" "logarithm"] + ["lux math ceil" "ceiling"] + ["lux math floor" "floor"] + ["lux math round" "rounding"])) + (~~ (do-template [ ] + [(test (format "Can calculate " ".") + (check-success+ (list subjectC paramC) Frac))] + + ["lux math atan2" "inverse/arc tangent (with 2 arguments)"] + ["lux math pow" "power"]))))))) + +(context: "Atom procedures" + (<| (times +100) + (do @ + [[elemT elemC] _primitive.primitive + sizeC (|> r.nat (:: @ map code.nat)) + idxC (|> r.nat (:: @ map code.nat)) + var-name (r.unicode +5) + #let [atomT (type (atom.Atom elemT))]] + ($_ seq + (test "Can create atomic reference." + (check-success+ "lux atom new" (list elemC) atomT)) + (test "Can read the value of an atomic reference." + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type elemT + (_primitive.analyse (` ("lux atom read" (~ (code.symbol ["" var-name])))))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error _) + false))) + (test "Can swap the value of an atomic reference." + (|> (scopeL.with-scope "" + (scopeL.with-local [var-name atomT] + (typeA.with-type Bool + (_primitive.analyse (` ("lux atom compare-and-swap" + (~ (code.symbol ["" var-name])) + (~ elemC) + (~ elemC))))))) + (macro.run (initL.compiler [])) + (case> (#e.Success _) + true + + (#e.Error _) + false))) + )))) + +(context: "Process procedures" + (<| (times +100) + (do @ + [[primT primC] _primitive.primitive + timeC (|> r.nat (:: @ map code.nat))] + ($_ seq + (test "Can query the level of concurrency." + (check-success+ "lux process parallelism-level" (list) Nat)) + (test "Can schedule an IO computation to run concurrently at some future time." + (check-success+ "lux process schedule" + (list timeC + (` ("lux function" (~' _) (~' _) (~ primC)))) + Any)) + )))) + +(context: "IO procedures" + (<| (times +100) + (do @ + [logC (|> (r.unicode +5) (:: @ map code.text)) + exitC (|> r.int (:: @ map code.int))] + ($_ seq + (test "Can log messages to standard output." + (check-success+ "lux io log" (list logC) Any)) + (test "Can throw a run-time error." + (check-success+ "lux io error" (list logC) Nothing)) + (test "Can exit the program." + (check-success+ "lux io exit" (list exitC) Nothing)) + (test "Can query the current time (as milliseconds since epoch)." + (check-success+ "lux io current-time" (list) Int)) + )))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux new file mode 100644 index 000000000..0a60149d5 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/procedure/host.jvm.lux @@ -0,0 +1,541 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (concurrency [atom]) + (data ["e" error] + [product] + [maybe] + [text "text/" Eq] + text/format + (coll [array] + [list "list/" Fold] + (dictionary ["dict" unordered]))) + ["r" math/random "r/" Monad] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type] + [".L" init] + (analysis [".A" type]) + (extension (analysis [".AE" host]))) + test) + (/// ["_." primitive])) + +(do-template [ ] + [(def: ( procedure params output-type) + (-> Text (List Code) Type Bool) + (|> (do Monad + [## runtime-bytecode @runtime.translate + ] + (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse (` ((~ (code.text procedure)) (~+ params))))))) + (lang.with-current-module "") + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [success true false] + [failure false true] + ) + +(do-template [ ] + [(def: ( syntax output-type) + (-> Code Type Bool) + (|> (do Monad + [## runtime-bytecode @runtime.translate + ] + (lang.with-scope + (typeA.with-type output-type + (_primitive.analyse syntax)))) + (lang.with-current-module "") + (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + (#e.Error error) + )))] + + [success' true false] + [failure' false true] + ) + +(context: "Conversions [double + float]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert double-to-float" "java.lang.Double" hostAE.Float] + ["jvm convert double-to-int" "java.lang.Double" hostAE.Integer] + ["jvm convert double-to-long" "java.lang.Double" hostAE.Long] + ["jvm convert float-to-double" "java.lang.Float" hostAE.Double] + ["jvm convert float-to-int" "java.lang.Float" hostAE.Integer] + ["jvm convert float-to-long" "java.lang.Float" hostAE.Long] + )] + ($_ seq + + ))) + +(context: "Conversions [int]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert int-to-byte" "java.lang.Integer" hostAE.Byte] + ["jvm convert int-to-char" "java.lang.Integer" hostAE.Character] + ["jvm convert int-to-double" "java.lang.Integer" hostAE.Double] + ["jvm convert int-to-float" "java.lang.Integer" hostAE.Float] + ["jvm convert int-to-long" "java.lang.Integer" hostAE.Long] + ["jvm convert int-to-short" "java.lang.Integer" hostAE.Short] + )] + ($_ seq + + ))) + +(context: "Conversions [long]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert long-to-double" "java.lang.Long" hostAE.Double] + ["jvm convert long-to-float" "java.lang.Long" hostAE.Float] + ["jvm convert long-to-int" "java.lang.Long" hostAE.Integer] + ["jvm convert long-to-short" "java.lang.Long" hostAE.Short] + ["jvm convert long-to-byte" "java.lang.Long" hostAE.Byte] + )] + ($_ seq + + ))) + +(context: "Conversions [char + byte + short]." + (with-expansions [ (do-template [ ] + [(test (format " SUCCESS") + (success (list (' ("lux coerce" (+0 (+0)) []))) )) + (test (format " FAILURE") + (failure (list (' [])) ))] + + ["jvm convert char-to-byte" "java.lang.Character" hostAE.Byte] + ["jvm convert char-to-short" "java.lang.Character" hostAE.Short] + ["jvm convert char-to-int" "java.lang.Character" hostAE.Integer] + ["jvm convert char-to-long" "java.lang.Character" hostAE.Long] + ["jvm convert byte-to-long" "java.lang.Byte" hostAE.Long] + ["jvm convert short-to-long" "java.lang.Short" hostAE.Long] + )] + ($_ seq + + ))) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + ))) + + (context: (format "Bitwise " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " and") ] + [(format "jvm " " or") ] + [(format "jvm " " xor") ] + [(format "jvm " " shl") "java.lang.Integer" ] + [(format "jvm " " shr") "java.lang.Integer" ] + [(format "jvm " " ushr") "java.lang.Integer" ] + )] + ($_ seq + + )))] + + + ["int" "java.lang.Integer" hostAE.Integer] + ["long" "java.lang.Long" hostAE.Long] + ) + +(do-template [ ] + [(context: (format "Arithmetic " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " +") ] + [(format "jvm " " -") ] + [(format "jvm " " *") ] + [(format "jvm " " /") ] + [(format "jvm " " %") ] + )] + ($_ seq + + ))) + + (context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + )))] + + + ["float" "java.lang.Float" hostAE.Float] + ["double" "java.lang.Double" hostAE.Double] + ) + +(do-template [ ] + [(context: (format "Order " "[" "].") + (with-expansions [ (do-template [ ] + [(test + (success + (list (' ("lux coerce" (+0 (+0)) [])) + (' ("lux coerce" (+0 (+0)) []))) + ))] + + [(format "jvm " " =") hostAE.Boolean] + [(format "jvm " " <") hostAE.Boolean] + )] + ($_ seq + + )))] + + + ["char" "java.lang.Character" hostAE.Character] + ) + +(def: array-type + (r.Random [Text Text]) + (let [entries (dict.entries hostAE.boxes) + num-entries (list.size entries)] + (do r.Monad + [choice (|> r.nat (:: @ map (n/% (inc num-entries)))) + #let [[unboxed boxed] (: [Text Text] + (|> entries + (list.nth choice) + (maybe.default ["java.lang.Object" "java.lang.Object"])))]] + (wrap [unboxed boxed])))) + +(context: "Array." + (<| (times +100) + (do @ + [#let [cap (|>> (n/% +10) (n/max +1))] + [unboxed boxed] array-type + size (|> r.nat (:: @ map cap)) + idx (|> r.nat (:: @ map (n/% size))) + level (|> r.nat (:: @ map cap)) + #let [unboxedT (#.Primitive unboxed (list)) + arrayT (#.Primitive "#Array" (list unboxedT)) + arrayC (`' ("lux check" (+0 "#Array" (+1 (+0 (~ (code.text unboxed)) (+0)) (+0))) + ("jvm array new" (~ (code.nat size))))) + boxedT (#.Primitive boxed (list)) + boxedTC (` (+0 (~ (code.text boxed)) (+0))) + multi-arrayT (list/fold (function (_ _ innerT) + (|> innerT (list) (#.Primitive "#Array"))) + boxedT + (list.n/range +1 level))]] + ($_ seq + (test "jvm array new" + (success "jvm array new" + (list (code.nat size)) + arrayT)) + (test "jvm array new (no nesting)" + (failure "jvm array new" + (list (code.nat size)) + unboxedT)) + (test "jvm array new (nested/multi-level)" + (success "jvm array new" + (list (code.nat size)) + multi-arrayT)) + (test "jvm array length" + (success "jvm array length" + (list arrayC) + Nat)) + (test "jvm array read" + (success' (` ("jvm object cast" + ("jvm array read" (~ arrayC) (~ (code.nat idx))))) + boxedT)) + (test "jvm array write" + (success "jvm array write" + (list arrayC (code.nat idx) (`' ("lux coerce" (~ boxedTC) []))) + arrayT)) + )))) + +(def: throwables + (List Text) + (list "java.lang.Throwable" + "java.lang.Error" + "java.io.IOError" + "java.lang.VirtualMachineError" + "java.lang.Exception" + "java.io.IOException" + "java.lang.RuntimeException")) + +(context: "Object." + (<| (times +100) + (do @ + [[unboxed boxed] array-type + [!unboxed !boxed] (|> array-type + (r.filter (function (_ [!unboxed !boxed]) + (not (text/= boxed !boxed))))) + #let [boxedT (#.Primitive boxed (list)) + boxedC (`' ("lux check" (+0 (~ (code.text boxed)) (+0)) + ("jvm object null"))) + !boxedC (`' ("lux check" (+0 (~ (code.text !boxed)) (+0)) + ("jvm object null"))) + unboxedC (`' ("lux check" (+0 (~ (code.text unboxed)) (+0)) + ("jvm object null")))] + throwable (|> r.nat + (:: @ map (n/% (inc (list.size throwables)))) + (:: @ map (function (_ idx) + (|> throwables + (list.nth idx) + (maybe.default "java.lang.Object"))))) + #let [throwableC (`' ("lux check" (+0 (~ (code.text throwable)) (+0)) + ("jvm object null")))]] + ($_ seq + (test "jvm object null" + (success "jvm object null" + (list) + (#.Primitive boxed (list)))) + (test "jvm object null (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object null" + (list) + (#.Primitive unboxed (list))))) + (test "jvm object null?" + (success "jvm object null?" + (list boxedC) + Bool)) + (test "jvm object synchronized" + (success "jvm object synchronized" + (list boxedC boxedC) + boxedT)) + (test "jvm object synchronized (no primitives)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object synchronized" + (list unboxedC boxedC) + boxedT))) + (test "jvm object throw" + (or (text/= "java.lang.Object" throwable) + (success "jvm object throw" + (list throwableC) + Nothing))) + (test "jvm object class" + (success "jvm object class" + (list (code.text boxed)) + (#.Primitive "java.lang.Class" (list boxedT)))) + (test "jvm object instance?" + (success "jvm object instance?" + (list (code.text boxed) + boxedC) + Bool)) + (test "jvm object instance? (lineage)" + (success "jvm object instance?" + (list (' "java.lang.Object") + boxedC) + Bool)) + (test "jvm object instance? (no lineage)" + (or (text/= "java.lang.Object" boxed) + (failure "jvm object instance?" + (list (code.text boxed) + !boxedC) + Bool))) + )))) + +(context: "Member [Static Field]." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code.text "java.lang.System") + (code.text "out")) + (#.Primitive "java.io.PrintStream" (list)))) + (test "jvm member static get (inheritance out)" + (success "jvm member static get" + (list (code.text "java.lang.System") + (code.text "out")) + (#.Primitive "java.lang.Object" (list)))) + (test "jvm member static put" + (success "jvm member static put" + (list (code.text "java.awt.datatransfer.DataFlavor") + (code.text "allHtmlFlavor") + (`' ("lux check" (+0 "java.awt.datatransfer.DataFlavor" (+0)) + ("jvm object null")))) + Any)) + (test "jvm member static put (final)" + (failure "jvm member static put" + (list (code.text "java.lang.System") + (code.text "out") + (`' ("lux check" (+0 "java.io.PrintStream" (+0)) + ("jvm object null")))) + Any)) + (test "jvm member static put (inheritance in)" + (success "jvm member static put" + (list (code.text "java.awt.datatransfer.DataFlavor") + (code.text "allHtmlFlavor") + (`' ("jvm object cast" + ("lux check" (+0 "javax.activation.ActivationDataFlavor" (+0)) + ("jvm object null"))))) + Any)) + )) + +(context: "Member [Virtual Field]." + ($_ seq + (test "jvm member virtual get" + (success "jvm member virtual get" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.String" (list)))) + (test "jvm member virtual get (inheritance out)" + (success "jvm member virtual get" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.Object" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code.text "org.omg.CORBA.ValueMember") + (code.text "id") + (`' ("lux check" (+0 "java.lang.String" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "org.omg.CORBA.ValueMember" (+0)) + ("jvm object null")))) + (primitive "org.omg.CORBA.ValueMember"))) + (test "jvm member virtual put (final)" + (failure "jvm member virtual put" + (list (code.text "javax.swing.text.html.parser.DTD") + (code.text "applet") + (`' ("lux check" (+0 "javax.swing.text.html.parser.Element" (+0)) + ("jvm object null"))) + (`' ("lux check" (+0 "javax.swing.text.html.parser.DTD" (+0)) + ("jvm object null")))) + (primitive "javax.swing.text.html.parser.DTD"))) + (test "jvm member virtual put (inheritance in)" + (success "jvm member virtual put" + (list (code.text "java.awt.GridBagConstraints") + (code.text "insets") + (`' ("jvm object cast" + ("lux check" (+0 "javax.swing.plaf.InsetsUIResource" (+0)) + ("jvm object null")))) + (`' ("lux check" (+0 "java.awt.GridBagConstraints" (+0)) + ("jvm object null")))) + (primitive "java.awt.GridBagConstraints"))) + )) + +(context: "Boxing/Unboxing." + ($_ seq + (test "jvm member static get" + (success "jvm member static get" + (list (code.text "java.util.GregorianCalendar") + (code.text "AD")) + (#.Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual get" + (success "jvm member virtual get" + (list (code.text "javax.accessibility.AccessibleAttributeSequence") + (code.text "startIndex") + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (#.Primitive "java.lang.Integer" (list)))) + (test "jvm member virtual put" + (success "jvm member virtual put" + (list (code.text "javax.accessibility.AccessibleAttributeSequence") + (code.text "startIndex") + (`' ("jvm object cast" + ("lux check" (+0 "java.lang.Integer" (+0)) + ("jvm object null")))) + (`' ("lux check" (+0 "javax.accessibility.AccessibleAttributeSequence" (+0)) + ("jvm object null")))) + (primitive "javax.accessibility.AccessibleAttributeSequence"))) + )) + +(context: "Member [Method]." + (let [longC (' ("lux coerce" (+0 "java.lang.Long" (+0)) + +123)) + intC (`' ("jvm convert long-to-int" (~ longC))) + stringC (' ("lux coerce" (+0 "java.lang.String" (+0)) + "YOLO")) + objectC (`' ("lux check" (+0 "java.util.ArrayList" (+1 (+0 "java.lang.Long" (+0)) (+0))) + ("jvm member invoke constructor" "java.util.ArrayList" + ["int" ("jvm object cast" (~ intC))])))] + ($_ seq + (test "jvm member invoke static" + (success' (` ("jvm member invoke static" + "java.lang.Long" "decode" + ["java.lang.String" (~ stringC)])) + (#.Primitive "java.lang.Long" (list)))) + (test "jvm member invoke virtual" + (success' (` ("jvm object cast" + ("jvm member invoke virtual" + "java.lang.Object" "equals" + ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke special" + (success' (` ("jvm object cast" + ("jvm member invoke special" + "java.lang.Long" "equals" + ("jvm object cast" (~ longC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke interface" + (success' (` ("jvm object cast" + ("jvm member invoke interface" + "java.util.Collection" "add" + ("jvm object cast" (~ objectC)) ["java.lang.Object" ("jvm object cast" (~ longC))]))) + (#.Primitive "java.lang.Boolean" (list)))) + (test "jvm member invoke constructor" + (success' (` ("jvm member invoke constructor" + "java.util.ArrayList" + ["int" ("jvm object cast" (~ intC))])) + (All [a] (#.Primitive "java.util.ArrayList" (list a))))) + ))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/reference.lux b/stdlib/test/test/lux/lang/compiler/analysis/reference.lux new file mode 100644 index 000000000..ff7ce3412 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/reference.lux @@ -0,0 +1,58 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data ["e" error] + [ident "ident/" Eq]) + ["r" math/random] + [macro #+ Monad] + (macro [code]) + [lang] + (lang [type "type/" Eq] + [".L" scope] + [".L" module] + [".L" reference] + (compiler [".L" init] + [".L" analysis] + (analysis [".A" type] + [".A" expression]))) + test) + (// ["_." primitive])) + +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(context: "References" + (<| (times +100) + (do @ + [[expectedT _] _primitive.primitive + module-name (r.unicode +5) + scope-name (r.unicode +5) + var-name (r.unicode +5) + #let [def-name [module-name var-name]]] + ($_ seq + (test "Can analyse variable." + (|> (scopeL.with-scope scope-name + (scopeL.with-local [var-name expectedT] + (typeA.with-inference + (..analyse (code.local-symbol var-name))))) + (macro.run (initL.compiler [])) + (case> (^ (#e.Success [inferredT (#analysisL.Reference (referenceL.local var))])) + (and (type/= expectedT inferredT) + (n/= +0 var)) + + _ + false))) + (test "Can analyse definition." + (|> (do Monad + [_ (moduleL.define var-name [expectedT (' {}) []])] + (typeA.with-inference + (..analyse (code.symbol def-name)))) + (moduleL.with-module +0 module-name) + (macro.run (initL.compiler [])) + (case> (^ (#e.Success [_ inferredT (#analysisL.Reference (referenceL.constant constant-name))])) + (and (type/= expectedT inferredT) + (ident/= def-name constant-name)) + + _ + false))))))) diff --git a/stdlib/test/test/lux/lang/compiler/analysis/structure.lux b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux new file mode 100644 index 000000000..2f3e369d6 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/analysis/structure.lux @@ -0,0 +1,292 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + ["e" error] + [product] + [maybe] + [text] + text/format + (coll [list "list/" Functor] + (set ["set" unordered]))) + ["r" math/random "r/" Monad] + [macro] + (macro [code]) + [lang] + (lang [type "type/" Eq] + (type ["tc" check]) + [".L" module] + (compiler [".L" init] + [".L" analysis #+ Analysis Variant Tag] + (analysis [".A" type] + ["/" structure] + [".A" expression]))) + test) + (// ["_." primitive])) + +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(do-template [ ] + [(def: #export + (All [a] (-> (Meta a) Bool)) + (|>> (macro.run (initL.compiler [])) + (case> (#e.Success _) + + + _ + )))] + + [check-succeeds true false] + [check-fails false true] + ) + +(def: (check-sum' size tag variant) + (-> Nat Tag (Variant Analysis) Bool) + (let [variant-tag (if (get@ #analysisL.right? variant) + (inc (get@ #analysisL.lefts variant)) + (get@ #analysisL.lefts variant))] + (|> size dec (n/= tag) + (bool/= (get@ #analysisL.right? variant)) + (and (n/= tag variant-tag))))) + +(def: (check-sum type size tag analysis) + (-> Type Nat Tag (Meta Analysis) Bool) + (|> analysis + (typeA.with-type type) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success sumA) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + false))) + +(def: (tagged module tags type) + (All [a] (-> Text (List moduleL.Tag) Type (Meta a) (Meta [Module a]))) + (|>> (do macro.Monad + [_ (moduleL.declare-tags tags false type)]) + (moduleL.with-module +0 module))) + +(def: (check-variant module tags type size tag analysis) + (-> Text (List moduleL.Tag) Type Nat Tag (Meta Analysis) Bool) + (|> analysis + (tagged module tags type) + (typeA.with-type type) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success [_ sumA]) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + false))) + +(def: (right-size? size) + (-> Nat (-> Analysis Bool)) + (|>> analysisL.tuple list.size (n/= size))) + +(def: (check-record-inference module tags type size analysis) + (-> Text (List moduleL.Tag) Type Nat (Meta [Type Analysis]) Bool) + (|> analysis + (tagged module tags type) + (macro.run (initL.compiler [])) + (case> (#e.Success [_ productT productA]) + (and (type/= type productT) + (right-size? size productA)) + + _ + false))) + +(context: "Sums" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + choice (|> r.nat (:: @ map (n/% size))) + primitives (r.list size _primitive.primitive) + +choice (|> r.nat (:: @ map (n/% (inc size)))) + [_ +valueC] _primitive.primitive + #let [variantT (type.variant (list/map product.left primitives)) + [valueT valueC] (maybe.assume (list.nth choice primitives)) + +size (inc size) + +primitives (list.concat (list (list.take choice primitives) + (list [(#.Bound +1) +valueC]) + (list.drop choice primitives))) + [+valueT +valueC] (maybe.assume (list.nth +choice +primitives)) + +variantT (type.variant (list/map product.left +primitives))]] + ($_ seq + (test "Can analyse sum." + (check-sum variantT size choice + (/.sum ..analyse choice valueC))) + (test "Can analyse sum through bound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var) + _ (typeA.with-env + (tc.check varT variantT))] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success sumA) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size choice variant) + + _ + false))) + (test "Cannot analyse sum through unbound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var)] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + check-fails)) + (test "Can analyse sum through existential quantification." + (|> (typeA.with-type (type.ex-q +1 +variantT) + (/.sum ..analyse +choice +valueC)) + check-succeeds)) + (test "Can analyse sum through universal quantification." + (let [check-outcome (if (not (n/= choice +choice)) + check-succeeds + check-fails)] + (|> (typeA.with-type (type.univ-q +1 +variantT) + (/.sum ..analyse +choice +valueC)) + check-outcome))) + )))) + +(context: "Products" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + primitives (r.list size _primitive.primitive) + choice (|> r.nat (:: @ map (n/% size))) + [_ +valueC] _primitive.primitive + #let [tupleT (type.tuple (list/map product.left primitives)) + [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) + +primitives (list.concat (list (list.take choice primitives) + (list [(#.Bound +1) +valueC]) + (list.drop choice primitives))) + +tupleT (type.tuple (list/map product.left +primitives))]] + ($_ seq + (test "Can analyse product." + (|> (typeA.with-type tupleT + (/.product ..analyse (list/map product.right primitives))) + (macro.run (initL.compiler [])) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + false))) + (test "Can infer product." + (|> (typeA.with-inference + (/.product ..analyse (list/map product.right primitives))) + (macro.run (initL.compiler [])) + (case> (#e.Success [_type tupleA]) + (and (type/= tupleT _type) + (right-size? size tupleA)) + + _ + false))) + (test "Can analyse pseudo-product (singleton tuple)" + (|> (typeA.with-type singletonT + (..analyse (` [(~ singletonC)]))) + check-succeeds)) + (test "Can analyse product through bound type-vars." + (|> (do macro.Monad + [[_ varT] (typeA.with-env tc.var) + _ (typeA.with-env + (tc.check varT (type.tuple (list/map product.left primitives))))] + (typeA.with-type varT + (/.product ..analyse (list/map product.right primitives)))) + (macro.run (initL.compiler [])) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + false))) + (test "Can analyse product through existential quantification." + (|> (typeA.with-type (type.ex-q +1 +tupleT) + (/.product ..analyse (list/map product.right +primitives))) + check-succeeds)) + (test "Cannot analyse product through universal quantification." + (|> (typeA.with-type (type.univ-q +1 +tupleT) + (/.product ..analyse (list/map product.right +primitives))) + check-fails)) + )))) + +(context: "Tagged Sums" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash size (r.unicode +5)) (:: @ map set.to-list)) + choice (|> r.nat (:: @ map (n/% size))) + other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not))) + primitives (r.list size _primitive.primitive) + module-name (r.unicode +5) + type-name (r.unicode +5) + #let [varT (#.Bound +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 (#.Bound +1) + tagsC (list/map (|>> [module-name] code.tag) tags) + primitivesT (list/map product.left primitives) + primitivesC (list/map product.right primitives) + tupleT (type.tuple primitivesT) + namedT (#.Named [module-name type-name] tupleT) + recordC (list.zip2 tagsC primitivesC) + named-polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q +1) + (#.Named [module-name type-name]))]] + ($_ seq + (test "Can infer record." + (|> (typeA.with-inference + (/.record ..analyse recordC)) + (check-record-inference module-name tags namedT size))) + (test "Records specialize when type-vars get bound." + (|> (typeA.with-inference + (/.record ..analyse recordC)) + (check-record-inference module-name tags named-polyT size))) + (test "Can specialize generic records." + (|> (do macro.Monad + [recordA (typeA.with-type tupleT + (/.record ..analyse recordC))] + (wrap [tupleT recordA])) + (check-record-inference module-name tags named-polyT size))) + )))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/case.lux b/stdlib/test/test/lux/lang/compiler/synthesis/case.lux new file mode 100644 index 000000000..228ed2920 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/synthesis/case.lux @@ -0,0 +1,82 @@ +(.module: + lux + (lux (control [monad #+ do] + pipe) + (data [error "error/" Functor]) + (lang ["///." reference] + ["///." compiler] + [".L" analysis #+ Branch Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random "r/" Monad] + test) + [//primitive]) + +(context: "Dummy variables." + (<| (times +100) + (do @ + [maskedA //primitive.primitive + temp (|> r.nat (:: @ map (n/% +100))) + #let [maskA (analysisL.control/case + [maskedA + [[(#analysisL.Bind temp) + (#analysisL.Reference (///reference.local temp))] + (list)]])]] + (test "Dummy variables created to mask expressions get eliminated during synthesis." + (|> maskA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (error/map (//primitive.corresponds? maskedA)) + (error.default false)))))) + +(context: "Let expressions." + (<| (times +100) + (do @ + [registerA r.nat + inputA //primitive.primitive + outputA //primitive.primitive + #let [letA (analysisL.control/case + [inputA + [[(#analysisL.Bind registerA) + outputA] + (list)]])]] + (test "Can detect and reify simple 'let' expressions." + (|> letA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) + (and (n/= registerA registerS) + (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? outputA outputS)) + + _ + false)))))) + +(context: "If expressions." + (<| (times +100) + (do @ + [then|else r.bool + inputA //primitive.primitive + thenA //primitive.primitive + elseA //primitive.primitive + #let [thenB (: Branch + [(#analysisL.Simple (#analysisL.Bool true)) + thenA]) + elseB (: Branch + [(#analysisL.Simple (#analysisL.Bool false)) + elseA]) + ifA (if then|else + (analysisL.control/case [inputA [thenB (list elseB)]]) + (analysisL.control/case [inputA [elseB (list thenB)]]))]] + (test "Can detect and reify simple 'if' expressions." + (|> ifA + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) + (and (//primitive.corresponds? inputA inputS) + (//primitive.corresponds? thenA thenS) + (//primitive.corresponds? elseA elseS)) + + _ + false)))))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/function.lux b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux new file mode 100644 index 000000000..c7b16de27 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/synthesis/function.lux @@ -0,0 +1,168 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [product] + [maybe] + [error] + [number] + text/format + (coll [list "list/" Functor Fold] + (dictionary ["dict" unordered #+ Dict]) + (set ["set" unordered]))) + (lang ["///." reference #+ Variable "variable/" Equality] + ["///." compiler] + [".L" analysis #+ Arity Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random] + test) + [//primitive]) + +(def: constant-function + (r.Random [Arity Analysis Analysis]) + (r.rec + (function (_ constant-function) + (do r.Monad + [function? r.bool] + (if function? + (do @ + [[arity bodyA predictionA] constant-function] + (wrap [(inc arity) + (#analysisL.Function (list) bodyA) + predictionA])) + (do @ + [predictionA //primitive.primitive] + (wrap [+0 predictionA predictionA]))))))) + +(def: (pick scope-size) + (-> Nat (r.Random Nat)) + (|> r.nat (:: r.Monad map (n/% scope-size)))) + +(def: function-with-environment + (r.Random [Arity Analysis Variable]) + (do r.Monad + [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10)))) + #let [indices (list.n/range +0 (dec num-locals)) + local-env (list/map (|>> #///reference.Local) indices) + foreign-env (list/map (|>> #///reference.Foreign) indices)] + [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable]) + (loop [arity +1 + current-env foreign-env] + (let [current-env/size (list.size current-env) + resolver (list/fold (function (_ [idx var] resolver) + (dict.put idx var resolver)) + (: (Dict Nat Variable) + (dict.new number.Hash)) + (list.enumerate current-env))] + (do @ + [nest? r.bool] + (if nest? + (do @ + [num-picks (:: @ map (n/max +1) (pick (inc current-env/size))) + picks (|> (r.set number.Hash num-picks (pick current-env/size)) + (:: @ map set.to-list)) + [arity bodyA predictionA] (recur (inc arity) + (list/map (function (_ pick) + (maybe.assume (list.nth pick current-env))) + picks)) + #let [picked-env (list/map (|>> #///reference.Foreign) picks)]] + (wrap [arity + (#analysisL.Function picked-env bodyA) + predictionA])) + (do @ + [chosen (pick (list.size current-env))] + (wrap [arity + (#analysisL.Reference (///reference.foreign chosen)) + (maybe.assume (dict.get chosen resolver))])))))))] + (wrap [arity + (#analysisL.Function local-env bodyA) + predictionA]))) + +(def: local-function + (r.Random [Arity Analysis Variable]) + (loop [arity +0 + nest? true] + (if nest? + (do r.Monad + [nest?' r.bool + [arity' bodyA predictionA] (recur (inc arity) nest?')] + (wrap [arity' + (#analysisL.Function (list) bodyA) + predictionA])) + (do r.Monad + [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] + (wrap [arity + (#analysisL.Reference (///reference.local chosen)) + (|> chosen (n/+ (dec arity)) #///reference.Local)]))))) + +(context: "Function definition." + (<| (seed +13007429814532219492) + ## (times +100) + (do @ + [[arity//constant function//constant prediction//constant] constant-function + [arity//environment function//environment prediction//environment] function-with-environment + [arity//local function//local prediction//local] local-function] + ($_ seq + (test "Nested functions will get folded together." + (|> function//constant + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity output]))) + (and (n/= arity//constant arity) + (//primitive.corresponds? prediction//constant output)) + + _ + (n/= +0 arity//constant)))) + (test "Folded functions provide direct access to environment variables." + (|> function//environment + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) + (and (n/= arity//environment arity) + (variable/= prediction//environment output)) + + _ + false))) + (test "Folded functions properly offset local variables." + (|> function//local + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) + (and (n/= arity//local arity) + (variable/= prediction//local output)) + + _ + false))) + )))) + +(context: "Function application." + (<| (times +100) + (do @ + [arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1)))) + funcA //primitive.primitive + argsA (r.list arity //primitive.primitive)] + ($_ seq + (test "Can synthesize function application." + (|> (analysisL.apply [funcA argsA]) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (^ (#error.Success (//.function/apply [funcS argsS]))) + (and (//primitive.corresponds? funcA funcS) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 argsA argsS))) + + _ + false))) + (test "Function application on no arguments just synthesizes to the function itself." + (|> (analysisL.apply [funcA (list)]) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success funcS) + (//primitive.corresponds? funcA funcS) + + _ + false))) + )))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux b/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux new file mode 100644 index 000000000..1c8368204 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/synthesis/primitive.lux @@ -0,0 +1,92 @@ +(.module: + [lux #- primitive] + (lux [io] + (control [monad #+ do] + pipe) + (data [error] + text/format) + [lang] + (lang [".L" extension] + ["///." compiler] + [".L" analysis #+ Analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression])) + ["r" math/random] + test)) + +(def: #export primitive + (r.Random Analysis) + (do r.Monad + [primitive (: (r.Random analysisL.Primitive) + ($_ r.alt + (wrap []) + r.bool + r.nat + r.int + r.deg + r.frac + (r.unicode +5)))] + (wrap (#analysisL.Primitive primitive)))) + +(def: #export (corresponds? analysis synthesis) + (-> Analysis Synthesis Bool) + (case [synthesis analysis] + [(#//.Primitive (#//.Text valueS)) + (#analysisL.Primitive (#analysisL.Unit valueA))] + (is? valueS (:! Text valueA)) + + [(#//.Primitive (#//.Bool valueS)) + (#analysisL.Primitive (#analysisL.Bool valueA))] + (is? valueS valueA) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Nat valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Int valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.I64 valueS)) + (#analysisL.Primitive (#analysisL.Deg valueA))] + (is? valueS (.i64 valueA)) + + [(#//.Primitive (#//.F64 valueS)) + (#analysisL.Primitive (#analysisL.Frac valueA))] + (is? valueS valueA) + + [(#//.Primitive (#//.Text valueS)) + (#analysisL.Primitive (#analysisL.Text valueA))] + (is? valueS valueA) + + _ + false)) + +(context: "Primitives." + (<| (times +100) + (do @ + [%bool% r.bool + %nat% r.nat + %int% r.int + %deg% r.deg + %frac% r.frac + %text% (r.unicode +5)] + (`` ($_ seq + (~~ (do-template [ ] + [(test (format "Can synthesize " ".") + (|> (#analysisL.Primitive ( )) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Primitive ( value))) + (is? value) + + _ + false)))] + + ["unit" #analysisL.Unit #//.Text //.unit] + ["bool" #analysisL.Bool #//.Bool %bool%] + ["nat" #analysisL.Nat #//.I64 (.i64 %nat%)] + ["int" #analysisL.Int #//.I64 (.i64 %int%)] + ["deg" #analysisL.Deg #//.I64 (.i64 %deg%)] + ["frac" #analysisL.Frac #//.F64 %frac%] + ["text" #analysisL.Text #//.Text %text%]))))))) diff --git a/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux new file mode 100644 index 000000000..e61386044 --- /dev/null +++ b/stdlib/test/test/lux/lang/compiler/synthesis/structure.lux @@ -0,0 +1,57 @@ +(.module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data [bool "bool/" Eq] + [product] + [error] + (coll [list])) + (lang ["///." compiler] + [".L" analysis] + ["//" synthesis #+ Synthesis] + (synthesis [".S" expression]) + [".L" extension]) + ["r" math/random "r/" Monad] + test) + [//primitive]) + +(context: "Variants" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/+ +2)))) + tagA (|> r.nat (:: @ map (n/% size))) + memberA //primitive.primitive] + ($_ seq + (test "Can synthesize variants." + (|> (analysisL.sum-analysis size tagA memberA) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS]))) + (let [tagS (if right?S (inc leftsS) leftsS)] + (and (n/= tagA tagS) + (|> tagS (n/= (dec size)) (bool/= right?S)) + (//primitive.corresponds? memberA valueS))) + + _ + false))) + )))) + +(context: "Tuples" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + membersA (r.list size //primitive.primitive)] + ($_ seq + (test "Can synthesize tuple." + (|> (analysisL.product-analysis membersA) + (expressionS.synthesizer extensionL.empty) + (///compiler.run //.init) + (case> (#error.Success (#//.Structure (#//.Tuple membersS))) + (and (n/= size (list.size membersS)) + (list.every? (product.uncurry //primitive.corresponds?) + (list.zip2 membersA membersS))) + + _ + false))) + )))) diff --git a/stdlib/test/test/lux/lang/synthesis/case.lux b/stdlib/test/test/lux/lang/synthesis/case.lux deleted file mode 100644 index 228ed2920..000000000 --- a/stdlib/test/test/lux/lang/synthesis/case.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - pipe) - (data [error "error/" Functor]) - (lang ["///." reference] - ["///." compiler] - [".L" analysis #+ Branch Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random "r/" Monad] - test) - [//primitive]) - -(context: "Dummy variables." - (<| (times +100) - (do @ - [maskedA //primitive.primitive - temp (|> r.nat (:: @ map (n/% +100))) - #let [maskA (analysisL.control/case - [maskedA - [[(#analysisL.Bind temp) - (#analysisL.Reference (///reference.local temp))] - (list)]])]] - (test "Dummy variables created to mask expressions get eliminated during synthesis." - (|> maskA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (error/map (//primitive.corresponds? maskedA)) - (error.default false)))))) - -(context: "Let expressions." - (<| (times +100) - (do @ - [registerA r.nat - inputA //primitive.primitive - outputA //primitive.primitive - #let [letA (analysisL.control/case - [inputA - [[(#analysisL.Bind registerA) - outputA] - (list)]])]] - (test "Can detect and reify simple 'let' expressions." - (|> letA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.branch/let [inputS registerS outputS]))) - (and (n/= registerA registerS) - (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? outputA outputS)) - - _ - false)))))) - -(context: "If expressions." - (<| (times +100) - (do @ - [then|else r.bool - inputA //primitive.primitive - thenA //primitive.primitive - elseA //primitive.primitive - #let [thenB (: Branch - [(#analysisL.Simple (#analysisL.Bool true)) - thenA]) - elseB (: Branch - [(#analysisL.Simple (#analysisL.Bool false)) - elseA]) - ifA (if then|else - (analysisL.control/case [inputA [thenB (list elseB)]]) - (analysisL.control/case [inputA [elseB (list thenB)]]))]] - (test "Can detect and reify simple 'if' expressions." - (|> ifA - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.branch/if [inputS thenS elseS]))) - (and (//primitive.corresponds? inputA inputS) - (//primitive.corresponds? thenA thenS) - (//primitive.corresponds? elseA elseS)) - - _ - false)))))) diff --git a/stdlib/test/test/lux/lang/synthesis/function.lux b/stdlib/test/test/lux/lang/synthesis/function.lux deleted file mode 100644 index c7b16de27..000000000 --- a/stdlib/test/test/lux/lang/synthesis/function.lux +++ /dev/null @@ -1,168 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [product] - [maybe] - [error] - [number] - text/format - (coll [list "list/" Functor Fold] - (dictionary ["dict" unordered #+ Dict]) - (set ["set" unordered]))) - (lang ["///." reference #+ Variable "variable/" Equality] - ["///." compiler] - [".L" analysis #+ Arity Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random] - test) - [//primitive]) - -(def: constant-function - (r.Random [Arity Analysis Analysis]) - (r.rec - (function (_ constant-function) - (do r.Monad - [function? r.bool] - (if function? - (do @ - [[arity bodyA predictionA] constant-function] - (wrap [(inc arity) - (#analysisL.Function (list) bodyA) - predictionA])) - (do @ - [predictionA //primitive.primitive] - (wrap [+0 predictionA predictionA]))))))) - -(def: (pick scope-size) - (-> Nat (r.Random Nat)) - (|> r.nat (:: r.Monad map (n/% scope-size)))) - -(def: function-with-environment - (r.Random [Arity Analysis Variable]) - (do r.Monad - [num-locals (|> r.nat (:: @ map (|>> (n/% +100) (n/max +10)))) - #let [indices (list.n/range +0 (dec num-locals)) - local-env (list/map (|>> #///reference.Local) indices) - foreign-env (list/map (|>> #///reference.Foreign) indices)] - [arity bodyA predictionA] (: (r.Random [Arity Analysis Variable]) - (loop [arity +1 - current-env foreign-env] - (let [current-env/size (list.size current-env) - resolver (list/fold (function (_ [idx var] resolver) - (dict.put idx var resolver)) - (: (Dict Nat Variable) - (dict.new number.Hash)) - (list.enumerate current-env))] - (do @ - [nest? r.bool] - (if nest? - (do @ - [num-picks (:: @ map (n/max +1) (pick (inc current-env/size))) - picks (|> (r.set number.Hash num-picks (pick current-env/size)) - (:: @ map set.to-list)) - [arity bodyA predictionA] (recur (inc arity) - (list/map (function (_ pick) - (maybe.assume (list.nth pick current-env))) - picks)) - #let [picked-env (list/map (|>> #///reference.Foreign) picks)]] - (wrap [arity - (#analysisL.Function picked-env bodyA) - predictionA])) - (do @ - [chosen (pick (list.size current-env))] - (wrap [arity - (#analysisL.Reference (///reference.foreign chosen)) - (maybe.assume (dict.get chosen resolver))])))))))] - (wrap [arity - (#analysisL.Function local-env bodyA) - predictionA]))) - -(def: local-function - (r.Random [Arity Analysis Variable]) - (loop [arity +0 - nest? true] - (if nest? - (do r.Monad - [nest?' r.bool - [arity' bodyA predictionA] (recur (inc arity) nest?')] - (wrap [arity' - (#analysisL.Function (list) bodyA) - predictionA])) - (do r.Monad - [chosen (|> r.nat (:: @ map (|>> (n/% +100) (n/max +2))))] - (wrap [arity - (#analysisL.Reference (///reference.local chosen)) - (|> chosen (n/+ (dec arity)) #///reference.Local)]))))) - -(context: "Function definition." - (<| (seed +13007429814532219492) - ## (times +100) - (do @ - [[arity//constant function//constant prediction//constant] constant-function - [arity//environment function//environment prediction//environment] function-with-environment - [arity//local function//local prediction//local] local-function] - ($_ seq - (test "Nested functions will get folded together." - (|> function//constant - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity output]))) - (and (n/= arity//constant arity) - (//primitive.corresponds? prediction//constant output)) - - _ - (n/= +0 arity//constant)))) - (test "Folded functions provide direct access to environment variables." - (|> function//environment - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) - (and (n/= arity//environment arity) - (variable/= prediction//environment output)) - - _ - false))) - (test "Folded functions properly offset local variables." - (|> function//local - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/abstraction [environment arity (#//.Reference (///reference.variable output))]))) - (and (n/= arity//local arity) - (variable/= prediction//local output)) - - _ - false))) - )))) - -(context: "Function application." - (<| (times +100) - (do @ - [arity (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1)))) - funcA //primitive.primitive - argsA (r.list arity //primitive.primitive)] - ($_ seq - (test "Can synthesize function application." - (|> (analysisL.apply [funcA argsA]) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (^ (#error.Success (//.function/apply [funcS argsS]))) - (and (//primitive.corresponds? funcA funcS) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 argsA argsS))) - - _ - false))) - (test "Function application on no arguments just synthesizes to the function itself." - (|> (analysisL.apply [funcA (list)]) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success funcS) - (//primitive.corresponds? funcA funcS) - - _ - false))) - )))) diff --git a/stdlib/test/test/lux/lang/synthesis/primitive.lux b/stdlib/test/test/lux/lang/synthesis/primitive.lux deleted file mode 100644 index 1c8368204..000000000 --- a/stdlib/test/test/lux/lang/synthesis/primitive.lux +++ /dev/null @@ -1,92 +0,0 @@ -(.module: - [lux #- primitive] - (lux [io] - (control [monad #+ do] - pipe) - (data [error] - text/format) - [lang] - (lang [".L" extension] - ["///." compiler] - [".L" analysis #+ Analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression])) - ["r" math/random] - test)) - -(def: #export primitive - (r.Random Analysis) - (do r.Monad - [primitive (: (r.Random analysisL.Primitive) - ($_ r.alt - (wrap []) - r.bool - r.nat - r.int - r.deg - r.frac - (r.unicode +5)))] - (wrap (#analysisL.Primitive primitive)))) - -(def: #export (corresponds? analysis synthesis) - (-> Analysis Synthesis Bool) - (case [synthesis analysis] - [(#//.Primitive (#//.Text valueS)) - (#analysisL.Primitive (#analysisL.Unit valueA))] - (is? valueS (:! Text valueA)) - - [(#//.Primitive (#//.Bool valueS)) - (#analysisL.Primitive (#analysisL.Bool valueA))] - (is? valueS valueA) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Nat valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Int valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.I64 valueS)) - (#analysisL.Primitive (#analysisL.Deg valueA))] - (is? valueS (.i64 valueA)) - - [(#//.Primitive (#//.F64 valueS)) - (#analysisL.Primitive (#analysisL.Frac valueA))] - (is? valueS valueA) - - [(#//.Primitive (#//.Text valueS)) - (#analysisL.Primitive (#analysisL.Text valueA))] - (is? valueS valueA) - - _ - false)) - -(context: "Primitives." - (<| (times +100) - (do @ - [%bool% r.bool - %nat% r.nat - %int% r.int - %deg% r.deg - %frac% r.frac - %text% (r.unicode +5)] - (`` ($_ seq - (~~ (do-template [ ] - [(test (format "Can synthesize " ".") - (|> (#analysisL.Primitive ( )) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Primitive ( value))) - (is? value) - - _ - false)))] - - ["unit" #analysisL.Unit #//.Text //.unit] - ["bool" #analysisL.Bool #//.Bool %bool%] - ["nat" #analysisL.Nat #//.I64 (.i64 %nat%)] - ["int" #analysisL.Int #//.I64 (.i64 %int%)] - ["deg" #analysisL.Deg #//.I64 (.i64 %deg%)] - ["frac" #analysisL.Frac #//.F64 %frac%] - ["text" #analysisL.Text #//.Text %text%]))))))) diff --git a/stdlib/test/test/lux/lang/synthesis/structure.lux b/stdlib/test/test/lux/lang/synthesis/structure.lux deleted file mode 100644 index e61386044..000000000 --- a/stdlib/test/test/lux/lang/synthesis/structure.lux +++ /dev/null @@ -1,57 +0,0 @@ -(.module: - lux - (lux [io] - (control [monad #+ do] - pipe) - (data [bool "bool/" Eq] - [product] - [error] - (coll [list])) - (lang ["///." compiler] - [".L" analysis] - ["//" synthesis #+ Synthesis] - (synthesis [".S" expression]) - [".L" extension]) - ["r" math/random "r/" Monad] - test) - [//primitive]) - -(context: "Variants" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/+ +2)))) - tagA (|> r.nat (:: @ map (n/% size))) - memberA //primitive.primitive] - ($_ seq - (test "Can synthesize variants." - (|> (analysisL.sum-analysis size tagA memberA) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Structure (#//.Variant [leftsS right?S valueS]))) - (let [tagS (if right?S (inc leftsS) leftsS)] - (and (n/= tagA tagS) - (|> tagS (n/= (dec size)) (bool/= right?S)) - (//primitive.corresponds? memberA valueS))) - - _ - false))) - )))) - -(context: "Tuples" - (<| (times +100) - (do @ - [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) - membersA (r.list size //primitive.primitive)] - ($_ seq - (test "Can synthesize tuple." - (|> (analysisL.product-analysis membersA) - (expressionS.synthesizer extensionL.empty) - (///compiler.run //.init) - (case> (#error.Success (#//.Structure (#//.Tuple membersS))) - (and (n/= size (list.size membersS)) - (list.every? (product.uncurry //primitive.corresponds?) - (list.zip2 membersA membersS))) - - _ - false))) - )))) -- cgit v1.2.3