diff options
Diffstat (limited to '')
21 files changed, 909 insertions, 913 deletions
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux index 306618caf..7d580f3b4 100644 --- a/new-luxc/source/luxc/analyser/case.lux +++ b/new-luxc/source/luxc/analyser/case.lux @@ -55,7 +55,7 @@ (do Monad<Lux> [[ex-id exT] (&;within-type-env TC;existential)] - (simplify-case-type (assume (type;apply-type type exT)))) + (simplify-case-type (assume (type;apply (list exT) type)))) _ (:: Monad<Lux> wrap type))) diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux index 5144534fb..f1d7fdd31 100644 --- a/new-luxc/source/luxc/analyser/function.lux +++ b/new-luxc/source/luxc/analyser/function.lux @@ -25,26 +25,24 @@ (#;Named name unnamedT) (recur unnamedT) - (#;App funT argT) - (do @ - [fully-applied (case (type;apply-type funT argT) - (#;Some value) - (wrap value) + (#;Apply argT funT) + (case (type;apply (list argT) funT) + (#;Some value) + (recur value) - #;None - (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT))))] - (recur fully-applied)) + #;None + (&;fail (format "Cannot apply type " (%type funT) " to type " (%type argT)))) (#;UnivQ _) (do @ [[var-id var] (&;within-type-env TC;existential)] - (recur (assume (type;apply-type expected var)))) + (recur (assume (type;apply (list var) expected)))) (#;ExQ _) (&common;with-var (function [[var-id var]] - (recur (assume (type;apply-type expected var))))) + (recur (assume (type;apply (list var) expected))))) (#;Var id) (do @ diff --git a/new-luxc/source/luxc/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux index 11ec58eb3..8390a890c 100644 --- a/new-luxc/source/luxc/analyser/inference.lux +++ b/new-luxc/source/luxc/analyser/inference.lux @@ -31,7 +31,7 @@ ([#;Sum] [#;Product] [#;Function] - [#;App]) + [#;Apply]) (#;Var id) (if (n.= var-id id) @@ -74,7 +74,7 @@ (&common;with-var (function [[var-id varT]] (do Monad<Lux> - [[outputT argsA] (apply-function analyse (assume (type;apply-type funcT varT)) args)] + [[outputT argsA] (apply-function analyse (assume (type;apply (list varT) funcT)) args)] (do @ [? (&;within-type-env (TC;bound? var-id)) @@ -90,7 +90,7 @@ (do Monad<Lux> [[ex-id exT] (&;within-type-env TC;existential)] - (apply-function analyse (assume (type;apply-type funcT exT)) args)) + (apply-function analyse (assume (type;apply (list exT) funcT)) args)) ## Arguments are inferred back-to-front because, by convention, ## Lux functions take the most important arguments *last*, which diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux index 37266b2fe..267dfec84 100644 --- a/new-luxc/source/luxc/analyser/structure.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -68,13 +68,13 @@ (do @ [[var-id var] (&;within-type-env TC;existential)] - (&;with-expected-type (assume (type;apply-type expected var)) + (&;with-expected-type (assume (type;apply (list var) expected)) (analyse-sum analyse tag valueC))) (#;ExQ _) (&common;with-var (function [[var-id var]] - (&;with-expected-type (assume (type;apply-type expected var)) + (&;with-expected-type (assume (type;apply (list var) expected)) (analyse-sum analyse tag valueC)))) _ @@ -165,13 +165,13 @@ (do @ [[var-id var] (&;within-type-env TC;existential)] - (&;with-expected-type (assume (type;apply-type expected var)) + (&;with-expected-type (assume (type;apply (list var) expected)) (analyse-product analyse membersC))) (#;ExQ _) (&common;with-var (function [[var-id var]] - (&;with-expected-type (assume (type;apply-type expected var)) + (&;with-expected-type (assume (type;apply (list var) expected)) (analyse-product analyse membersC)))) _ diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux index d095023ff..b447dd7a8 100644 --- a/new-luxc/source/luxc/generator.lux +++ b/new-luxc/source/luxc/generator.lux @@ -112,18 +112,19 @@ (def: init-cursor Cursor ["" +0 +0]) -(def: init-type-context +(def: #export init-type-context Type-Context {#;ex-counter +0 #;var-counter +0 #;var-bindings (list)}) -(def: init-compiler-info +(def: #export init-compiler-info Compiler-Info - {#;compiler-version &;compiler-version + {#;compiler-name "Lux/JVM" + #;compiler-version &;compiler-version #;compiler-mode #;Build}) -(def: (init-compiler host) +(def: #export (init-compiler host) (-> &&common;Host Compiler) {#;info init-compiler-info #;source [init-cursor ""] diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux index 5cd6299fc..1e280e62b 100644 --- a/new-luxc/source/luxc/parser.lux +++ b/new-luxc/source/luxc/parser.lux @@ -27,20 +27,21 @@ (;module: lux - (lux (control monad) + (lux (control monad + ["p" parser "p/" Monad<Parser>]) (data [bool] [char] [text] ["R" result] [number] - (text ["l" lexer #+ Lexer Monad<Lexer> "l/" Monad<Lexer>] + (text ["l" lexer] format) [product] (coll [list "L/" Functor<List> Fold<List>] ["V" vector])))) (def: white-space Text "\t\v \r\f") -(def: new-line "\n") +(def: new-line Text "\n") ## This is the parser for white-space. ## Whenever a new-line is encountered, the column gets reset to 0, and @@ -48,12 +49,12 @@ ## It operates recursively in order to produce the longest continuous ## chunk of white-space. (def: (space^ where) - (-> Cursor (Lexer [Cursor Text])) - (do Monad<Lexer> - [head (l;some' (l;one-of white-space))] + (-> Cursor (l;Lexer [Cursor Text])) + (do p;Monad<Parser> + [head (l;some (l;one-of white-space))] ## New-lines must be handled as a separate case to ensure line ## information is handled properly. - (l;either (l;after (l;one-of new-line) + (p;either (p;after (l;one-of new-line) (do @ [[end tail] (space^ (|> where (update@ #;line n.inc) @@ -66,11 +67,11 @@ ## Single-line comments can start anywhere, but only go up to the ## next new-line. (def: (single-line-comment^ where) - (-> Cursor (Lexer [Cursor Text])) - (do Monad<Lexer> - [_ (l;text "##") - comment (l;some' (l;none-of new-line)) - _ (l;text new-line)] + (-> Cursor (l;Lexer [Cursor Text])) + (do p;Monad<Parser> + [_ (l;this "##") + comment (l;some (l;none-of new-line)) + _ (l;this new-line)] (wrap [(|> where (update@ #;line n.inc) (set@ #;column +0)) @@ -79,11 +80,11 @@ ## This is just a helper parser to find text which doesn't run into ## any special character sequences for multi-line comments. (def: comment-bound^ - (Lexer Text) - ($_ l;either - (l;text new-line) - (l;text ")#") - (l;text "#("))) + (l;Lexer Unit) + ($_ p;either + (l;this new-line) + (l;this ")#") + (l;this "#("))) ## Multi-line comments are bounded by #( these delimiters, #(and, they may ## also be nested)# )#. @@ -91,22 +92,22 @@ ## That is, any nested comment must have matched delimiters. ## Unbalanced comments ought to be rejected as invalid code. (def: (multi-line-comment^ where) - (-> Cursor (Lexer [Cursor Text])) - (do Monad<Lexer> - [_ (l;text "#(")] + (-> Cursor (l;Lexer [Cursor Text])) + (do p;Monad<Parser> + [_ (l;this "#(")] (loop [comment "" where (update@ #;column (n.+ +2) where)] - ($_ l;either + ($_ p;either ## These are normal chunks of commented text. (do @ - [chunk (l;many' (l;not comment-bound^))] + [chunk (l;many (l;not comment-bound^))] (recur (format comment chunk) (|> where (update@ #;column (n.+ (text;size chunk)))))) ## This is a special rule to handle new-lines within ## comments properly. (do @ - [_ (l;text new-line)] + [_ (l;this new-line)] (recur (format comment new-line) (|> where (update@ #;line n.inc) @@ -123,7 +124,7 @@ sub-where)) ## Finally, this is the rule for closing the comment. (do @ - [_ (l;text ")#")] + [_ (l;this ")#")] (wrap [(update@ #;column (n.+ +2) where) comment])) )))) @@ -135,8 +136,8 @@ ## from being used in any situation (alternatively, forcing one type ## of comment to be the only usable one). (def: (comment^ where) - (-> Cursor (Lexer [Cursor Text])) - (l;either (single-line-comment^ where) + (-> Cursor (l;Lexer [Cursor Text])) + (p;either (single-line-comment^ where) (multi-line-comment^ where))) ## To simplify parsing, I remove any left-padding that an Code token @@ -144,11 +145,11 @@ ## Left-padding is assumed to be either white-space or a comment. ## The cursor gets updated, but the padding gets ignored. (def: (left-padding^ where) - (-> Cursor (Lexer Cursor)) - (l;either (do Monad<Lexer> + (-> Cursor (l;Lexer Cursor)) + (p;either (do p;Monad<Parser> [[where comment] (comment^ where)] (left-padding^ where)) - (do Monad<Lexer> + (do p;Monad<Parser> [[where white-space] (space^ where)] (wrap where)) )) @@ -159,25 +160,25 @@ ## and 4 characters long (e.g. \u12aB). ## Escaped characters may show up in Char and Text literals. (def: escaped-char^ - (Lexer [Text Char]) - (l;after (l;char #"\\") - (do Monad<Lexer> + (l;Lexer [Text Char]) + (p;after (l;this "\\") + (do p;Monad<Parser> [code l;any] (case code ## Handle special cases. - #"t" (wrap ["\\t" #"\t"]) - #"v" (wrap ["\\v" #"\v"]) - #"b" (wrap ["\\b" #"\b"]) - #"n" (wrap ["\\n" #"\n"]) - #"r" (wrap ["\\r" #"\r"]) - #"f" (wrap ["\\f" #"\f"]) - #"\"" (wrap ["\\\"" #"\""]) - #"\\" (wrap ["\\\\" #"\\"]) + "t" (wrap ["\\t" #"\t"]) + "v" (wrap ["\\v" #"\v"]) + "b" (wrap ["\\b" #"\b"]) + "n" (wrap ["\\n" #"\n"]) + "r" (wrap ["\\r" #"\r"]) + "f" (wrap ["\\f" #"\f"]) + "\"" (wrap ["\\\"" #"\""]) + "\\" (wrap ["\\\\" #"\\"]) ## Handle unicode escapes. - #"u" - (do Monad<Lexer> - [code (l;between' +1 +4 l;hex-digit)] + "u" + (do p;Monad<Parser> + [code (l;between +1 +4 l;hex-digit)] (wrap (case (:: number;Hex@Codec<Text,Nat> decode (format "+" code)) (#;Right value) @@ -187,7 +188,7 @@ (undefined)))) _ - (l;fail (format "Invalid escaping syntax: " (%c code))))))) + (p;fail (format "Invalid escaping syntax: " (%t code))))))) ## A character can be either a normal glyph, or a escaped character. ## The reason why this parser returns both the Char and it's textual @@ -197,81 +198,75 @@ ## representation may be multi-glyph (e.g. \u1234, \n), in which case, ## the text that was parsed needs to be counted to update the cursor. (def: raw-char^ - (Lexer [Text Char]) - (l;either (do Monad<Lexer> + (l;Lexer [Text Char]) + (p;either (do p;Monad<Parser> [char (l;none-of "\\\"\n")] - (wrap [(char;as-text char) char])) + (wrap [char (|> char (text;nth +0) assume)])) escaped-char^)) ## These are very simple parsers that just cut chunks of text in ## specific shapes and then use decoders already present in the ## standard library to actually produce the values from the literals. (def: rich-digit - (Lexer Char) - (l;either l;digit - (l;char #"_"))) + (l;Lexer Text) + (p;either l;digit + (p;after (l;this "_") (p/wrap "")))) -(def: rich-digits - (Lexer Text) - (l;seq' (l/map char;as-text l;digit) - (l;some' rich-digit))) +(def: rich-digits^ + (l;Lexer Text) + (l;seq l;digit + (l;some rich-digit))) -(def: (without-separators raw) - (-> (Lexer Text) (Lexer Text)) - (do Monad<Lexer> - [input raw] - (wrap (text;replace-all "_" "" input)))) +(def: (marker^ token) + (-> Text (l;Lexer Text)) + (p;after (l;this token) (p/wrap token))) (do-template [<name> <tag> <lexer> <codec>] [(def: #export (<name> where) - (-> Cursor (Lexer [Cursor Code])) - (do Monad<Lexer> + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad<Parser> [chunk <lexer>] (case (:: <codec> decode chunk) (#;Left error) - (l;fail error) + (p;fail error) (#;Right value) (wrap [(update@ #;column (n.+ (text;size chunk)) where) [where (<tag> value)]]))))] [parse-bool #;Bool - (l;either (l;text "true") (l;text "false")) + (p;either (marker^ "true") (marker^ "false")) bool;Codec<Text,Bool>] [parse-nat #;Nat - (without-separators - (l;seq' (l;text "+") - rich-digits)) + (l;seq (l;one-of "+") + rich-digits^) number;Codec<Text,Nat>] [parse-int #;Int - (without-separators - (l;seq' (l;default "" (l;text "-")) - rich-digits)) + (l;seq (p;default "" (l;one-of "-")) + rich-digits^) number;Codec<Text,Int>] [parse-real #;Real - (without-separators - ($_ l;seq' - (l;default "" (l;text "-")) - rich-digits - (l;text ".") - rich-digits)) + ($_ l;seq + (p;default "" (l;one-of "-")) + rich-digits^ + (l;one-of ".") + rich-digits^) number;Codec<Text,Real>] [parse-deg #;Deg - (without-separators - (l;seq' (l;text ".") - rich-digits)) + (l;seq (l;one-of ".") + rich-digits^) number;Codec<Text,Deg>] ) ## This parser doesn't delegate the work of producing the value to a ## codec, since the raw-char^ parser already takes care of that magic. (def: #export (parse-char where) - (-> Cursor (Lexer [Cursor Code])) - (do Monad<Lexer> + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad<Parser> [[chunk value] (l;enclosed ["#\"" "\""] raw-char^)] (wrap [(update@ #;column (|>. ($_ n.+ +3 (text;size chunk))) where) @@ -280,11 +275,11 @@ ## This parser looks so complex because text in Lux can be multi-line ## and there are rules regarding how this is handled. (def: #export (parse-text where) - (-> Cursor (Lexer [Cursor Code])) - (do Monad<Lexer> + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad<Parser> [## Lux text "is delimited by double-quotes", as usual in most ## programming languages. - _ (l;text "\"") + _ (l;this "\"") ## I must know what column the text body starts at (which is ## always 1 column after the left-delimiting quote). ## This is important because, when procesing subsequent lines, @@ -293,7 +288,7 @@ ## This helps ensure that the formatting on the text in the ## source-code matches the formatting of the Text value. #let [offset-column (n.inc (get@ #;column where))] - [where' text-read] (: (Lexer [Cursor Text]) + [where' text-read] (: (l;Lexer [Cursor Text]) ## I must keep track of how much of the ## text body has been read, how far the ## cursor has progressed, and whether I'm @@ -303,7 +298,7 @@ where (|> where (update@ #;column n.inc)) must-have-offset? false] - (l;either (if must-have-offset? + (p;either (if must-have-offset? ## If I'm at the start of a ## new line, I must ensure the ## space-offset is at least @@ -311,7 +306,7 @@ ## the text's body's column, ## to ensure they are aligned. (do @ - [offset (l;many' (l;char #" ")) + [offset (l;many (l;one-of " ")) #let [offset-size (text;size offset)]] (if (n.>= offset-column offset-size) ## Any extra offset @@ -325,13 +320,13 @@ (|> where (update@ #;column (n.+ offset-size))) false) - (l;fail (format "Each line of a multi-line text must have an appropriate offset!\n" + (p;fail (format "Each line of a multi-line text must have an appropriate offset!\n" "Expected: " (%i (nat-to-int offset-column)) " columns.\n" " Actual: " (%i (nat-to-int offset-size)) " columns.\n")))) - ($_ l;either + ($_ p;either ## Normal text characters. (do @ - [normal (l;many' (l;none-of "\\\"\n"))] + [normal (l;many (l;none-of "\\\"\n"))] (recur (format text-read normal) (|> where (update@ #;column (n.+ (text;size normal)))) @@ -347,7 +342,7 @@ ## The text ends when it ## reaches the right-delimiter. (do @ - [_ (l;text "\"")] + [_ (l;this "\"")] (wrap [(update@ #;column n.inc where) text-read])))) ## If a new-line is @@ -356,7 +351,7 @@ ## the loop is alerted that the ## next line must have an offset. (do @ - [_ (l;text new-line)] + [_ (l;this new-line)] (recur (format text-read new-line) (|> where (update@ #;line n.inc) @@ -371,14 +366,14 @@ (do-template [<name> <tag> <open> <close>] [(def: (<name> where parse-ast) (-> Cursor - (-> Cursor (Lexer [Cursor Code])) - (Lexer [Cursor Code])) - (do Monad<Lexer> - [_ (l;text <open>) + (-> Cursor (l;Lexer [Cursor Code])) + (l;Lexer [Cursor Code])) + (do p;Monad<Parser> + [_ (l;this <open>) [where' elems] (loop [elems (: (V;Vector Code) V;empty) where where] - (l;either (do @ + (p;either (do @ [## Must update the cursor as I ## go along, to keep things accurate. [where' elem] (parse-ast where)] @@ -389,7 +384,7 @@ ## padding present before the ## end-delimiter. where' (left-padding^ where) - _ (l;text <close>)] + _ (l;this <close>)] (wrap [(update@ #;column n.inc where') (V;to-list elems)]))))] (wrap [where' @@ -410,21 +405,21 @@ ## macros. (def: (parse-record where parse-ast) (-> Cursor - (-> Cursor (Lexer [Cursor Code])) - (Lexer [Cursor Code])) - (do Monad<Lexer> - [_ (l;text "{") + (-> Cursor (l;Lexer [Cursor Code])) + (l;Lexer [Cursor Code])) + (do p;Monad<Parser> + [_ (l;this "{") [where' elems] (loop [elems (: (V;Vector [Code Code]) V;empty) where where] - (l;either (do @ + (p;either (do @ [[where' key] (parse-ast where) [where' val] (parse-ast where')] (recur (V;add [key val] elems) where')) (do @ [where' (left-padding^ where) - _ (l;text "}")] + _ (l;this "}")] (wrap [(update@ #;column n.inc where') (V;to-list elems)]))))] (wrap [where' @@ -453,38 +448,37 @@ ## Additionally, the first character in an identifier's part cannot be ## a digit, to avoid confusion with regards to numbers. (def: ident-part^ - (Lexer Text) - (do Monad<Lexer> + (l;Lexer Text) + (do p;Monad<Parser> [#let [digits "0123456789" delimiters (format "()[]{}#\"" identifier-separator) space (format white-space new-line) head-lexer (l;none-of (format digits delimiters space)) - tail-lexer (l;some' (l;none-of (format delimiters space)))] + tail-lexer (l;some (l;none-of (format delimiters space)))] head head-lexer tail tail-lexer] - (wrap (format (char;as-text head) - tail)))) + (wrap (format head tail)))) (def: ident^ - (Lexer [Ident Nat]) - ($_ l;either + (l;Lexer [Ident Nat]) + ($_ p;either ## When an identifier starts with 2 marks, it's module is ## taken to be the current-module being compiled at the moment. ## This can be useful when mentioning identifiers and tags ## inside quoted/templated code in macros. - (do Monad<Lexer> + (do p;Monad<Parser> [#let [current-module-mark (format identifier-separator identifier-separator)] - _ (l;text current-module-mark) + _ (l;this current-module-mark) def-name ident-part^] - (l;fail (format "Cannot handle " current-module-mark " syntax for identifiers."))) + (p;fail (format "Cannot handle " current-module-mark " syntax for identifiers."))) ## If the identifier is prefixed by the mark, but no module ## part, the module is assumed to be "lux" (otherwise known as ## the 'prelude'). ## This makes it easy to refer to definitions in that module, ## since it is the most fundamental module in the entire ## standard library. - (do Monad<Lexer> - [_ (l;text identifier-separator) + (do p;Monad<Parser> + [_ (l;this identifier-separator) def-name ident-part^] (wrap [["lux" def-name] (n.inc (text;size def-name))])) @@ -497,10 +491,10 @@ ## Function arguments and local-variables may not be referred-to ## using identifiers with module parts, so being able to specify ## identifiers with empty modules helps with those use-cases. - (do Monad<Lexer> + (do p;Monad<Parser> [first-part ident-part^] - (l;either (do @ - [_ (l;text identifier-separator) + (p;either (do @ + [_ (l;this identifier-separator) second-part ident-part^] (wrap [[first-part second-part] ($_ n.+ @@ -519,21 +513,21 @@ ## construction and de-structuring (during pattern-matching). (do-template [<name> <tag> <lexer> <extra>] [(def: #export (<name> where) - (-> Cursor (Lexer [Cursor Code])) - (do Monad<Lexer> + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad<Parser> [[value length] <lexer>] (wrap [(update@ #;column (|>. ($_ n.+ <extra> length)) where) [where (<tag> value)]])))] [parse-symbol #;Symbol ident^ +0] - [parse-tag #;Tag (l;after (l;char #"#") ident^) +1] + [parse-tag #;Tag (p;after (l;this "#") ident^) +1] ) (def: (parse-ast where) - (-> Cursor (Lexer [Cursor Code])) - (do Monad<Lexer> + (-> Cursor (l;Lexer [Cursor Code])) + (do p;Monad<Parser> [where (left-padding^ where)] - ($_ l;either + ($_ p;either (parse-form where parse-ast) (parse-tuple where parse-ast) (parse-record where parse-ast) @@ -550,7 +544,7 @@ (def: #export (parse [where code]) (-> [Cursor Text] (R;Result [[Cursor Text] Code])) - (case (l;run' code (parse-ast where)) + (case (p;run code (parse-ast where)) (#R;Error error) (#R;Error error) diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux index 3fe67b7a3..037f99feb 100644 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -120,7 +120,7 @@ (r/wrap (code;record (list;zip2 record-tags primitivesC))) )))) -(test: "Pattern-matching." +(context: "Pattern-matching." #seed +9253409297339902486 [module-name (r;text +5) variant-name (r;text +5) @@ -142,35 +142,35 @@ non-total-branchesC (list;take (n.dec (list;size total-branchesC)) total-branchesC)]] ($_ seq - (assert "Will reject empty pattern-matching (no branches)." - (|> (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC (list)))) - check-failure)) - (assert "Can analyse total pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC total-branchesC))))) - check-success)) - (assert "Will reject non-total pattern-matching." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@module;declare-tags variant-tags false - (#;Named [module-name variant-name] - (type;variant primitivesT))) - _ (@module;declare-tags record-tags false - (#;Named [module-name record-name] - (type;tuple primitivesT)))] - (&;with-scope - (&;with-expected-type outputT - (@;analyse-case analyse inputC non-total-branchesC))))) - check-failure)) + (test "Will reject empty pattern-matching (no branches)." + (|> (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC (list)))) + check-failure)) + (test "Can analyse total pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC total-branchesC))))) + check-success)) + (test "Will reject non-total pattern-matching." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags variant-tags false + (#;Named [module-name variant-name] + (type;variant primitivesT))) + _ (@module;declare-tags record-tags false + (#;Named [module-name record-name] + (type;tuple primitivesT)))] + (&;with-scope + (&;with-expected-type outputT + (@;analyse-case analyse inputC non-total-branchesC))))) + check-failure)) )) diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux index 4957bfe06..909fb9293 100644 --- a/new-luxc/test/test/luxc/analyser/function.lux +++ b/new-luxc/test/test/luxc/analyser/function.lux @@ -64,49 +64,49 @@ (#R;Error error) false))) -(test: "Function definition." +(context: "Function definition." [func-name (r;text +5) arg-name (|> (r;text +5) (r;filter (|>. (T/= func-name) not))) [outputT outputC] gen-primitive [inputT _] gen-primitive] ($_ seq - (assert "Can analyse function." - (|> (&;with-expected-type (type (All [a] (-> a outputT))) - (@;analyse-function analyse func-name arg-name outputC)) - (macro;run (init-compiler [])) - succeeds?)) - (assert "Generic functions can always be specialized." - (and (|> (&;with-expected-type (-> inputT outputT) - (@;analyse-function analyse func-name arg-name outputC)) - (macro;run (init-compiler [])) - succeeds?) - (|> (&;with-expected-type (-> inputT inputT) - (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) - (macro;run (init-compiler [])) - succeeds?))) - (assert "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)))))) - (assert "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)))))) - (assert "The function's name is bound to the function's type." - (|> (&;with-expected-type (type (Rec self (-> inputT self))) - (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (macro;run (init-compiler [])) - succeeds?)) - (assert "Can infer recursive types for functions." - (|> (@common;with-unknown-type - (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (macro;run (init-compiler [])) - (check-type (type (Rec self (All [a] (-> a self))))))) + (test "Can analyse function." + (|> (&;with-expected-type (type (All [a] (-> a outputT))) + (@;analyse-function analyse func-name arg-name outputC)) + (macro;run (init-compiler [])) + succeeds?)) + (test "Generic functions can always be specialized." + (and (|> (&;with-expected-type (-> inputT outputT) + (@;analyse-function analyse func-name arg-name outputC)) + (macro;run (init-compiler [])) + succeeds?) + (|> (&;with-expected-type (-> inputT inputT) + (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) + (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-expected-type (type (Rec self (-> inputT self))) + (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) + (macro;run (init-compiler [])) + succeeds?)) + (test "Can infer recursive types for functions." + (|> (@common;with-unknown-type + (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) + (macro;run (init-compiler [])) + (check-type (type (Rec self (All [a] (-> a self))))))) )) -(test: "Function application." +(context: "Function application." [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)))) @@ -130,27 +130,27 @@ (type;function (#;Cons varT partial-poly-inputsT)) varT)]] ($_ seq - (assert "Can analyse monomorphic type application." - (|> (@common;with-unknown-type - (@;analyse-apply analyse funcT (#la;Unit) inputsC)) - (check-apply outputT full-args))) - (assert "Can partially apply functions." - (|> (@common;with-unknown-type - (@;analyse-apply analyse funcT (#la;Unit) - (list;take partial-args inputsC))) - (check-apply partialT partial-args))) - (assert "Can apply polymorphic functions." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (#la;Unit) inputsC)) - (check-apply poly-inputT full-args))) - (assert "Polymorphic partial application propagates found type-vars." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (#la;Unit) - (list;take (n.inc var-idx) inputsC))) - (check-apply partial-polyT1 (n.inc var-idx)))) - (assert "Polymorphic partial application preserves quantification for type-vars." - (|> (@common;with-unknown-type - (@;analyse-apply analyse polyT (#la;Unit) - (list;take var-idx inputsC))) - (check-apply partial-polyT2 var-idx))) + (test "Can analyse monomorphic type application." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (#la;Unit) inputsC)) + (check-apply outputT full-args))) + (test "Can partially apply functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse funcT (#la;Unit) + (list;take partial-args inputsC))) + (check-apply partialT partial-args))) + (test "Can apply polymorphic functions." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (#la;Unit) inputsC)) + (check-apply poly-inputT full-args))) + (test "Polymorphic partial application propagates found type-vars." + (|> (@common;with-unknown-type + (@;analyse-apply analyse polyT (#la;Unit) + (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 (#la;Unit) + (list;take var-idx inputsC))) + (check-apply partial-polyT2 var-idx))) )) diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux index 5e4e318a5..545b4e0fd 100644 --- a/new-luxc/test/test/luxc/analyser/primitive.lux +++ b/new-luxc/test/test/luxc/analyser/primitive.lux @@ -27,7 +27,7 @@ (.. common) (test/luxc common)) -(test: "Primitives" +(context: "Primitives" [%bool% r;bool %nat% r;nat %int% r;int @@ -37,17 +37,17 @@ %text% (r;text +5)] (with-expansions [<tests> (do-template [<desc> <type> <tag> <value> <analyser>] - [(assert (format "Can analyse " <desc> ".") - (|> (@common;with-unknown-type - (<analyser> <value>)) - (macro;run (init-compiler [])) - (case> (#R;Success [_type (<tag> value)]) - (and (Type/= <type> _type) - (is <value> value)) + [(test (format "Can analyse " <desc> ".") + (|> (@common;with-unknown-type + (<analyser> <value>)) + (macro;run (init-compiler [])) + (case> (#R;Success [_type (<tag> value)]) + (and (Type/= <type> _type) + (is <value> value)) - _ - false)) - )] + _ + false)) + )] ["unit" Unit #~;Unit [] (function [value] @;analyse-unit)] ["bool" Bool #~;Bool %bool% @;analyse-bool] diff --git a/new-luxc/test/test/luxc/analyser/procedure/common.lux b/new-luxc/test/test/luxc/analyser/procedure/common.lux index 9ebcf6880..dd099829c 100644 --- a/new-luxc/test/test/luxc/analyser/procedure/common.lux +++ b/new-luxc/test/test/luxc/analyser/procedure/common.lux @@ -39,268 +39,268 @@ [check-failure+ false true] ) -(test: "Lux procedures" +(context: "Lux procedures" [[primT primC] gen-primitive [antiT antiC] (|> gen-primitive (r;filter (|>. product;left (Type/= primT) not)))] ($_ seq - (assert "Can test for reference equality." - (check-success+ "lux is" (list primC primC) Bool)) - (assert "Reference equality must be done with elements of the same type." - (check-failure+ "lux is" (list primC antiC) Bool)) - (assert "Can 'try' risky IO computations." - (check-success+ "lux try" - (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) - (type (Either Text primT)))) + (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)))) )) -(test: "Bit procedures" +(context: "Bit procedures" [subjectC (|> r;nat (:: @ map code;nat)) signedC (|> r;int (:: @ map code;int)) paramC (|> r;nat (:: @ map code;nat))] ($_ seq - (assert "Can count the number of 1 bits in a bit pattern." - (check-success+ "bit count" (list subjectC) Nat)) - (assert "Can perform bit 'and'." - (check-success+ "bit and" (list subjectC paramC) Nat)) - (assert "Can perform bit 'or'." - (check-success+ "bit or" (list subjectC paramC) Nat)) - (assert "Can perform bit 'xor'." - (check-success+ "bit xor" (list subjectC paramC) Nat)) - (assert "Can shift bit pattern to the left." - (check-success+ "bit shift-left" (list subjectC paramC) Nat)) - (assert "Can shift bit pattern to the right." - (check-success+ "bit unsigned-shift-right" (list subjectC paramC) Nat)) - (assert "Can shift signed bit pattern to the right." - (check-success+ "bit shift-right" (list signedC paramC) Int)) + (test "Can count the number of 1 bits in a bit pattern." + (check-success+ "bit count" (list subjectC) Nat)) + (test "Can perform bit 'and'." + (check-success+ "bit and" (list subjectC paramC) Nat)) + (test "Can perform bit 'or'." + (check-success+ "bit or" (list subjectC paramC) Nat)) + (test "Can perform bit 'xor'." + (check-success+ "bit xor" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the left." + (check-success+ "bit shift-left" (list subjectC paramC) Nat)) + (test "Can shift bit pattern to the right." + (check-success+ "bit unsigned-shift-right" (list subjectC paramC) Nat)) + (test "Can shift signed bit pattern to the right." + (check-success+ "bit shift-right" (list signedC paramC) Int)) )) -(test: "Nat procedures" +(context: "Nat procedures" [subjectC (|> r;nat (:: @ map code;nat)) paramC (|> r;nat (:: @ map code;nat))] ($_ seq - (assert "Can add natural numbers." - (check-success+ "nat +" (list subjectC paramC) Nat)) - (assert "Can subtract natural numbers." - (check-success+ "nat -" (list subjectC paramC) Nat)) - (assert "Can multiply natural numbers." - (check-success+ "nat *" (list subjectC paramC) Nat)) - (assert "Can divide natural numbers." - (check-success+ "nat /" (list subjectC paramC) Nat)) - (assert "Can calculate remainder of natural numbers." - (check-success+ "nat %" (list subjectC paramC) Nat)) - (assert "Can test equality of natural numbers." - (check-success+ "nat =" (list subjectC paramC) Bool)) - (assert "Can compare natural numbers." - (check-success+ "nat <" (list subjectC paramC) Bool)) - (assert "Can obtain minimum natural number." - (check-success+ "nat min" (list) Nat)) - (assert "Can obtain maximum natural number." - (check-success+ "nat max" (list) Nat)) - (assert "Can convert natural number to integer." - (check-success+ "nat to-int" (list subjectC) Int)) - (assert "Can convert natural number to text." - (check-success+ "nat to-text" (list subjectC) Text)) + (test "Can add natural numbers." + (check-success+ "nat +" (list subjectC paramC) Nat)) + (test "Can subtract natural numbers." + (check-success+ "nat -" (list subjectC paramC) Nat)) + (test "Can multiply natural numbers." + (check-success+ "nat *" (list subjectC paramC) Nat)) + (test "Can divide natural numbers." + (check-success+ "nat /" (list subjectC paramC) Nat)) + (test "Can calculate remainder of natural numbers." + (check-success+ "nat %" (list subjectC paramC) Nat)) + (test "Can test equality of natural numbers." + (check-success+ "nat =" (list subjectC paramC) Bool)) + (test "Can compare natural numbers." + (check-success+ "nat <" (list subjectC paramC) Bool)) + (test "Can obtain minimum natural number." + (check-success+ "nat min" (list) Nat)) + (test "Can obtain maximum natural number." + (check-success+ "nat max" (list) Nat)) + (test "Can convert natural number to integer." + (check-success+ "nat to-int" (list subjectC) Int)) + (test "Can convert natural number to text." + (check-success+ "nat to-text" (list subjectC) Text)) )) -(test: "Int procedures" +(context: "Int procedures" [subjectC (|> r;int (:: @ map code;int)) paramC (|> r;int (:: @ map code;int))] ($_ seq - (assert "Can add integers." - (check-success+ "int +" (list subjectC paramC) Int)) - (assert "Can subtract integers." - (check-success+ "int -" (list subjectC paramC) Int)) - (assert "Can multiply integers." - (check-success+ "int *" (list subjectC paramC) Int)) - (assert "Can divide integers." - (check-success+ "int /" (list subjectC paramC) Int)) - (assert "Can calculate remainder of integers." - (check-success+ "int %" (list subjectC paramC) Int)) - (assert "Can test equality of integers." - (check-success+ "int =" (list subjectC paramC) Bool)) - (assert "Can compare integers." - (check-success+ "int <" (list subjectC paramC) Bool)) - (assert "Can obtain minimum integer." - (check-success+ "int min" (list) Int)) - (assert "Can obtain maximum integer." - (check-success+ "int max" (list) Int)) - (assert "Can convert integer to natural number." - (check-success+ "int to-nat" (list subjectC) Nat)) - (assert "Can convert integer to real number." - (check-success+ "int to-real" (list subjectC) Real)) + (test "Can add integers." + (check-success+ "int +" (list subjectC paramC) Int)) + (test "Can subtract integers." + (check-success+ "int -" (list subjectC paramC) Int)) + (test "Can multiply integers." + (check-success+ "int *" (list subjectC paramC) Int)) + (test "Can divide integers." + (check-success+ "int /" (list subjectC paramC) Int)) + (test "Can calculate remainder of integers." + (check-success+ "int %" (list subjectC paramC) Int)) + (test "Can test equality of integers." + (check-success+ "int =" (list subjectC paramC) Bool)) + (test "Can compare integers." + (check-success+ "int <" (list subjectC paramC) Bool)) + (test "Can obtain minimum integer." + (check-success+ "int min" (list) Int)) + (test "Can obtain maximum integer." + (check-success+ "int max" (list) Int)) + (test "Can convert integer to natural number." + (check-success+ "int to-nat" (list subjectC) Nat)) + (test "Can convert integer to real number." + (check-success+ "int to-real" (list subjectC) Real)) )) -(test: "Deg procedures" +(context: "Deg procedures" [subjectC (|> r;deg (:: @ map code;deg)) paramC (|> r;deg (:: @ map code;deg)) natC (|> r;nat (:: @ map code;nat))] ($_ seq - (assert "Can add degrees." - (check-success+ "deg +" (list subjectC paramC) Deg)) - (assert "Can subtract degrees." - (check-success+ "deg -" (list subjectC paramC) Deg)) - (assert "Can multiply degrees." - (check-success+ "deg *" (list subjectC paramC) Deg)) - (assert "Can divide degrees." - (check-success+ "deg /" (list subjectC paramC) Deg)) - (assert "Can calculate remainder of degrees." - (check-success+ "deg %" (list subjectC paramC) Deg)) - (assert "Can test equality of degrees." - (check-success+ "deg =" (list subjectC paramC) Bool)) - (assert "Can compare degrees." - (check-success+ "deg <" (list subjectC paramC) Bool)) - (assert "Can obtain minimum degree." - (check-success+ "deg min" (list) Deg)) - (assert "Can obtain maximum degree." - (check-success+ "deg max" (list) Deg)) - (assert "Can convert degree to real number." - (check-success+ "deg to-real" (list subjectC) Real)) - (assert "Can scale degree." - (check-success+ "deg scale" (list subjectC natC) Deg)) - (assert "Can calculate the reciprocal of a natural number." - (check-success+ "deg reciprocal" (list natC) Deg)) + (test "Can add degrees." + (check-success+ "deg +" (list subjectC paramC) Deg)) + (test "Can subtract degrees." + (check-success+ "deg -" (list subjectC paramC) Deg)) + (test "Can multiply degrees." + (check-success+ "deg *" (list subjectC paramC) Deg)) + (test "Can divide degrees." + (check-success+ "deg /" (list subjectC paramC) Deg)) + (test "Can calculate remainder of degrees." + (check-success+ "deg %" (list subjectC paramC) Deg)) + (test "Can test equality of degrees." + (check-success+ "deg =" (list subjectC paramC) Bool)) + (test "Can compare degrees." + (check-success+ "deg <" (list subjectC paramC) Bool)) + (test "Can obtain minimum degree." + (check-success+ "deg min" (list) Deg)) + (test "Can obtain maximum degree." + (check-success+ "deg max" (list) Deg)) + (test "Can convert degree to real number." + (check-success+ "deg to-real" (list subjectC) Real)) + (test "Can scale degree." + (check-success+ "deg scale" (list subjectC natC) Deg)) + (test "Can calculate the reciprocal of a natural number." + (check-success+ "deg reciprocal" (list natC) Deg)) )) -(test: "Real procedures" +(context: "Real procedures" [subjectC (|> r;real (:: @ map code;real)) paramC (|> r;real (:: @ map code;real)) encodedC (|> (r;text +5) (:: @ map code;text))] ($_ seq - (assert "Can add real numbers." - (check-success+ "real +" (list subjectC paramC) Real)) - (assert "Can subtract real numbers." - (check-success+ "real -" (list subjectC paramC) Real)) - (assert "Can multiply real numbers." - (check-success+ "real *" (list subjectC paramC) Real)) - (assert "Can divide real numbers." - (check-success+ "real /" (list subjectC paramC) Real)) - (assert "Can calculate remainder of real numbers." - (check-success+ "real %" (list subjectC paramC) Real)) - (assert "Can test equality of real numbers." - (check-success+ "real =" (list subjectC paramC) Bool)) - (assert "Can compare real numbers." - (check-success+ "real <" (list subjectC paramC) Bool)) - (assert "Can obtain minimum real number." - (check-success+ "real min" (list) Real)) - (assert "Can obtain maximum real number." - (check-success+ "real max" (list) Real)) - (assert "Can obtain smallest real number." - (check-success+ "real smallest" (list) Real)) - (assert "Can obtain not-a-number." - (check-success+ "real not-a-number" (list) Real)) - (assert "Can obtain positive infinity." - (check-success+ "real positive-infinity" (list) Real)) - (assert "Can obtain negative infinity." - (check-success+ "real negative-infinity" (list) Real)) - (assert "Can convert real number to integer." - (check-success+ "real to-int" (list subjectC) Int)) - (assert "Can convert real number to degree." - (check-success+ "real to-deg" (list subjectC) Deg)) - (assert "Can convert real number to text." - (check-success+ "real to-text" (list subjectC) Text)) - (assert "Can convert text to real number." - (check-success+ "real from-text" (list encodedC) (type (Maybe Real)))) + (test "Can add real numbers." + (check-success+ "real +" (list subjectC paramC) Real)) + (test "Can subtract real numbers." + (check-success+ "real -" (list subjectC paramC) Real)) + (test "Can multiply real numbers." + (check-success+ "real *" (list subjectC paramC) Real)) + (test "Can divide real numbers." + (check-success+ "real /" (list subjectC paramC) Real)) + (test "Can calculate remainder of real numbers." + (check-success+ "real %" (list subjectC paramC) Real)) + (test "Can test equality of real numbers." + (check-success+ "real =" (list subjectC paramC) Bool)) + (test "Can compare real numbers." + (check-success+ "real <" (list subjectC paramC) Bool)) + (test "Can obtain minimum real number." + (check-success+ "real min" (list) Real)) + (test "Can obtain maximum real number." + (check-success+ "real max" (list) Real)) + (test "Can obtain smallest real number." + (check-success+ "real smallest" (list) Real)) + (test "Can obtain not-a-number." + (check-success+ "real not-a-number" (list) Real)) + (test "Can obtain positive infinity." + (check-success+ "real positive-infinity" (list) Real)) + (test "Can obtain negative infinity." + (check-success+ "real negative-infinity" (list) Real)) + (test "Can convert real number to integer." + (check-success+ "real to-int" (list subjectC) Int)) + (test "Can convert real number to degree." + (check-success+ "real to-deg" (list subjectC) Deg)) + (test "Can convert real number to text." + (check-success+ "real to-text" (list subjectC) Text)) + (test "Can convert text to real number." + (check-success+ "real from-text" (list encodedC) (type (Maybe Real)))) )) -(test: "Text procedures" +(context: "Text procedures" [subjectC (|> (r;text +5) (:: @ map code;text)) paramC (|> (r;text +5) (:: @ map code;text)) replacementC (|> (r;text +5) (:: @ map code;text)) fromC (|> r;nat (:: @ map code;nat)) toC (|> r;nat (:: @ map code;nat))] ($_ seq - (assert "Can test text equality." - (check-success+ "text =" (list subjectC paramC) Bool)) - (assert "Compare texts in lexicographical order." - (check-success+ "text <" (list subjectC paramC) Bool)) - (assert "Can prepend one text to another." - (check-success+ "text prepend" (list subjectC paramC) Text)) - (assert "Can find the index of a piece of text inside a larger one that (may) contain it." - (check-success+ "text index" (list subjectC paramC fromC) (type (Maybe Nat)))) - (assert "Can query the size/length of a text." - (check-success+ "text size" (list subjectC) Nat)) - (assert "Can calculate a hash code for text." - (check-success+ "text hash" (list subjectC) Nat)) - (assert "Can replace a text inside of a larger one (once)." - (check-success+ "text replace-once" (list subjectC paramC replacementC) Text)) - (assert "Can replace a text inside of a larger one (all times)." - (check-success+ "text replace-all" (list subjectC paramC replacementC) Text)) - (assert "Can obtain the character code of a text at a given index." - (check-success+ "text char" (list subjectC fromC) Nat)) - (assert "Can clip a piece of text between 2 indices." - (check-success+ "text clip" (list subjectC fromC toC) Text)) + (test "Can test text equality." + (check-success+ "text =" (list subjectC paramC) Bool)) + (test "Compare texts in lexicographical order." + (check-success+ "text <" (list subjectC paramC) Bool)) + (test "Can prepend one text to another." + (check-success+ "text prepend" (list subjectC paramC) Text)) + (test "Can find the index of a piece of text inside a larger one that (may) contain it." + (check-success+ "text index" (list subjectC paramC fromC) (type (Maybe Nat)))) + (test "Can query the size/length of a text." + (check-success+ "text size" (list subjectC) Nat)) + (test "Can calculate a hash code for text." + (check-success+ "text hash" (list subjectC) Nat)) + (test "Can replace a text inside of a larger one (once)." + (check-success+ "text replace-once" (list subjectC paramC replacementC) Text)) + (test "Can replace a text inside of a larger one (all times)." + (check-success+ "text replace-all" (list subjectC paramC replacementC) Text)) + (test "Can obtain the character code of a text at a given index." + (check-success+ "text char" (list subjectC fromC) Nat)) + (test "Can clip a piece of text between 2 indices." + (check-success+ "text clip" (list subjectC fromC toC) Text)) )) -(test: "Array procedures" +(context: "Array procedures" [[elemT elemC] gen-primitive sizeC (|> r;nat (:: @ map code;nat)) idxC (|> r;nat (:: @ map code;nat)) var-name (r;text +5) #let [arrayT (type (array;Array elemT))]] ($_ seq - (assert "Can create arrays." - (check-success+ "array new" (list sizeC) arrayT)) - (assert "Can get a value inside an array." - (|> (&env;with-scope "" - (&env;with-local [var-name arrayT] - (&;with-expected-type elemT - (@;analyse-procedure analyse "array get" - (list idxC - (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - true + (test "Can create arrays." + (check-success+ "array new" (list sizeC) arrayT)) + (test "Can get a value inside an array." + (|> (&env;with-scope "" + (&env;with-local [var-name arrayT] + (&;with-expected-type elemT + (@;analyse-procedure analyse "array get" + (list idxC + (code;symbol ["" var-name])))))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + true - (#R;Error _) - false))) - (assert "Can put a value inside an array." - (|> (&env;with-scope "" - (&env;with-local [var-name arrayT] - (&;with-expected-type arrayT - (@;analyse-procedure analyse "array put" - (list idxC - elemC - (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - true + (#R;Error _) + false))) + (test "Can put a value inside an array." + (|> (&env;with-scope "" + (&env;with-local [var-name arrayT] + (&;with-expected-type arrayT + (@;analyse-procedure analyse "array put" + (list idxC + elemC + (code;symbol ["" var-name])))))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + true - (#R;Error _) - false))) - (assert "Can remove a value from an array." - (|> (&env;with-scope "" - (&env;with-local [var-name arrayT] - (&;with-expected-type arrayT - (@;analyse-procedure analyse "array remove" - (list idxC - (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - true + (#R;Error _) + false))) + (test "Can remove a value from an array." + (|> (&env;with-scope "" + (&env;with-local [var-name arrayT] + (&;with-expected-type arrayT + (@;analyse-procedure analyse "array remove" + (list idxC + (code;symbol ["" var-name])))))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + true - (#R;Error _) - false))) - (assert "Can query the size of an array." - (|> (&env;with-scope "" - (&env;with-local [var-name arrayT] - (&;with-expected-type Nat - (@;analyse-procedure analyse "array size" - (list (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - true + (#R;Error _) + false))) + (test "Can query the size of an array." + (|> (&env;with-scope "" + (&env;with-local [var-name arrayT] + (&;with-expected-type Nat + (@;analyse-procedure analyse "array size" + (list (code;symbol ["" var-name])))))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + true - (#R;Error _) - false))) + (#R;Error _) + false))) )) -(test: "Math procedures" +(context: "Math procedures" [subjectC (|> r;real (:: @ map code;real)) paramC (|> r;real (:: @ map code;real))] (with-expansions [<unary> (do-template [<proc> <desc>] - [(assert (format "Can calculate " <desc> ".") - (check-success+ <proc> (list subjectC) Real))] + [(test (format "Can calculate " <desc> ".") + (check-success+ <proc> (list subjectC) Real))] ["math cos" "cosine"] ["math sin" "sine"] @@ -319,8 +319,8 @@ ["math floor" "floor"] ["math round" "rounding"]) <binary> (do-template [<proc> <desc>] - [(assert (format "Can calculate " <desc> ".") - (check-success+ <proc> (list subjectC paramC) Real))] + [(test (format "Can calculate " <desc> ".") + (check-success+ <proc> (list subjectC paramC) Real))] ["math atan2" "inverse/arc tangent (with 2 arguments)"] ["math pow" "power"])] @@ -328,70 +328,70 @@ <unary> <binary>))) -(test: "Atom procedures" +(context: "Atom procedures" [[elemT elemC] gen-primitive sizeC (|> r;nat (:: @ map code;nat)) idxC (|> r;nat (:: @ map code;nat)) var-name (r;text +5) #let [atomT (type (atom;Atom elemT))]] ($_ seq - (assert "Can create atomic reference." - (check-success+ "atom new" (list elemC) atomT)) - (assert "Can read the value of an atomic reference." - (|> (&env;with-scope "" - (&env;with-local [var-name atomT] - (&;with-expected-type elemT - (@;analyse-procedure analyse "atom read" - (list (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - true + (test "Can create atomic reference." + (check-success+ "atom new" (list elemC) atomT)) + (test "Can read the value of an atomic reference." + (|> (&env;with-scope "" + (&env;with-local [var-name atomT] + (&;with-expected-type elemT + (@;analyse-procedure analyse "atom read" + (list (code;symbol ["" var-name])))))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + true - (#R;Error _) - false))) - (assert "Can swap the value of an atomic reference." - (|> (&env;with-scope "" - (&env;with-local [var-name atomT] - (&;with-expected-type Bool - (@;analyse-procedure analyse "atom compare-and-swap" - (list elemC - elemC - (code;symbol ["" var-name])))))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - true + (#R;Error _) + false))) + (test "Can swap the value of an atomic reference." + (|> (&env;with-scope "" + (&env;with-local [var-name atomT] + (&;with-expected-type Bool + (@;analyse-procedure analyse "atom compare-and-swap" + (list elemC + elemC + (code;symbol ["" var-name])))))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + true - (#R;Error _) - false))) + (#R;Error _) + false))) )) -(test: "Process procedures" +(context: "Process procedures" [[primT primC] gen-primitive timeC (|> r;nat (:: @ map code;nat))] ($_ seq - (assert "Can query the level of concurrency." - (check-success+ "process concurrency-level" (list) Nat)) - (assert "Can run an IO computation concurrently." - (check-success+ "process future" - (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) - Unit)) - (assert "Can schedule an IO computation to run concurrently at some future time." - (check-success+ "process schedule" - (list timeC - (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) - Unit)) + (test "Can query the level of concurrency." + (check-success+ "process concurrency-level" (list) Nat)) + (test "Can run an IO computation concurrently." + (check-success+ "process future" + (list (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) + Unit)) + (test "Can schedule an IO computation to run concurrently at some future time." + (check-success+ "process schedule" + (list timeC + (` ((~' _lux_function) (~' _) (~' _) (~ primC)))) + Unit)) )) -(test: "IO procedures" +(context: "IO procedures" [logC (|> (r;text +5) (:: @ map code;text)) exitC (|> r;nat (:: @ map code;nat))] ($_ seq - (assert "Can log messages to standard output." - (check-success+ "io log" (list logC) Unit)) - (assert "Can log messages to standard output." - (check-success+ "io error" (list logC) Bottom)) - (assert "Can log messages to standard output." - (check-success+ "io exit" (list exitC) Bottom)) - (assert "Can query the current time (as milliseconds since epoch)." - (check-success+ "io current-time" (list) Int)) + (test "Can log messages to standard output." + (check-success+ "io log" (list logC) Unit)) + (test "Can log messages to standard output." + (check-success+ "io error" (list logC) Bottom)) + (test "Can log messages to standard output." + (check-success+ "io exit" (list exitC) Bottom)) + (test "Can query the current time (as milliseconds since epoch)." + (check-success+ "io current-time" (list) Int)) )) diff --git a/new-luxc/test/test/luxc/analyser/reference.lux b/new-luxc/test/test/luxc/analyser/reference.lux index 5e277b2a6..33d93e415 100644 --- a/new-luxc/test/test/luxc/analyser/reference.lux +++ b/new-luxc/test/test/luxc/analyser/reference.lux @@ -17,34 +17,34 @@ (.. common) (test/luxc common)) -(test: "References" +(context: "References" [[ref-type _] gen-primitive module-name (r;text +5) scope-name (r;text +5) var-name (r;text +5)] ($_ seq - (assert "Can analyse relative reference." - (|> (&env;with-scope scope-name - (&env;with-local [var-name ref-type] - (@common;with-unknown-type - (@;analyse-reference ["" var-name])))) - (macro;run (init-compiler [])) - (case> (#R;Success [_type (#~;Relative idx)]) - (Type/= ref-type _type) - - _ - false))) - (assert "Can analyse absolute reference." - (|> (do Monad<Lux> - [_ (&module;create +0 module-name) - _ (&module;define [module-name var-name] - [ref-type (list) (:! Void [])])] + (test "Can analyse relative reference." + (|> (&env;with-scope scope-name + (&env;with-local [var-name ref-type] (@common;with-unknown-type - (@;analyse-reference [module-name var-name]))) - (macro;run (init-compiler [])) - (case> (#R;Success [_type (#~;Absolute idx)]) - (Type/= ref-type _type) + (@;analyse-reference ["" var-name])))) + (macro;run (init-compiler [])) + (case> (#R;Success [_type (#~;Relative idx)]) + (Type/= ref-type _type) + + _ + false))) + (test "Can analyse absolute reference." + (|> (do Monad<Lux> + [_ (&module;create +0 module-name) + _ (&module;define [module-name var-name] + [ref-type (list) (:! Void [])])] + (@common;with-unknown-type + (@;analyse-reference [module-name var-name]))) + (macro;run (init-compiler [])) + (case> (#R;Success [_type (#~;Absolute idx)]) + (Type/= ref-type _type) - _ - false))) + _ + false))) )) diff --git a/new-luxc/test/test/luxc/analyser/structure.lux b/new-luxc/test/test/luxc/analyser/structure.lux index 597388aa2..914b1bf3b 100644 --- a/new-luxc/test/test/luxc/analyser/structure.lux +++ b/new-luxc/test/test/luxc/analyser/structure.lux @@ -55,7 +55,7 @@ _ #;None)) -(test: "Sums" +(context: "Sums" [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) choice (|> r;nat (:: @ map (n.% size))) primitives (r;list size gen-primitive) @@ -70,72 +70,72 @@ [+valueT +valueC] (assume (list;nth +choice +primitives)) +variantT (type;variant (L/map product;left +primitives))]] ($_ seq - (assert "Can analyse sum." - (|> (&;with-scope - (&;with-expected-type variantT - (@;analyse-sum analyse choice valueC))) - (macro;run (init-compiler [])) - (case> (^multi (#R;Success [_ sumA]) - [(flatten-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag choice) - (B/= last? (n.= (n.dec size) choice))) + (test "Can analyse sum." + (|> (&;with-scope + (&;with-expected-type variantT + (@;analyse-sum analyse choice valueC))) + (macro;run (init-compiler [])) + (case> (^multi (#R;Success [_ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (B/= last? (n.= (n.dec size) choice))) - _ - false))) - (assert "Can analyse sum through bound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (do Monad<Lux> - [_ (&;within-type-env - (TC;check varT variantT))] - (&;with-expected-type varT - (@;analyse-sum analyse choice valueC)))))) - (macro;run (init-compiler [])) - (case> (^multi (#R;Success [_ sumA]) - [(flatten-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag choice) - (B/= last? (n.= (n.dec size) choice))) - - _ - false))) - (assert "Cannot analyse sum through unbound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] + _ + false))) + (test "Can analyse sum through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do Monad<Lux> + [_ (&;within-type-env + (TC;check varT variantT))] (&;with-expected-type varT - (@;analyse-sum analyse choice valueC))))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - false + (@;analyse-sum analyse choice valueC)))))) + (macro;run (init-compiler [])) + (case> (^multi (#R;Success [_ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag choice) + (B/= last? (n.= (n.dec size) choice))) + + _ + false))) + (test "Cannot analyse sum through unbound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (&;with-expected-type varT + (@;analyse-sum analyse choice valueC))))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + false - _ - true))) - (assert "Can analyse sum through existential quantification." - (|> (&;with-scope - (&;with-expected-type (type;ex-q +1 +variantT) - (@;analyse-sum analyse +choice +valueC))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - true + _ + true))) + (test "Can analyse sum through existential quantification." + (|> (&;with-scope + (&;with-expected-type (type;ex-q +1 +variantT) + (@;analyse-sum analyse +choice +valueC))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + true - (#R;Error error) - false))) - (assert "Can analyse sum through universal quantification." - (|> (&;with-scope - (&;with-expected-type (type;univ-q +1 +variantT) - (@;analyse-sum analyse +choice +valueC))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - (not (n.= choice +choice)) + (#R;Error error) + false))) + (test "Can analyse sum through universal quantification." + (|> (&;with-scope + (&;with-expected-type (type;univ-q +1 +variantT) + (@;analyse-sum analyse +choice +valueC))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + (not (n.= choice +choice)) - (#R;Error error) - (n.= choice +choice)))) + (#R;Error error) + (n.= choice +choice)))) )) -(test: "Products" +(context: "Products" [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) primitives (r;list size gen-primitive) choice (|> r;nat (:: @ map (n.% size))) @@ -146,70 +146,70 @@ (list;drop choice primitives))) +tupleT (type;tuple (L/map product;left +primitives))]] ($_ seq - (assert "Can analyse product." - (|> (&;with-expected-type (type;tuple (L/map product;left primitives)) - (@;analyse-product analyse (L/map product;right primitives))) - (macro;run (init-compiler [])) - (case> (#R;Success tupleA) - (n.= size (list;size (flatten-tuple tupleA))) + (test "Can analyse product." + (|> (&;with-expected-type (type;tuple (L/map product;left primitives)) + (@;analyse-product analyse (L/map product;right primitives))) + (macro;run (init-compiler [])) + (case> (#R;Success tupleA) + (n.= size (list;size (flatten-tuple tupleA))) - _ - false))) - (assert "Can infer product." - (|> (@common;with-unknown-type - (@;analyse-product analyse (L/map product;right primitives))) - (macro;run (init-compiler [])) - (case> (#R;Success [_type tupleA]) - (and (Type/= (type;tuple (L/map product;left primitives)) - _type) - (n.= size (list;size (flatten-tuple tupleA)))) + _ + false))) + (test "Can infer product." + (|> (@common;with-unknown-type + (@;analyse-product analyse (L/map product;right primitives))) + (macro;run (init-compiler [])) + (case> (#R;Success [_type tupleA]) + (and (Type/= (type;tuple (L/map product;left primitives)) + _type) + (n.= size (list;size (flatten-tuple tupleA)))) - _ - false))) - (assert "Can analyse pseudo-product (singleton tuple)" - (|> (&;with-expected-type singletonT - (analyse (` [(~ singletonC)]))) - (macro;run (init-compiler [])) - (case> (#R;Success singletonA) - true + _ + false))) + (test "Can analyse pseudo-product (singleton tuple)" + (|> (&;with-expected-type singletonT + (analyse (` [(~ singletonC)]))) + (macro;run (init-compiler [])) + (case> (#R;Success singletonA) + true - (#R;Error error) - false))) - (assert "Can analyse product through bound type-vars." - (|> (&;with-scope - (@common;with-var - (function [[var-id varT]] - (do Monad<Lux> - [_ (&;within-type-env - (TC;check varT (type;tuple (L/map product;left primitives))))] - (&;with-expected-type varT - (@;analyse-product analyse (L/map product;right primitives))))))) - (macro;run (init-compiler [])) - (case> (#R;Success [_ tupleA]) - (n.= size (list;size (flatten-tuple tupleA))) + (#R;Error error) + false))) + (test "Can analyse product through bound type-vars." + (|> (&;with-scope + (@common;with-var + (function [[var-id varT]] + (do Monad<Lux> + [_ (&;within-type-env + (TC;check varT (type;tuple (L/map product;left primitives))))] + (&;with-expected-type varT + (@;analyse-product analyse (L/map product;right primitives))))))) + (macro;run (init-compiler [])) + (case> (#R;Success [_ tupleA]) + (n.= size (list;size (flatten-tuple tupleA))) - _ - false))) - (assert "Can analyse product through existential quantification." - (|> (&;with-scope - (&;with-expected-type (type;ex-q +1 +tupleT) - (@;analyse-product analyse (L/map product;right +primitives)))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - true + _ + false))) + (test "Can analyse product through existential quantification." + (|> (&;with-scope + (&;with-expected-type (type;ex-q +1 +tupleT) + (@;analyse-product analyse (L/map product;right +primitives)))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + true - (#R;Error error) - false))) - (assert "Cannot analyse product through universal quantification." - (|> (&;with-scope - (&;with-expected-type (type;univ-q +1 +tupleT) - (@;analyse-product analyse (L/map product;right +primitives)))) - (macro;run (init-compiler [])) - (case> (#R;Success _) - false + (#R;Error error) + false))) + (test "Cannot analyse product through universal quantification." + (|> (&;with-scope + (&;with-expected-type (type;univ-q +1 +tupleT) + (@;analyse-product analyse (L/map product;right +primitives)))) + (macro;run (init-compiler [])) + (case> (#R;Success _) + false - (#R;Error error) - true))) + (#R;Error error) + true))) )) (def: (check-variant-inference variantT choice size analysis) @@ -239,7 +239,7 @@ _ false))) -(test: "Tagged Sums" +(context: "Tagged Sums" [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) choice (|> r;nat (:: @ map (n.% size))) @@ -261,49 +261,49 @@ choice-tag (assume (list;nth choice tags)) other-choice-tag (assume (list;nth other-choice tags))]] ($_ seq - (assert "Can infer tagged sum." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@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))) - (assert "Tagged sums specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@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))) - (assert "Tagged sum inference retains universal quantification when type-vars are not bound." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@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))) - (assert "Can specialize generic tagged sums." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-expected-type variantT - (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (macro;run (init-compiler [])) - (case> (^multi (#R;Success [_ _ sumA]) - [(flatten-variant sumA) - (#;Some [tag last? valueA])]) - (and (n.= tag other-choice) - (B/= last? (n.= (n.dec size) other-choice))) + (test "Can infer tagged sum." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@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))) + (test "Tagged sums specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@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))) + (test "Tagged sum inference retains universal quantification when type-vars are not bound." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@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))) + (test "Can specialize generic tagged sums." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type variantT + (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) + (macro;run (init-compiler [])) + (case> (^multi (#R;Success [_ _ sumA]) + [(flatten-variant sumA) + (#;Some [tag last? valueA])]) + (and (n.= tag other-choice) + (B/= last? (n.= (n.dec size) other-choice))) - _ - false))) + _ + false))) )) -(test: "Records" +(context: "Records" [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) tags (|> (r;set text;Hash<Text> size (r;text +5)) (:: @ map S;to-list)) primitives (r;list size gen-primitive) @@ -323,35 +323,35 @@ (type;univ-q +1)) named-polyT (#;Named [module-name type-name] polyT)]] ($_ seq - (assert "Can infer record." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@module;declare-tags tags false namedT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) - (check-record-inference tupleT size))) - (assert "Records specialize when type-vars get bound." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (@common;with-unknown-type - (@;analyse-record analyse recordC))))) - (check-record-inference tupleT size))) - (assert "Can specialize generic records." - (|> (@module;with-module +0 module-name - (do Monad<Lux> - [_ (@module;declare-tags tags false named-polyT)] - (&;with-scope - (&;with-expected-type tupleT - (@;analyse-record analyse recordC))))) - (macro;run (init-compiler [])) - (case> (^multi (#R;Success [_ _ productA]) - [(flatten-tuple productA) - membersA]) - (n.= size (list;size membersA)) + (test "Can infer record." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false namedT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (test "Records specialize when type-vars get bound." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (@common;with-unknown-type + (@;analyse-record analyse recordC))))) + (check-record-inference tupleT size))) + (test "Can specialize generic records." + (|> (@module;with-module +0 module-name + (do Monad<Lux> + [_ (@module;declare-tags tags false named-polyT)] + (&;with-scope + (&;with-expected-type tupleT + (@;analyse-record analyse recordC))))) + (macro;run (init-compiler [])) + (case> (^multi (#R;Success [_ _ productA]) + [(flatten-tuple productA) + membersA]) + (n.= size (list;size membersA)) - _ - false))) + _ + false))) )) diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux index 6892274e4..161675075 100644 --- a/new-luxc/test/test/luxc/common.lux +++ b/new-luxc/test/test/luxc/common.lux @@ -11,7 +11,8 @@ (def: init-compiler-info Compiler-Info - {#;compiler-version &;compiler-version + {#;compiler-name "Lux/JVM" + #;compiler-version &;compiler-version #;compiler-mode #;Build}) (def: init-type-context diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux index a64712e86..53b455812 100644 --- a/new-luxc/test/test/luxc/generator/primitive.lux +++ b/new-luxc/test/test/luxc/generator/primitive.lux @@ -19,7 +19,7 @@ ["@;" common])) (test/luxc common)) -(test: "Primitives." +(context: "Primitives." [%bool% r;bool %nat% r;nat %int% r;int @@ -29,14 +29,14 @@ %text% (r;text +5)] (with-expansions [<tests> (do-template [<desc> <type> <synthesis> <sample> <test>] - [(assert (format "Can generate " <desc> ".") - (|> (@eval;eval (@;generate (<synthesis> <sample>))) - (macro;run (init-compiler [])) - (case> (#R;Success valueG) - (<test> <sample> (:! <type> valueG)) + [(test (format "Can generate " <desc> ".") + (|> (@eval;eval (@;generate (<synthesis> <sample>))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (<test> <sample> (:! <type> valueG)) - _ - false)))] + _ + false)))] ["bool" Bool #ls;Bool %bool% B/=] ["nat" Nat #ls;Nat %nat% n.=] @@ -46,13 +46,13 @@ ["char" Char #ls;Char %char% C/=] ["text" Text #ls;Text %text% T/=])] ($_ seq - (assert "Can generate unit." - (|> (@eval;eval (@;generate #ls;Unit)) - (macro;run (init-compiler [])) - (case> (#R;Success valueG) - (is @common;unit (:! Text valueG)) + (test "Can generate unit." + (|> (@eval;eval (@;generate #ls;Unit)) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (is @common;unit (:! Text valueG)) - _ - false))) + _ + false))) <tests> ))) diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux index ddf4f0afc..817052eff 100644 --- a/new-luxc/test/test/luxc/generator/structure.lux +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -62,44 +62,44 @@ false )) -(test: "Tuples." +(context: "Tuples." [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) members (r;list size gen-primitive)] - (assert "Can generate tuple." - (|> (@eval;eval (@;generate (#ls;Tuple members))) - (macro;run (init-compiler [])) - (case> (#R;Success valueG) - (let [valueG (:! (a;Array Top) valueG)] - (and (n.= size (a;size valueG)) - (list;every? corresponds? (list;zip2 members (a;to-list valueG))))) + (test "Can generate tuple." + (|> (@eval;eval (@;generate (#ls;Tuple members))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (let [valueG (:! (a;Array Top) valueG)] + (and (n.= size (a;size valueG)) + (list;every? corresponds? (list;zip2 members (a;to-list valueG))))) - _ - false)))) + _ + false)))) -(test: "Variants." +(context: "Variants." [num-tags (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) tag (|> r;nat (:: @ map (n.% num-tags))) #let [last? (n.= (n.dec num-tags) tag)] member gen-primitive] - (assert "Can generate variant." - (|> (do Monad<Lux> - [runtime-bytecode @runtime;generate] - (@eval;eval (@;generate (#ls;Variant tag last? member)))) - (macro;run (init-compiler [])) - (case> (#R;Success valueG) - (let [valueG (:! (a;Array Top) valueG)] - (and (n.= +3 (a;size valueG)) - (let [_tag (:! Integer (assume (a;get +0 valueG))) - _last? (a;get +1 valueG) - _value (:! Top (assume (a;get +2 valueG)))] - (and (n.= tag (|> _tag host;i2l int-to-nat)) - (case _last? - (#;Some _last?') - (and last? (T/= "" (:! Text _last?'))) + (test "Can generate variant." + (|> (do Monad<Lux> + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate (#ls;Variant tag last? member)))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (let [valueG (:! (a;Array Top) valueG)] + (and (n.= +3 (a;size valueG)) + (let [_tag (:! Integer (assume (a;get +0 valueG))) + _last? (a;get +1 valueG) + _value (:! Top (assume (a;get +2 valueG)))] + (and (n.= tag (|> _tag host;i2l int-to-nat)) + (case _last? + (#;Some _last?') + (and last? (T/= "" (:! Text _last?'))) - #;None - (not last?)) - (corresponds? [member _value]))))) + #;None + (not last?)) + (corresponds? [member _value]))))) - _ - false)))) + _ + false)))) diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux index 33b6eba36..21d34f7c0 100644 --- a/new-luxc/test/test/luxc/parser.lux +++ b/new-luxc/test/test/luxc/parser.lux @@ -75,16 +75,17 @@ (r;either simple^ composite^)))))) -(test: "Lux code parser." +(context: "Lux code parser." + #seed +15765541630132670628 [sample code^] - (assert "Can parse Lux code." - (case (&;parse [default-cursor (code;to-text sample)]) - (#R;Error error) - false + (test "Can parse Lux code." + (case (&;parse [default-cursor (code;to-text sample)]) + (#R;Error error) + false - (#R;Success [_ parsed]) - (:: code;Eq<Code> = parsed sample)) - )) + (#R;Success [_ parsed]) + (:: code;Eq<Code> = parsed sample)) + )) (def: comment-text^ (r;Random Text) @@ -109,7 +110,8 @@ nested^)] (wrap (format "#( " comment " )#"))))))) -(test: "Multi-line text & comments." +(context: "Multi-line text & comments." + #seed +13835085537605735783 [#let [char-gen (|> r;char (r;filter (function [value] (not (or (char;space? value) (C/= #"\"" value) @@ -123,57 +125,57 @@ comment comment^ unbalanced-comment comment-text^] ($_ seq - (assert "Will reject invalid multi-line text." - (let [bad-match (format (char;as-text x) "\n" + (test "Will reject invalid multi-line text." + (let [bad-match (format (char;as-text x) "\n" + (char;as-text y) "\n" + (char;as-text z))] + (case (&;parse [default-cursor + (format "\"" bad-match "\"")]) + (#R;Error error) + true + + (#R;Success [_ parsed]) + false))) + (test "Will accept valid multi-line text" + (let [good-input (format (char;as-text x) "\n" + offset (char;as-text y) "\n" + offset (char;as-text z)) + good-output (format (char;as-text x) "\n" (char;as-text y) "\n" (char;as-text z))] - (case (&;parse [default-cursor - (format "\"" bad-match "\"")]) - (#R;Error error) - true - - (#R;Success [_ parsed]) - false))) - (assert "Will accept valid multi-line text" - (let [good-input (format (char;as-text x) "\n" - offset (char;as-text y) "\n" - offset (char;as-text z)) - good-output (format (char;as-text x) "\n" - (char;as-text y) "\n" - (char;as-text z))] - (case (&;parse [(|> default-cursor - (update@ #;column (n.+ (n.dec offset-size)))) - (format "\"" good-input "\"")]) - (#R;Error error) - false - - (#R;Success [_ parsed]) - (:: code;Eq<Code> = - parsed - (code;text good-output))))) - (assert "Can handle comments." - (case (&;parse [default-cursor - (format comment (code;to-text sample))]) + (case (&;parse [(|> default-cursor + (update@ #;column (n.+ (n.dec offset-size)))) + (format "\"" good-input "\"")]) (#R;Error error) false (#R;Success [_ parsed]) - (:: code;Eq<Code> = parsed sample))) - (assert "Will reject unbalanced multi-line comments." - (and (case (&;parse [default-cursor - (format "#(" "#(" unbalanced-comment ")#" - (code;to-text sample))]) - (#R;Error error) - true + (:: code;Eq<Code> = + parsed + (code;text good-output))))) + (test "Can handle comments." + (case (&;parse [default-cursor + (format comment (code;to-text sample))]) + (#R;Error error) + false + + (#R;Success [_ parsed]) + (:: code;Eq<Code> = parsed sample))) + (test "Will reject unbalanced multi-line comments." + (and (case (&;parse [default-cursor + (format "#(" "#(" unbalanced-comment ")#" + (code;to-text sample))]) + (#R;Error error) + true - (#R;Success [_ parsed]) - false) - (case (&;parse [default-cursor - (format "#(" unbalanced-comment ")#" ")#" - (code;to-text sample))]) - (#R;Error error) - true + (#R;Success [_ parsed]) + false) + (case (&;parse [default-cursor + (format "#(" unbalanced-comment ")#" ")#" + (code;to-text sample))]) + (#R;Error error) + true - (#R;Success [_ parsed]) - false))) + (#R;Success [_ parsed]) + false))) )) diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux index 6ad7ed634..acc39ce16 100644 --- a/new-luxc/test/test/luxc/synthesizer/function.lux +++ b/new-luxc/test/test/luxc/synthesizer/function.lux @@ -104,52 +104,52 @@ (|> chosen (n.+ (n.dec num-args)) nat-to-int) (#la;Relative (#;Local chosen))]))))) -(test: "Function definition." +(context: "Function definition." [[args1 prediction1 function1] gen-function//constant [args2 prediction2 function2] gen-function//captured [args3 prediction3 function3] gen-function//local] ($_ seq - (assert "Nested functions will get folded together." - (|> (synthesizer;synthesize function1) - (case> (#ls;Function args captured output) - (and (n.= args1 args) - (corresponds? prediction1 output)) - - _ - (n.= +0 args1)))) - (assert "Folded functions provide direct access to captured variables." - (|> (synthesizer;synthesize function2) - (case> (#ls;Function args captured (#ls;Variable output)) - (and (n.= args2 args) - (i.= prediction2 output)) - - _ - false))) - (assert "Folded functions properly offset local variables." - (|> (synthesizer;synthesize function3) - (case> (#ls;Function args captured (#ls;Variable output)) - (and (n.= args3 args) - (i.= prediction3 output)) - - _ - false))) + (test "Nested functions will get folded together." + (|> (synthesizer;synthesize function1) + (case> (#ls;Function args captured output) + (and (n.= args1 args) + (corresponds? prediction1 output)) + + _ + (n.= +0 args1)))) + (test "Folded functions provide direct access to captured variables." + (|> (synthesizer;synthesize function2) + (case> (#ls;Function args captured (#ls;Variable output)) + (and (n.= args2 args) + (i.= prediction2 output)) + + _ + false))) + (test "Folded functions properly offset local variables." + (|> (synthesizer;synthesize function3) + (case> (#ls;Function args captured (#ls;Variable output)) + (and (n.= args3 args) + (i.= prediction3 output)) + + _ + false))) )) -(test: "Function application." +(context: "Function application." [num-args (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1)))) funcA gen-primitive argsA (r;list num-args gen-primitive)] ($_ seq - (assert "Can synthesize function application." - (|> (synthesizer;synthesize (la;apply argsA funcA)) - (case> (#ls;Call funcS argsS) - (and (corresponds? funcA funcS) - (list;every? (product;uncurry corresponds?) - (list;zip2 argsA argsS))) - - _ - false))) - (assert "Function application on no arguments just synthesizes to the function itself." - (|> (synthesizer;synthesize (la;apply (list) funcA)) - (corresponds? funcA))) + (test "Can synthesize function application." + (|> (synthesizer;synthesize (la;apply argsA funcA)) + (case> (#ls;Call funcS argsS) + (and (corresponds? funcA funcS) + (list;every? (product;uncurry corresponds?) + (list;zip2 argsA argsS))) + + _ + false))) + (test "Function application on no arguments just synthesizes to the function itself." + (|> (synthesizer;synthesize (la;apply (list) funcA)) + (corresponds? funcA))) )) diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux index 07f2b8a13..abc06dbb8 100644 --- a/new-luxc/test/test/luxc/synthesizer/loop.lux +++ b/new-luxc/test/test/luxc/synthesizer/loop.lux @@ -134,31 +134,31 @@ arity (make-function arity bodyS)]))) -(test: "Recursion." +(context: "Recursion." [[prediction arity analysis] gen-recursion] ($_ seq - (assert "Can accurately identify (and then reify) tail recursion." - (case (synthesizer;synthesize analysis) - (#ls;Function _arity _env _body) - (|> _body - (does-recursion? arity) - (B/= prediction) - (and (n.= arity _arity))) - - _ - false)))) - -(test: "Loop." + (test "Can accurately identify (and then reify) tail recursion." + (case (synthesizer;synthesize analysis) + (#ls;Function _arity _env _body) + (|> _body + (does-recursion? arity) + (B/= prediction) + (and (n.= arity _arity))) + + _ + false)))) + +(context: "Loop." [[prediction arity analysis] gen-recursion] ($_ seq - (assert "Can reify loops." - (case (synthesizer;synthesize (make-apply analysis (list;repeat arity #la;Unit))) - (#ls;Loop _register _inits _body) - (and (n.= arity (list;size _inits)) - (not (&&loop;contains-self-reference? _body))) + (test "Can reify loops." + (case (synthesizer;synthesize (make-apply analysis (list;repeat arity #la;Unit))) + (#ls;Loop _register _inits _body) + (and (n.= arity (list;size _inits)) + (not (&&loop;contains-self-reference? _body))) - (#ls;Call (#ls;Function _arity _env _bodyS) argsS) - (&&loop;contains-self-reference? _bodyS) + (#ls;Call (#ls;Function _arity _env _bodyS) argsS) + (&&loop;contains-self-reference? _bodyS) - _ - false)))) + _ + false)))) diff --git a/new-luxc/test/test/luxc/synthesizer/primitive.lux b/new-luxc/test/test/luxc/synthesizer/primitive.lux index 4c67fa0a4..c17d41a78 100644 --- a/new-luxc/test/test/luxc/synthesizer/primitive.lux +++ b/new-luxc/test/test/luxc/synthesizer/primitive.lux @@ -11,7 +11,7 @@ [analyser] [synthesizer])) -(test: "Primitives" +(context: "Primitives" [%bool% r;bool %nat% r;nat %int% r;int @@ -21,13 +21,13 @@ %text% (r;text +5)] (with-expansions [<tests> (do-template [<desc> <analysis> <synthesis> <sample>] - [(assert (format "Can synthesize " <desc> ".") - (|> (synthesizer;synthesize (<analysis> <sample>)) - (case> (<synthesis> value) - (is <sample> value) + [(test (format "Can synthesize " <desc> ".") + (|> (synthesizer;synthesize (<analysis> <sample>)) + (case> (<synthesis> value) + (is <sample> value) - _ - false)))] + _ + false)))] ["unit" #la;Unit #ls;Unit []] ["bool" #la;Bool #ls;Bool %bool%] diff --git a/new-luxc/test/test/luxc/synthesizer/procedure.lux b/new-luxc/test/test/luxc/synthesizer/procedure.lux index 898987308..91369a59b 100644 --- a/new-luxc/test/test/luxc/synthesizer/procedure.lux +++ b/new-luxc/test/test/luxc/synthesizer/procedure.lux @@ -15,18 +15,18 @@ [synthesizer]) (.. common)) -(test: "Procedures" +(context: "Procedures" [num-args (|> r;nat (:: @ map (n.% +10))) nameA (r;text +5) argsA (r;list num-args gen-primitive)] ($_ seq - (assert "Can synthesize procedure calls." - (|> (synthesizer;synthesize (#la;Procedure nameA argsA)) - (case> (#ls;Procedure nameS argsS) - (and (T/= nameA nameS) - (list;every? (product;uncurry corresponds?) - (list;zip2 argsA argsS))) - - _ - false))) + (test "Can synthesize procedure calls." + (|> (synthesizer;synthesize (#la;Procedure nameA argsA)) + (case> (#ls;Procedure nameS argsS) + (and (T/= nameA nameS) + (list;every? (product;uncurry corresponds?) + (list;zip2 argsA argsS))) + + _ + false))) )) diff --git a/new-luxc/test/test/luxc/synthesizer/structure.lux b/new-luxc/test/test/luxc/synthesizer/structure.lux index 3f90bf321..eba24213e 100644 --- a/new-luxc/test/test/luxc/synthesizer/structure.lux +++ b/new-luxc/test/test/luxc/synthesizer/structure.lux @@ -13,33 +13,33 @@ [synthesizer]) (.. common)) -(test: "Variants" +(context: "Variants" [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) tagA (|> r;nat (:: @ map (n.% size))) memberA gen-primitive] ($_ seq - (assert "Can synthesize variants." - (|> (synthesizer;synthesize (la;sum tagA size +0 memberA)) - (case> (#ls;Variant tagS last?S memberS) - (and (n.= tagA tagS) - (B/= (n.= (n.dec size) tagA) - last?S) - (corresponds? memberA memberS)) - - _ - false))) + (test "Can synthesize variants." + (|> (synthesizer;synthesize (la;sum tagA size +0 memberA)) + (case> (#ls;Variant tagS last?S memberS) + (and (n.= tagA tagS) + (B/= (n.= (n.dec size) tagA) + last?S) + (corresponds? memberA memberS)) + + _ + false))) )) -(test: "Tuples" +(context: "Tuples" [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) membersA (r;list size gen-primitive)] ($_ seq - (assert "Can synthesize tuple." - (|> (synthesizer;synthesize (la;product membersA)) - (case> (#ls;Tuple membersS) - (and (n.= size (list;size membersS)) - (list;every? (product;uncurry corresponds?) (list;zip2 membersA membersS))) + (test "Can synthesize tuple." + (|> (synthesizer;synthesize (la;product membersA)) + (case> (#ls;Tuple membersS) + (and (n.= size (list;size membersS)) + (list;every? (product;uncurry corresponds?) (list;zip2 membersA membersS))) - _ - false))) + _ + false))) )) |