diff options
Diffstat (limited to 'new-luxc/test')
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/case.lux | 10 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/function.lux | 8 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/procedure/common.lux | 14 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux | 2 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/analysis/structure.lux | 24 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/lang/syntax.lux | 233 | ||||
| -rw-r--r-- | new-luxc/test/tests.lux | 3 |
7 files changed, 30 insertions, 264 deletions
diff --git a/new-luxc/test/test/luxc/lang/analysis/case.lux b/new-luxc/test/test/luxc/lang/analysis/case.lux index ee8b9b74d..6d34ef4c5 100644 --- a/new-luxc/test/test/luxc/lang/analysis/case.lux +++ b/new-luxc/test/test/luxc/lang/analysis/case.lux @@ -169,7 +169,7 @@ ($_ seq (test "Will reject empty pattern-matching (no branches)." (|> (&;with-scope - (&;with-expected-type outputT + (&;with-type outputT (@;analyse-case analyse inputC (list)))) check-failure)) (test "Can analyse exhaustive pattern-matching." @@ -182,7 +182,7 @@ (#;Named [module-name record-name] (type;tuple primitivesT)))] (&;with-scope - (&;with-expected-type outputT + (&;with-type outputT (@;analyse-case analyse inputC exhaustive-branchesC))))) check-success)) (test "Will reject non-exhaustive pattern-matching." @@ -195,7 +195,7 @@ (#;Named [module-name record-name] (type;tuple primitivesT)))] (&;with-scope - (&;with-expected-type outputT + (&;with-type outputT (@;analyse-case analyse inputC non-exhaustive-branchesC))))) check-failure)) (test "Will reject redundant pattern-matching." @@ -208,7 +208,7 @@ (#;Named [module-name record-name] (type;tuple primitivesT)))] (&;with-scope - (&;with-expected-type outputT + (&;with-type outputT (@;analyse-case analyse inputC redundant-branchesC))))) check-failure)) (test "Will reject pattern-matching if the bodies of the branches do not all have the same type." @@ -221,7 +221,7 @@ (#;Named [module-name record-name] (type;tuple primitivesT)))] (&;with-scope - (&;with-expected-type outputT + (&;with-type outputT (@;analyse-case analyse inputC heterogeneous-branchesC))))) check-failure)) )))) diff --git a/new-luxc/test/test/luxc/lang/analysis/function.lux b/new-luxc/test/test/luxc/lang/analysis/function.lux index e08e7a9bd..6cddfebd2 100644 --- a/new-luxc/test/test/luxc/lang/analysis/function.lux +++ b/new-luxc/test/test/luxc/lang/analysis/function.lux @@ -72,16 +72,16 @@ [inputT _] gen-primitive] ($_ seq (test "Can analyse function." - (|> (&;with-expected-type (type (All [a] (-> a outputT))) + (|> (&;with-type (type (All [a] (-> a outputT))) (@;analyse-function analyse func-name arg-name outputC)) (meta;run (init-compiler [])) succeeds?)) (test "Generic functions can always be specialized." - (and (|> (&;with-expected-type (-> inputT outputT) + (and (|> (&;with-type (-> inputT outputT) (@;analyse-function analyse func-name arg-name outputC)) (meta;run (init-compiler [])) succeeds?) - (|> (&;with-expected-type (-> inputT inputT) + (|> (&;with-type (-> inputT inputT) (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) (meta;run (init-compiler [])) succeeds?))) @@ -96,7 +96,7 @@ (meta;run (init-compiler [])) (check-type (type (All [a] (-> a a)))))) (test "The function's name is bound to the function's type." - (|> (&;with-expected-type (type (Rec self (-> inputT self))) + (|> (&;with-type (type (Rec self (-> inputT self))) (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) (meta;run (init-compiler [])) succeeds?)) 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 dae39228f..3420ebb4d 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/common.lux @@ -28,7 +28,7 @@ [(def: (<name> procedure params output-type) (-> Text (List Code) Type Bool) (|> (&;with-scope - (&;with-expected-type output-type + (&;with-type output-type (@;analyse-procedure analyse evalL;eval procedure params))) (meta;run (init-compiler [])) (case> (#e;Success _) @@ -262,7 +262,7 @@ (test "Can get a value inside an array." (|> (&scope;with-scope "" (&scope;with-local [var-name arrayT] - (&;with-expected-type elemT + (&;with-type elemT (@;analyse-procedure analyse evalL;eval "lux array get" (list idxC (code;symbol ["" var-name])))))) @@ -275,7 +275,7 @@ (test "Can put a value inside an array." (|> (&scope;with-scope "" (&scope;with-local [var-name arrayT] - (&;with-expected-type arrayT + (&;with-type arrayT (@;analyse-procedure analyse evalL;eval "lux array put" (list idxC elemC @@ -289,7 +289,7 @@ (test "Can remove a value from an array." (|> (&scope;with-scope "" (&scope;with-local [var-name arrayT] - (&;with-expected-type arrayT + (&;with-type arrayT (@;analyse-procedure analyse evalL;eval "lux array remove" (list idxC (code;symbol ["" var-name])))))) @@ -302,7 +302,7 @@ (test "Can query the size of an array." (|> (&scope;with-scope "" (&scope;with-local [var-name arrayT] - (&;with-expected-type Nat + (&;with-type Nat (@;analyse-procedure analyse evalL;eval "lux array size" (list (code;symbol ["" var-name])))))) (meta;run (init-compiler [])) @@ -362,7 +362,7 @@ (test "Can read the value of an atomic reference." (|> (&scope;with-scope "" (&scope;with-local [var-name atomT] - (&;with-expected-type elemT + (&;with-type elemT (@;analyse-procedure analyse evalL;eval "lux atom read" (list (code;symbol ["" var-name])))))) (meta;run (init-compiler [])) @@ -374,7 +374,7 @@ (test "Can swap the value of an atomic reference." (|> (&scope;with-scope "" (&scope;with-local [var-name atomT] - (&;with-expected-type Bool + (&;with-type Bool (@;analyse-procedure analyse evalL;eval "lux atom compare-and-swap" (list elemC elemC diff --git a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux index 3d5da350a..783174777 100644 --- a/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/lang/analysis/procedure/host.jvm.lux @@ -36,7 +36,7 @@ (|> (do Monad<Meta> [runtime-bytecode @runtime;translate] (&;with-scope - (&;with-expected-type output-type + (&;with-type output-type (@;analyse-procedure analyse evalL;eval procedure params)))) (meta;run (init-compiler [])) (case> (#e;Success _) diff --git a/new-luxc/test/test/luxc/lang/analysis/structure.lux b/new-luxc/test/test/luxc/lang/analysis/structure.lux index b299872ca..8cc95fd88 100644 --- a/new-luxc/test/test/luxc/lang/analysis/structure.lux +++ b/new-luxc/test/test/luxc/lang/analysis/structure.lux @@ -45,7 +45,7 @@ ($_ seq (test "Can analyse sum." (|> (&;with-scope - (&;with-expected-type variantT + (&;with-type variantT (@;analyse-sum analyse choice valueC))) (meta;run (init-compiler [])) (case> (^multi (#e;Success [_ sumA]) @@ -62,7 +62,7 @@ [[_ varT] (&;with-type-env tc;var) _ (&;with-type-env (tc;check varT variantT))] - (&;with-expected-type varT + (&;with-type varT (@;analyse-sum analyse choice valueC)))) (meta;run (init-compiler [])) (case> (^multi (#e;Success [_ sumA]) @@ -77,7 +77,7 @@ (|> (&;with-scope (do meta;Monad<Meta> [[_ varT] (&;with-type-env tc;var)] - (&;with-expected-type varT + (&;with-type varT (@;analyse-sum analyse choice valueC)))) (meta;run (init-compiler [])) (case> (#e;Success _) @@ -87,7 +87,7 @@ true))) (test "Can analyse sum through existential quantification." (|> (&;with-scope - (&;with-expected-type (type;ex-q +1 +variantT) + (&;with-type (type;ex-q +1 +variantT) (@;analyse-sum analyse +choice +valueC))) (meta;run (init-compiler [])) (case> (#e;Success _) @@ -97,7 +97,7 @@ false))) (test "Can analyse sum through universal quantification." (|> (&;with-scope - (&;with-expected-type (type;univ-q +1 +variantT) + (&;with-type (type;univ-q +1 +variantT) (@;analyse-sum analyse +choice +valueC))) (meta;run (init-compiler [])) (case> (#e;Success _) @@ -121,7 +121,7 @@ +tupleT (type;tuple (list/map product;left +primitives))]] ($_ seq (test "Can analyse product." - (|> (&;with-expected-type (type;tuple (list/map product;left primitives)) + (|> (&;with-type (type;tuple (list/map product;left primitives)) (@;analyse-product analyse (list/map product;right primitives))) (meta;run (init-compiler [])) (case> (#e;Success tupleA) @@ -141,7 +141,7 @@ _ false))) (test "Can analyse pseudo-product (singleton tuple)" - (|> (&;with-expected-type singletonT + (|> (&;with-type singletonT (analyse (` [(~ singletonC)]))) (meta;run (init-compiler [])) (case> (#e;Success singletonA) @@ -155,7 +155,7 @@ [[_ varT] (&;with-type-env tc;var) _ (&;with-type-env (tc;check varT (type;tuple (list/map product;left primitives))))] - (&;with-expected-type varT + (&;with-type varT (@;analyse-product analyse (list/map product;right primitives))))) (meta;run (init-compiler [])) (case> (#e;Success [_ tupleA]) @@ -165,7 +165,7 @@ false))) (test "Can analyse product through existential quantification." (|> (&;with-scope - (&;with-expected-type (type;ex-q +1 +tupleT) + (&;with-type (type;ex-q +1 +tupleT) (@;analyse-product analyse (list/map product;right +primitives)))) (meta;run (init-compiler [])) (case> (#e;Success _) @@ -175,7 +175,7 @@ false))) (test "Cannot analyse product through universal quantification." (|> (&;with-scope - (&;with-expected-type (type;univ-q +1 +tupleT) + (&;with-type (type;univ-q +1 +tupleT) (@;analyse-product analyse (list/map product;right +primitives)))) (meta;run (init-compiler [])) (case> (#e;Success _) @@ -265,7 +265,7 @@ (do meta;Monad<Meta> [_ (@module;declare-tags tags false named-polyT)] (&;with-scope - (&;with-expected-type variantT + (&;with-type variantT (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) (meta;run (init-compiler [])) (case> (^multi (#e;Success [_ _ sumA]) @@ -321,7 +321,7 @@ (do meta;Monad<Meta> [_ (@module;declare-tags tags false named-polyT)] (&;with-scope - (&;with-expected-type tupleT + (&;with-type tupleT (@;analyse-record analyse recordC))))) (meta;run (init-compiler [])) (case> (^multi (#e;Success [_ _ productA]) diff --git a/new-luxc/test/test/luxc/lang/syntax.lux b/new-luxc/test/test/luxc/lang/syntax.lux deleted file mode 100644 index 0f2306eb1..000000000 --- a/new-luxc/test/test/luxc/lang/syntax.lux +++ /dev/null @@ -1,233 +0,0 @@ -(;module: - lux - (lux [io] - (control [monad #+ do]) - (data [number] - ["e" error] - [text] - (text format - ["l" lexer]) - (coll [list])) - ["r" math/random "r/" Monad<Random>] - (meta [code]) - test) - (luxc (lang ["&" syntax]))) - -(def: default-cursor - Cursor - {#;module "" - #;line +0 - #;column +0}) - -(def: ident-part^ - (r;Random Text) - (do r;Monad<Random> - [#let [digits "0123456789" - delimiters "()[]{}#;\"" - space "\t\v \n\r\f" - invalid-range (format digits delimiters space) - char-gen (|> r;nat - (r;filter (function [sample] - (not (text;contains? (text;from-code sample) - invalid-range)))))] - size (|> r;nat (:: @ map (|>. (n.% +20) (n.max +1))))] - (r;text' char-gen size))) - -(def: ident^ - (r;Random Ident) - (r;seq ident-part^ ident-part^)) - -(def: code^ - (r;Random Code) - (let [numeric^ (: (r;Random Code) - ($_ r;either - (|> r;bool (r/map (|>. #;Bool [default-cursor]))) - (|> r;nat (r/map (|>. #;Nat [default-cursor]))) - (|> r;int (r/map (|>. #;Int [default-cursor]))) - (|> r;deg (r/map (|>. #;Deg [default-cursor]))) - (|> r;frac (r/map (|>. #;Frac [default-cursor]))))) - textual^ (: (r;Random Code) - ($_ r;either - (do r;Monad<Random> - [size (|> r;nat (r/map (n.% +20)))] - (|> (r;text size) (r/map (|>. #;Text [default-cursor])))) - (|> ident^ (r/map (|>. #;Symbol [default-cursor]))) - (|> ident^ (r/map (|>. #;Tag [default-cursor]))))) - simple^ (: (r;Random Code) - ($_ r;either - numeric^ - textual^))] - (r;rec - (function [code^] - (let [multi^ (do r;Monad<Random> - [size (|> r;nat (r/map (n.% +3)))] - (r;list size code^)) - composite^ (: (r;Random Code) - ($_ r;either - (|> multi^ (r/map (|>. #;Form [default-cursor]))) - (|> multi^ (r/map (|>. #;Tuple [default-cursor]))) - (do r;Monad<Random> - [size (|> r;nat (r/map (n.% +3)))] - (|> (r;list size (r;seq code^ code^)) - (r/map (|>. #;Record [default-cursor]))))))] - (r;either simple^ - composite^)))))) - -(context: "Lux code syntax." - (<| (times +100) - (do @ - [sample code^ - other code^] - ($_ seq - (test "Can parse Lux code." - (case (&;parse "" [default-cursor +0 (code;to-text sample)]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq<Code> = parsed sample))) - (test "Can parse Lux multiple code nodes." - (case (&;parse "" [default-cursor +0 (format (code;to-text sample) " " - (code;to-text other))]) - (#e;Error error) - false - - (#e;Success [remaining =sample]) - (case (&;parse "" remaining) - (#e;Error error) - false - - (#e;Success [_ =other]) - (and (:: code;Eq<Code> = sample =sample) - (:: code;Eq<Code> = other =other))))) - )))) - -(def: nat-to-frac - (-> Nat Frac) - (|>. nat-to-int int-to-frac)) - -(context: "Frac special syntax." - (<| (times +100) - (do @ - [numerator (|> r;nat (:: @ map (|>. (n.% +100) nat-to-frac))) - denominator (|> r;nat (:: @ map (|>. (n.% +100) (n.max +1) nat-to-frac))) - signed? r;bool - #let [expected (|> numerator (f./ denominator) (f.* (if signed? -1.0 1.0)))]] - (test "Can parse frac ratio syntax." - (case (&;parse "" [default-cursor +0 - (format (if signed? "-" "") - (%i (frac-to-int numerator)) - "/" - (%i (frac-to-int denominator)))]) - (#e;Success [_ [_ (#;Frac actual)]]) - (f.= expected actual) - - _ - false) - )))) - -(context: "Nat special syntax." - (<| (times +100) - (do @ - [expected (|> r;nat (:: @ map (n.% +1_000)))] - (test "Can parse nat char syntax." - (case (&;parse "" [default-cursor +0 - (format "#" (%t (text;from-code expected)) "")]) - (#e;Success [_ [_ (#;Nat actual)]]) - (n.= expected actual) - - _ - false) - )))) - -(def: comment-text^ - (r;Random Text) - (let [char-gen (|> r;nat (r;filter (function [value] - (not (or (text;space? value) - (n.= (char "#") value) - (n.= (char "(") value) - (n.= (char ")") value))))))] - (do r;Monad<Random> - [size (|> r;nat (r/map (n.% +20)))] - (r;text' char-gen size)))) - -(def: comment^ - (r;Random Text) - (r;either (do r;Monad<Random> - [comment comment-text^] - (wrap (format "## " comment "\n"))) - (r;rec (function [nested^] - (do r;Monad<Random> - [comment (r;either comment-text^ - nested^)] - (wrap (format "#( " comment " )#"))))))) - -(context: "Multi-line text & comments." - (<| (times +100) - (do @ - [#let [char-gen (|> r;nat (r;filter (function [value] - (not (or (text;space? value) - (n.= (char "\"") value))))))] - x char-gen - y char-gen - z char-gen - offset-size (|> r;nat (r/map (|>. (n.% +10) (n.max +1)))) - #let [offset (text;join-with "" (list;repeat offset-size " "))] - sample code^ - comment comment^ - unbalanced-comment comment-text^] - ($_ seq - (test "Will reject invalid multi-line text." - (let [bad-match (format (text;from-code x) "\n" - (text;from-code y) "\n" - (text;from-code z))] - (case (&;parse "" [default-cursor +0 - (format "\"" bad-match "\"")]) - (#e;Error error) - true - - (#e;Success [_ parsed]) - false))) - (test "Will accept valid multi-line text" - (let [good-input (format (text;from-code x) "\n" - offset (text;from-code y) "\n" - offset (text;from-code z)) - good-output (format (text;from-code x) "\n" - (text;from-code y) "\n" - (text;from-code z))] - (case (&;parse "" [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size)))) - +0 - (format "\"" good-input "\"")]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq<Code> = - parsed - (code;text good-output))))) - (test "Can handle comments." - (case (&;parse "" [default-cursor +0 - (format comment (code;to-text sample))]) - (#e;Error error) - false - - (#e;Success [_ parsed]) - (:: code;Eq<Code> = parsed sample))) - (test "Will reject unbalanced multi-line comments." - (and (case (&;parse "" [default-cursor +0 - (format "#(" "#(" unbalanced-comment ")#" - (code;to-text sample))]) - (#e;Error error) - true - - (#e;Success [_ parsed]) - false) - (case (&;parse "" [default-cursor +0 - (format "#(" unbalanced-comment ")#" ")#" - (code;to-text sample))]) - (#e;Error error) - true - - (#e;Success [_ parsed]) - false))) - )))) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 88d89ad90..b36782517 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -5,8 +5,7 @@ (concurrency [promise]) [cli #+ program:] [test]) - (test (luxc (lang ["_;L" syntax] - (analysis ["_;A" primitive] + (test (luxc (lang (analysis ["_;A" primitive] ["_;A" structure] ["_;A" reference] ["_;A" case] |