aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
authorEduardo Julian2017-06-27 17:52:52 -0400
committerEduardo Julian2017-06-27 17:52:52 -0400
commit36cf0c61991bda395e224fa2d435fa6b6f5090e5 (patch)
tree50216b0052b413dd7dff04a980e6f238cec98984 /new-luxc
parent49fab71f7965e4c76796d5b4ce9648fc46ab2660 (diff)
- Adapted compiler to the latest stdlib changes.
Diffstat (limited to 'new-luxc')
-rw-r--r--new-luxc/source/luxc/analyser/case.lux2
-rw-r--r--new-luxc/source/luxc/analyser/function.lux18
-rw-r--r--new-luxc/source/luxc/analyser/inference.lux6
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux8
-rw-r--r--new-luxc/source/luxc/generator.lux9
-rw-r--r--new-luxc/source/luxc/parser.lux244
-rw-r--r--new-luxc/test/test/luxc/analyser/case.lux64
-rw-r--r--new-luxc/test/test/luxc/analyser/function.lux118
-rw-r--r--new-luxc/test/test/luxc/analyser/primitive.lux22
-rw-r--r--new-luxc/test/test/luxc/analyser/procedure/common.lux510
-rw-r--r--new-luxc/test/test/luxc/analyser/reference.lux46
-rw-r--r--new-luxc/test/test/luxc/analyser/structure.lux378
-rw-r--r--new-luxc/test/test/luxc/common.lux3
-rw-r--r--new-luxc/test/test/luxc/generator/primitive.lux30
-rw-r--r--new-luxc/test/test/luxc/generator/structure.lux62
-rw-r--r--new-luxc/test/test/luxc/parser.lux110
-rw-r--r--new-luxc/test/test/luxc/synthesizer/function.lux76
-rw-r--r--new-luxc/test/test/luxc/synthesizer/loop.lux44
-rw-r--r--new-luxc/test/test/luxc/synthesizer/primitive.lux14
-rw-r--r--new-luxc/test/test/luxc/synthesizer/procedure.lux20
-rw-r--r--new-luxc/test/test/luxc/synthesizer/structure.lux38
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)))
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-07 17:14:47 +0000