diff options
4 files changed, 65 insertions, 105 deletions
diff --git a/new-luxc/test/test/luxc/lang/analysis/function.lux b/new-luxc/test/test/luxc/lang/analysis/function.lux index 3f8a17505..62d5ad93c 100644 --- a/new-luxc/test/test/luxc/lang/analysis/function.lux +++ b/new-luxc/test/test/luxc/lang/analysis/function.lux @@ -52,13 +52,13 @@ [analysis (list)])) (def: (check-apply expectedT num-args analysis) - (-> Type Nat (Meta [Type la.Analysis]) Bool) + (-> Type Nat (Meta la.Analysis) Bool) (|> analysis + (&.with-type expectedT) (macro.run (init-compiler [])) - (case> (#e.Success [applyT applyA]) + (case> (#e.Success applyA) (let [[funcA argsA] (flatten-apply applyA)] - (and (type/= expectedT applyT) - (n/= num-args (list.size argsA)))) + (n/= num-args (list.size argsA))) (#e.Error error) false))) @@ -69,35 +69,30 @@ [func-name (r.text +5) arg-name (|> (r.text +5) (r.filter (|>> (text/= func-name) not))) [outputT outputC] gen-primitive - [inputT _] gen-primitive] + [inputT _] gen-primitive + #let [g!arg (code.local-symbol arg-name)]] ($_ seq (test "Can analyse function." - (|> (&.with-type (type (All [a] (-> a outputT))) - (@.analyse-function analyse func-name arg-name outputC)) - (macro.run (init-compiler [])) - succeeds?)) + (and (|> (&.with-type (All [a] (-> a outputT)) + (@.analyse-function analyse func-name arg-name outputC)) + (macro.run (init-compiler [])) + succeeds?) + (|> (&.with-type (All [a] (-> a a)) + (@.analyse-function analyse func-name arg-name g!arg)) + (macro.run (init-compiler [])) + succeeds?))) (test "Generic functions can always be specialized." (and (|> (&.with-type (-> inputT outputT) (@.analyse-function analyse func-name arg-name outputC)) (macro.run (init-compiler [])) succeeds?) (|> (&.with-type (-> inputT inputT) - (@.analyse-function analyse func-name arg-name (code.symbol ["" arg-name]))) + (@.analyse-function analyse func-name arg-name g!arg)) (macro.run (init-compiler [])) succeeds?))) - (test "Can infer function (constant output and unused input)." - (|> (@common.with-unknown-type - (@.analyse-function analyse func-name arg-name outputC)) - (macro.run (init-compiler [])) - (check-type (type (All [a] (-> a outputT)))))) - (test "Can infer function (output = input)." - (|> (@common.with-unknown-type - (@.analyse-function analyse func-name arg-name (code.symbol ["" arg-name]))) - (macro.run (init-compiler [])) - (check-type (type (All [a] (-> a a)))))) (test "The function's name is bound to the function's type." - (|> (&.with-type (type (Rec self (-> inputT self))) - (@.analyse-function analyse func-name arg-name (code.symbol ["" func-name]))) + (|> (&.with-type (Rec self (-> inputT self)) + (@.analyse-function analyse func-name arg-name (code.local-symbol func-name))) (macro.run (init-compiler [])) succeeds?)) )))) @@ -129,26 +124,18 @@ varT)]] ($_ seq (test "Can analyse monomorphic type application." - (|> (@common.with-unknown-type - (@.analyse-apply analyse funcT (' []) inputsC)) + (|> (@.analyse-apply analyse funcT (' []) inputsC) (check-apply outputT full-args))) (test "Can partially apply functions." - (|> (@common.with-unknown-type - (@.analyse-apply analyse funcT (' []) - (list.take partial-args inputsC))) + (|> (@.analyse-apply analyse funcT (' []) (list.take partial-args inputsC)) (check-apply partialT partial-args))) (test "Can apply polymorphic functions." - (|> (@common.with-unknown-type - (@.analyse-apply analyse polyT (' []) inputsC)) + (|> (@.analyse-apply analyse polyT (' []) inputsC) (check-apply poly-inputT full-args))) (test "Polymorphic partial application propagates found type-vars." - (|> (@common.with-unknown-type - (@.analyse-apply analyse polyT (' []) - (list.take (n/inc var-idx) inputsC))) + (|> (@.analyse-apply analyse polyT (' []) (list.take (n/inc var-idx) inputsC)) (check-apply partial-polyT1 (n/inc var-idx)))) (test "Polymorphic partial application preserves quantification for type-vars." - (|> (@common.with-unknown-type - (@.analyse-apply analyse polyT (' []) - (list.take var-idx inputsC))) + (|> (@.analyse-apply analyse polyT (' []) (list.take var-idx inputsC)) (check-apply partial-polyT2 var-idx))) )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux index bde0e0b60..9701a04b6 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux @@ -254,61 +254,34 @@ sizeC (|> r.nat (:: @ map code.nat)) idxC (|> r.nat (:: @ map code.nat)) var-name (r.text +5) - #let [arrayT (type (Array elemT))]] + #let [arrayT (type (Array elemT)) + g!array (code.local-symbol var-name) + array-operation (function [output-type code] + (|> (&scope.with-scope "" + (&scope.with-local [var-name arrayT] + (&.with-type output-type + (analyse code)))) + (macro.run (init-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." - (|> (&scope.with-scope "" - (&scope.with-local [var-name arrayT] - (&.with-type elemT - (analyse (` ("lux array get" - (~ (code.symbol ["" var-name])) - (~ idxC))))))) - (macro.run (init-compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) + (array-operation (type (Maybe elemT)) + (` ("lux array get" (~ g!array) (~ idxC))))) (test "Can put a value inside an array." - (|> (&scope.with-scope "" - (&scope.with-local [var-name arrayT] - (&.with-type arrayT - (analyse (` ("lux array put" - (~ (code.symbol ["" var-name])) - (~ idxC) - (~ elemC))))))) - (macro.run (init-compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) + (array-operation arrayT + (` ("lux array put" (~ g!array) (~ idxC) (~ elemC))))) (test "Can remove a value from an array." - (|> (&scope.with-scope "" - (&scope.with-local [var-name arrayT] - (&.with-type arrayT - (analyse (` ("lux array remove" - (~ (code.symbol ["" var-name])) - (~ idxC))))))) - (macro.run (init-compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) + (array-operation arrayT + (` ("lux array remove" (~ g!array) (~ idxC))))) (test "Can query the size of an array." - (|> (&scope.with-scope "" - (&scope.with-local [var-name arrayT] - (&.with-type Nat - (analyse (` ("lux array size" (~ (code.symbol ["" var-name])))))))) - (macro.run (init-compiler [])) - (case> (#e.Success _) - true - - (#e.Error _) - false))) + (array-operation Nat + (` ("lux array size" (~ g!array))))) )))) (context: "Math procedures" diff --git a/new-luxc/test/test/luxc/lang/analysis/structure.lux b/new-luxc/test/test/luxc/lang/analysis/structure.lux index 5694c0927..42177ebb4 100644 --- a/new-luxc/test/test/luxc/lang/analysis/structure.lux +++ b/new-luxc/test/test/luxc/lang/analysis/structure.lux @@ -185,15 +185,15 @@ true))) )))) -(def: (check-variant-inference variantT choice size analysis) - (-> Type Nat Nat (Meta [Module Scope Type la.Analysis]) Bool) +(def: (check-variant variantT choice size analysis) + (-> Type Nat Nat (Meta [Module Scope la.Analysis]) Bool) (|> analysis + (&.with-type variantT) (macro.run (init-compiler [])) - (case> (^multi (#e.Success [_ _ sumT sumA]) + (case> (^multi (#e.Success [_ _ sumA]) [(la.unfold-variant sumA) (#.Some [tag last? valueA])]) - (and (type/= variantT sumT) - (n/= tag choice) + (and (n/= tag choice) (bool/= last? (n/= (n/dec size) choice))) _ @@ -241,25 +241,22 @@ (do macro.Monad<Meta> [_ (@module.declare-tags tags false namedT)] (&.with-scope - (@common.with-unknown-type - (@.analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) - (check-variant-inference variantT choice size))) + (@.analyse-tagged-sum analyse [module-name choice-tag] choiceC)))) + (check-variant variantT choice size))) (test "Tagged sums specialize when type-vars get bound." (|> (@module.with-module +0 module-name (do macro.Monad<Meta> [_ (@module.declare-tags tags false named-polyT)] (&.with-scope - (@common.with-unknown-type - (@.analyse-tagged-sum analyse [module-name choice-tag] choiceC))))) - (check-variant-inference variantT choice size))) + (@.analyse-tagged-sum analyse [module-name choice-tag] choiceC)))) + (check-variant variantT choice size))) (test "Tagged sum inference retains universal quantification when type-vars are not bound." (|> (@module.with-module +0 module-name (do macro.Monad<Meta> [_ (@module.declare-tags tags false named-polyT)] (&.with-scope - (@common.with-unknown-type - (@.analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (check-variant-inference polyT other-choice size))) + (@.analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC)))) + (check-variant polyT other-choice size))) (test "Can specialize generic tagged sums." (|> (@module.with-module +0 module-name (do macro.Monad<Meta> diff --git a/new-luxc/test/test/luxc/lang/translation/jvm/case.lux b/new-luxc/test/test/luxc/lang/translation/jvm/case.lux index 91071be6c..2df52d78b 100644 --- a/new-luxc/test/test/luxc/lang/translation/jvm/case.lux +++ b/new-luxc/test/test/luxc/lang/translation/jvm/case.lux @@ -48,24 +48,27 @@ #let [caseS (` [(~+ (list.concat (list (list.repeat idx (' [])) (list subS) (list.repeat (|> size n/dec (n/- idx)) (' [])))))]) - caseP (if (tail? size idx) - (` ("lux case tuple right" (~ (code.nat idx)) (~ subP))) - (` ("lux case tuple left" (~ (code.nat idx)) (~ subP))))]] + caseP (` ("lux case seq" + (~ (if (tail? size idx) + (` ("lux case tuple right" (~ (code.nat idx)))) + (` ("lux case tuple left" (~ (code.nat idx)))))) + (~ subP)))]] (wrap [caseS caseP])) (do r.Monad<Random> [size (|> r.nat (:: @ map (|>> (n/% struct-limit) (n/max +2)))) idx (|> r.nat (:: @ map (n/% size))) [subS subP] gen-case #let [caseS (` ((~ (code.nat idx)) (~ (code.bool (tail? size idx))) (~ subS))) - caseP (if (tail? size idx) - (` ("lux case variant right" (~ (code.nat idx)) (~ subP))) - (` ("lux case variant left" (~ (code.nat idx)) (~ subP))))]] + caseP (` ("lux case seq" + (~ (if (tail? size idx) + (` ("lux case variant right" (~ (code.nat idx)))) + (` ("lux case variant left" (~ (code.nat idx)))))) + (~ subP)))]] (wrap [caseS caseP])) )))) (context: "Pattern-matching." - (<| (seed +517905247826) - ## (times +100) + (<| (times +100) (do @ [[valueS pathS] gen-case to-bind r.nat] |