zeolite-lang 0.9.0.0 → 0.10.0.0

raw patch · 105 files changed

+4413/−5338 lines, 105 filesdep +parser-combinatorsPVP ok

version bump matches the API change (PVP)

Dependencies added: parser-combinators

API changes (from Hackage documentation)

Files

• ChangeLog.md +70/−0
• bin/unit-tests.hs +1/−1
• bin/zeolite-setup.hs +4/−3
• example/parser/parser-test.0rt +16/−17
• example/tree/tree-test.0rt +49/−51
• example/tree/tree.0rp +1/−1
• example/tree/type-tree.0rp +2/−2
• example/tree/type-tree.0rx +4/−4
• lib/file/.zeolite-module +1/−1
• lib/file/tests.0rt +64/−115
• lib/math/.zeolite-module +1/−1
• lib/math/tests.0rt +104/−35
• lib/testing/.zeolite-module +3/−0
• lib/testing/helpers.0rp +32/−0
• lib/testing/helpers.0rx +60/−0
• lib/testing/tests.0rt +69/−0
• lib/util/.zeolite-module +1/−1
• lib/util/Category_Argv.cpp +1/−1
• lib/util/tests.0rt +116/−254
• src/Base/CompileError.hs +4/−0
• src/Base/CompileInfo.hs +2/−2
• src/Base/Mergeable.hs +12/−2
• src/Cli/Compiler.hs +5/−5
• src/Cli/Programs.hs +2/−1
• src/Cli/RunCompiler.hs +10/−10
• src/Cli/TestRunner.hs +77/−48
• src/Compilation/CompilerState.hs +17/−2
• src/Compilation/ProcedureContext.hs +91/−12
• src/Compilation/ScopeContext.hs +1/−1
• src/CompilerCxx/Category.hs +78/−48
• src/CompilerCxx/CategoryContext.hs +3/−0
• src/CompilerCxx/Code.hs +11/−2
• src/CompilerCxx/Naming.hs +4/−0
• src/CompilerCxx/Procedure.hs +68/−18
• src/Config/LocalConfig.hs +7/−6
• src/Module/CompileMetadata.hs +2/−1
• src/Module/ParseMetadata.hs +79/−80
• src/Module/ProcessMetadata.hs +20/−11
• src/Parser/Common.hs +145/−88
• src/Parser/DefinedCategory.hs +22/−39
• src/Parser/IntegrationTest.hs +17/−10
• src/Parser/Pragma.hs +23/−23
• src/Parser/Procedure.hs +28/−17
• src/Parser/SourceFile.hs +8/−18
• src/Parser/TypeCategory.hs +22/−20
• src/Test/Common.hs +10/−21
• src/Test/IntegrationTest.hs +26/−27
• src/Test/ParseMetadata.hs +138/−126
• src/Test/Parser.hs +2/−3
• src/Test/Pragma.hs +4/−4
• src/Test/Procedure.hs +9/−9
• src/Test/TypeCategory.hs +2/−2
• src/Test/TypeInstance.hs +2/−2
• src/Test/testfiles/basic_compiles_test.0rt +19/−0
• src/Test/testfiles/basic_crash_test.0rt +5/−1
• src/Test/testfiles/basic_error_test.0rt +4/−0
• src/Test/testfiles/basic_success_test.0rt +5/−1
• src/Test/testfiles/concrete.0rx +0/−1
• src/Test/testfiles/macro-config.txt +12/−0
• src/Test/testfiles/module-cache.txt +76/−0
• src/Test/testfiles/module-config.txt +33/−9
• src/Test/testfiles/test.0rt +5/−1
• src/Types/IntegrationTest.hs +26/−14
• src/Types/Pragma.hs +11/−1
• src/Types/Procedure.hs +9/−1
• src/Types/TypeCategory.hs +16/−16
• src/Types/TypeInstance.hs +9/−3
• tests/.zeolite-module +17/−0
• tests/assignments.0rt +0/−54
• tests/bad-path/.zeolite-module +2/−0
• tests/bad-path/README.md +19/−0
• tests/builtin-types.0rt +786/−1054
• tests/check-defs/README.md +1/−1
• tests/cli-tests.sh +11/−0
• tests/conditionals.0rt +52/−141
• tests/expr-lookup.0rt +54/−105
• tests/failure.0rt +17/−29
• tests/filters.0rt +18/−15
• tests/function-calls.0rt +94/−127
• tests/function-merging.0rt +9/−37
• tests/helpers.0rp +0/−32
• tests/helpers.0rx +0/−45
• tests/inference.0rt +95/−107
• tests/infix-functions.0rt +58/−64
• tests/infix-operations.0rt +131/−233
• tests/internal-inheritance.0rt +26/−52
• tests/internal-params.0rt +39/−145
• tests/member-init.0rt +78/−84
• tests/modified-storage.0rt +92/−96
• tests/multiple-returns.0rt +21/−31
• tests/named-returns.0rt +81/−114
• tests/positional-returns.0rt +44/−51
• tests/reduce.0rt +216/−362
• tests/regressions.0rt +5/−1
• tests/scoped.0rt +247/−406
• tests/simple.0rt +31/−38
• tests/templates/tests.0rt +5/−1
• tests/tracing.0rt +31/−52
• tests/typename.0rt +61/−193
• tests/unary-functions.0rt +48/−53
• tests/unreachable.0rt +52/−87
• tests/value-init.0rt +38/−61
• tests/visibility.0rt +5/−1
• tests/while.0rt +139/−270
• zeolite-lang.cabal +10/−3

@@ -1,5 +1,75 @@ # Revision history for zeolite-lang +## 0.10.0.0  -- 2020-12-05++### Language++* **[breaking]** Major changes to `.0rt` syntax:++  * **[breaking]** Removes the expression argument from `success` and `crash`+    `testcase` types. Use one or more `unittest` (see next point) instead.++  * **[new]** Adds `unittest` keyword to allow the user to define multiple+    tests within a single `success` `testcase`.++    ```text+    testcase "simple tests" {+      success+    }++    unittest checkInvariant1 {+      // this is a regular procedure with no return+    }++    unittest checkInvariant2 {+      // this is a regular procedure with no return+    }+    ```++    This allows multiple tests to use the same setup, while still being able to+    track multiple test failures. `error` and `crash` `testcase` types are still+    available.++  * **[breaking]** Allows `testcase` to statically set `Argv` (see `lib/util`)+    using the `args` keyword. By default, only the program name is set.+    Previously, `Argv` used whatever was passed to the test binary.++    ```text+    testcase "with static Argv" {+      success+      args "arg1" "arg2"+    }++    unittest test {+      // something that requires Argv.global()+    }+    ```++    Note that this *isn't* a+    library change; this also affects C++ extensions that use `Argv` from+    `base/logging.hpp`.++  * **[new]** Adds `compiles` mode for `testcase`. This is like `success` except+    nothing is executed. (`success` requires at least one `unittest`, whereas+    `compiles` will not execute anything even if `unittest` are present.)++### Libraries++* **[new]** Adds the `lib/testing` library with basic helpers for unit tests.++### Compiler CLI++* **[new]** Updates parsing of `.zeolite-module` to allow any ordering of the+  fields. Previously, the fields needed to be in a very specific order.++* **[fix]** Adds compile-time protection against self-referential expression+  macros defined in `expression_map:` in `.zeolite-module`. Previously, the+  result was infinite recursion that could exhaust system resources.++* **[breaking]** Adds an error when `root`/`path` in `.zeolite-module` differs+  from the location of the respective `.zeolite-module`. This is to catch both+  typos (e.g., copy-and-paste errors) and ambiguities.+ ## 0.9.0.0  -- 2020-11-23  ### Compiler CLI

@@ -48,4 +48,4 @@   ]  labelWith :: String -> [IO (CompileInfo ())] -> [IO (CompileInfo ())]-labelWith s ts = map (\(n,t) -> fmap (<?? ("In " ++ s ++ " (#" ++ show n ++ "):")) t) (zip ([1..] :: [Int]) ts)+labelWith s ts = map (\(n,t) -> fmap (<?? "In " ++ s ++ " (#" ++ show n ++ "):") t) (zip ([1..] :: [Int]) ts)

@@ -22,9 +22,9 @@ import System.Exit import System.IO +import Base.CompileInfo import Cli.CompileOptions import Cli.RunCompiler-import Base.CompileInfo import Config.LoadConfig import Config.LocalConfig @@ -55,10 +55,11 @@ libraries :: [String] libraries = [     "base",-    "tests",+    "lib/testing",     "lib/util",     "lib/file",-    "lib/math"+    "lib/math",+    "tests"   ]  includePaths :: [String]

@@ -1,29 +1,28 @@ testcase "parse data from a file" {-  success Test.execute()-}--concrete Test {-  @type execute () -> ()+  success } -define Test {-  execute () {-    TestData data <- TestData.parseFrom(loadTestData()).getValue()+unittest test {+  TestData data <- TestData.parseFrom(Helpers.loadTestData()).getValue() -    if (data.getName() != "example data") {-      fail(data.getName())-    }+  if (data.getName() != "example data") {+    fail(data.getName())+  } -    if (data.getDescription() != "THIS_IS_A_TOKEN") {-      fail(data.getDescription())-    }+  if (data.getDescription() != "THIS_IS_A_TOKEN") {+    fail(data.getDescription())+  } -    if (data.getBoolean() != false) {-      fail(data.getBoolean())-    }+  if (data.getBoolean() != false) {+    fail(data.getBoolean())   }+} +concrete Helpers {   @type loadTestData () -> (String)+}++define Helpers {   loadTestData () {     scoped {       RawFileReader reader <- RawFileReader.open($ExprLookup[MODULE_PATH]$ + "/test-data.txt")

@@ -1,64 +1,62 @@ // Each testcase is essentially followed by its own private .0rx that is-// separate from all other testcases. In this case, the testcase expects that-// the source will compile and Test.execute() will succeed, but testcases can-// also expect a compiler error ("error") or a runtime crash ("crash"). Note-// that you *cannot* expect parse-time errors.+// separate from all other testcases. In addition to category declarations and+// definitions, each testcase can define one or more unittest procedures.+//+// In this example, "success" means that all unittest are expected to succeed.+// The other options are "crash" for a runtime failure and "error" for a+// compilation error.  testcase "integration test" {-  success Test.execute()+  success } -// Everything past the testcase (up until the next testcase, if there is one) is-// treated as a self-contained .0rx. This is compiled into a binary that calls-// the expression that follows "success" above.+// Everything past here until the next testcase belongs to this testcase. This+// allows you to perform additional setup. -concrete Test {-  @type execute () -> ()-}+// Each unittest is executed separately. If one unittest updates global state,+// it won't affect any other unittest. -define Test {-  execute () {-    // Just select the required usage patterns with an intersection.-    [KVWriter<Int,Int>&KVReader<Int,Int>] tree <- Tree<Int,Int>.new()-    Int count <- 30+unittest test {+  // Just select the required usage patterns with an intersection.+  [KVWriter<Int,Int>&KVReader<Int,Int>] tree <- Tree<Int,Int>.new()+  Int count <- 30 -    // Insert values.-    scoped {-      Int i <- 0-    } in while (i < count) {-      Int new <- ((i + 13) * 3547) % count-      \ tree.set(new,i)-    } update {-      i <- i+1-    }+  // Insert values.+  scoped {+    Int i <- 0+  } in while (i < count) {+    Int new <- ((i + 13) * 3547) % count+    \ tree.set(new,i)+  } update {+    i <- i+1+  } -    // Verify and remove values.+  // Verify and remove values.+  scoped {+    Int i <- 0+  } in while (i < count) {+    Int new <- ((i + 13) * 3547) % count     scoped {-      Int i <- 0-    } in while (i < count) {-      Int new <- ((i + 13) * 3547) % count-      scoped {-        optional Int value <- tree.get(new)-      } in if (!present(value)) {-        \ LazyStream<Formatted>.new()-            .append("Not found ")-            .append(new)-            .append(" but should have been ")-            .append(i)-            .writeTo(SimpleOutput.error())-      } elif (require(value) != i) {-        \ LazyStream<Formatted>.new()-            .append("Element ")-            .append(new)-            .append(" should have been ")-            .append(i)-            .append(" but was ")-            .append(require(value))-            .writeTo(SimpleOutput.error())-      }-      \ tree.remove(new)-    } update {-      i <- i+1+      optional Int value <- tree.get(new)+    } in if (!present(value)) {+      \ LazyStream<Formatted>.new()+          .append("Not found ")+          .append(new)+          .append(" but should have been ")+          .append(i)+          .writeTo(SimpleOutput.error())+    } elif (require(value) != i) {+      \ LazyStream<Formatted>.new()+          .append("Element ")+          .append(new)+          .append(" should have been ")+          .append(i)+          .append(" but was ")+          .append(require(value))+          .writeTo(SimpleOutput.error())     }+    \ tree.remove(new)+  } update {+    i <- i+1   } }

@@ -18,7 +18,7 @@   refines KVReader<#k,#v>   #k defines LessThan<#k> -  // Creates a new Tree, e.g., Tree$new().+  // Creates a new Tree, e.g., Tree.new().   @type new () -> (Tree<#k,#v>)    // Normally you do not need to redeclare functions inherited from interfaces.

@@ -4,7 +4,7 @@  * matches the type of the value.  */ concrete TypeTree {-  // Creates a new TypeTree, e.g., TypeTree$new().+  // Creates a new TypeTree, e.g., TypeTree.new().   @type new () -> (TypeTree)    // Sets the value for the given key, inserting if necessary.@@ -45,6 +45,6 @@   defines LessThan<TypeKey<any>>   defines Equals<TypeKey<any>> -  // Creates a new TypeKey, e.g., TypeTree<#x>$new().+  // Creates a new TypeKey, e.g., TypeTree<#x>.new().   @type new () -> (TypeKey<#x>) }

@@ -81,10 +81,10 @@       // The runtime type of value does not matter here; it just needs to be of       // type optional #x at compile time.       //-      // This is more like template meta-programming in C++ than it is like a-      // runtime type cast in Java. The reduce call could in theory be replaced-      // at compile time with either value or empty if parameter substitution-      // happened at compile time. (Like C++ does with templates.)+      // This is more like template meta-programming in C++ than it is like+      // instanceof or reflection in Java. The reduce call could in theory be+      // replaced at compile time with either value or empty if parameter+      // substitution happened at compile time. (Like C++ does with templates.)       return reduce<#x,#y>(value)     } else {       return empty

@@ -1,7 +1,7 @@ root: ".." path: "file" public_deps: [-  "../util"+  "lib/util" ] extra_files: [   category_source {

@@ -17,151 +17,100 @@ // Author: Kevin P. Barry [ta0kira@gmail.com]  testcase "read and write" {-  success Test.run()+  success } -define Test {-  run () {-    RawFileWriter writer <- RawFileWriter.open("testfile")-    if (present(writer.getFileError())) {-      fail(require(writer.getFileError()))-    }-    RawFileReader reader <- RawFileReader.open("testfile")-    if (present(reader.getFileError())) {-      fail(require(reader.getFileError()))-    }--    String data <- "this is some\x00data"--    Int writeSize <- writer.writeBlock(data)-    if (writeSize != data.readSize()) {-      fail(writeSize)-    }-    if (present(writer.getFileError())) {-      fail(require(writer.getFileError()))-    }--    scoped {-      String data2 <- reader.readBlock(8)-    } in if (data2 != "this is ") {-      fail("\"" + data2 + "\"")-    }-    scoped {-      String data2 <- reader.readBlock(20)-    } in if (data2 != "some\x00data") {-      fail("\"" + data2 + "\"")-    }-    if (present(reader.getFileError())) {-      fail(require(reader.getFileError()))-    }--    if (!reader.pastEnd()) {-      fail("more data in file")-    }+unittest readWrite {+  RawFileWriter writer <- RawFileWriter.open("testfile")+  if (present(writer.getFileError())) {+    fail(require(writer.getFileError()))   }-}--concrete Test {-  @type run () -> ()-}-+  RawFileReader reader <- RawFileReader.open("testfile")+  if (present(reader.getFileError())) {+    fail(require(reader.getFileError()))+  } -testcase "read empty file" {-  success Test.run()-}+  String data <- "this is some\x00data" -define Test {-  run () {-    \ RawFileWriter.open("testfile").freeResource()-    RawFileReader reader <- RawFileReader.open("testfile")+  Int writeSize <- writer.writeBlock(data)+  if (writeSize != data.readSize()) {+    fail(writeSize)+  }+  if (present(writer.getFileError())) {+    fail(require(writer.getFileError()))+  } -    String data <- reader.readBlock(10)-    if (data != "") {-      fail("\"" + data + "\"")-    }-    if (present(reader.getFileError())) {-      fail(require(reader.getFileError()))-    }-    if (!reader.pastEnd()) {-      fail("more data in file")-    }+  scoped {+    String data2 <- reader.readBlock(8)+  } in if (data2 != "this is ") {+    fail("\"" + data2 + "\"")   }-}+  scoped {+    String data2 <- reader.readBlock(20)+  } in if (data2 != "some\x00data") {+    fail("\"" + data2 + "\"")+  }+  if (present(reader.getFileError())) {+    fail(require(reader.getFileError()))+  } -concrete Test {-  @type run () -> ()+  if (!reader.pastEnd()) {+    fail("more data in file")+  } } +unittest readEmpty {+  \ RawFileWriter.open("testfile").freeResource()+  RawFileReader reader <- RawFileReader.open("testfile") -testcase "read missing file" {-  success Test.run()+  String data <- reader.readBlock(10)+  if (data != "") {+    fail("\"" + data + "\"")+  }+  if (present(reader.getFileError())) {+    fail(require(reader.getFileError()))+  }+  if (!reader.pastEnd()) {+    fail("more data in file")+  } } -define Test {-  run () {-    RawFileReader reader <- RawFileReader.open("do-not-create-this-file")-    if (!present(reader.getFileError())) {-      fail("expected file error")-    }+unittest readMissing {+  RawFileReader reader <- RawFileReader.open("do-not-create-this-file")+  if (!present(reader.getFileError())) {+    fail("expected file error")   } } -concrete Test {-  @type run () -> ()+unittest unwritable {+  RawFileWriter writer <- RawFileWriter.open("testfile")+  \ writer.freeResource()+  if (!present(writer.getFileError())) {+    fail("expected file error")+  } }   testcase "read missing file crash" {-  crash Test.run()+  crash   require "do-not-create-this-file"   require "RawFileReader .*originally created" } -define Test {-  run () {-    RawFileReader reader <- RawFileReader.open("do-not-create-this-file")-    \ reader.readBlock(0)-  }-}--concrete Test {-  @type run () -> ()-}---testcase "unwritable file" {-  success Test.run()-}--define Test {-  run () {-    RawFileWriter writer <- RawFileWriter.open("testfile")-    \ writer.freeResource()-    if (!present(writer.getFileError())) {-      fail("expected file error")-    }-  }-}--concrete Test {-  @type run () -> ()+unittest test {+  RawFileReader reader <- RawFileReader.open("do-not-create-this-file")+  \ reader.readBlock(0) }   testcase "unwritable file crash" {-  crash Test.run()+  crash   require "testfile"   require "RawFileWriter .*originally created" } -define Test {-  run () {-    RawFileWriter writer <- RawFileWriter.open("testfile")-    \ writer.freeResource()-    \ writer.writeBlock("")-  }-}--concrete Test {-  @type run () -> ()+unittest test {+  RawFileWriter writer <- RawFileWriter.open("testfile")+  \ writer.freeResource()+  \ writer.writeBlock("") }

@@ -1,7 +1,7 @@ root: "../.." path: "lib/math" private_deps: [-  "../../tests"+  "lib/testing" ] extra_files: [   category_source {

@@ -17,44 +17,113 @@ // Author: Kevin P. Barry [ta0kira@gmail.com]  testcase "sanity check all functions" {-  success Test.run()+  success } -define Test {-  run () {-    \ Testing.checkBetween<?>(Math.cos(2.0),-0.42,-0.41)-    \ Testing.checkBetween<?>(Math.sin(2.0),0.90,0.91)-    \ Testing.checkBetween<?>(Math.tan(2.0),-2.19,-2.18)-    \ Testing.checkBetween<?>(Math.acos(0.5),1.04,1.05)-    \ Testing.checkBetween<?>(Math.asin(0.5),0.52,0.53)-    \ Testing.checkBetween<?>(Math.atan(0.5),0.46,0.47)-    \ Testing.checkBetween<?>(Math.cosh(2.0),3.76,3.77)-    \ Testing.checkBetween<?>(Math.sinh(2.0),3.62,3.63)-    \ Testing.checkBetween<?>(Math.tanh(2.0),0.96,0.97)-    \ Testing.checkBetween<?>(Math.acosh(2.0),1.31,1.32)-    \ Testing.checkBetween<?>(Math.asinh(2.0),1.44,1.45)-    \ Testing.checkBetween<?>(Math.atanh(0.5),0.54,0.55)-    \ Testing.checkBetween<?>(Math.exp(1.0),2.71,2.72)-    \ Testing.checkBetween<?>(Math.log(9.0),2.19,2.20)-    \ Testing.checkBetween<?>(Math.log10(100.0),1.99,2.01)-    \ Testing.checkBetween<?>(Math.log2(8.0),2.99,3.01)-    \ Testing.checkBetween<?>(Math.pow(2.0,3.0),7.99,8.01)-    \ Testing.checkBetween<?>(Math.sqrt(4.0),1.99,2.01)-    \ Testing.checkBetween<?>(Math.ceil(2.2),2.99,3.01)-    \ Testing.checkBetween<?>(Math.floor(2.2),1.99,2.01)-    \ Testing.checkBetween<?>(Math.fmod(7.0,4.0),2.99,3.01)-    \ Testing.checkBetween<?>(Math.trunc(2.2),1.99,2.01)-    \ Testing.checkBetween<?>(Math.round(2.7),2.99,3.01)-    \ Testing.checkBetween<?>(Math.fabs(-10.0),9.99,10.01)-    if (!Math.isinf(Math.log(0.0))) {-      fail("Failed")-    }-    if (!Math.isnan(Math.sqrt(-1.0))) {-      fail("Failed")-    }+unittest cos {+  \ Testing.checkBetween<?>(Math.cos(2.0),-0.42,-0.41)+}++unittest sin {+  \ Testing.checkBetween<?>(Math.sin(2.0),0.90,0.91)+}++unittest tan {+  \ Testing.checkBetween<?>(Math.tan(2.0),-2.19,-2.18)+}++unittest acos {+  \ Testing.checkBetween<?>(Math.acos(0.5),1.04,1.05)+}++unittest asin {+  \ Testing.checkBetween<?>(Math.asin(0.5),0.52,0.53)+}++unittest atan {+  \ Testing.checkBetween<?>(Math.atan(0.5),0.46,0.47)+}++unittest cosh {+  \ Testing.checkBetween<?>(Math.cosh(2.0),3.76,3.77)+}++unittest sinh {+  \ Testing.checkBetween<?>(Math.sinh(2.0),3.62,3.63)+}++unittest tanh {+  \ Testing.checkBetween<?>(Math.tanh(2.0),0.96,0.97)+}++unittest acosh {+  \ Testing.checkBetween<?>(Math.acosh(2.0),1.31,1.32)+}++unittest asinh {+  \ Testing.checkBetween<?>(Math.asinh(2.0),1.44,1.45)+}++unittest atanh {+  \ Testing.checkBetween<?>(Math.atanh(0.5),0.54,0.55)+}++unittest exp {+  \ Testing.checkBetween<?>(Math.exp(1.0),2.71,2.72)+}++unittest log {+  \ Testing.checkBetween<?>(Math.log(9.0),2.19,2.20)+}++unittest log10 {+  \ Testing.checkBetween<?>(Math.log10(100.0),1.99,2.01)+}++unittest log2 {+  \ Testing.checkBetween<?>(Math.log2(8.0),2.99,3.01)+}++unittest pow {+  \ Testing.checkBetween<?>(Math.pow(2.0,3.0),7.99,8.01)+}++unittest sqrt {+  \ Testing.checkBetween<?>(Math.sqrt(4.0),1.99,2.01)+}++unittest ceil {+  \ Testing.checkBetween<?>(Math.ceil(2.2),2.99,3.01)+}++unittest floor {+  \ Testing.checkBetween<?>(Math.floor(2.2),1.99,2.01)+}++unittest fmod {+  \ Testing.checkBetween<?>(Math.fmod(7.0,4.0),2.99,3.01)+}++unittest trunc {+  \ Testing.checkBetween<?>(Math.trunc(2.2),1.99,2.01)+}++unittest round {+  \ Testing.checkBetween<?>(Math.round(2.7),2.99,3.01)+}++unittest fabs {+  \ Testing.checkBetween<?>(Math.fabs(-10.0),9.99,10.01)+}++unittest isinf {+  if (!Math.isinf(Math.log(0.0))) {+    fail("Failed")   } } -concrete Test {-  @type run () -> ()+unittest isnan {+  if (!Math.isnan(Math.sqrt(-1.0))) {+    fail("Failed")+  } }

@@ -0,0 +1,3 @@+root: ".."+path: "testing"+mode: incremental {}

@@ -0,0 +1,32 @@+/* -----------------------------------------------------------------------------+Copyright 2020 Kevin P. Barry++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+----------------------------------------------------------------------------- */++// Author: Kevin P. Barry [ta0kira@gmail.com]++$TestsOnly$++concrete Testing {+  @type checkEquals<#x>+    #x requires Formatted+    #x defines Equals<#x>+  (#x /*actual*/, #x /*expected*/) -> ()++  @type checkBetween<#x>+    #x requires Formatted+    #x defines Equals<#x>+    #x defines LessThan<#x>+  (#x /*actual*/, #x /*lower*/, #x /*upper*/) -> ()+}

@@ -0,0 +1,60 @@+/* -----------------------------------------------------------------------------+Copyright 2020 Kevin P. Barry++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+----------------------------------------------------------------------------- */++// Author: Kevin P. Barry [ta0kira@gmail.com]++$TestsOnly$++define Testing {+  checkEquals (x,y) {+    if (!#x.equals(x,y)) {+      fail(String.builder()+        .append(x.formatted())+        .append(" is not equal to ")+        .append(y.formatted())+        .build())+    }+  }++  checkBetween (x,l,h) {+    if (!lessEquals<?>(l,h)) {+      fail(String.builder()+        .append("Upper limit ")+        .append(l.formatted())+        .append(" is not at or above lower limit ")+        .append(h.formatted())+        .build())+    }+    if (!lessEquals<?>(l,x) || !lessEquals<?>(x,h)) {+      fail(String.builder()+        .append(x.formatted())+        .append(" is not between ")+        .append(l.formatted())+        .append(" and ")+        .append(h.formatted())+        .build())+    }+  }++  @type lessEquals<#x>+    #x defines Equals<#x>+    #x defines LessThan<#x>+  (#x,#x) -> (Bool)+  lessEquals (x,y) {+    // Using !#x.lessThan(y,x) wouldn't account for NaNs.+    return #x.lessThan(x,y) || #x.equals(x,y)+  }+}

@@ -0,0 +1,69 @@+/* -----------------------------------------------------------------------------+Copyright 2020 Kevin P. Barry++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+----------------------------------------------------------------------------- */++// Author: Kevin P. Barry [ta0kira@gmail.com]++testcase "checkEquals success" {+  success+}++unittest test {+  \ Testing.checkEquals<?>(13,13)+}+++testcase "checkEquals fail" {+  crash+  require stderr "13"+  require stderr "15"+}++unittest test {+  \ Testing.checkEquals<?>(13,15)+}+++testcase "checkBetween success" {+  success+}++unittest test {+  \ Testing.checkBetween<?>(13,13,15)+}+++testcase "checkBetween fail" {+  crash+  require stderr "13"+  require stderr "14"+  require stderr "15"+}++unittest test {+  \ Testing.checkBetween<?>(13,14,15)+}+++testcase "checkBetween bad range" {+  crash+  exclude stderr "14"+  require stderr "13"+  require stderr "15"+}++unittest test {+  \ Testing.checkBetween<?>(14,15,13)+}

@@ -7,7 +7,7 @@   } ] private_deps: [-  "../../tests"+  "lib/testing" ] extra_files: [   category_source {

@@ -142,7 +142,7 @@   const PrimInt Var_arg1 = (args.At(0))->AsInt();   const PrimInt Var_arg2 = (args.At(1))->AsInt();   if (Var_arg1 < 0 || (Var_arg1 > 0 && Var_arg1 >= GetSize())) {-    FAIL() << "Subsequence position " << Var_arg1 << " is out of bounds";+    FAIL() << "Subsequence index " << Var_arg1 << " is out of bounds";   }   if (Var_arg2 < 0 || Var_arg1 + Var_arg2 > GetSize()) {     FAIL() << "Subsequence size " << Var_arg2 << " is invalid";

@@ -17,233 +17,135 @@ // Author: Kevin P. Barry [ta0kira@gmail.com]  testcase "stdout writer" {-  success Test.run()+  success   require stdout "message"   exclude stderr "message" } -define Test {-  run () {-    \ LazyStream<Formatted>.new().append("message").writeTo(SimpleOutput.stdout())-  }-}--concrete Test {-  @type run () -> ()+unittest test {+  \ LazyStream<Formatted>.new().append("message").writeTo(SimpleOutput.stdout()) }   testcase "stderr writer" {-  success Test.run()+  success   require stderr "message"   exclude stdout "message" } -define Test {-  run () {-    \ LazyStream<Formatted>.new().append("message").writeTo(SimpleOutput.stderr())-  }-}--concrete Test {-  @type run () -> ()+unittest test {+  \ LazyStream<Formatted>.new().append("message").writeTo(SimpleOutput.stderr()) }   testcase "error writer" {-  crash Test.run()+  crash   require "message" } -define Test {-  run () {-    \ LazyStream<Formatted>.new().append("message").writeTo(SimpleOutput.error())-  }-}--concrete Test {-  @type run () -> ()+unittest test {+  \ LazyStream<Formatted>.new().append("message").writeTo(SimpleOutput.error()) }  -testcase "iterate String forward" {-  success Test.run()+testcase "iterate ReadIterator" {+  success } -define Test {-  run () {-    String s <- "abcde"-    Int count <- 0-    scoped {-      ReadIterator<Char> iter <- ReadIterator:fromReadPosition<Char>(s)-    } in while (!iter.pastForwardEnd()) {-      if (iter.readCurrent() != s.readPosition(count)) {-        fail(iter.readCurrent())-      }-    } update {-      count <- count+1-      iter <- iter.forward()-    }-    if (count != s.readSize()) {-     fail(count)+unittest forward {+  String s <- "abcde"+  Int count <- 0+  scoped {+    ReadIterator<Char> iter <- ReadIterator:fromReadPosition<Char>(s)+  } in while (!iter.pastForwardEnd()) {+    if (iter.readCurrent() != s.readPosition(count)) {+      fail(iter.readCurrent())     }+  } update {+    count <- count+1+    iter <- iter.forward()   }-}--concrete Test {-  @type run () -> ()-}---testcase "iterate String reverse" {-  success Test.run()+  if (count != s.readSize()) {+    fail(count)+  } } -define Test {-  run () {-    String s <- "abcde"-    Int count <- s.readSize()-1-    scoped {-      ReadIterator<Char> iter <- ReadIterator:fromReadPositionAt<Char>(s,count)-    } in while (!iter.pastReverseEnd()) {-      if (iter.readCurrent() != s.readPosition(count)) {-        fail(iter.readCurrent())-      }-    } update {-      count <- count-1-      iter <- iter.reverse()-    }-    if (count != -1) {-     fail(count)+unittest reverse {+  String s <- "abcde"+  Int count <- s.readSize()-1+  scoped {+    ReadIterator<Char> iter <- ReadIterator:fromReadPositionAt<Char>(s,count)+  } in while (!iter.pastReverseEnd()) {+    if (iter.readCurrent() != s.readPosition(count)) {+      fail(iter.readCurrent())     }+  } update {+    count <- count-1+    iter <- iter.reverse()   }-}--concrete Test {-  @type run () -> ()+  if (count != -1) {+    fail(count)+  } }  -testcase "Argv is set and available" {-  success Test.run()-  require stdout "/testcase$"+testcase "Argv checks" {+  success+  args "arg1" "arg2" "arg3" "arg4" } -define Test {-  run () {-    Int count <- Argv.global().readSize()-    if (count != 1) {-      fail(count)-    }-    String name <- Argv.global().readPosition(0)-    \ LazyStream<Formatted>.new()-        .append(name)-        .append("\n")-        .writeTo(SimpleOutput.stdout())+unittest global {+  Int count <- Argv.global().readSize()+  if (count != 5) {+    fail(count)   }+  \ Testing.checkEquals<?>(Argv.global().readPosition(0),"testcase")+  \ Testing.checkEquals<?>(Argv.global().readPosition(1),"arg1")+  \ Testing.checkEquals<?>(Argv.global().readPosition(2),"arg2")+  \ Testing.checkEquals<?>(Argv.global().readPosition(3),"arg3")+  \ Testing.checkEquals<?>(Argv.global().readPosition(4),"arg4") } -concrete Test {-  @type run () -> ()+unittest subSequence {+  ReadPosition<String> argv <- Argv.global().subSequence(2,2)+  Int count <- argv.readSize()+  if (count != 2) {+    fail(count)+  }+  \ Testing.checkEquals<?>(argv.readPosition(0),"arg2")+  \ Testing.checkEquals<?>(argv.readPosition(1),"arg3") }  -testcase "Argv subSequence" {-  success Test.run()-  require stdout "/testcase$"-}--define Test {-  run () {-    ReadPosition<String> argv <- Argv.global().subSequence(0,1)-    Int count <- argv.readSize()-    if (count != 1) {-      fail(count)-    }-    String name <- argv.readPosition(0)-    \ LazyStream<Formatted>.new()-        .append(name)-        .append("\n")-        .writeTo(SimpleOutput.stdout())-  }+testcase "Argv readPosition out of bounds" {+  crash+  require "index 5" } -concrete Test {-  @type run () -> ()+unittest test {+  \ Argv.global().readPosition(5) }   testcase "Argv subSequence out of bounds" {-  crash Test.run()-  require "position 5"-}--define Test {-  run () {-    ReadPosition<String> argv <- Argv.global().subSequence(5,1)-  }+  crash+  require "index 5" } -concrete Test {-  @type run () -> ()+unittest test {+  \ Argv.global().subSequence(5,1) }  -testcase "TextReader splits lines correctly" {-  success Test.run()-}--concrete FakeFile {-  refines BlockReader<String>--  @type create () -> (FakeFile)+testcase "TextReader checks" {+  success } -define FakeFile {-  @value Int counter--  create () {-    return FakeFile{ 0 }-  }--  readBlock (_) {-    cleanup {-      counter <- counter+1-    } in if (counter == 0) {-      return "this is a "-    } elif (counter == 1) {-      return "partial line\nwith "-    } elif (counter == 2) {-      return "some more data\nand\nmore lines"-    } elif (counter == 3) {-      return "\nunfinished"-    } else {-      fail("too many reads")-    }-  }--  pastEnd () {-    return counter > 3-  }+concrete Helper {+  @type checkNext (TextReader,String) -> () } -define Test {-  run () {-    TextReader reader <- TextReader.fromBlockReader(FakeFile.create())-    \ checkNext(reader,"this is a partial line")-    \ checkNext(reader,"with some more data")-    \ checkNext(reader,"and")-    \ checkNext(reader,"more lines")-    \ checkNext(reader,"unfinished")-    if (!reader.pastEnd()) {-      fail("not past end")-    }-    if (reader.readNextLine() != "") {-      fail("reused data")-    }-  }--  @type checkNext (TextReader,String) -> ()+define Helper {   checkNext (reader,line) {     if (reader.pastEnd()) {       fail("past end")@@ -255,15 +157,6 @@   } } -concrete Test {-  @type run () -> ()-}---testcase "TextReader readAll" {-  success Test.run()-}- concrete FakeFile {   refines BlockReader<String> @@ -298,103 +191,72 @@   } } -define Test {-  run () {-    String allContents <- TextReader.readAll(FakeFile.create())-    \ Testing.check<?>(allContents,"this is a partial line\nwith some more data\nand\nmore lines\nunfinished")-  }+unittest correctSplit {+    TextReader reader <- TextReader.fromBlockReader(FakeFile.create())+    \ Helper.checkNext(reader,"this is a partial line")+    \ Helper.checkNext(reader,"with some more data")+    \ Helper.checkNext(reader,"and")+    \ Helper.checkNext(reader,"more lines")+    \ Helper.checkNext(reader,"unfinished")+    if (!reader.pastEnd()) {+      fail("not past end")+    }+    if (reader.readNextLine() != "") {+      fail("reused data")+    } } -concrete Test {-  @type run () -> ()+unittest readAll {+  String allContents <- TextReader.readAll(FakeFile.create())+  \ Testing.checkEquals<?>(allContents,"this is a partial line\nwith some more data\nand\nmore lines\nunfinished") }  -testcase "ErrorOr value" {-  success Test.run()+testcase "ErrorOr checks" {+  success } -define Test {-  run () {-    ErrorOr<Int> value <- ErrorOr:value<Int>(10)-    if (value.isError()) {-      fail("Failed")-    }-    \ Testing.check<?>(value.getValue(),10)+unittest withValue {+  ErrorOr<Int> value <- ErrorOr:value<Int>(10)+  if (value.isError()) {+    fail("Failed")   }-}--concrete Test {-  @type run () -> ()-}---testcase "ErrorOr getError() crashes with value" {-  crash Test.run()-  require "empty"+  \ Testing.checkEquals<?>(value.getValue(),10) } -define Test {-  run () {-    ErrorOr<Int> value <- ErrorOr:value<Int>(10)-    \ value.getError()+unittest withError {+  ErrorOr<String> value <- ErrorOr:error("error message")+  if (!value.isError()) {+    fail("Failed")   }+  \ Testing.checkEquals<?>(value.getError().formatted(),"error message") } -concrete Test {-  @type run () -> ()+unittest convertError {+  scoped {+    ErrorOr<String> error <- ErrorOr:error("error message")+  } in ErrorOr<Int> value <- error.convertError()+  \ Testing.checkEquals<?>(value.getError().formatted(),"error message") }  -testcase "ErrorOr error" {-  success Test.run()-}--define Test {-  run () {-    ErrorOr<String> value <- ErrorOr:error("error message")-    if (!value.isError()) {-      fail("Failed")-    }-    \ Testing.check<?>(value.getError().formatted(),"error message")-  }+testcase "ErrorOr getError() crashes with value" {+  crash+  require "empty" } -concrete Test {-  @type run () -> ()+unittest test {+  ErrorOr<Int> value <- ErrorOr:value<Int>(10)+  \ value.getError() }   testcase "ErrorOr getValue() crashes with error" {-  crash Test.run()+  crash   require "error message" } -define Test {-  run () {-    ErrorOr<String> value <- ErrorOr:error("error message")-    \ value.getValue()-  }-}--concrete Test {-  @type run () -> ()-}---testcase "ErrorOr convert error" {-  success Test.run()-}--define Test {-  run () {-    scoped {-      ErrorOr<String> error <- ErrorOr:error("error message")-    } in ErrorOr<Int> value <- error.convertError()-    \ Testing.check<?>(value.getError().formatted(),"error message")-  }-}--concrete Test {-  @type run () -> ()+unittest test {+  ErrorOr<String> value <- ErrorOr:error("error message")+  \ value.getValue() }

@@ -68,15 +68,19 @@  (<??) :: CompileErrorM m => m a -> String -> m a (<??) = withContextM+infixl 1 <??  (??>) :: CompileErrorM m => String -> m a -> m a (??>) = flip withContextM+infixr 1 ??>  (<!!) :: CompileErrorM m => m a -> String -> m a (<!!) = summarizeErrorsM+infixl 1 <!!  (!!>) :: CompileErrorM m => String -> m a -> m a (!!>) = flip summarizeErrorsM+infixr 1 !!>  collectAllM_ :: (Foldable f, CompileErrorM m) => f (m a) -> m () collectAllM_ = fmap (const ()) . collectAllM

@@ -60,9 +60,9 @@ import Base.CompileError  -type CompileInfo a = CompileInfoT Identity a+type CompileInfo = CompileInfoT Identity -type CompileInfoIO a = CompileInfoT IO a+type CompileInfoIO = CompileInfoT IO  data CompileInfoT m a =   CompileInfoT {

@@ -23,6 +23,8 @@ module Base.Mergeable (   Mergeable(..),   PreserveMerge(..),+  (<||>),+  (<&&>), ) where  import Data.Map as Map hiding (foldr)@@ -36,10 +38,18 @@   type T a :: *   convertMerge :: Mergeable b => (T a -> b) -> a -> b +(<||>) :: Mergeable a => a -> a -> a+(<||>) x y = mergeAny [x,y]+infixl 2 <||>++(<&&>) :: Mergeable a => a -> a -> a+(<&&>) x y = mergeAll [x,y]+infixl 2 <&&>+ instance Mergeable Bool where   mergeAny = foldr (||) False   mergeAll = foldr (&&) True  instance (Ord k, Mergeable a) => Mergeable (Map k a) where-  mergeAny = Map.fromListWith (\x y -> mergeAny [x,y]) . foldr ((++) . Map.toList) []-  mergeAll = Map.fromListWith (\x y -> mergeAll [x,y]) . foldr ((++) . Map.toList) []+  mergeAny = Map.fromListWith (<||>) . foldr ((++) . Map.toList) []+  mergeAll = Map.fromListWith (<&&>) . foldr ((++) . Map.toList) []

@@ -210,8 +210,8 @@             coNamespace = case c `Map.lookup` ca of                                Just ns2 -> ns2                                Nothing  -> NoNamespace,-            coUsesNamespace = [ns0,ns1],-            coUsesCategory = ds2,+            coUsesNamespace = Set.fromList [ns0,ns1],+            coUsesCategory = Set.fromList ds2,             coOutput = []           }     compileExtraSource _ _ paths (OtherSource f2) = do@@ -314,9 +314,9 @@   [WithVisibility (AnyCategory c)] -> LanguageModule c createLanguageModule ex ss em cs = lm where   lm = LanguageModule {-      lmPublicNamespaces  = map wvData $ apply ns [with    FromDependency,without ModuleOnly,without TestsOnly],-      lmPrivateNamespaces = map wvData $ apply ns [with    FromDependency,with    ModuleOnly,without TestsOnly],-      lmLocalNamespaces   = map wvData $ apply ns [without FromDependency],+      lmPublicNamespaces  = Set.fromList $ map wvData $ apply ns [with    FromDependency,without ModuleOnly],+      lmPrivateNamespaces = Set.fromList $ map wvData $ apply ns [with    FromDependency,with    ModuleOnly],+      lmLocalNamespaces   = Set.fromList $ map wvData $ apply ns [without FromDependency],       lmPublicDeps        = map wvData $ apply cs [with    FromDependency,without ModuleOnly,without TestsOnly],       lmPrivateDeps       = map wvData $ apply cs [with    FromDependency,with    ModuleOnly,without TestsOnly],       lmTestingDeps       = map wvData $ apply cs [with    FromDependency,with TestsOnly],

@@ -61,7 +61,8 @@ data TestCommand =   TestCommand {     tcBinary :: String,-    tcPath :: String+    tcPath :: String,+    tcArgs :: [String]   }   deriving (Show) 

@@ -70,7 +70,7 @@     processResults passed failed rs       | isCompileError rs =         (fromCompileInfo rs) <!!-          ("\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)")+          "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)"       | otherwise =         errorFromIO $ hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)" @@ -103,24 +103,24 @@     msMode = (CompileBinary c fn (absolute </> show c) []),     msForce = f   }-  compileModule resolver backend spec <?? ("In compilation of \"" ++ f2' ++ "\"")+  compileModule resolver backend spec <?? "In compilation of \"" ++ f2' ++ "\""   errorFromIO $ removeDirectoryRecursive dir  runCompiler resolver backend (CompileOptions h _ _ ds _ _ p CompileRecompileRecursive f) = do-  foldM (recursive resolver) Set.empty ds >> return () where-    recursive r da d0 = do-      isSystem <- isSystemModule r p d0+  foldM (recursive resolver) Set.empty (map ((,) p) ds) >> return () where+    recursive r da (p2,d0) = do+      isSystem <- isSystemModule r p2 d0       if isSystem          then do-           compileWarningM $ "Skipping system module " ++ d0 ++ "."+           compileWarningM $ "Skipping system dependency " ++ d0 ++ " for " ++ p2 ++ "."            return da          else do-           d <- errorFromIO $ canonicalizePath (p </> d0)+           d <- errorFromIO $ canonicalizePath (p2 </> d0)            rm <- loadRecompile d            if mcPath rm `Set.member` da                then return da                else do-                 let ds3 = map (\d2 -> d </> d2) (mcPublicDeps rm ++ mcPrivateDeps rm)+                 let ds3 = map ((,) d) (mcPublicDeps rm ++ mcPrivateDeps rm)                  da' <- foldM (recursive r) (mcPath rm `Set.insert` da) ds3                  runCompiler resolver backend (CompileOptions h [] [] [d] [] [] p CompileRecompile f)                  return da'@@ -155,7 +155,7 @@              msMode = m,              msForce = f            }-           compileModule resolver backend spec <?? ("In compilation of module \"" ++ d ++ "\"")+           compileModule resolver backend spec <?? "In compilation of module \"" ++ d ++ "\""  runCompiler resolver backend (CompileOptions _ is is2 ds _ _ p CreateTemplates f) = mapM_ compileSingle ds where   compilerHash = getCompilerHash backend@@ -167,7 +167,7 @@     deps1 <- loadPublicDeps compilerHash f Map.empty (base:as)     deps2 <- loadPublicDeps compilerHash f (mapMetadata deps1) as2     path <- errorFromIO $ canonicalizePath p-    createModuleTemplates resolver path d deps1 deps2 <?? ("In module \"" ++ d' ++ "\"")+    createModuleTemplates resolver path d deps1 deps2 <?? "In module \"" ++ d' ++ "\""  runCompiler resolver backend (CompileOptions h is is2 ds es ep p m f) = mapM_ compileSingle ds where   compileSingle d = do

@@ -22,13 +22,15 @@  import Control.Arrow (second) import Control.Monad (when)-import Data.List (isSuffixOf,nub)+import Control.Monad.IO.Class+import Data.List (isSuffixOf,nub,sort) import System.Directory import System.IO import System.Posix.Temp (mkdtemp) import System.FilePath import Text.Parsec import Text.Regex.TDFA -- Not safe!+import qualified Data.Map as Map  import Base.CompileError import Base.CompileInfo@@ -40,6 +42,7 @@ import Module.ProcessMetadata import Parser.SourceFile import Types.IntegrationTest+import Types.Procedure import Types.TypeCategory  @@ -56,33 +59,57 @@         return ((0,1),ts >> return ())       | otherwise = do           let (_,ts') = getCompileSuccess ts-          allResults <- sequence $ map runSingle ts'-          let passed = length $ filter (not . isCompileError) allResults-          let failed = length $ filter isCompileError allResults-          return ((passed,failed),collectAllM_ allResults)+          allResults <- mapErrorsM runSingle ts'+          let passed = sum $ map (fst . fst) allResults+          let failed = sum $ map (snd . fst) allResults+          let result = collectAllM_ $ map snd allResults+          return ((passed,failed),result)+     runSingle t = do       let name = "\"" ++ ithTestName (itHeader t) ++ "\" (from " ++ f ++ ")"       let context = formatFullContextBrace (ithContext $ itHeader t)-      errorFromIO $ hPutStrLn stderr $ "\n*** Executing test " ++ name ++ " ***"-      outcome <- fmap (("\nIn test \"" ++ ithTestName (itHeader t) ++ "\"" ++ context) ??>) $-                   run (ithResult $ itHeader t) (itCategory t) (itDefinition t)-      if isCompileError outcome-         then errorFromIO $ hPutStrLn stderr $ "*** Test " ++ name ++ " failed ***"-         else errorFromIO $ hPutStrLn stderr $ "*** Test " ++ name ++ " passed ***"-      return outcome+      let scope = "\nIn testcase \"" ++ ithTestName (itHeader t) ++ "\"" ++ context+      errorFromIO $ hPutStrLn stderr $ "\n*** Executing testcase " ++ name ++ " ***"+      result <- toCompileInfo $ run (ithResult $ itHeader t) (ithArgs $ itHeader t) (itCategory t) (itDefinition t) (itTests t)+      if isCompileError result+         then return ((0,1),scope ??> (result >> return ()))+         else do+           let allResults = getCompileSuccess result+           let passed = length $ filter (not . isCompileError) allResults+           let failed = length $ filter isCompileError allResults+           let combined = scope ??> collectAllM_ allResults+           if failed > 0+             then errorFromIO $ hPutStrLn stderr $ "*** Some tests in testcase " ++ name ++ " failed ***"+             else errorFromIO $ hPutStrLn stderr $ "*** All tests in testcase " ++ name ++ " passed ***"+           return ((passed,failed),combined) -    run (ExpectCompileError _ rs es) cs ds = do-      let result = compileAll Nothing cs ds+    run (ExpectCompileError _ rs es) args cs ds ts = do+      let result = compileAll args cs ds ts       if not $ isCompileError result-         then undefined  -- Should be caught in compileAll.-         else return $ do+         then compileErrorM "Expected compilation failure"+         else fmap (:[]) $ return $ do            let warnings = show $ getCompileWarnings result            let errors   = show $ getCompileError result            checkContent rs es (lines warnings ++ lines errors) [] [] -    run (ExpectRuntimeError   _ e rs es) cs ds = execute False e rs es cs ds-    run (ExpectRuntimeSuccess _ e rs es) cs ds = execute True  e rs es cs ds+    run (ExpectCompiles _ rs es) args cs ds ts = do+      let result = compileAll args cs ds ts+      if isCompileError result+         then fromCompileInfo result >> return []+         else fmap (:[]) $ return $ do+           let warnings = show $ getCompileWarnings result+           checkContent rs es (lines warnings) [] [] +    run (ExpectRuntimeError _ rs es) args cs ds ts = do+      when (length ts /= 1) $ compileErrorM "Exactly one unittest is required when crash is expected"+      uniqueTestNames ts+      execute False rs es args cs ds ts++    run (ExpectRuntimeSuccess _ rs es) args cs ds ts = do+      when (null ts) $ compileErrorM "At least one unittest is required when success is expected"+      uniqueTestNames ts+      execute True rs es args cs ds ts+     checkContent rs es comp err out = do       let cr = checkRequired rs comp err out       let ce = checkExcluded es comp err out@@ -99,42 +126,44 @@          then collectAllM_ [cr,ce,compError,errError,outError]          else collectAllM_ [cr,ce] -    execute s2 e rs es cs ds = toCompileInfo $ do-      let result = compileAll (Just e) cs ds+    uniqueTestNames ts = do+      let ts' = Map.fromListWith (++) $ map (\t -> (tpName t,[t])) ts+      mapErrorsM_ testClash $ Map.toList ts'+    testClash (_,[_]) = return ()+    testClash (n,ts) = "unittest " ++ show n ++ " is defined multiple times" !!>+      (mapErrorsM_ (compileErrorM . ("Defined at " ++) . formatFullContext) $ sort $ map tpContext ts)++    execute s2 rs es args cs ds ts = do+      let result = compileAll args cs ds ts       if isCompileError result-         then fromCompileInfo result >> return ()+         then return [result >> return ()]          else do-           let warnings = getCompileWarnings result-           let (xx,main) = getCompileSuccess result+           let (xx,main,fs) = getCompileSuccess result            (dir,binaryName) <- createBinary main xx-           let command = TestCommand binaryName (takeDirectory binaryName)-           (TestCommandResult s2' out err) <- runTestCommand b command-           case (s2,s2') of-                (True,False) -> collectAllM_ $ (asCompileError result):(map compileErrorM $ err ++ out)-                (False,True) ->-                  if isEmptyCompileMessage warnings-                     then compileErrorM "Expected runtime failure"-                     else collectAllM_ [compileErrorM "Expected runtime failure",-                                        asCompileError result <?? "\nOutput from compiler:"]-                _ -> do-                  let result2 = checkContent rs es (lines $ show warnings) err out-                  when (not $ isCompileError result2) $ errorFromIO $ removeDirectoryRecursive dir-                  fromCompileInfo result2+           results <- liftIO $ sequence $ map (toCompileInfo . executeTest binaryName rs es result s2) fs+           when (not $ any isCompileError results) $ errorFromIO $ removeDirectoryRecursive dir+           return results -    compileAll e cs ds = do+    executeTest binary rs es res s2 (f2,c) = printOutcome $ "\nIn unittest " ++ show f2 ++ formatFullContextBrace c ??> do+      let command = TestCommand binary (takeDirectory binary) [show f2]+      (TestCommandResult s2' out err) <- runTestCommand b command+      case (s2,s2') of+           (True,False) -> collectAllM_ $ (asCompileError res):(map compileErrorM $ err ++ out)+           (False,True) -> collectAllM_ [compileErrorM "Expected runtime failure",+                                         asCompileError res <?? "\nOutput from compiler:"]+           _ -> fromCompileInfo $ checkContent rs es (lines $ show $ getCompileWarnings res) err out+      where+        printOutcome outcome = do+          failed <- isCompileErrorM outcome+          if failed+             then errorFromIO $ hPutStrLn stderr $ "--- unittest " ++ show f2 ++ " failed ---"+             else errorFromIO $ hPutStrLn stderr $ "--- unittest " ++ show f2 ++ " passed ---"+          outcome++    compileAll args cs ds ts = do       let ns1 = StaticNamespace $ privateNamespace s       let cs' = map (setCategoryNamespace ns1) cs-      let xs = PrivateSource {-          psNamespace = ns1,-          psTesting = True,-          psCategory = cs',-          psDefine = ds-        }-      xx <- compileLanguageModule cm [xs]-      main <- case e of-                   Just e2 -> compileTestMain cm xs e2-                   Nothing -> compileErrorM ""-      return (xx,main)+      compileTestsModule cm ns1 args cs' ds ts      checkRequired rs comp err out = mapErrorsM_ (checkSubsetForRegex True  comp err out) rs     checkExcluded es comp err out = mapErrorsM_ (checkSubsetForRegex False comp err out) es

@@ -58,6 +58,8 @@   csPrimNamedReturns,   csPushCleanup,   csRegisterReturn,+  csReleaseExprMacro,+  csReserveExprMacro,   csRequiresTypes,   csResolver,   csSameType,@@ -87,6 +89,7 @@ import Base.CompileError import Types.DefinedCategory import Types.Positional+import Types.Pragma (MacroName) import Types.Procedure import Types.TypeCategory import Types.TypeInstance@@ -123,7 +126,9 @@   ccStartCleanup :: a -> m a   ccPushCleanup :: a -> CleanupSetup a s -> m a   ccGetCleanup :: a -> JumpType -> m (CleanupSetup a s)-  ccExprLookup :: a -> [c] -> String -> m (Expression c)+  ccExprLookup :: a -> [c] -> MacroName -> m (Expression c)+  ccReserveExprMacro :: a -> [c] -> MacroName -> m a+  ccReleaseExprMacro :: a -> [c] -> MacroName -> m a   ccSetNoTrace :: a -> Bool -> m a   ccGetNoTrace :: a -> m Bool @@ -176,15 +181,19 @@  (<???) :: CompileErrorM m => CompilerState a m b -> String -> CompilerState a m b (<???) x s = mapStateT (<?? s) x+infixl 1 <???  (???>) :: CompileErrorM m => String -> CompilerState a m b -> CompilerState a m b (???>) s x = mapStateT (s ??>) x+infixr 1 ???>  (<!!!) :: CompileErrorM m => CompilerState a m b -> String -> CompilerState a m b (<!!!) x s = mapStateT (<!! s) x+infixl 1 <!!!  (!!!>) :: CompileErrorM m => String -> CompilerState a m b -> CompilerState a m b (!!!>) s x = mapStateT (s !!>) x+infixr 1 !!!>  resetBackgroundStateT :: CompileErrorM m => CompilerState a m b -> CompilerState a m b resetBackgroundStateT x = mapStateT resetBackgroundM x@@ -280,8 +289,14 @@ csGetCleanup :: CompilerContext c m s a => JumpType -> CompilerState a m (CleanupSetup a s) csGetCleanup j = fmap (\x -> ccGetCleanup x j) get >>= lift -csExprLookup :: CompilerContext c m s a => [c] -> String -> CompilerState a m (Expression c)+csExprLookup :: CompilerContext c m s a => [c] -> MacroName -> CompilerState a m (Expression c) csExprLookup c n = fmap (\x -> ccExprLookup x c n) get >>= lift++csReserveExprMacro :: CompilerContext c m s a => [c] -> MacroName -> CompilerState a m ()+csReserveExprMacro c n = fmap (\x -> ccReserveExprMacro x c n) get >>= lift >>= put++csReleaseExprMacro :: CompilerContext c m s a => [c] -> MacroName -> CompilerState a m ()+csReleaseExprMacro c n = fmap (\x -> ccReleaseExprMacro x c n) get >>= lift >>= put  csSetNoTrace :: CompilerContext c m s a => Bool -> CompilerState a m () csSetNoTrace t = fmap (\x -> ccSetNoTrace x t) get >>= lift >>= put

@@ -38,6 +38,7 @@ import Types.DefinedCategory import Types.GeneralType import Types.Positional+import Types.Pragma (MacroName) import Types.Procedure import Types.TypeCategory import Types.TypeInstance@@ -68,10 +69,11 @@     pcCleanupSetup :: [CleanupSetup (ProcedureContext c) [String]],     pcInCleanup :: Bool,     pcExprMap :: ExprMap c,+    pcReservedMacros :: [(MacroName,[c])],     pcNoTrace :: Bool   } -type ExprMap c = Map.Map String (Expression c)+type ExprMap c = Map.Map MacroName (Expression c)  data ReturnValidation c =   ValidatePositions {@@ -119,6 +121,7 @@       pcCleanupSetup = pcCleanupSetup ctx,       pcInCleanup = pcInCleanup ctx,       pcExprMap = pcExprMap ctx,+      pcReservedMacros = pcReservedMacros ctx,       pcNoTrace = pcNoTrace ctx     }   ccGetRequired = return . pcRequiredTypes@@ -152,7 +155,7 @@       compileErrorM $ "Use explicit type conversion to call " ++ show n ++ " from " ++ show t     getFromAll ts = do       collectFirstM ts <!!-        ("Function " ++ show n ++ " not available for type " ++ show t ++ formatFullContextBrace c)+        "Function " ++ show n ++ " not available for type " ++ show t ++ formatFullContextBrace c     getFromSingle (JustParamName _ p) = do       fa <- ccAllFilters ctx       fs <- case p `Map.lookup` fa of@@ -161,7 +164,7 @@       let ts = map tfType $ filter isRequiresFilter fs       let ds = map dfType $ filter isDefinesFilter  fs       collectFirstM (map (getFunction . Just) ts ++ map checkDefine ds) <!!-        ("Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c)+        "Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c     getFromSingle (JustTypeInstance t2)       -- Same category as the procedure itself.       | tiName t2 == pcType ctx =@@ -186,7 +189,7 @@         compileErrorM $ "Function " ++ show n ++ " in " ++ show t2 ++                        " is a category function" ++ formatFullContextBrace c       paired <- processPairs alwaysPair ps1 ps2 <??-        ("In external function call at " ++ formatFullContext c)+        "In external function call at " ++ formatFullContext c       let assigned = Map.fromList paired       uncheckedSubFunction assigned f     subAndCheckFunction t2 _ _ _ =@@ -197,7 +200,7 @@     | t /= pcType ctx =       compileErrorM $ "Category " ++ show (pcType ctx) ++ " cannot initialize values from " ++                      show t ++ formatFullContextBrace c-    | otherwise = ("In initialization at " ++ formatFullContext c) ??> do+    | otherwise = "In initialization at " ++ formatFullContext c ??> do       let t' = TypeInstance (pcType ctx) as       r <- ccResolver ctx       allFilters <- ccAllFilters ctx@@ -224,7 +227,7 @@           mapErrorsM (uncheckedSubFilter $ getValueForParam fm) fs         checkInit r fa (MemberValue c2 n t0) (i,t1) = do           checkValueAssignment r fa t1 t0 <??-            ("In initializer " ++ show i ++ " for " ++ show n ++ formatFullContextBrace c2)+            "In initializer " ++ show i ++ " for " ++ show n ++ formatFullContextBrace c2         subSingle pa (DefinedMember c2 _ t2 n _) = do           t2' <- uncheckedSubValueType (getValueForParam pa) t2           return $ MemberValue c2 n t2'@@ -263,6 +266,7 @@         pcCleanupSetup = pcCleanupSetup ctx,         pcInCleanup = pcInCleanup ctx,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }   ccCheckVariableInit ctx c n =@@ -295,6 +299,7 @@       pcCleanupSetup = pcCleanupSetup ctx,       pcInCleanup = pcInCleanup ctx,       pcExprMap = pcExprMap ctx,+      pcReservedMacros = pcReservedMacros ctx,       pcNoTrace = pcNoTrace ctx     }   ccGetOutput = return . pcOutput@@ -322,6 +327,7 @@         pcCleanupSetup = pcCleanupSetup ctx,         pcInCleanup = pcInCleanup ctx,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }   ccUpdateAssigned ctx n = update (pcReturns ctx) where@@ -349,6 +355,7 @@         pcCleanupSetup = pcCleanupSetup ctx,         pcInCleanup = pcInCleanup ctx,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }     update _ = return ctx@@ -376,6 +383,7 @@       pcCleanupSetup = pcCleanupSetup ctx,       pcInCleanup = pcInCleanup ctx,       pcExprMap = pcExprMap ctx,+      pcReservedMacros = pcReservedMacros ctx,       pcNoTrace = pcNoTrace ctx     }     where@@ -417,6 +425,7 @@         pcCleanupSetup = pcCleanupSetup ctx,         pcInCleanup = pcInCleanup ctx,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }     where@@ -426,17 +435,17 @@                        Just vs2 -> vs2         -- Check for a count match first, to avoid the default error message.         processPairs_ alwaysPair (fmap pvType rs) vs' <??-          ("In procedure return at " ++ formatFullContext c)+          "In procedure return at " ++ formatFullContext c         processPairs_ checkReturnType rs (Positional $ zip ([0..] :: [Int]) $ pValues vs') <??-          ("In procedure return at " ++ formatFullContext c)+          "In procedure return at " ++ formatFullContext c         return (ValidatePositions rs)         where           checkReturnType ta0@(PassedValue _ t0) (n,t) = do             r <- ccResolver ctx             pa <- ccAllFilters ctx             checkValueAssignment r pa t t0 <!!-              ("Cannot convert " ++ show t ++ " to " ++ show ta0 ++ " in return " ++-               show n ++ " at " ++ formatFullContext c)+              "Cannot convert " ++ show t ++ " to " ++ show ta0 ++ " in return " +++               show n ++ " at " ++ formatFullContext c       check (ValidateNames ns ts ra) = do         case vs of              Just _  -> check (ValidatePositions ts) >> return ()@@ -475,6 +484,7 @@         pcCleanupSetup = pcCleanupSetup ctx,         pcInCleanup = pcInCleanup ctx,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }   ccStartLoop ctx l =@@ -502,6 +512,7 @@         pcCleanupSetup = LoopBoundary:(pcCleanupSetup ctx),         pcInCleanup = pcInCleanup ctx,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }   ccGetLoop = return . pcLoopSetup@@ -531,6 +542,7 @@         pcCleanupSetup = pcCleanupSetup ctx,         pcInCleanup = True,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }     where@@ -565,6 +577,7 @@         pcCleanupSetup = cs:(pcCleanupSetup ctx),         pcInCleanup = pcInCleanup ctx,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }   ccGetCleanup ctx j = return combined where@@ -575,8 +588,73 @@     combine cs = CleanupSetup (concat $ map csReturnContext cs) (concat $ map csCleanup cs)   ccExprLookup ctx c n =     case n `Map.lookup` pcExprMap ctx of-         Nothing -> compileErrorM $ "Env expression " ++ n ++ " is not defined" ++ formatFullContextBrace c-         Just e -> return e+         Nothing -> compileErrorM $ "Env expression " ++ show n ++ " is not defined" ++ formatFullContextBrace c+         Just e -> do+           checkReserved (pcReservedMacros ctx) [(n,c)]+           return e+    where+      checkReserved [] _ = return ()+      checkReserved (m@(n2,_):ms) rs+        | n2 /= n = checkReserved ms (m:rs)+        | otherwise = (mapErrorsM_ singleError (m:rs)) <!!+            "Expression macro " ++ show n ++ " references itself"+      singleError (n2,c2) = compileErrorM $ show n2 ++ " expanded at " ++ formatFullContext c2+  ccReserveExprMacro ctx c n =+    return $ ProcedureContext {+        pcScope = pcScope ctx,+        pcType = pcType ctx,+        pcExtParams = pcExtParams ctx,+        pcIntParams = pcIntParams ctx,+        pcMembers = pcMembers ctx,+        pcCategories = pcCategories ctx,+        pcAllFilters = pcAllFilters ctx,+        pcExtFilters = pcExtFilters ctx,+        pcIntFilters = pcIntFilters ctx,+        pcParamScopes = pcParamScopes ctx,+        pcFunctions = pcFunctions ctx,+        pcVariables = pcVariables ctx,+        pcReturns = pcReturns ctx,+        pcJumpType = pcJumpType ctx,+        pcIsNamed = pcIsNamed ctx,+        pcPrimNamed = pcPrimNamed ctx,+        pcRequiredTypes = pcRequiredTypes ctx,+        pcOutput = pcOutput ctx,+        pcDisallowInit = pcDisallowInit ctx,+        pcLoopSetup = pcLoopSetup ctx,+        pcCleanupSetup = pcCleanupSetup ctx,+        pcInCleanup = pcInCleanup ctx,+        pcExprMap = pcExprMap ctx,+        pcReservedMacros = ((n,c):pcReservedMacros ctx),+        pcNoTrace = pcNoTrace ctx+      }+  ccReleaseExprMacro ctx _ n =+    return $ ProcedureContext {+        pcScope = pcScope ctx,+        pcType = pcType ctx,+        pcExtParams = pcExtParams ctx,+        pcIntParams = pcIntParams ctx,+        pcMembers = pcMembers ctx,+        pcCategories = pcCategories ctx,+        pcAllFilters = pcAllFilters ctx,+        pcExtFilters = pcExtFilters ctx,+        pcIntFilters = pcIntFilters ctx,+        pcParamScopes = pcParamScopes ctx,+        pcFunctions = pcFunctions ctx,+        pcVariables = pcVariables ctx,+        pcReturns = pcReturns ctx,+        pcJumpType = pcJumpType ctx,+        pcIsNamed = pcIsNamed ctx,+        pcPrimNamed = pcPrimNamed ctx,+        pcRequiredTypes = pcRequiredTypes ctx,+        pcOutput = pcOutput ctx,+        pcDisallowInit = pcDisallowInit ctx,+        pcLoopSetup = pcLoopSetup ctx,+        pcCleanupSetup = pcCleanupSetup ctx,+        pcInCleanup = pcInCleanup ctx,+        pcExprMap = pcExprMap ctx,+        pcReservedMacros = filter ((/= n) . fst) $ pcReservedMacros ctx,+        pcNoTrace = pcNoTrace ctx+      }   ccSetNoTrace ctx t =     return $ ProcedureContext {         pcScope = pcScope ctx,@@ -602,6 +680,7 @@         pcCleanupSetup = pcCleanupSetup ctx,         pcInCleanup = pcInCleanup ctx,         pcExprMap = pcExprMap ctx,+        pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = t       }   ccGetNoTrace = return . pcNoTrace

@@ -102,7 +102,7 @@       fa' <- fmap (Map.union fa) $ getFilterMap pi2 fi2       mapErrorsM_ (checkFilter r fa') fi2     checkFilter r fa (ParamFilter c2 n2 f) =-      validateTypeFilter r fa f <?? ("In " ++ show n2 ++ " " ++ show f ++ formatFullContextBrace c2)+      validateTypeFilter r fa f <?? "In " ++ show n2 ++ " " ++ show f ++ formatFullContextBrace c2     checkFunction pm f =       when (sfScope f == ValueScope) $         mapErrorsM_ (checkParam pm) $ pValues $ sfParams f

@@ -16,6 +16,7 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Safe #-} @@ -29,7 +30,7 @@   compileConcreteTemplate,   compileInterfaceDefinition,   compileModuleMain,-  compileTestMain,+  compileTestsModule, ) where  import Control.Monad (foldM,when)@@ -38,6 +39,11 @@ import qualified Data.Map as Map import qualified Data.Set as Set +#if MIN_VERSION_base(4,11,0)+#else+import Data.Semigroup+#endif+ import Base.CompileError import Base.MergeTree import Compilation.CompilerState@@ -63,17 +69,17 @@     coCategory :: Maybe CategoryName,     coFilename :: String,     coNamespace :: Namespace,-    coUsesNamespace :: [Namespace],-    coUsesCategory :: [CategoryName],+    coUsesNamespace :: Set.Set Namespace,+    coUsesCategory :: Set.Set CategoryName,     coOutput :: [String]   }   deriving (Show)  data LanguageModule c =   LanguageModule {-    lmPublicNamespaces :: [Namespace],-    lmPrivateNamespaces :: [Namespace],-    lmLocalNamespaces :: [Namespace],+    lmPublicNamespaces :: Set.Set Namespace,+    lmPrivateNamespaces :: Set.Set Namespace,+    lmLocalNamespaces :: Set.Set Namespace,     lmPublicDeps :: [AnyCategory c],     lmPrivateDeps :: [AnyCategory c],     lmTestingDeps :: [AnyCategory c],@@ -115,8 +121,8 @@     tmPublic  = foldM includeNewTypes defaultCategories [cs0,cs1]     tmPrivate = tmPublic  >>= \tm -> foldM includeNewTypes tm [ps0,ps1]     tmTesting = tmPrivate >>= \tm -> foldM includeNewTypes tm [ts0,ts1]-    nsPublic = ns0 ++ ns2-    nsPrivate = nsPublic ++ ns1+    nsPublic = ns0 `Set.union` ns2+    nsPrivate = ns1 `Set.union` nsPublic     nsTesting = nsPrivate     compileSourceP testing tm ns c = do       tm' <- tm@@ -147,7 +153,7 @@       hxx <- mapErrorsM (compileCategoryDeclaration testing tm' ns4) cs2       let interfaces = filter (not . isValueConcrete) cs2       cxx1 <- mapErrorsM (compileInterfaceDefinition testing) interfaces-      cxx2 <- mapErrorsM (compileDefinition testing tm' (ns:ns4)) ds+      cxx2 <- mapErrorsM (compileDefinition testing tm' (ns `Set.insert` ns4)) ds       return (ds,hxx ++ cxx1 ++ cxx2)     mergeGeneratedX ((ds,xx):xs2) = let (ds2,xx2) = mergeGeneratedX xs2 in (ds++ds2,xx++xx2)     mergeGeneratedX _             = ([],[])@@ -190,7 +196,7 @@              ("Category " ++ show (getCategoryName t) ++               formatFullContextBrace (getCategoryContext t) ++               " is defined " ++ show (length ds) ++ " times") !!>-               (mapErrorsM_ (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds)+                mapErrorsM_ (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds     checkSupefluous es2       | null es2 = return ()       | otherwise = compileErrorM $ "External categories either not concrete or not present: " ++@@ -199,12 +205,29 @@     streamlinedError n =       compileErrorM $ "Category " ++ show n ++ " cannot be streamlined because it was not declared external" +compileTestsModule :: (Show c, CompileErrorM m) =>+  LanguageModule c -> Namespace -> [String] -> [AnyCategory c] -> [DefinedCategory c] ->+  [TestProcedure c] -> m ([CxxOutput],CxxOutput,[(FunctionName,[c])])+compileTestsModule cm ns args cs ds ts = do+  let xs = PrivateSource {+      psNamespace = ns,+      psTesting = True,+      psCategory = cs,+      psDefine = ds+    }+  xx <- compileLanguageModule cm [xs]+  (main,fs) <- compileTestMain cm args xs ts+  return (xx,main,fs)+ compileTestMain :: (Show c, CompileErrorM m) =>-  LanguageModule c -> PrivateSource c -> Expression c -> m CxxOutput-compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ _ em) ts2 e = do+  LanguageModule c -> [String] -> PrivateSource c -> [TestProcedure c] ->+  m (CxxOutput,[(FunctionName,[c])])+compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ _ em) args ts2 tests = do   tm' <- tm-  (req,main) <- createTestFile tm' em e-  return $ CxxOutput Nothing testFilename NoNamespace ([psNamespace ts2]++ns0++ns1++ns2) req main where+  (CompiledData req main) <- createTestFile tm' em args tests+  let output = CxxOutput Nothing testFilename NoNamespace (psNamespace ts2 `Set.insert` Set.unions [ns0,ns1,ns2]) req main+  let tests' = map (\t -> (tpName t,tpContext t)) tests+  return (output,tests') where   tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1,psCategory ts2]  compileModuleMain :: (Show c, CompileErrorM m) =>@@ -216,22 +239,22 @@   let cs = filter (\c -> getCategoryName c == n) $ concat $ map psCategory xa   tm'' <- includeNewTypes tm' cs   (ns,main) <- createMainFile tm'' em n f-  return $ CxxOutput Nothing mainFilename NoNamespace ([ns]++ns0++ns1++ns2) [n] main where+  return $ CxxOutput Nothing mainFilename NoNamespace (ns `Set.insert` Set.unions [ns0,ns1,ns2]) (Set.fromList [n]) main where     tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1]     reconcile [_] = return ()     reconcile []  = compileErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)"     reconcile ds  =-      ("Multiple matches for main category " ++ show n) !!>+      "Multiple matches for main category " ++ show n !!>         mapErrorsM_ (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds  compileCategoryDeclaration :: (Show c, CompileErrorM m) =>-  Bool -> CategoryMap c -> [Namespace] -> AnyCategory c -> m CxxOutput+  Bool -> CategoryMap c -> Set.Set Namespace -> AnyCategory c -> m CxxOutput compileCategoryDeclaration testing _ ns t =   return $ CxxOutput (Just $ getCategoryName t)                      (headerFilename name)                      (getCategoryNamespace t)-                     (ns ++ [getCategoryNamespace t])-                     (Set.toList $ cdRequired file)+                     (getCategoryNamespace t `Set.insert` ns)+                     (cdRequired file)                      (cdOutput file) where     file = mconcat $ [         CompiledData depends [],@@ -265,7 +288,7 @@ compileInterfaceDefinition :: CompileErrorM m => Bool -> AnyCategory c -> m CxxOutput compileInterfaceDefinition testing t = do   te <- typeConstructor-  commonDefineAll testing t [] Nothing emptyCode emptyCode emptyCode te []+  commonDefineAll testing t Set.empty Nothing emptyCode emptyCode emptyCode te []   where     typeConstructor = do       let ps = map vpParam $ getCategoryParams t@@ -281,7 +304,7 @@   Bool -> CategoryMap c -> CategoryName -> m CxxOutput compileConcreteTemplate testing ta n = do   (_,t) <- getConcreteCategory ta ([],n)-  compileConcreteDefinition testing ta Map.empty [] Nothing (defined t) <?? ("In generated template for " ++ show n) where+  compileConcreteDefinition testing ta Map.empty Set.empty Nothing (defined t) <?? "In generated template for " ++ show n where     defined t = DefinedCategory {         dcContext = [],         dcName = getCategoryName t,@@ -311,7 +334,7 @@  compileConcreteStreamlined :: (Show c, CompileErrorM m) =>   Bool -> CategoryMap c -> CategoryName -> m [CxxOutput]-compileConcreteStreamlined testing ta n =  ("In streamlined compilation of " ++ show n) ??> do+compileConcreteStreamlined testing ta n =  "In streamlined compilation of " ++ show n ??> do   (_,t) <- getConcreteCategory ta ([],n)   let guard = if testing                  then testsOnlySourceGuard@@ -320,19 +343,19 @@   let hxx = CxxOutput (Just $ getCategoryName t)                       (headerStreamlined $ getCategoryName t)                       (getCategoryNamespace t)-                      [getCategoryNamespace t]-                      (getCategoryMentions t)+                      (Set.fromList [getCategoryNamespace t])+                      (Set.fromList $ getCategoryMentions t)                       guard   let cxx = CxxOutput (Just $ getCategoryName t)                       (sourceStreamlined $ getCategoryName t)                       (getCategoryNamespace t)-                      [getCategoryNamespace t]-                      (getCategoryMentions t)+                      (Set.fromList [getCategoryNamespace t])+                      (Set.fromList $ getCategoryMentions t)                       []   return [hxx,cxx]  compileConcreteDefinition :: (Show c, CompileErrorM m) =>-  Bool -> CategoryMap c -> ExprMap c -> [Namespace] -> Maybe [ValueRefine c] ->+  Bool -> CategoryMap c -> ExprMap c -> Set.Set Namespace -> Maybe [ValueRefine c] ->   DefinedCategory c -> m CxxOutput compileConcreteDefinition testing ta em ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do   (_,t) <- getConcreteCategory ta (c,n)@@ -413,7 +436,7 @@       concatM [           return $ onlyCode $ categoryName n ++ "()" ++ initColon ++ initMembersStr ++ " {",           return $ indentCompiled $ onlyCodes $ getCycleCheck (categoryName n),-          return $ indentCompiled $ onlyCode $ startFunctionTracing $ show n ++ " (init @category)",+          return $ indentCompiled $ onlyCode $ startInitTracing n CategoryScope,           return $ onlyCode "}",           return $ clearCompiled initMembers -- Inherit required types.         ]@@ -430,7 +453,7 @@       concatM [           return $ onlyCode $ typeName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {",           return $ indentCompiled $ onlyCodes $ getCycleCheck (typeName n),-          return $ indentCompiled $ onlyCode $ startFunctionTracing $ show n ++ " (init @type)",+          return $ indentCompiled $ onlyCode $ startInitTracing n TypeScope,           return $ indentCompiled $ initMembers,           return $ onlyCode "}"         ]@@ -447,11 +470,11 @@     unwrappedArg i m = writeStoredVariable (dmType m) (UnwrappedSingle $ "args.At(" ++ show i ++ ")")     createMember r filters m = do       validateGeneralInstance r filters (vtType $ dmType m) <??-        ("In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m))+        "In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)       return $ onlyCode $ variableStoredType (dmType m) ++ " " ++ variableName (dmName m) ++ ";"     createMemberLazy r filters m = do       validateGeneralInstance r filters (vtType $ dmType m) <??-        ("In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m))+        "In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)       return $ onlyCode $ variableLazyType (dmType m) ++ " " ++ variableName (dmName m) ++ ";"     categoryDispatch fs2 =       return $ onlyCodes $ [@@ -481,7 +504,7 @@       | otherwise = []  commonDefineAll :: CompileErrorM m =>-  Bool -> AnyCategory c -> [Namespace] -> Maybe [ValueRefine c] ->+  Bool -> AnyCategory c -> Set.Set Namespace -> Maybe [ValueRefine c] ->   CompiledData [String] -> CompiledData [String] -> CompiledData [String] ->   CompiledData [String] -> [ScopedFunction c] -> m CxxOutput commonDefineAll testing t ns rs top bottom ce te fe = do@@ -503,8 +526,8 @@   return $ CxxOutput (Just $ getCategoryName t)                      filename                      (getCategoryNamespace t)-                     ((getCategoryNamespace t):ns)-                     (Set.toList req)+                     (getCategoryNamespace t `Set.insert` ns)+                     req                      (guard ++ baseSourceIncludes ++ includes ++ out)   where     conditionalContent@@ -798,34 +821,41 @@       "}"     ] -createMainCommon :: String -> CompiledData [String] -> [String]-createMainCommon n (CompiledData req out) =-  baseSourceIncludes ++ mainSourceIncludes ++ depIncludes req ++ [+createMainCommon :: String -> CompiledData [String] -> CompiledData [String] -> [String]+createMainCommon n (CompiledData req0 out0) (CompiledData req1 out1) =+  baseSourceIncludes ++ mainSourceIncludes ++ depIncludes (req0 `Set.union` req1) ++ out0 ++ [       "int main(int argc, const char** argv) {",       "  SetSignalHandler();",-      "  ProgramArgv program_argv(argc, argv);",-      "  " ++ startFunctionTracing n-    ] ++ out ++ ["}"] where+      "  " ++ startFunctionTracing CategoryNone (FunctionName n)+    ] ++ map ("  " ++) out1 ++ ["}"] where       depIncludes req2 = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $                            Set.toList req2  createMainFile :: (Show c, CompileErrorM m) =>   CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String])-createMainFile tm em n f = ("In the creation of the main binary procedure") ??> do-  ca <- fmap indentCompiled (compileMainProcedure tm em expr)-  let file = noTestsOnlySourceGuard ++ createMainCommon "main" ca+createMainFile tm em n f = "In the creation of the main binary procedure" ??> do+  ca <- compileMainProcedure tm em expr+  let file = noTestsOnlySourceGuard ++ createMainCommon "main" emptyCode (argv <> ca)   (_,t) <- getConcreteCategory tm ([],n)   return (getCategoryNamespace t,file) where     funcCall = FunctionCall [] f (Positional []) (Positional [])     mainType = JustTypeInstance $ TypeInstance n (Positional [])     expr = Expression [] (TypeCall [] mainType funcCall) []+    argv = onlyCode "ProgramArgv program_argv(argc, argv);"  createTestFile :: (Show c, CompileErrorM m) =>-  CategoryMap c -> ExprMap c  -> Expression c -> m ([CategoryName],[String])-createTestFile tm em e = ("In the creation of the test binary procedure") ??> do-  ca@(CompiledData req _) <- fmap indentCompiled (compileMainProcedure tm em e)-  let file = testsOnlySourceGuard ++ createMainCommon "test" ca-  return (Set.toList req,file)+  CategoryMap c -> ExprMap c  -> [String] -> [TestProcedure c] -> m (CompiledData [String])+createTestFile tm em args ts = "In the creation of the test binary procedure" ??> do+  ts' <- fmap mconcat $ mapErrorsM (compileTestProcedure tm em) ts+  (include,sel) <- selectTestFromArgv1 $ map tpName ts+  let (CompiledData req _) = ts' <> sel+  let file = testsOnlySourceGuard ++ createMainCommon "testcase" (onlyCodes include <> ts') (argv <> sel)+  return $ CompiledData req file where+    args' = map escapeChars args+    argv = onlyCodes [+        "const char* argv2[] = { \"testcase\" " ++ concat (map (", " ++) args') ++ " };",+        "ProgramArgv program_argv(sizeof argv2 / sizeof(char*), argv2);"+      ]  getCategoryMentions :: AnyCategory c -> [CategoryName] getCategoryMentions t = fromRefines (getCategoryRefines t) ++

@@ -82,6 +82,7 @@       pcCleanupSetup = [],       pcInCleanup = False,       pcExprMap = em,+      pcReservedMacros = [],       pcNoTrace = False     } @@ -143,6 +144,7 @@       pcCleanupSetup = [],       pcInCleanup = False,       pcExprMap = em,+      pcReservedMacros = [],       pcNoTrace = False     }   where@@ -173,5 +175,6 @@     pcCleanupSetup = [],     pcInCleanup = False,     pcExprMap = em,+    pcReservedMacros = [],     pcNoTrace = False   }

@@ -41,6 +41,8 @@   showCreationTrace,   startCleanupTracing,   startFunctionTracing,+  startInitTracing,+  startTestTracing,   testsOnlyCategoryGuard,   testsOnlySourceGuard,   typeBase,@@ -85,8 +87,15 @@ clearCompiled :: CompiledData [String] -> CompiledData [String] clearCompiled (CompiledData r _) = CompiledData r [] -startFunctionTracing :: String -> String-startFunctionTracing f = "TRACE_FUNCTION(" ++ show f ++ ")"+startFunctionTracing :: CategoryName -> FunctionName -> String+startFunctionTracing CategoryNone f = "TRACE_FUNCTION(" ++ show (show f) ++ ")"+startFunctionTracing t            f = "TRACE_FUNCTION(" ++ show (show t ++ "." ++ show f) ++ ")"++startInitTracing :: CategoryName -> SymbolScope -> String+startInitTracing t s = "TRACE_FUNCTION(" ++ show (show t ++ " " ++ show s ++ " init") ++ ")"++startTestTracing :: FunctionName -> String+startTestTracing f = "TRACE_FUNCTION(" ++ show ("unittest " ++ show f) ++ ")"  startCleanupTracing :: String startCleanupTracing = "TRACE_CLEANUP"

@@ -45,6 +45,7 @@   sourceStreamlined,   tableName,   testFilename,+  testFunctionName,   typeCreator,   typeGetter,   typeName,@@ -133,6 +134,9 @@  collectionName :: CategoryName -> String collectionName n = "Functions_" ++ show n++testFunctionName :: FunctionName -> String+testFunctionName f = "Test_" ++ show f  tableName :: CategoryName -> String tableName n = "Table_" ++ show n

@@ -29,6 +29,8 @@   compileMainProcedure,   compileLazyInit,   compileRegularInit,+  compileTestProcedure,+  selectTestFromArgv1, ) where  import Control.Applicative ((<|>))@@ -77,7 +79,7 @@       unreachable <- csIsUnreachable       when (not unreachable) $         doImplicitReturn [] <???-          ("In implicit return from " ++ show n ++ formatFullContextBrace c)+          "In implicit return from " ++ show n ++ formatFullContextBrace c     wrapProcedure output pt ct =       mconcat [           onlyCode header2,@@ -117,7 +119,7 @@     returnType = "ReturnTuple"     setProcedureTrace       | any isNoTrace pragmas = return []-      | otherwise             = return [startFunctionTracing $ show t ++ "." ++ show n]+      | otherwise             = return [startFunctionTracing t n]     setCreationTrace       | not $ any isTraceCreation pragmas = return []       | s /= ValueScope =@@ -152,7 +154,7 @@      then return e'      else return $ predTraceContext c ++ e'   where-    compile = ("In condition at " ++ formatFullContext c) ???> do+    compile = "In condition at " ++ formatFullContext c ???> do       (ts,e') <- compileExpression e       lift $ checkCondition ts       return $ useAsUnboxed PrimBool e'@@ -203,7 +205,7 @@       autoPositionalCleanup e     -- Multi-expression => must all be singles.     getReturn rs = do-      (lift $ mapErrorsM_ checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) <???+      lift (mapErrorsM_ checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) <???         ("In return at " ++ formatFullContext c)       csRegisterReturn c $ Just $ Positional $ map (head . pValues . fst . snd) rs       let e = OpaqueMulti $ "ReturnTuple(" ++ intercalate "," (map (useAsUnwrapped . snd . snd) rs) ++ ")"@@ -243,7 +245,7 @@   r <- csResolver   fa <- csAllFilters   lift $ (checkValueAssignment r fa t0 formattedRequiredValue) <??-    ("In fail call at " ++ formatFullContext c)+    "In fail call at " ++ formatFullContext c   csSetJumpType JumpFailCall   maybeSetTrace c   csWrite ["BUILTIN_FAIL(" ++ useAsUnwrapped e0 ++ ")"]@@ -274,14 +276,14 @@       return t     getVariableType (ExistingVariable (DiscardInput _)) t = return t     createVariable r fa (CreateVariable c2 t1 n) t2 =-      ("In creation of " ++ show n ++ " at " ++ formatFullContext c2) ???> do+      "In creation of " ++ show n ++ " at " ++ formatFullContext c2 ???> do         -- TODO: Call csRequiresTypes for t1. (Maybe needs a helper function.)         lift $ collectAllM_ [validateGeneralInstance r fa (vtType t1),                              checkValueAssignment r fa t2 t1]         csAddVariable c2 n (VariableValue c2 LocalScope t1 True)         csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"]     createVariable r fa (ExistingVariable (InputValue c2 n)) t2 =-      ("In assignment to " ++ show n ++ " at " ++ formatFullContext c2) ???> do+      "In assignment to " ++ show n ++ " at " ++ formatFullContext c2 ???> do         (VariableValue _ _ t1 w) <- csGetVariable c2 n         when (not w) $ lift $ compileErrorM $ "Cannot assign to read-only variable " ++                                               show n ++ formatFullContextBrace c2@@ -328,7 +330,7 @@   fa <- csAllFilters   let Positional [t2] = ts   lift $ (checkValueAssignment r fa t2 t1) <??-    ("In initialization of " ++ show n ++ " at " ++ formatFullContext c)+    "In initialization of " ++ show n ++ " at " ++ formatFullContext c   csWrite [variableName n ++ "([this]() { return " ++ writeStoredVariable t1 e' ++ "; })"]  compileVoidExpression :: (Show c, CompileErrorM m,@@ -426,7 +428,7 @@     case cl of          Just p2@(Procedure c _) -> do            ctxCl0' <- lift $ ccStartCleanup ctxCl0-           ctxCl <- compileProcedure ctxCl0' p2 <??? ("In cleanup starting at " ++ formatFullContext c)+           ctxCl <- compileProcedure ctxCl0' p2 <??? "In cleanup starting at " ++ formatFullContext c            p2' <- lift $ ccGetOutput ctxCl            noTrace <- csGetNoTrace            let p2'' = if noTrace@@ -453,7 +455,7 @@   where     createVariable r fa (c,t,n) = do       lift $ validateGeneralInstance r fa (vtType t) <??-        ("In creation of " ++ show n ++ " at " ++ formatFullContext c)+        "In creation of " ++ show n ++ " at " ++ formatFullContext c       csWrite [variableStoredType t ++ " " ++ variableName n ++ ";"]     showVariable (c,t,n) = do       -- TODO: Call csRequiresTypes for t. (Maybe needs a helper function.)@@ -576,7 +578,7 @@       -- Multi-expression => must all be singles.       getValues rs = do         (mapErrorsM_ checkArity $ zip ([0..] :: [Int]) $ map fst rs) <??-          ("In return at " ++ formatFullContext c)+          "In return at " ++ formatFullContext c         return (map (head . pValues . fst) rs,                 "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")       checkArity (_,Positional [_]) = return ()@@ -658,7 +660,7 @@     fa <- csAllFilters     let vt = ValueType RequiredValue $ singleType $ JustTypeInstance t     (lift $ checkValueAssignment r fa t' vt) <???-      ("In converted call at " ++ formatFullContext c)+      "In converted call at " ++ formatFullContext c     f' <- lookupValueFunction vt f     compileFunctionCall (Just $ useAsUnwrapped e') f' f   transform e (ValueCall c f) = do@@ -694,7 +696,11 @@   return (Positional [t],readStoredVariable lazy t (scoped ++ variableName n)) compileExpressionStart (NamedMacro c n) = do   e <- csExprLookup c n-  compileExpression e <??? ("In env lookup at " ++ formatFullContext c)+  csReserveExprMacro c n+  e' <- compileExpression e <??? "In expansion of " ++ show n ++ " at " ++ formatFullContext c+  -- NOTE: This will be skipped if expression compilation fails.+  csReleaseExprMacro c n+  return e' compileExpressionStart (CategoryCall c t f@(FunctionCall _ n _ _)) = do   f' <- csGetCategoryFunction c (Just t) n   csRequiresTypes $ Set.fromList [t,sfType f']@@ -703,7 +709,7 @@ compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do   r <- csResolver   fa <- csAllFilters-  lift $ validateGeneralInstance r fa (singleType t) <?? ("In function call at " ++ formatFullContext c)+  lift $ validateGeneralInstance r fa (singleType t) <?? "In function call at " ++ formatFullContext c   f' <- csGetTypeFunction c (Just $ singleType t) n   when (sfScope f' /= TypeScope) $ lift $ compileErrorM $ "Function " ++ show n ++                                           " cannot be used as a type function" ++@@ -755,7 +761,7 @@   lift $ validateGeneralInstance r fa t1   lift $ validateGeneralInstance r fa t2   lift $ (checkValueAssignment r fa t0 (ValueType OptionalValue t1)) <??-    ("In argument to reduce call at " ++ formatFullContext c)+    "In argument to reduce call at " ++ formatFullContext c   -- TODO: If t1 -> t2 then just return e without a Reduce call.   t1' <- expandGeneralInstance t1   t2' <- expandGeneralInstance t2@@ -813,7 +819,7 @@   r <- csResolver   fa <- csAllFilters   lift $ (checkValueAssignment r fa t t0) <??-    ("In assignment at " ++ formatFullContext c)+    "In assignment at " ++ formatFullContext c   csUpdateAssigned n   scoped <- autoScope s   let lazy = s == CategoryScope@@ -875,13 +881,13 @@     -- Multi-expression => must all be singles.     getValues rs = do       (mapErrorsM_ checkArity $ zip ([0..] :: [Int]) $ map fst rs) <??-        ("In return at " ++ formatFullContext c)+        "In return at " ++ formatFullContext c       return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")     checkArity (_,Positional [_]) = return ()     checkArity (i,Positional ts)  =       compileErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"     checkArg r fa t0 (i,t1) = do-      checkValueAssignment r fa t1 t0 <?? ("In argument " ++ show i ++ " to " ++ show (sfName f))+      checkValueAssignment r fa t1 t0 <?? "In argument " ++ show i ++ " to " ++ show (sfName f)  guessParamsFromArgs :: (Show c, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->@@ -911,6 +917,50 @@     compiler = do       ctx0 <- getCleanContext       compileProcedure ctx0 procedure >>= put++compileTestProcedure :: (Show c, CompileErrorM m) =>+  CategoryMap c -> ExprMap c -> TestProcedure c -> m (CompiledData [String])+compileTestProcedure tm em (TestProcedure c n p) = do+  ctx <- getMainContext tm em+  p' <- runDataCompiler compiler ctx <??+    "In unittest " ++ show n ++ formatFullContextBrace c+  return $ mconcat [+      onlyCode $ "ReturnTuple " ++ testFunctionName n ++ "() {",+      indentCompiled $ onlyCode $ startTestTracing n,+      indentCompiled p',+      indentCompiled $ onlyCode $ "return ReturnTuple();",+      onlyCode "}"+    ] where+    compiler = do+      ctx0 <- getCleanContext+      compileProcedure ctx0 p >>= put++selectTestFromArgv1 :: CompileErrorM m => [FunctionName] -> m ([String],CompiledData [String])+selectTestFromArgv1 fs = return (includes,allCode) where+  allCode = mconcat [+      initMap,+      selectFromMap+    ]+  initMap = onlyCodes $ [+      "const std::unordered_map<std::string, ReturnTuple(*)()> tests{"+    ] ++ map (("  " ++) . testEntry) fs ++ [+      "};"+    ]+  selectFromMap = onlyCodes [+      "if (argc < 2) FAIL() << argv[0] << \" [unittest name]\";",+      "const auto name = argv[1];",+      "const auto test = tests.find(name);",+      "if (test != tests.end()) {",+      "  (void) (*test->second)();",+      " } else {",+      "  FAIL() << argv[0] << \": unittest \" << name << \" does not exist\";",+      "}"+    ]+  testEntry f = "{ \"" ++ show f ++ "\", &" ++ testFunctionName f ++ " },"+  includes = [+      "#include <string>",+      "#include <unordered_map>"+    ]  autoScope :: CompilerContext c m s a =>   SymbolScope -> CompilerState a m String

@@ -79,13 +79,13 @@ instance CompilerBackend Backend where   runCxxCommand (UnixBackend cb co ab) (CompileToObject s p ms ps e) = do     objName <- errorFromIO $ canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".o")-    executeProcess cb (co ++ otherOptions ++ ["-c", s, "-o", objName]) <?? ("In compilation of " ++ s)+    executeProcess cb (co ++ otherOptions ++ ["-c", s, "-o", objName]) <?? "In compilation of " ++ s     if e       then do         -- Extra files are put into .a since they will be unconditionally         -- included. This prevents unwanted symbol dependencies.         arName  <- errorFromIO $ canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".a")-        executeProcess ab ["-q",arName,objName] <?? ("In packaging of " ++ objName)+        executeProcess ab ["-q",arName,objName] <?? "In packaging of " ++ objName         return arName       else return objName where       otherOptions = map (("-I" ++) . normalise) ps ++ map macro ms@@ -94,10 +94,10 @@   runCxxCommand (UnixBackend cb co _) (CompileToBinary m ss o ps lf) = do     let arFiles    = filter (isSuffixOf ".a")       ss     let otherFiles = filter (not . isSuffixOf ".a") ss-    executeProcess cb (co ++ otherOptions ++ m:otherFiles ++ arFiles ++ ["-o", o]) <?? ("In linking of " ++ o)+    executeProcess cb (co ++ otherOptions ++ m:otherFiles ++ arFiles ++ ["-o", o]) <?? "In linking of " ++ o     return o where       otherOptions = lf ++ map ("-I" ++) (map normalise ps)-  runTestCommand _ (TestCommand b p) = errorFromIO $ do+  runTestCommand _ (TestCommand b p as) = errorFromIO $ do     (outF,outH) <- mkstemps "/tmp/ztest_" ".txt"     (errF,errH) <- mkstemps "/tmp/ztest_" ".txt"     pid <- forkProcess (execWithCapture outH errH)@@ -116,7 +116,7 @@         when (not $ null p) $ setCurrentDirectory p         hDuplicateTo h1 stdout         hDuplicateTo h2 stderr-        executeFile b True [] Nothing+        executeFile b True as Nothing   getCompilerHash b = VersionHash $ flip showHex "" $ abs $ hash $ minorVersion ++ show b where     minorVersion = show $ take 3 $ versionBranch version @@ -141,7 +141,8 @@        then return False        else do          ps2 <- errorFromIO $ potentialSystemPaths r m-         errorFromIO (findModule ps2) >>= return . not . isJust+         path <- errorFromIO (findModule ps2)+         return $ isJust path   resolveBaseModule _ = do     let m = "base"     m0 <- errorFromIO $ getDataFileName m

@@ -32,6 +32,7 @@  import Cli.CompileOptions import Cli.Programs (VersionHash)+import Types.Pragma (MacroName) import Types.Procedure (Expression) import Types.TypeCategory (Namespace) import Types.TypeInstance (CategoryName)@@ -95,7 +96,7 @@   ModuleConfig {     mcRoot :: FilePath,     mcPath :: FilePath,-    mcExprMap :: [(String,Expression SourcePos)],+    mcExprMap :: [(MacroName,Expression SourcePos)],     mcPublicDeps :: [FilePath],     mcPrivateDeps :: [FilePath],     mcExtraFiles :: [ExtraSource],

@@ -22,9 +22,9 @@   autoWriteConfig, ) where +import Control.Applicative.Permutations import Control.Monad (when) import Text.Parsec-import Text.Parsec.String  import Base.CompileError import Cli.CompileOptions@@ -32,32 +32,29 @@ import Module.CompileMetadata import Parser.Common import Parser.Procedure ()-import Parser.Pragma (parseMacroName) import Parser.TypeCategory () import Parser.TypeInstance () import Text.Regex.TDFA -- Not safe!+import Types.Pragma (MacroName) import Types.Procedure (Expression) import Types.TypeCategory (FunctionName(..),Namespace(..)) import Types.TypeInstance (CategoryName(..))   class ConfigFormat a where-  readConfig :: Parser a+  readConfig :: CompileErrorM m => ParserE m a   writeConfig :: CompileErrorM m => a -> m [String]  autoReadConfig :: (ConfigFormat a, CompileErrorM m) => String -> String -> m a-autoReadConfig f s  = unwrap parsed where-  parsed = parse (between optionalSpace endOfDoc readConfig) f s-  unwrap (Left e)  = compileErrorM (show e)-  unwrap (Right t) = return t+autoReadConfig f s = runParserE (between optionalSpace endOfDoc readConfig) f s  autoWriteConfig ::  (ConfigFormat a, CompileErrorM m) => a -> m String autoWriteConfig = fmap unlines . writeConfig -structOpen :: Parser ()+structOpen :: Monad m => ParserE m () structOpen = sepAfter (string_ "{") -structClose :: Parser ()+structClose :: Monad m => ParserE m () structClose = sepAfter (string_ "}")  indents :: [String] -> [String]@@ -75,23 +72,17 @@     when (not $ show c =~ "^[A-Z][A-Za-z0-9]*$") $       compileErrorM $ "Invalid category name: \"" ++ show c ++ "\"" -parseCategoryName :: Parser CategoryName-parseCategoryName = sourceParser :: Parser CategoryName- validateFunctionName :: CompileErrorM m => FunctionName -> m () validateFunctionName f =     when (not $ show f =~ "^[a-z][A-Za-z0-9]*$") $       compileErrorM $ "Invalid function name: \"" ++ show f ++ "\"" -parseFunctionName :: Parser FunctionName-parseFunctionName = sourceParser :: Parser FunctionName- validateHash :: CompileErrorM m => VersionHash -> m () validateHash h =     when (not $ show h =~ "^[A-Za-z0-9]+$") $       compileErrorM $ "Version hash must be a hex string: \"" ++ show h ++ "\"" -parseHash :: Parser VersionHash+parseHash :: Monad m => ParserE m VersionHash parseHash = labeled "version hash" $ sepAfter (fmap VersionHash $ many1 hexDigit)  maybeShowNamespace :: CompileErrorM m => String -> Namespace -> m [String]@@ -101,55 +92,56 @@   return [l ++ " " ++ ns] maybeShowNamespace _ _ = return [] -parseNamespace :: Parser Namespace+parseNamespace :: Monad m => ParserE m Namespace parseNamespace = labeled "namespace" $ do   b <- lower   e <- sepAfter $ many (alphaNum <|> char '_')   return $ StaticNamespace (b:e) -parseQuoted :: Parser String+parseQuoted :: Monad m => ParserE m String parseQuoted = labeled "quoted string" $ do   string_ "\""   ss <- manyTill stringChar (string_ "\"")   optionalSpace   return ss -parseList :: Parser a -> Parser [a]+parseList :: Monad m => ParserE m a -> ParserE m [a] parseList p = labeled "list" $ do   sepAfter (string_ "[")   xs <- manyTill (sepAfter p) (string_ "]")   optionalSpace   return xs -parseOptional :: String -> a -> Parser a -> Parser a-parseOptional l def p = parseRequired l p <|> return def+parseOptional :: Monad m => String -> a -> ParserE m a -> Permutation (ParserE m) a+parseOptional l def p = toPermutationWithDefault def $ do+    try $ sepAfter (string_ l)+    p -parseRequired :: String -> Parser a -> Parser a-parseRequired l p = do+parseRequired :: Monad m => String -> ParserE m a -> Permutation (ParserE m) a+parseRequired l p = toPermutation $ do     try $ sepAfter (string_ l)     p  instance ConfigFormat CompileMetadata where-  readConfig = do-    h   <- parseRequired "version_hash:"       parseHash-    p   <- parseRequired "path:"               parseQuoted-    ns1 <- parseOptional "public_namespace:"   NoNamespace parseNamespace-    ns2 <- parseOptional "private_namespace:"  NoNamespace parseNamespace-    is  <- parseRequired "public_deps:"        (parseList parseQuoted)-    is2 <- parseRequired "private_deps:"       (parseList parseQuoted)-    cs1 <- parseRequired "public_categories:"  (parseList parseCategoryName)-    cs2 <- parseRequired "private_categories:" (parseList parseCategoryName)-    ds1 <- parseRequired "public_subdirs:"     (parseList parseQuoted)-    ds2 <- parseRequired "private_subdirs:"    (parseList parseQuoted)-    ps  <- parseRequired "public_files:"       (parseList parseQuoted)-    xs  <- parseRequired "private_files:"      (parseList parseQuoted)-    ts  <- parseRequired "test_files:"         (parseList parseQuoted)-    hxx <- parseRequired "hxx_files:"          (parseList parseQuoted)-    cxx <- parseRequired "cxx_files:"          (parseList parseQuoted)-    bs  <- parseRequired "binaries:"           (parseList parseQuoted)-    lf  <- parseRequired "link_flags:"         (parseList parseQuoted)-    os  <- parseRequired "object_files:"       (parseList readConfig)-    return (CompileMetadata h p ns1 ns2 is is2 cs1 cs2 ds1 ds2 ps xs ts hxx cxx bs lf os)+  readConfig = runPermutation $ CompileMetadata+    <$> parseRequired "version_hash:"       parseHash+    <*> parseRequired "path:"               parseQuoted+    <*> parseOptional "public_namespace:"   NoNamespace parseNamespace+    <*> parseOptional "private_namespace:"  NoNamespace parseNamespace+    <*> parseRequired "public_deps:"        (parseList parseQuoted)+    <*> parseRequired "private_deps:"       (parseList parseQuoted)+    <*> parseRequired "public_categories:"  (parseList sourceParser)+    <*> parseRequired "private_categories:" (parseList sourceParser)+    <*> parseRequired "public_subdirs:"     (parseList parseQuoted)+    <*> parseRequired "private_subdirs:"    (parseList parseQuoted)+    <*> parseRequired "public_files:"       (parseList parseQuoted)+    <*> parseRequired "private_files:"      (parseList parseQuoted)+    <*> parseRequired "test_files:"         (parseList parseQuoted)+    <*> parseRequired "hxx_files:"          (parseList parseQuoted)+    <*> parseRequired "cxx_files:"          (parseList parseQuoted)+    <*> parseRequired "binaries:"           (parseList parseQuoted)+    <*> parseRequired "link_flags:"         (parseList parseQuoted)+    <*> parseRequired "object_files:"       (parseList readConfig)   writeConfig (CompileMetadata h p ns1 ns2 is is2 cs1 cs2 ds1 ds2 ps xs ts hxx cxx bs lf os) = do     validateHash h     ns1' <- maybeShowNamespace "public_namespace:"  ns1@@ -210,17 +202,19 @@     category = do       sepAfter (string_ "category_object")       structOpen-      c <-  parseRequired "category:" readConfig-      rs <- parseRequired "requires:" (parseList readConfig)-      fs <- parseRequired "files:"    (parseList parseQuoted)+      o <- runPermutation $ CategoryObjectFile+        <$> parseRequired "category:" readConfig+        <*> parseRequired "requires:" (parseList readConfig)+        <*> parseRequired "files:"    (parseList parseQuoted)       structClose-      return (CategoryObjectFile c rs fs)+      return o     other = do       sepAfter (string_ "other_object")       structOpen-      f <- parseRequired "file:" parseQuoted+      f <- runPermutation $ OtherObjectFile+        <$> parseRequired "file:" parseQuoted       structClose-      return (OtherObjectFile f)+      return f   writeConfig (CategoryObjectFile c rs fs) = do     category <- writeConfig c     requires <- fmap concat $ mapErrorsM writeConfig rs@@ -247,17 +241,19 @@     category = do       sepAfter (string_ "category")       structOpen-      c <-  parseRequired "name:"      parseCategoryName-      ns <- parseOptional "namespace:" NoNamespace parseNamespace-      p <-  parseRequired "path:"      parseQuoted+      i <- runPermutation $ CategoryIdentifier+        <$> parseRequired "path:"      parseQuoted+        <*> parseRequired "name:"      sourceParser+        <*> parseOptional "namespace:" NoNamespace parseNamespace       structClose-      return (CategoryIdentifier p c ns)+      return i     unresolved = do       sepAfter (string_ "unresolved")       structOpen-      c <- parseRequired "name:" parseCategoryName+      c <- runPermutation $ UnresolvedCategory+        <$> parseRequired "name:" sourceParser       structClose-      return (UnresolvedCategory c)+      return c   writeConfig (CategoryIdentifier p c ns) = do     validateCategoryName c     namespace <- maybeShowNamespace "namespace:" ns@@ -273,16 +269,15 @@     return $ ["unresolved { " ++ "name: " ++ show c ++ " " ++ "}"]  instance ConfigFormat ModuleConfig where-  readConfig = do-      p   <- parseOptional "root:"           "" parseQuoted-      d   <- parseRequired "path:"              parseQuoted-      em  <- parseOptional "expression_map:" [] (parseList parseExprMacro)-      is  <- parseOptional "public_deps:"    [] (parseList parseQuoted)-      is2 <- parseOptional "private_deps:"   [] (parseList parseQuoted)-      es  <- parseOptional "extra_files:"    [] (parseList readConfig)-      ep  <- parseOptional "include_paths:"  [] (parseList parseQuoted)-      m   <- parseRequired "mode:"              readConfig-      return (ModuleConfig p d em is is2 es ep m)+  readConfig = runPermutation $ ModuleConfig+    <$> parseOptional "root:"           "" parseQuoted+    <*> parseRequired "path:"              parseQuoted+    <*> parseOptional "expression_map:" [] (parseList parseExprMacro)+    <*> parseOptional "public_deps:"    [] (parseList parseQuoted)+    <*> parseOptional "private_deps:"   [] (parseList parseQuoted)+    <*> parseOptional "extra_files:"    [] (parseList readConfig)+    <*> parseOptional "include_paths:"  [] (parseList parseQuoted)+    <*> parseRequired "mode:"              readConfig   writeConfig (ModuleConfig p d em is is2 es ep m) = do     es' <- fmap concat $ mapErrorsM writeConfig es     m' <- writeConfig m@@ -313,11 +308,12 @@     category = do       sepAfter (string_ "category_source")       structOpen-      f <-  parseRequired "source:"        parseQuoted-      cs <- parseOptional "categories:" [] (parseList parseCategoryName)-      ds <- parseOptional "requires:"   [] (parseList parseCategoryName)+      s <- runPermutation $ CategorySource+        <$> parseRequired "source:"        parseQuoted+        <*> parseOptional "categories:" [] (parseList sourceParser)+        <*> parseOptional "requires:"   [] (parseList sourceParser)       structClose-      return (CategorySource f cs ds)+      return s     other = do       f <- parseQuoted       return (OtherSource f)@@ -342,18 +338,20 @@     binary = do       sepAfter (string_ "binary")       structOpen-      c <-  parseRequired "category:"      parseCategoryName-      f <-  parseRequired "function:"      parseFunctionName-      o <-  parseOptional "output:"     "" parseQuoted-      lf <- parseOptional "link_flags:" [] (parseList parseQuoted)+      b <- runPermutation $ CompileBinary+        <$> parseRequired "category:"      sourceParser+        <*> parseRequired "function:"      sourceParser+        <*> parseOptional "output:"     "" parseQuoted+        <*> parseOptional "link_flags:" [] (parseList parseQuoted)       structClose-      return (CompileBinary c f o lf)+      return b     incremental = do       sepAfter (string_ "incremental")       structOpen-      lf <- parseOptional "link_flags:" [] (parseList parseQuoted)+      lf <- runPermutation $ CompileIncremental+        <$> parseOptional "link_flags:" [] (parseList parseQuoted)       structClose-      return (CompileIncremental lf)+      return lf   writeConfig (CompileBinary c f o lf) = do     validateCategoryName c     validateFunctionName f@@ -378,11 +376,12 @@   writeConfig CompileUnspecified = writeConfig (CompileIncremental [])   writeConfig _ = compileErrorM "Invalid compile mode" -parseExprMacro :: Parser (String,Expression SourcePos)+parseExprMacro :: CompileErrorM m => ParserE m (MacroName,Expression SourcePos) parseExprMacro = do   sepAfter (string_ "expression_macro")   structOpen-  n <- parseRequired "name:"       parseMacroName-  e <- parseRequired "expression:" sourceParser+  e <- runPermutation $ (,)+    <$> parseRequired "name:"       sourceParser+    <*> parseRequired "expression:" sourceParser   structClose-  return (n,e)+  return e

@@ -99,8 +99,17 @@   filePresent <- errorFromIO $ doesFileExist f   when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been configured yet"   c <- errorFromIO $ readFile f-  (autoReadConfig f c) <!!-    ("Could not parse metadata from \"" ++ p ++ "\"; please reconfigure")+  m <- autoReadConfig f c <!!+    "Could not parse metadata from \"" ++ p ++ "\"; please reconfigure"+  p0 <- errorFromIO $ canonicalizePath p+  let p1 = mcRoot m </> mcPath m+  p2 <- errorFromIO $ canonicalizePath $ p0 </> p1+  when (p2 /= p0) $ compileErrorM $ "Expected module path from " ++ f +++                                    " to match " ++ moduleFilename +++                                    " location but got " ++ p2 +++                                    " (resolved from root: \"" ++ mcRoot m +++                                    "\" and path: \"" ++ mcPath m ++ "\")"+  return m  isPathUpToDate :: VersionHash -> ForceMode -> FilePath -> CompileInfoIO Bool isPathUpToDate h f p = do@@ -116,7 +125,7 @@ writeMetadata p m = do   p' <- errorFromIO $ canonicalizePath p   errorFromIO $ hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"."-  m' <- autoWriteConfig m <?? ("In data for " ++ p)+  m' <- autoWriteConfig m <?? "In data for " ++ p   writeCachedFile p' "" metadataFilename m'  writeRecompile :: FilePath -> ModuleConfig -> CompileInfoIO ()@@ -124,7 +133,7 @@   p' <- errorFromIO $ canonicalizePath p   let f = p </> moduleFilename   errorFromIO $ hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"."-  m' <- autoWriteConfig m <?? ("In data for " ++ p)+  m' <- autoWriteConfig m <?? "In data for " ++ p   errorFromIO $ writeFile f m'  eraseCachedData :: FilePath -> CompileInfoIO ()@@ -167,7 +176,7 @@ getExprMap :: FilePath -> ModuleConfig -> CompileInfoIO (ExprMap SourcePos) getExprMap p m = do   path <- errorFromIO $ canonicalizePath (p </> mcRoot m </> mcPath m)-  let defaults = [("MODULE_PATH",Literal (StringLiteral [] path))]+  let defaults = [(MacroName "MODULE_PATH",Literal (StringLiteral [] path))]   return $ Map.fromList $ mcExprMap m ++ defaults  getRealPathsForDeps :: [CompileMetadata] -> [FilePath]@@ -236,7 +245,7 @@           when (cmPath m /= p') $             compileErrorM $ "Module \"" ++ p ++ "\" has an invalid cache path and must be recompiled"           fresh <- errorFromIO $ toCompileInfo $ checkModuleFreshness h cm p m <!!-            ("Module \"" ++ p ++ "\" is out of date and should be recompiled")+            "Module \"" ++ p ++ "\" is out of date and should be recompiled"           if enforce              then fromCompileInfo   fresh              else asCompileWarnings fresh@@ -257,7 +266,7 @@          when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been compiled yet"          c <- errorFromIO $ readFile f          (autoReadConfig f c) <!!-            ("Could not parse metadata from \"" ++ p ++ "\"; please recompile")+            "Could not parse metadata from \"" ++ p ++ "\"; please recompile"  sortCompiledFiles :: [FilePath] -> ([FilePath],[FilePath],[FilePath]) sortCompiledFiles = foldl split ([],[],[]) where@@ -325,7 +334,7 @@         then return True         else errorFromIO $ doesDirectoryExist f2 -getObjectFileResolver :: [ObjectFile] -> [Namespace] -> [CategoryName] -> [FilePath]+getObjectFileResolver :: [ObjectFile] -> Set.Set Namespace -> Set.Set CategoryName -> [FilePath] getObjectFileResolver os ns ds = resolved ++ nonCategories where   categories    = filter isCategoryObjectFile os   nonCategories = map oofFile $ filter (not . isCategoryObjectFile) os@@ -333,10 +342,10 @@   keyByCategory2 o = ((ciCategory $ cofCategory o,ciNamespace $ cofCategory o),o)   objectMap = Map.fromList $ map keyBySpec categories   keyBySpec o = (cofCategory o,o)-  directDeps = concat $ map resolveDep2 ds+  directDeps = concat $ map resolveDep2 $ Set.toList ds   directResolved = map cofCategory directDeps   resolveDep2 d = unwrap $ foldl (<|>) Nothing allChecks <|> Just [] where-    allChecks = map (\n -> (d,n) `Map.lookup` categoryMap >>= return . (:[])) (ns ++ [NoNamespace])+    allChecks = map (\n -> (d,n) `Map.lookup` categoryMap >>= return . (:[])) (Set.toList ns ++ [NoNamespace])     unwrap (Just xs) = xs     unwrap _         = []   (_,_,resolved) = collectAll Set.empty Set.empty directResolved@@ -369,7 +378,7 @@   cxxToId _                               = undefined   resolveCategory (fs,ca@(CxxOutput _ _ _ ns2 ds _)) =     (cxxToId ca,CategoryObjectFile (cxxToId ca) (filter (/= cxxToId ca) rs) fs) where-      rs = concat $ map (resolveDep categoryMap (ns2 ++ publicNamespaces)) ds+      rs = concat $ map (resolveDep categoryMap (Set.toList ns2 ++ publicNamespaces)) $ Set.toList ds  resolveCategoryDeps :: [CategoryName] -> [CompileMetadata] -> [CategoryIdentifier] resolveCategoryDeps cs deps = resolvedCategories where

@@ -16,10 +16,12 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Safe #-}  module Parser.Common (   ParseFromSource(..),+  ParserE,   anyComment,   assignOperator,   blockComment,@@ -66,6 +68,7 @@   kwType,   kwTypename,   kwTypes,+  kwUnittest,   kwUpdate,   kwValue,   kwWeak,@@ -80,11 +83,14 @@   nullParse,   operator,   optionalSpace,+  parseAny2,+  parseAny3,   parseBin,   parseDec,   parseHex,   parseOct,   parseSubOne,+  parseErrorM,   pragmaArgsEnd,   pragmaArgsStart,   pragmaEnd,@@ -94,8 +100,10 @@   put22,   put23,   put33,+  quotedString,   regexChar,   requiredSpace,+  runParserE,   sepAfter,   sepAfter1,   sepAfter_,@@ -107,184 +115,204 @@   valueSymbolGet, ) where +import Control.Applicative (empty)+import Control.Monad.Trans (lift) import Data.Char import Data.Foldable import Data.Functor import Data.Monoid import Prelude hiding (foldl,foldr) import Text.Parsec-import Text.Parsec.String import qualified Data.Set as Set +import Base.CompileError ++type ParserE = ParsecT String ()+ class ParseFromSource a where-  -- Should never prune whitespace/comments from front, but always from back.-  sourceParser :: Parser a+  -- Must never prune whitespace/comments from front, but always from back.+  sourceParser :: CompileErrorM m => ParserE m a -labeled :: String -> Parser a -> Parser a+runParserE :: CompileErrorM m => ParserE m a -> String -> String -> m a+runParserE p n s = do+  result <- runPT p () n s+  case result of+       Left e  -> compileErrorM (show e)+       Right t -> return t++parseErrorM :: CompileErrorM m => SourcePos -> String -> ParserE m a+parseErrorM c e = lift $ compileErrorM $ "At " ++ show c ++ ": " ++ e++labeled :: Monad m => String -> ParserE m a -> ParserE m a labeled = flip label -escapeStart :: Parser ()+escapeStart :: Monad m => ParserE m () escapeStart = sepAfter (string_ "\\") -statementStart :: Parser ()+statementStart :: Monad m => ParserE m () statementStart = sepAfter (string_ "\\") -statementEnd :: Parser ()+statementEnd :: Monad m => ParserE m () statementEnd = sepAfter (string_ "") -valueSymbolGet :: Parser ()+valueSymbolGet :: Monad m => ParserE m () valueSymbolGet = sepAfter (string_ ".") -categorySymbolGet :: Parser ()+categorySymbolGet :: CompileErrorM m => ParserE m () categorySymbolGet = labeled ":" $ useNewOperators <|> sepAfter (string_ ":") -typeSymbolGet :: Parser ()+typeSymbolGet :: CompileErrorM m => ParserE m () typeSymbolGet = labeled "." $ useNewOperators <|> sepAfter (string_ ".")  -- TODO: Remove this after a reasonable amount of time.-useNewOperators :: Parser ()+useNewOperators :: CompileErrorM m => ParserE m () useNewOperators = newCategory <|> newType where   newCategory = do+    c <- getPosition     try $ string_ "$$"-    fail "use \":\" instead of \"$$\" to call @category functions"+    parseErrorM c "use \":\" instead of \"$$\" to call @category functions"   newType = do+    c <- getPosition     try $ string_ "$"-    fail "use \".\" instead of \"$\" to call @type functions"+    parseErrorM c "use \".\" instead of \"$\" to call @type functions" -assignOperator :: Parser ()+assignOperator :: Monad m => ParserE m () assignOperator = operator "<-" >> return () -infixFuncStart :: Parser ()+infixFuncStart :: Monad m => ParserE m () infixFuncStart = sepAfter (string_ "`") -infixFuncEnd :: Parser ()+infixFuncEnd :: Monad m => ParserE m () infixFuncEnd = sepAfter (string_ "`")  -- TODO: Maybe this should not use strings.-builtinValues :: Parser String-builtinValues = foldr (<|>) (fail "empty") $ map try [+builtinValues :: Monad m => ParserE m String+builtinValues = foldr (<|>) empty $ map try [     kwSelf >> return "self"   ] -kwAll :: Parser ()+kwAll :: Monad m => ParserE m () kwAll = keyword "all" -kwAllows :: Parser ()+kwAllows :: Monad m => ParserE m () kwAllows = keyword "allows" -kwAny :: Parser ()+kwAny :: Monad m => ParserE m () kwAny = keyword "any" -kwBreak :: Parser ()+kwBreak :: Monad m => ParserE m () kwBreak = keyword "break" -kwCategory :: Parser ()+kwCategory :: Monad m => ParserE m () kwCategory = keyword "@category" -kwCleanup :: Parser ()+kwCleanup :: Monad m => ParserE m () kwCleanup = keyword "cleanup" -kwConcrete :: Parser ()+kwConcrete :: Monad m => ParserE m () kwConcrete = keyword "concrete" -kwContinue :: Parser ()+kwContinue :: Monad m => ParserE m () kwContinue = keyword "continue" -kwDefine :: Parser ()+kwDefine :: Monad m => ParserE m () kwDefine = keyword "define" -kwDefines :: Parser ()+kwDefines :: Monad m => ParserE m () kwDefines = keyword "defines" -kwElif :: Parser ()+kwElif :: Monad m => ParserE m () kwElif = keyword "elif" -kwElse :: Parser ()+kwElse :: Monad m => ParserE m () kwElse = keyword "else" -kwEmpty :: Parser ()+kwEmpty :: Monad m => ParserE m () kwEmpty = keyword "empty" -kwFail :: Parser ()+kwFail :: Monad m => ParserE m () kwFail = keyword "fail" -kwFalse :: Parser ()+kwFalse :: Monad m => ParserE m () kwFalse = keyword "false" -kwIf :: Parser ()+kwIf :: Monad m => ParserE m () kwIf = keyword "if" -kwIn :: Parser ()+kwIn :: Monad m => ParserE m () kwIn = keyword "in" -kwIgnore :: Parser ()+kwIgnore :: Monad m => ParserE m () kwIgnore = keyword "_" -kwInterface :: Parser ()+kwInterface :: Monad m => ParserE m () kwInterface = keyword "interface" -kwOptional :: Parser ()+kwOptional :: Monad m => ParserE m () kwOptional = keyword "optional" -kwPresent :: Parser ()+kwPresent :: Monad m => ParserE m () kwPresent = keyword "present" -kwReduce :: Parser ()+kwReduce :: Monad m => ParserE m () kwReduce = keyword "reduce" -kwRefines :: Parser ()+kwRefines :: Monad m => ParserE m () kwRefines = keyword "refines" -kwRequire :: Parser ()+kwRequire :: Monad m => ParserE m () kwRequire = keyword "require" -kwRequires :: Parser ()+kwRequires :: Monad m => ParserE m () kwRequires = keyword "requires" -kwReturn :: Parser ()+kwReturn :: Monad m => ParserE m () kwReturn = keyword "return" -kwSelf :: Parser ()+kwSelf :: Monad m => ParserE m () kwSelf = keyword "self" -kwScoped :: Parser ()+kwScoped :: Monad m => ParserE m () kwScoped = keyword "scoped" -kwStrong :: Parser ()+kwStrong :: Monad m => ParserE m () kwStrong = keyword "strong" -kwTestcase :: Parser ()+kwTestcase :: Monad m => ParserE m () kwTestcase = keyword "testcase" -kwTrue :: Parser ()+kwTrue :: Monad m => ParserE m () kwTrue = keyword "true" -kwType :: Parser ()+kwType :: Monad m => ParserE m () kwType = keyword "@type" -kwTypename :: Parser ()+kwTypename :: Monad m => ParserE m () kwTypename = keyword "typename" -kwTypes :: Parser ()+kwTypes :: Monad m => ParserE m () kwTypes = keyword "types" -kwUpdate :: Parser ()+kwUnittest :: Monad m => ParserE m ()+kwUnittest = keyword "unittest"++kwUpdate :: Monad m => ParserE m () kwUpdate = keyword "update" -kwValue :: Parser ()+kwValue :: Monad m => ParserE m () kwValue = keyword "@value" -kwWeak :: Parser ()+kwWeak :: Monad m => ParserE m () kwWeak = keyword "weak" -kwWhile :: Parser ()+kwWhile :: Monad m => ParserE m () kwWhile = keyword "while" -operatorSymbol :: Parser Char+operatorSymbol :: Monad m => ParserE m Char operatorSymbol = labeled "operator symbol" $ satisfy (`Set.member` Set.fromList "+-*/%=!<>&|") -isKeyword :: Parser ()+isKeyword :: Monad m => ParserE m () isKeyword = foldr (<|>) nullParse $ map try [     kwAll,     kwAllows,@@ -320,88 +348,89 @@     kwType,     kwTypename,     kwTypes,+    kwUnittest,     kwUpdate,     kwValue,     kwWeak,     kwWhile   ] -nullParse :: Parser ()+nullParse :: Monad m => ParserE m () nullParse = return () -char_ :: Char -> Parser ()+char_ :: Monad m => Char -> ParserE m () char_ = (>> return ()) . char -string_ :: String -> Parser ()+string_ :: Monad m => String -> ParserE m () string_ = (>> return ()) . string -lineEnd :: Parser ()+lineEnd :: Monad m => ParserE m () lineEnd = (endOfLine >> return ()) <|> endOfDoc -lineComment :: Parser String+lineComment :: Monad m => ParserE m String lineComment = between (string_ "//")                       lineEnd                       (many $ satisfy (/= '\n')) -blockComment :: Parser String+blockComment :: Monad m => ParserE m String blockComment = between (string_ "/*")                        (string_ "*/")                        (many $ notFollowedBy (string_ "*/") >> anyChar) -anyComment :: Parser String+anyComment :: Monad m => ParserE m String anyComment = try blockComment <|> try lineComment -optionalSpace :: Parser ()+optionalSpace :: Monad m => ParserE m () optionalSpace = labeled "" $ many (anyComment <|> many1 space) >> nullParse -requiredSpace :: Parser ()+requiredSpace :: Monad m => ParserE m () requiredSpace = labeled "break" $ eof <|> (many1 (anyComment <|> many1 space) >> nullParse) -sepAfter :: Parser a -> Parser a+sepAfter :: Monad m => ParserE m a -> ParserE m a sepAfter = between nullParse optionalSpace -sepAfter_ :: Parser a -> Parser ()+sepAfter_ :: Monad m => ParserE m a -> ParserE m () sepAfter_ = (>> return ()) . between nullParse optionalSpace -sepAfter1 :: Parser a -> Parser a+sepAfter1 :: Monad m => ParserE m a -> ParserE m a sepAfter1 = between nullParse requiredSpace -keyword :: String -> Parser ()+keyword :: Monad m => String -> ParserE m () keyword s = labeled s $ sepAfter $ string s >> (labeled "" $ notFollowedBy (many alphaNum)) -noKeywords :: Parser ()+noKeywords :: Monad m => ParserE m () noKeywords = notFollowedBy isKeyword -endOfDoc :: Parser ()+endOfDoc :: Monad m => ParserE m () endOfDoc = labeled "" $ optionalSpace >> eof -notAllowed :: Parser a -> String -> Parser ()+notAllowed :: ParserE m a -> String -> ParserE m () -- Based on implementation of notFollowedBy. notAllowed p s = (try p >> fail s) <|> return () -pragmaStart :: Parser ()+pragmaStart :: Monad m => ParserE m () pragmaStart = string_ "$" -pragmaEnd :: Parser ()+pragmaEnd :: Monad m => ParserE m () pragmaEnd = string_ "$" -pragmaArgsStart :: Parser ()+pragmaArgsStart :: Monad m => ParserE m () pragmaArgsStart = string_ "[" -pragmaArgsEnd :: Parser ()+pragmaArgsEnd :: Monad m => ParserE m () pragmaArgsEnd = string_ "]" -inferredParam :: Parser ()+inferredParam :: Monad m => ParserE m () inferredParam = string_ "?" -operator :: String -> Parser String+operator :: Monad m => String -> ParserE m String operator o = labeled o $ do   string_ o   notFollowedBy operatorSymbol   optionalSpace   return o -stringChar :: Parser Char+stringChar :: Monad m => ParserE m Char stringChar = escaped <|> notEscaped where   escaped = labeled "escaped char sequence" $ do     char_ '\\'@@ -433,6 +462,11 @@         return $ chr $ 16*h1 + h2   notEscaped = noneOf "\"" +quotedString :: Monad m => ParserE m String+quotedString = do+  string_ "\""+  manyTill stringChar (string_ "\"")+ digitVal :: Char -> Int digitVal c   | c >= '0' && c <= '9' = ord(c) - ord('0')@@ -440,27 +474,27 @@   | c >= 'a' && c <= 'f' = 10 + ord(c) - ord('a')   | otherwise = undefined -parseDec :: Parser Integer+parseDec :: Monad m => ParserE m Integer parseDec = fmap snd $ parseIntCommon 10 digit -parseHex :: Parser Integer+parseHex :: Monad m => ParserE m Integer parseHex = fmap snd $ parseIntCommon 16 hexDigit -parseOct :: Parser Integer+parseOct :: Monad m => ParserE m Integer parseOct = fmap snd $ parseIntCommon 8 octDigit -parseBin :: Parser Integer+parseBin :: Monad m => ParserE m Integer parseBin = fmap snd $ parseIntCommon 2 (oneOf "01") -parseSubOne :: Parser (Integer,Integer)+parseSubOne :: Monad m => ParserE m (Integer,Integer) parseSubOne = parseIntCommon 10 digit -parseIntCommon :: Integer -> Parser Char -> Parser (Integer,Integer)+parseIntCommon :: Monad m => Integer -> ParserE m Char -> ParserE m (Integer,Integer) parseIntCommon b p = do   ds <- many1 p   return $ foldl (\(n,x) y -> (n+1,b*x + (fromIntegral $ digitVal y :: Integer))) (0,0) ds -regexChar :: Parser String+regexChar :: Monad m => ParserE m String regexChar = escaped <|> notEscaped where   escaped = do     char_ '\\'@@ -492,3 +526,26 @@ merge3 :: (Foldable f, Monoid a, Monoid b, Monoid c) => f (a,b,c) -> (a,b,c) merge3 = foldr merge (mempty,mempty,mempty) where   merge (xs1,ys1,zs1) (xs2,ys2,zs2) = (xs1<>xs2,ys1<>ys2,zs1<>zs2)++parseAny2 :: Monad m => ParserE m a -> ParserE m b -> ParserE m ([a],[b])+parseAny2 p1 p2 = sepBy anyType optionalSpace >>= return . merge2 where+  anyType = p1' <|> p2'+  p1' = do+    x <- p1+    return ([x],[])+  p2' = do+    y <- p2+    return ([],[y])++parseAny3 :: Monad m => ParserE m a -> ParserE m b -> ParserE m c -> ParserE m ([a],[b],[c])+parseAny3 p1 p2 p3 = sepBy anyType optionalSpace >>= return . merge3 where+  anyType = p1' <|> p2' <|> p3'+  p1' = do+    x <- p1+    return ([x],[],[])+  p2' = do+    y <- p2+    return ([],[y],[])+  p3' = do+    z <- p3+    return ([],[],[z])

@@ -20,14 +20,13 @@ {-# LANGUAGE Safe #-}  module Parser.DefinedCategory (-  parseAnySource, ) where  import Control.Monad (when) import Prelude hiding (pi) import Text.Parsec-import Text.Parsec.String +import Base.CompileError import Parser.Common import Parser.Procedure () import Parser.TypeCategory@@ -89,40 +88,24 @@         t <- sourceParser         return (s,t) -parseMemberProcedureFunction ::-  CategoryName ->-  Parser ([DefinedMember SourcePos],[ExecutableProcedure SourcePos],[ScopedFunction SourcePos])-parseMemberProcedureFunction n = parsed >>= return . foldr merge empty where-  empty = ([],[],[])-  merge (ms1,ps1,fs1) (ms2,ps2,fs2) = (ms1++ms2,ps1++ps2,fs1++fs2)-  parsed = sepBy anyType optionalSpace-  anyType = labeled "" $ catchUnscopedType <|> singleMember <|> singleProcedure <|> singleFunction-  singleMember = labeled "member" $ do-    m <- sourceParser-    return ([m],[],[])-  singleProcedure = labeled "procedure" $ do-    p <- sourceParser-    return ([],[p],[])-  singleFunction = labeled "function" $ do-    f <- try $ parseScopedFunction parseScope (return n)-    p <- labeled ("definition of function " ++ show (sfName f)) $ sourceParser-    when (sfName f /= epName p) $-      fail $ "expecting definition of function " ++ show (sfName f) ++-             " but got definition of " ++ show (epName p)-    return ([],[p],[f])-  catchUnscopedType = do-    _ <- try sourceParser :: Parser ValueType-    fail $ "members must have an explicit @value or @category scope"--parseAnySource :: Parser ([AnyCategory SourcePos],[DefinedCategory SourcePos])-parseAnySource = parsed >>= return . foldr merge empty where-  empty = ([],[])-  merge (cs1,ds1) (cs2,ds2) = (cs1++cs2,ds1++ds2)-  parsed = sepBy anyType optionalSpace-  anyType = singleCategory <|> singleDefine2-  singleCategory = do-    c <- sourceParser-    return ([c],[])-  singleDefine2 = do-    d <- sourceParser-    return ([],[d])+parseMemberProcedureFunction :: CompileErrorM m =>+  CategoryName -> ParserE m ([DefinedMember SourcePos],+                             [ExecutableProcedure SourcePos],+                             [ScopedFunction SourcePos])+parseMemberProcedureFunction n = do+  (ms,ps,fs) <- parseAny3 (catchUnscopedType <|> sourceParser) sourceParser singleFunction+  let ps2 = ps ++ map snd fs+  let fs2 = map fst fs+  return (ms,ps2,fs2) where+    singleFunction = labeled "function" $ do+      f <- parseScopedFunction parseScope (return n)+      c <- getPosition+      p <- labeled ("definition of function " ++ show (sfName f)) $ sourceParser+      when (sfName f /= epName p) $+        parseErrorM c $ "expecting definition of function " ++ show (sfName f) +++                        " but got definition of " ++ show (epName p)+      return (f,p)+    catchUnscopedType = labeled "" $ do+      c <- getPosition+      _ <- try sourceParser :: CompileErrorM m => ParserE m ValueType+      parseErrorM c "members must have an explicit @value or @category scope"

@@ -25,7 +25,7 @@ import Text.Parsec  import Parser.Common-import Parser.DefinedCategory+import Parser.DefinedCategory () import Parser.Procedure () import Parser.TypeCategory () import Types.IntegrationTest@@ -39,9 +39,15 @@     name <- manyTill stringChar (string_ "\"")     optionalSpace     sepAfter (string_ "{")-    result <- resultError <|> resultCrash <|> resultSuccess+    result <- resultCompiles <|> resultError <|> resultCrash <|> resultSuccess+    args <- parseArgs <|> return []     sepAfter (string_ "}")-    return $ IntegrationTestHeader [c] name result where+    return $ IntegrationTestHeader [c] name args result where+      resultCompiles = labeled "compiles expectation" $ do+        c <- getPosition+        try $ sepAfter (keyword "compiles")+        (req,exc) <- requireOrExclude+        return $ ExpectCompiles [c] req exc       resultError = labeled "error expectation" $ do         c <- getPosition         sepAfter (keyword "error")@@ -49,16 +55,17 @@         return $ ExpectCompileError [c] req exc       resultCrash = labeled "crash expectation" $ do         c <- getPosition-        sepAfter (keyword "crash")-        e <- labeled "test expression" sourceParser+        try $ sepAfter (keyword "crash")         (req,exc) <- requireOrExclude-        return $ ExpectRuntimeError [c] e req exc+        return $ ExpectRuntimeError [c] req exc       resultSuccess = labeled "success expectation" $ do         c <- getPosition         sepAfter (keyword "success")-        e <- labeled "test expression" sourceParser         (req,exc) <- requireOrExclude-        return $ ExpectRuntimeSuccess [c] e req exc+        return $ ExpectRuntimeSuccess [c] req exc+      parseArgs = labeled "testcase args" $ do+        sepAfter (keyword "args")+        many (sepAfter quotedString)       requireOrExclude = parsed >>= return . foldr merge empty where         empty = ([],[])         merge (cs1,ds1) (cs2,ds2) = (cs1++cs2,ds1++ds2)@@ -91,5 +98,5 @@ instance ParseFromSource (IntegrationTest SourcePos) where   sourceParser = labeled "integration test" $ do     h <- sourceParser-    (cs,ds) <- parseAnySource-    return $ IntegrationTest h cs ds+    (cs,ds,ts) <- parseAny3 sourceParser sourceParser sourceParser+    return $ IntegrationTest h cs ds ts

@@ -19,7 +19,6 @@ {-# LANGUAGE Safe #-}  module Parser.Pragma (-  parseMacroName,   parsePragmas,   pragmaComment,   pragmaExprLookup,@@ -32,49 +31,49 @@  import Control.Monad (when) import Text.Parsec-import Text.Parsec.String +import Base.CompileError import Parser.Common import Types.Pragma  -parsePragmas :: [Parser a] -> Parser [a]+parsePragmas :: CompileErrorM m => [ParserE m a] -> ParserE m [a] parsePragmas = many . foldr ((<|>)) unknownPragma -pragmaModuleOnly :: Parser (Pragma SourcePos)+pragmaModuleOnly :: CompileErrorM m => ParserE m (Pragma SourcePos) pragmaModuleOnly = autoPragma "ModuleOnly" $ Left parseAt where   parseAt c = PragmaVisibility [c] ModuleOnly -parseMacroName :: Parser String-parseMacroName = labeled "macro name" $ do-  h <- upper <|> char '_'-  t <- many (upper <|> digit <|> char '_')-  optionalSpace-  return (h:t)+instance ParseFromSource MacroName where+  sourceParser = labeled "macro name" $ do+    h <- upper <|> char '_'+    t <- many (upper <|> digit <|> char '_')+    optionalSpace+    return $ MacroName (h:t) -pragmaExprLookup :: Parser (Pragma SourcePos)+pragmaExprLookup :: CompileErrorM m => ParserE m (Pragma SourcePos) pragmaExprLookup = autoPragma "ExprLookup" $ Right parseAt where   parseAt c = do-    name <- parseMacroName+    name <- sourceParser     return $ PragmaExprLookup [c] name -pragmaSourceContext :: Parser (Pragma SourcePos)+pragmaSourceContext :: CompileErrorM m => ParserE m (Pragma SourcePos) pragmaSourceContext = autoPragma "SourceContext" $ Left parseAt where   parseAt c = PragmaSourceContext c -pragmaNoTrace :: Parser (Pragma SourcePos)+pragmaNoTrace :: CompileErrorM m => ParserE m (Pragma SourcePos) pragmaNoTrace = autoPragma "NoTrace" $ Left parseAt where   parseAt c = PragmaTracing [c] NoTrace -pragmaTraceCreation :: Parser (Pragma SourcePos)+pragmaTraceCreation :: CompileErrorM m => ParserE m (Pragma SourcePos) pragmaTraceCreation = autoPragma "TraceCreation" $ Left parseAt where   parseAt c = PragmaTracing [c] TraceCreation -pragmaTestsOnly :: Parser (Pragma SourcePos)+pragmaTestsOnly :: CompileErrorM m => ParserE m (Pragma SourcePos) pragmaTestsOnly = autoPragma "TestsOnly" $ Left parseAt where   parseAt c = PragmaVisibility [c] TestsOnly -pragmaComment :: Parser (Pragma SourcePos)+pragmaComment :: CompileErrorM m => ParserE m (Pragma SourcePos) pragmaComment = autoPragma "Comment" $ Right parseAt where   parseAt c = do     string_ "\""@@ -82,13 +81,14 @@     optionalSpace     return $ PragmaComment [c] ss -unknownPragma :: Parser a+unknownPragma :: CompileErrorM m => ParserE m a unknownPragma = do+  c <- getPosition   try pragmaStart   p <- many1 alphaNum-  fail $ "Pragma " ++ p ++ " is not supported in this context"+  parseErrorM c $ "pragma " ++ p ++ " is not supported in this context" -autoPragma :: String -> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a+autoPragma :: CompileErrorM m => String -> Either (SourcePos -> a) (SourcePos -> ParserE m a) -> ParserE m a autoPragma p f = do   c <- getPosition   try $ pragmaStart >> string_ p >> notFollowedBy alphaNum@@ -97,11 +97,11 @@   if hasArgs      then do        extra <- manyTill anyChar (string_ "]$")-       when (not $ null extra) $ fail $ "Content unused by pragma " ++ p ++ ": " ++ extra+       when (not $ null extra) $ parseErrorM c $ "content unused by pragma " ++ p ++ ": " ++ extra        optionalSpace      else sepAfter pragmaEnd   return x where     delegate False (Left f2)  c = return $ f2 c     delegate True  (Right f2) c = f2 c-    delegate _     (Left _)   _ = fail $ "Pragma " ++ p ++ " does not allow arguments using []"-    delegate _     (Right _)  _ = fail $ "Pragma " ++ p ++ " requires arguments using []"+    delegate _     (Left _)   c = parseErrorM c $ "pragma " ++ p ++ " does not allow arguments using []"+    delegate _     (Right _)  c = parseErrorM c $ "pragma " ++ p ++ " requires arguments using []"

@@ -23,10 +23,11 @@ module Parser.Procedure ( ) where +import Control.Applicative (empty) import Text.Parsec-import Text.Parsec.String import qualified Data.Set as Set +import Base.CompileError import Parser.Common import Parser.Pragma import Parser.TypeCategory ()@@ -50,6 +51,16 @@     sepAfter (string_ "}")     return $ ExecutableProcedure [c] pragmas [c2] n as rs pp +instance ParseFromSource (TestProcedure SourcePos) where+  sourceParser = labeled "test procedure" $ do+    c <- getPosition+    kwUnittest+    n <- try sourceParser+    sepAfter (string_ "{")+    pp <- sourceParser+    sepAfter (string_ "}")+    return $ TestProcedure [c] n pp+ instance ParseFromSource (ArgValues SourcePos) where   sourceParser = labeled "procedure arguments" $ do     c <- getPosition@@ -139,12 +150,12 @@       c <- getPosition       try kwReturn       emptyReturn c <|> multiReturn c-    multiReturn :: SourcePos -> Parser (Statement SourcePos)+    multiReturn :: CompileErrorM m => SourcePos -> ParserE m (Statement SourcePos)     multiReturn c = do       rs <- sepBy sourceParser (sepAfter $ string_ ",")       statementEnd       return $ ExplicitReturn [c] (Positional rs)-    emptyReturn :: SourcePos -> Parser (Statement SourcePos)+    emptyReturn :: CompileErrorM m => SourcePos -> ParserE m (Statement SourcePos)     emptyReturn c = do       kwIgnore       statementEnd@@ -167,8 +178,9 @@       strayFuncCall <|> return ()       return $ ExistingVariable n     strayFuncCall = do+      c <- getPosition       valueSymbolGet <|> typeSymbolGet <|> categorySymbolGet-      fail "function returns must be explicitly handled"+      parseErrorM c "function returns must be explicitly handled"  instance ParseFromSource (VoidExpression SourcePos) where   sourceParser = conditional <|> loop <|> scoped where@@ -240,9 +252,9 @@       p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser       return $ NoValueExpression [c] (Unconditional p) -unaryOperator :: Parser (Operator c)+unaryOperator :: Monad m => ParserE m (Operator c) unaryOperator = op >>= return . NamedOperator where-  op = labeled "unary operator" $ foldr (<|>) (fail "empty") $ map (try . operator) ops+  op = labeled "unary operator" $ foldr (<|>) empty $ map (try . operator) ops   ops = logicalUnary ++ arithUnary ++ bitwiseUnary  logicalUnary :: [String]@@ -254,9 +266,9 @@ bitwiseUnary :: [String] bitwiseUnary = ["~"] -infixOperator :: Parser (Operator c)+infixOperator :: Monad m => ParserE m (Operator c) infixOperator = op >>= return . NamedOperator where-  op = labeled "binary operator" $ foldr (<|>) (fail "empty") $ map (try . operator) ops+  op = labeled "binary operator" $ foldr (<|>) empty $ map (try . operator) ops   ops = compareInfix ++ logicalInfix ++ addInfix ++ subInfix ++ multInfix ++ bitwiseInfix ++ bitshiftInfix  compareInfix :: [String]@@ -290,7 +302,7 @@     | o `Set.member` Set.fromList logicalInfix = 5   infixOrder _ = 3 -functionOperator :: Parser (Operator SourcePos)+functionOperator :: CompileErrorM m => ParserE m (Operator SourcePos) functionOperator = do   c <- getPosition   infixFuncStart@@ -403,7 +415,7 @@       sepAfter_ inferredParam       return $ InferredInstance [c] -parseFunctionCall :: SourcePos -> FunctionName -> Parser (FunctionCall SourcePos)+parseFunctionCall :: CompileErrorM m => SourcePos -> FunctionName -> ParserE m (FunctionCall SourcePos) parseFunctionCall c n = do   -- NOTE: try is needed here so that < operators work when the left side is   -- just a variable name, e.g., x < y.@@ -415,8 +427,8 @@                 (sepBy sourceParser (sepAfter $ string_ ","))   return $ FunctionCall [c] n (Positional ps) (Positional es) -builtinFunction :: Parser FunctionName-builtinFunction = foldr (<|>) (fail "empty") $ map try [+builtinFunction :: Monad m => ParserE m FunctionName+builtinFunction = foldr (<|>) empty $ map try [     kwPresent >> return BuiltinPresent,     kwReduce >> return BuiltinReduce,     kwRequire >> return BuiltinRequire,@@ -440,13 +452,13 @@       e <- try (assign c) <|> expr c       sepAfter (string_ ")")       return e-    assign :: SourcePos -> Parser (ExpressionStart SourcePos)+    assign :: CompileErrorM m => SourcePos -> ParserE m (ExpressionStart SourcePos)     assign c = do       n <- sourceParser       assignOperator       e <- sourceParser       return $ InlineAssignment [c] n e-    expr :: SourcePos -> Parser (ExpressionStart SourcePos)+    expr :: CompileErrorM m => SourcePos -> ParserE m (ExpressionStart SourcePos)     expr c = do       e <- sourceParser       return $ ParensExpression [c] e@@ -471,7 +483,7 @@            _ -> undefined  -- Should be caught above.     variableOrUnqualified = do       c <- getPosition-      n <- sourceParser :: Parser VariableName+      n <- sourceParser :: CompileErrorM m => ParserE m VariableName       asUnqualifiedCall c n <|> asVariable c n     asVariable c n = do       return $ NamedVariable (OutputValue [c] n)@@ -505,8 +517,7 @@                  emptyLiteral where     stringLiteral = do       c <- getPosition-      string_ "\""-      ss <- manyTill stringChar (string_ "\"")+      ss <- quotedString       optionalSpace       return $ StringLiteral [c] ss     charLiteral = do

@@ -25,11 +25,10 @@ ) where  import Text.Parsec-import Text.Parsec.String  import Base.CompileError import Parser.Common-import Parser.DefinedCategory+import Parser.DefinedCategory () import Parser.IntegrationTest () import Parser.Pragma import Parser.TypeCategory ()@@ -41,21 +40,15 @@  parseInternalSource :: CompileErrorM m =>   (FilePath,String) -> m ([Pragma SourcePos],[AnyCategory SourcePos],[DefinedCategory SourcePos])-parseInternalSource (f,s) = unwrap parsed where-  parsed = parse (between optionalSpace endOfDoc withPragmas) f s-  unwrap (Left e)  = compileErrorM (show e)-  unwrap (Right t) = return t+parseInternalSource (f,s) = runParserE (between optionalSpace endOfDoc withPragmas) f s where   withPragmas = do     pragmas <- parsePragmas internalSourcePragmas     optionalSpace-    (cs,ds) <- parseAnySource+    (cs,ds) <- parseAny2 sourceParser sourceParser     return (pragmas,cs,ds)  parsePublicSource :: CompileErrorM m => (FilePath,String) -> m ([Pragma SourcePos],[AnyCategory SourcePos])-parsePublicSource (f,s) = unwrap parsed where-  parsed = parse (between optionalSpace endOfDoc withPragmas) f s-  unwrap (Left e)  = compileErrorM (show e)-  unwrap (Right t) = return t+parsePublicSource (f,s) = runParserE (between optionalSpace endOfDoc withPragmas) f s where   withPragmas = do     pragmas <- parsePragmas publicSourcePragmas     optionalSpace@@ -63,21 +56,18 @@     return (pragmas,cs)  parseTestSource :: CompileErrorM m => (FilePath,String) -> m ([Pragma SourcePos],[IntegrationTest SourcePos])-parseTestSource (f,s) = unwrap parsed where-  parsed = parse (between optionalSpace endOfDoc withPragmas) f s-  unwrap (Left e)  = compileErrorM (show e)-  unwrap (Right t) = return t+parseTestSource (f,s) = runParserE (between optionalSpace endOfDoc withPragmas) f s where   withPragmas = do     pragmas <- parsePragmas testSourcePragmas     optionalSpace     ts <- sepBy sourceParser optionalSpace     return (pragmas,ts) -publicSourcePragmas :: [Parser (Pragma SourcePos)]+publicSourcePragmas :: CompileErrorM m => [ParserE m (Pragma SourcePos)] publicSourcePragmas = [pragmaModuleOnly,pragmaTestsOnly] -internalSourcePragmas :: [Parser (Pragma SourcePos)]+internalSourcePragmas :: CompileErrorM m => [ParserE m (Pragma SourcePos)] internalSourcePragmas = [pragmaTestsOnly] -testSourcePragmas :: [Parser (Pragma SourcePos)]+testSourcePragmas :: CompileErrorM m => [ParserE m (Pragma SourcePos)] testSourcePragmas = []

@@ -29,8 +29,8 @@ ) where  import Text.Parsec-import Text.Parsec.String +import Base.CompileError import Parser.Common import Parser.TypeInstance () import Types.Positional@@ -74,7 +74,7 @@       close       return $ ValueConcrete [c] NoNamespace n ps rs ds vs fs -parseCategoryParams :: Parser [ValueParam SourcePos]+parseCategoryParams :: CompileErrorM m => ParserE m [ValueParam SourcePos] parseCategoryParams = do   (con,inv,cov) <- none <|> try fixedOnly <|> try noFixed <|> try explicitFixed   return $ map (apply Contravariant) con ++@@ -114,41 +114,40 @@       return (c,n)     apply v (c,n) = ValueParam [c] n v -singleRefine :: Parser (ValueRefine SourcePos)+singleRefine :: CompileErrorM m => ParserE m (ValueRefine SourcePos) singleRefine = do   c <- getPosition   try kwRefines   t <- sourceParser   return $ ValueRefine [c] t -singleDefine :: Parser (ValueDefine SourcePos)+singleDefine :: CompileErrorM m => ParserE m (ValueDefine SourcePos) singleDefine = do   c <- getPosition   try kwDefines   t <- sourceParser   return $ ValueDefine [c] t -singleFilter :: Parser (ParamFilter SourcePos)+singleFilter :: CompileErrorM m => ParserE m (ParamFilter SourcePos) singleFilter = try $ do   c <- getPosition   n <- sourceParser   f <- sourceParser   return $ ParamFilter [c] n f -parseCategoryRefines :: Parser [ValueRefine SourcePos]+parseCategoryRefines :: CompileErrorM m => ParserE m [ValueRefine SourcePos] parseCategoryRefines = sepAfter $ sepBy singleRefine optionalSpace -parseFilters :: Parser [ParamFilter SourcePos]+parseFilters :: CompileErrorM m => ParserE m [ParamFilter SourcePos] parseFilters = sepBy singleFilter optionalSpace -parseRefinesFilters :: Parser ([ValueRefine SourcePos],[ParamFilter SourcePos])+parseRefinesFilters :: CompileErrorM m => ParserE m ([ValueRefine SourcePos],[ParamFilter SourcePos]) parseRefinesFilters = parsed >>= return . merge2 where   parsed = sepBy anyType optionalSpace   anyType = labeled "refine or param filter" $ put12 singleRefine <|> put22 singleFilter -parseRefinesDefinesFilters :: Parser ([ValueRefine SourcePos],-                                      [ValueDefine SourcePos],-                                      [ParamFilter SourcePos])+parseRefinesDefinesFilters :: CompileErrorM m =>+  ParserE m ([ValueRefine SourcePos],[ValueDefine SourcePos],[ParamFilter SourcePos]) parseRefinesDefinesFilters = parsed >>= return . merge3 where   parsed = sepBy anyType optionalSpace   anyType =@@ -161,13 +160,11 @@     e <- sepAfter $ many alphaNum     return $ FunctionName (b:e) -parseScopedFunction :: Parser SymbolScope -> Parser CategoryName ->-                       Parser (ScopedFunction SourcePos)+parseScopedFunction :: CompileErrorM m =>+  ParserE m SymbolScope -> ParserE m CategoryName -> ParserE m (ScopedFunction SourcePos) parseScopedFunction sp tp = labeled "function" $ do   c <- getPosition-  s <- try sp -- Could be a constant, i.e., nothing consumed.-  t <- try tp -- Same here.-  n <- try sourceParser+  (s,t,n) <- try parseName   ps <- fmap Positional $ noParams <|> someParams   fa <- parseFilters   as <- fmap Positional $ typeList "argument type"@@ -175,6 +172,11 @@   rs <- fmap Positional $ typeList "return type"   return $ ScopedFunction [c] n t s as rs ps fa []   where+    parseName = do+      s <- sp -- Could be a constant, i.e., nothing consumed.+      t <- tp -- Same here.+      n <- sourceParser+      return (s,t,n)     noParams = notFollowedBy (string "<") >> return []     someParams = between (sepAfter $ string_ "<")                          (sepAfter $ string_ ">")@@ -191,14 +193,14 @@       t <- sourceParser       return $ PassedValue [c] t -parseScope :: Parser SymbolScope+parseScope :: Monad m => ParserE m SymbolScope parseScope = try categoryScope <|> try typeScope <|> valueScope -categoryScope :: Parser SymbolScope+categoryScope :: Monad m => ParserE m SymbolScope categoryScope = kwCategory >> return CategoryScope -typeScope :: Parser SymbolScope+typeScope :: Monad m => ParserE m SymbolScope typeScope = kwType >> return TypeScope -valueScope :: Parser SymbolScope+valueScope :: Monad m => ParserE m SymbolScope valueScope = kwValue >> return ValueScope

@@ -46,7 +46,6 @@ import System.FilePath import System.IO import Text.Parsec-import Text.Parsec.String import qualified Data.Map as Map import qualified Data.Set as Set @@ -72,26 +71,16 @@   | otherwise        = Right (getCompileSuccess c)  forceParse :: ParseFromSource a => String -> a-forceParse s = force $ parse sourceParser "(string)" s where-  force (Right x) = x-  force _         = undefined+forceParse s = getCompileSuccess $ runParserE sourceParser "(string)" s  readSingle :: ParseFromSource a => String -> String -> CompileInfo a-readSingle = readSingleWith (optionalSpace >> sourceParser)+readSingle  = readSingleWith sourceParser -readSingleWith :: Parser a -> String -> String -> CompileInfo a-readSingleWith p f s =-  unwrap $ parse (between nullParse endOfDoc p) f s-  where-    unwrap (Left e)  = compileErrorM (show e)-    unwrap (Right t) = return t+readSingleWith :: ParserE CompileInfo a -> String -> String -> CompileInfo a+readSingleWith p = runParserE (between nullParse endOfDoc p)  readMulti :: ParseFromSource a => String -> String -> CompileInfo [a]-readMulti f s =-  unwrap $ parse (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s-  where-    unwrap (Left e)  = compileErrorM (show e)-    unwrap (Right t) = return t+readMulti f s = runParserE (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s  parseFilterMap :: [(String,[String])] -> CompileInfo ParamFilters parseFilterMap pa = do@@ -118,7 +107,7 @@   check $ validateGeneralInstance r pa2 t   where     prefix = x ++ " " ++ showParams pa-    check x2 = x2 <!! (prefix ++ ":")+    check x2 = x2 <!! prefix ++ ":"  checkTypeFail :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo () checkTypeFail r pa x = do@@ -137,7 +126,7 @@   check $ validateDefinesInstance r pa2 t   where     prefix = x ++ " " ++ showParams pa-    check x2 = x2 <!! (prefix ++ ":")+    check x2 = x2 <!! prefix ++ ":"  checkDefinesFail :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo () checkDefinesFail r pa x = do@@ -158,7 +147,7 @@  containsNoDuplicates :: (Ord a, Show a) => [a] -> CompileInfo () containsNoDuplicates expected =-  (mapErrorsM_ checkSingle $ group $ sort expected) <!! (show expected)+  (mapErrorsM_ checkSingle $ group $ sort expected) <!! show expected   where     checkSingle xa@(x:_:_) =       compileErrorM $ "Item " ++ show x ++ " occurs " ++ show (length xa) ++ " times"@@ -167,7 +156,7 @@ containsAtLeast :: (Ord a, Show a) => [a] -> [a] -> CompileInfo () containsAtLeast actual expected =   (mapErrorsM_ (checkInActual $ Set.fromList actual) expected) <!!-        (show actual ++ " (actual) vs. " ++ show expected ++ " (expected)")+        show actual ++ " (actual) vs. " ++ show expected ++ " (expected)"   where     checkInActual va v =       if v `Set.member` va@@ -177,7 +166,7 @@ containsAtMost :: (Ord a, Show a) => [a] -> [a] -> CompileInfo () containsAtMost actual expected =   (mapErrorsM_ (checkInExpected $ Set.fromList expected) actual) <!!-        (show actual ++ " (actual) vs. " ++ show expected ++ " (expected)")+        show actual ++ " (actual) vs. " ++ show expected ++ " (expected)"   where     checkInExpected va v =       if v `Set.member` va

@@ -31,17 +31,32 @@ import Test.Common import Types.DefinedCategory import Types.IntegrationTest-import Types.Positional-import Types.Procedure import Types.TypeCategory-import Types.TypeInstance   tests :: [IO (CompileInfo ())] tests = [     checkFileContents+      ("testfiles" </> "basic_compiles_test.0rt")+      (\t -> do+        let h = itHeader t+        when (not $ isExpectCompiles $ ithResult h) $ compileErrorM "Expected ExpectCompiles"+        checkEquals (ithTestName h) "basic compiles test"+        containsExactly (getRequirePattern $ ithResult h) [+            OutputPattern OutputCompiler "pattern in output 1",+            OutputPattern OutputAny      "pattern in output 2"+          ]+        containsExactly (getExcludePattern $ ithResult h) [+            OutputPattern OutputStderr "pattern not in output 1",+            OutputPattern OutputStdout "pattern not in output 2"+          ]+        containsExactly (extractCategoryNames t) ["Test"]+        containsExactly (extractDefinitionNames t) ["Test"]+        ),++    checkFileContents       ("testfiles" </> "basic_error_test.0rt")-      (\t -> return $ do+      (\t -> do         let h = itHeader t         when (not $ isExpectCompileError $ ithResult h) $ compileErrorM "Expected ExpectCompileError"         checkEquals (ithTestName h) "basic error test"@@ -59,17 +74,10 @@      checkFileContents       ("testfiles" </> "basic_crash_test.0rt")-      (\t -> return $ do+      (\t -> do         let h = itHeader t         when (not $ isExpectRuntimeError $ ithResult h) $ compileErrorM "Expected ExpectRuntimeError"         checkEquals (ithTestName h) "basic crash test"-        let match = case ereExpression $ ithResult h of-                         (Expression _-                           (TypeCall _-                             (JustTypeInstance (TypeInstance (CategoryName "Test") (Positional [])))-                             (FunctionCall _ (FunctionName "execute") (Positional []) (Positional []))) []) -> True-                         _ -> False-        when (not match) $ compileErrorM "Expected test expression \"Test$execute()\""         containsExactly (getRequirePattern $ ithResult h) [             OutputPattern OutputAny "pattern in output 1",             OutputPattern OutputAny "pattern in output 2"@@ -84,17 +92,10 @@      checkFileContents       ("testfiles" </> "basic_success_test.0rt")-      (\t -> return $ do+      (\t -> do         let h = itHeader t         when (not $ isExpectRuntimeSuccess $ ithResult h) $ compileErrorM "Expected ExpectRuntimeSuccess"         checkEquals (ithTestName h) "basic success test"-        let match = case ersExpression $ ithResult h of-                         (Expression _-                           (TypeCall _-                             (JustTypeInstance (TypeInstance (CategoryName "Test") (Positional [])))-                             (FunctionCall _ (FunctionName "execute") (Positional []) (Positional []))) []) -> True-                         _ -> False-        when (not match) $ compileErrorM "Expected test expression \"Test$execute()\""         containsExactly (getRequirePattern $ ithResult h) [             OutputPattern OutputAny "pattern in output 1",             OutputPattern OutputAny "pattern in output 2"@@ -109,13 +110,11 @@   ]  checkFileContents ::-  String -> (IntegrationTest SourcePos -> IO (CompileInfo ())) -> IO (CompileInfo ())-checkFileContents f o = do-  s <- loadFile f-  unwrap $ parse (between optionalSpace endOfDoc sourceParser) f s-  where-    unwrap (Left e)  = return $ compileErrorM (show e)-    unwrap (Right t) = fmap (("Check " ++ f ++ ":") ??>) $ o t+  String -> (IntegrationTest SourcePos -> CompileInfo ()) -> IO (CompileInfo ())+checkFileContents f o = toCompileInfo $ do+  s <- errorFromIO $ loadFile f+  t <- runParserE (between optionalSpace endOfDoc sourceParser) f s+  fromCompileInfo $ o t <!! "Check " ++ f ++ ":"  extractCategoryNames :: IntegrationTest c -> [String] extractCategoryNames = map (show . getCategoryName) . itCategory

@@ -30,94 +30,140 @@ import System.FilePath import Test.Common import Types.Positional+import Types.Pragma import Types.Procedure import Types.TypeCategory (FunctionName(..),Namespace(..)) import Types.TypeInstance (CategoryName(..)) -tests :: [IO (CompileInfo ())]-tests = [-    checkWriteThenRead $ CompileMetadata {-      cmVersionHash = VersionHash "0123456789ABCDEFabcdef",-      cmPath = "/home/project/special",-      cmPublicNamespace = StaticNamespace "public_ABCDEF",-      cmPrivateNamespace = StaticNamespace "private_ABCDEF",-      cmPublicDeps = [-        "/home/project/public-dep1",-        "/home/project/public-dep2"-      ],-      cmPrivateDeps = [-        "/home/project/private-dep1",-        "/home/project/private-dep2"-      ],-      cmPublicCategories = [-        CategoryName "MyCategory",-        CategoryName "MyOtherCategory"-      ],-      cmPrivateCategories = [-        CategoryName "PrivateCategory",-        CategoryName "PrivateOtherCategory"-      ],-      cmPublicSubdirs = [-        "/home/project/special/subdir1",-        "/home/project/special/subdir2"-      ],-      cmPrivateSubdirs = [-        "/home/project/special/subdir1",-        "/home/project/special/subdir2"-      ],-      cmPublicFiles = [-        "/home/project/special/category1.0rp",-        "/home/project/special/category2.0rp"-      ],-      cmPrivateFiles = [-        "/home/project/special/category1.0rx",-        "/home/project/special/category2.0rx"-      ],-      cmTestFiles = [-        "/home/project/special/category1.0rt",-        "/home/project/special/category2.0rt"-      ],-      cmHxxFiles = [-        "/home/project/special/category1.hpp",-        "/home/project/special/category2.hpp"-      ],-      cmCxxFiles = [-        "/home/project/special/category1.cpp",-        "/home/project/special/category2.cpp"-      ],-      cmBinaries = [-        "/home/project/special/binary1",-        "/home/project/special/binary2"-      ],-      cmLinkFlags = [++hugeCompileMetadata :: CompileMetadata  -- testfiles/module-cache.txt+hugeCompileMetadata = CompileMetadata {+    cmVersionHash = VersionHash "0123456789ABCDEFabcdef",+    cmPath = "/home/project/special",+    cmPublicNamespace = StaticNamespace "public_ABCDEF",+    cmPrivateNamespace = StaticNamespace "private_ABCDEF",+    cmPublicDeps = [+      "/home/project/public-dep1",+      "/home/project/public-dep2"+    ],+    cmPrivateDeps = [+      "/home/project/private-dep1",+      "/home/project/private-dep2"+    ],+    cmPublicCategories = [+      CategoryName "MyCategory",+      CategoryName "MyOtherCategory"+    ],+    cmPrivateCategories = [+      CategoryName "PrivateCategory",+      CategoryName "PrivateOtherCategory"+    ],+    cmPublicSubdirs = [+      "/home/project/special/subdir1",+      "/home/project/special/subdir2"+    ],+    cmPrivateSubdirs = [+      "/home/project/special/subdir1",+      "/home/project/special/subdir2"+    ],+    cmPublicFiles = [+      "/home/project/special/category1.0rp",+      "/home/project/special/category2.0rp"+    ],+    cmPrivateFiles = [+      "/home/project/special/category1.0rx",+      "/home/project/special/category2.0rx"+    ],+    cmTestFiles = [+      "/home/project/special/category1.0rt",+      "/home/project/special/category2.0rt"+    ],+    cmHxxFiles = [+      "/home/project/special/category1.hpp",+      "/home/project/special/category2.hpp"+    ],+    cmCxxFiles = [+      "/home/project/special/category1.cpp",+      "/home/project/special/category2.cpp"+    ],+    cmBinaries = [+      "/home/project/special/binary1",+      "/home/project/special/binary2"+    ],+    cmLinkFlags = [+      "-lm",+      "-ldl"+    ],+    cmObjectFiles = [+      CategoryObjectFile {+        cofCategory = CategoryIdentifier {+          ciPath = "/home/project/special",+          ciCategory = CategoryName "SpecialCategory",+          ciNamespace = StaticNamespace "public_ABCDEF"+        },+        cofRequires = [+          CategoryIdentifier {+            ciPath = "/home/project/private-dep1",+            ciCategory = CategoryName "PrivateCategory",+            ciNamespace = NoNamespace+          },+          UnresolvedCategory {+            ucCategory = CategoryName "UnresolvedCategory"+          }+        ],+        cofFiles = [+          "/home/project/special/object1.o",+          "/home/project/special/object1.o"+        ]+      }+    ]+  }++hugeModuleConfig :: ModuleConfig  -- testfiles/module-config.txt+hugeModuleConfig = ModuleConfig {+    mcRoot = "/home/projects",+    mcPath = "special",+    mcExprMap = [],+    mcPublicDeps = [+      "/home/project/public-dep1",+      "/home/project/public-dep2"+    ],+    mcPrivateDeps = [+      "/home/project/private-dep1",+      "/home/project/private-dep2"+    ],+    mcExtraFiles = [+      CategorySource {+        csSource = "extra1.cpp",+        csCategories = [+          CategoryName "Category1",+          CategoryName "Category2"+        ],+        csRequires = [+          CategoryName "DepCategory1",+          CategoryName "DepCategory2"+        ]+      },+      OtherSource {+        osSource = "extra2.cpp"+      }+    ],+    mcExtraPaths = [+      "extra1",+      "extra2"+    ],+    mcMode = CompileIncremental {+      ciLinkFlags = [         "-lm",         "-ldl"-      ],-      cmObjectFiles = [-        CategoryObjectFile {-          cofCategory = CategoryIdentifier {-            ciPath = "/home/project/special",-            ciCategory = CategoryName "SpecialCategory",-            ciNamespace = StaticNamespace "public_ABCDEF"-          },-          cofRequires = [-            CategoryIdentifier {-              ciPath = "/home/project/private-dep1",-              ciCategory = CategoryName "PrivateCategory",-              ciNamespace = NoNamespace-            },-            UnresolvedCategory {-              ucCategory = CategoryName "UnresolvedCategory"-            }-          ],-          cofFiles = [-            "/home/project/special/object1.o",-            "/home/project/special/object1.o"-          ]-        }       ]-    },+    }+  } +tests :: [IO (CompileInfo ())]+tests = [+    checkWriteThenRead hugeCompileMetadata,+     checkWriteFail "bad hash" $ CompileMetadata {       cmVersionHash = VersionHash "bad hash",       cmPath = "/home/project/special",@@ -227,50 +273,12 @@       cmObjectFiles = []     }, -    checkWriteThenRead $ ModuleConfig {-      mcRoot = "/home/projects",-      mcPath = "special",-      mcExprMap = [],-      mcPublicDeps = [-        "/home/project/public-dep1",-        "/home/project/public-dep2"-      ],-      mcPrivateDeps = [-        "/home/project/private-dep1",-        "/home/project/private-dep2"-      ],-      mcExtraFiles = [-        CategorySource {-          csSource = "extra1.cpp",-          csCategories = [-            CategoryName "Category1",-            CategoryName "Category2"-          ],-          csRequires = [-            CategoryName "DepCategory1",-            CategoryName "DepCategory2"-          ]-        },-        OtherSource {-          osSource = "extra2.cpp"-        }-      ],-      mcExtraPaths = [-        "extra1",-        "extra2"-      ],-      mcMode = CompileIncremental {-        ciLinkFlags = [-          "-lm",-          "-ldl"-        ]-      }-    },+    checkWriteThenRead hugeModuleConfig,      checkWriteFail "empty.+map" $ ModuleConfig {       mcRoot = "/home/projects",       mcPath = "special",-      mcExprMap = [("MACRO",Literal (StringLiteral [] "something"))],+      mcExprMap = [(MacroName "MACRO",Literal (StringLiteral [] "something"))],       mcPublicDeps = [],       mcPrivateDeps = [],       mcExtraFiles = [],@@ -351,25 +359,29 @@     checkWriteFail "compile mode" $ CompileRecompileRecursive,     checkWriteFail "compile mode" $ CreateTemplates, -    checkParsesAs ("testfiles" </> "module-config.txt")+    checkParsesAs ("testfiles" </> "macro-config.txt")       (\m -> case mcExprMap m of-                  [("MY_MACRO",+                  [(MacroName "MY_MACRO",                     Expression _ (BuiltinCall _                       (FunctionCall _ BuiltinRequire (Positional [])                         (Positional [Literal (EmptyLiteral _)]))) []),-                   ("MY_OTHER_MACRO",+                   (MacroName "MY_OTHER_MACRO",                     Expression _                       (TypeCall _ _                         (FunctionCall _ (FunctionName "execute") (Positional [])                           (Positional [Literal (StringLiteral _ "this is a string\n")]))) [])                     ] -> True-                  _ -> False)+                  _ -> False),++    checkParsesAs ("testfiles" </> "module-config.txt") (== hugeModuleConfig),++    checkParsesAs ("testfiles" </> "module-cache.txt") (== hugeCompileMetadata)   ]  checkWriteThenRead :: (Eq a, Show a, ConfigFormat a) => a -> IO (CompileInfo ()) checkWriteThenRead m = return $ do   text <- fmap spamComments $ autoWriteConfig m-  m' <- autoReadConfig "(string)" text <!! ("Serialized >>>\n\n" ++ text ++ "\n<<< Serialized\n\n")+  m' <- autoReadConfig "(string)" text <!! "Serialized >>>\n\n" ++ text ++ "\n<<< Serialized\n\n"   when (m' /= m) $     compileErrorM $ "Failed to match after write/read\n" ++                    "Before:\n" ++ show m ++ "\n" ++@@ -397,7 +409,7 @@   return $ check parsed contents   where     check x contents = do-      x' <- x <!! ("While parsing " ++ f)+      x' <- x <!! "While parsing " ++ f       when (not $ m x') $         compileErrorM $ "Failed to match after write/read\n" ++                        "Unparsed:\n" ++ contents ++ "\n" ++

@@ -26,7 +26,6 @@ import Base.CompileInfo import Parser.Common import Test.Common-import Text.Parsec.String   tests :: [IO (CompileInfo ())]@@ -57,7 +56,7 @@     checkParseFail regexChar "\""   ] -checkParsesAs :: (Eq a, Show a) => Parser a -> [Char] -> a -> IO (CompileInfo ())+checkParsesAs :: (Eq a, Show a) => ParserE CompileInfo a -> [Char] -> a -> IO (CompileInfo ()) checkParsesAs p s m = return $ do   let parsed = readSingleWith p "(string)" s   check parsed@@ -69,7 +68,7 @@       | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)       | otherwise = return () -checkParseFail :: Show a => Parser a -> [Char] -> IO (CompileInfo ())+checkParseFail :: Show a => ParserE CompileInfo a -> [Char] -> IO (CompileInfo ()) checkParseFail p s = do   let parsed = readSingleWith p "(string)" s   return $ check parsed

@@ -20,11 +20,11 @@  import Control.Monad (when) import Text.Parsec-import Text.Parsec.String import Text.Regex.TDFA -- Not safe!  import Base.CompileError import Base.CompileInfo+import Parser.Common import Parser.Pragma import Test.Common import Types.Pragma@@ -64,7 +64,7 @@      checkParsesAs "$ExprLookup[ \nMODULE_PATH /*comment*/\n ]$" (fmap (:[]) pragmaExprLookup)       (\e -> case e of-                  [PragmaExprLookup _ "MODULE_PATH"] -> True+                  [PragmaExprLookup _ (MacroName "MODULE_PATH")] -> True                   _ -> False),      checkParsesAs "/*only comments*/" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly])@@ -98,7 +98,7 @@     checkParseError "$ExprLookup[ \"bad stuff\" ]$" "macro name" pragmaExprLookup   ] -checkParsesAs :: String -> Parser [Pragma SourcePos] -> ([Pragma SourcePos] -> Bool) -> IO (CompileInfo ())+checkParsesAs :: String -> ParserE CompileInfo [Pragma SourcePos] -> ([Pragma SourcePos] -> Bool) -> IO (CompileInfo ()) checkParsesAs s p m = return $ do   let parsed = readSingleWith p "(string)" s   check parsed@@ -110,7 +110,7 @@       | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)       | otherwise = return () -checkParseError :: String -> String -> Parser (Pragma SourcePos) -> IO (CompileInfo ())+checkParseError :: String -> String -> ParserE CompileInfo (Pragma SourcePos) -> IO (CompileInfo ()) checkParseError s m p = return $ do   let parsed = readSingleWith p "(string)" s   check parsed

@@ -200,15 +200,15 @@     checkShortParseSuccess "x <- 123.0 + z.call()",     checkShortParseFail "x <- \"123\".call()",     checkShortParseFail "x <- 123.call()",-    checkShortParseSuccess " x <- 'x'",-    checkShortParseSuccess " x <- '\\xAA'",-    checkShortParseFail " x <- '\\xAAZ'",-    checkShortParseSuccess " x <- '\076'",-    checkShortParseFail " x <- '\\07'",-    checkShortParseSuccess " x <- '\\n'",-    checkShortParseFail " x <- 'x",-    checkShortParseFail " x <- 'xx'",-    checkShortParseSuccess " x <- \"'xx\"",+    checkShortParseSuccess "x <- 'x'",+    checkShortParseSuccess "x <- '\\xAA'",+    checkShortParseFail "x <- '\\xAAZ'",+    checkShortParseSuccess "x <- '\076'",+    checkShortParseFail "x <- '\\07'",+    checkShortParseSuccess "x <- '\\n'",+    checkShortParseFail "x <- 'x",+    checkShortParseFail "x <- 'xx'",+    checkShortParseSuccess "x <- \"'xx\"",      checkParsesAs "'\"'"                   (\e -> case e of

@@ -1194,7 +1194,7 @@     compileErrorM $ "Different item counts: " ++ show actual ++ " (actual) vs. " ++                    show expected ++ " (expected)"   | otherwise = mapErrorsM_ check (zip3 actual expected ([1..] :: [Int])) where-    check (a,e,n) = f a e <!! ("Item " ++ show n ++ " mismatch")+    check (a,e,n) = f a e <!! "Item " ++ show n ++ " mismatch"  containsPaired :: (Eq a, Show a) => [a] -> [a] -> CompileInfo () containsPaired = checkPaired checkSingle where@@ -1208,7 +1208,7 @@   let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos]   return $ check (parsed >>= o >> return ())   where-    check x = x <!! ("Check " ++ f ++ ":")+    check x = x <!! "Check " ++ f ++ ":"  checkOperationFail :: String -> ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) checkOperationFail f o = do

@@ -957,8 +957,8 @@   Map.Map CategoryName (Map.Map CategoryName (InstanceParams -> InstanceParams))   -> TypeInstance -> CategoryName -> m InstanceParams getParams ma (TypeInstance n1 ps1) n2 = do-  ra <- mapLookup ma n1 <?? ("In lookup of category " ++ show n1)-  f <- mapLookup ra n2 <?? ("In lookup of parent " ++ show n2 ++ " of " ++ show n1)+  ra <- mapLookup ma n1 <?? "In lookup of category " ++ show n1+  f <- mapLookup ra n2 <?? "In lookup of parent " ++ show n2 ++ " of " ++ show n1   return $ f ps1  getTypeFilters :: CompileErrorM m => TypeInstance -> m InstanceFilters

@@ -0,0 +1,19 @@+testcase "basic compiles test" {+  compiles+  require compiler "pattern in output 1"+  exclude stderr   "pattern not in output 1"+  require any      "pattern in output 2"+  exclude stdout   "pattern not in output 2"+}++concrete Test {+  @type execute () -> ()+}++define Test {+  execute () { }+}++unittest test {+  \ Test.execute()+}

@@ -1,5 +1,5 @@ testcase "basic crash test" {-  crash Test.execute()+  crash   require "pattern in output 1"   exclude "pattern not in output 1"   require "pattern in output 2"@@ -12,4 +12,8 @@  define Test {   execute () { }+}++unittest test {+  \ Test.execute() }

@@ -13,3 +13,7 @@ define Test {   execute () { } }++unittest test {+  \ Test.execute()+}

@@ -1,5 +1,5 @@ testcase "basic success test" {-  success Test.execute()+  success   require "pattern in output 1"   exclude "pattern not in output 1"   require "pattern in output 2"@@ -12,4 +12,8 @@  define Test {   execute () { }+}++unittest test {+  \ Test.execute() }

@@ -1,4 +1,3 @@-// A concrete type with contrived comments. concrete/*!!!*/Type<#a,#b // <- contravariant params              |#c,#d // <- invariant params              |#e,#f /* <- covariant params*/> {

@@ -0,0 +1,12 @@+path: "testfiles"+expression_map: [+  expression_macro {+    name: MY_MACRO+    expression: require(empty)+  }+  expression_macro {+    name: MY_OTHER_MACRO+    expression: Type<Int>.execute("this is a string\012")+  }+]+mode: incremental {}

@@ -0,0 +1,76 @@+public_categories: [+  MyCategory+  MyOtherCategory+]+private_categories: [+  PrivateCategory+  PrivateOtherCategory+]+public_subdirs: [+  "/home/project/special/subdir1"+  "/home/project/special/subdir2"+]+private_subdirs: [+  "/home/project/special/subdir1"+  "/home/project/special/subdir2"+]+version_hash: 0123456789ABCDEFabcdef+path: "/home/project/special"+public_namespace: public_ABCDEF+hxx_files: [+  "/home/project/special/category1.hpp"+  "/home/project/special/category2.hpp"+]+private_namespace: private_ABCDEF+public_deps: [+  "/home/project/public-dep1"+  "/home/project/public-dep2"+]+private_deps: [+  "/home/project/private-dep1"+  "/home/project/private-dep2"+]+private_files: [+  "/home/project/special/category1.0rx"+  "/home/project/special/category2.0rx"+]+test_files: [+  "/home/project/special/category1.0rt"+  "/home/project/special/category2.0rt"+]+public_files: [+  "/home/project/special/category1.0rp"+  "/home/project/special/category2.0rp"+]+cxx_files: [+  "/home/project/special/category1.cpp"+  "/home/project/special/category2.cpp"+]+object_files: [+  category_object {+    category: category {+      path: "/home/project/special"+      namespace: public_ABCDEF+      name: SpecialCategory+    }+    requires: [+      category {+        path: "/home/project/private-dep1"+        name: PrivateCategory+      }+      unresolved { name: UnresolvedCategory }+    ]+    files: [+      "/home/project/special/object1.o"+      "/home/project/special/object1.o"+    ]+  }+]+binaries: [+  "/home/project/special/binary1"+  "/home/project/special/binary2"+]+link_flags: [+  "-lm"+  "-ldl"+]

@@ -1,12 +1,36 @@-path: "testfiles"+public_deps: [+  "/home/project/public-dep1"+  "/home/project/public-dep2"+]+root: "/home/projects" expression_map: [-  expression_macro {-    name: MY_MACRO-    expression: require(empty)-  }-  expression_macro {-    name: MY_OTHER_MACRO-    expression: Type<Int>.execute("this is a string\012")+]+mode: incremental {+  link_flags: [+    "-lm"+    "-ldl"+  ]+}+private_deps: [+  "/home/project/private-dep1"+  "/home/project/private-dep2"+]+include_paths: [+  "extra1"+  "extra2"+]+path: "special"+extra_files: [+  category_source {+    requires: [+      DepCategory1+      DepCategory2+    ]+    source: "extra1.cpp"+    categories: [+      Category1+      Category2+    ]   }+  "extra2.cpp" ]-mode: incremental {}

@@ -1,5 +1,9 @@ testcase "test" {-  success Test.run()+  success+}++unittest test {+  \ Test.run() }  concrete Test {

@@ -27,19 +27,21 @@   getExcludePattern,   getRequirePattern,   isExpectCompileError,+  isExpectCompiles,   isExpectRuntimeError,   isExpectRuntimeSuccess, ) where  import Types.TypeCategory import Types.DefinedCategory-import Types.Procedure (Expression)+import Types.Procedure   data IntegrationTestHeader c =   IntegrationTestHeader {     ithContext :: [c],     ithTestName :: String,+    ithArgs :: [String],     ithResult :: ExpectedResult c   } @@ -47,7 +49,8 @@   IntegrationTest {     itHeader :: IntegrationTestHeader c,     itCategory :: [AnyCategory c],-    itDefinition :: [DefinedCategory c]+    itDefinition :: [DefinedCategory c],+    itTests :: [TestProcedure c]   }  data ExpectedResult c =@@ -56,15 +59,18 @@     eceRequirePattern :: [OutputPattern],     eceExcludePattern :: [OutputPattern]   } |+  ExpectCompiles {+    eceContext :: [c],+    eceRequirePattern :: [OutputPattern],+    eceExcludePattern :: [OutputPattern]+  } |   ExpectRuntimeError {     ereContext :: [c],-    ereExpression :: Expression c,     ereRequirePattern :: [OutputPattern],     ereExcludePattern :: [OutputPattern]   } |   ExpectRuntimeSuccess {     ersContext :: [c],-    ersExpression :: Expression c,     ersRequirePattern :: [OutputPattern],     ersExcludePattern :: [OutputPattern]   }@@ -78,24 +84,30 @@  data OutputScope = OutputAny | OutputCompiler | OutputStderr | OutputStdout deriving (Eq,Ord,Show) +isExpectCompiles :: ExpectedResult c -> Bool+isExpectCompiles (ExpectCompiles _ _ _) = True+isExpectCompiles _                      = False+ isExpectCompileError :: ExpectedResult c -> Bool isExpectCompileError (ExpectCompileError _ _ _) = True isExpectCompileError _                          = False  isExpectRuntimeError :: ExpectedResult c -> Bool-isExpectRuntimeError (ExpectRuntimeError _ _ _ _) = True-isExpectRuntimeError _                            = False+isExpectRuntimeError (ExpectRuntimeError _ _ _) = True+isExpectRuntimeError _                          = False  isExpectRuntimeSuccess :: ExpectedResult c -> Bool-isExpectRuntimeSuccess (ExpectRuntimeSuccess _ _ _ _) = True-isExpectRuntimeSuccess _                              = False+isExpectRuntimeSuccess (ExpectRuntimeSuccess _ _ _) = True+isExpectRuntimeSuccess _                            = False  getRequirePattern :: ExpectedResult c -> [OutputPattern]-getRequirePattern (ExpectCompileError _ rs _)     = rs-getRequirePattern (ExpectRuntimeError _ _ rs _)   = rs-getRequirePattern (ExpectRuntimeSuccess _ _ rs _) = rs+getRequirePattern (ExpectCompiles _ rs _)       = rs+getRequirePattern (ExpectCompileError _ rs _)   = rs+getRequirePattern (ExpectRuntimeError _ rs _)   = rs+getRequirePattern (ExpectRuntimeSuccess _ rs _) = rs  getExcludePattern :: ExpectedResult c -> [OutputPattern]-getExcludePattern (ExpectCompileError _ _ es)     = es-getExcludePattern (ExpectRuntimeError _ _ _ es)   = es-getExcludePattern (ExpectRuntimeSuccess _ _ _ es) = es+getExcludePattern (ExpectCompiles _ _ es)       = es+getExcludePattern (ExpectCompileError _ _ es)   = es+getExcludePattern (ExpectRuntimeError _ _ es)   = es+getExcludePattern (ExpectRuntimeSuccess _ _ es) = es

@@ -20,6 +20,7 @@  module Types.Pragma (   CodeVisibility(..),+  MacroName(..),   Pragma(..),   TraceType(..),   WithVisibility(..),@@ -59,6 +60,15 @@  data TraceType = NoTrace | TraceCreation deriving (Show) +newtype MacroName =+  MacroName {+    mnName :: String+  }+  deriving (Eq,Ord)++instance Show MacroName where+  show = mnName+ data Pragma c =   PragmaVisibility {     pvContext :: [c],@@ -66,7 +76,7 @@   } |   PragmaExprLookup {     pelContext :: [c],-    pelName :: String+    pelName :: MacroName   } |   PragmaSourceContext {     pscContext :: c

@@ -36,6 +36,7 @@   ReturnValues(..),   ScopedBlock(..),   Statement(..),+  TestProcedure(..),   ValueLiteral(..),   ValueOperation(..),   VariableName(..),@@ -139,6 +140,13 @@ instance Show c => Show (OutputValue c) where   show (OutputValue c v) = show v ++ " /*" ++ formatFullContext c ++ "*/" +data TestProcedure c =+  TestProcedure {+    tpContext :: [c],+    tpName :: FunctionName,+    tpProcedure :: Procedure c+  }+  deriving (Show)  data Procedure c =   Procedure [c] [Statement c]@@ -240,7 +248,7 @@  data ExpressionStart c =   NamedVariable (OutputValue c) |-  NamedMacro [c] String |+  NamedMacro [c] MacroName |   CategoryCall [c] CategoryName (FunctionCall c) |   TypeCall [c] TypeInstanceOrParam (FunctionCall c) |   UnqualifiedCall [c] (FunctionCall c) |

@@ -501,20 +501,16 @@ disallowBoundedParams :: CompileErrorM m => ParamFilters -> m () disallowBoundedParams = mapErrorsM_ checkBounds . Map.toList where   checkBounds (p,fs) = do-    let bs = splitBounds fs-    case bs of-         ([],_) -> return ()-         (_,[]) -> return ()-         (ls,hs) -> ("Param " ++ show p ++ " cannot have both lower and upper bounds") !!>-           collectAllM_ [-               mapErrorsM_ (filterAsError p) ls <!! "Lower bound:",-               mapErrorsM_ (filterAsError p) hs <!! "Upper bound:"-             ]-  splitBounds (f@(TypeFilter FilterRequires _):fs) = let (ls,hs) = splitBounds fs in (ls,f:hs)-  splitBounds (f@(TypeFilter FilterAllows   _):fs) = let (ls,hs) = splitBounds fs in (f:ls,hs)-  splitBounds (_:fs) = splitBounds fs-  splitBounds _ = ([],[])-  filterAsError p f = compileErrorM $ show p ++ " " ++ show f+    let (lb,ub) = foldr splitBounds (minBound,maxBound) fs+    when (lb /= minBound && ub /= maxBound) $+      ("Param " ++ show p ++ " cannot have both lower and upper bounds") !!>+        collectAllM_ [+            compileErrorM $ "Lower bound: " ++ show lb,+            compileErrorM $ "Upper bound: " ++ show ub+          ]+  splitBounds (TypeFilter FilterRequires t) (lb,ub) = (lb,t<&&>ub)+  splitBounds (TypeFilter FilterAllows   t) (lb,ub) = (t<||>lb,ub)+  splitBounds _ bs = bs  checkConnectedTypes :: (Show c, CompileErrorM m) =>   CategoryMap c -> [AnyCategory c] -> m ()@@ -1044,8 +1040,12 @@   }   deriving (Eq,Ord) -instance Show a => Show (GuessRange a) where-  show (GuessRange lo hi) = "Something between " ++ show lo ++ " and " ++ show hi+instance (Bounded a, Eq a, Show a) => Show (GuessRange a) where+  show (GuessRange lo hi)+    | lo == minBound && hi == maxBound = "Literally anything is possible"+    | lo == minBound = "Something at or below " ++ show hi+    | hi == maxBound = "Something at or above " ++ show lo+    | otherwise = "Something between " ++ show lo ++ " and " ++ show hi  data GuessUnion a =   GuessUnion {

@@ -355,7 +355,9 @@ checkGeneralMatch :: (CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> Variance ->   GeneralInstance -> GeneralInstance -> m (MergeTree InferredTypeGuess)-checkGeneralMatch r f v t1 t2 = collectFirstM [matchInferredRight,bothSingle,matchNormal v] where+checkGeneralMatch r f v t1 t2 = do+  ss <- collectFirstM [fmap Just bothSingle,return Nothing]+  collectFirstM [matchInferredRight,getMatcher ss] where   matchNormal Invariant =     mergeAllM [matchNormal Contravariant,matchNormal Covariant]   matchNormal Contravariant =@@ -368,7 +370,11 @@   bothSingle = do     t1' <- matchOnlyLeaf t1     t2' <- matchOnlyLeaf t2-    checkSingleMatch r f v t1' t2'+    return (t1',t2')+  getMatcher ss =+    case ss of+         Just (t1',t2') -> checkSingleMatch r f v t1' t2'+         Nothing        -> matchNormal v  checkSingleMatch :: (CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> Variance ->@@ -399,7 +405,7 @@   | v == Contravariant = do     ps2' <- trRefines r t2 n1     checkInstanceToInstance r f Contravariant t1 (TypeInstance n1 ps2')-  | otherwise = compileErrorM $ "Category " ++ show n2 ++ " is required but got " ++ show n2+  | otherwise = compileErrorM $ "Category " ++ show n2 ++ " is required but got " ++ show n1  checkParamToInstance :: (CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> Variance -> ParamName -> TypeInstance -> m (MergeTree InferredTypeGuess)

@@ -14,8 +14,25 @@     name: META_VAR     expression: $ExprLookup[INT_EXPR]$*5   }+  expression_macro {+    name: USES_RECURSIVE+    expression: 7 * $ExprLookup[RECURSIVE_MACRO1]$+  }+  expression_macro {+    name: RECURSIVE_MACRO1+    expression: 100 + $ExprLookup[RECURSIVE_MACRO2]$+  }+  expression_macro {+    name: RECURSIVE_MACRO2+    expression: $ExprLookup[RECURSIVE_MACRO3]$ - 200+  }+  expression_macro {+    name: RECURSIVE_MACRO3+    expression: $ExprLookup[RECURSIVE_MACRO1]$+  } ] private_deps: [+  "lib/testing"   "visibility"   "visibility2" ]

@@ -1,54 +0,0 @@-/* ------------------------------------------------------------------------------Copyright 2020 Kevin P. Barry--Licensed under the Apache License, Version 2.0 (the "License");-you may not use this file except in compliance with the License.-You may obtain a copy of the License at--    http://www.apache.org/licenses/LICENSE-2.0--Unless required by applicable law or agreed to in writing, software-distributed under the License is distributed on an "AS IS" BASIS,-WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.-See the License for the specific language governing permissions and-limitations under the License.------------------------------------------------------------------------------ */--// Author: Kevin P. Barry [ta0kira@gmail.com]--testcase "overwrite arg" {-  error-  require "arg"-}--define Test {-  @type call (Int) -> ()-  call (arg) {-    arg <- 2-  }--  run () {}-}--concrete Test {-  @type run () -> ()-}---testcase "self in @category function" {-  error-  require "self"-}--define Test {-  @category call () -> ()-  call () {-    Test value <- self-  }--  run () {}-}--concrete Test {-  @type run () -> ()-}

@@ -0,0 +1,2 @@+path: "/dev/null"+mode: incremental {}

@@ -0,0 +1,19 @@+# Bad Path in `.zeolite-module`++Compiling this module should **always fail**. It tests that a mismatch between+`root`/`path` from `.zeolite-module` and the path to the same `.zeolite-module`+causes an error.++To compile:++```shell+ZEOLITE_PATH=$(zeolite --get-path)+zeolite -p $ZEOLITE_PATH -r tests/bad-path+```++The compiler errors should look something like this:++```text+Zeolite execution failed:+  Expected module path from /home/user/zeolite/tests/bad-path/.zeolite-module to match .zeolite-module location but got /dev/null (resolved from root: "" and path: "/dev/null")+```

@@ -17,1058 +17,790 @@ // Author: Kevin P. Barry [ta0kira@gmail.com]  testcase "not true" {-  success Test.run()-}--define Test {-  run () {-    if (!true) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "reduce Bool" {-  success Test.run()-}--define Test {-  run () {-    if (!present(reduce<Bool,Bool>(true))) {-      fail("Failed")-    }-    if (!present(reduce<Bool,AsBool>(true))) {-      fail("Failed")-    }-    if (present(reduce<Bool,AsChar>(true))) {-      fail("Failed")-    }-    if (!present(reduce<Bool,AsInt>(true))) {-      fail("Failed")-    }-    if (!present(reduce<Bool,AsFloat>(true))) {-      fail("Failed")-    }-    if (!present(reduce<Bool,Formatted>(true))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "reduce Char" {-  success Test.run()-}--define Test {-  run () {-    if (!present(reduce<Char,Char>('a'))) {-      fail("Failed")-    }-    if (!present(reduce<Char,AsBool>('a'))) {-      fail("Failed")-    }-    if (!present(reduce<Char,AsChar>('a'))) {-      fail("Failed")-    }-    if (!present(reduce<Char,AsInt>('a'))) {-      fail("Failed")-    }-    if (!present(reduce<Char,AsFloat>('a'))) {-      fail("Failed")-    }-    if (!present(reduce<Char,Formatted>('a'))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "reduce Int" {-  success Test.run()-}--define Test {-  run () {-    if (!present(reduce<Int,Int>(1))) {-      fail("Failed")-    }-    if (!present(reduce<Int,AsBool>(1))) {-      fail("Failed")-    }-    if (!present(reduce<Int,AsChar>(1))) {-      fail("Failed")-    }-    if (!present(reduce<Int,AsInt>(1))) {-      fail("Failed")-    }-    if (!present(reduce<Int,AsFloat>(1))) {-      fail("Failed")-    }-    if (!present(reduce<Int,Formatted>(1))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "reduce Float" {-  success Test.run()-}--define Test {-  run () {-    if (!present(reduce<Float,Float>(1.0))) {-      fail("Failed")-    }-    if (!present(reduce<Float,AsBool>(1.0))) {-      fail("Failed")-    }-    if (present(reduce<Float,AsChar>(1.0))) {-      fail("Failed")-    }-    if (!present(reduce<Float,AsInt>(1.0))) {-      fail("Failed")-    }-    if (!present(reduce<Float,AsFloat>(1.0))) {-      fail("Failed")-    }-    if (!present(reduce<Float,Formatted>(1.0))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "reduce String" {-  success Test.run()-}--define Test {-  run () {-    if (!present(reduce<String,String>("a"))) {-      fail("Failed")-    }-    if (!present(reduce<String,AsBool>("a"))) {-      fail("Failed")-    }-    if (present(reduce<String,AsChar>("a"))) {-      fail("Failed")-    }-    if (present(reduce<String,AsInt>("a"))) {-      fail("Failed")-    }-    if (present(reduce<String,AsFloat>("a"))) {-      fail("Failed")-    }-    if (!present(reduce<String,Formatted>("a"))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "reduce ReadPosition success" {-  success Test.run()-}--define Test {-  run () {-    if (!present(reduce<ReadPosition<Char>,ReadPosition<Formatted>>("x"))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "reduce ReadPosition fail" {-  success Test.run()-}--define Test {-  run () {-    if (present(reduce<ReadPosition<Formatted>,ReadPosition<Char>>("x"))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String LessThan" {-  success Test.run()-}--define Test {-  run () {-    if (!("x" `String.lessThan` "y")) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Bool Equals" {-  success Test.run()-}--define Test {-  run () {-    if (!(true `Bool.equals` true)) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String Equals" {-  success Test.run()-}--define Test {-  run () {-    if (!("x" `String.equals` "x")) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String Builder" {-  success Test.run()-}--define Test {-  run () {-    Builder<String> builder <- String.builder()-    \ Testing.check<?>(builder.build(),"")-    \ Testing.check<?>(builder.append("xyz").build(),"xyz")-    \ Testing.check<?>(builder.append("123").build(),"xyz123")-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Char LessThan" {-  success Test.run()-}--define Test {-  run () {-    if (!('x' `Char.lessThan` 'y')) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Char Equals" {-  success Test.run()-}--define Test {-  run () {-    if (!('x' `Char.equals` 'x')) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int LessThan" {-  success Test.run()-}--define Test {-  run () {-    if (!(1 `Int.lessThan` 2)) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int Equals" {-  success Test.run()-}--define Test {-  run () {-    if (!(1 `Int.equals` 1)) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Float LessThan" {-  success Test.run()-}--define Test {-  run () {-    if (!(1.0 `Float.lessThan` 2.0)) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Float Equals" {-  success Test.run()-}--define Test {-  run () {-    if (!(1.0 `Float.equals` 1.0)) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Bool is shared" {-  success Test.run()-}--define Test {-  run () {-    Bool value1 <- true-    // Shared because true and false are boxed constants.-    weak Bool value2 <- value1-    if (!present(strong(value2))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String is shared" {-  success Test.run()-}--define Test {-  run () {-    String value1 <- "x"-    weak String value2 <- value1-    if (!present(strong(value2))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String Builder is not lazy" {-  success Test.run()-}--define Test {-  run () {-    optional String value1 <- "value"-    weak String value2 <- value1-    if (!present(strong(value2))) {-      fail("Failed")-    }-    Builder<String> builder <- String.builder().append(require(value1))-    value1 <- empty-    if (present(strong(value2))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Char is not shared" {-  success Test.run()-}--define Test {-  run () {-    Char value1 <- 'x'-    weak Char value2 <- value1-    if (present(strong(value2))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int is not shared" {-  success Test.run()-}--define Test {-  run () {-    Int value1 <- 1-    weak Int value2 <- value1-    if (present(strong(value2))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Float is not shared" {-  success Test.run()-}--define Test {-  run () {-    Float value1 <- 1.1-    weak Float value2 <- value1-    if (present(strong(value2))) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String Formatted" {-  success Test.run()-}--define Test {-  run () {-    String s <- ("x").formatted()-    if (s != "x") {-      fail(s)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Char Formatted" {-  success Test.run()-}--define Test {-  run () {-    String s <- ('x').formatted()-    if (s != "x") {-      fail(s)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Char octal Formatted" {-  success Test.run()-}--define Test {-  run () {-    String s <- ('\170').formatted()-    if (s != "x") {-      fail(s)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Char hex Formatted" {-  success Test.run()-}--define Test {-  run () {-    String s <- ('\x78').formatted()-    if (s != "x") {-      fail(s)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int Formatted" {-  success Test.run()-}--define Test {-  run () {-    String s <- (1).formatted()-    if (s != "1") {-      fail(s)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int hex Formatted" {-  success Test.run()-}--define Test {-  run () {-    String s <- (\x0010).formatted()-    if (s != "16") {-      fail(s)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Float Formatted" {-  success Test.run()-}--define Test {-  run () {-    String s <- (1.1).formatted()-    if (s != "1.1") {  // precision might vary-      fail(s)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Bool Formatted" {-  success Test.run()-}--define Test {-  run () {-    String s <- (false).formatted()-    if (s != "false") {-      fail(s)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String access" {-  success Test.run()-}--define Test {-  run () {-    String s <- "abcde"-    Char c <- s.readPosition(3)-    if (c != 'd') {-      fail(c)-    }-    Int size <- s.readSize()-    if (size != 5) {-      fail(size)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String access negative" {-  crash Test.run()-  require "-10"-  require "bounds"-}--define Test {-  run () {-    \ ("abc").readPosition(-10)-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String access past end" {-  crash Test.run()-  require "100"-  require "bounds"-}--define Test {-  run () {-    \ ("abc").readPosition(100)-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String subsequence" {-  success Test.run()-}--define Test {-  run () {-    String s <- "abcde"-    String s2 <- s.subSequence(1,3)-    if (s2 != "bcd") {-      fail(s2)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String empty subsequence at end" {-  success Test.run()-}--define Test {-  run () {-    String s <- ""-    String s2 <- s.subSequence(0,0)-    if (s2 != "") {-      fail(s2)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String subsequence past end" {-  crash Test.run()-  require "100"-  require "size"-}--define Test {-  run () {-    \ ("abc").subSequence(1,100)-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int max is accurate" {-  success Test.run()-}--define Test {-  run () {-    Int x <- 9223372036854775807 - 1-    if (x != 9223372036854775806) {-      fail(x)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int min is accurate" {-  success Test.run()-}--define Test {-  run () {-    Int x <- -9223372036854775806 + 1-    if (x != -9223372036854775805) {-      fail(x)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int unsigned works properly" {-  success Test.run()-}--define Test {-  run () {-    if (\xffffffffffffffff != -1) {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int literal too large" {-  error-  require "9223372036854775808"-  require "max"-}--define Test {-  run () {-    \ 9223372036854775808-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int unsigned literal too large" {-  error-  require "18446744073709551616"-  require "max"-}--define Test {-  run () {-    \ \x10000000000000000-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int literal too small" {-  error-  require "-9223372036854775807"-  require "min"-}--define Test {-  run () {-    \ -9223372036854775807-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Float exponent does not cross whitespace" {-  success Test.run()-}--concrete E10 {-  @type create () -> (E10)-}--define E10 {-  create () {-    return E10{ }-  }-}--define Test {-  run () {-    Float x <- 1.2345-    E10 y <- E10.create()-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String allows null" {-  success Test.run()-}--define Test {-  run () {-    if ("abc\x00def" == "abc") {-      fail("Failed")-    }-    if (("abc\x00def").readPosition(4) != 'd') {-      fail("Failed")-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Bool conversions" {-  success Test.run()-}--define Test {-  run () {-    Bool b1 <- (false).asBool()-    if (b1 != false) {-      fail(b1)-    }-    Bool b2 <- (true).asBool()-    if (b2 != true) {-      fail(b2)-    }-    Int i <- (true).asInt()-    if (i != 1) {-      fail(i)-    }-    Float f <- (true).asFloat()-    if (f != 1.0) {-      fail(f)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Char conversions" {-  success Test.run()-}--define Test {-  run () {-    Bool b1 <- ('\x00').asBool()-    if (b1 != false) {-      fail(b1)-    }-    Bool b2 <- ('\x10').asBool()-    if (b2 != true) {-      fail(b2)-    }-    Char c <- ('a').asChar()-    if (c != 'a') {-      fail(c)-    }-    Int i <- ('\x10').asInt()-    if (i != 16) {-      fail(i)-    }-    Float f <- ('\x10').asFloat()-    if (f != 16.0) {-      fail(f)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Int conversions" {-  success Test.run()-}--define Test {-  run () {-    Bool b1 <- (0).asBool()-    if (b1 != false) {-      fail(b1)-    }-    Bool b2 <- (16).asBool()-    if (b2 != true) {-      fail(b2)-    }-    Char c <- (97).asChar()-    if (c != 'a') {-      fail(c)-    }-    Int i <- (16).asInt()-    if (i != 16) {-      fail(i)-    }-    Float f <- (16).asFloat()-    if (f != 16.0) {-      fail(f)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "Float conversions" {-  success Test.run()-}--define Test {-  run () {-    Bool b1 <- (0.0).asBool()-    if (b1 != false) {-      fail(b1)-    }-    Bool b2 <- (16.0).asBool()-    if (b2 != true) {-      fail(b2)-    }-    Int i <- (16.0).asInt()-    if (i != 16) {-      fail(i)-    }-    Float f <- (16.0).asFloat()-    if (f != 16.0) {-      fail(f)-    }-  }-}--concrete Test {-  @type run () -> ()-}---testcase "String conversions" {-  success Test.run()-}--define Test {-  run () {-    Bool b1 <- ("").asBool()-    if (b1 != false) {-      fail(b1)-    }-    Bool b2 <- ("\x00").asBool()-    if (b2 != true) {-      fail(b2)-    }-  }-}--concrete Test {-  @type run () -> ()+  success+}++unittest test {+  if (!true) {+    fail("Failed")+  }+}+++testcase "reduce Bool" {+  success+}++unittest bool {+  if (!present(reduce<Bool,Bool>(true))) {+    fail("Failed")+  }+}++unittest asBool {+  if (!present(reduce<Bool,AsBool>(true))) {+    fail("Failed")+  }+}++unittest asChar {+  if (present(reduce<Bool,AsChar>(true))) {+    fail("Failed")+  }+}++unittest asInt {+  if (!present(reduce<Bool,AsInt>(true))) {+    fail("Failed")+  }+}++unittest asFloat {+  if (!present(reduce<Bool,AsFloat>(true))) {+    fail("Failed")+  }+}++unittest formatted {+  if (!present(reduce<Bool,Formatted>(true))) {+    fail("Failed")+  }+}+++testcase "reduce Char" {+  success+}++unittest char {+  if (!present(reduce<Char,Char>('a'))) {+    fail("Failed")+  }+}++unittest asBool {+  if (!present(reduce<Char,AsBool>('a'))) {+    fail("Failed")+  }+}++unittest asChar {+  if (!present(reduce<Char,AsChar>('a'))) {+    fail("Failed")+  }+}++unittest asInt {+  if (!present(reduce<Char,AsInt>('a'))) {+    fail("Failed")+  }+}++unittest asFloat {+  if (!present(reduce<Char,AsFloat>('a'))) {+    fail("Failed")+  }+}++unittest formatted {+  if (!present(reduce<Char,Formatted>('a'))) {+    fail("Failed")+  }+}+++testcase "reduce Int" {+  success+}++unittest int {+  if (!present(reduce<Int,Int>(1))) {+    fail("Failed")+  }+}++unittest asBool {+  if (!present(reduce<Int,AsBool>(1))) {+    fail("Failed")+  }+}++unittest asChar {+  if (!present(reduce<Int,AsChar>(1))) {+    fail("Failed")+  }+}++unittest asInt {+  if (!present(reduce<Int,AsInt>(1))) {+    fail("Failed")+  }+}++unittest asFloat {+  if (!present(reduce<Int,AsFloat>(1))) {+    fail("Failed")+  }+}++unittest formatted {+  if (!present(reduce<Int,Formatted>(1))) {+    fail("Failed")+  }+}+++testcase "reduce Float" {+  success+}++unittest float {+  if (!present(reduce<Float,Float>(1.0))) {+    fail("Failed")+  }+}++unittest asBool {+  if (!present(reduce<Float,AsBool>(1.0))) {+    fail("Failed")+  }+}++unittest asChar {+  if (present(reduce<Float,AsChar>(1.0))) {+    fail("Failed")+  }+}++unittest asInt {+  if (!present(reduce<Float,AsInt>(1.0))) {+    fail("Failed")+  }+}++unittest asFloat {+  if (!present(reduce<Float,AsFloat>(1.0))) {+    fail("Failed")+  }+}++unittest formatted {+  if (!present(reduce<Float,Formatted>(1.0))) {+    fail("Failed")+  }+}+++testcase "reduce String" {+  success+}++unittest string {+  if (!present(reduce<String,String>("a"))) {+    fail("Failed")+  }+}++unittest asBool {+  if (!present(reduce<String,AsBool>("a"))) {+    fail("Failed")+  }+}++unittest asChar {+  if (present(reduce<String,AsChar>("a"))) {+    fail("Failed")+  }+}++unittest asInt {+  if (present(reduce<String,AsInt>("a"))) {+    fail("Failed")+  }+}++unittest asFloar {+  if (present(reduce<String,AsFloat>("a"))) {+    fail("Failed")+  }+}++unittest formatted {+  if (!present(reduce<String,Formatted>("a"))) {+    fail("Failed")+  }+}+++testcase "reduce ReadPosition" {+  success+}++unittest success {+  if (!present(reduce<ReadPosition<Char>,ReadPosition<Formatted>>("x"))) {+    fail("Failed")+  }+}++unittest failure {+  if (present(reduce<ReadPosition<Formatted>,ReadPosition<Char>>("x"))) {+    fail("Failed")+  }+}+++testcase "interface implementations" {+  success+}++unittest stringLessThan {+  if (!("x" `String.lessThan` "y")) {+    fail("Failed")+  }+}++unittest boolEquals {+  if (!(true `Bool.equals` true)) {+    fail("Failed")+  }+}++unittest stringEquals {+  if (!("x" `String.equals` "x")) {+    fail("Failed")+  }+}++unittest stringBuilder {+  Builder<String> builder <- String.builder()+  \ Testing.checkEquals<?>(builder.build(),"")+  \ Testing.checkEquals<?>(builder.append("xyz").build(),"xyz")+  \ Testing.checkEquals<?>(builder.append("123").build(),"xyz123")+}++unittest charLessThan {+  if (!('x' `Char.lessThan` 'y')) {+    fail("Failed")+  }+}++unittest charEquals {+  if (!('x' `Char.equals` 'x')) {+    fail("Failed")+  }+}++unittest intLessThan {+  if (!(1 `Int.lessThan` 2)) {+    fail("Failed")+  }+}++unittest intEquals {+  if (!(1 `Int.equals` 1)) {+    fail("Failed")+  }+}++unittest floatLessThan {+  if (!(1.0 `Float.lessThan` 2.0)) {+    fail("Failed")+  }+}++unittest floatEquals {+  if (!(1.0 `Float.equals` 1.0)) {+    fail("Failed")+  }+}++unittest stringFormatted {+  String s <- ("x").formatted()+  if (s != "x") {+    fail(s)+  }+}++unittest charFormatted {+  String s <- ('x').formatted()+  if (s != "x") {+    fail(s)+  }+}++unittest charFormattedOct {+  String s <- ('\170').formatted()+  if (s != "x") {+    fail(s)+  }+}++unittest charFormattedHex {+  String s <- ('\x78').formatted()+  if (s != "x") {+    fail(s)+  }+}++unittest intFormatted {+  String s <- (1).formatted()+  if (s != "1") {+    fail(s)+  }+}++unittest intFormattedHex {+  String s <- (\x0010).formatted()+  if (s != "16") {+    fail(s)+  }+}++unittest floatFormatted {+  String s <- (1.1).formatted()+  if (s != "1.1") {  // precision might vary+    fail(s)+  }+}++unittest boolFormatted {+  String s <- (false).formatted()+  if (s != "false") {+    fail(s)+  }+}+++testcase "reference sharing" {+  success+}++unittest boolShared {+  Bool value1 <- true+  // Shared because true and false are boxed constants.+  weak Bool value2 <- value1+  if (!present(strong(value2))) {+    fail("Failed")+  }+}++unittest stringShared {+  String value1 <- "x"+  weak String value2 <- value1+  if (!present(strong(value2))) {+    fail("Failed")+  }+}++unittest charNotShared {+  Char value1 <- 'x'+  weak Char value2 <- value1+  if (present(strong(value2))) {+    fail("Failed")+  }+}++unittest intNotShared {+  Int value1 <- 1+  weak Int value2 <- value1+  if (present(strong(value2))) {+    fail("Failed")+  }+}++unittest floatNotShared {+  Float value1 <- 1.1+  weak Float value2 <- value1+  if (present(strong(value2))) {+    fail("Failed")+  }+}+++testcase "String stuff" {+  success+}++unittest builderNotLazy {+  optional String value1 <- "value"+  weak String value2 <- value1+  if (!present(strong(value2))) {+    fail("Failed")+  }+  Builder<String> builder <- String.builder().append(require(value1))+  value1 <- empty+  if (present(strong(value2))) {+    fail("Failed")+  }+}++unittest simpleAccess {+  String s <- "abcde"+  Char c <- s.readPosition(3)+  if (c != 'd') {+    fail(c)+  }+  Int size <- s.readSize()+  if (size != 5) {+    fail(size)+  }+}++unittest subsequence {+  String s <- "abcde"+  String s2 <- s.subSequence(1,3)+  if (s2 != "bcd") {+    fail(s2)+  }+}++unittest emptySubsequence {+  String s <- ""+  String s2 <- s.subSequence(0,0)+  if (s2 != "") {+    fail(s2)+  }+}++unittest nullChar {+  if ("abc\x00def" == "abc") {+    fail("Failed")+  }+  if (("abc\x00def").readPosition(4) != 'd') {+    fail("Failed")+  }+}+++testcase "String access negative" {+  crash+  require "-10"+  require "bounds"+}++unittest test {+  \ Test.run()+}++define Test {+  run () {+    \ ("abc").readPosition(-10)+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "String access past end" {+  crash+  require "100"+  require "bounds"+}++unittest test {+  \ Test.run()+}++define Test {+  run () {+    \ ("abc").readPosition(100)+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "String subsequence past end" {+  crash+  require "100"+  require "size"+}++unittest test {+  \ Test.run()+}++define Test {+  run () {+    \ ("abc").subSequence(1,100)+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Int stuff" {+  success+}++unittest accurateMax {+  Int x <- 9223372036854775807 - 1+  if (x != 9223372036854775806) {+    fail(x)+  }+}++unittest accurateMin {+  Int x <- -9223372036854775806 + 1+  if (x != -9223372036854775805) {+    fail(x)+  }+}++unittest hexUnsigned {+  if (\xffffffffffffffff != -1) {+    fail("Failed")+  }+}+++testcase "Int literal too large" {+  error+  require "9223372036854775808"+  require "max"+}++define Test {+  run () {+    \ 9223372036854775808+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Int unsigned literal too large" {+  error+  require "18446744073709551616"+  require "max"+}++define Test {+  run () {+    \ \x10000000000000000+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Int literal too small" {+  error+  require "-9223372036854775807"+  require "min"+}++define Test {+  run () {+    \ -9223372036854775807+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Float exponent does not cross whitespace" {+  success+}++unittest test {+  \ Test.run()+}++concrete E10 {+  @type create () -> (E10)+}++define E10 {+  create () {+    return E10{ }+  }+}++define Test {+  run () {+    Float x <- 1.2345+    E10 y <- E10.create()+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "Bool conversions" {+  success+}++unittest falseAsBool {+  Bool b1 <- (false).asBool()+  if (b1 != false) {+    fail(b1)+  }+}++unittest trueAsBool {+  Bool b2 <- (true).asBool()+  if (b2 != true) {+    fail(b2)+  }+}++unittest asInt {+  Int i <- (true).asInt()+  if (i != 1) {+    fail(i)+  }+}++unittest asFloat {+  Float f <- (true).asFloat()+  if (f != 1.0) {+    fail(f)+  }+}+++testcase "Char conversions" {+  success+}++unittest nullAsBool {+  Bool b1 <- ('\x00').asBool()+  if (b1 != false) {+    fail(b1)+  }+}++unittest nonNullAsBool {+  Bool b2 <- ('\x10').asBool()+  if (b2 != true) {+    fail(b2)+  }+}++unittest asChar {+  Char c <- ('a').asChar()+  if (c != 'a') {+    fail(c)+  }+}++unittest asInt {+  Int i <- ('\x10').asInt()+  if (i != 16) {+    fail(i)+  }+}++unittest asFloat {+  Float f <- ('\x10').asFloat()+  if (f != 16.0) {+    fail(f)+  }+}+++testcase "Int conversions" {+  success+}++unittest zeroAsBool {+  Bool b1 <- (0).asBool()+  if (b1 != false) {+    fail(b1)+  }+}++unittest nonZeroAsBool {+  Bool b2 <- (16).asBool()+  if (b2 != true) {+    fail(b2)+  }+}++unittest asChar {+  Char c <- (97).asChar()+  if (c != 'a') {+    fail(c)+  }+}++unittest asInt {+  Int i <- (16).asInt()+  if (i != 16) {+    fail(i)+  }+}++unittest asFloat {+  Float f <- (16).asFloat()+  if (f != 16.0) {+    fail(f)+  }+}+++testcase "Float conversions" {+  success+}++unittest zeroAsBool {+  Bool b1 <- (0.0).asBool()+  if (b1 != false) {+    fail(b1)+  }+}++unittest nonZeroAsBool {+  Bool b2 <- (16.0).asBool()+  if (b2 != true) {+    fail(b2)+  }+}++unittest asInt {+  Int i <- (16.0).asInt()+  if (i != 16) {+    fail(i)+  }+}++unittest asFloat {+  Float f <- (16.0).asFloat()+  if (f != 16.0) {+    fail(f)+  }+}+++testcase "String conversions" {+  success+}++unittest emptyAsBool {+  Bool b1 <- ("").asBool()+  if (b1 != false) {+    fail(b1)+  }+}++unittest singleNullAsBool {+  Bool b2 <- ("\x00").asBool()+  if (b2 != true) {+    fail(b2)+  } }