zeolite-lang 0.6.0.0 → 0.7.0.0

raw patch · 74 files changed

+2752/−1666 lines, 74 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−0
• base/logging.cpp +33/−25
• base/logging.hpp +5/−3
• bin/unit-tests.hs +7/−2
• bin/zeolite-setup.hs +6/−4
• bin/zeolite.hs +45/−6
• example/parser/README.md +5/−6
• example/parser/parse-text.0rp +1/−0
• example/parser/parse-text.0rx +48/−21
• example/parser/parser.0rp +12/−15
• example/parser/parser.0rx +25/−19
• example/parser/test-data.0rp +4/−2
• example/parser/test-data.0rx +45/−48
• example/tree/tree-demo.0rx +7/−7
• example/tree/type-tree.0rx +2/−2
• lib/math/tests.0rt +24/−24
• lib/util/tests.0rt +3/−3
• src/Base/CompileError.hs +19/−18
• src/Base/CompileInfo.hs +224/−0
• src/Base/MergeTree.hs +82/−0
• src/Base/Mergeable.hs +19/−11
• src/Cli/CompileMetadata.hs +1/−1
• src/Cli/Compiler.hs +109/−161
• src/Cli/ParseCompileOptions.hs +6/−43
• src/Cli/ParseMetadata.hs +15/−15
• src/Cli/Paths.hs +34/−0
• src/Cli/ProcessMetadata.hs +122/−162
• src/Cli/Programs.hs +75/−0
• src/Cli/RunCompiler.hs +88/−120
• src/Cli/TestRunner.hs +28/−28
• src/Compilation/CompileInfo.hs +0/−151
• src/Compilation/CompilerState.hs +1/−1
• src/Compilation/ProcedureContext.hs +29/−28
• src/Compilation/ScopeContext.hs +2/−2
• src/CompilerCxx/Category.hs +23/−22
• src/CompilerCxx/Procedure.hs +94/−70
• src/Config/LoadConfig.hs +18/−168
• src/Config/LocalConfig.hs +180/−0
• src/Config/Paths.hs +0/−30
• src/Config/Programs.hs +0/−71
• src/Parser/Common.hs +4/−0
• src/Parser/Procedure.hs +12/−1
• src/Parser/SourceFile.hs +3/−3
• src/Test/Common.hs +31/−41
• src/Test/CompileInfo.hs +89/−0
• src/Test/DefinedCategory.hs +3/−3
• src/Test/IntegrationTest.hs +8/−8
• src/Test/MergeTree.hs +103/−0
• src/Test/ParseMetadata.hs +8/−8
• src/Test/Parser.hs +4/−4
• src/Test/Pragma.hs +5/−5
• src/Test/Procedure.hs +7/−7
• src/Test/SourceFile.hs +2/−2
• src/Test/TypeCategory.hs +240/−18
• src/Test/TypeInstance.hs +125/−13
• src/Test/testfiles/flatten.0rx +10/−10
• src/Test/testfiles/inference.0rx +19/−0
• src/Types/DefinedCategory.hs +7/−7
• src/Types/Function.hs +16/−16
• src/Types/Positional.hs +8/−2
• src/Types/Procedure.hs +8/−2
• src/Types/TypeCategory.hs +159/−108
• src/Types/TypeInstance.hs +157/−76
• tests/builtin-types.0rt +3/−3
• tests/check-defs/README.md +5/−5
• tests/expr-lookup.0rt +6/−6
• tests/inference.0rt +219/−0
• tests/infix-operations.0rt +16/−16
• tests/internal-params.0rt +1/−1
• tests/member-init.0rt +1/−1
• tests/module-only/README.md +3/−3
• tests/tests-only/README.md +2/−2
• tests/tests-only2/README.md +2/−2
• zeolite-lang.cabal +8/−4

@@ -1,5 +1,22 @@ # Revision history for zeolite-lang +## 0.7.0.0  -- 2020-05-19++### Language++* **[new]** Adds limited inference of type parameters in function calls. The new+  syntax is `call<?,Int>(foo,bar)`, where `?` designates that inference is+  requested for the first position.++* **[behavior]** Reduces the memory cost of `$TraceCreation$` by avoiding+  storing the entire trace text.++### Compiler CLI++* **[behavior]** Improves handling of I/O errors when calling `zeolite`, and+  allows compilation to continue in `-r`/`-R` modes if compilation of one module+  fails.+ ## 0.6.0.0  -- 2020-05-14  ### Compiler CLI

@@ -40,25 +40,26 @@       std::cerr << " '" << condition_ << "'";     }     std::cerr << ": " << output_.str() << std::endl;-    const TraceList call_trace = TraceContext::GetTrace();-    for (const auto& trace : call_trace) {-      if (!trace.empty()) {-        std::cerr << "  " << trace << std::endl;-      }-    }+    PrintTrace(TraceContext::GetTrace());     const TraceList creation_trace = TraceCreation::GetTrace();     if (!creation_trace.empty()) {       std::cerr << TraceCreation::GetType() << " value originally created at:" << std::endl;-      for (const auto& trace : creation_trace) {-        if (!trace.empty()) {-          std::cerr << "  " << trace << std::endl;-        }-      }+      PrintTrace(creation_trace);     }     std::raise(signal_);   } } +// static+void LogThenCrash::PrintTrace(const TraceList &call_trace) {+  for (const auto& trace : call_trace) {+    const std::string message = trace();+    if (!message.empty()) {+      std::cerr << "  " << message << std::endl;+    }+  }+}+ // TODO: Should only be available used if POSIX is defined. void TraceOnSignal(int signal) {   LogThenCrash(true,signal) << "Recieved signal " << signal;@@ -118,13 +119,17 @@ }  void SourceContext::AppendTrace(TraceList& trace) const {-  std::ostringstream output;-  if (at_ == nullptr || at_[0] == 0x00) {-    output << "From " << name_;-  } else {-    output << "From " << name_ << " at " << at_;-  }-  trace.push_back(output.str());+  const char* const name = name_;+  const char* const at   = at_;+  trace.push_back([name,at]() {+      std::ostringstream output;+      if (at == nullptr || at[0] == 0x00) {+        output << "From " << name;+      } else {+        output << "From " << name << " at " << at;+      }+      return output.str();+    }); }  const TraceContext* SourceContext::GetNext() const {@@ -137,13 +142,16 @@ }  void CleanupContext::AppendTrace(TraceList& trace) const {-  std::ostringstream output;-  if (at_ == nullptr || at_[0] == 0x00) {-    output << "In cleanup block";-  } else {-    output << "In cleanup block at " << at_;-  }-  trace.push_back(output.str());+  const char* const at = at_;+  trace.push_back([at]() {+      std::ostringstream output;+      if (at == nullptr || at[0] == 0x00) {+        output << "In cleanup block";+      } else {+        output << "In cleanup block at " << at;+      }+      return output.str();+    }); }  const TraceContext* CleanupContext::GetNext() const {

@@ -19,6 +19,7 @@ #ifndef LOGGING_HPP_ #define LOGGING_HPP_ +#include <functional> #include <list> #include <sstream> #include <string>@@ -31,6 +32,8 @@  void SetSignalHandler(); +using TraceList = std::list<std::function<std::string()>>;+ class LogThenCrash {  public:   LogThenCrash(bool fail, const std::string& condition = "");@@ -52,6 +55,8 @@   LogThenCrash& operator =(LogThenCrash&&) = delete;   void* operator new(std::size_t size) = delete; +  static void PrintTrace(const TraceList&);+   const bool fail_;   const int signal_;   const std::string condition_;@@ -94,9 +99,6 @@   #define TRACE_CREATION  #endif---using TraceList = std::list<std::string>;   class TraceContext : public capture_thread::ThreadCapture<TraceContext> {

@@ -17,9 +17,12 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  import Base.CompileError+import Base.CompileInfo import Test.Common+import qualified Test.CompileInfo     as TestCompileInfo import qualified Test.DefinedCategory as TestDefinedCategory import qualified Test.IntegrationTest as TestIntegrationTest+import qualified Test.MergeTree       as TestMergeTree import qualified Test.ParseMetadata   as TestParseMetadata import qualified Test.Parser          as TestParser import qualified Test.Pragma          as TestPragma@@ -31,8 +34,10 @@  main :: IO () main = runAllTests $ concat [+    labelWith "CompileInfo"     TestCompileInfo.tests,     labelWith "DefinedCategory" TestDefinedCategory.tests,     labelWith "IntegrationTest" TestIntegrationTest.tests,+    labelWith "MergeTree"       TestMergeTree.tests,     labelWith "ParseMetadata"   TestParseMetadata.tests,     labelWith "Parser"          TestParser.tests,     labelWith "Pragma"          TestPragma.tests,@@ -42,5 +47,5 @@     labelWith "TypeInstance"    TestTypeInstance.tests   ] -labelWith :: CompileErrorM m => String -> [IO (m ())] -> [IO (m ())]-labelWith s ts = map (\(n,t) -> fmap (`reviseError` ("In " ++ s ++ " (#" ++ show n ++ "):")) t) (zip ([1..] :: [Int]) ts)+labelWith :: String -> [IO (CompileInfo ())] -> [IO (CompileInfo ())]+labelWith s ts = map (\(n,t) -> fmap (`reviseErrorM` ("In " ++ s ++ " (#" ++ show n ++ "):")) t) (zip ([1..] :: [Int]) ts)

@@ -24,7 +24,9 @@  import Cli.CompileOptions import Cli.RunCompiler+import Base.CompileInfo import Config.LoadConfig+import Config.LocalConfig   main :: IO ()@@ -38,7 +40,7 @@   config <- createConfig   hPutStrLn stderr $ "Writing local config to " ++ f ++ "."   writeFile f (show config ++ "\n")-  initLibraries+  initLibraries config   hPutStrLn stderr "Setup is now complete!"  clangBinary :: String@@ -114,8 +116,8 @@     exitFailure   hGetLine stdin -initLibraries :: IO ()-initLibraries = do+initLibraries :: LocalConfig -> IO ()+initLibraries (LocalConfig backend resolver) = do   path <- rootPath >>= canonicalizePath   let options = CompileOptions {       coHelp = HelpNotNeeded,@@ -128,4 +130,4 @@       coMode = CompileRecompileRecursive,       coForce = ForceAll     }-  runCompiler options+  tryCompileInfoIO "Zeolite setup failed." $ runCompiler resolver backend options

@@ -17,15 +17,22 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  import Control.Monad (when)+import System.Directory import System.Environment import System.Exit import System.IO+import qualified Data.Map as Map  import Base.CompileError+import Cli.CompileMetadata import Cli.CompileOptions+import Cli.ProcessMetadata import Cli.ParseCompileOptions -- Not safe, due to Text.Regex.TDFA.+import Cli.Programs import Cli.RunCompiler-import Compilation.CompileInfo+import Base.CompileInfo+import Config.LoadConfig+import Config.LocalConfig   main :: IO ()@@ -33,19 +40,51 @@   args <- getArgs   tryFastModes args   let options = parseCompileOptions args >>= validateCompileOptions-  compile options where+  compile options+  hPutStrLn stderr "Zeolite execution succeeded." where     compile co       | isCompileError co = do           hPutStr stderr $ show $ getCompileError co           hPutStrLn stderr "Use the -h option to show help."           exitFailure-      | otherwise = do-        let co' = getCompileSuccess co-        when (HelpNotNeeded /= (coHelp co')) $ showHelp >> exitFailure-        runCompiler co'+      | otherwise = tryCompileInfoIO "Zeolite execution failed." $ do+          let co' = getCompileSuccess co+          (resolver,backend) <- loadConfig+          when (HelpNotNeeded /= (coHelp co')) $ errorFromIO $ showHelp >> exitFailure+          runCompiler resolver backend co'  showHelp :: IO () showHelp = do   hPutStrLn stderr "Zeolite CLI Help:"   mapM_ (hPutStrLn stderr . ("  " ++)) optionHelpText   hPutStrLn stderr "Also see https://ta0kira.github.io/zeolite for more documentation."++tryFastModes :: [String] -> IO ()+tryFastModes ("--get-path":os) = do+  when (not $ null os) $ hPutStrLn stderr $ "Ignoring extra arguments: " ++ show os+  p <- rootPath >>= canonicalizePath+  hPutStrLn stdout p+  if null os+     then exitSuccess+     else exitFailure+tryFastModes ("--version":os) = do+  when (not $ null os) $ hPutStrLn stderr $ "Ignoring extra arguments: " ++ show os+  hPutStrLn stdout compilerVersion+  if null os+     then exitSuccess+     else exitFailure+tryFastModes ("--show-deps":ps) = do+  tryCompileInfoIO "Zeolite execution failed." $ mapM_ showDeps ps+  exitSuccess where+    showDeps p = do+      (_,backend) <- loadConfig+      p' <- errorFromIO $ canonicalizePath p+      m <- loadModuleMetadata (getCompilerHash backend) ForceAll Map.empty p'+      errorFromIO $ hPutStrLn stdout $ show p'+      errorFromIO $ mapM_ showDep (cmObjectFiles m)+    showDep (CategoryObjectFile c ds _) = do+      mapM_ (\d -> hPutStrLn stdout $ "  " ++ show (ciCategory c) +++                                      " -> " ++ show (ciCategory d) +++                                      " " ++ show (ciPath d)) ds+    showDep _ = return ()+tryFastModes _ = return ()

@@ -24,12 +24,6 @@   (see `parser.0rp` and `parser.0rx`), which allows `ParseState` to   conditionally expose the `ParseContext` interface to other functions. -- **Function Merging.** `ParseState` and `ParseContext` declare some of the same-  functions in `parser.0rp`. When `ParseState` inherits `ParseContext`-  internally in `parser.0rx`, functions with the same names are merged by the-  compiler. This allows `ParseState` to expose a subset of `ParseContext`-  without needing a superfluous interface with the shared functions.- - **Parameter Variance.** Several categories used in this example (e.g.,   `ParseState` and `ParseContext`) have a *covariant* parameter, which allows   their parameters to be converted to other types. Specifically:@@ -57,6 +51,11 @@ - **Module Config.** The `.zeolite-module` file contains the build configuration   for this example. This means that building and running the example does not   require special instructions, scripting, or `Makefile`s.++- **Type Inference.** Several of the function definitions in the `.0rx` files+  request parameter type-inference using `?`, e.g., `ErrorOr$$value<?>(match)`.+  This is useful when the parameter value can be easily guessed by the reader of+  the code from its context.  ## Running 

@@ -20,6 +20,7 @@  */ concrete Parse {   @type const<#x> (#x)                     -> (Parser<#x>)+  @type error     (Formatted)              -> (Parser<all>)   @type try<#x>   (Parser<#x>)             -> (Parser<#x>)   @type or<#x>    (Parser<#x>,Parser<#x>)  -> (Parser<#x>)   @type left<#x>  (Parser<#x>,Parser<any>) -> (Parser<#x>)

@@ -5,7 +5,7 @@    run (contextOld) {     if (contextOld.hasAnyError()) {-      return contextOld.convertError<String>()+      return contextOld.convertError()     }     String message <- "Failed to match \"" + match + "\" at " + contextOld.getPosition()     ParseContext<any> context <- contextOld@@ -17,14 +17,14 @@           // Partial match => set error context.           return context.setBrokenInput(message)         } else {-          return context.setValue<String>(ErrorOr$$error(message))+          return context.setValue<?>(ErrorOr$$error(message))         }       }     } update {       index <- index+1       context <- context.advance()     }-    return context.setValue<String>(ErrorOr$$value<String>(match))+    return context.setValue<?>(ErrorOr$$value<?>(match))   }    create (match) {@@ -41,7 +41,7 @@    run (contextOld) {     if (contextOld.hasAnyError()) {-      return contextOld.convertError<String>()+      return contextOld.convertError()     }     String message <- "Failed to match [" + matches + "]{" +                       min.formatted() + "," + max.formatted() + "} at " +@@ -70,12 +70,12 @@       context <- context.advance()     }     if (count >= min) {-      return context.setValue<String>(ErrorOr$$value<String>(builder.build()))+      return context.setValue<?>(ErrorOr$$value<?>(builder.build()))     } elif (count > 0) {       // Partial match => set error context.       return context.setBrokenInput(message)     } else {-      return context.setValue<String>(ErrorOr$$error(message))+      return context.setValue<?>(ErrorOr$$error(message))     }   } @@ -91,13 +91,13 @@    run (contextOld) {     if (contextOld.hasAnyError()) {-      return contextOld.convertError<Char>()+      return contextOld.convertError()     }     if (contextOld.atEof() || contextOld.current() != match) {       String message <- "Failed to match '" + match.formatted() + "' at " + contextOld.getPosition()-      return contextOld.setValue<Char>(ErrorOr$$error(message))+      return contextOld.setValue<?>(ErrorOr$$error(message))     } else {-      return contextOld.advance().setValue<Char>(ErrorOr$$value<Char>(match))+      return contextOld.advance().setValue<?>(ErrorOr$$value<?>(match))     }   } @@ -116,7 +116,7 @@   @value #x value    run (contextOld) {-    return contextOld.setValue<#x>(ErrorOr$$value<#x>(value))+    return contextOld.setValue<?>(ErrorOr$$value<?>(value))   }    create (value) {@@ -124,6 +124,24 @@   } } +concrete ErrorParser {+  @type create (Formatted) -> (Parser<all>)+}++define ErrorParser {+  refines Parser<all>++  @value Formatted message++  run (contextOld) {+    return contextOld.setValue<?>(ErrorOr$$error(message))+  }++  create (message) {+    return ErrorParser{ message }+  }+}+ concrete TryParser<#x> {   @type create (Parser<#x>) -> (Parser<#x>) }@@ -135,11 +153,11 @@    run (contextOld) {     if (contextOld.hasAnyError()) {-      return contextOld.convertError<#x>()+      return contextOld.convertError()     }     ParseContext<#x> context <- contextOld.run<#x>(parser)     if (context.hasAnyError()) {-      return contextOld.setValue<#x>(context.getValue().convertError())+      return contextOld.setValue<?>(context.getValue().convertError())     } else {       return context.toState()     }@@ -162,7 +180,7 @@    run (contextOld) {     if (contextOld.hasAnyError()) {-      return contextOld.convertError<#x>()+      return contextOld.convertError()     }     ParseContext<#x> context <- contextOld.run<#x>(parser1)     if (context.hasAnyError() && !context.hasBrokenInput()) {@@ -189,13 +207,18 @@    run (contextOld) {     if (contextOld.hasAnyError()) {-      return contextOld.convertError<#x>()+      return contextOld.convertError()     }     ParseContext<#x> context <- contextOld.run<#x>(parser1)-    if (!context.hasAnyError()) {-      return context.run<any>(parser2).setValue<#x>(context.getValue())-    } else {+    if (context.hasAnyError()) {       return context.toState()+    } else {+      ParseContext<any> context2 <- context.run<any>(parser2)+      if (context2.hasAnyError()) {+        return context2.convertError()+      } else {+        return context2.setValue<?>(context.getValue())+      }     }   } @@ -216,13 +239,13 @@    run (contextOld) {     if (contextOld.hasAnyError()) {-      return contextOld.convertError<#x>()+      return contextOld.convertError()     }     ParseContext<any> context <- contextOld.run<any>(parser1)-    if (!context.hasAnyError()) {-      return context.run<#x>(parser2).toState()+    if (context.hasAnyError()) {+      return context.convertError()     } else {-      return context.convertError<#x>()+      return context.run<#x>(parser2).toState()     }   } @@ -234,6 +257,10 @@ define Parse {   const (value) {     return ConstParser<#x>$create(value)+  }++  error (message) {+    return ErrorParser$create(message)   }    try (parser) {

@@ -6,14 +6,8 @@  * ParseState<all> can convert to all other ParseState.  */ concrete ParseState<|#x> {-  @category new (String) -> (ParseState<any>)--  @value run<#y>       (Parser<#y>) -> (ParseState<#y>)-  @value runAndGet<#y> (Parser<#y>) -> (ParseState<any>,ErrorOr<#y>)--  @value atEof       () -> (Bool)-  @value hasAnyError () -> (Bool)-  @value getError    () -> (Formatted)+  // Consumes all input and returns the result.+  @category consumeAll<#y> (Parser<#y>,String) -> (ErrorOr<#y>) }  /* A self-contained parser operation.@@ -31,21 +25,24 @@  * ParseContext<all> can convert to all other ParseContext.  */ @value interface ParseContext<|#x> {+  // Continue computation.   run<#y>       (Parser<#y>) -> (ParseContext<#y>)   runAndGet<#y> (Parser<#y>) -> (ParseContext<any>,ErrorOr<#y>)--  convertError<#y> ()            -> (ParseState<#y>)-  getValue         ()            -> (ErrorOr<#x>)-  setValue<#y>     (ErrorOr<#y>) -> (ParseState<#y>)-  setBrokenInput   (Formatted)   -> (ParseState<all>)-  toState          ()            -> (ParseState<#x>)+  getValue      ()           -> (ErrorOr<#x>) -  getPosition () -> (String)+  // End computation and pass on the next state.+  convertError   ()            -> (ParseState<all>)+  setValue<#y>   (ErrorOr<#y>) -> (ParseState<#y>)+  setBrokenInput (Formatted)   -> (ParseState<all>)+  toState        ()            -> (ParseState<#x>) +  // Context metadata.+  getPosition    () -> (String)   atEof          () -> (Bool)   hasAnyError    () -> (Bool)   hasBrokenInput () -> (Bool) +  // Reading data.   current () -> (Char)   advance () -> (ParseContext<#x>) }

@@ -1,11 +1,4 @@ define ParseState {-  // This internal inheritance takes advantage of function merging.-  //-  // Notice that several functions (e.g., run, hasAnyError) appear to be-  // declared separately in ParseState and ParseContext in parser.0rp. Since the-  // function types are compatible, the compiler automatically merges them. This-  // allows ParseState to expose a subset of ParseContext without needing a-  // superfluous interface that both categories refine.   refines ParseContext<#x>    @value String             data@@ -15,8 +8,15 @@   @value ErrorOr<#x>        value   @value optional Formatted error -  new (data) {-    return ParseState<any>{ data, 0, 0, 0, ErrorOr$$value<Void>(Void$void()), empty }+  consumeAll (parser,data) {+    ParseContext<#y> context <- parser.run(new(data))+    if (context.hasAnyError()) {+      return context.getValue()+    } elif (!context.atEof()) {+      return ErrorOr$$error("Parsing did not consume all of the data " + context.getPosition())+    } else {+      return context.getValue()+    }   }    run (parser) {@@ -24,14 +24,10 @@   }    runAndGet (parser) {-    ParseState<#y> context <- parser.run(self)+    ParseContext<#y> context <- parser.run(self)     return context, context.getValue()   } -  convertError () {-    return ParseState<#y>{ data, index, line, char, ErrorOr$$error(getError()), error }-  }-   getValue () {     if (present(error)) {       return ErrorOr$$error(require(error))@@ -40,9 +36,13 @@     }   } +  convertError () {+    return ParseState<all>{ data, index, line, char, ErrorOr$$error(getError()), error }+  }+   setValue (value2) {     if (hasBrokenInput()) {-      return convertError<#y>()+      return convertError()     } else {       return ParseState<#y>{ data, index, line, char, value2, error }     }@@ -58,11 +58,11 @@    getPosition () {     return String$builder()-        .append("(")+        .append("[line: ")         .append(line.formatted())-        .append(",")+        .append(", char: ")         .append(char.formatted())-        .append(")")+        .append("]")         .build()   } @@ -86,12 +86,18 @@   advance () {     \ sanityCheck()     if (data.readPosition(index) == '\n') {-      return ParseState<#x>{ data, index+1, line+1, 0, value, error }+      return ParseState<#x>{ data, index+1, line+1, 1, value, error }     } else {       return ParseState<#x>{ data, index+1, line, char+1, value, error }     }   } +  @category new (String) -> (ParseState<any>)+  new (data) {+    return ParseState<any>{ data, 0, 1, 1, ErrorOr$$value<?>(Void$void()), empty }+  }++  @value getError () -> (Formatted)   getError () {     if (present(error)) {       return require(error)

@@ -1,9 +1,11 @@ $TestsOnly$ -/* Parses the test-data.txt file using a one-off format.+/* A contrived object for test data.  */ concrete TestData {-  @type parseFrom (String) -> (ErrorOr<TestData>)+  // Parses the test-data.txt file using a one-off format.+  @type parseFrom (String)             -> (ErrorOr<TestData>)+  @type create    (String,String,Bool) -> (TestData)    @value getName        () -> (String)   @value getDescription () -> (String)

@@ -1,46 +1,16 @@ $TestsOnly$  define TestData {-  @category Parser<any> whitespace <- SequenceOfParser$create(" \n\t",1,0)--  @category Parser<String> sentence        <- SentenceParser$create()-  @category Parser<String> token           <- SequenceOfParser$create("ABCDEFGHIJKLMNOPQRSTUVWXYZ_",1,0)-  @category Parser<String> sentenceOrToken <- sentence `Parse$or<String>` token `Parse$left<String>` whitespace--  @category Parser<Bool> acronym           <- StringParser$create("acronym")  `Parse$right<Bool>` Parse$const<Bool>(true)-  @category Parser<Bool> aardvark          <- StringParser$create("aardvark") `Parse$right<Bool>` Parse$const<Bool>(false)-  @category Parser<Bool> acronymOrAardvark <- `Parse$try<Bool>` acronym `Parse$or<Bool>` aardvark `Parse$left<Bool>` whitespace--  @category Parser<any> fileStart      <- StringParser$create("file_start")   `Parse$left<any>` whitespace-  @category Parser<any> fileEnd        <- StringParser$create("file_end")     `Parse$left<any>` whitespace-  @category Parser<any> nameTag        <- StringParser$create("name:")        `Parse$left<any>` whitespace-  @category Parser<any> descriptionTag <- StringParser$create("description:") `Parse$left<any>` whitespace-  @category Parser<any> aWordTag       <- StringParser$create("a_word:")      `Parse$left<any>` whitespace-   @value String name   @value String description   @value Bool   boolean    parseFrom (data) {-    ParseState<any> state <- ParseState$$new(data)-    state                              <- state.run<any>(fileStart)-    state                              <- state.run<any>(nameTag)-    state, ErrorOr<String> name        <- state.runAndGet<String>(sentenceOrToken)-    state                              <- state.run<any>(descriptionTag)-    state, ErrorOr<String> description <- state.runAndGet<String>(sentenceOrToken)-    state                              <- state.run<any>(aWordTag)-    state, ErrorOr<Bool> boolean       <- state.runAndGet<Bool>(acronymOrAardvark)-    state                              <- state.run<any>(fileEnd)+    return TestDataParser$create() `ParseState$$consumeAll<?>` data+  } -    if (state.hasAnyError()) {-      return ErrorOr$$error(state.getError())-    } elif (!state.atEof()) {-      return ErrorOr$$error("Parsing did not consume all of the data")-    } else {-      return ErrorOr$$value<TestData>(TestData{ name.getValue(),-                                                description.getValue(),-                                                boolean.getValue() })-    }+  create (name,description,boolean) {+    return TestData{ name, description, boolean }   }    getName () {@@ -56,30 +26,57 @@   } } -concrete SentenceParser {-  @type create () -> (Parser<String>)+concrete TestDataParser {+  @type create () -> (Parser<TestData>) } -define SentenceParser {-  refines Parser<String>+define TestDataParser {+  refines Parser<TestData> +  @category Parser<any> whitespace <- SequenceOfParser$create(" \n\t",1,0) `Parse$or<?>` Parse$error("Expected whitespace")+   @category String sentenceChars <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ" +                                     "abcdefghijklmnopqrstuvwxyz" +                                     "., !?-"-  @category Parser<String> string <- SequenceOfParser$create(sentenceChars,0,0)+  @category Parser<String> sentence <- SequenceOfParser$create(sentenceChars,0,0)+  @category Parser<any>    quote    <- CharParser$create('"') +  @category Parser<String> quotedSentence  <- quote `Parse$right<?>` sentence `Parse$left<?>` quote+  @category Parser<String> token           <- SequenceOfParser$create("ABCDEFGHIJKLMNOPQRSTUVWXYZ_",1,0)+  @category Parser<String> sentenceOrToken <- quotedSentence `Parse$or<?>` token `Parse$left<?>` whitespace++  @category Parser<Bool> acronym           <- StringParser$create("acronym")  `Parse$right<?>` Parse$const<?>(true)+  @category Parser<Bool> aardvark          <- StringParser$create("aardvark") `Parse$right<?>` Parse$const<?>(false)+  @category Parser<Bool> acronymOrAardvark <- Parse$try<?>(acronym) `Parse$or<?>` aardvark `Parse$left<?>` whitespace++  @category Parser<any> fileStart      <- StringParser$create("file_start")   `Parse$left<?>` whitespace+  @category Parser<any> fileEnd        <- StringParser$create("file_end")     `Parse$left<?>` whitespace+  @category Parser<any> nameTag        <- StringParser$create("name:")        `Parse$left<?>` whitespace+  @category Parser<any> descriptionTag <- StringParser$create("description:") `Parse$left<?>` whitespace+  @category Parser<any> aWordTag       <- StringParser$create("a_word:")      `Parse$left<?>` whitespace+   run (contextOld) {-    if (contextOld.hasAnyError()) {-      return contextOld.convertError<String>()-    }     ParseContext<any> context <- contextOld-    context                       <- context.run<any>(CharParser$create('"'))-    context, ErrorOr<String> text <- context.runAndGet<String>(string)-    context                       <- context.run<any>(CharParser$create('"'))-    return context.setValue<String>(text)+    context                              <- context.run<?>(fileStart)+    context                              <- context.run<?>(nameTag)+    context, ErrorOr<String> name        <- context.runAndGet<?>(sentenceOrToken)+    context                              <- context.run<?>(descriptionTag)+    context, ErrorOr<String> description <- context.runAndGet<?>(sentenceOrToken)+    context                              <- context.run<?>(aWordTag)+    context, ErrorOr<Bool> boolean       <- context.runAndGet<?>(acronymOrAardvark)+    context                              <- context.run<?>(fileEnd)++    if (context.hasAnyError()) {+      return context.convertError()+    } else {+      return context.setValue<?>(+        ErrorOr$$value<?>(TestData$create(name.getValue(),+                                          description.getValue(),+                                          boolean.getValue())))+    }   } -  create () {-    return SentenceParser{ }+  create ()  {+    return TestDataParser{ }   } }

@@ -11,15 +11,15 @@     TypeKey<Float>  keyFloat  <- TypeKey<Float>$new()     TypeKey<Value>  keyValue  <- TypeKey<Value>$new() -    \ tree.set<Int>(keyInt,1)-    \ tree.set<String>(keyString,"a")+    \ tree.set<?>(keyInt,1)+    \ tree.set<?>(keyString,"a") -    \ check<Int>(tree,keyInt)-    \ check<String>(tree,keyString)-    \ check<Float>(tree,keyFloat)  // Not found, since we never added a value.+    \ check<?>(tree,keyInt)+    \ check<?>(tree,keyString)+    \ check<?>(tree,keyFloat)  // Not found, since we never added a value. -    \ tree.set<Value>(keyValue,Value$new())-    \ check<Value>(tree,keyValue)+    \ tree.set<?>(keyValue,Value$new())+    \ check<?>(tree,keyValue)   }    @category check<#x>

@@ -12,7 +12,7 @@   }    set (k,v) {-    \ tree.set(k,LockedType$$create<#x>(k,v))+    \ tree.set(k,LockedType$$create<?>(k,v))     return self   } @@ -25,7 +25,7 @@     scoped {       optional LockedType<any> value <- tree.get(k)     } in if (present(value)) {-      return require(value).check<#x>(k)+      return require(value).check<?>(k)     } else {       return empty     }

@@ -22,7 +22,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$cos(2.0),-0.42,-0.41)+    \ Testing$checkBetween<?>(Math$cos(2.0),-0.42,-0.41)   } } @@ -37,7 +37,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$sin(2.0),0.90,0.91)+    \ Testing$checkBetween<?>(Math$sin(2.0),0.90,0.91)   } } @@ -52,7 +52,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$tan(2.0),-2.19,-2.18)+    \ Testing$checkBetween<?>(Math$tan(2.0),-2.19,-2.18)   } } @@ -67,7 +67,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$acos(0.5),1.04,1.05)+    \ Testing$checkBetween<?>(Math$acos(0.5),1.04,1.05)   } } @@ -82,7 +82,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$asin(0.5),0.52,0.53)+    \ Testing$checkBetween<?>(Math$asin(0.5),0.52,0.53)   } } @@ -97,7 +97,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$atan(0.5),0.46,0.47)+    \ Testing$checkBetween<?>(Math$atan(0.5),0.46,0.47)   } } @@ -112,7 +112,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$cosh(2.0),3.76,3.77)+    \ Testing$checkBetween<?>(Math$cosh(2.0),3.76,3.77)   } } @@ -127,7 +127,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$sinh(2.0),3.62,3.63)+    \ Testing$checkBetween<?>(Math$sinh(2.0),3.62,3.63)   } } @@ -142,7 +142,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$tanh(2.0),0.96,0.97)+    \ Testing$checkBetween<?>(Math$tanh(2.0),0.96,0.97)   } } @@ -157,7 +157,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$acosh(2.0),1.31,1.32)+    \ Testing$checkBetween<?>(Math$acosh(2.0),1.31,1.32)   } } @@ -172,7 +172,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$asinh(2.0),1.44,1.45)+    \ Testing$checkBetween<?>(Math$asinh(2.0),1.44,1.45)   } } @@ -187,7 +187,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$atanh(0.5),0.54,0.55)+    \ Testing$checkBetween<?>(Math$atanh(0.5),0.54,0.55)   } } @@ -202,7 +202,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$exp(1.0),2.71,2.72)+    \ Testing$checkBetween<?>(Math$exp(1.0),2.71,2.72)   } } @@ -217,7 +217,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$log(9.0),2.19,2.20)+    \ Testing$checkBetween<?>(Math$log(9.0),2.19,2.20)   } } @@ -232,7 +232,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$log10(100.0),1.99,2.01)+    \ Testing$checkBetween<?>(Math$log10(100.0),1.99,2.01)   } } @@ -247,7 +247,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$log2(8.0),2.99,3.01)+    \ Testing$checkBetween<?>(Math$log2(8.0),2.99,3.01)   } } @@ -262,7 +262,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$pow(2.0,3.0),7.99,8.01)+    \ Testing$checkBetween<?>(Math$pow(2.0,3.0),7.99,8.01)   } } @@ -277,7 +277,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$sqrt(4.0),1.99,2.01)+    \ Testing$checkBetween<?>(Math$sqrt(4.0),1.99,2.01)   } } @@ -292,7 +292,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$ceil(2.2),2.99,3.01)+    \ Testing$checkBetween<?>(Math$ceil(2.2),2.99,3.01)   } } @@ -307,7 +307,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$floor(2.2),1.99,2.01)+    \ Testing$checkBetween<?>(Math$floor(2.2),1.99,2.01)   } } @@ -322,7 +322,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$fmod(7.0,4.0),2.99,3.01)+    \ Testing$checkBetween<?>(Math$fmod(7.0,4.0),2.99,3.01)   } } @@ -337,7 +337,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$trunc(2.2),1.99,2.01)+    \ Testing$checkBetween<?>(Math$trunc(2.2),1.99,2.01)   } } @@ -352,7 +352,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$round(2.7),2.99,3.01)+    \ Testing$checkBetween<?>(Math$round(2.7),2.99,3.01)   } } @@ -367,7 +367,7 @@  define Test {   run () {-    \ Testing$checkBetween<Float>(Math$fabs(-10.0),9.99,10.01)+    \ Testing$checkBetween<?>(Math$fabs(-10.0),9.99,10.01)   } } 

@@ -260,7 +260,7 @@ define Test {   run () {     String allContents <- TextReader$readAll(FakeFile$create())-    \ Testing$check<String>(allContents,"this is a partial line\nwith some more data\nand\nmore lines\nunfinished")+    \ Testing$check<?>(allContents,"this is a partial line\nwith some more data\nand\nmore lines\nunfinished")   } } @@ -315,7 +315,7 @@     if (!value.isError()) {       fail("Failed")     }-    \ Testing$check<String>(value.getError().formatted(),"error message")+    \ Testing$check<?>(value.getError().formatted(),"error message")   } } @@ -350,7 +350,7 @@     scoped {       ErrorOr<String> error <- ErrorOr$$error("error message")     } in ErrorOr<Int> value <- error.convertError()-    \ Testing$check<String>(value.getError().formatted(),"error message")+    \ Testing$check<?>(value.getError().formatted(),"error message")   } } 

@@ -21,14 +21,14 @@ {-# LANGUAGE Safe #-}  module Base.CompileError (-  CompileError(..),   CompileErrorM(..),+  errorFromIO,+  mapErrorsM,+  mapErrorsM_, ) where -#if MIN_VERSION_base(4,8,0)-#else-import Data.Foldable-#endif+import Control.Monad.IO.Class+import System.IO.Error (catchIOError)  #if MIN_VERSION_base(4,13,0) import Control.Monad.Fail ()@@ -37,27 +37,28 @@ #endif  -class CompileError a where-  compileError :: String -> a-  isCompileError :: a -> Bool-  reviseError :: a -> String -> a-  reviseError e _ = e- -- For some GHC versions, pattern-matching failures require MonadFail. #if MIN_VERSION_base(4,9,0)-class (Functor m, Monad m, MonadFail m) => CompileErrorM m where+class (Monad m, MonadFail m) => CompileErrorM m where #else-class (Functor m, Monad m) => CompileErrorM m where+class Monad m => CompileErrorM m where #endif   compileErrorM :: String -> m a-  isCompileErrorM :: m a -> Bool   collectAllOrErrorM :: Foldable f => f (m a) -> m [a]   collectOneOrErrorM :: Foldable f => f (m a) -> m a   reviseErrorM :: m a -> String -> m a   reviseErrorM e _ = e   compileWarningM :: String -> m () -instance CompileErrorM m => CompileError (m a) where-  compileError = compileErrorM-  isCompileError = isCompileErrorM-  reviseError = reviseErrorM+mapErrorsM :: CompileErrorM m => (a -> m b) -> [a] -> m [b]+mapErrorsM f = collectAllOrErrorM . map f++mapErrorsM_ :: CompileErrorM m => (a -> m b) -> [a] -> m ()+mapErrorsM_ f xs = mapErrorsM f xs >> return ()++errorFromIO :: (MonadIO m, CompileErrorM m) => IO a -> m a+errorFromIO x = do+  x' <- liftIO $ fmap Right x `catchIOError` (return . Left . show)+  case x' of+       (Right x2) -> return x2+       (Left e)   -> compileErrorM e

@@ -0,0 +1,224 @@+{- -----------------------------------------------------------------------------+Copyright 2019-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]++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Safe #-}++module Base.CompileInfo (+  CompileInfo,+  CompileInfoIO,+  CompileMessage,+  fromCompileInfo,+  getCompileError,+  getCompileErrorT,+  getCompileSuccess,+  getCompileSuccessT,+  getCompileWarnings,+  getCompileWarningsT,+  isCompileError,+  isCompileErrorT,+  toCompileInfo,+  tryCompileInfoIO,+) where++import Control.Applicative+import Control.Monad ((>=>))+import Control.Monad.IO.Class ()+import Control.Monad.Trans+import Data.Foldable+import Data.Functor+import Data.Functor.Identity+import Data.List (intercalate)+import Prelude hiding (concat,foldr)+import System.Exit+import System.IO++#if MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ()+#elif MIN_VERSION_base(4,9,0)+import Control.Monad.Fail+#endif++import Base.CompileError+import Base.Mergeable+++type CompileInfo a = CompileInfoT Identity a++type CompileInfoIO a = CompileInfoT IO a++data CompileInfoT m a =+  CompileInfoT {+    citState :: m (CompileInfoState a)+  }++getCompileError :: CompileInfo a -> CompileMessage+getCompileError = runIdentity . getCompileErrorT++getCompileSuccess :: CompileInfo a -> a+getCompileSuccess = runIdentity . getCompileSuccessT++getCompileWarnings :: CompileInfo a -> [String]+getCompileWarnings = runIdentity . getCompileWarningsT++isCompileError :: CompileInfo a -> Bool+isCompileError = runIdentity . isCompileErrorT++getCompileErrorT :: Monad m => CompileInfoT m a -> m CompileMessage+getCompileErrorT = fmap cfErrors . citState++getCompileSuccessT :: Monad m => CompileInfoT m a -> m a+getCompileSuccessT = fmap csData . citState++getCompileWarningsT :: Monad m => CompileInfoT m a -> m [String]+getCompileWarningsT = fmap getWarnings . citState++isCompileErrorT :: Monad m => CompileInfoT m a -> m Bool+isCompileErrorT x = do+  x' <- citState x+  case x' of+       CompileFail _ _ -> return True+       _               -> return False++fromCompileInfo :: Monad m => CompileInfo a -> CompileInfoT m a+fromCompileInfo x = runIdentity $ do+  x' <- citState x+  return $ CompileInfoT $ return x'++toCompileInfo :: Monad m => CompileInfoT m a -> m (CompileInfo a)+toCompileInfo x = do+  x' <- citState x+  return $ CompileInfoT $ return x'++tryCompileInfoIO :: String -> CompileInfoIO a -> IO a+tryCompileInfoIO message x = do+  x' <- toCompileInfo $ x `reviseErrorM` message+  if isCompileError x'+     then do+       hPutStr stderr $ concat $ map (++ "\n") (getCompileWarnings x')+       hPutStr stderr $ show $ getCompileError x'+       exitFailure+     else do+       hPutStr stderr $ concat $ map (++ "\n") (getCompileWarnings x')+       return $ getCompileSuccess x'++data CompileMessage =+  CompileMessage {+    cmMessage :: String,+    cmNested :: [CompileMessage]+  }++instance Show CompileMessage where+  show = format "" where+    format indent (CompileMessage [] ms) =+      concat (map (format indent) ms)+    format indent (CompileMessage m ms) =+      (doIndent indent m) ++ "\n" ++ concat (map (format $ indent ++ "  ") ms)+    doIndent indent s = intercalate "\n" $ map (indent ++) $ lines s++data CompileInfoState a =+  CompileFail {+    cfWarnings :: [String],+    cfErrors :: CompileMessage+  } |+  CompileSuccess {+    csWarnings :: [String],+    csData :: a+  }++instance (Functor m, Monad m) => Functor (CompileInfoT m) where+  fmap f x = CompileInfoT $ do+    x' <- citState x+    case x' of+         CompileFail w e    -> return $ CompileFail w e -- Not the same a.+         CompileSuccess w d -> return $ CompileSuccess w (f d)++instance (Applicative m, Monad m) => Applicative (CompileInfoT m) where+  pure = CompileInfoT .return . CompileSuccess []+  f <*> x = CompileInfoT $ do+    f' <- citState f+    x' <- citState x+    case (f',x') of+         (CompileFail w e,     _)                   -> return $ CompileFail w e -- Not the same a.+         (i,                   CompileFail w e)     -> return $ CompileFail (getWarnings i ++ w) e -- Not the same a.+         (CompileSuccess w1 f2,CompileSuccess w2 d) -> return $ CompileSuccess (w1 ++ w2) (f2 d)++instance Monad m => Monad (CompileInfoT m) where+  x >>= f = CompileInfoT $ do+    x' <- citState x+    case x' of+         CompileFail w e    -> return $ CompileFail w e -- Not the same a.+         CompileSuccess w d -> do+           d2 <- citState $ f d+           return $ prependWarning w d2+  return = pure++#if MIN_VERSION_base(4,9,0)+instance Monad m => MonadFail (CompileInfoT m) where+  fail = compileErrorM+#endif++instance MonadTrans CompileInfoT where+  lift = CompileInfoT . fmap (CompileSuccess [])++instance MonadIO m => MonadIO (CompileInfoT m) where+  liftIO = lift . liftIO++instance Monad m => CompileErrorM (CompileInfoT m) where+  compileErrorM e = CompileInfoT (return $ CompileFail [] $ CompileMessage e [])+  collectAllOrErrorM xs = CompileInfoT $ do+    xs' <- sequence $ map citState $ foldr (:) [] xs+    return $ result $ splitErrorsAndData xs' where+      result ([],xs2,ws) = CompileSuccess ws xs2+      result (es,_,ws)   = CompileFail ws $ CompileMessage "" es+  collectOneOrErrorM xs = CompileInfoT $ do+    xs' <- sequence $ map citState $ foldr (:) [] xs+    return $ result $ splitErrorsAndData xs' where+      result (_,x:_,ws) = CompileSuccess ws x+      result ([],_,ws)  = CompileFail ws $ CompileMessage "" []+      result (es,_,ws)  = CompileFail ws $ CompileMessage "" es+  reviseErrorM x e2 = CompileInfoT $ do+    x' <- citState x+    case x' of+         CompileFail w (CompileMessage [] ms) -> return $ CompileFail w $ CompileMessage e2 ms+         CompileFail w e                      -> return $ CompileFail w $ CompileMessage e2 [e]+         x2                                   -> return x2+  compileWarningM w = CompileInfoT (return $ CompileSuccess [w] ())++instance Monad m => MergeableM (CompileInfoT m) where+  mergeAnyM xs = CompileInfoT $ do+    xs' <- sequence $ map citState $ foldr (:) [] xs+    return $ result $ splitErrorsAndData xs' where+      result ([],[],ws) = CompileFail ws $ CompileMessage "" []+      result (es,[],ws) = CompileFail ws $ CompileMessage "" es+      result (_,xs2,ws) = CompileSuccess ws (mergeAny xs2)+  mergeAllM = collectAllOrErrorM >=> return . mergeAll++getWarnings :: CompileInfoState a -> [String]+getWarnings (CompileFail w _)    = w+getWarnings (CompileSuccess w _) = w++prependWarning :: [String] -> CompileInfoState a -> CompileInfoState a+prependWarning w (CompileSuccess w2 d) = CompileSuccess (w ++ w2) d+prependWarning w (CompileFail w2 e)    = CompileFail (w ++ w2) e++splitErrorsAndData :: Foldable f => f (CompileInfoState a) -> ([CompileMessage],[a],[String])+splitErrorsAndData = foldr partition ([],[],[]) where+  partition (CompileFail w e)    (es,ds,ws) = (e:es,ds,w++ws)+  partition (CompileSuccess w d) (es,ds,ws) = (es,d:ds,w++ws)

@@ -0,0 +1,82 @@+{- -----------------------------------------------------------------------------+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]++{-# LANGUAGE Safe #-}++module Base.MergeTree (+  MergeTree,+  mergeLeaf,+  pruneMergeTree,+  reduceMergeTree,+) where++import Base.Mergeable+++data MergeTree a =+  MergeAny [MergeTree a] |+  MergeAll [MergeTree a] |+  MergeLeaf a+  deriving (Eq)++instance Show a => Show (MergeTree a) where+  show (MergeAny xs) = "mergeAny " ++ show xs+  show (MergeAll xs) = "mergeAll " ++ show xs+  show (MergeLeaf x) = "mergeLeaf " ++ show x++mergeLeaf :: a -> MergeTree a+mergeLeaf = MergeLeaf++reduceMergeTree :: (Mergeable b, MergeableM m) => (b -> m b) -> (b -> m b) ->+  (a -> m b) -> MergeTree a -> m b+reduceMergeTree anyOp allOp leafOp xa = reduce xa where+  reduce (MergeAny xs) = do+    xs' <- mergeAnyM $ map reduce xs+    anyOp xs'+  reduce (MergeAll xs) = do+    xs' <- mergeAllM $ map reduce xs+    allOp xs'+  reduce (MergeLeaf x) = leafOp x++pruneMergeTree :: MergeableM m => MergeTree (m a) -> m (MergeTree a)+pruneMergeTree = reduceMergeTree return return (fmap MergeLeaf)++instance Functor MergeTree where+  fmap f (MergeAny xs) = MergeAny (map (fmap f) xs)+  fmap f (MergeAll xs) = MergeAll (map (fmap f) xs)+  fmap f (MergeLeaf x) = MergeLeaf (f x)++instance Foldable MergeTree where+  foldr f y = foldr f y . maybe [] id . reduceMergeTree return return (return . (:[]))++instance Traversable MergeTree where+  traverse f (MergeAny xs) = MergeAny <$> foldr (<*>) (pure []) (map (fmap (:) . traverse f) xs)+  traverse f (MergeAll xs) = MergeAll <$> foldr (<*>) (pure []) (map (fmap (:) . traverse f) xs)+  traverse f (MergeLeaf x) = fmap MergeLeaf (f x)++instance Mergeable (MergeTree a) where+  mergeAny = unnest . filter (not . isEmptyAny) . foldr (:) [] where+    isEmptyAny (MergeAny []) = True+    isEmptyAny _             = False+    unnest [x] = x+    unnest xs  = MergeAny xs+  mergeAll = unnest . filter (not . isEmptyAll) . foldr (:) [] where+    isEmptyAll (MergeAll []) = True+    isEmptyAll _             = False+    unnest [x] = x+    unnest xs  = MergeAll xs

@@ -23,30 +23,38 @@ module Base.Mergeable (   Mergeable(..),   MergeableM(..),+  mergeDefault,+  mergeDefaultM, ) where -#if MIN_VERSION_base(4,8,0)+#if MIN_VERSION_base(4,11,0) #else-import Data.Foldable+import Data.Monoid ((<>)) #endif   class Mergeable a where   mergeAny :: Foldable f => f a -> a   mergeAll :: Foldable f => f a -> a-  mergeNested :: a -> a -> a-  mergeNested x y = mergeAll [x,y]-  mergeDefault :: a-  mergeDefault = mergeAll Nothing -class (Functor m, Monad m) => MergeableM m where+class Monad m => MergeableM m where   mergeAnyM :: (Mergeable a, Foldable f) => f (m a) -> m a   mergeAllM :: (Mergeable a, Foldable f) => f (m a) -> m a-  mergeNestedM :: Mergeable a => m a -> m a -> m a-  mergeNestedM x y = mergeAllM [x,y]-  mergeDefaultM :: Mergeable a => m a-  mergeDefaultM = mergeAllM Nothing +mergeDefault :: Mergeable a => a+mergeDefault = mergeAll Nothing++mergeDefaultM :: (MergeableM m, Mergeable a) => m a+mergeDefaultM = mergeAllM Nothing+ instance Mergeable () where   mergeAny = const ()   mergeAll = const ()++instance Mergeable [a] where+  mergeAny = foldr (++) []+  mergeAll = foldr (++) []++instance MergeableM Maybe where+  mergeAnyM = fmap mergeAny . foldr ((<>) . fmap (:[])) Nothing+  mergeAllM = fmap mergeAll . sequence . foldr (:) []

@@ -31,7 +31,7 @@ import Text.Parsec (SourcePos)  import Cli.CompileOptions-import Config.Programs (VersionHash)+import Cli.Programs (VersionHash) import Types.Procedure (Expression) import Types.TypeCategory (Namespace) import Types.TypeInstance (CategoryName)

@@ -28,7 +28,6 @@ import Data.Either (partitionEithers) import Data.List (isSuffixOf,nub,sort) import System.Directory-import System.Exit import System.FilePath import System.Posix.Temp (mkstemps) import System.IO@@ -39,15 +38,14 @@ import Base.CompileError import Cli.CompileMetadata import Cli.CompileOptions+import Cli.Paths import Cli.ProcessMetadata+import Cli.Programs import Cli.TestRunner -- Not safe, due to Text.Regex.TDFA.-import Compilation.CompileInfo+import Base.CompileInfo import Compilation.ProcedureContext (ExprMap) import CompilerCxx.Category import CompilerCxx.Naming-import Config.LoadConfig-import Config.Paths-import Config.Programs import Parser.SourceFile import Types.Builtin import Types.DefinedCategory@@ -84,19 +82,15 @@   }   deriving (Show) -compileModule :: ModuleSpec -> IO ()-compileModule (ModuleSpec p d em is is2 ps xs ts es ep m f) = do-  (backend,resolver) <- loadConfig-  let hash = getCompilerHash backend-  as  <- fmap fixPaths $ sequence $ map (resolveModule resolver (p </> d)) is-  as2 <- fmap fixPaths $ sequence $ map (resolveModule resolver (p </> d)) is2+compileModule :: (PathIOHandler r, CompilerBackend b) => r -> b -> ModuleSpec -> CompileInfoIO ()+compileModule resolver backend (ModuleSpec p d em is is2 ps xs ts es ep m f) = do+  as  <- fmap fixPaths $ mapErrorsM (resolveModule resolver (p </> d)) is+  as2 <- fmap fixPaths $ mapErrorsM (resolveModule resolver (p </> d)) is2   let ca0 = Map.empty-  (fr1,deps1) <- loadPublicDeps hash ca0 as+  deps1 <- loadPublicDeps compilerHash f ca0 as   let ca1 = ca0 `Map.union` mapMetadata deps1-  checkAllowedStale fr1 f-  (fr2,deps2) <- loadPublicDeps hash ca1 as2+  deps2 <- loadPublicDeps compilerHash f ca1 as2   let ca2 = ca1 `Map.union` mapMetadata deps2-  checkAllowedStale fr2 f   base <- resolveBaseModule resolver   actual <- resolveModule resolver p d   isBase <- isBaseModule resolver actual@@ -104,42 +98,36 @@   deps1' <- if isBase                then return deps1                else do-                 (fr3,bpDeps) <- loadPublicDeps hash ca2 [base]-                 checkAllowedStale fr3 f+                 bpDeps <- loadPublicDeps compilerHash f ca2 [base]                  return $ bpDeps ++ deps1   ns0 <- createPublicNamespace p d   let ex = concat $ map getSourceCategories es-  cm <- loadLanguageModule p ns0 ex em ps deps1' deps2-  xa <- fmap collectAllOrErrorM $ sequence $ map (loadPrivateSource p) xs-  let fs = compileAll cm xa+  (cm,(pc,tc)) <- loadLanguageModule p ns0 ex em ps deps1' deps2+  xa <- mapErrorsM (loadPrivateSource p) xs+  (xx1,xx2) <- compileLanguageModule cm xa+  mf <- maybeCreateMain cm xa m+  let fs' = xx1++xx2   eraseCachedData (p </> d)-  when (isCompileError fs) $ do-    formatWarnings fs-    hPutStr stderr $ "Compiler errors:\n" ++ (show $ getCompileError fs)-    hPutStrLn stderr $ "Zeolite compilation failed."-    exitFailure-  formatWarnings fs-  let (pc,tc,mf,fs') = getCompileSuccess fs   let ps2 = map takeFileName ps   let xs2 = map takeFileName xs   let ts2 = map takeFileName ts   let paths = map (\ns -> getCachedPath (p </> d) ns "") $ nub $ filter (not . null) $ map show $ [ns0] ++ map coNamespace fs'-  paths' <- sequence $ map canonicalizePath paths-  s0 <- canonicalizePath $ getCachedPath (p </> d) (show ns0) ""+  paths' <- mapM (errorFromIO . canonicalizePath) paths+  s0 <- errorFromIO $ canonicalizePath $ getCachedPath (p </> d) (show ns0) ""   let paths2 = base:(getIncludePathsForDeps (deps1' ++ deps2)) ++ ep' ++ paths'   let hxx   = filter (isSuffixOf ".hpp" . coFilename)       fs'   let other = filter (not . isSuffixOf ".hpp" . coFilename) fs'-  os1 <- sequence $ map (writeOutputFile backend (show ns0) paths2) $ hxx ++ other+  os1 <- mapErrorsM (writeOutputFile (show ns0) paths2) $ hxx ++ other   let files = map (\f2 -> getCachedPath (p </> d) (show $ coNamespace f2) (coFilename f2)) fs' ++               map (\f2 -> p </> getSourceFile f2) es-  files' <- sequence $ map checkOwnedFile files-  os2 <- fmap concat $ sequence $ map (compileExtraSource backend (show ns0) paths2) es+  files' <- mapErrorsM checkOwnedFile files+  os2 <- fmap concat $ mapErrorsM (compileExtraSource (show ns0) paths2) es   let (hxx',cxx,os') = sortCompiledFiles files'   let (osCat,osOther) = partitionEithers os2-  path <- canonicalizePath $ p </> d+  path <- errorFromIO $ canonicalizePath $ p </> d   let os1' = resolveObjectDeps (deps1' ++ deps2) path path (os1 ++ osCat)   let cm2 = CompileMetadata {-      cmVersionHash = hash,+      cmVersionHash = compilerHash,       cmPath = path,       cmNamespace = ns0,       cmPublicDeps = as,@@ -156,7 +144,7 @@       cmLinkFlags = getLinkFlags m,       cmObjectFiles = os1' ++ osOther ++ map OtherObjectFile os'     }-  bs <- createBinary backend resolver paths' (cm2:(deps1' ++ deps2)) m mf+  bs <- createBinary paths' (cm2:(deps1' ++ deps2)) m mf   let cm2' = CompileMetadata {       cmVersionHash = cmVersionHash cm2,       cmPath = cmPath cm2,@@ -175,17 +163,11 @@       cmLinkFlags = cmLinkFlags cm2,       cmObjectFiles = cmObjectFiles cm2     }-  writeMetadata (p </> d) cm2'-  hPutStrLn stderr $ "Zeolite compilation succeeded." where-    compileAll cm xa = do-      (cm',(pc,tc)) <- cm-      xa' <- xa-      (xx1,xx2) <- compileLanguageModule cm' xa'-      ms <- maybeCreateMain cm' xa' m-      return (pc,tc,ms,xx1++xx2)+  writeMetadata (p </> d) cm2' where+    compilerHash = getCompilerHash backend     ep' = fixPaths $ map (p </>) ep-    writeOutputFile b ns0 paths ca@(CxxOutput _ f2 ns _ _ content) = do-      hPutStrLn stderr $ "Writing file " ++ f2+    writeOutputFile ns0 paths ca@(CxxOutput _ f2 ns _ _ content) = do+      errorFromIO $ hPutStrLn stderr $ "Writing file " ++ f2       writeCachedFile (p </> d) (show ns) f2 $ concat $ map (++ "\n") content       if isSuffixOf ".cpp" f2 || isSuffixOf ".cc" f2          then do@@ -195,17 +177,17 @@            createCachePath (p </> d)            let ns' = if isStaticNamespace ns then show ns else show ns0            let command = CompileToObject f2' (getCachedPath (p </> d) ns' "") dynamicNamespaceName "" (p0:p1:paths) False-           o2 <- runCxxCommand b command+           o2 <- runCxxCommand backend command            return $ ([o2],ca)          else return ([],ca)-    compileExtraSource b ns0 paths (CategorySource f2 cs ds2) = do-      f2' <- compileExtraFile False b ns0 paths f2+    compileExtraSource ns0 paths (CategorySource f2 cs ds2) = do+      f2' <- compileExtraFile False ns0 paths f2       let ds2' = nub $ cs ++ ds2       case f2' of            Nothing -> return []            Just o  -> return $ map (\c -> Left $ ([o],fakeCxxForSource ns0 ds2' c)) cs-    compileExtraSource b ns0 paths (OtherSource f2) = do-      f2' <- compileExtraFile True b ns0 paths f2+    compileExtraSource ns0 paths (OtherSource f2) = do+      f2' <- compileExtraFile True ns0 paths f2       case f2' of            Just o  -> return [Right $ OtherObjectFile o]            Nothing -> return []@@ -219,157 +201,126 @@       } where         ns' = if null ns then NoNamespace else StaticNamespace ns     checkOwnedFile f2 = do-      exists <- doesFileExist f2-      when (not exists) $ do-        hPutStrLn stderr $ "Owned file " ++ f2 ++ " does not exist."-        hPutStrLn stderr $ "Zeolite compilation failed."-        exitFailure-      canonicalizePath f2-    compileExtraFile e b ns0 paths f2+      exists <- errorFromIO $ doesFileExist f2+      when (not exists) $ compileErrorM $ "Owned file " ++ f2 ++ " does not exist."+      errorFromIO $ canonicalizePath f2+    compileExtraFile e ns0 paths f2       | isSuffixOf ".cpp" f2 || isSuffixOf ".cc" f2 = do           let f2' = p </> f2           createCachePath (p </> d)           let command = CompileToObject f2' (getCachedPath (p </> d) "" "") dynamicNamespaceName ns0 paths e-          fmap Just $ runCxxCommand b command+          fmap Just $ runCxxCommand backend command       | isSuffixOf ".a" f2 || isSuffixOf ".o" f2 = return (Just f2)       | otherwise = return Nothing-    createBinary b r paths deps (CompileBinary n _ o lf) ms-      | length ms > 1 = do-        hPutStrLn stderr $ "Multiple matches for main category " ++ show n ++ "."-        exitFailure-      | length ms == 0 = do-        hPutStrLn stderr $ "Main category " ++ show n ++ " not found."-        exitFailure+    createBinary paths deps (CompileBinary n _ o lf) ms+      | length ms >  1 = compileErrorM $ "Multiple matches for main category " ++ show n ++ "."+      | length ms == 0 = compileErrorM $ "Main category " ++ show n ++ " not found."       | otherwise = do           f0 <- if null o-                   then canonicalizePath $ p </> d </> show n-                   else canonicalizePath $ p </> d </> o+                   then errorFromIO $ canonicalizePath $ p </> d </> show n+                   else errorFromIO $ canonicalizePath $ p </> d </> o           let (CxxOutput _ _ _ ns2 req content) = head ms           -- TODO: Create a helper or a constant or something.-          (o',h) <- mkstemps "/tmp/zmain_" ".cpp"-          hPutStr h $ concat $ map (++ "\n") content-          hClose h-          base <- resolveBaseModule r-          (fr,deps2)  <- loadPrivateDeps (getCompilerHash b) (mapMetadata deps) deps-          checkAllowedStale fr f+          (o',h) <- errorFromIO $ mkstemps "/tmp/zmain_" ".cpp"+          errorFromIO $ hPutStr h $ concat $ map (++ "\n") content+          errorFromIO $ hClose h+          base <- resolveBaseModule resolver+          deps2  <- loadPrivateDeps compilerHash f (mapMetadata deps) deps           let lf' = lf ++ getLinkFlagsForDeps deps2           let paths' = fixPaths $ paths ++ base:(getIncludePathsForDeps deps)           let os     = getObjectFilesForDeps deps2           let ofr = getObjectFileResolver os           let os' = ofr ns2 req           let command = CompileToBinary o' os' f0 paths' lf'-          hPutStrLn stderr $ "Creating binary " ++ f0-          _ <- runCxxCommand b command-          removeFile o'-          return [f0]-    createBinary _ _ _ _ _ _ = return []+          errorFromIO $ hPutStrLn stderr $ "Creating binary " ++ f0+          f1 <- runCxxCommand backend command+          errorFromIO $ removeFile o'+          return [f1]+    createBinary _ _ _ _ = return []     maybeCreateMain cm2 xs2 (CompileBinary n f2 _ _) =       fmap (:[]) $ compileModuleMain cm2 xs2 n f2     maybeCreateMain _ _ _ = return [] -createModuleTemplates :: FilePath -> FilePath -> [CompileMetadata] -> [CompileMetadata] -> IO ()+createModuleTemplates :: FilePath -> FilePath -> [CompileMetadata] -> [CompileMetadata] -> CompileInfoIO () createModuleTemplates p d deps1 deps2 = do   ns0 <- createPublicNamespace p d   (ps,xs,_) <- findSourceFiles p d-  cm <- fmap (fmap fst) $ loadLanguageModule p ns0 [] Map.empty ps deps1 deps2+  (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _ _,_) <-+    fmap (fmap fst) $ loadLanguageModule p ns0 [] Map.empty ps deps1 deps2   xs' <- zipWithContents p xs-  let ts = createTemplates cm xs'-  if isCompileError ts-      then do-        formatWarnings ts-        hPutStr stderr $ "Compiler errors:\n" ++ (show $ getCompileError ts)-        hPutStrLn stderr $ "Zeolite compilation failed."-        exitFailure-      else do-        formatWarnings ts-        sequence_ $ map writeTemplate $ getCompileSuccess ts where-  createTemplates cm xs = do-    (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _ _) <- cm-    ds <- collectAllOrErrorM $ map parseInternalSource xs-    let ds2 = concat $ map (\(_,_,d2) -> d2) ds-    tm <- foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1]-    let cs = filter isValueConcrete $ cs1++ps1++ts1-    let ca = Set.fromList $ map getCategoryName $ filter isValueConcrete cs-    let ca' = foldr Set.delete ca $ map dcName ds2-    collectAllOrErrorM $ map (compileConcreteTemplate tm) $ Set.toList ca'+  ds <- mapErrorsM parseInternalSource xs'+  let ds2 = concat $ map (\(_,_,d2) -> d2) ds+  tm <- foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1]+  let cs = filter isValueConcrete $ cs1++ps1++ts1+  let ca = Set.fromList $ map getCategoryName $ filter isValueConcrete cs+  let ca' = foldr Set.delete ca $ map dcName ds2+  ts <- mapErrorsM (compileConcreteTemplate tm) $ Set.toList ca'+  mapErrorsM_ writeTemplate ts where   writeTemplate (CxxOutput _ n _ _ _ content) = do     let n' = p </> d </> n-    exists <- doesFileExist n'+    exists <- errorFromIO $ doesFileExist n'     if exists-        then hPutStrLn stderr $ "Skipping existing file " ++ n+        then compileWarningM $ "Skipping existing file " ++ n         else do-          hPutStrLn stderr $ "Writing file " ++ n-          writeFile n' $ concat $ map (++ "\n") content+          errorFromIO $ hPutStrLn stderr $ "Writing file " ++ n+          errorFromIO $ writeFile n' $ concat $ map (++ "\n") content -runModuleTests :: CompilerBackend b => b -> FilePath -> [FilePath] -> LoadedTests -> IO [((Int,Int),CompileInfo ())]-runModuleTests b base tp (LoadedTests p d m em deps1 deps2) = do+runModuleTests :: (PathIOHandler r, CompilerBackend b) => r -> b -> FilePath ->+  [FilePath] -> LoadedTests -> CompileInfoIO [((Int,Int),CompileInfo ())]+runModuleTests _ backend base tp (LoadedTests p d m em deps1 deps2) = do   let paths = base:(getIncludePathsForDeps deps1)-  mapM_ showSkipped $ filter (not . isTestAllowed) $ cmTestFiles m+  mapErrorsM_ showSkipped $ filter (not . isTestAllowed) $ cmTestFiles m   ts' <- zipWithContents p $ map (d </>) $ filter isTestAllowed $ cmTestFiles m-  path <- canonicalizePath (p </> d)-  cm <- fmap (fmap fst) $ loadLanguageModule path NoNamespace [] em [] deps1 []-  if isCompileError cm-      then return [((0,0),cm >> return ())]-      else sequence $ map (runSingleTest b (getCompileSuccess cm) path paths (m:deps2)) ts' where+  path <- errorFromIO $ canonicalizePath (p </> d)+  (cm,_) <- loadLanguageModule path NoNamespace [] em [] deps1 []+  mapErrorsM (runSingleTest backend cm path paths (m:deps2)) ts' where     allowTests = Set.fromList tp     isTestAllowed t = if null allowTests then True else t `Set.member` allowTests-    showSkipped f = do-      hPutStrLn stderr $ "Skipping tests in " ++ f ++ " due to explicit test filter."--createPublicNamespace :: FilePath -> FilePath -> IO Namespace-createPublicNamespace p d = canonicalizePath (p </> d) >>= return . StaticNamespace . publicNamespace+    showSkipped f = compileWarningM $ "Skipping tests in " ++ f ++ " due to explicit test filter." -createPrivateNamespace :: FilePath -> FilePath -> IO Namespace-createPrivateNamespace p f = canonicalizePath (p </> f) >>= return . StaticNamespace . publicNamespace+createPublicNamespace :: FilePath -> FilePath -> CompileInfoIO Namespace+createPublicNamespace p d = (errorFromIO $ canonicalizePath (p </> d)) >>= return . StaticNamespace . publicNamespace -formatWarnings :: CompileInfo a -> IO ()-formatWarnings c-  | null $ getCompileWarnings c = return ()-  | otherwise = hPutStr stderr $ "Compiler warnings:\n" ++ (concat $ map (++ "\n") (getCompileWarnings c))+createPrivateNamespace :: FilePath -> FilePath -> CompileInfoIO Namespace+createPrivateNamespace p f = (errorFromIO $ canonicalizePath (p </> f)) >>= return . StaticNamespace . publicNamespace -zipWithContents :: FilePath -> [FilePath] -> IO [(FilePath,String)]-zipWithContents p fs = fmap (zip $ map fixPath fs) $ sequence $ map (readFile . (p </>)) fs+zipWithContents :: FilePath -> [FilePath] -> CompileInfoIO [(FilePath,String)]+zipWithContents p fs = fmap (zip $ map fixPath fs) $ mapM (errorFromIO . readFile . (p </>)) fs -loadPrivateSource :: CompileErrorM m => FilePath -> FilePath -> IO (m (PrivateSource SourcePos))+loadPrivateSource :: FilePath -> FilePath -> CompileInfoIO (PrivateSource SourcePos) loadPrivateSource p f = do   [f'] <- zipWithContents p [f]   ns <- createPrivateNamespace p f-  return $ do-    (pragmas,cs,ds) <- parseInternalSource f'-    let cs' = map (setCategoryNamespace ns) cs-    let testing = any isTestsOnly pragmas-    return $ PrivateSource ns testing cs' ds+  (pragmas,cs,ds) <- parseInternalSource f'+  let cs' = map (setCategoryNamespace ns) cs+  let testing = any isTestsOnly pragmas+  return $ PrivateSource ns testing cs' ds -loadLanguageModule :: CompileErrorM m => FilePath -> Namespace ->-  [CategoryName] -> ExprMap SourcePos -> [FilePath] -> [CompileMetadata] ->-  [CompileMetadata] -> IO (m (LanguageModule SourcePos,([CategoryName],[CategoryName])))+loadLanguageModule :: FilePath -> Namespace -> [CategoryName] ->+  ExprMap SourcePos -> [FilePath] -> [CompileMetadata] -> [CompileMetadata] ->+  CompileInfoIO (LanguageModule SourcePos,([CategoryName],[CategoryName])) loadLanguageModule p ns2 ex em fs deps1 deps2 = do   let public = Set.fromList $ map cmPath deps1   let deps2' = filter (\cm -> not $ cmPath cm `Set.member` public) deps2   let ns0 = filter (not . isNoNamespace) $ getNamespacesForDeps deps1   let ns1 = filter (not . isNoNamespace) $ getNamespacesForDeps deps2'-  m0 <- fmap merge $ sequence $ map processAll deps1-  m1 <- fmap merge $ sequence $ map processAll deps2'-  m2 <- loadAllPublic "" fs-  return $ construct m0 m1 m2 ns0 ns1 where-    construct m0 m1 m2 ns0 ns1 = do-      (ps0,_,tsA0,_)      <- m0-      (ps1,_,tsA1,_)      <- m1-      (ps2,xs2,tsA2,tsB2) <- m2-      let cm = LanguageModule {-          lmPublicNamespaces = ns0,-          lmPrivateNamespaces = ns1,-          lmLocalNamespaces = [ns2],-          lmPublicDeps = ps0,-          lmPrivateDeps = ps1,-          lmTestingDeps = tsA0++tsA1,-          lmPublicLocal = map (setCategoryNamespace ns2) ps2,-          lmPrivateLocal = map (setCategoryNamespace ns2) xs2,-          lmTestingLocal = map (setCategoryNamespace ns2) $ tsA2 ++ tsB2,-          lmExternal = ex,-          lmExprMap = em-        }-      return (cm,(map getCategoryName $ ps2++tsA2,map getCategoryName $ xs2++tsB2))+  (ps0,_,  tsA0,_)    <- fmap merge $ mapErrorsM processAll deps1+  (ps1,_,  tsA1,_)    <- fmap merge $ mapErrorsM processAll deps2'+  (ps2,xs2,tsA2,tsB2) <- loadAllPublic "" fs+  let cm = LanguageModule {+      lmPublicNamespaces = ns0,+      lmPrivateNamespaces = ns1,+      lmLocalNamespaces = [ns2],+      lmPublicDeps = ps0,+      lmPrivateDeps = ps1,+      lmTestingDeps = tsA0++tsA1,+      lmPublicLocal = map (setCategoryNamespace ns2) ps2,+      lmPrivateLocal = map (setCategoryNamespace ns2) xs2,+      lmTestingLocal = map (setCategoryNamespace ns2) $ tsA2 ++ tsB2,+      lmExternal = ex,+      lmExprMap = em+    }+  return (cm,(map getCategoryName $ ps2++tsA2,map getCategoryName $ xs2++tsB2)) where     loadPublic p2 p3 = parsePublicSource p3 >>= return . uncurry (partition p2)     partition p2 pragmas cs       -- Allow ModuleOnly when the path is the same. Only needed for tests.@@ -382,12 +333,9 @@     processAll dep = do       let dep' = getSourceFilesForDeps [dep]       loadAllPublic (cmPath dep) dep'-    merge as = do-      as' <- collectAllOrErrorM as-      return $ foldl merge4 ([],[],[],[]) as'     loadAllPublic p2 fs2 = do       fs2' <- zipWithContents p fs2-      return $ do-        as <- collectAllOrErrorM $ map (loadPublic p2) fs2'-        return $ foldl merge4 ([],[],[],[]) as+      as <- mapErrorsM (loadPublic p2) fs2'+      return $ merge as+    merge = foldl merge4 ([],[],[],[])     merge4 (ps1,xs1,tsA1,tsB1) (ps2,xs2,tsA2,tsB2) = (ps1++ps2,xs1++xs2,tsA1++tsA2,tsB1++tsB2)

@@ -19,23 +19,15 @@ module Cli.ParseCompileOptions (   optionHelpText,   parseCompileOptions,-  tryFastModes,   validateCompileOptions, ) where  import Control.Monad (when) import Data.List (isSuffixOf)-import System.Directory-import System.Exit-import System.IO import Text.Regex.TDFA -- Not safe!-import qualified Data.Map as Map  import Base.CompileError-import Cli.CompileMetadata import Cli.CompileOptions-import Cli.ProcessMetadata-import Config.LoadConfig (compilerVersion,rootPath) import Types.TypeCategory (FunctionName(..)) import Types.TypeInstance (CategoryName(..)) @@ -85,42 +77,13 @@ defaultMainFunc :: String defaultMainFunc = "run" -tryFastModes :: [String] -> IO ()-tryFastModes ("--get-path":os) = do-  when (not $ null os) $ hPutStrLn stderr $ "Ignoring extra arguments: " ++ show os-  p <- rootPath >>= canonicalizePath-  hPutStrLn stdout p-  if null os-     then exitSuccess-     else exitFailure-tryFastModes ("--version":os) = do-  when (not $ null os) $ hPutStrLn stderr $ "Ignoring extra arguments: " ++ show os-  hPutStrLn stdout compilerVersion-  if null os-     then exitSuccess-     else exitFailure-tryFastModes ("--show-deps":ps) = do-  mapM_ showDeps ps-  exitSuccess where-    showDeps p = do-      p' <- canonicalizePath p-      m <- loadMetadata Map.empty p'-      hPutStrLn stdout $ show p'-      mapM_ showDep (cmObjectFiles m)-    showDep (CategoryObjectFile c ds _) = do-      mapM_ (\d -> hPutStrLn stdout $ "  " ++ show (ciCategory c) ++-                                      " -> " ++ show (ciCategory d) ++-                                      " " ++ show (ciPath d)) ds-    showDep _ = return ()-tryFastModes _ = return ()- parseCompileOptions :: CompileErrorM m => [String] -> m CompileOptions parseCompileOptions = parseAll emptyCompileOptions . zip ([1..] :: [Int]) where   parseAll co [] = return co   parseAll co os = do     (os',co') <- parseSingle co os     parseAll co' os'-  argError n o m = compileError $ "Argument " ++ show n ++ " (\"" ++ o ++ "\"): " ++ m+  argError n o m = compileErrorM $ "Argument " ++ show n ++ " (\"" ++ o ++ "\"): " ++ m   checkPathName n f o     | f =~ "^(/[^/]+|[^-/][^/]*)(/[^/]+)*$" = return ()     | null o    = argError n f "Invalid file path."@@ -246,16 +209,16 @@   | h /= HelpNotNeeded = return co    | (not $ null $ is ++ is2) && (isExecuteTests m) =-    compileError "Include paths (-i/-I) are not allowed in test mode (-t)."+    compileErrorM "Include paths (-i/-I) are not allowed in test mode (-t)."    | (not $ null $ is ++ is2) && (isCompileRecompile m) =-    compileError "Include paths (-i/-I) are not allowed in recompile mode (-r/-R)."+    compileErrorM "Include paths (-i/-I) are not allowed in recompile mode (-r/-R)."    | (length ds /= 0) && (isCompileFast m) =-    compileError "Input path is not allowed with fast mode (--fast)."+    compileErrorM "Input path is not allowed with fast mode (--fast)."   | null ds && (not $ isCompileFast m) =-    compileError "Please specify at least one input path."+    compileErrorM "Please specify at least one input path."   | (length ds > 1) && (not $ isCompileRecompile m) && (not $ isExecuteTests m) =-    compileError "Multiple input paths are only allowed with recompile mode (-r/-R) and test mode (-t)."+    compileErrorM "Multiple input paths are only allowed with recompile mode (-r/-R) and test mode (-t)."    | otherwise = return co

@@ -29,7 +29,7 @@ import Base.CompileError import Cli.CompileMetadata import Cli.CompileOptions-import Config.Programs (VersionHash(..))+import Cli.Programs (VersionHash(..)) import Parser.Common import Parser.Procedure () import Parser.Pragma (parseMacroName)@@ -48,7 +48,7 @@ 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)  = compileError (show e)+  unwrap (Left e)  = compileErrorM (show e)   unwrap (Right t) = return t  autoWriteConfig ::  (ConfigFormat a, CompileErrorM m) => a -> m String@@ -73,7 +73,7 @@ validateCategoryName :: CompileErrorM m => CategoryName -> m () validateCategoryName c =     when (not $ show c =~ "^[A-Z][A-Za-z0-9]*$") $-      compileError $ "Invalid category name: \"" ++ show c ++ "\""+      compileErrorM $ "Invalid category name: \"" ++ show c ++ "\""  parseCategoryName :: Parser CategoryName parseCategoryName = sourceParser :: Parser CategoryName@@ -81,7 +81,7 @@ validateFunctionName :: CompileErrorM m => FunctionName -> m () validateFunctionName f =     when (not $ show f =~ "^[a-z][A-Za-z0-9]*$") $-      compileError $ "Invalid function name: \"" ++ show f ++ "\""+      compileErrorM $ "Invalid function name: \"" ++ show f ++ "\""  parseFunctionName :: Parser FunctionName parseFunctionName = sourceParser :: Parser FunctionName@@ -89,7 +89,7 @@ validateHash :: CompileErrorM m => VersionHash -> m () validateHash h =     when (not $ show h =~ "^[A-Za-z0-9]+$") $-      compileError $ "Version hash must be a hex string: \"" ++ show h ++ "\""+      compileErrorM $ "Version hash must be a hex string: \"" ++ show h ++ "\""  parseHash :: Parser VersionHash parseHash = labeled "version hash" $ sepAfter (fmap VersionHash $ many1 hexDigit)@@ -97,7 +97,7 @@ maybeShowNamespace :: CompileErrorM m => String -> Namespace -> m [String] maybeShowNamespace l (StaticNamespace ns) = do   when (not $ ns =~ "^[A-Za-z][A-Za-z0-9_]*$") $-    compileError $ "Invalid category namespace: \"" ++ ns ++ "\""+    compileErrorM $ "Invalid category namespace: \"" ++ ns ++ "\""   return [l ++ " " ++ ns] maybeShowNamespace _ _ = return [] @@ -151,9 +151,9 @@   writeConfig m = do     validateHash (cmVersionHash m)     namespace <- maybeShowNamespace "namespace:" (cmNamespace m)-    _ <- collectAllOrErrorM $ map validateCategoryName (cmPublicCategories m)-    _ <- collectAllOrErrorM $ map validateCategoryName (cmPrivateCategories m)-    objects <- fmap concat $ collectAllOrErrorM $ map writeConfig $ cmObjectFiles m+    _ <- mapErrorsM validateCategoryName (cmPublicCategories m)+    _ <- mapErrorsM validateCategoryName (cmPrivateCategories m)+    objects <- fmap concat $ mapErrorsM writeConfig $ cmObjectFiles m     return $ [         "version_hash: " ++ (show $ cmVersionHash m),         "path: " ++ (show $ cmPath m)@@ -217,7 +217,7 @@       return (OtherObjectFile f)   writeConfig (CategoryObjectFile c rs fs) = do     category <- writeConfig c-    requires <- fmap concat $ collectAllOrErrorM $ map writeConfig rs+    requires <- fmap concat $ mapErrorsM writeConfig rs     return $ [         "category_object {"       ] ++ indents ("category: " `prependFirst` category) ++ [@@ -278,9 +278,9 @@       m   <- parseRequired "mode:"              readConfig       return (ModuleConfig p d em is is2 es ep m)   writeConfig m = do-    extra    <- fmap concat $ collectAllOrErrorM $ map writeConfig $ rmExtraFiles m+    extra    <- fmap concat $ mapErrorsM writeConfig $ rmExtraFiles m     mode <- writeConfig (rmMode m)-    when (not $ null $ rmExprMap m) $ compileError "Only empty expression maps are allowed when writing"+    when (not $ null $ rmExprMap m) $ compileErrorM "Only empty expression maps are allowed when writing"     return $ [         "root: " ++ show (rmRoot m),         "path: " ++ show (rmPath m),@@ -316,8 +316,8 @@       f <- parseQuoted       return (OtherSource f)   writeConfig (CategorySource f cs ds) = do-    _ <- collectAllOrErrorM $ map validateCategoryName cs-    _ <- collectAllOrErrorM $ map validateCategoryName ds+    _ <- mapErrorsM validateCategoryName cs+    _ <- mapErrorsM validateCategoryName ds     return $ [         "category_source {",         indent ("source: " ++ show f),@@ -370,7 +370,7 @@         "}"       ]   writeConfig CompileUnspecified = writeConfig (CompileIncremental [])-  writeConfig _ = compileError "Invalid compile mode"+  writeConfig _ = compileErrorM "Invalid compile mode"  parseExprMacro :: Parser (String,Expression SourcePos) parseExprMacro = do

@@ -0,0 +1,34 @@+{- -----------------------------------------------------------------------------+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]++{-# LANGUAGE Safe #-}++module Cli.Paths (+  PathIOHandler(..),+) where++import Control.Monad.IO.Class++import Base.CompileError+++class PathIOHandler r where+  resolveModule     :: (MonadIO m, CompileErrorM m) => r -> FilePath -> FilePath -> m FilePath+  isSystemModule    :: (MonadIO m, CompileErrorM m) => r -> FilePath -> FilePath -> m Bool+  resolveBaseModule :: (MonadIO m, CompileErrorM m) => r -> m FilePath+  isBaseModule      :: (MonadIO m, CompileErrorM m) => r -> FilePath -> m Bool

@@ -18,8 +18,6 @@  module Cli.ProcessMetadata (   MetadataMap,-  checkAllowedStale,-  checkMetadataFreshness,   createCachePath,   eraseCachedData,   findSourceFiles,@@ -37,15 +35,15 @@   getSourceFilesForDeps,   isPathConfigured,   isPathUpToDate,+  loadModuleMetadata,   loadPrivateDeps,   loadPublicDeps,+  loadRecompile,   loadTestingDeps,-  loadMetadata,   mapMetadata,   resolveCategoryDeps,   resolveObjectDeps,   sortCompiledFiles,-  tryLoadRecompile,   writeCachedFile,   writeMetadata,   writeRecompile,@@ -56,7 +54,6 @@ import Data.List (nub,isSuffixOf) import Data.Maybe (isJust) import System.Directory-import System.Exit (exitFailure) import System.FilePath import System.IO import Text.Parsec (SourcePos)@@ -67,10 +64,10 @@ import Cli.CompileMetadata import Cli.CompileOptions import Cli.ParseMetadata -- Not safe, due to Text.Regex.TDFA.-import Compilation.CompileInfo+import Cli.Programs (VersionHash(..))+import Base.CompileInfo import Compilation.ProcedureContext (ExprMap) import CompilerCxx.Category (CxxOutput(..))-import Config.Programs (VersionHash(..)) import Types.Procedure (Expression(Literal),ValueLiteral(..)) import Types.TypeCategory import Types.TypeInstance@@ -85,130 +82,66 @@ metadataFilename :: FilePath metadataFilename = "compile-metadata" -checkAllowedStale :: Bool -> ForceMode -> IO ()-checkAllowedStale fr f = do-  when (not fr && f < ForceAll) $ do-    hPutStrLn stderr $ "Some dependencies are out of date. " ++-                       "Recompile them or use -f to force."-    exitFailure- type MetadataMap = Map.Map FilePath CompileMetadata  mapMetadata :: [CompileMetadata] -> MetadataMap mapMetadata cs = Map.fromList $ zip (map cmPath cs) cs -loadMetadata :: MetadataMap -> FilePath -> IO CompileMetadata-loadMetadata ca p = do-  path <- canonicalizePath p-  case path `Map.lookup` ca of-       Just cm -> return cm-       Nothing -> do-         let f = p </> cachedDataPath </> metadataFilename-         isFile <- doesFileExist p-         when isFile $ do-           hPutStrLn stderr $ "Path \"" ++ p ++ "\" is not a directory."-           exitFailure-         isDir <- doesDirectoryExist p-         when (not isDir) $ do-           hPutStrLn stderr $ "Path \"" ++ p ++ "\" does not exist."-           exitFailure-         filePresent <- doesFileExist f-         when (not filePresent) $ do-           hPutStrLn stderr $ "Module \"" ++ p ++ "\" has not been compiled yet."-           exitFailure-         c <- readFile f-         let m = autoReadConfig f c-         if isCompileError m-            then do-              hPutStrLn stderr $ "Could not parse metadata from \"" ++ p ++ "\"; please recompile."-              hPutStrLn stderr $ show (getCompileError m)-              exitFailure-            else return (getCompileSuccess m)--checkMetadataFreshness :: FilePath -> CompileMetadata -> IO Bool-checkMetadataFreshness = checkModuleFreshness False--tryLoadMetadata :: FilePath -> IO (Maybe CompileMetadata)-tryLoadMetadata p = tryLoadData $ (p </> cachedDataPath </> metadataFilename)--tryLoadRecompile :: FilePath -> IO (Maybe ModuleConfig)-tryLoadRecompile p = tryLoadData $ (p </> moduleFilename)--tryLoadData :: ConfigFormat a => FilePath -> IO (Maybe a)-tryLoadData f = do-  filePresent <- doesFileExist f-  if not filePresent-    then return Nothing-    else do-      c <- readFile f-      let m = autoReadConfig f c-      if isCompileError m-         then do-           hPutStrLn stderr $ "Could not parse config file:"-           hPutStr stderr $ show (getCompileError m)-           return Nothing-         else return $ Just (getCompileSuccess m)+loadRecompile :: FilePath -> CompileInfoIO ModuleConfig+loadRecompile p = do+  let f = p </> moduleFilename+  isFile <- errorFromIO $ doesFileExist p+  when isFile $ compileErrorM $ "Path \"" ++ p ++ "\" is not a directory"+  isDir <- errorFromIO $ doesDirectoryExist p+  when (not isDir) $ compileErrorM $ "Path \"" ++ p ++ "\" does not exist"+  filePresent <- errorFromIO $ doesFileExist f+  when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been configured yet"+  c <- errorFromIO $ readFile f+  (autoReadConfig f c) `reviseErrorM`+    ("Could not parse metadata from \"" ++ p ++ "\"; please reconfigure") -isPathUpToDate :: VersionHash -> FilePath -> IO Bool-isPathUpToDate h p = do-  m <- tryLoadMetadata p-  case m of-       Nothing -> return False-       Just _ -> do-         (fr,_) <- loadDepsCommon True h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p]-         return fr+isPathUpToDate :: VersionHash -> ForceMode -> FilePath -> CompileInfoIO Bool+isPathUpToDate h f p = do+  m <- errorFromIO $ toCompileInfo $ loadDepsCommon f h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p]+  return $ not $ isCompileError m -isPathConfigured :: FilePath -> IO Bool+isPathConfigured :: FilePath -> CompileInfoIO Bool isPathConfigured p = do-  -- Just for error messages.-  _ <- tryLoadRecompile p-  doesFileExist (p </> moduleFilename)+  m <- errorFromIO $ toCompileInfo $ loadRecompile p+  return $ not $ isCompileError m -writeMetadata :: FilePath -> CompileMetadata -> IO ()+writeMetadata :: FilePath -> CompileMetadata -> CompileInfoIO () writeMetadata p m = do-  p' <- canonicalizePath p-  hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"."-  let m' = autoWriteConfig m-  if isCompileError m'-     then do-       hPutStrLn stderr $ "Could not serialize metadata."-       hPutStrLn stderr $ show (getCompileError m')-       exitFailure-     else writeCachedFile p' "" metadataFilename (getCompileSuccess m')+  p' <- errorFromIO $ canonicalizePath p+  errorFromIO $ hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"."+  m' <- autoWriteConfig m `reviseErrorM` ("In data for " ++ p)+  writeCachedFile p' "" metadataFilename m' -writeRecompile :: FilePath -> ModuleConfig -> IO ()+writeRecompile :: FilePath -> ModuleConfig -> CompileInfoIO () writeRecompile p m = do-  p' <- canonicalizePath p+  p' <- errorFromIO $ canonicalizePath p   let f = p </> moduleFilename-  hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"."-  let m' = autoWriteConfig m-  if isCompileError m'-     then do-       hPutStrLn stderr $ "Could not serialize module config."-       hPutStrLn stderr $ show (getCompileError m')-       exitFailure-     else do-       exists <- doesFileExist f-       when exists $ removeFile f-       writeFile f (getCompileSuccess m')+  errorFromIO $ hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"."+  m' <- autoWriteConfig m `reviseErrorM` ("In data for " ++ p)+  errorFromIO $ writeFile f m' -eraseCachedData :: FilePath -> IO ()+eraseCachedData :: FilePath -> CompileInfoIO () eraseCachedData p = do   let d  = p </> cachedDataPath-  dirExists <- doesDirectoryExist d-  when dirExists $ removeDirectoryRecursive d+  dirExists <- errorFromIO $ doesDirectoryExist d+  when dirExists $ errorFromIO $ removeDirectoryRecursive d -createCachePath :: FilePath -> IO ()+createCachePath :: FilePath -> CompileInfoIO () createCachePath p = do   let f = p </> cachedDataPath-  exists <- doesDirectoryExist f-  when (not exists) $ createDirectoryIfMissing False f+  exists <- errorFromIO $ doesDirectoryExist f+  when (not exists) $ errorFromIO $ createDirectoryIfMissing False f -writeCachedFile :: FilePath -> String -> FilePath -> String -> IO ()+writeCachedFile :: FilePath -> String -> FilePath -> String -> CompileInfoIO () writeCachedFile p ns f c = do   createCachePath p-  createDirectoryIfMissing False $ p </> cachedDataPath </> ns-  writeFile (getCachedPath p ns f) c+  errorFromIO $ createDirectoryIfMissing False $ p </> cachedDataPath </> ns+  errorFromIO $ writeFile (getCachedPath p ns f) c  getCachedPath :: FilePath -> String -> FilePath -> FilePath getCachedPath p ns f = fixPath $ p </> cachedDataPath </> ns </> f@@ -216,26 +149,22 @@ getCacheRelativePath :: FilePath -> FilePath getCacheRelativePath f = ".." </> f -findSourceFiles :: FilePath -> FilePath -> IO ([FilePath],[FilePath],[FilePath])+findSourceFiles :: FilePath -> FilePath -> CompileInfoIO ([FilePath],[FilePath],[FilePath]) findSourceFiles p0 p = do   let absolute = p0 </> p-  isFile <- doesFileExist absolute-  when isFile $ do-    hPutStrLn stderr $ "Path \"" ++ absolute ++ "\" is not a directory."-    exitFailure-  isDir <- doesDirectoryExist absolute-  when (not isDir) $ do-    hPutStrLn stderr $ "Path \"" ++ absolute ++ "\" does not exist."-    exitFailure-  ds <- getDirectoryContents absolute >>= return . map (p </>)+  isFile <- errorFromIO $ doesFileExist absolute+  when isFile $ compileErrorM $ "Path \"" ++ absolute ++ "\" is not a directory"+  isDir <- errorFromIO $ doesDirectoryExist absolute+  when (not isDir) $ compileErrorM $ "Path \"" ++ absolute ++ "\" does not exist"+  ds <- errorFromIO $ getDirectoryContents absolute >>= return . map (p </>)   let ps = filter (isSuffixOf ".0rp") ds   let xs = filter (isSuffixOf ".0rx") ds   let ts = filter (isSuffixOf ".0rt") ds   return (ps,xs,ts) -getExprMap :: FilePath -> ModuleConfig -> IO (ExprMap SourcePos)+getExprMap :: FilePath -> ModuleConfig -> CompileInfoIO (ExprMap SourcePos) getExprMap p m = do-  path <- canonicalizePath (p </> rmRoot m </> rmPath m)+  path <- errorFromIO $ canonicalizePath (p </> rmRoot m </> rmPath m)   let defaults = [("MODULE_PATH",Literal (StringLiteral [] path))]   return $ Map.fromList $ rmExprMap m ++ defaults @@ -258,42 +187,73 @@ getObjectFilesForDeps :: [CompileMetadata] -> [ObjectFile] getObjectFilesForDeps = concat . map cmObjectFiles -loadPublicDeps :: VersionHash -> MetadataMap -> [FilePath] -> IO (Bool,[CompileMetadata])-loadPublicDeps h ca = loadDepsCommon False h ca Set.empty cmPublicDeps+loadModuleMetadata :: VersionHash -> ForceMode -> MetadataMap -> FilePath ->+  CompileInfoIO CompileMetadata+loadModuleMetadata h f ca = fmap head . loadDepsCommon f h ca Set.empty (const []) . (:[]) -loadTestingDeps :: VersionHash -> MetadataMap -> CompileMetadata -> IO (Bool,[CompileMetadata])-loadTestingDeps h ca m = loadDepsCommon False h ca (Set.fromList [cmPath m]) cmPublicDeps (cmPublicDeps m ++ cmPrivateDeps m)+loadPublicDeps :: VersionHash -> ForceMode -> MetadataMap -> [FilePath] ->+  CompileInfoIO [CompileMetadata]+loadPublicDeps h f ca = loadDepsCommon f h ca Set.empty cmPublicDeps -loadPrivateDeps :: VersionHash -> MetadataMap -> [CompileMetadata] -> IO (Bool,[CompileMetadata])-loadPrivateDeps h ca ms = do-  (fr,new) <- loadDepsCommon False h ca pa (\m -> cmPublicDeps m ++ cmPrivateDeps m) paths-  return (fr,ms ++ new) where+loadTestingDeps :: VersionHash -> ForceMode -> MetadataMap -> CompileMetadata ->+  CompileInfoIO [CompileMetadata]+loadTestingDeps h f ca m = loadDepsCommon f h ca (Set.fromList [cmPath m]) cmPublicDeps (cmPublicDeps m ++ cmPrivateDeps m)++loadPrivateDeps :: VersionHash -> ForceMode -> MetadataMap -> [CompileMetadata] ->+  CompileInfoIO [CompileMetadata]+loadPrivateDeps h f ca ms = do+  new <- loadDepsCommon f h ca pa (\m -> cmPublicDeps m ++ cmPrivateDeps m) paths+  return $ ms ++ new where     paths = concat $ map (\m -> cmPublicDeps m ++ cmPrivateDeps m) ms     pa = Set.fromList $ map cmPath ms -loadDepsCommon :: Bool -> VersionHash -> MetadataMap -> Set.Set FilePath ->-  (CompileMetadata -> [FilePath]) -> [FilePath] -> IO (Bool,[CompileMetadata])-loadDepsCommon s h ca pa0 f ps = fmap snd $ fixedPaths >>= collect (pa0,(True,[])) where-  fixedPaths = sequence $ map canonicalizePath ps-  collect xa@(pa,(fr,xs)) (p:ps2)-    | p `Set.member` pa = collect xa ps2-    | otherwise = do-        (m,fr2) <-+loadDepsCommon :: ForceMode -> VersionHash -> MetadataMap -> Set.Set FilePath ->+  (CompileMetadata -> [FilePath]) -> [FilePath] -> CompileInfoIO [CompileMetadata]+loadDepsCommon f h ca pa0 getDeps ps = do+  (_,processed) <- fixedPaths >>= collect (pa0,[])+  mapErrorsM check processed where+    enforce = f /= ForceAll+    fixedPaths = mapM (errorFromIO . canonicalizePath) ps+    collect xa@(pa,xs) (p:ps2)+      | p `Set.member` pa = collect xa ps2+      | otherwise = do+          let continue m ds = collect (p `Set.insert` pa,xs ++ [m]) (ps2 ++ ds)           case p `Map.lookup` ca of-               Just m2 -> return (m2,True)+               Just m2 -> continue m2 []                Nothing -> do-                 when (not s) $ hPutStrLn stderr $ "Loading metadata for dependency \"" ++ p ++ "\"."+                 errorFromIO $ hPutStrLn stderr $ "Loading metadata for dependency \"" ++ p ++ "\"."                  m2 <- loadMetadata ca p-                 fresh <- checkModuleFreshness s p m2-                 when (not s && not fresh) $-                   hPutStrLn stderr $ "Module \"" ++ p ++ "\" is out of date and should be recompiled."-                 let sameVersion = checkModuleVersionHash h m2-                 when (not s && not sameVersion) $-                   hPutStrLn stderr $ "Module \"" ++ p ++ "\" was compiled with a different compiler setup."-                 return (m2,sameVersion && fresh)-        collect (p `Set.insert` pa,(fr2 && fr,xs ++ [m])) (ps2 ++ f m)-  collect xa _ = return xa+                 let ds = getDeps m2+                 continue m2 ds+    collect xa _ = return xa+    check m+      | cmPath m `Map.member` ca = return m+      | otherwise = do+          fresh <- checkModuleFreshness (cmPath m) m+          let sameVersion = checkModuleVersionHash h m+          when (enforce && not fresh) $+            compileErrorM $ "Module \"" ++ cmPath m ++ "\" is out of date and should be recompiled"+          when (enforce && not sameVersion) $+            compileErrorM $ "Module \"" ++ cmPath m ++ "\" was compiled with a different compiler setup"+          return m +loadMetadata :: MetadataMap -> FilePath -> CompileInfoIO CompileMetadata+loadMetadata ca p = do+  path <- errorFromIO $ canonicalizePath p+  case path `Map.lookup` ca of+       Just cm -> return cm+       Nothing -> do+         let f = p </> cachedDataPath </> metadataFilename+         isFile <- errorFromIO $ doesFileExist p+         when isFile $ compileErrorM $ "Path \"" ++ p ++ "\" is not a directory"+         isDir <- errorFromIO $ doesDirectoryExist p+         when (not isDir) $ compileErrorM $ "Path \"" ++ p ++ "\" does not exist"+         filePresent <- errorFromIO $ doesFileExist f+         when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been compiled yet"+         c <- errorFromIO $ readFile f+         (autoReadConfig f c) `reviseErrorM`+            ("Could not parse metadata from \"" ++ p ++ "\"; please recompile")+ fixPath :: FilePath -> FilePath fixPath = foldl (</>) "" . process [] . map dropSlash . splitPath where   dropSlash "/" = "/"@@ -324,46 +284,46 @@ checkModuleVersionHash :: VersionHash -> CompileMetadata -> Bool checkModuleVersionHash h m = cmVersionHash m == h -checkModuleFreshness :: Bool -> FilePath -> CompileMetadata -> IO Bool-checkModuleFreshness s p (CompileMetadata _ p2 _ is is2 _ _ _ ps xs ts hxx cxx bs _ _) = do-  time <- getModificationTime $ getCachedPath p "" metadataFilename+checkModuleFreshness :: FilePath -> CompileMetadata -> CompileInfoIO Bool+checkModuleFreshness p (CompileMetadata _ p2 _ is is2 _ _ _ ps xs ts hxx cxx bs _ _) = do+  time <- errorFromIO $ getModificationTime $ getCachedPath p "" metadataFilename   (ps2,xs2,ts2) <- findSourceFiles p ""   let e1 = checkMissing ps ps2   let e2 = checkMissing xs xs2   let e3 = checkMissing ts ts2   rm <- checkInput time (p </> moduleFilename)-  f1 <- sequence $ map (\p3 -> checkInput time $ getCachedPath p3 "" metadataFilename) $ is ++ is2-  f2 <- sequence $ map (checkInput time . (p2 </>)) $ ps ++ xs-  f3 <- sequence $ map (checkInput time . getCachedPath p2 "") $ hxx ++ cxx-  f4 <- sequence $ map checkOutput bs+  f1 <- mapErrorsM (\p3 -> checkInput time $ getCachedPath p3 "" metadataFilename) $ is ++ is2+  f2 <- mapErrorsM (checkInput time . (p2 </>)) $ ps ++ xs+  f3 <- mapErrorsM (checkInput time . getCachedPath p2 "") $ hxx ++ cxx+  f4 <- mapErrorsM checkOutput bs   let fresh = not $ any id $ [rm,e1,e2,e3] ++ f1 ++ f2 ++ f3 ++ f4   return fresh where     checkInput time f = do       exists <- doesFileOrDirExist f       if not exists          then do-           when (not s) $ hPutStrLn stderr $ "Required path \"" ++ f ++ "\" is missing."+           compileWarningM $ "Required path \"" ++ f ++ "\" is missing"            return True          else do-           time2 <- getModificationTime f+           time2 <- errorFromIO $ getModificationTime f            if time2 > time               then do-                when (not s) $ hPutStrLn stderr $ "Required path \"" ++ f ++ "\" is newer than cached data."+                compileWarningM $ "Required path \"" ++ f ++ "\" is newer than cached data"                 return True               else return False     checkOutput f = do-      exists <- doesFileExist f+      exists <- errorFromIO $ doesFileExist f       if not exists          then do-           when (not s) $ hPutStrLn stderr $ "Output file \"" ++ f ++ "\" is missing."+           compileWarningM $ "Output file \"" ++ f ++ "\" is missing"            return True          else return False     checkMissing s0 s1 = not $ null $ (Set.fromList s1) `Set.difference` (Set.fromList s0)     doesFileOrDirExist f2 = do-      existF <- doesFileExist f2+      existF <- errorFromIO $ doesFileExist f2       if existF         then return True-        else doesDirectoryExist f2+        else errorFromIO $ doesDirectoryExist f2  getObjectFileResolver :: [ObjectFile] -> [Namespace] -> [CategoryName] -> [FilePath] getObjectFileResolver os ns ds = resolved ++ nonCategories where

@@ -0,0 +1,75 @@+{- -----------------------------------------------------------------------------+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]++{-# LANGUAGE Safe #-}++module Cli.Programs (+  CompilerBackend(..),+  CxxCommand(..),+  TestCommand(..),+  TestCommandResult(..),+  VersionHash(..),+) where++import Control.Monad.IO.Class++import Base.CompileError+++class CompilerBackend b where+  runCxxCommand   :: (MonadIO m, CompileErrorM m) => b -> CxxCommand -> m String+  runTestCommand  :: (MonadIO m, CompileErrorM m) => b -> TestCommand -> m TestCommandResult+  getCompilerHash :: b -> VersionHash++newtype VersionHash = VersionHash String deriving (Eq)++instance Show VersionHash where+  show (VersionHash h) = h++data CxxCommand =+  CompileToObject {+    ctoSource :: String,+    ctoPath :: String,+    ctoNamespaceMacro :: String,+    ctoNamespace :: String,+    ctoPaths :: [String],+    ctoExtra :: Bool+  } |+  CompileToBinary {+    ctbMain :: String,+    ctbSources :: [String],+    ctbOutput :: String,+    ctbPaths :: [String],+    ctbLinkFlags :: [String]+  }+  deriving (Show)++data TestCommand =+  TestCommand {+    tcBinary :: String,+    tcPath :: String+  }+  deriving (Show)++data TestCommandResult =+  TestCommandResult {+    tcrSuccess :: Bool,+    tcrOutput :: [String],+    tcrError :: [String]+  }+  deriving (Show)

@@ -23,10 +23,8 @@ import Control.Monad (foldM,when) import Data.List (intercalate) import System.Directory-import System.Exit import System.FilePath import System.Posix.Temp (mkdtemp)-import System.IO import qualified Data.Map as Map import qualified Data.Set as Set @@ -35,67 +33,51 @@ import Cli.CompileMetadata import Cli.CompileOptions import Cli.Compiler+import Cli.Paths import Cli.ProcessMetadata-import Compilation.CompileInfo-import Config.LoadConfig-import Config.Paths-import Config.Programs+import Cli.Programs+import Base.CompileInfo  -runCompiler :: CompileOptions -> IO ()-runCompiler (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp) f) = do-  (backend,resolver) <- loadConfig+runCompiler :: (PathIOHandler r, CompilerBackend b) => r -> b -> CompileOptions -> CompileInfoIO ()+runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp) f) = do   base <- resolveBaseModule resolver-  ts <- fmap snd $ foldM (preloadTests backend base) (Map.empty,[]) ds+  ts <- fmap snd $ foldM (preloadTests base) (Map.empty,[]) ds   checkTestFilters ts-  allResults <- fmap concat $ sequence $ map (runModuleTests backend base tp) ts+  allResults <- fmap concat $ mapErrorsM (runModuleTests resolver backend base tp) ts   let passed = sum $ map (fst . fst) allResults   let failed = sum $ map (snd . fst) allResults-  processResults passed failed (mergeAllM $ map snd allResults) where-    preloadTests b base (ca,ms) d = do-      m <- loadMetadata ca (p </> d)+  processResults passed failed (mapErrorsM_ snd allResults) where+    compilerHash = getCompilerHash backend+    preloadTests base (ca,ms) d = do+      m <- loadModuleMetadata compilerHash f ca (p </> d)       let ca2 = ca `Map.union` mapMetadata [m]-      fr <- checkMetadataFreshness (p </> d) m-      checkAllowedStale fr f-      rm <- tryLoadRecompile (p </> d)-      rm' <- case rm of-                  Just rm2 -> return rm2-                  Nothing -> do-                    hPutStr stderr $ "Module config for " ++ d ++ " is missing."-                    exitFailure-      (fr0,deps0) <- loadPublicDeps (getCompilerHash b) ca2 [base]+      rm <- loadRecompile (p </> d)+      deps0 <- loadPublicDeps compilerHash f ca2 [base]       let ca3 = ca2 `Map.union` mapMetadata deps0-      checkAllowedStale fr0 f-      (fr1,deps1) <- loadTestingDeps (getCompilerHash b) ca3 m+      deps1 <- loadTestingDeps compilerHash f ca3 m       let ca4 = ca3 `Map.union` mapMetadata deps1-      checkAllowedStale fr1 f-      (fr2,deps2) <- loadPrivateDeps (getCompilerHash b) ca4 (deps0++[m]++deps1)+      deps2 <- loadPrivateDeps compilerHash f ca4 (deps0++[m]++deps1)       let ca5 = ca4 `Map.union` mapMetadata deps2-      checkAllowedStale fr2 f-      em <- getExprMap (p </> d) rm'+      em <- getExprMap (p </> d) rm       return (ca5,ms ++ [LoadedTests p d m em (deps0++[m]++deps1) deps2])     checkTestFilters ts = do       let possibleTests = Set.fromList $ concat $ map (cmTestFiles . ltMetadata) ts       case Set.toList $ (Set.fromList tp) `Set.difference` possibleTests of           [] -> return ()-          fs -> do-            hPutStr stderr $ "Some test files do not occur in the selected modules: " ++-                             intercalate ", " (map show fs) ++ "\n"-            exitFailure+          fs -> compileErrorM $ "Some test files do not occur in the selected modules: " +++                                intercalate ", " (map show fs) ++ "\n"     processResults passed failed rs-      | isCompileError rs = do-          hPutStr stderr $ "\nTest errors:\n" ++ (show $ getCompileError rs)-          hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)"-          hPutStrLn stderr $ "Zeolite tests failed."-          exitFailure-      | otherwise = do-          hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)"-          hPutStrLn stderr $ "Zeolite tests passed."+      | isCompileError rs =+        (fromCompileInfo rs) `reviseErrorM`+          ("\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)")+      | otherwise =+        compileWarningM $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)" -runCompiler (CompileOptions _ is is2 _ _ _ p (CompileFast c fn f2) f) = do-  dir <- mkdtemp "/tmp/zfast_"-  absolute <- canonicalizePath p-  f2' <- canonicalizePath (p </> f2)+runCompiler resolver backend (CompileOptions _ is is2 _ _ _ p (CompileFast c fn f2) f) = do+  dir <- errorFromIO $ mkdtemp "/tmp/zfast_"+  absolute <- errorFromIO $ canonicalizePath p+  f2' <- errorFromIO $ canonicalizePath (p </> f2)   let rm = ModuleConfig {     rmRoot = "",     rmPath = ".",@@ -121,95 +103,81 @@     msMode = (CompileBinary c fn (absolute </> show c) []),     msForce = f   }-  compileModule spec-  removeDirectoryRecursive dir+  compileModule resolver backend spec `reviseErrorM` ("In compilation of \"" ++ f2' ++ "\"")+  errorFromIO $ removeDirectoryRecursive dir -runCompiler (CompileOptions h _ _ ds _ _ p CompileRecompileRecursive f) = do-  (_,resolver) <- loadConfig+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       if isSystem          then do-           hPutStrLn stderr $ "Skipping system module " ++ d0 ++ "."-           exitFailure+           compileWarningM $ "Skipping system module " ++ d0 ++ "."+           return da          else do-           d <- canonicalizePath (p </> d0)-           rm <- tryLoadRecompile d-           case rm of-                Nothing -> do-                  hPutStrLn stderr $ "Path " ++ d ++ " does not have a valid configuration."-                  exitFailure-                Just m ->-                  if rmPath m `Set.member` da-                     then return da-                     else do-                       let ds3 = map (\d2 -> d </> d2) (rmPublicDeps m ++ rmPrivateDeps m)-                       da' <- foldM (recursive r) (rmPath m `Set.insert` da) ds3-                       runCompiler (CompileOptions h [] [] [d] [] [] p CompileRecompile f)-                       return da'+           d <- errorFromIO $ canonicalizePath (p </> d0)+           rm <- loadRecompile d+           if rmPath rm `Set.member` da+               then return da+               else do+                 let ds3 = map (\d2 -> d </> d2) (rmPublicDeps rm ++ rmPrivateDeps rm)+                 da' <- foldM (recursive r) (rmPath rm `Set.insert` da) ds3+                 runCompiler resolver backend (CompileOptions h [] [] [d] [] [] p CompileRecompile f)+                 return da' -runCompiler (CompileOptions _ _ _ ds _ _ p CompileRecompile f) = do-  (backend,_) <- loadConfig-  fmap mergeAll $ sequence $ map (recompileSingle $ getCompilerHash backend) ds where-    recompileSingle h2 d0 = do-      let d = p </> d0-      rm <- tryLoadRecompile d-      upToDate <- isPathUpToDate h2 d-      maybeCompile rm upToDate where-        maybeCompile Nothing _ = do-          hPutStrLn stderr $ "Path " ++ d0 ++ " does not have a valid configuration."-          exitFailure-        maybeCompile (Just rm') upToDate-          | f < ForceAll && upToDate = hPutStrLn stderr $ "Path " ++ d0 ++ " is up to date."-          | otherwise = do-              let (ModuleConfig p2 d _ is is2 es ep m) = rm'-              -- In case the module is manually configured with a p such as "..",-              -- since the absolute path might not be known ahead of time.-              absolute <- canonicalizePath (p </> d0)-              let fixed = fixPath (absolute </> p2)-              (ps,xs,ts) <- findSourceFiles fixed d-              em <- getExprMap (p </> d0) rm'-              let spec = ModuleSpec {-                msRoot = fixed,-                msPath = d,-                msExprMap = em,-                msPublicDeps = is,-                msPrivateDeps = is2,-                msPublicFiles = ps,-                msPrivateFiles = xs,-                msTestFiles = ts,-                msExtraFiles = es,-                msExtraPaths = ep,-                msMode = m,-                msForce = f-              }-              compileModule spec+runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p CompileRecompile f) = do+  mergeAllM $ map recompileSingle ds where+    compilerHash = getCompilerHash backend+    recompileSingle d0 = do+      d <- errorFromIO $ canonicalizePath (p </> d0)+      upToDate <- isPathUpToDate compilerHash f d+      if f < ForceAll && upToDate+         then compileWarningM $ "Path " ++ d0 ++ " is up to date"+         else do+           rm@(ModuleConfig p2 d2 _ is is2 es ep m) <- loadRecompile d+           -- In case the module is manually configured with a p such as "..",+           -- since the absolute path might not be known ahead of time.+           absolute <- errorFromIO $ canonicalizePath (p </> d0)+           let fixed = fixPath (absolute </> p2)+           (ps,xs,ts) <- findSourceFiles fixed d2+           em <- getExprMap (p </> d0) rm+           let spec = ModuleSpec {+             msRoot = fixed,+             msPath = d2,+             msExprMap = em,+             msPublicDeps = is,+             msPrivateDeps = is2,+             msPublicFiles = ps,+             msPrivateFiles = xs,+             msTestFiles = ts,+             msExtraFiles = es,+             msExtraPaths = ep,+             msMode = m,+             msForce = f+           }+           compileModule resolver backend spec `reviseErrorM` ("In compilation of module \"" ++ d ++ "\"") -runCompiler (CompileOptions _ is is2 ds _ _ p CreateTemplates f) = mapM_ compileSingle ds where+runCompiler resolver backend (CompileOptions _ is is2 ds _ _ p CreateTemplates f) = mapM_ compileSingle ds where+  compilerHash = getCompilerHash backend   compileSingle d = do-    (backend,resolver) <- loadConfig+    d' <- errorFromIO $ canonicalizePath (p </> d)     base <- resolveBaseModule resolver-    as  <- fmap fixPaths $ sequence $ map (resolveModule resolver (p </> d)) is-    as2 <- fmap fixPaths $ sequence $ map (resolveModule resolver (p </> d)) is2-    (fr1,deps1) <- loadPublicDeps (getCompilerHash backend) Map.empty (base:as)-    checkAllowedStale fr1 f-    (fr2,deps2) <- loadPublicDeps (getCompilerHash backend) (mapMetadata deps1) as2-    checkAllowedStale fr2 f-    path <- canonicalizePath p-    createModuleTemplates path d deps1 deps2+    as  <- fmap fixPaths $ mapErrorsM (resolveModule resolver d') is+    as2 <- fmap fixPaths $ mapErrorsM (resolveModule resolver d') is2+    deps1 <- loadPublicDeps compilerHash f Map.empty (base:as)+    deps2 <- loadPublicDeps compilerHash f (mapMetadata deps1) as2+    path <- errorFromIO $ canonicalizePath p+    createModuleTemplates path d deps1 deps2 `reviseErrorM` ("In module \"" ++ d' ++ "\"") -runCompiler (CompileOptions h is is2 ds es ep p m f) = mapM_ compileSingle ds where+runCompiler resolver backend (CompileOptions h is is2 ds es ep p m f) = mapM_ compileSingle ds where   compileSingle d = do-    (_,resolver) <- loadConfig-    as  <- fmap fixPaths $ sequence $ map (resolveModule resolver (p </> d)) is-    as2 <- fmap fixPaths $ sequence $ map (resolveModule resolver (p </> d)) is2+    as  <- fmap fixPaths $ mapErrorsM (resolveModule resolver (p </> d)) is+    as2 <- fmap fixPaths $ mapErrorsM (resolveModule resolver (p </> d)) is2     isConfigured <- isPathConfigured d     when (isConfigured && f == DoNotForce) $ do-      hPutStrLn stderr $ "Module " ++ d ++ " has an existing configuration. " ++-                        "Recompile with -r or use -f to overwrite the config."-      exitFailure-    absolute <- canonicalizePath p+      compileErrorM $ "Module " ++ d ++ " has an existing configuration. " +++                      "Recompile with -r or use -f to overwrite the config."+    absolute <- errorFromIO $ canonicalizePath p     let rm = ModuleConfig {       rmRoot = absolute,       rmPath = d,@@ -221,4 +189,4 @@       rmMode = m     }     writeRecompile (p </> d) rm-    runCompiler (CompileOptions h [] [] [d] [] [] p CompileRecompile DoNotForce)+    runCompiler resolver backend (CompileOptions h [] [] [d] [] [] p CompileRecompile DoNotForce)

@@ -34,10 +34,10 @@ import Base.Mergeable import Cli.CompileMetadata import Cli.ProcessMetadata-import Compilation.CompileInfo+import Cli.Programs+import Base.CompileInfo import CompilerCxx.Category import CompilerCxx.Naming-import Config.Programs import Parser.SourceFile import Types.IntegrationTest import Types.TypeCategory@@ -45,14 +45,14 @@  runSingleTest :: CompilerBackend b => b -> LanguageModule SourcePos ->   FilePath -> [FilePath] -> [CompileMetadata] -> (String,String) ->-  IO ((Int,Int),CompileInfo ())+  CompileInfoIO ((Int,Int),CompileInfo ()) runSingleTest b cm p paths deps (f,s) = do-  hPutStrLn stderr $ "\nExecuting tests from " ++ f+  errorFromIO $ hPutStrLn stderr $ "\nExecuting tests from " ++ f   allResults <- checkAndRun (parseTestSource (f,s))-  return $ second (flip reviseError $ "\nIn test file " ++ f) allResults where+  return $ second (flip reviseErrorM $ "\nIn test file " ++ f) allResults where     checkAndRun ts       | isCompileError ts = do-        hPutStrLn stderr $ "Failed to parse tests in " ++ f+        errorFromIO $ hPutStrLn stderr $ "Failed to parse tests in " ++ f         return ((0,1),ts >> return ())       | otherwise = do           let (_,ts') = getCompileSuccess ts@@ -61,14 +61,14 @@           let failed = length $ filter isCompileError allResults           return ((passed,failed),mergeAllM allResults)     runSingle t = do-      let name = ithTestName $ itHeader t+      let name = "\"" ++ ithTestName (itHeader t) ++ "\" (from " ++ f ++ ")"       let context = formatFullContextBrace (ithContext $ itHeader t)-      hPutStrLn stderr $ "\n*** Executing test \"" ++ name ++ "\" ***"-      outcome <- fmap (flip reviseError ("\nIn test \"" ++ name ++ "\"" ++ context)) $+      errorFromIO $ hPutStrLn stderr $ "\n*** Executing test " ++ name ++ " ***"+      outcome <- fmap (flip reviseErrorM ("\nIn test \"" ++ name ++ "\"" ++ context)) $                    run (ithResult $ itHeader t) (itCategory t) (itDefinition t)       if isCompileError outcome-         then hPutStrLn stderr $ "*** Test \"" ++ name ++ "\" failed ***"-         else hPutStrLn stderr $ "*** Test \"" ++ name ++ "\" passed ***"+         then errorFromIO $ hPutStrLn stderr $ "*** Test " ++ name ++ " failed ***"+         else errorFromIO $ hPutStrLn stderr $ "*** Test " ++ name ++ " passed ***"       return outcome      run (ExpectCompileError _ rs es) cs ds = do@@ -88,21 +88,21 @@       let ce = checkExcluded es comp err out       let compError = if null comp                          then return ()-                         else (mergeAllM $ map compileError comp) `reviseError` "\nOutput from compiler:"+                         else (mergeAllM $ map compileErrorM comp) `reviseErrorM` "\nOutput from compiler:"       let errError = if null err                         then return ()-                        else (mergeAllM $ map compileError err) `reviseError` "\nOutput to stderr from test:"+                        else (mergeAllM $ map compileErrorM err) `reviseErrorM` "\nOutput to stderr from test:"       let outError = if null out                         then return ()-                        else (mergeAllM $ map compileError out) `reviseError` "\nOutput to stdout from test:"+                        else (mergeAllM $ map compileErrorM out) `reviseErrorM` "\nOutput to stdout from test:"       if isCompileError cr || isCompileError ce          then mergeAllM [cr,ce,compError,errError,outError]          else mergeAllM [cr,ce] -    execute s2 e rs es cs ds = do+    execute s2 e rs es cs ds = toCompileInfo $ do       let result = compileAll (Just e) cs ds       if isCompileError result-         then return $ result >> return ()+         then fromCompileInfo result >> return ()          else do            let warnings = getCompileWarnings result            let (xx,main) = getCompileSuccess result@@ -110,12 +110,12 @@            let command = TestCommand binaryName (takeDirectory binaryName)            (TestCommandResult s2' out err) <- runTestCommand b command            case (s2,s2') of-                (True,False) -> return $ mergeAllM $ map compileError $ warnings ++ err ++ out-                (False,True) -> return $ compileError "Expected runtime failure"+                (True,False) -> mergeAllM $ map compileErrorM $ warnings ++ err ++ out+                (False,True) -> compileErrorM "Expected runtime failure"                 _ -> do                   let result2 = checkContent rs es warnings err out-                  when (not $ isCompileError result) $ removeDirectoryRecursive dir-                  return result2+                  when (not $ isCompileError result) $ errorFromIO $ removeDirectoryRecursive dir+                  fromCompileInfo result2      compileAll e cs ds = do       let ns1 = StaticNamespace $ privateNamespace s@@ -129,7 +129,7 @@       (_,xx) <- compileLanguageModule cm [xs]       main <- case e of                    Just e2 -> compileTestMain cm xs e2-                   Nothing -> compileError "Expected compiler error"+                   Nothing -> compileErrorM "Expected compiler error"       return (xx,main)      checkRequired rs comp err out = mergeAllM $ map (checkSubsetForRegex True  comp err out) rs@@ -145,17 +145,17 @@     checkForRegex :: Bool -> [String] -> String -> String -> CompileInfo ()     checkForRegex expected ms r n = do       let found = any (=~ r) ms-      when (found && not expected) $ compileError $ "Pattern \"" ++ r ++ "\" present in " ++ n-      when (not found && expected) $ compileError $ "Pattern \"" ++ r ++ "\" missing from " ++ n+      when (found && not expected) $ compileErrorM $ "Pattern \"" ++ r ++ "\" present in " ++ n+      when (not found && expected) $ compileErrorM $ "Pattern \"" ++ r ++ "\" missing from " ++ n     createBinary (CxxOutput _ f2 _ ns req content) xx = do-      dir <- mkdtemp "/tmp/ztest_"-      hPutStrLn stderr $ "Writing temporary files to " ++ dir-      sources <- sequence $ map (writeSingleFile dir) xx+      dir <- errorFromIO $ mkdtemp "/tmp/ztest_"+      errorFromIO $ hPutStrLn stderr $ "Writing temporary files to " ++ dir+      sources <- mapErrorsM (writeSingleFile dir) xx       -- TODO: Cache CompileMetadata here for debugging failures.       let sources' = resolveObjectDeps deps p dir sources       let main   = dir </> f2       let binary = dir </> "testcase"-      writeFile main $ concat $ map (++ "\n") content+      errorFromIO $ writeFile main $ concat $ map (++ "\n") content       let flags = getLinkFlagsForDeps deps       let paths' = nub $ map fixPath (dir:paths)       let os  = getObjectFilesForDeps deps@@ -165,7 +165,7 @@       file <- runCxxCommand b command       return (dir,file)     writeSingleFile d ca@(CxxOutput _ f2 _ _ _ content) = do-      writeFile (d </> f2) $ concat $ map (++ "\n") content+      errorFromIO $ writeFile (d </> f2) $ concat $ map (++ "\n") content       if isSuffixOf ".cpp" f2          then return ([d </> f2],ca)          else return ([],ca)

@@ -1,151 +0,0 @@-{- ------------------------------------------------------------------------------Copyright 2019-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]--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}--module Compilation.CompileInfo (-  CompileInfo,-  CompileMessage,-  getCompileError,-  getCompileSuccess,-  getCompileWarnings,-) where--import Control.Applicative-import Data.List (intercalate)-import Data.Foldable-import Data.Functor-import Prelude hiding (concat,foldr)--#if MIN_VERSION_base(4,8,0)-#else-import Data.Foldable-#endif--#if MIN_VERSION_base(4,13,0)-import Control.Monad.Fail ()-#elif MIN_VERSION_base(4,9,0)-import Control.Monad.Fail-#endif--import Base.CompileError-import Base.Mergeable---data CompileMessage =-  CompileMessage {-    cmMessage :: String,-    cmNested :: [CompileMessage]-  }--instance Show CompileMessage where-  show = format "" where-    format indent (CompileMessage [] ms) =-      concat (map (format indent) ms)-    format indent (CompileMessage m ms) =-      (doIndent indent m) ++ "\n" ++ concat (map (format $ indent ++ "  ") ms)-    doIndent indent s = intercalate "\n" $ map (indent ++) $ lines s--data CompileInfo a =-  CompileFail {-    cfWarnings :: [String],-    cfErrors :: CompileMessage-  } |-  CompileSuccess {-    csWarnings :: [String],-    csData :: a-  }--getCompileError :: CompileInfo a -> CompileMessage-getCompileError   = cfErrors--getCompileSuccess :: CompileInfo a -> a-getCompileSuccess = csData--getCompileWarnings :: CompileInfo a -> [String]-getCompileWarnings (CompileFail w _)    = w-getCompileWarnings (CompileSuccess w _) = w---instance Functor CompileInfo where-  fmap _ (CompileFail w e)    = CompileFail w e -- Not the same a.-  fmap f (CompileSuccess w d) = CompileSuccess w (f d)--instance Applicative CompileInfo where-  pure = CompileSuccess []-  (CompileFail w e) <*> _ = CompileFail w e -- Not the same a.-  i <*> (CompileFail w e) = CompileFail (getCompileWarnings i ++ w) e -- Not the same a.-  (CompileSuccess w1 f) <*> (CompileSuccess w2 d) = CompileSuccess (w1 ++ w2) (f d)--instance Monad CompileInfo where-  (CompileFail w e)    >>= _ = CompileFail w e -- Not the same a.-  (CompileSuccess w d) >>= f = prependWarning w $ f d-  return = pure--prependWarning :: [String] -> CompileInfo a -> CompileInfo a-prependWarning w (CompileSuccess w2 d) = CompileSuccess (w ++ w2) d-prependWarning w (CompileFail w2 e)    = CompileFail (w ++ w2) e--instance CompileErrorM CompileInfo where-  compileErrorM = CompileFail [] . flip CompileMessage []-  isCompileErrorM (CompileFail _ _) = True-  isCompileErrorM _                 = False-  collectAllOrErrorM = result . splitErrorsAndData where-    result ([],xs,ws) = CompileSuccess ws xs-    result (es,_,ws) = CompileFail ws $ CompileMessage "" es-  collectOneOrErrorM = result . splitErrorsAndData where-    result (_,x:_,ws) = CompileSuccess ws x-    result ([],_,ws)  = CompileFail ws $ CompileMessage "" []-    result (es,_,ws)  = CompileFail ws $ CompileMessage "" es-  reviseErrorM x@(CompileSuccess _ _) _ = x-  reviseErrorM (CompileFail w (CompileMessage [] ms)) s = CompileFail w $ CompileMessage s ms-  reviseErrorM (CompileFail w e) s = CompileFail w $ CompileMessage s [e]-  compileWarningM w = CompileSuccess [w] ()--instance MergeableM CompileInfo where-  mergeAnyM = result . splitErrorsAndData where-    result (_,xs@(_:_),ws) = CompileSuccess ws $ mergeAny xs-    result ([],_,ws)       = CompileFail ws $ CompileMessage "" []-    result (es,_,ws)       = CompileFail ws $ CompileMessage "" es-  mergeAllM = result . splitErrorsAndData where-    result ([],xs,ws) = CompileSuccess ws $ mergeAll xs-    result (es,_,ws)  = CompileFail ws $ CompileMessage "" es-  (CompileSuccess w1 x) `mergeNestedM` (CompileSuccess w2 y) = CompileSuccess (w1 ++ w2) $ x `mergeNested` y-  (CompileFail w1 e)    `mergeNestedM` (CompileSuccess w2 _) = CompileFail (w1 ++ w2) e-  (CompileSuccess w1 _) `mergeNestedM` (CompileFail w2 e)    = CompileFail (w1 ++ w2) e-  (CompileFail w1 e1)   `mergeNestedM` (CompileFail w2 e2)   = CompileFail (w1 ++ w2) $ e1 `nestMessages` e2--#if MIN_VERSION_base(4,9,0)-instance MonadFail CompileInfo where-  fail = compileErrorM-#endif--nestMessages :: CompileMessage -> CompileMessage -> CompileMessage-nestMessages (CompileMessage m1 ms1) (CompileMessage [] ms2) =-  CompileMessage m1 (ms1 ++ ms2)-nestMessages (CompileMessage [] ms1) (CompileMessage m2 ms2) =-  CompileMessage m2 (ms1 ++ ms2)-nestMessages (CompileMessage m1 ms1) ma@(CompileMessage _ _) =-  CompileMessage m1 (ms1 ++ [ma])--splitErrorsAndData :: Foldable f => f (CompileInfo a) -> ([CompileMessage],[a],[String])-splitErrorsAndData = foldr partition ([],[],[]) where-  partition (CompileFail w e)    (es,ds,ws) = (e:es,ds,w++ws)-  partition (CompileSuccess w d) (es,ds,ws) = (es,d:ds,w++ws)

@@ -149,7 +149,7 @@   show (VariableValue c _ t _) = show t ++ formatFullContextBrace c  reviseErrorStateT :: (CompileErrorM m) => CompilerState a m b -> String -> CompilerState a m b-reviseErrorStateT x s = mapStateT (`reviseError` s) x+reviseErrorStateT x s = mapStateT (`reviseErrorM` s) x  csCurrentScope :: CompilerContext c m s a => CompilerState a m SymbolScope csCurrentScope = fmap ccCurrentScope get >>= lift

@@ -90,7 +90,7 @@   ccGetParamScope ctx p = do     case p `Map.lookup` pcParamScopes ctx of             (Just s) -> return s-            _ -> compileError $ "Param " ++ show p ++ " does not exist"+            _ -> compileErrorM $ "Param " ++ show p ++ " does not exist"   ccRequiresTypes ctx ts = return $     ProcedureContext {       pcScope = pcScope ctx,@@ -128,30 +128,30 @@         checkFunction $ n `Map.lookup` fa     checkFunction (Just f) = do       when (pcDisallowInit ctx && t == pcType ctx && pcScope ctx == CategoryScope) $-        compileError $ "Function " ++ show n +++        compileErrorM $ "Function " ++ show n ++                        " disallowed during initialization" ++ formatFullContextBrace c       when (sfScope f /= CategoryScope) $-        compileError $ "Function " ++ show n ++ " in " ++ show t ++ " cannot be used as a category function"+        compileErrorM $ "Function " ++ show n ++ " in " ++ show t ++ " cannot be used as a category function"       return f     checkFunction _ =-      compileError $ "Category " ++ show t +++      compileErrorM $ "Category " ++ show t ++                      " does not have a category function named " ++ show n ++                      formatFullContextBrace c   ccGetTypeFunction ctx c t n = getFunction t where     getFunction (Just t2@(TypeMerge MergeUnion _)) =-      compileError $ "Use explicit type conversion to call " ++ show n ++ " for union type " +++      compileErrorM $ "Use explicit type conversion to call " ++ show n ++ " for union type " ++                      show t2 ++ formatFullContextBrace c     getFunction (Just ta@(TypeMerge MergeIntersect ts)) =-      collectOneOrErrorM (map getFunction $ map Just ts) `reviseError`+      collectOneOrErrorM (map getFunction $ map Just ts) `reviseErrorM`         ("Function " ++ show n ++ " not available for type " ++ show ta ++ formatFullContextBrace c)     getFunction (Just (SingleType (JustParamName p))) = do       fa <- ccAllFilters ctx       fs <- case p `Map.lookup` fa of                 (Just fs) -> return fs-                _ -> compileError $ "Param " ++ show p ++ " does not exist"+                _ -> compileErrorM $ "Param " ++ show p ++ " does not exist"       let ts = map tfType $ filter isRequiresFilter fs       let ds = map dfType $ filter isDefinesFilter  fs-      collectOneOrErrorM (map (getFunction . Just . SingleType) ts ++ map checkDefine ds) `reviseError`+      collectOneOrErrorM (map (getFunction . Just . SingleType) ts ++ map checkDefine ds) `reviseErrorM`         ("Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c)     getFunction (Just (SingleType (JustTypeInstance t2)))       -- Same category as the procedure itself.@@ -166,6 +166,7 @@     getFunction Nothing = do       let ps = fmap (SingleType . JustParamName . vpParam) $ pcExtParams ctx       getFunction (Just $ SingleType $ JustTypeInstance $ TypeInstance (pcType ctx) ps)+    getFunction (Just t2) = compileErrorM $ "Type " ++ show t2 ++ " contains unresolved types"     checkDefine t2 = do       (_,ca) <- getCategory (pcCategories ctx) (c,diName t2)       let params = Positional $ map vpParam $ getCategoryParams ca@@ -173,24 +174,24 @@       checkFunction (diName t2) params (diParams t2) $ n `Map.lookup` fa     checkFunction t2 ps1 ps2 (Just f) = do       when (pcDisallowInit ctx && t2 == pcType ctx) $-        compileError $ "Function " ++ show n +++        compileErrorM $ "Function " ++ show n ++                        " disallowed during initialization" ++ formatFullContextBrace c       when (sfScope f == CategoryScope) $-        compileError $ "Function " ++ show n ++ " in " ++ show t2 +++        compileErrorM $ "Function " ++ show n ++ " in " ++ show t2 ++                        " is a category function" ++ formatFullContextBrace c-      paired <- processPairs alwaysPair ps1 ps2 `reviseError`+      paired <- processPairs alwaysPair ps1 ps2 `reviseErrorM`         ("In external function call at " ++ formatFullContext c)       let assigned = Map.fromList paired       uncheckedSubFunction assigned f     checkFunction t2 _ _ _ =-      compileError $ "Category " ++ show t2 +++      compileErrorM $ "Category " ++ show t2 ++                      " does not have a type or value function named " ++ show n ++                      formatFullContextBrace c   ccCheckValueInit ctx c (TypeInstance t as) ts ps     | t /= pcType ctx =-      compileError $ "Category " ++ show (pcType ctx) ++ " cannot initialize values from " +++      compileErrorM $ "Category " ++ show (pcType ctx) ++ " cannot initialize values from " ++                      show t ++ formatFullContextBrace c-    | otherwise = flip reviseError ("In initialization at " ++ formatFullContext c) $ do+    | otherwise = flip reviseErrorM ("In initialization at " ++ formatFullContext c) $ do       let t' = TypeInstance (pcType ctx) as       r <- ccResolver ctx       allFilters <- ccAllFilters ctx@@ -202,10 +203,10 @@       let mapped = Map.fromListWith (++) $ map (\f -> (pfParam f,[pfFilter f])) (pcIntFilters ctx)       let positional = map (getFilters mapped) (map vpParam $ pValues $ pcIntParams ctx)       assigned <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ pcIntParams ctx) ps-      subbed <- fmap Positional $ collectAllOrErrorM $ map (assignFilters assigned) positional+      subbed <- fmap Positional $ mapErrorsM (assignFilters assigned) positional       processPairs_ (validateAssignment r allFilters) ps subbed       -- Check initializer types.-      ms <- fmap Positional $ collectAllOrErrorM $ map (subSingle pa') (pcMembers ctx)+      ms <- fmap Positional $ mapErrorsM (subSingle pa') (pcMembers ctx)       processPairs_ (checkInit r allFilters) ms (Positional $ zip ([1..] :: [Int]) $ pValues ts)       return ()       where@@ -214,9 +215,9 @@               (Just fs) -> fs               _ -> []         assignFilters fm fs = do-          collectAllOrErrorM $ map (uncheckedSubFilter $ getValueForParam fm) fs+          mapErrorsM (uncheckedSubFilter $ getValueForParam fm) fs         checkInit r fa (MemberValue c2 n t0) (i,t1) = do-          checkValueTypeMatch r fa t1 t0 `reviseError`+          checkValueTypeMatch r fa t1 t0 `reviseErrorM`             ("In initializer " ++ show i ++ " for " ++ show n ++ formatFullContextBrace c2)         subSingle pa (DefinedMember c2 _ t2 n _) = do           t2' <- uncheckedSubValueType (getValueForParam pa) t2@@ -224,12 +225,12 @@   ccGetVariable ctx c n =     case n `Map.lookup` pcVariables ctx of           (Just v) -> return v-          _ -> compileError $ "Variable " ++ show n ++ " is not defined" +++          _ -> compileErrorM $ "Variable " ++ show n ++ " is not defined" ++                               formatFullContextBrace c   ccAddVariable ctx c n t = do     case n `Map.lookup` pcVariables ctx of           Nothing -> return ()-          (Just v) -> compileError $ "Variable " ++ show n +++          (Just v) -> compileErrorM $ "Variable " ++ show n ++                                     formatFullContextBrace c ++                                     " is already defined: " ++ show v     return $ ProcedureContext {@@ -258,7 +259,7 @@   ccCheckVariableInit ctx c n =     case pcReturns ctx of          ValidateNames _ na -> when (n `Map.member` na) $-           compileError $ "Named return " ++ show n ++ " might not be initialized" ++ formatFullContextBrace c+           compileErrorM $ "Named return " ++ show n ++ " might not be initialized" ++ formatFullContextBrace c          _ -> return ()   ccWrite ctx ss = return $     ProcedureContext {@@ -399,23 +400,23 @@                        Nothing -> Positional []                        Just vs2 -> vs2         -- Check for a count match first, to avoid the default error message.-        processPairs_ alwaysPair (fmap pvType rs) vs' `reviseError`+        processPairs_ alwaysPair (fmap pvType rs) vs' `reviseErrorM`           ("In procedure return at " ++ formatFullContext c)-        processPairs_ checkReturnType rs (Positional $ zip ([0..] :: [Int]) $ pValues vs') `reviseError`+        processPairs_ checkReturnType rs (Positional $ zip ([0..] :: [Int]) $ pValues vs') `reviseErrorM`           ("In procedure return at " ++ formatFullContext c)         return ()         where           checkReturnType ta0@(PassedValue _ t0) (n,t) = do             r <- ccResolver ctx             pa <- ccAllFilters ctx-            checkValueTypeMatch r pa t t0 `reviseError`+            checkValueTypeMatch r pa t t0 `reviseErrorM`               ("Cannot convert " ++ show t ++ " to " ++ show ta0 ++ " in return " ++                show n ++ " at " ++ formatFullContext c)       check (ValidateNames ts ra) =         case vs of              Just _ -> check (ValidatePositions ts)              Nothing -> mergeAllM $ map alwaysError $ Map.toList ra where-               alwaysError (n,t) = compileError $ "Named return " ++ show n ++ " (" ++ show t +++               alwaysError (n,t) = compileErrorM $ "Named return " ++ show n ++ " (" ++ show t ++                                                   ") might not have been set before return at " ++                                                   formatFullContext c       check _ = return ()@@ -503,7 +504,7 @@   ccGetCleanup = return . pcCleanupSetup   ccExprLookup ctx c n =     case n `Map.lookup` pcExprMap ctx of-         Nothing -> compileError $ "Env expression " ++ n ++ " is not defined" ++ formatFullContextBrace c+         Nothing -> compileErrorM $ "Env expression " ++ n ++ " is not defined" ++ formatFullContextBrace c          Just e -> return e   ccSetNoTrace ctx t =     return $ ProcedureContext {@@ -545,7 +546,7 @@           va' <- va           case ovName r `Map.lookup` va' of                Nothing -> return $ Map.insert (ovName r) (VariableValue c LocalScope t True) va'-               (Just v) -> compileError $ "Variable " ++ show (ovName r) +++               (Just v) -> compileErrorM $ "Variable " ++ show (ovName r) ++                                           formatFullContextBrace (ovContext r) ++                                           " is already defined" ++                                           formatFullContextBrace (vvContext v)@@ -562,7 +563,7 @@       va' <- va       case ivName a `Map.lookup` va' of             Nothing -> return $ Map.insert (ivName a) (VariableValue c LocalScope t False) va'-            (Just v) -> compileError $ "Variable " ++ show (ivName a) +++            (Just v) -> compileErrorM $ "Variable " ++ show (ivName a) ++                                        formatFullContextBrace (ivContext a) ++                                        " is already defined" ++                                        formatFullContextBrace (vvContext v)

@@ -102,7 +102,7 @@       let fa' = Map.union fa $ getFilterMap pi2 fi2       mergeAllM $ map (checkFilter r fa') fi2     checkFilter r fa (ParamFilter c2 n2 f) =-      validateTypeFilter r fa f `reviseError`+      validateTypeFilter r fa f `reviseErrorM`         (show n2 ++ " " ++ show f ++ formatFullContextBrace c2)     checkFunction pm f =       when (sfScope f == ValueScope) $@@ -110,7 +110,7 @@     checkParam pm p =       case vpParam p `Map.lookup` pm of            Nothing -> return ()-           (Just c2) -> compileError $ "Internal param " ++ show (vpParam p) +++           (Just c2) -> compileErrorM $ "Internal param " ++ show (vpParam p) ++                                        formatFullContextBrace (vpContext p) ++                                        " is already defined at " ++                                        formatFullContext c2

@@ -99,10 +99,10 @@   -- Check public sources up front so that error messages aren't duplicated for   -- every source file.   _ <- tmTesting-  (hxx1,cxx1) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmPublic  nsPublic)  cs1-  (hxx2,cxx2) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmPrivate nsPrivate) ps1-  (hxx3,cxx3) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmTesting nsTesting) ts1-  (ds,xx) <- fmap mergeGeneratedX $ collectAllOrErrorM $ map compileSourceX xa+  (hxx1,cxx1) <- fmap mergeGeneratedP $ mapErrorsM (compileSourceP tmPublic  nsPublic)  cs1+  (hxx2,cxx2) <- fmap mergeGeneratedP $ mapErrorsM (compileSourceP tmPrivate nsPrivate) ps1+  (hxx3,cxx3) <- fmap mergeGeneratedP $ mapErrorsM (compileSourceP tmTesting nsTesting) ts1+  (ds,xx) <- fmap mergeGeneratedX $ mapErrorsM compileSourceX xa   -- TODO: This should account for a name clash between a category declared in a   -- TestsOnly .0rp and one declared in a non-TestOnly .0rx.   let dm = mapByName ds@@ -140,11 +140,11 @@       -- Ensures that there isn't an inavertent collision when resolving       -- dependencies for the module later on.       tmTesting' <- tmTesting-      _ <- includeNewTypes tmTesting' cs2 `reviseError` "In a module source that is conditionally public"-      hxx <- collectAllOrErrorM $ map (compileCategoryDeclaration tm' ns4) cs2+      _ <- includeNewTypes tmTesting' cs2 `reviseErrorM` "In a module source that is conditionally public"+      hxx <- mapErrorsM (compileCategoryDeclaration tm' ns4) cs2       let interfaces = filter (not . isValueConcrete) cs2-      cxx1 <- collectAllOrErrorM $ map compileInterfaceDefinition interfaces-      cxx2 <- collectAllOrErrorM $ map (compileDefinition tm' (ns:ns4)) ds+      cxx1 <- mapErrorsM compileInterfaceDefinition interfaces+      cxx2 <- mapErrorsM (compileDefinition tm' (ns:ns4)) ds       return (ds,hxx ++ cxx1 ++ cxx2)     mergeGeneratedX ((ds,xx):xs2) = let (ds2,xx2) = mergeGeneratedX xs2 in (ds++ds2,xx++xx2)     mergeGeneratedX _             = ([],[])@@ -158,7 +158,7 @@     checkLocal cs2 d =       if dcName d `Set.member` cs2          then return ()-         else compileError ("Definition for " ++ show (dcName d) +++         else compileErrorM ("Definition for " ++ show (dcName d) ++                             formatFullContextBrace (dcContext d) ++                             " does not correspond to a visible category in this module")     checkDefined dm ex2 = mergeAllM . map (checkSingle dm (Set.fromList ex2))@@ -167,21 +167,21 @@            (False,Just [_]) -> return ()            (True,Nothing)   -> return ()            (True,Just [d]) ->-             compileError ("Category " ++ show (getCategoryName t) +++             compileErrorM ("Category " ++ show (getCategoryName t) ++                            formatFullContextBrace (getCategoryContext t) ++                            " was declared external but is also defined at " ++ formatFullContext (dcContext d))            (False,Nothing) ->-             compileError ("Category " ++ show (getCategoryName t) +++             compileErrorM ("Category " ++ show (getCategoryName t) ++                            formatFullContextBrace (getCategoryContext t) ++                            " has not been defined or declared external")            (_,Just ds) ->-             flip reviseError ("Category " ++ show (getCategoryName t) +++             flip reviseErrorM ("Category " ++ show (getCategoryName t) ++                                formatFullContextBrace (getCategoryContext t) ++                                " is defined " ++ show (length ds) ++ " times") $-               mergeAllM $ map (\d -> compileError $ "Defined at " ++ formatFullContext (dcContext d)) ds+               mergeAllM $ map (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds     checkSupefluous es2       | null es2 = return ()-      | otherwise = compileError $ "External categories either not concrete or not present: " +++      | otherwise = compileErrorM $ "External categories either not concrete or not present: " ++                                    intercalate ", " (map show es2)  compileTestMain :: (Show c, CompileErrorM m, MergeableM m) =>@@ -206,8 +206,8 @@     reconcile [_] = return ()     reconcile []  = compileErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)"     reconcile ds  =-      flip reviseError ("Multiple matches for main category " ++ show n) $-        mergeAllM $ map (\d -> compileError $ "Defined at " ++ formatFullContext (dcContext d)) ds+      flip reviseErrorM ("Multiple matches for main category " ++ show n) $+        mergeAllM $ map (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds  compileCategoryDeclaration :: (Show c, CompileErrorM m, MergeableM m) =>   CategoryMap c -> [Namespace] -> AnyCategory c -> m CxxOutput@@ -265,7 +265,7 @@   CategoryMap c -> CategoryName -> m CxxOutput compileConcreteTemplate ta n = do   (_,t) <- getConcreteCategory ta ([],n)-  compileConcreteDefinition ta Map.empty [] Nothing (defined t) `reviseError` ("In generated template for " ++ show n) where+  compileConcreteDefinition ta Map.empty [] Nothing (defined t) `reviseErrorM` ("In generated template for " ++ show n) where     defined t = DefinedCategory {         dcContext = [],         dcName = getCategoryName t,@@ -356,7 +356,7 @@       [DefinedMember c] -> m ()     disallowTypeMembers tm =       mergeAllM $ flip map tm-        (\m -> compileError $ "Member " ++ show (dmName m) +++        (\m -> compileErrorM $ "Member " ++ show (dmName m) ++                               " is not allowed to be @type-scoped" ++                               formatFullContextBrace (dmContext m))     createParams = mergeAllM $ map createParam pi@@ -408,11 +408,11 @@       return $ onlyCode $ valueName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}"     unwrappedArg i m = writeStoredVariable (dmType m) (UnwrappedSingle $ "args.At(" ++ show i ++ ")")     createMember r filters m = do-      validateGeneralInstance r filters (vtType $ dmType m) `reviseError`+      validateGeneralInstance r filters (vtType $ dmType m) `reviseErrorM`         ("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) `reviseError`+      validateGeneralInstance r filters (vtType $ dmType m) `reviseErrorM`         ("In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m))       return $ onlyCode $ variableLazyType (dmType m) ++ " " ++ variableName (dmName m) ++ ";"     initMember (DefinedMember _ _ _ _ Nothing) = return mergeDefault@@ -664,6 +664,7 @@   where     ps' = map expandLocalType $ pValues ps expandLocalType (SingleType (JustParamName p)) = paramName p+expandLocalType _ = undefined  -- The instance is an InferredType.  defineCategoryName :: CategoryName -> CompiledData [String] defineCategoryName t = onlyCode $ "std::string CategoryName() const final { return \"" ++ show t ++ "\"; }"@@ -771,7 +772,7 @@  createMainFile :: (Show c, CompileErrorM m, MergeableM m) =>   CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String])-createMainFile tm em n f = flip reviseError ("In the creation of the main binary procedure") $ do+createMainFile tm em n f = flip reviseErrorM ("In the creation of the main binary procedure") $ do   ca <- fmap indentCompiled (compileMainProcedure tm em expr)   let file = createMainCommon "main" ca   (_,t) <- getConcreteCategory tm ([],n)@@ -782,7 +783,7 @@  createTestFile :: (Show c, CompileErrorM m, MergeableM m) =>   CategoryMap c -> ExprMap c  -> Expression c -> m ([CategoryName],[String])-createTestFile tm em e = flip reviseError ("In the creation of the test binary procedure") $ do+createTestFile tm em e = flip reviseErrorM ("In the creation of the test binary procedure") $ do   ca@(CompiledData req _) <- fmap indentCompiled (compileMainProcedure tm em e)   let file = createMainCommon "test" ca   return (Set.toList req,file)

@@ -37,6 +37,7 @@ import Control.Monad.Trans.State (execStateT,get,put,runStateT) import Control.Monad.Trans (lift) import Data.List (intercalate)+import qualified Data.Map as Map import qualified Data.Set as Set  import Base.CompileError@@ -151,7 +152,7 @@       where         checkCondition (Positional [t]) | t == boolRequiredValue = return ()         checkCondition (Positional ts) =-          compileError $ "Conditionals must have exactly one Bool return but found {" +++          compileErrorM $ "Conditionals must have exactly one Bool return but found {" ++                          intercalate "," (map show ts) ++ "}"  -- Returns the state so that returns can be properly checked for if/elif/else.@@ -192,7 +193,7 @@       autoPositionalCleanup e     -- Multi-expression => must all be singles.     getReturn rs = do-      lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) `reviseError`+      lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) `reviseErrorM`         ("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) ++ ")"@@ -200,30 +201,30 @@       autoPositionalCleanup e     checkArity (_,Positional [_]) = return ()     checkArity (i,Positional ts)  =-      compileError $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"+      compileErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1" compileStatement (LoopBreak c) = do   loop <- csGetLoop   case loop of        NotInLoop ->-         lift $ compileError $ "Using break outside of while is no allowed" ++ formatFullContextBrace c+         lift $ compileErrorM $ "Using break outside of while is no allowed" ++ formatFullContextBrace c        _ -> return ()   csWrite ["break;"] compileStatement (LoopContinue c) = do   loop <- csGetLoop   case loop of        NotInLoop ->-         lift $ compileError $ "Using continue outside of while is no allowed" ++ formatFullContextBrace c+         lift $ compileErrorM $ "Using continue outside of while is no allowed" ++ formatFullContextBrace c        _ -> return ()   csWrite $ ["{"] ++ lsUpdate loop ++ ["}","continue;"] compileStatement (FailCall c e) = do   csRequiresTypes (Set.fromList [BuiltinFormatted,BuiltinString])   e' <- compileExpression e   when (length (pValues $ fst e') /= 1) $-    lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e0) = e'   r <- csResolver   fa <- csAllFilters-  lift $ (checkValueTypeMatch r fa t0 formattedRequiredValue) `reviseError`+  lift $ (checkValueTypeMatch_ r fa t0 formattedRequiredValue) `reviseErrorM`     ("In fail call at " ++ formatFullContext c)   csSetNoReturn   maybeSetTrace c@@ -258,16 +259,16 @@     createVariable r fa (CreateVariable c2 t1 n) t2 = do       -- TODO: Call csRequiresTypes for t1. (Maybe needs a helper function.)       lift $ mergeAllM [validateGeneralInstance r fa (vtType t1),-                        checkValueTypeMatch r fa t2 t1] `reviseError`+                        checkValueTypeMatch_ r fa t2 t1] `reviseErrorM`         ("In creation of " ++ show n ++ " at " ++ formatFullContext c2)       csAddVariable c2 n (VariableValue c2 LocalScope t1 True)       csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"]     createVariable r fa (ExistingVariable (InputValue c2 n)) t2 = do       (VariableValue _ _ t1 w) <- csGetVariable c2 n-      when (not w) $ lift $ compileError $ "Cannot assign to read-only variable " +++      when (not w) $ lift $ compileErrorM $ "Cannot assign to read-only variable " ++                                            show n ++ formatFullContextBrace c2       -- TODO: Also show original context.-      lift $ (checkValueTypeMatch r fa t2 t1) `reviseError`+      lift $ (checkValueTypeMatch_ r fa t2 t1) `reviseErrorM`         ("In assignment to " ++ show n ++ " at " ++ formatFullContext c2)       csUpdateAssigned n     createVariable _ _ _ _ = return ()@@ -296,11 +297,11 @@ compileLazyInit (DefinedMember c _ t1 n (Just e)) = do   (ts,e') <- compileExpression e   when (length (pValues ts) /= 1) $-    lift $ compileError $ "Expected single return in initializer" ++ formatFullContextBrace (getExpressionContext e)+    lift $ compileErrorM $ "Expected single return in initializer" ++ formatFullContextBrace (getExpressionContext e)   r <- csResolver   fa <- csAllFilters   let Positional [t2] = ts-  lift $ (checkValueTypeMatch r fa t2 t1) `reviseError`+  lift $ (checkValueTypeMatch_ r fa t2 t1) `reviseErrorM`     ("In initialization of " ++ show n ++ " at " ++ formatFullContext c)   csWrite [variableName n ++ "([this]() { return " ++ writeStoredVariable t1 e' ++ "; })"] @@ -418,7 +419,7 @@   csInheritReturns [ctxCl]   where     createVariable r fa (c,t,n) = do-      lift $ validateGeneralInstance r fa (vtType t) `reviseError`+      lift $ validateGeneralInstance r fa (vtType t) `reviseErrorM`         ("In creation of " ++ show n ++ " at " ++ formatFullContext c)       csWrite [variableStoredType t ++ " " ++ variableName n ++ ";"]     showVariable (c,t,n) = do@@ -457,15 +458,15 @@     return (Positional [charRequiredValue],UnboxedPrimitive PrimChar $ "PrimChar('" ++ escapeChar l ++ "')")   compile (Literal (IntegerLiteral c True l)) = do     csRequiresTypes (Set.fromList [BuiltinInt])-    when (l > 2^(64 :: Integer) - 1) $ lift $ compileError $+    when (l > 2^(64 :: Integer) - 1) $ lift $ compileErrorM $       "Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit unsigned"     let l' = if l > 2^(63 :: Integer) - 1 then l - 2^(64 :: Integer) else l     return (Positional [intRequiredValue],UnboxedPrimitive PrimInt $ "PrimInt(" ++ show l' ++ ")")   compile (Literal (IntegerLiteral c False l)) = do     csRequiresTypes (Set.fromList [BuiltinInt])-    when (l > 2^(63 :: Integer) - 1) $ lift $ compileError $+    when (l > 2^(63 :: Integer) - 1) $ lift $ compileErrorM $       "Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit signed"-    when ((-l) > (2^(63 :: Integer) - 2)) $ lift $ compileError $+    when ((-l) > (2^(63 :: Integer) - 2)) $ lift $ compileErrorM $       "Literal " ++ show l ++ formatFullContextBrace c ++ " is less than the min value for 64-bit signed"     return (Positional [intRequiredValue],UnboxedPrimitive PrimInt $ "PrimInt(" ++ show l ++ ")")   compile (Literal (DecimalLiteral _ l e)) = do@@ -503,11 +504,11 @@         | o == "!" = doNot t e2         | o == "-" = doNeg t e2         | o == "~" = doComp t e2-        | otherwise = lift $ compileError $ "Unknown unary operator \"" ++ o ++ "\" " +++        | otherwise = lift $ compileErrorM $ "Unknown unary operator \"" ++ o ++ "\" " ++                                             formatFullContextBrace c       doNot t e2 = do         when (t /= boolRequiredValue) $-          lift $ compileError $ "Cannot use " ++ show t ++ " with unary ! operator" +++          lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary ! operator" ++                                 formatFullContextBrace c         return $ (Positional [boolRequiredValue],UnboxedPrimitive PrimBool $ "!" ++ useAsUnboxed PrimBool e2)       doNeg t e2@@ -515,12 +516,12 @@                                             UnboxedPrimitive PrimInt $ "-" ++ useAsUnboxed PrimInt e2)         | t == floatRequiredValue = return $ (Positional [floatRequiredValue],                                              UnboxedPrimitive PrimFloat $ "-" ++ useAsUnboxed PrimFloat e2)-        | otherwise = lift $ compileError $ "Cannot use " ++ show t ++ " with unary - operator" +++        | otherwise = lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary - operator" ++                                             formatFullContextBrace c       doComp t e2         | t == intRequiredValue = return $ (Positional [intRequiredValue],                                             UnboxedPrimitive PrimInt $ "~" ++ useAsUnboxed PrimInt e2)-        | otherwise = lift $ compileError $ "Cannot use " ++ show t ++ " with unary ~ operator" +++        | otherwise = lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary ~ operator" ++                                             formatFullContextBrace c   compile (InitializeValue c t ps es) = do     es' <- sequence $ map compileExpression $ pValues es@@ -542,13 +543,13 @@       getValues [(Positional ts,e)] = return (ts,useAsArgs e)       -- Multi-expression => must all be singles.       getValues rs = do-        lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) `reviseError`+        lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) `reviseErrorM`           ("In return at " ++ formatFullContext c)         return (map (head . pValues . fst) rs,                 "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")       checkArity (_,Positional [_]) = return ()       checkArity (i,Positional ts)  =-        compileError $ "Initializer position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"+        compileErrorM $ "Initializer position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"   compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec _ (CategoryFunction c2 cn) fn ps)) e2) =     compile (Expression c (CategoryCall c2 cn (FunctionCall c fn ps (Positional [e1,e2]))) [])   compile (InfixExpression c e1 (FunctionOperator _ (FunctionSpec _ (TypeFunction c2 tn) fn ps)) e2) =@@ -583,7 +584,7 @@     where       bind t1 t2         | t1 /= t2 =-          lift $ compileError $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " +++          lift $ compileErrorM $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " ++                                 show t2 ++ formatFullContextBrace c         | o `Set.member` comparison && t1 == intRequiredValue = do           return (Positional [boolRequiredValue],glueInfix PrimInt PrimBool e1 o e2)@@ -614,7 +615,7 @@         | o `Set.member` equals && t1 == boolRequiredValue = do           return (Positional [boolRequiredValue],glueInfix PrimBool PrimBool e1 o e2)         | otherwise =-          lift $ compileError $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " +++          lift $ compileErrorM $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " ++                                 show t2 ++ formatFullContextBrace c       glueInfix t1 t2 e3 o2 e4 =         UnboxedPrimitive t2 $ useAsUnboxed t1 e3 ++ o2 ++ useAsUnboxed t1 e4@@ -624,7 +625,7 @@     r <- csResolver     fa <- csAllFilters     let vt = ValueType RequiredValue $ SingleType $ JustTypeInstance t-    lift $ (checkValueTypeMatch r fa t' vt) `reviseError`+    lift $ (checkValueTypeMatch_ r fa t' vt) `reviseErrorM`       ("In converted call at " ++ formatFullContext c)     f' <- lookupValueFunction vt f     compileFunctionCall (Just $ useAsUnwrapped e') f' f@@ -635,17 +636,17 @@     compileFunctionCall (Just $ useAsUnwrapped e') f' f   requireSingle _ [t] = return t   requireSingle c2 ts =-    lift $ compileError $ "Function call requires 1 return but found but found {" +++    lift $ compileErrorM $ "Function call requires 1 return but found but found {" ++                           intercalate "," (map show ts) ++ "}" ++ formatFullContextBrace c2  lookupValueFunction :: (Show c, CompileErrorM m, MergeableM m,                         CompilerContext c m [String] a) =>   ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c) lookupValueFunction (ValueType WeakValue t) (FunctionCall c _ _ _) =-  lift $ compileError $ "Use strong to convert " ++ show t +++  lift $ compileErrorM $ "Use strong to convert " ++ show t ++                         " to optional first" ++ formatFullContextBrace c lookupValueFunction (ValueType OptionalValue t) (FunctionCall c _ _ _) =-  lift $ compileError $ "Use require to convert " ++ show t +++  lift $ compileErrorM $ "Use require to convert " ++ show t ++                         " to required first" ++ formatFullContextBrace c lookupValueFunction (ValueType RequiredValue t) (FunctionCall c n _ _) =   csGetTypeFunction c (Just t) n@@ -670,9 +671,9 @@ compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do   r <- csResolver   fa <- csAllFilters-  lift $ validateGeneralInstance r fa (SingleType t) `reviseError` ("In function call at " ++ formatFullContext c)+  lift $ validateGeneralInstance r fa (SingleType t) `reviseErrorM` ("In function call at " ++ formatFullContext c)   f' <- csGetTypeFunction c (Just $ SingleType t) n-  when (sfScope f' /= TypeScope) $ lift $ compileError $ "Function " ++ show n +++  when (sfScope f' /= TypeScope) $ lift $ compileErrorM $ "Function " ++ show n ++                                           " cannot be used as a type function" ++                                           formatFullContextBrace c   csRequiresTypes $ Set.unions $ map categoriesFromTypes [SingleType t]@@ -689,39 +690,39 @@     tryNonCategory ctx = do       f' <- ccGetTypeFunction ctx c Nothing n       s <- ccCurrentScope ctx-      when (sfScope f' > s) $ compileError $+      when (sfScope f' > s) $ compileErrorM $         "Function " ++ show n ++ " is not in scope here" ++ formatFullContextBrace c       return f' -- TODO: Compile BuiltinCall like regular functions, for consistent validation. compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinPresent ps es)) = do   csRequiresTypes (Set.fromList [BuiltinBool])   when (length (pValues ps) /= 0) $-    lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c   when (length (pValues es) /= 1) $-    lift $ compileError $ "Expected 1 argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 1 argument" ++ formatFullContextBrace c   es' <- sequence $ map compileExpression $ pValues es   when (length (pValues $ fst $ head es') /= 1) $-    lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'   when (isWeakValue t0) $-    lift $ compileError $ "Weak values not allowed here" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Weak values not allowed here" ++ formatFullContextBrace c   return $ (Positional [boolRequiredValue],             UnboxedPrimitive PrimBool $ valueBase ++ "::Present(" ++ useAsUnwrapped e ++ ")") compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinReduce ps es)) = do   when (length (pValues ps) /= 2) $-    lift $ compileError $ "Expected 2 type parameters" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 2 type parameters" ++ formatFullContextBrace c   when (length (pValues es) /= 1) $-    lift $ compileError $ "Expected 1 argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 1 argument" ++ formatFullContextBrace c   es' <- sequence $ map compileExpression $ pValues es   when (length (pValues $ fst $ head es') /= 1) $-    lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'-  let (Positional [t1,t2]) = ps+  [t1,t2] <- lift $ disallowInferred ps   r <- csResolver   fa <- csAllFilters   lift $ validateGeneralInstance r fa t1   lift $ validateGeneralInstance r fa t2-  lift $ (checkValueTypeMatch r fa t0 (ValueType OptionalValue t1)) `reviseError`+  lift $ (checkValueTypeMatch_ r fa t0 (ValueType OptionalValue t1)) `reviseErrorM`     ("In argument to reduce call at " ++ formatFullContext c)   -- TODO: If t1 -> t2 then just return e without a Reduce call.   t1' <- expandGeneralInstance t1@@ -732,25 +733,25 @@             UnwrappedSingle $ typeBase ++ "::Reduce(" ++ t1' ++ ", " ++ t2' ++ ", " ++ useAsUnwrapped e ++ ")") compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinRequire ps es)) = do   when (length (pValues ps) /= 0) $-    lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c   when (length (pValues es) /= 1) $-    lift $ compileError $ "Expected 1 argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 1 argument" ++ formatFullContextBrace c   es' <- sequence $ map compileExpression $ pValues es   when (length (pValues $ fst $ head es') /= 1) $-    lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'   when (isWeakValue t0) $-    lift $ compileError $ "Weak values not allowed here" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Weak values not allowed here" ++ formatFullContextBrace c   return $ (Positional [ValueType RequiredValue (vtType t0)],             UnwrappedSingle $ valueBase ++ "::Require(" ++ useAsUnwrapped e ++ ")") compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinStrong ps es)) = do   when (length (pValues ps) /= 0) $-    lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c   when (length (pValues es) /= 1) $-    lift $ compileError $ "Expected 1 argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 1 argument" ++ formatFullContextBrace c   es' <- sequence $ map compileExpression $ pValues es   when (length (pValues $ fst $ head es') /= 1) $-    lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'   let t1 = Positional [ValueType OptionalValue (vtType t0)]   if isWeakValue t0@@ -759,27 +760,27 @@      else return (t1,e) compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinTypename ps es)) = do   when (length (pValues ps) /= 1) $-    lift $ compileError $ "Expected 1 type parameter" ++ formatFullContextBrace c+    lift $ compileErrorM $ "Expected 1 type parameter" ++ formatFullContextBrace c   when (length (pValues es) /= 0) $-    lift $ compileError $ "Expected 0 arguments" ++ formatFullContextBrace c-  let t = head $ pValues ps+    lift $ compileErrorM $ "Expected 0 arguments" ++ formatFullContextBrace c+  [t] <- lift $ disallowInferred ps   r <- csResolver   fa <- csAllFilters   lift $ validateGeneralInstance r fa t   t' <- expandGeneralInstance t-  csRequiresTypes $ Set.unions $ map categoriesFromTypes $ pValues ps+  csRequiresTypes $ Set.unions $ map categoriesFromTypes [t]   return $ (Positional [formattedRequiredValue],             valueAsWrapped $ UnboxedPrimitive PrimString $ typeBase ++ "::TypeName(" ++ t' ++ ")") compileExpressionStart (BuiltinCall _ _) = undefined compileExpressionStart (ParensExpression _ e) = compileExpression e compileExpressionStart (InlineAssignment c n e) = do   (VariableValue _ s t0 w) <- csGetVariable c n-  when (not w) $ lift $ compileError $ "Cannot assign to read-only variable " +++  when (not w) $ lift $ compileErrorM $ "Cannot assign to read-only variable " ++                                         show n ++ formatFullContextBrace c   (Positional [t],e') <- compileExpression e -- TODO: Get rid of the Positional matching here.   r <- csResolver   fa <- csAllFilters-  lift $ (checkValueTypeMatch r fa t t0) `reviseError`+  lift $ (checkValueTypeMatch_ r fa t t0) `reviseErrorM`     ("In assignment at " ++ formatFullContext c)   csUpdateAssigned n   scoped <- autoScope s@@ -787,31 +788,35 @@   return (Positional [t0],readStoredVariable lazy t0 $ "(" ++ scoped ++ variableName n ++                                                      " = " ++ writeStoredVariable t0 e' ++ ")") +disallowInferred :: (Show c, CompileErrorM m) => Positional (InstanceOrInferred c) -> m [GeneralInstance]+disallowInferred = mapErrorsM disallow . pValues where+  disallow (AssignedInstance _ t) = return t+  disallow (InferredInstance c) =+    compileErrorM $ "Type inference is not allowed in reduce calls" ++ formatFullContextBrace c+ compileFunctionCall :: (Show c, CompileErrorM m, MergeableM m,                         CompilerContext c m [String] a) =>   Maybe String -> ScopedFunction c -> FunctionCall c ->   CompilerState a m (ExpressionType,ExprValue)-compileFunctionCall e f (FunctionCall c _ ps es) = do+compileFunctionCall e f (FunctionCall c _ ps es) = flip reviseErrorStateT errorContext $ do   r <- csResolver   fa <- csAllFilters-  f' <- lift $ parsedToFunctionType f `reviseError`-          ("In function call at " ++ formatFullContext c)-  f'' <- lift $ assignFunctionParams r fa ps f' `reviseError`-          ("In function call at " ++ formatFullContext c)   es' <- sequence $ map compileExpression $ pValues es   (ts,es'') <- getValues es'+  ps2 <- lift $ guessParamsFromArgs r fa f ps (Positional ts)+  f' <- lift $ parsedToFunctionType f+  f'' <- lift $ assignFunctionParams r fa ps2 f'   -- Called an extra time so arg count mismatches have reasonable errors.-  lift $ processPairs_ (\_ _ -> return ()) (ftArgs f'') (Positional ts) `reviseError`-    ("In function call at " ++ formatFullContext c)-  lift $ processPairs_ (checkArg r fa) (ftArgs f'') (Positional $ zip ([0..] :: [Int]) ts) `reviseError`-    ("In function call at " ++ formatFullContext c)-  csRequiresTypes $ Set.unions $ map categoriesFromTypes $ pValues ps+  lift $ processPairs_ (\_ _ -> return ()) (ftArgs f'') (Positional ts)+  lift $ processPairs_ (checkArg r fa) (ftArgs f'') (Positional $ zip ([0..] :: [Int]) ts)+  csRequiresTypes $ Set.unions $ map categoriesFromTypes $ pValues ps2   csRequiresTypes (Set.fromList [sfType f])-  params <- expandParams2 ps+  params <- expandParams2 ps2   scoped <- autoScope (sfScope f)   call <- assemble e scoped (sfScope f) params es''   return $ (ftReturns f'',OpaqueMulti call)   where+    errorContext = "In call to " ++ show (sfName f) ++ " at " ++ formatFullContext c     assemble Nothing _ ValueScope ps2 es2 =       return $ callName (sfName f) ++ "(Var_self, " ++ ps2 ++ ", " ++ es2 ++ ")"     assemble Nothing scoped _ ps2 es2 =@@ -825,15 +830,33 @@     getValues [(Positional ts,e2)] = return (ts,useAsArgs e2)     -- Multi-expression => must all be singles.     getValues rs = do-      lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) `reviseError`+      lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) `reviseErrorM`         ("In return at " ++ formatFullContext c)       return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")     checkArity (_,Positional [_]) = return ()     checkArity (i,Positional ts)  =-      compileError $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"+      compileErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"     checkArg r fa t0 (i,t1) = do-      checkValueTypeMatch r fa t1 t0 `reviseError` ("In argument " ++ show i ++ " to " ++ show (sfName f))+      checkValueTypeMatch r fa t1 t0 `reviseErrorM` ("In argument " ++ show i ++ " to " ++ show (sfName f)) +guessParamsFromArgs :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) =>+  r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->+  Positional ValueType -> m (Positional GeneralInstance)+guessParamsFromArgs r fa f ps ts = do+  let fa2 = fa `Map.union` getFunctionFilterMap f+  args <- processPairs alwaysPair ts (fmap pvType $ sfArgs f)+  pa <- fmap Map.fromList $ processPairs toInstance (fmap vpParam $ sfParams f) ps+  let pa2 = pa `Map.union` (Map.fromList $ zip (Map.keys fa2) (map (SingleType . JustParamName) $ Map.keys fa2))+  pa3 <- inferParamTypes r fa2 pa2 args+  fmap Positional $ mapErrorsM (subPosition pa3) (pValues $ sfParams f) where+    subPosition pa2 p =+      case (vpParam p) `Map.lookup` pa2 of+           Just t  -> return t+           Nothing -> compileErrorM $ "Something went wrong inferring " +++                      show (vpParam p) ++ formatFullContextBrace (vpContext p)+    toInstance p1 (AssignedInstance _ t) = return (p1,t)+    toInstance p1 (InferredInstance _)   = return (p1,SingleType $ JustInferredType p1)+ compileMainProcedure :: (Show c, CompileErrorM m, MergeableM m) =>   CategoryMap c -> ExprMap c -> Expression c -> m (CompiledData [String]) compileMainProcedure tm em e = do@@ -868,13 +891,13 @@ categoriesFromDefine :: DefinesInstance -> Set.Set CategoryName categoriesFromDefine (DefinesInstance t ps) = t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps) -expandParams :: (CompilerContext c m s a) =>+expandParams :: (CompileErrorM m, CompilerContext c m s a) =>   Positional GeneralInstance -> CompilerState a m String expandParams ps = do   ps' <- sequence $ map expandGeneralInstance $ pValues ps   return $ "T_get(" ++ intercalate "," (map ("&" ++) ps') ++ ")" -expandParams2 :: (CompilerContext c m s a) =>+expandParams2 :: (CompileErrorM m, CompilerContext c m s a) =>   Positional GeneralInstance -> CompilerState a m String expandParams2 ps = do   ps' <- sequence $ map expandGeneralInstance $ pValues ps@@ -884,7 +907,7 @@   CategoryName -> CompilerState a m String expandCategory t = return $ categoryGetter t ++ "()" -expandGeneralInstance :: (CompilerContext c m s a) =>+expandGeneralInstance :: (CompileErrorM m, CompilerContext c m s a) =>   GeneralInstance -> CompilerState a m String expandGeneralInstance (TypeMerge MergeUnion     []) = return $ allGetter ++ "()" expandGeneralInstance (TypeMerge MergeIntersect []) = return $ anyGetter ++ "()"@@ -901,6 +924,7 @@   s <- csGetParamScope p   scoped <- autoScope s   return $ scoped ++ paramName p+expandGeneralInstance t = lift $ compileErrorM $ "Type " ++ show t ++ " contains unresolved types"  doImplicitReturn :: (Show c,CompilerContext c m [String] a) => [c] -> CompilerState a m () doImplicitReturn c = do

@@ -19,83 +19,39 @@ {-# LANGUAGE Safe #-}  module Config.LoadConfig (-  Backend(..),-  LocalConfig(..),-  Resolver(..),-  compilerVersion,   localConfigPath,   loadConfig,-  rootPath, ) where -import Config.Paths-import Config.Programs- import Control.Monad (when)-import Data.Hashable (hash)-import Data.List (intercalate,isPrefixOf,isSuffixOf)-import Data.Maybe (isJust)-import Data.Version (showVersion,versionBranch)-import GHC.IO.Handle-import Numeric (showHex)+import Control.Monad.IO.Class import System.Directory-import System.Exit-import System.FilePath-import System.IO-import System.Posix.Process (ProcessStatus(..),executeFile,forkProcess,getProcessStatus)-import System.Posix.Temp (mkstemps) -import Paths_zeolite_lang (getDataFileName,version)+import Base.CompileError+import Config.LocalConfig +import Paths_zeolite_lang (getDataFileName) -loadConfig :: IO (Backend,Resolver)++loadConfig :: (MonadIO m, CompileErrorM m) => m (Resolver,Backend) loadConfig = do-  configFile <- localConfigPath-  isFile <- doesFileExist configFile-  when (not isFile) $ do-    hPutStrLn stderr "Zeolite has not been configured. Please run zeolite-setup."-    exitFailure-  configString <- readFile configFile+  configFile <- liftIO localConfigPath+  isFile <- liftIO $ doesFileExist configFile+  when (not isFile) $ compileErrorM "Zeolite has not been configured. Please run zeolite-setup."+  configString <- liftIO $ readFile configFile   lc <- check $ (reads configString :: [(LocalConfig,String)])-  pathsFile <- globalPathsPath-  pathsExists <- doesFileExist pathsFile+  pathsFile   <- liftIO $ globalPathsPath+  pathsExists <- liftIO $ doesFileExist pathsFile   paths <- if pathsExists-              then readFile pathsFile >>= return . lines+              then liftIO $ readFile pathsFile >>= return . lines               else return []-  return (lcBackend lc,addPaths (lcResolver lc) paths) where-    check [(cm,"")] = return cm+  return (addPaths (lcResolver lc) paths,lcBackend lc) where+    check [(cm,"")]   = return cm     check [(cm,"\n")] = return cm-    check _ = do-      hPutStrLn stderr "Zeolite configuration is corrupt. Please rerun zeolite-setup."-      exitFailure--rootPath :: IO FilePath-rootPath = getDataFileName ""--compilerVersion :: String-compilerVersion = showVersion version--data Backend =-  UnixBackend {-    ucCxxBinary :: FilePath,-    ucCxxOptions :: [String],-    ucArBinary :: FilePath-  }-  deriving (Read,Show)--data Resolver =-  SimpleResolver {-    srVisibleSystem :: [FilePath],-    srExtraPaths :: [FilePath]-  }-  deriving (Read,Show)+    check _ = compileErrorM "Zeolite configuration is corrupt. Please rerun zeolite-setup." -data LocalConfig =-  LocalConfig {-    lcBackend :: Backend,-    lcResolver :: Resolver-  }-  deriving (Read,Show)+localConfigPath :: IO FilePath+localConfigPath = getDataFileName localConfigFilename >>= canonicalizePath  localConfigFilename :: FilePath localConfigFilename = ".local-config"@@ -103,114 +59,8 @@ globalPathsFilename :: FilePath globalPathsFilename = "global-paths" -localConfigPath :: IO FilePath-localConfigPath = getDataFileName localConfigFilename >>= canonicalizePath- globalPathsPath :: IO FilePath globalPathsPath = getDataFileName globalPathsFilename >>= canonicalizePath  addPaths :: Resolver -> [FilePath] -> Resolver addPaths (SimpleResolver ls ps) ps2 = SimpleResolver ls (ps ++ ps2)--instance CompilerBackend Backend where-  runCxxCommand (UnixBackend cb co ab) (CompileToObject s p nm ns ps e) = do-    objName <- canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".o")-    executeProcess cb $ co ++ otherOptions ++ ["-c", s, "-o", objName]-    if e-      then do-        -- Extra files are put into .a since they will be unconditionally-        -- included. This prevents unwanted symbol dependencies.-        arName  <- canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".a")-        executeProcess ab ["-q",arName,objName]-        return arName-      else return objName where-      otherOptions = map (("-I" ++) . normalise) ps ++ nsFlag-      nsFlag-        | null ns = []-        | otherwise = ["-D" ++ nm ++ "=" ++ ns]-  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]-    return o where-      otherOptions = lf ++ map ("-I" ++) (map normalise ps)-  runTestCommand _ (TestCommand b p) = do-    (outF,outH) <- mkstemps "/tmp/ztest_" ".txt"-    (errF,errH) <- mkstemps "/tmp/ztest_" ".txt"-    pid <- forkProcess (execWithCapture outH errH)-    hClose outH-    hClose errH-    status <- getProcessStatus True True pid-    out <- readFile outF-    removeFile outF-    err <- readFile errF-    removeFile errF-    let success = case status of-                       Just (Exited ExitSuccess) -> True-                       _ -> False-    return $ TestCommandResult success (lines out) (lines err) where-      execWithCapture h1 h2 = do-        when (not $ null p) $ setCurrentDirectory p-        hDuplicateTo h1 stdout-        hDuplicateTo h2 stderr-        executeFile b True [] Nothing-  getCompilerHash b = VersionHash $ flip showHex "" $ abs $ hash $ minorVersion ++ show b where-    minorVersion = show $ take 3 $ versionBranch version--executeProcess :: String -> [String] -> IO ()-executeProcess c os = do-  hPutStrLn stderr $ "Executing: " ++ intercalate " " (c:os)-  pid <- forkProcess $ executeFile c True os Nothing-  status <- getProcessStatus True True pid-  case status of-       Just (Exited ExitSuccess) -> return ()-       _ -> exitFailure--instance PathResolver Resolver where-  resolveModule r p m = do-    ps2 <- potentialSystemPaths r m-    firstExisting m $ [p</>m] ++ ps2-  isSystemModule r p m = do-    isDir <- doesDirectoryExist (p</>m)-    if isDir-       then return False-       else do-         ps2 <- potentialSystemPaths r m-         findModule ps2 >>= return . not . isJust-  resolveBaseModule _ = do-    let m = "base"-    m0 <- getDataFileName m-    firstExisting m [m0]-  isBaseModule r f = do-    b <- resolveBaseModule r-    return (f == b)--potentialSystemPaths :: Resolver -> FilePath -> IO [FilePath]-potentialSystemPaths (SimpleResolver ls ps) m = do-  let allowGlobal = not (".." `elem` components)-  m0 <- if allowGlobal && any (\l -> isPrefixOf (l ++ "/") m) ls-           then getDataFileName m >>= return . (:[])-           else return []-  let m2 = if allowGlobal-              then map (</> m) ps-              else []-  return $ m0 ++ m2 where-    components = map stripSlash $ splitPath m-    stripSlash = reverse . dropWhile (== '/') . reverse--firstExisting :: FilePath -> [FilePath] -> IO FilePath-firstExisting m ps = do-  p <- findModule ps-  case p of-       Nothing -> do-         hPutStrLn stderr $ "Could not find path " ++ m-         exitFailure-       Just p2 -> return p2--findModule :: [FilePath] -> IO (Maybe FilePath)-findModule [] = return Nothing-findModule (p:ps) = do-  isDir <- doesDirectoryExist p-  if isDir-     then fmap Just $ canonicalizePath p-     else findModule ps

@@ -0,0 +1,180 @@+{- -----------------------------------------------------------------------------+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]++{-# LANGUAGE Safe #-}++module Config.LocalConfig (+  Backend(..),+  LocalConfig(..),+  Resolver(..),+  rootPath,+  compilerVersion,+) where++import Control.Monad (when)+import Control.Monad.IO.Class+import Data.Hashable (hash)+import Data.List (intercalate,isPrefixOf,isSuffixOf)+import Data.Maybe (isJust)+import Data.Version (showVersion,versionBranch)+import GHC.IO.Handle+import Numeric (showHex)+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.Posix.Process (ProcessStatus(..),executeFile,forkProcess,getProcessStatus)+import System.Posix.Temp (mkstemps)++import Base.CompileError+import Cli.Paths+import Cli.Programs++import Paths_zeolite_lang (getDataFileName,version)+++data Backend =+  UnixBackend {+    ucCxxBinary :: FilePath,+    ucCxxOptions :: [String],+    ucArBinary :: FilePath+  }+  deriving (Read,Show)++data Resolver =+  SimpleResolver {+    srVisibleSystem :: [FilePath],+    srExtraPaths :: [FilePath]+  }+  deriving (Read,Show)++data LocalConfig =+  LocalConfig {+    lcBackend :: Backend,+    lcResolver :: Resolver+  }+  deriving (Read,Show)++rootPath :: IO FilePath+rootPath = getDataFileName ""++compilerVersion :: String+compilerVersion = showVersion version++instance CompilerBackend Backend where+  runCxxCommand (UnixBackend cb co ab) (CompileToObject s p nm ns ps e) = do+    objName <- errorFromIO $ canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".o")+    executeProcess cb $ co ++ otherOptions ++ ["-c", s, "-o", objName]+    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]+        return arName+      else return objName where+      otherOptions = map (("-I" ++) . normalise) ps ++ nsFlag+      nsFlag+        | null ns = []+        | otherwise = ["-D" ++ nm ++ "=" ++ ns]+  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]+    return o where+      otherOptions = lf ++ map ("-I" ++) (map normalise ps)+  runTestCommand _ (TestCommand b p) = errorFromIO $ do+    (outF,outH) <- mkstemps "/tmp/ztest_" ".txt"+    (errF,errH) <- mkstemps "/tmp/ztest_" ".txt"+    pid <- forkProcess (execWithCapture outH errH)+    hClose outH+    hClose errH+    status <- getProcessStatus True True pid+    out <- readFile outF+    removeFile outF+    err <- readFile errF+    removeFile errF+    let success = case status of+                       Just (Exited ExitSuccess) -> True+                       _ -> False+    return $ TestCommandResult success (lines out) (lines err) where+      execWithCapture h1 h2 = do+        when (not $ null p) $ setCurrentDirectory p+        hDuplicateTo h1 stdout+        hDuplicateTo h2 stderr+        executeFile b True [] Nothing+  getCompilerHash b = VersionHash $ flip showHex "" $ abs $ hash $ minorVersion ++ show b where+    minorVersion = show $ take 3 $ versionBranch version++executeProcess :: (MonadIO m, CompileErrorM m) => String -> [String] -> m ()+executeProcess c os = do+  errorFromIO $ hPutStrLn stderr $ "Executing: " ++ intercalate " " (c:os)+  pid    <- errorFromIO $ forkProcess $ executeFile c True os Nothing+  status <- errorFromIO $ getProcessStatus True True pid+  case status of+       Just (Exited ExitSuccess) -> return ()+       _ -> do+         errorFromIO $ hPutStrLn stderr $ "Execution of " ++ c ++ " failed"+         compileErrorM $ "Execution of " ++ c ++ " failed"++instance PathIOHandler Resolver where+  resolveModule r p m = do+    ps2 <- errorFromIO $ potentialSystemPaths r m+    firstExisting m $ [p</>m] ++ ps2+  isSystemModule r p m = do+    isDir <- errorFromIO $ doesDirectoryExist (p</>m)+    if isDir+       then return False+       else do+         ps2 <- errorFromIO $ potentialSystemPaths r m+         errorFromIO (findModule ps2) >>= return . not . isJust+  resolveBaseModule _ = do+    let m = "base"+    m0 <- errorFromIO $ getDataFileName m+    firstExisting m [m0]+  isBaseModule r f = do+    b <- resolveBaseModule r+    return (f == b)++potentialSystemPaths :: Resolver -> FilePath -> IO [FilePath]+potentialSystemPaths (SimpleResolver ls ps) m = do+  let allowGlobal = not (".." `elem` components)+  m0 <- if allowGlobal && any (\l -> isPrefixOf (l ++ "/") m) ls+           then getDataFileName m >>= return . (:[])+           else return []+  let m2 = if allowGlobal+              then map (</> m) ps+              else []+  return $ m0 ++ m2 where+    components = map stripSlash $ splitPath m+    stripSlash = reverse . dropWhile (== '/') . reverse++firstExisting :: (MonadIO m, CompileErrorM m) => FilePath -> [FilePath] -> m FilePath+firstExisting m ps = do+  p <- errorFromIO $ findModule ps+  case p of+       Nothing -> compileErrorM $ "Could not find path " ++ m+       Just p2 -> return p2++findModule :: [FilePath] -> IO (Maybe FilePath)+findModule [] = return Nothing+findModule (p:ps) = do+  isDir <- doesDirectoryExist p+  if isDir+     then fmap Just $ canonicalizePath p+     else findModule ps

@@ -1,30 +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]--{-# LANGUAGE Safe #-}--module Config.Paths (-  PathResolver(..),-) where---class PathResolver r where-  resolveModule :: r -> FilePath -> FilePath -> IO FilePath-  isSystemModule :: r -> FilePath -> FilePath -> IO Bool-  resolveBaseModule :: r -> IO FilePath-  isBaseModule :: r -> FilePath -> IO Bool

@@ -1,71 +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]--{-# LANGUAGE Safe #-}--module Config.Programs (-  CompilerBackend(..),-  CxxCommand(..),-  TestCommand(..),-  TestCommandResult(..),-  VersionHash(..),-) where---class CompilerBackend b where-  runCxxCommand :: b -> CxxCommand -> IO String-  runTestCommand :: b -> TestCommand -> IO TestCommandResult-  getCompilerHash :: b -> VersionHash--newtype VersionHash = VersionHash String deriving (Eq)--instance Show VersionHash where-  show (VersionHash h) = h--data CxxCommand =-  CompileToObject {-    ctoSource :: String,-    ctoPath :: String,-    ctoNamespaceMacro :: String,-    ctoNamespace :: String,-    ctoPaths :: [String],-    ctoExtra :: Bool-  } |-  CompileToBinary {-    ctbMain :: String,-    ctbSources :: [String],-    ctbOutput :: String,-    ctbPaths :: [String],-    ctbLinkFlags :: [String]-  }-  deriving (Show)--data TestCommand =-  TestCommand {-    tcBinary :: String,-    tcPath :: String-  }-  deriving (Show)--data TestCommandResult =-  TestCommandResult {-    tcrSuccess :: Bool,-    tcrOutput :: [String],-    tcrError :: [String]-  }-  deriving (Show)

@@ -28,6 +28,7 @@   char_,   endOfDoc,   escapeStart,+  inferredParam,   infixFuncEnd,   infixFuncStart,   keyword,@@ -379,6 +380,9 @@  pragmaArgsEnd :: Parser () pragmaArgsEnd = string_ "]"++inferredParam :: Parser ()+inferredParam = string_ "?"  operator :: String -> Parser String operator o = labeled o $ do

@@ -31,8 +31,8 @@ import Parser.Pragma import Parser.TypeCategory () import Parser.TypeInstance ()-import Types.Pragma import Types.Positional+import Types.Pragma import Types.Procedure import Types.TypeCategory import Types.TypeInstance@@ -388,6 +388,17 @@                           (sepAfter $ string_ ">")                           (sepBy sourceParser (sepAfter $ string_ ",")) <|> return []       return $ FunctionSpec [c] UnqualifiedFunction n (Positional ps)++instance ParseFromSource (InstanceOrInferred SourcePos) where+  sourceParser = assigned <|> inferred where+    assigned = do+      c <- getPosition+      t <- sourceParser+      return $ AssignedInstance [c] t+    inferred = do+      c <- getPosition+      sepAfter_ inferredParam+      return $ InferredInstance [c]  parseFunctionCall :: SourcePos -> FunctionName -> Parser (FunctionCall SourcePos) parseFunctionCall c n = do

@@ -43,7 +43,7 @@   (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)  = compileError (show e)+  unwrap (Left e)  = compileErrorM (show e)   unwrap (Right t) = return t   withPragmas = do     pragmas <- parsePragmas internalSourcePragmas@@ -54,7 +54,7 @@ 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)  = compileError (show e)+  unwrap (Left e)  = compileErrorM (show e)   unwrap (Right t) = return t   withPragmas = do     pragmas <- parsePragmas publicSourcePragmas@@ -65,7 +65,7 @@ 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)  = compileError (show e)+  unwrap (Left e)  = compileErrorM (show e)   unwrap (Right t) = return t   withPragmas = do     pragmas <- parsePragmas testSourcePragmas

@@ -52,7 +52,7 @@  import Base.CompileError import Base.Mergeable-import Compilation.CompileInfo+import Base.CompileInfo import Parser.Common import Parser.TypeInstance () import Types.TypeInstance@@ -77,36 +77,35 @@   force (Right x) = x   force _         = undefined -readSingle :: (ParseFromSource a, CompileErrorM m) => String -> String -> m a+readSingle :: ParseFromSource a => String -> String -> CompileInfo a readSingle = readSingleWith (optionalSpace >> sourceParser) -readSingleWith :: CompileErrorM m => Parser a -> String -> String -> m a+readSingleWith :: Parser a -> String -> String -> CompileInfo a readSingleWith p f s =   unwrap $ parse (between nullParse endOfDoc p) f s   where-    unwrap (Left e)  = compileError (show e)+    unwrap (Left e)  = compileErrorM (show e)     unwrap (Right t) = return t -readMulti :: CompileErrorM m => ParseFromSource a => String -> String -> m [a]+readMulti :: ParseFromSource a => String -> String -> CompileInfo [a] readMulti f s =   unwrap $ parse (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s   where-    unwrap (Left e)  = compileError (show e)+    unwrap (Left e)  = compileErrorM (show e)     unwrap (Right t) = return t -parseFilterMap :: CompileErrorM m => [(String,[String])] -> m ParamFilters+parseFilterMap :: [(String,[String])] -> CompileInfo ParamFilters parseFilterMap pa = do-  pa2 <- collectAllOrErrorM $ map parseFilters pa+  pa2 <- mapErrorsM parseFilters pa   return $ Map.fromList pa2   where     parseFilters (n,fs) = do-      fs2 <- collectAllOrErrorM $ map (readSingle "(string)") fs+      fs2 <- mapErrorsM (readSingle "(string)") fs       return (ParamName n,fs2) -parseTheTest :: (ParseFromSource a, CompileErrorM m) =>-  [(String,[String])] -> [String] -> m ([a],ParamFilters)+parseTheTest :: ParseFromSource a => [(String,[String])] -> [String] -> CompileInfo ([a],ParamFilters) parseTheTest pa xs = do-  ts <- collectAllOrErrorM $ map (readSingle "(string)") xs+  ts <- mapErrorsM (readSingle "(string)") xs   pa2 <- parseFilterMap pa   return (ts,pa2) @@ -114,17 +113,15 @@ showParams pa = "[" ++ intercalate "," (concat $ map expand pa) ++ "]" where   expand (n,ps) = map (\p -> n ++ " " ++ p) ps -checkTypeSuccess :: (TypeResolver r) =>-  r -> [(String,[String])] -> String -> CompileInfo ()+checkTypeSuccess :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo () checkTypeSuccess r pa x = do   ([t],pa2) <- parseTheTest pa [x]   check $ validateGeneralInstance r pa2 t   where     prefix = x ++ " " ++ showParams pa-    check = flip reviseError (prefix ++ ":")+    check = flip reviseErrorM (prefix ++ ":") -checkTypeFail :: (TypeResolver r) =>-  r -> [(String,[String])] -> String -> CompileInfo ()+checkTypeFail :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo () checkTypeFail r pa x = do   ([t],pa2) <- parseTheTest pa [x]   check $ validateGeneralInstance r pa2 t@@ -133,19 +130,17 @@     check :: CompileInfo a -> CompileInfo ()     check c       | isCompileError c = return ()-      | otherwise = compileError $ prefix ++ ": Expected failure\n"+      | otherwise = compileErrorM $ prefix ++ ": Expected failure\n" -checkDefinesSuccess :: (TypeResolver r) =>-  r -> [(String,[String])] -> String -> CompileInfo ()+checkDefinesSuccess :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo () checkDefinesSuccess r pa x = do   ([t],pa2) <- parseTheTest pa [x]   check $ validateDefinesInstance r pa2 t   where     prefix = x ++ " " ++ showParams pa-    check = flip reviseError (prefix ++ ":")+    check = flip reviseErrorM (prefix ++ ":") -checkDefinesFail :: (TypeResolver r) =>-  r -> [(String,[String])] -> String -> CompileInfo ()+checkDefinesFail :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo () checkDefinesFail r pa x = do   ([t],pa2) <- parseTheTest pa [x]   check $ validateDefinesInstance r pa2 t@@ -154,51 +149,46 @@     check :: CompileInfo a -> CompileInfo ()     check c       | isCompileError c = return ()-      | otherwise = compileError $ prefix ++ ": Expected failure\n"+      | otherwise = compileErrorM $ prefix ++ ": Expected failure\n" -containsExactly :: (Ord a, Show a, MergeableM m, CompileErrorM m) =>-  [a] -> [a] -> m ()+containsExactly :: (Ord a, Show a) => [a] -> [a] -> CompileInfo () containsExactly actual expected = do   containsNoDuplicates actual   containsAtLeast actual expected   containsAtMost actual expected -containsNoDuplicates :: (Ord a, Show a, MergeableM m, CompileErrorM m) =>-  [a] -> m ()+containsNoDuplicates :: (Ord a, Show a) => [a] -> CompileInfo () containsNoDuplicates expected =-  (mergeAllM $ map checkSingle $ group $ sort expected) `reviseError` (show expected)+  (mergeAllM $ map checkSingle $ group $ sort expected) `reviseErrorM` (show expected)   where     checkSingle xa@(x:_:_) =-      compileError $ "Item " ++ show x ++ " occurs " ++ show (length xa) ++ " times"+      compileErrorM $ "Item " ++ show x ++ " occurs " ++ show (length xa) ++ " times"     checkSingle _ = return () -containsAtLeast :: (Ord a, Show a, MergeableM m, CompileErrorM m) =>-  [a] -> [a] -> m ()+containsAtLeast :: (Ord a, Show a) => [a] -> [a] -> CompileInfo () containsAtLeast actual expected =-  (mergeAllM $ map (checkInActual $ Set.fromList actual) expected) `reviseError`+  (mergeAllM $ map (checkInActual $ Set.fromList actual) expected) `reviseErrorM`         (show actual ++ " (actual) vs. " ++ show expected ++ " (expected)")   where     checkInActual va v =       if v `Set.member` va          then return ()-         else compileError $ "Item " ++ show v ++ " was expected but not present"+         else compileErrorM $ "Item " ++ show v ++ " was expected but not present" -containsAtMost :: (Ord a, Show a, MergeableM m, CompileErrorM m) =>-  [a] -> [a] -> m ()+containsAtMost :: (Ord a, Show a) => [a] -> [a] -> CompileInfo () containsAtMost actual expected =-  (mergeAllM $ map (checkInExpected $ Set.fromList expected) actual) `reviseError`+  (mergeAllM $ map (checkInExpected $ Set.fromList expected) actual) `reviseErrorM`         (show actual ++ " (actual) vs. " ++ show expected ++ " (expected)")   where     checkInExpected va v =       if v `Set.member` va          then return ()-         else compileError $ "Item " ++ show v ++ " is unexpected"+         else compileErrorM $ "Item " ++ show v ++ " is unexpected" -checkEquals :: (Eq a, Show a, MergeableM m, CompileErrorM m) =>-  a -> a -> m ()+checkEquals :: (Eq a, Show a) => a -> a -> CompileInfo () checkEquals actual expected   | actual == expected = return ()-  | otherwise = compileError $ "Expected " ++ show expected ++ " but got " ++ show actual+  | otherwise = compileErrorM $ "Expected " ++ show expected ++ " but got " ++ show actual  loadFile :: String -> IO String loadFile f = readFile ("src" </> "Test" </> f)

@@ -0,0 +1,89 @@+{- -----------------------------------------------------------------------------+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]++{-# LANGUAGE Safe #-}++module Test.CompileInfo (tests) where++import Base.CompileError+import Base.Mergeable+import Base.CompileInfo+++tests :: [IO (CompileInfo ())]+tests = [+    checkSuccess 'a' (return 'a'),+    checkError "error\n" (compileErrorM "error" :: CompileInfoIO Char),++    checkSuccess ['a','b']          (collectAllOrErrorM [return 'a',return 'b']),+    checkSuccess []                 (collectAllOrErrorM [] :: CompileInfoIO [Char]),+    checkError   "error1\nerror2\n" (collectAllOrErrorM [compileErrorM "error1",return 'b',compileErrorM "error2"]),++    checkSuccess 'a' (collectOneOrErrorM [return 'a',return 'b']),+    checkError   ""  (collectOneOrErrorM [] :: CompileInfoIO Char),+    checkSuccess 'b' (collectOneOrErrorM [compileErrorM "error1",return 'b',compileErrorM "error2"]),++    checkSuccess ['a','b','c']      (mergeAllM [return ['a'],return ['b','c']]),+    checkSuccess []                 (mergeAllM [] :: CompileInfoIO [Char]),+    checkError   "error1\nerror2\n" (mergeAllM [compileErrorM "error1",return ['b'],compileErrorM "error2"]),++    checkSuccess ['a','b'] (mergeAnyM [return ['a'],return ['b']]),+    checkError   ""        (mergeAnyM [] :: CompileInfoIO [Char]),+    checkSuccess ['b']     (mergeAnyM [compileErrorM "error1",return ['b'],compileErrorM "error2"]),++    checkSuccessAndWarnings ["warning1","warning2"] ()+      (compileWarningM "warning1" >> return () >> compileWarningM "warning2"),+    checkErrorAndWarnings ["warning1"] "error\n"+      (compileWarningM "warning1" >> compileErrorM "error" >> compileWarningM "warning2" :: CompileInfoIO ()),++    checkSuccess ['a','b']  (sequence [return 'a',return 'b']),+    checkSuccess []         (sequence [] :: CompileInfoIO [Char]),+    checkError   "error1\n" (sequence [compileErrorM "error1",return 'b',compileErrorM "error2"])+  ]++checkSuccess :: (Eq a, Show a) => a -> CompileInfoIO a -> IO (CompileInfo ())+checkSuccess x y = do+  y' <- toCompileInfo y+  if isCompileError y' || getCompileSuccess y' == x+     then return $ y' >> return ()+     else return $ compileErrorM $ "Expected value " ++ show x ++ " but got value " ++ show (getCompileSuccess y')++checkError :: (Eq a, Show a) => String -> CompileInfoIO a -> IO (CompileInfo ())+checkError e y = do+  y' <- toCompileInfo y+  if not (isCompileError y')+     then return $ compileErrorM $ "Expected error \"" ++ e ++ "\" but got value " ++ show (getCompileSuccess y')+     else if show (getCompileError y') == e+          then return $ return ()+          else return $ compileErrorM $ "Expected error \"" ++ e ++ "\" but got error \"" ++ show (getCompileError y') ++ "\""++checkSuccessAndWarnings :: (Eq a, Show a) => [String] -> a -> CompileInfoIO a -> IO (CompileInfo ())+checkSuccessAndWarnings w x y = do+  y' <- toCompileInfo y+  outcome <- checkSuccess x y+  if getCompileWarnings y' == w+     then return $ outcome >> return ()+     else return $ compileErrorM $ "Expected warnings " ++ show w ++ " but got warnings " ++ show (getCompileWarnings y')++checkErrorAndWarnings :: (Eq a, Show a) => [String] -> String -> CompileInfoIO a -> IO (CompileInfo ())+checkErrorAndWarnings w e y = do+  y' <- toCompileInfo y+  outcome <- checkError e y+  if getCompileWarnings y' == w+     then return $ outcome >> return ()+     else return $ compileErrorM $ "Expected warnings " ++ show w ++ " but got warnings " ++ show (getCompileWarnings y')

@@ -24,7 +24,7 @@ import Text.Parsec  import Base.CompileError-import Compilation.CompileInfo+import Base.CompileInfo import Parser.DefinedCategory () import Test.Common import Types.DefinedCategory@@ -45,7 +45,7 @@   return $ check parsed   where   check c-    | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)+    | isCompileError c = compileErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)     | otherwise = return ()  checkParseFail :: String -> IO (CompileInfo ())@@ -56,5 +56,5 @@   where   check c     | isCompileError c = return ()-    | otherwise = compileError $ "Parse " ++ f ++ ": Expected failure but got\n" +++    | otherwise = compileErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++                                  show (getCompileSuccess c) ++ "\n"

@@ -25,7 +25,7 @@ import Text.Parsec  import Base.CompileError-import Compilation.CompileInfo+import Base.CompileInfo import Parser.Common import Parser.IntegrationTest () import Test.Common@@ -43,7 +43,7 @@       ("testfiles" </> "basic_error_test.0rt")       (\t -> return $ do         let h = itHeader t-        when (not $ isExpectCompileError $ ithResult h) $ compileError "Expected ExpectCompileError"+        when (not $ isExpectCompileError $ ithResult h) $ compileErrorM "Expected ExpectCompileError"         checkEquals (ithTestName h) "basic error test"         containsExactly (getRequirePattern $ ithResult h) [             OutputPattern OutputCompiler "pattern in output 1",@@ -61,7 +61,7 @@       ("testfiles" </> "basic_crash_test.0rt")       (\t -> return $ do         let h = itHeader t-        when (not $ isExpectRuntimeError $ ithResult h) $ compileError "Expected ExpectRuntimeError"+        when (not $ isExpectRuntimeError $ ithResult h) $ compileErrorM "Expected ExpectRuntimeError"         checkEquals (ithTestName h) "basic crash test"         let match = case ereExpression $ ithResult h of                          (Expression _@@ -69,7 +69,7 @@                              (JustTypeInstance (TypeInstance (CategoryName "Test") (Positional [])))                              (FunctionCall _ (FunctionName "execute") (Positional []) (Positional []))) []) -> True                          _ -> False-        when (not match) $ compileError "Expected test expression \"Test$execute()\""+        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"@@ -86,7 +86,7 @@       ("testfiles" </> "basic_success_test.0rt")       (\t -> return $ do         let h = itHeader t-        when (not $ isExpectRuntimeSuccess $ ithResult h) $ compileError "Expected ExpectRuntimeSuccess"+        when (not $ isExpectRuntimeSuccess $ ithResult h) $ compileErrorM "Expected ExpectRuntimeSuccess"         checkEquals (ithTestName h) "basic success test"         let match = case ersExpression $ ithResult h of                          (Expression _@@ -94,7 +94,7 @@                              (JustTypeInstance (TypeInstance (CategoryName "Test") (Positional [])))                              (FunctionCall _ (FunctionName "execute") (Positional []) (Positional []))) []) -> True                          _ -> False-        when (not match) $ compileError "Expected test expression \"Test$execute()\""+        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"@@ -114,8 +114,8 @@   s <- loadFile f   unwrap $ parse (between optionalSpace endOfDoc sourceParser) f s   where-    unwrap (Left e)  = return $ compileError (show e)-    unwrap (Right t) = fmap (flip reviseError ("Check " ++ f ++ ":")) $ o t+    unwrap (Left e)  = return $ compileErrorM (show e)+    unwrap (Right t) = fmap (flip reviseErrorM ("Check " ++ f ++ ":")) $ o t  extractCategoryNames :: IntegrationTest c -> [String] extractCategoryNames = map (show . getCategoryName) . itCategory

@@ -0,0 +1,103 @@+{- -----------------------------------------------------------------------------+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]++{-# LANGUAGE Safe #-}++module Test.MergeTree (tests) where++import Control.Monad (when)++import Base.CompileError+import Base.CompileInfo+import Base.MergeTree+import Base.Mergeable+++tests :: [IO (CompileInfo ())]+tests = [+   checkMatch (mergeAny $ fmap mergeLeaf [2,4,6]) (fmap (*2))+              (mergeAny $ map mergeLeaf [1..3] :: MergeTree Int),+   checkMatch (mergeAll $ fmap mergeLeaf [2,4,6]) (fmap (*2))+              (mergeAll $ map mergeLeaf [1..3] :: MergeTree Int),++   checkMatch (mergeLeaf 1) id (mergeAny [mergeLeaf 1,mergeAny []] :: MergeTree Int),+   checkMatch (mergeLeaf 1) id (mergeAll [mergeLeaf 1,mergeAll []] :: MergeTree Int),++   checkMatch ([1,2]) (foldr (:) [])+              (mergeAny [mergeLeaf 1,mergeAll [mergeLeaf 2]] :: MergeTree Int),+   checkMatch ([1,2]) (foldr (:) [])+              (mergeAll [mergeLeaf 1,mergeAny [mergeLeaf 2]] :: MergeTree Int),++   checkSuccess (mergeAny $ fmap mergeLeaf [1,2,3]) (sequence . fmap return)+                (mergeAny $ map mergeLeaf [1..3] :: MergeTree Int),+   checkSuccess (mergeAll $ fmap mergeLeaf [1,2,3]) (sequence . fmap return)+                (mergeAll $ map mergeLeaf [1..3] :: MergeTree Int),++   checkError "1 is odd\n" (sequence . fmap oddError)+              (mergeAny $ map mergeLeaf [1..3] :: MergeTree Int),+   checkError "1 is odd\n" (sequence . fmap oddError)+              (mergeAll $ map mergeLeaf [1..3] :: MergeTree Int),+   checkSuccess (mergeAny $ map mergeLeaf [1..3]) (sequence . fmap return)+                (mergeAny $ map mergeLeaf [1..3] :: MergeTree Int),+   checkSuccess (mergeAll $ map mergeLeaf [1..3]) (sequence . fmap return)+                (mergeAll $ map mergeLeaf [1..3] :: MergeTree Int),++   checkSuccess (mergeAny $ map mergeLeaf [2,4]) (pruneMergeTree . fmap oddError)+                (mergeAny $ map mergeLeaf [1..4] :: MergeTree Int),+   checkError "1 is odd\n3 is odd\n" (pruneMergeTree . fmap oddError)+              (mergeAll $ map mergeLeaf [1..4] :: MergeTree Int),+   checkSuccess (mergeAny $ map mergeLeaf [1..4]) (pruneMergeTree . fmap return)+                (mergeAny $ map mergeLeaf [1..4] :: MergeTree Int),+   checkSuccess (mergeAll $ map mergeLeaf [1..4]) (pruneMergeTree . fmap return)+                (mergeAll $ map mergeLeaf [1..4] :: MergeTree Int),++   checkSuccess [2,4]+                (reduceMergeTree return (\xs -> compileErrorM $ "mergeAll " ++ show xs) oddError2)+                (mergeAny $ map mergeLeaf [1..4] :: MergeTree Int),+   checkError "1 is odd\n3 is odd\n"+              (reduceMergeTree (\xs -> compileErrorM $ "mergeAny " ++ show xs) return oddError2)+              (mergeAll $ map mergeLeaf [1..4] :: MergeTree Int)+ ]++oddError :: Int -> CompileInfo Int+oddError x = do+  when (x `mod` 2 == 1) $ compileErrorM $ show x ++ " is odd"+  return x++oddError2 :: Int -> CompileInfo [Int]+oddError2 = fmap (:[]) . oddError++checkMatch :: (Eq b, Show b) => b -> (a -> b) -> a -> IO (CompileInfo ())+checkMatch x f y = let y' = f y in+  return $ if x /= y'+              then compileErrorM $ "Expected " ++ show x ++ " but got " ++ show y'+              else return ()++checkSuccess :: (Eq b, Show b) => b -> (a -> CompileInfo b) -> a -> IO (CompileInfo ())+checkSuccess x f y = let y' = f y in+  return $ if isCompileError y' || getCompileSuccess y' == x+              then y' >> return ()+              else compileErrorM $ "Expected value " ++ show x ++ " but got value " ++ show (getCompileSuccess y')++checkError :: Show b => String -> (a -> CompileInfo b) -> a -> IO (CompileInfo ())+checkError e f y = let y' = f y in+  return $ if not (isCompileError y')+              then compileErrorM $ "Expected error \"" ++ e ++ "\" but got value " ++ show (getCompileSuccess y')+              else if show (getCompileError y') == e+                      then return ()+                      else compileErrorM $ "Expected error \"" ++ e ++ "\" but got error \"" ++ show (getCompileError y') ++ "\""

@@ -22,11 +22,11 @@ import Text.Regex.TDFA -- Not safe!  import Base.CompileError-import Compilation.CompileInfo+import Base.CompileInfo import Cli.CompileMetadata import Cli.CompileOptions import Cli.ParseMetadata-import Config.Programs (VersionHash(..))+import Cli.Programs (VersionHash(..)) import System.FilePath import Test.Common import Types.Positional@@ -335,9 +335,9 @@ checkWriteThenRead :: (Eq a, Show a, ConfigFormat a) => a -> IO (CompileInfo ()) checkWriteThenRead m = return $ do   text <- fmap spamComments $ autoWriteConfig m-  m' <- autoReadConfig "(string)" text `reviseError` ("Serialized >>>\n\n" ++ text ++ "\n<<< Serialized\n\n")+  m' <- autoReadConfig "(string)" text `reviseErrorM` ("Serialized >>>\n\n" ++ text ++ "\n<<< Serialized\n\n")   when (m' /= m) $-    compileError $ "Failed to match after write/read\n" +++    compileErrorM $ "Failed to match after write/read\n" ++                    "Before:\n" ++ show m ++ "\n" ++                    "After:\n" ++ show m' ++ "\n" ++                    "Intermediate:\n" ++ text where@@ -352,9 +352,9 @@       | isCompileError c = do           let text = show (getCompileError c)           when (not $ text =~ p) $-            compileError $ "Expected pattern " ++ show p ++ " in error output but got\n" ++ text+            compileErrorM $ "Expected pattern " ++ show p ++ " in error output but got\n" ++ text       | otherwise =-          compileError $ "Expected write failure but got\n" ++ getCompileSuccess c+          compileErrorM $ "Expected write failure but got\n" ++ getCompileSuccess c  checkParsesAs :: (Show a, ConfigFormat a) => String -> (a -> Bool) -> IO (CompileInfo ()) checkParsesAs f m = do@@ -363,8 +363,8 @@   return $ check parsed contents   where     check x contents = do-      x' <- x `reviseError` ("While parsing " ++ f)+      x' <- x `reviseErrorM` ("While parsing " ++ f)       when (not $ m x') $-        compileError $ "Failed to match after write/read\n" +++        compileErrorM $ "Failed to match after write/read\n" ++                        "Unparsed:\n" ++ contents ++ "\n" ++                        "Parsed:\n" ++ show x' ++ "\n"

@@ -23,7 +23,7 @@ import Control.Monad (when)  import Base.CompileError-import Compilation.CompileInfo+import Base.CompileInfo import Parser.Common import Test.Common import Text.Parsec.String@@ -63,10 +63,10 @@   check parsed   e <- parsed   when (e /= m) $-    compileError $ show s ++ " does not parse as " ++ show m ++ ":\n" ++ show e+    compileErrorM $ show s ++ " does not parse as " ++ show m ++ ":\n" ++ show e   where     check c-      | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)+      | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)       | otherwise = return ()  checkParseFail :: Show a => Parser a -> [Char] -> IO (CompileInfo ())@@ -76,5 +76,5 @@   where     check c       | isCompileError c = return ()-      | otherwise = compileError $ "Parse '" ++ s ++ "': Expected failure but got\n" +++      | otherwise = compileErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++                                    show (getCompileSuccess c) ++ "\n"

@@ -24,7 +24,7 @@ import Text.Regex.TDFA -- Not safe!  import Base.CompileError-import Compilation.CompileInfo+import Base.CompileInfo import Parser.Pragma import Test.Common import Types.Pragma@@ -99,10 +99,10 @@   check parsed   e <- parsed   when (not $ m e) $-    compileError $ "No match in '" ++ s ++ "':\n" ++ show e+    compileErrorM $ "No match in '" ++ s ++ "':\n" ++ show e   where     check c-      | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)+      | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)       | otherwise = return ()  checkParseError :: String -> String -> Parser (Pragma SourcePos) -> IO (CompileInfo ())@@ -114,6 +114,6 @@       | isCompileError c = do           let text = show (getCompileError c)           when (not $ text =~ m) $-            compileError $ "Expected pattern " ++ show m ++ " in error output but got\n" ++ text+            compileErrorM $ "Expected pattern " ++ show m ++ " in error output but got\n" ++ text       | otherwise =-          compileError $ "Expected write failure but got\n" ++ show (getCompileSuccess c)+          compileErrorM $ "Expected write failure but got\n" ++ show (getCompileSuccess c)

@@ -25,7 +25,7 @@ import Text.Parsec  import Base.CompileError-import Compilation.CompileInfo+import Base.CompileInfo import Parser.Procedure () import Test.Common import Types.Positional@@ -411,7 +411,7 @@   return $ check parsed   where     check c-      | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)+      | isCompileError c = compileErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)       | otherwise = return ()  checkParseFail :: String -> IO (CompileInfo ())@@ -422,7 +422,7 @@   where     check c       | isCompileError c = return ()-      | otherwise = compileError $ "Parse " ++ f ++ ": Expected failure but got\n" +++      | otherwise = compileErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++                                    show (getCompileSuccess c) ++ "\n"  checkShortParseSuccess :: String -> IO (CompileInfo ())@@ -431,7 +431,7 @@   return $ check parsed   where     check c-      | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)+      | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)       | otherwise = return ()  checkShortParseFail :: String -> IO (CompileInfo ())@@ -441,7 +441,7 @@   where     check c       | isCompileError c = return ()-      | otherwise = compileError $ "Parse '" ++ s ++ "': Expected failure but got\n" +++      | otherwise = compileErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++                                    show (getCompileSuccess c) ++ "\n"  checkParsesAs :: String -> (Expression SourcePos -> Bool) -> IO (CompileInfo ())@@ -450,8 +450,8 @@   check parsed   e <- parsed   when (not $ m e) $-    compileError $ "No match in '" ++ s ++ "':\n" ++ show e+    compileErrorM $ "No match in '" ++ s ++ "':\n" ++ show e   where     check c-      | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)+      | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)       | otherwise = return ()

@@ -23,7 +23,7 @@ import System.FilePath  import Base.CompileError-import Compilation.CompileInfo+import Base.CompileInfo import Parser.SourceFile import Test.Common @@ -42,5 +42,5 @@   return $ check parsed   where     check c-      | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)+      | isCompileError c = compileErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)       | otherwise = return ()

@@ -27,10 +27,11 @@  import Base.CompileError import Base.Mergeable-import Compilation.CompileInfo+import Base.CompileInfo import Parser.TypeCategory () import Test.Common import Types.Builtin+import Types.GeneralType import Types.Positional import Types.TypeCategory import Types.TypeInstance@@ -120,7 +121,7 @@       (\ts -> do         ts2 <- topoSortCategories defaultCategories ts         map (show . getCategoryName) ts2 `containsPaired` [-            "Type","Object2","Object3","Object1","Parent","Child"+            "Object2","Object3","Object1","Type","Parent","Child"           ]),     checkOperationSuccess       ("testfiles" </> "flatten.0rx")@@ -791,20 +792,189 @@       ("testfiles" </> "resolved_in_preserved.0rx")       (\ts -> do         ts2 <- topoSortCategories defaultCategories ts-        flattenAllConnections defaultCategories ts2 >> return ())+        flattenAllConnections defaultCategories ts2 >> return ()),++    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Type1","#x")]+          [("#x","Type1",Covariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Type2","#x"),("Type1","#x")]+          [("#x","Type1",Covariant)]),++    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface1<Type2>","#x"),("Interface1<Type1>","#x")]+          [("#x","Interface1<Type1>",Covariant)]),++    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface2<Type2>","#x"),("Interface2<Type1>","#x")]+          [("#x","Interface2<Type2>",Covariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface2<Type2>","Interface2<#x>"),+           ("Interface2<Type1>","Interface2<#x>")]+          [("#x","Type2",Contravariant)]),++    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface3<Type1>","#x"),("Interface3<Type1>","#x")]+          [("#x","Interface3<Type1>",Covariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceFail tm+          [("#x",[])] ["#x"]+          [("Interface3<Type1>","#x"),("Interface3<Type2>","#x")]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface3<Type1>","Interface3<#x>"),+           ("Interface3<Type1>","Interface3<#x>")]+          [("#x","Type1",Invariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceFail tm+          [("#x",[])] ["#x"]+          [("Interface3<Type1>","Interface3<#x>"),+           ("Interface3<Type2>","Interface3<#x>")]),++    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Type1","#x"),+           ("Interface1<Type2>","Interface1<#x>"),+           ("Interface2<Type0>","Interface2<#x>")]+          [("#x","Type1",Covariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface3<Type2>","Interface3<#x>"),+           ("Interface1<Type2>","Interface1<#x>"),+           ("Interface2<Type1>","Interface2<#x>")]+          [("#x","Type2",Invariant)]),++    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[]),("#y",["allows #x"])] ["#x"]+          [("Interface1<Type1>","Interface1<#x>"),+           ("Type0","#y")]  -- The filter for #y influences the guess for #x.+          [("#x","Type0",Covariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[]),("#y",["allows #x"])] ["#x"]+          [("Interface1<Type1>","Interface1<#x>"),+           ("Type2","#y")]+          [("#x","Type1",Covariant)]),++    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface1<Type1>","Interface1<[#x|Interface2<#x>]>")]+          [("#x","Type1",Covariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface1<Type2>","Interface1<[#x&Type1]>")]+          [("#x","Type2",Covariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface2<Type1>","Interface2<[#x&Interface2<#x>]>")]+          [("#x","Type1",Contravariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface2<Type0>","Interface2<[#x|Type1]>")]+          [("#x","Type0",Contravariant)]),++    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          [("Interface3<Type0>","[Interface1<#x>|Interface3<#x>]")]+          -- Guesses are either Type0 or Type1, and Type1 is more specific.+          [("#x","Type1",Covariant)]),+    checkOperationSuccess+      ("testfiles" </> "inference.0rx")+      (\ts -> do+        tm <- includeNewTypes defaultCategories ts+        checkInferenceSuccess tm+          [("#x",[])] ["#x"]+          -- Guesses are both Type0 and Type1, and Type0 is more general.+          [("Interface3<Type0>","[Interface1<#x>&Interface3<#x>]")]+          [("#x","Type0",Invariant)])   ]  getRefines :: Map.Map CategoryName (AnyCategory c) -> String -> CompileInfo [String] getRefines tm n =   case (CategoryName n) `Map.lookup` tm of        (Just t) -> return $ map (show . vrType) (getCategoryRefines t)-       _ -> compileError $ "Type " ++ n ++ " not found"+       _ -> compileErrorM $ "Type " ++ n ++ " not found"  getDefines ::  Map.Map CategoryName (AnyCategory c) -> String -> CompileInfo [String] getDefines tm n =   case (CategoryName n) `Map.lookup` tm of        (Just t) -> return $ map (show . vdType) (getCategoryDefines t)-       _ -> compileError $ "Type " ++ n ++ " not found"+       _ -> compileErrorM $ "Type " ++ n ++ " not found"  getTypeRefines :: Show c => [AnyCategory c] -> String -> String -> CompileInfo [String] getTypeRefines ts s n = do@@ -856,21 +1026,19 @@   scrapeSingle (ValueConcrete _ _ n _ _ ds _ _) = map ((,) n . vdType) ds   scrapeSingle _ = [] -checkPaired :: (Show a, CompileErrorM m, MergeableM m) =>-  (a -> a -> m ()) -> [a] -> [a] -> m ()+checkPaired :: Show a => (a -> a -> CompileInfo ()) -> [a] -> [a] -> CompileInfo () checkPaired f actual expected   | length actual /= length expected =-    compileError $ "Different item counts: " ++ show actual ++ " (actual) vs. " +++    compileErrorM $ "Different item counts: " ++ show actual ++ " (actual) vs. " ++                    show expected ++ " (expected)"   | otherwise = mergeAllM $ map check (zip3 actual expected ([1..] :: [Int])) where-    check (a,e,n) = f a e `reviseError` ("Item " ++ show n ++ " mismatch")+    check (a,e,n) = f a e `reviseErrorM` ("Item " ++ show n ++ " mismatch") -containsPaired :: (Eq a, Show a, CompileErrorM m, MergeableM m) =>-  [a] -> [a] -> m ()+containsPaired :: (Eq a, Show a) => [a] -> [a] -> CompileInfo () containsPaired = checkPaired checkSingle where   checkSingle a e     | a == e = return ()-    | otherwise = compileError $ show a ++ " (actual) vs. " ++ show e ++ " (expected)"+    | otherwise = compileErrorM $ show a ++ " (actual) vs. " ++ show e ++ " (expected)"  checkOperationSuccess :: String -> ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) checkOperationSuccess f o = do@@ -878,7 +1046,7 @@   let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos]   return $ check (parsed >>= o >> return ())   where-    check = flip reviseError ("Check " ++ f ++ ":")+    check = flip reviseErrorM ("Check " ++ f ++ ":")  checkOperationFail :: String -> ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) checkOperationFail f o = do@@ -888,7 +1056,7 @@   where     check c       | isCompileError c = return ()-      | otherwise = compileError $ "Check " ++ f ++ ": Expected failure but got\n" +++      | otherwise = compileErrorM $ "Check " ++ f ++ ": Expected failure but got\n" ++                                    show (getCompileSuccess c) ++ "\n"  checkSingleParseSuccess :: String -> IO (CompileInfo ())@@ -898,7 +1066,7 @@   return $ check parsed   where     check c-      | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)+      | isCompileError c = compileErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)       | otherwise = return ()  checkSingleParseFail :: String -> IO (CompileInfo ())@@ -909,7 +1077,7 @@   where     check c       | isCompileError c = return ()-      | otherwise = compileError $ "Parse " ++ f ++ ": Expected failure but got\n" +++      | otherwise = compileErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++                                    show (getCompileSuccess c) ++ "\n"  checkShortParseSuccess :: String -> IO (CompileInfo ())@@ -918,7 +1086,7 @@   return $ check parsed   where     check c-      | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)+      | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)       | otherwise = return ()  checkShortParseFail :: String -> IO (CompileInfo ())@@ -928,5 +1096,59 @@   where     check c       | isCompileError c = return ()-      | otherwise = compileError $ "Parse '" ++ s ++ "': Expected failure but got\n" +++      | otherwise = compileErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++                                    show (getCompileSuccess c) ++ "\n"++checkInferenceSuccess :: CategoryMap SourcePos -> [(String, [String])] ->+  [String] -> [(String, String)] -> [(String,String,Variance)] -> CompileInfo ()+checkInferenceSuccess tm pa is ts gs = checkInferenceCommon check tm pa is ts gs where+  prefix = show ts ++ " " ++ showParams pa+  check gs2 c+    | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileError c)+    | otherwise        = getCompileSuccess c `containsExactly` gs2++checkInferenceFail :: CategoryMap SourcePos -> [(String, [String])] ->+  [String] -> [(String, String)] -> CompileInfo ()+checkInferenceFail tm pa is ts = checkInferenceCommon check tm pa is ts [] where+  prefix = show ts ++ " " ++ showParams pa+  check _ c+    | isCompileError c = return ()+    | otherwise = compileErrorM $ prefix ++ ": Expected failure\n"++checkInferenceCommon :: ([InferredTypeGuess] -> CompileInfo [InferredTypeGuess] -> CompileInfo ()) ->+  CategoryMap SourcePos -> [(String, [String])] -> [String] ->+  [(String,String)] -> [(String,String,Variance)] -> CompileInfo ()+checkInferenceCommon check tm pa is ts gs = checked `reviseErrorM` context where+  context = "With params = " ++ show pa ++ ", pairs = " ++ show ts+  checked = do+    let r = CategoryResolver tm+    pa2 <- parseFilterMap pa+    ts2 <- mapErrorsM parsePair ts+    ia2 <- mapErrorsM readInferred is+    gs' <- mapErrorsM parseGuess gs+    let iaMap = Map.fromList ia2+    -- TODO: Put the next few lines in a function in TypeCategory.+    pa3 <- fmap Map.fromList $ mapErrorsM (filterSub iaMap) $ Map.toList pa2+    gs2 <- mergeAllM $ map (subAndInfer r pa3 iaMap) ts2+    check gs' $ mergeInferredTypes r pa3 gs2+  subAndInfer r f im (t1,t2) = do+    t2' <- uncheckedSubInstance (weakLookup im) t2+    checkGeneralMatch r f Covariant t1 t2'+  readInferred p = do+    p' <- readSingle "(string)" p+    return (p',SingleType $ JustInferredType p')+  parseGuess (p,t,v) = do+    p' <- readSingle "(string)" p+    t' <- readSingle "(string)" t+    return $ InferredTypeGuess p' t' v+  parsePair (t1,t2) = do+    t1' <- readSingle "(string)" t1+    t2' <- readSingle "(string)" t2+    return (t1',t2')+  weakLookup tm2 n =+    case n `Map.lookup` tm2 of+         Just t  -> return t+         Nothing -> return $ SingleType $ JustParamName n+  filterSub im (k,fs) = do+    fs' <- mapErrorsM (uncheckedSubFilter (weakLookup im)) fs+    return (k,fs')

@@ -23,9 +23,12 @@ import qualified Data.Map as Map  import Base.CompileError-import Compilation.CompileInfo+import Base.CompileInfo+import Base.MergeTree+import Base.Mergeable import Parser.TypeInstance () import Test.Common+import Types.GeneralType import Types.Positional import Types.TypeInstance import Types.Variance@@ -559,7 +562,70 @@       "Instance1<Type3>",     return $ checkDefinesSuccess Resolver       []-      "Instance1<Type1<Type3>>"+      "Instance1<Type1<Type3>>",++    checkInferenceSuccess+      [("#x",[])] ["#x"]+      "Type1<Type0>" "Type1<#x>"+      (mergeLeaf ("#x","Type0",Invariant)),+    checkInferenceFail+      [("#x",[])] ["#x"]+      "Type1<Type3>" "Type4<#x>",++    checkInferenceSuccess+      [("#x",[])] ["#x"]+      "Instance1<Type1<Type3>>" "Instance1<#x>"+      (mergeLeaf ("#x","Type1<Type3>",Contravariant)),+    checkInferenceSuccess+      [("#x",[])] ["#x"]+      "Instance1<Type1<Type3>>" "Instance1<Type1<#x>>"+      (mergeLeaf ("#x","Type3",Invariant)),++    checkInferenceSuccess+      [("#x",[])] ["#x"]+      "Type2<Type3,Type0,Type3>" "Type2<#x,Type0,#x>"+      (mergeAll [mergeLeaf ("#x","Type3",Contravariant),+                 mergeLeaf ("#x","Type3",Covariant)]),+    checkInferenceSuccess+      [("#x",[]),("#y",[])] ["#x"]+      "Type2<Type3,#y,Type3>" "Type2<#x,#y,#x>"+      (mergeAll [mergeLeaf ("#x","Type3",Contravariant),+                 mergeLeaf ("#x","Type3",Covariant)]),+    checkInferenceFail+      [("#x",[]),("#y",[])] ["#x"]+      "Type2<Type3,Type0,Type3>" "Type2<#x,#y,#x>",++    checkInferenceSuccess+      [("#x",[]),("#y",[])] ["#x"]+      "Type2<Type3,#y,Type0>" "Type1<#x>"+      (mergeLeaf ("#x","Type3",Invariant)),++    checkInferenceSuccess+      [("#x",[]),("#y",[])] ["#x"]+      "Instance1<#y>" "Instance1<#x>"+      (mergeLeaf ("#x","#y",Contravariant)),++    checkInferenceSuccess+      [("#x",[])] ["#x"]+      "Instance1<Instance0>" "Instance1<[#x&Type0]>"+      (mergeLeaf ("#x","Instance0",Contravariant)),+    checkInferenceFail+      [("#x",[])] ["#x"]+      "Instance1<Instance0>" "Instance1<[#x|Type0]>",+    checkInferenceSuccess+      [("#x",[])] ["#x"]+      "Instance1<Type1<Type0>>" "Instance1<[Type0&Type1<#x>]>"+      (mergeLeaf ("#x","Type0",Invariant)),+    checkInferenceSuccess+      [("#x",[])] ["#x"]+      "Instance1<Type1<Type0>>" "Instance1<[#x&Type1<#x>]>"+      (mergeAny [mergeLeaf ("#x","Type1<Type0>",Contravariant),+                 mergeLeaf ("#x","Type0",Invariant)]),++    checkInferenceSuccess+      [("#x",[]),("#y",["allows #x"])] ["#x"]+      "Type0" "#y"  -- The filter for #y influences the guess for #x.+      (mergeLeaf ("#x","Type0",Covariant))   ]  @@ -679,23 +745,69 @@            ])   ] -checkSimpleConvertSuccess :: [Char] -> [Char] -> IO (CompileInfo ())+checkSimpleConvertSuccess :: String -> String -> IO (CompileInfo ()) checkSimpleConvertSuccess = checkConvertSuccess [] -checkSimpleConvertFail :: [Char] -> [Char] -> IO (CompileInfo ())+checkSimpleConvertFail :: String -> String -> IO (CompileInfo ()) checkSimpleConvertFail = checkConvertFail [] -checkConvertSuccess :: [(String, [String])] -> [Char] -> [Char] -> IO (CompileInfo ())+checkConvertSuccess :: [(String, [String])] -> String -> String -> IO (CompileInfo ()) checkConvertSuccess pa x y = return checked where   prefix = x ++ " -> " ++ y ++ " " ++ showParams pa   checked = do     ([t1,t2],pa2) <- parseTheTest pa [x,y]     check $ checkValueTypeMatch Resolver pa2 t1 t2   check c-    | isCompileError c = compileError $ prefix ++ ":\n" ++ show (getCompileError c)+    | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileError c)     | otherwise = return () -checkConvertFail :: [(String, [String])] -> [Char] -> [Char] -> IO (CompileInfo ())+checkInferenceSuccess :: [(String, [String])] -> [String] -> String ->+  String -> MergeTree (String,String,Variance) -> IO (CompileInfo ())+checkInferenceSuccess pa is x y gs = checkInferenceCommon check pa is x y gs where+  prefix = x ++ " -> " ++ y ++ " " ++ showParams pa+  check gs2 c+    | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileError c)+    | otherwise        = getCompileSuccess c `checkEquals` gs2++checkInferenceFail :: [(String, [String])] -> [String] -> String ->+  String -> IO (CompileInfo ())+checkInferenceFail pa is x y = checkInferenceCommon check pa is x y (mergeAll []) where+  prefix = x ++ " -> " ++ y ++ " " ++ showParams pa+  check _ c+    | isCompileError c = return ()+    | otherwise = compileErrorM $ prefix ++ ": Expected failure\n"++checkInferenceCommon ::+  (MergeTree InferredTypeGuess -> CompileInfo (MergeTree InferredTypeGuess) -> CompileInfo ()) ->+  [(String, [String])] -> [String] -> String -> String ->+  MergeTree (String,String,Variance) -> IO (CompileInfo ())+checkInferenceCommon check pa is x y gs = return $ checked `reviseErrorM` context where+  context = "With params = " ++ show pa ++ ", pair = (" ++ show x ++ "," ++ show y ++ ")"+  checked = do+    ([t1,t2],pa2) <- parseTheTest pa [x,y]+    ia2 <- mapErrorsM readInferred is+    gs' <- sequence $ fmap parseGuess gs+    let iaMap = Map.fromList ia2+    -- TODO: Merge duplication with Test.TypeCategory.+    pa3 <- fmap Map.fromList $ mapErrorsM (filterSub iaMap) $ Map.toList pa2+    t2' <- uncheckedSubInstance (weakLookup iaMap) t2+    check gs' $ checkGeneralMatch Resolver pa3 Covariant t1 t2'+  readInferred p = do+    p' <- readSingle "(string)" p+    return (p',SingleType $ JustInferredType p')+  parseGuess (p,t,v) = do+    p' <- readSingle "(string)" p+    t' <- readSingle "(string)" t+    return $ InferredTypeGuess p' t' v+  weakLookup tm n =+    case n `Map.lookup` tm of+         Just t  -> return t+         Nothing -> return $ SingleType $ JustParamName n+  filterSub im (k,fs) = do+    fs' <- mapErrorsM (uncheckedSubFilter (weakLookup im)) fs+    return (k,fs')++checkConvertFail :: [(String, [String])] -> String -> String -> IO (CompileInfo ()) checkConvertFail pa x y = return checked where   prefix = x ++ " /> " ++ y ++ " " ++ showParams pa   checked = do@@ -704,7 +816,7 @@   check :: CompileInfo a -> CompileInfo ()   check c     | isCompileError c = return ()-    | otherwise = compileError $ prefix ++ ": Expected failure\n"+    | otherwise = compileErrorM $ prefix ++ ": Expected failure\n"  data Resolver = Resolver @@ -721,21 +833,21 @@   Map.Map CategoryName (Map.Map CategoryName (InstanceParams -> InstanceParams))   -> TypeInstance -> CategoryName -> m InstanceParams getParams ma (TypeInstance n1 ps1) n2 = do-  ra <- mapLookup ma n1-  f <- mapLookup ra n2+  ra <- mapLookup ma n1 `reviseErrorM` ("In lookup of category " ++ show n1)+  f <- mapLookup ra n2 `reviseErrorM` ("In lookup of parent " ++ show n2 ++ " of " ++ show n1)   return $ f ps1  getTypeFilters :: CompileErrorM m => TypeInstance -> m InstanceFilters-getTypeFilters (TypeInstance n ps) = do+getTypeFilters (TypeInstance n ps) = flip reviseErrorM "In type filters lookup" $ do   f <- mapLookup typeFilters n   return $ f ps  getDefinesFilters :: CompileErrorM m => DefinesInstance -> m InstanceFilters-getDefinesFilters (DefinesInstance n ps) = do+getDefinesFilters (DefinesInstance n ps) = flip reviseErrorM "In defines filters lookup" $ do   f <- mapLookup definesFilters n   return $ f ps  mapLookup :: (Ord n, Show n, CompileErrorM m) => Map.Map n a -> n -> m a mapLookup ma n = resolve $ n `Map.lookup` ma where   resolve (Just x) = return x-  resolve _        = compileError $ "Map key " ++ show n ++ " not found"+  resolve _        = compileErrorM $ "Map key " ++ show n ++ " not found"

@@ -5,16 +5,6 @@  @value interface Object2 {} -@value interface Object3<#x> {-  refines Object2-}--@value interface Parent<#x> {-  refines Object1<#x,Object3<Object2>>-  // -> refines Object3<Object3<Object2>>-  // -> refines Object2-}- @type interface Type<#x> {}  concrete Child {@@ -24,4 +14,14 @@   // -> refines Object2    defines Type<Child>+}++@value interface Parent<#x> {+  refines Object1<#x,Object3<Object2>>+  // -> refines Object3<Object3<Object2>>+  // -> refines Object2+}++@value interface Object3<#x> {+  refines Object2 }

@@ -0,0 +1,19 @@+@value interface Interface1<|#x> {}++@value interface Interface2<#y|> {}++@value interface Interface3<#z> {+  refines Interface1<Type1>+}++@value interface Interface4<#x|#y|#z> {}++@value interface Type0 {}++@value interface Type1 {+  refines Type0+}++@value interface Type2 {+  refines Type1+}

@@ -90,7 +90,7 @@     case n `Map.lookup` fa' of          Nothing -> return $ Map.insert n f fa'          (Just f0@(ScopedFunction c2 _ _ _ _ _ _ _ ms2)) -> do-           flip reviseError ("In function merge:\n---\n" ++ show f0 +++           flip reviseErrorM ("In function merge:\n---\n" ++ show f0 ++                              "\n  ->\n" ++ show f ++ "\n---\n") $ do              f0' <- parsedToFunctionType f0              f' <- parsedToFunctionType f@@ -110,7 +110,7 @@       case epName p `Map.lookup` pa' of            Nothing -> return ()            -- TODO: The error might show things in the wrong order.-           (Just p0) -> compileError $ "Procedure " ++ show (epName p) +++           (Just p0) -> compileErrorM $ "Procedure " ++ show (epName p) ++                                        formatFullContextBrace (epContext p) ++                                        " is already defined" ++                                        formatFullContextBrace (epContext p0)@@ -120,15 +120,15 @@       p <- getPair (n `Map.lookup` fa2) (n `Map.lookup` pa)       return (p:ps2')     getPair (Just f) Nothing =-      compileError $ "Function " ++ show (sfName f) +++      compileErrorM $ "Function " ++ show (sfName f) ++                      formatFullContextBrace (sfContext f) ++                      " has no procedure definition"     getPair Nothing (Just p) =-      compileError $ "Procedure " ++ show (epName p) +++      compileErrorM $ "Procedure " ++ show (epName p) ++                      formatFullContextBrace (epContext p) ++                      " does not correspond to a function"     getPair (Just f) (Just p) = do-      processPairs_ alwaysPair (sfArgs f) (avNames $ epArgs p) `reviseError`+      processPairs_ alwaysPair (sfArgs f) (avNames $ epArgs p) `reviseErrorM`         ("Procedure for " ++ show (sfName f) ++          formatFullContextBrace (avContext $ epArgs p) ++          " has the wrong number of arguments" ++@@ -136,7 +136,7 @@       if isUnnamedReturns (epReturns p)          then return ()          else do-           processPairs_ alwaysPair (sfReturns f) (nrNames $ epReturns p) `reviseError`+           processPairs_ alwaysPair (sfReturns f) (nrNames $ epReturns p) `reviseErrorM`              ("Procedure for " ++ show (sfName f) ++               formatFullContextBrace (nrContext $ epReturns p) ++               " has the wrong number of returns" ++@@ -153,7 +153,7 @@     case dmName m `Map.lookup` ma' of          Nothing ->  return ()          -- TODO: The error might show things in the wrong order.-         (Just m0) -> compileError $ "Member " ++ show (dmName m) +++         (Just m0) -> compileErrorM $ "Member " ++ show (dmName m) ++                                      formatFullContextBrace (dmContext m) ++                                      " is already defined" ++                                      formatFullContextBrace (vvContext m0)

@@ -70,28 +70,28 @@   where     allVariances = Map.union vm (Map.fromList $ zip (pValues ps) (repeat Invariant))     checkCount xa@(x:_:_) =-      compileError $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++ " times"+      compileErrorM $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++ " times"     checkCount _ = return ()     checkHides n =       when (n `Map.member` fm) $-        compileError $ "Param " ++ show n ++ " hides another param in a higher scope"+        compileErrorM $ "Param " ++ show n ++ " hides another param in a higher scope"     checkFilterType fa2 (n,f) =-      validateTypeFilter r fa2 f `reviseError` ("In filter " ++ show n ++ " " ++ show f)+      validateTypeFilter r fa2 f `reviseErrorM` ("In filter " ++ show n ++ " " ++ show f)     checkFilterVariance (n,f@(TypeFilter FilterRequires t)) =-      validateInstanceVariance r allVariances Contravariant (SingleType t) `reviseError`+      validateInstanceVariance r allVariances Contravariant (SingleType t) `reviseErrorM`         ("In filter " ++ show n ++ " " ++ show f)     checkFilterVariance (n,f@(TypeFilter FilterAllows t)) =-      validateInstanceVariance r allVariances Covariant (SingleType t) `reviseError`+      validateInstanceVariance r allVariances Covariant (SingleType t) `reviseErrorM`         ("In filter " ++ show n ++ " " ++ show f)     checkFilterVariance (n,f@(DefinesFilter t)) =-      validateDefinesVariance r allVariances Contravariant t `reviseError`+      validateDefinesVariance r allVariances Contravariant t `reviseErrorM`         ("In filter " ++ show n ++ " " ++ show f)-    checkArg fa2 ta@(ValueType _ t) = flip reviseError ("In argument " ++ show ta) $ do-      when (isWeakValue ta) $ compileError "Weak values not allowed as argument types"+    checkArg fa2 ta@(ValueType _ t) = flip reviseErrorM ("In argument " ++ show ta) $ do+      when (isWeakValue ta) $ compileErrorM "Weak values not allowed as argument types"       validateGeneralInstance r fa2 t       validateInstanceVariance r allVariances Contravariant t-    checkReturn fa2 ta@(ValueType _ t) = flip reviseError ("In return " ++ show ta) $ do-      when (isWeakValue ta) $ compileError "Weak values not allowed as return types"+    checkReturn fa2 ta@(ValueType _ t) = flip reviseErrorM ("In return " ++ show ta) $ do+      when (isWeakValue ta) $ compileErrorM "Weak values not allowed as return types"       validateGeneralInstance r fa2 t       validateInstanceVariance r allVariances Covariant t @@ -102,15 +102,15 @@   mergeAllM $ map (validateGeneralInstance r fm) $ pValues ts   assigned <- fmap Map.fromList $ processPairs alwaysPair ps ts   let allAssigned = Map.union assigned (Map.fromList $ map (\n -> (n,SingleType $ JustParamName n)) $ Map.keys fm)-  fa' <- fmap Positional $ collectAllOrErrorM $ map (assignFilters allAssigned) (pValues fa)+  fa' <- fmap Positional $ mapErrorsM (assignFilters allAssigned) (pValues fa)   processPairs_ (validateAssignment r fm) ts fa'-  as' <- fmap Positional $ collectAllOrErrorM $-         map (uncheckedSubValueType $ getValueForParam allAssigned) (pValues as)-  rs' <- fmap Positional $ collectAllOrErrorM $-         map (uncheckedSubValueType $ getValueForParam allAssigned) (pValues rs)+  as' <- fmap Positional $+         mapErrorsM (uncheckedSubValueType $ getValueForParam allAssigned) (pValues as)+  rs' <- fmap Positional $+         mapErrorsM (uncheckedSubValueType $ getValueForParam allAssigned) (pValues rs)   return $ FunctionType as' rs' (Positional []) (Positional [])   where-    assignFilters fm2 fs = collectAllOrErrorM $ map (uncheckedSubFilter $ getValueForParam fm2) fs+    assignFilters fm2 fs = mapErrorsM (uncheckedSubFilter $ getValueForParam fm2) fs  checkFunctionConvert :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> FunctionType -> FunctionType -> m ()

@@ -21,12 +21,14 @@   alwaysPair,   processPairs,   processPairs_,+  processPairsM,   processPairsT, ) where  import Control.Monad.Trans (MonadTrans(..))  import Base.CompileError+import Base.Mergeable   newtype Positional a =@@ -45,9 +47,13 @@   (a -> b -> m c) -> Positional a -> Positional b -> m [c] processPairs f (Positional ps1) (Positional ps2)   | length ps1 == length ps2 =-    collectAllOrErrorM $ map (uncurry f) (zip ps1 ps2)+    mapErrorsM (uncurry f) (zip ps1 ps2)   | otherwise = mismatchError ps1 ps2 +processPairsM :: (Show a, Show b, Mergeable c, CompileErrorM m) =>+  (a -> b -> m c) -> Positional a -> Positional b -> m c+processPairsM f x y = fmap mergeAll $ processPairs f x y+ processPairs_ :: (Show a, Show b, CompileErrorM m) =>   (a -> b -> m c) -> Positional a -> Positional b -> m () processPairs_ f xs ys = processPairs f xs ys >> return ()@@ -60,5 +66,5 @@   | otherwise = lift $ mismatchError ps1 ps2  mismatchError :: (Show a, Show b, CompileErrorM m) => [a] -> [b] -> m c-mismatchError ps1 ps2 = compileError $ "Count mismatch: " ++ show ps1 +++mismatchError ps1 ps2 = compileErrorM $ "Count mismatch: " ++ show ps1 ++                                        " (expected) vs. " ++ show ps2 ++ " (actual)"

@@ -29,6 +29,7 @@   FunctionSpec(..),   IfElifElse(..),   InputValue(..),+  InstanceOrInferred(..),   Operator(..),   OutputValue(..),   Procedure(..),@@ -211,8 +212,13 @@   UnqualifiedFunction   deriving (Show) +data InstanceOrInferred c =+  AssignedInstance [c] GeneralInstance |+  InferredInstance [c]+  deriving (Show)+ data FunctionSpec c =-  FunctionSpec [c] (FunctionQualifier c) FunctionName (Positional GeneralInstance)+  FunctionSpec [c] (FunctionQualifier c) FunctionName (Positional (InstanceOrInferred c))   deriving (Show)  data Operator c =@@ -228,7 +234,7 @@ getExpressionContext (InitializeValue c _ _ _) = c  data FunctionCall c =-  FunctionCall [c] FunctionName (Positional GeneralInstance) (Positional (Expression c))+  FunctionCall [c] FunctionName (Positional (InstanceOrInferred c)) (Positional (Expression c))   deriving (Show)  data ExpressionStart c =

@@ -56,6 +56,7 @@   getInstanceCategory,   getValueCategory,   includeNewTypes,+  inferParamTypes,   isInstanceInterface,   isDynamicNamespace,   isNoNamespace,@@ -64,6 +65,7 @@   isValueInterface,   mergeDefines,   mergeFunctions,+  mergeInferredTypes,   mergeRefines,   noDuplicateDefines,   noDuplicateRefines,@@ -82,6 +84,7 @@ import qualified Data.Set as Set  import Base.CompileError+import Base.MergeTree import Base.Mergeable import Types.Function import Types.GeneralType@@ -323,8 +326,8 @@         let pa = Map.fromList $ map (\r -> (tiName r,tiParams r)) $ map vrType $ getCategoryRefines t         ps2 <- case n2 `Map.lookup` pa of                     (Just x) -> return x-                    _ -> compileError $ "Category " ++ show n1 ++ " does not refine " ++ show n2-        fmap Positional $ collectAllOrErrorM $ map (subAllParams assigned) $ pValues ps2+                    _ -> compileErrorM $ "Category " ++ show n1 ++ " does not refine " ++ show n2+        fmap Positional $ mapErrorsM (subAllParams assigned) $ pValues ps2     trDefines (CategoryResolver tm) (TypeInstance n1 ps1) n2 = do       (_,t) <- getValueCategory tm ([],n1)       let params = map vpParam $ getCategoryParams t@@ -332,8 +335,8 @@       let pa = Map.fromList $ map (\r -> (diName r,diParams r)) $ map vdType $ getCategoryDefines t       ps2 <- case n2 `Map.lookup` pa of                   (Just x) -> return x-                  _ -> compileError $ "Category " ++ show n1 ++ " does not define " ++ show n2-      fmap Positional $ collectAllOrErrorM $ map (subAllParams assigned) $ pValues ps2+                  _ -> compileErrorM $ "Category " ++ show n1 ++ " does not define " ++ show n2+      fmap Positional $ mapErrorsM (subAllParams assigned) $ pValues ps2     trVariance (CategoryResolver tm) n = do       (_,t) <- getCategory tm ([],n)       return $ Positional $ map vpVariance $ getCategoryParams t@@ -374,15 +377,15 @@ checkFilters t ps = do   let params = map vpParam $ getCategoryParams t   assigned <- fmap Map.fromList $ processPairs alwaysPair (Positional params) ps-  fs <- collectAllOrErrorM $ map (subSingleFilter assigned . \f -> (pfParam f,pfFilter f))+  fs <- mapErrorsM (subSingleFilter assigned . \f -> (pfParam f,pfFilter f))                                   (getCategoryFilters t)   let fa = Map.fromListWith (++) $ map (second (:[])) fs-  fmap Positional $ collectAllOrErrorM $ map (assignFilter fa) params where+  fmap Positional $ mapErrorsM (assignFilter fa) params where     subSingleFilter pa (n,(TypeFilter v t2)) = do       (SingleType t3) <- uncheckedSubInstance (getValueForParam pa) (SingleType t2)       return (n,(TypeFilter v t3))     subSingleFilter pa (n,(DefinesFilter (DefinesInstance n2 ps2))) = do-      ps3 <- collectAllOrErrorM $ map (uncheckedSubInstance $ getValueForParam pa) (pValues ps2)+      ps3 <- mapErrorsM (uncheckedSubInstance $ getValueForParam pa) (pValues ps2)       return (n,(DefinesFilter (DefinesInstance n2 (Positional ps3))))     assignFilter fa n =       case n `Map.lookup` fa of@@ -400,7 +403,7 @@ getCategory tm (c,n) =   case n `Map.lookup` tm of        (Just t) -> return (c,t)-       _ -> compileError $ "Type " ++ show n ++ context ++ " not found"+       _ -> compileErrorM $ "Type " ++ show n ++ context ++ " not found"   where     context       | null c = ""@@ -412,7 +415,7 @@   (c2,t) <- getCategory tm (c,n)   if isValueInterface t || isValueConcrete t      then return (c2,t)-     else compileError $ "Category " ++ show n +++     else compileErrorM $ "Category " ++ show n ++                          " cannot be used as a value" ++                          formatFullContextBrace c @@ -422,7 +425,7 @@   (c2,t) <- getCategory tm (c,n)   if isInstanceInterface t      then return (c2,t)-     else compileError $ "Category " ++ show n +++     else compileErrorM $ "Category " ++ show n ++                          " cannot be used as a type interface" ++                          formatFullContextBrace c @@ -432,7 +435,7 @@   (c2,t) <- getCategory tm (c,n)   if isValueConcrete t      then return (c2,t)-     else compileError $ "Category " ++ show n +++     else compileErrorM $ "Category " ++ show n ++                          " cannot be used as concrete" ++                          formatFullContextBrace c @@ -452,14 +455,11 @@ declareAllTypes tm0 = foldr (\t tm -> tm >>= update t) (return tm0) where   update t tm =     case getCategoryName t `Map.lookup` tm of-        (Just t2) -> compileError $ "Type " ++ show (getCategoryName t) ++-                                    formatFullContextBrace (getCategoryContext t) ++-                                    " has already been declared" ++-                                    showExisting t2+        (Just t2) -> compileErrorM $ "Type " ++ show (getCategoryName t) +++                                     formatFullContextBrace (getCategoryContext t) +++                                     " has already been declared" +++                                     formatFullContextBrace (getCategoryContext t2)         _ -> return $ Map.insert (getCategoryName t) t tm-  showExisting t-    | isBuiltinCategory (getCategoryName t) = " [builtin type]"-    | otherwise = formatFullContextBrace (getCategoryContext t)  getFilterMap :: [ValueParam c] -> [ParamFilter c] -> ParamFilters getFilterMap ps fs = getFilters $ zip (Set.toList pa) (repeat []) where@@ -482,14 +482,14 @@   where     checkSingle tm (ValueInterface c _ n _ rs _ _) = do       let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs-      is <- collectAllOrErrorM $ map (getCategory tm) ts2+      is <- mapErrorsM (getCategory tm) ts2       mergeAllM (map (valueRefinesInstanceError c n) is)       mergeAllM (map (valueRefinesConcreteError c n) is)     checkSingle tm (ValueConcrete c _ n _ rs ds _ _) = do       let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs       let ts3 = map (\d -> (vdContext d,diName $ vdType d)) ds-      is1 <- collectAllOrErrorM $ map (getCategory tm) ts2-      is2 <- collectAllOrErrorM $ map (getCategory tm) ts3+      is1 <- mapErrorsM (getCategory tm) ts2+      is2 <- mapErrorsM (getCategory tm) ts3       mergeAllM (map (concreteRefinesInstanceError c n) is1)       mergeAllM (map (concreteDefinesValueError c n) is2)       mergeAllM (map (concreteRefinesConcreteError c n) is1)@@ -497,39 +497,39 @@     checkSingle _ _ = return ()     valueRefinesInstanceError c n (c2,t)       | isInstanceInterface t =-        compileError $ "Value interface " ++ show n ++ formatFullContextBrace c ++-                      " cannot refine type interface " ++-                      show (iiName t) ++ formatFullContextBrace c2+        compileErrorM $ "Value interface " ++ show n ++ formatFullContextBrace c +++                        " cannot refine type interface " +++                        show (iiName t) ++ formatFullContextBrace c2       | otherwise = return ()     valueRefinesConcreteError c n (c2,t)       | isValueConcrete t =-        compileError $ "Value interface " ++ show n ++ formatFullContextBrace c ++-                      " cannot refine concrete type " ++-                      show (getCategoryName t) ++ formatFullContextBrace c2+        compileErrorM $ "Value interface " ++ show n ++ formatFullContextBrace c +++                        " cannot refine concrete type " +++                        show (getCategoryName t) ++ formatFullContextBrace c2       | otherwise = return ()     concreteRefinesInstanceError c n (c2,t)       | isInstanceInterface t =-        compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c ++-                      " cannot refine instance interface " ++-                      show (getCategoryName t) ++ formatFullContextBrace c2 ++-                      " => use defines instead"+        compileErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c +++                        " cannot refine instance interface " +++                        show (getCategoryName t) ++ formatFullContextBrace c2 +++                        " => use defines instead"       | otherwise = return ()     concreteDefinesValueError c n (c2,t)       | isValueInterface t =-        compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c +++        compileErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++                       " cannot define value interface " ++                       show (getCategoryName t) ++ formatFullContextBrace c2 ++                       " => use refines instead"       | otherwise = return ()     concreteRefinesConcreteError c n (c2,t)       | isValueConcrete t =-        compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c +++        compileErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++                       " cannot refine concrete type " ++                       show (getCategoryName t) ++ formatFullContextBrace c2       | otherwise = return ()     concreteDefinesConcreteError c n (c2,t)       | isValueConcrete t =-        compileError $ "Concrete type " ++ show n ++ formatFullContextBrace c +++        compileErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++                       " cannot define concrete type " ++                       show (getCategoryName t) ++ formatFullContextBrace c2       | otherwise = return ()@@ -541,17 +541,17 @@   checker us (ValueInterface c _ n _ rs _ _) = do     failIfCycle n c us     let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs-    is <- collectAllOrErrorM $ map (getValueCategory tm) ts2+    is <- mapErrorsM (getValueCategory tm) ts2     mergeAllM (map (checker (us ++ [n]) . snd) is)   checker us (ValueConcrete c _ n _ rs _ _ _) = do     failIfCycle n c us     let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs-    is <- collectAllOrErrorM $ map (getValueCategory tm) ts2+    is <- mapErrorsM (getValueCategory tm) ts2     mergeAllM (map (checker (us ++ [n]) . snd) is)   checker _ _ = return ()   failIfCycle n c us =     when (n `Set.member` (Set.fromList us)) $-      compileError $ "Category " ++ show n ++ formatFullContextBrace c +++      compileErrorM $ "Category " ++ show n ++ formatFullContextBrace c ++                      " refers back to itself: " ++                      intercalate " -> " (map show (us ++ [n])) @@ -579,37 +579,37 @@       mergeAllM $ map (checkFilterVariance r vm) fa     noDuplicates c n ps = mergeAllM (map checkCount $ group $ sort $ map vpParam ps) where       checkCount xa@(x:_:_) =-        compileError $ "Param " ++ show x ++ " occurs " ++ show (length xa) +++        compileErrorM $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++                       " times in " ++ show n ++ formatFullContextBrace c       checkCount _ = return ()     checkRefine r vm (ValueRefine c t) =-      validateInstanceVariance r vm Covariant (SingleType $ JustTypeInstance t) `reviseError`+      validateInstanceVariance r vm Covariant (SingleType $ JustTypeInstance t) `reviseErrorM`         (show t ++ formatFullContextBrace c)     checkDefine r vm (ValueDefine c t) =-      validateDefinesVariance r vm Covariant t `reviseError`+      validateDefinesVariance r vm Covariant t `reviseErrorM`         (show t ++ formatFullContextBrace c)     checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterRequires t)) =-      flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do+      flip reviseErrorM ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do         case n `Map.lookup` vs of-             Just Contravariant -> compileError $ "Contravariant param " ++ show n +++             Just Contravariant -> compileErrorM $ "Contravariant param " ++ show n ++                                                   " cannot have a requires filter"-             Nothing -> compileError $ "Param " ++ show n ++ " is undefined"+             Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined"              _ -> return ()         validateInstanceVariance r vs Contravariant (SingleType t)     checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterAllows t)) =-      flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do+      flip reviseErrorM ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do         case n `Map.lookup` vs of-             Just Covariant -> compileError $ "Covariant param " ++ show n +++             Just Covariant -> compileErrorM $ "Covariant param " ++ show n ++                                               " cannot have an allows filter"-             Nothing -> compileError $ "Param " ++ show n ++ " is undefined"+             Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined"              _ -> return ()         validateInstanceVariance r vs Covariant (SingleType t)     checkFilterVariance r vs (ParamFilter c n f@(DefinesFilter t)) =-      flip reviseError ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do+      flip reviseErrorM ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do         case n `Map.lookup` vs of-             Just Contravariant -> compileError $ "Contravariant param " ++ show n +++             Just Contravariant -> compileErrorM $ "Contravariant param " ++ show n ++                                                   " cannot have a defines filter"-             Nothing -> compileError $ "Param " ++ show n ++ " is undefined"+             Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined"              _ -> return ()         validateDefinesVariance r vs Contravariant t @@ -630,15 +630,15 @@       mergeAllM $ map (validateCategoryFunction r t) (getCategoryFunctions t)     checkFilterParam pa (ParamFilter c n _) =       when (not $ n `Set.member` pa) $-        compileError $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist"+        compileErrorM $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist"     checkRefine r fm (ValueRefine c t) =-      validateTypeInstance r fm t `reviseError`+      validateTypeInstance r fm t `reviseErrorM`         (show t ++ formatFullContextBrace c)     checkDefine r fm (ValueDefine c t) =-      validateDefinesInstance r fm t `reviseError`+      validateDefinesInstance r fm t `reviseErrorM`         (show t ++ formatFullContextBrace c)     checkFilter r fm (ParamFilter c n f) =-      validateTypeFilter r fm f `reviseError`+      validateTypeFilter r fm f `reviseErrorM`         (show n ++ " " ++ show f ++ formatFullContextBrace c)  validateCategoryFunction :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -646,7 +646,7 @@ validateCategoryFunction r t f = do   let fm = getCategoryFilterMap t   let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t-  flip reviseError ("In function:\n---\n" ++ show f ++ "\n---\n") $ do+  flip reviseErrorM ("In function:\n---\n" ++ show f ++ "\n---\n") $ do     funcType <- parsedToFunctionType f     case sfScope f of          CategoryScope -> validatateFunctionType r Map.empty Map.empty funcType@@ -658,49 +658,43 @@   CategoryMap c -> [AnyCategory c] -> m [AnyCategory c] topoSortCategories tm0 ts = do   tm <- declareAllTypes tm0 ts-  (ts',_) <- foldr (update tm) (return ([],Map.keysSet tm0)) ts-  return ts'+  fmap fst $ update tm (Map.keysSet tm0) ts   where-    update tm t u = do-      (_,ta) <- u+    update tm ta (t:ts2) = do       if getCategoryName t `Set.member` ta-         then u+         then update tm ta ts2          else do-          refines <- collectAllOrErrorM $-                    map (\r -> getCategory tm (vrContext r,tiName $ vrType r)) $ getCategoryRefines t-          defines <- collectAllOrErrorM $-                    map (\d -> getCategory tm (vdContext d,diName $ vdType d)) $ getCategoryDefines t-          (ts',ta') <- foldr (update tm) u (map snd $ refines ++ defines)-          let ts'' = ts' ++ [t]-          let ta'' = Set.insert (getCategoryName t) ta'-          return (ts'',ta'')+           refines <- mapErrorsM (\r -> getCategory tm (vrContext r,tiName $ vrType r)) $ getCategoryRefines t+           defines <- mapErrorsM (\d -> getCategory tm (vdContext d,diName $ vdType d)) $ getCategoryDefines t+           (ts3,ta2) <- update tm (getCategoryName t `Set.insert` ta) (map snd $ refines ++ defines)+           (ts4,ta3) <- update tm ta2 ts2+           return (ts3 ++ [t] ++ ts4,ta3)+    update _ ta _ = return ([],ta)  mergeObjects :: (MergeableM m, CompileErrorM m) =>   (a -> a -> m ()) -> [a] -> m [a]-mergeObjects f = return . merge [] where-  merge cs [] = cs-  merge cs (x:xs) = merge (cs ++ ys) xs where-    -- TODO: Should f just perform merging? In case we want to preserve info-    -- about what was merged, e.g., return m [(p,a)].-    checker x2 = f x2 x-    ys = if isCompileError $ mergeAnyM (map checker (cs ++ xs))-            then [x] -- x is not redundant => keep.-            else []  -- x is redundant => remove.+mergeObjects f = merge [] where+  merge cs [] = return cs+  merge cs (x:xs) = do+    ys <- collectOneOrErrorM $ map check (cs ++ xs) ++ [return [x]]+    merge (cs ++ ys) xs where+      check x2 = x2 `f` x >> return []  mergeRefines :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> [ValueRefine c] -> m [ValueRefine c] mergeRefines r f = mergeObjects check where   check (ValueRefine _ t1@(TypeInstance n1 _)) (ValueRefine _ t2@(TypeInstance n2 _))-    | n1 /= n2 = compileError $ show t1 ++ " and " ++ show t2 ++ " are incompatible"-    | otherwise = do-      checkGeneralMatch r f Covariant (SingleType $ JustTypeInstance $ t1)-                                      (SingleType $ JustTypeInstance $ t2)+    | n1 /= n2 = compileErrorM $ show t1 ++ " and " ++ show t2 ++ " are incompatible"+    | otherwise =+      noInferredTypes $ checkGeneralMatch r f Covariant+                        (SingleType $ JustTypeInstance $ t1)+                        (SingleType $ JustTypeInstance $ t2)  mergeDefines :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> [ValueDefine c] -> m [ValueDefine c] mergeDefines r f = mergeObjects check where   check (ValueDefine _ t1@(DefinesInstance n1 _)) (ValueDefine _ t2@(DefinesInstance n2 _))-    | n1 /= n2 = compileError $ show t1 ++ " and " ++ show t2 ++ " are incompatible"+    | n1 /= n2 = compileErrorM $ show t1 ++ " and " ++ show t2 ++ " are incompatible"     | otherwise = do       checkDefinesMatch r f t1 t2       return ()@@ -723,7 +717,7 @@   mergeAllM $ map checkCount $ groupBy (\x y -> fst x == fst y) $                                sortBy (\x y -> fst x `compare` fst y) ns where     checkCount xa@(x:_:_) =-      compileError $ "Category " ++ show (fst x) ++ " occurs " ++ show (length xa) +++      compileErrorM $ "Category " ++ show (fst x) ++ " occurs " ++ show (length xa) ++                       " times in " ++ show n ++ formatFullContextBrace c ++ " :\n---\n" ++                       intercalate "\n---\n" (map (show . snd) xa)     checkCount _ = return ()@@ -742,21 +736,21 @@       t' <- preMergeSingle tm t       return $ Map.insert (getCategoryName t') t' tm     preMergeSingle tm (ValueInterface c ns n ps rs vs fs) = do-      rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs+      rs' <- fmap concat $ mapErrorsM (getRefines tm) rs       return $ ValueInterface c ns n ps rs' vs fs     preMergeSingle tm (ValueConcrete c ns n ps rs ds vs fs) = do-      rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs+      rs' <- fmap concat $ mapErrorsM (getRefines tm) rs       return $ ValueConcrete c ns n ps rs' ds vs fs     preMergeSingle _ t = return t     update r t u = do       (ts2,tm) <- u-      t' <- updateSingle r tm t `reviseError`+      t' <- updateSingle r tm t `reviseErrorM`               ("In category " ++ show (getCategoryName t) ++                formatFullContextBrace (getCategoryContext t))       return (ts2 ++ [t'],Map.insert (getCategoryName t') t' tm)     updateSingle r tm t@(ValueInterface c ns n ps rs vs fs) = do       let fm = getCategoryFilterMap t-      rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs+      rs' <- fmap concat $ mapErrorsM (getRefines tm) rs       rs'' <- mergeRefines r fm rs'       noDuplicateRefines c n rs''       checkMerged r fm rs rs''@@ -766,7 +760,7 @@     -- TODO: Remove duplication below and/or have separate tests.     updateSingle r tm t@(ValueConcrete c ns n ps rs ds vs fs) = do       let fm = getCategoryFilterMap t-      rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs+      rs' <- fmap concat $ mapErrorsM (getRefines tm) rs       rs'' <- mergeRefines r fm rs'       noDuplicateRefines c n rs''       checkMerged r fm rs rs''@@ -780,7 +774,7 @@       (_,v) <- getValueCategory tm (c,n)       let refines = getCategoryRefines v       pa <- assignParams tm c t-      fmap (ra:) $ collectAllOrErrorM $ map (subAll c pa) refines+      fmap (ra:) $ mapErrorsM (subAll c pa) refines     subAll c pa (ValueRefine c1 t1) = do       (SingleType (JustTypeInstance t2)) <-         uncheckedSubInstance (getValueForParam pa) (SingleType (JustTypeInstance t1))@@ -794,9 +788,10 @@       let rm = Map.fromList $ map (\t -> (tiName $ vrType t,t)) rs       mergeAllM $ map (\t -> checkConvert r fm (tiName (vrType t) `Map.lookup` rm) t) rs2     checkConvert r fm (Just ta1@(ValueRefine _ t1)) ta2@(ValueRefine _ t2) = do-      checkGeneralMatch r fm Covariant (SingleType $ JustTypeInstance t1)-                                       (SingleType $ JustTypeInstance t2) `reviseError`-        ("Cannot refine " ++ show ta1 ++ " from inherited " ++ show ta2)+      noInferredTypes $ checkGeneralMatch r fm Covariant+                        (SingleType $ JustTypeInstance t1)+                        (SingleType $ JustTypeInstance t2) `reviseErrorM`+                        ("Cannot refine " ++ show ta1 ++ " from inherited " ++ show ta2)       return ()     checkConvert _ _ _ _ = return () @@ -804,39 +799,39 @@   r -> CategoryMap c -> ParamFilters -> [ValueRefine c] ->   [ValueDefine c] -> [ScopedFunction c] -> m [ScopedFunction c] mergeFunctions r tm fm rs ds fs = do-  inheritValue <- fmap concat $ collectAllOrErrorM $ map (getRefinesFuncs tm) rs-  inheritType  <- fmap concat $ collectAllOrErrorM $ map (getDefinesFuncs tm) ds+  inheritValue <- fmap concat $ mapErrorsM (getRefinesFuncs tm) rs+  inheritType  <- fmap concat $ mapErrorsM (getDefinesFuncs tm) ds   let inheritByName  = Map.fromListWith (++) $ map (\f -> (sfName f,[f])) $ inheritValue ++ inheritType   let explicitByName = Map.fromListWith (++) $ map (\f -> (sfName f,[f])) fs   let allNames = Set.toList $ Set.union (Map.keysSet inheritByName) (Map.keysSet explicitByName)-  collectAllOrErrorM $ map (mergeByName r fm inheritByName explicitByName) allNames where-    getRefinesFuncs tm2 ra@(ValueRefine c (TypeInstance n ts2)) = flip reviseError (show ra) $ do+  mapErrorsM (mergeByName r fm inheritByName explicitByName) allNames where+    getRefinesFuncs tm2 ra@(ValueRefine c (TypeInstance n ts2)) = flip reviseErrorM (show ra) $ do       (_,t) <- getValueCategory tm2 (c,n)       let ps = map vpParam $ getCategoryParams t       let fs2 = getCategoryFunctions t       paired <- processPairs alwaysPair (Positional ps) ts2       let assigned = Map.fromList paired-      collectAllOrErrorM (map (uncheckedSubFunction assigned) fs2)-    getDefinesFuncs tm2 da@(ValueDefine c (DefinesInstance n ts2)) = flip reviseError (show da) $  do+      mapErrorsM (uncheckedSubFunction assigned) fs2+    getDefinesFuncs tm2 da@(ValueDefine c (DefinesInstance n ts2)) = flip reviseErrorM (show da) $  do       (_,t) <- getInstanceCategory tm2 (c,n)       let ps = map vpParam $ getCategoryParams t       let fs2 = getCategoryFunctions t       paired <- processPairs alwaysPair (Positional ps) ts2       let assigned = Map.fromList paired-      collectAllOrErrorM (map (uncheckedSubFunction assigned) fs2)+      mapErrorsM (uncheckedSubFunction assigned) fs2     mergeByName r2 fm2 im em n =       tryMerge r2 fm2 n (n `Map.lookup` im) (n `Map.lookup` em)     -- Inherited without an override.     tryMerge _ _ n (Just is) Nothing       | length is == 1 = return $ head is-      | otherwise = compileError $ "Function " ++ show n ++ " is inherited " +++      | otherwise = compileErrorM $ "Function " ++ show n ++ " is inherited " ++                                    show (length is) ++ " times:\n---\n" ++                                    intercalate "\n---\n" (map show is)     -- Not inherited.     tryMerge r2 fm2 n Nothing es = tryMerge r2 fm2 n (Just []) es     -- Explicit override, possibly inherited.     tryMerge r2 fm2 n (Just is) (Just es)-      | length es /= 1 = compileError $ "Function " ++ show n ++ " is declared " +++      | length es /= 1 = compileErrorM $ "Function " ++ show n ++ " is declared " ++                                         show (length es) ++ " times:\n---\n" ++                                         intercalate "\n---\n" (map show es)       | otherwise = do@@ -846,11 +841,11 @@         where           checkMerge r3 fm3 f1 f2             | sfScope f1 /= sfScope f2 =-              compileError $ "Cannot merge " ++ show (sfScope f2) ++ " with " +++              compileErrorM $ "Cannot merge " ++ show (sfScope f2) ++ " with " ++                              show (sfScope f1) ++ " in function merge:\n---\n" ++                              show f2 ++ "\n  ->\n" ++ show f1             | otherwise =-              flip reviseError ("In function merge:\n---\n" ++ show f2 +++              flip reviseErrorM ("In function merge:\n---\n" ++ show f2 ++                                 "\n  ->\n" ++ show f1 ++ "\n---\n") $ do                 f1' <- parsedToFunctionType f1                 f2' <- parsedToFunctionType f2@@ -933,7 +928,7 @@     pa = Set.fromList $ map vpParam $ pValues ps     checkFilter f =       when (not $ (pfParam f) `Set.member` pa) $-      compileError $ "Filtered param " ++ show (pfParam f) +++      compileErrorM $ "Filtered param " ++ show (pfParam f) ++                      " is not defined for function " ++ show n ++                      formatFullContextBrace c     getFilters fm2 n2 =@@ -944,13 +939,13 @@ uncheckedSubFunction :: (Show c, MergeableM m, CompileErrorM m) =>   Map.Map ParamName GeneralInstance -> ScopedFunction c -> m (ScopedFunction c) uncheckedSubFunction pa ff@(ScopedFunction c n t s as rs ps fa ms) =-  flip reviseError ("In function:\n---\n" ++ show ff ++ "\n---\n") $ do+  flip reviseErrorM ("In function:\n---\n" ++ show ff ++ "\n---\n") $ do     let fixed = Map.fromList $ map (\n2 -> (n2,SingleType $ JustParamName n2)) $ map vpParam $ pValues ps     let pa' = Map.union pa fixed-    as' <- fmap Positional $ collectAllOrErrorM $ map (subPassed pa') $ pValues as-    rs' <- fmap Positional $ collectAllOrErrorM $ map (subPassed pa') $ pValues rs-    fa' <- collectAllOrErrorM $ map (subFilter pa') fa-    ms' <- collectAllOrErrorM $ map (uncheckedSubFunction pa) ms+    as' <- fmap Positional $ mapErrorsM (subPassed pa') $ pValues as+    rs' <- fmap Positional $ mapErrorsM (subPassed pa') $ pValues rs+    fa' <- mapErrorsM (subFilter pa') fa+    ms' <- mapErrorsM (uncheckedSubFunction pa) ms     return $ (ScopedFunction c n t s as' rs' ps fa' ms')     where       subPassed pa2 (PassedValue c2 t2) = do@@ -959,3 +954,59 @@       subFilter pa2 (ParamFilter c2 n2 f) = do         f' <- uncheckedSubFilter (getValueForParam pa2) f         return $ ParamFilter c2 n2 f'++inferParamTypes :: (MergeableM m, CompileErrorM m, TypeResolver r) =>+  r -> ParamFilters -> Map.Map ParamName GeneralInstance ->+  [(ValueType,ValueType)] -> m (Map.Map ParamName GeneralInstance)+inferParamTypes r f ps ts = do+  ts2 <- mapErrorsM subAll ts+  f2  <- fmap Map.fromList $ mapErrorsM filterSub $ Map.toList f+  gs  <- mergeAllM $ map (uncurry $ checkValueTypeMatch r f2) ts2+  let gs2 = concat $ map (filtersToGuess f2) $ Map.elems ps+  let gs3 = mergeAll $ gs:(map mergeLeaf gs2)+  gs4 <- mergeInferredTypes r f2 gs3+  let ga = Map.fromList $ zip (map itgParam gs4) (map itgGuess gs4)+  return $ ga `Map.union` ps where+    subAll (t1,t2) = do+      t2' <- uncheckedSubValueType (getValueForParam ps) t2+      return (t1,t2')+    filterSub (k,fs) = do+      fs' <- mapErrorsM (uncheckedSubFilter (getValueForParam ps)) fs+      return (k,fs')+    filtersToGuess f2 (SingleType (JustInferredType p)) =+      case p `Map.lookup` f2 of+           Nothing -> []+           Just fs -> concat $ map (filterToGuess p) fs+    filtersToGuess _ _ = []+    filterToGuess p (TypeFilter FilterRequires t) =+      [InferredTypeGuess p (SingleType t) Contravariant]+    filterToGuess p (TypeFilter FilterAllows t) =+      [InferredTypeGuess p (SingleType t) Covariant]+    filterToGuess _ _ = []++mergeInferredTypes :: (MergeableM m, CompileErrorM m, TypeResolver r) =>+  r -> ParamFilters -> MergeTree InferredTypeGuess -> m [InferredTypeGuess]+mergeInferredTypes r f = reduceMergeTree anyOp allOp leafOp where+  leafOp i = noInferred (itgGuess i) >> return [i]+  anyOp = mergeCommon anyCheck+  allOp = mergeCommon allCheck+  mergeCommon check is = do+    let ia = Map.fromListWith (++) $ zip (map itgParam is) (map (:[]) is)+    mergeAllM $ map (tryMerge check) $ Map.toList ia+  tryMerge check (i,is) = do+    is' <- mergeObjects check is+    case is' of+         []   -> undefined  -- Shouldn't happen.+         [i2] -> return [i2]+         is2  -> compileErrorM $ "Could not reconcile guesses for " ++ show i +++                                 ": " ++ show is2+  noInferred (TypeMerge _ ts) = mergeAllM $ map noInferred ts+  noInferred (SingleType (JustTypeInstance (TypeInstance _ (Positional ts)))) = mergeAllM $ map noInferred ts+  noInferred (SingleType (JustInferredType i)) = compileErrorM $ "Failed to infer " ++ show i+  noInferred _ = return ()+  anyCheck (InferredTypeGuess _ g1 v1) (InferredTypeGuess _ g2 _) =+    -- Find the least-general guess: If g1 can be replaced with g2, prefer g1.+    noInferredTypes $ checkGeneralMatch r f v1 g1 g2+  allCheck (InferredTypeGuess _ g1 _) (InferredTypeGuess _ g2 v2) =+    -- Find the most-general guess: If g2 can be replaced with g1, prefer g1.+    noInferredTypes $ checkGeneralMatch r f v2 g2 g1

@@ -26,6 +26,7 @@   DefinesInstance(..),   FilterDirection(..),   GeneralInstance,+  InferredTypeGuess(..),   InstanceFilters,   InstanceParams,   InstanceVariances,@@ -41,6 +42,7 @@   checkDefinesMatch,   checkGeneralMatch,   checkValueTypeMatch,+  checkValueTypeMatch_,   uncheckedSubFilter,   uncheckedSubFilters,   uncheckedSubInstance,@@ -50,6 +52,7 @@   isDefinesFilter,   isRequiresFilter,   isWeakValue,+  noInferredTypes,   requiredParam,   requiredSingleton,   validateAssignment,@@ -61,11 +64,12 @@   validateTypeInstance, ) where -import Control.Monad (when)+import Control.Monad ((>=>),when) import Data.List (intercalate) import qualified Data.Map as Map  import Base.CompileError+import Base.MergeTree import Base.Mergeable import Types.GeneralType import Types.Positional@@ -172,18 +176,33 @@   show (DefinesInstance n (Positional ts)) =     show n ++ "<" ++ intercalate "," (map show ts) ++ ">" +data InferredTypeGuess =+  InferredTypeGuess {+    itgParam :: ParamName,+    itgGuess :: GeneralInstance,+    itgVariance :: Variance+  }+  deriving (Eq,Ord)++instance Show InferredTypeGuess where+  show (InferredTypeGuess n g v) = show n ++ " = " ++ show g ++ " (" ++ show v ++ ")"+ data TypeInstanceOrParam =   JustTypeInstance {     jtiType :: TypeInstance   } |   JustParamName {     jpnName :: ParamName+  } |+  JustInferredType {+    jitParam :: ParamName   }   deriving (Eq,Ord)  instance Show TypeInstanceOrParam where   show (JustTypeInstance t) = show t   show (JustParamName n)    = show n+  show (JustInferredType i) = show i ++ " /*inferred*/"  data FilterDirection =   FilterRequires |@@ -261,38 +280,58 @@   ParamFilters -> ParamName -> m [TypeFilter] filterLookup ps n = resolve $ n `Map.lookup` ps where   resolve (Just x) = return x-  resolve _        = compileError $ "Param " ++ show n ++ " not found"+  resolve _        = compileErrorM $ "Param " ++ show n ++ " not found"  getValueForParam :: (CompileErrorM m) =>   Map.Map ParamName GeneralInstance -> ParamName -> m GeneralInstance getValueForParam pa n =   case n `Map.lookup` pa of         (Just x) -> return x-        _ -> compileError $ "Param " ++ show n ++ " does not exist"+        _ -> compileErrorM $ "Param " ++ show n ++ " does not exist" -checkValueTypeMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) =>+noInferredTypes :: (MergeableM m, CompileErrorM m) => m (MergeTree InferredTypeGuess) -> m ()+noInferredTypes = id >=> reduceMergeTree return return message where+  message i = compileErrorM $ "Type guess " ++ show i ++ " not allowed here"++checkValueTypeMatch_ :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> ValueType -> ValueType -> m ()+checkValueTypeMatch_ r f t1 t2 = noInferredTypes $ checkValueTypeMatch r f t1 t2++checkValueTypeMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) =>+  r -> ParamFilters -> ValueType -> ValueType -> m (MergeTree InferredTypeGuess) checkValueTypeMatch r f ts1@(ValueType r1 t1) ts2@(ValueType r2 t2)   | r1 < r2 =-    compileError $ "Cannot convert " ++ show ts1 ++ " to " ++ show ts2-  | otherwise = checkGeneralMatch r f Covariant t1 t2 `reviseError`+    compileErrorM $ "Cannot convert " ++ show ts1 ++ " to " ++ show ts2+  | otherwise = checkGeneralMatch r f Covariant t1 t2 `reviseErrorM`       ("Cannot convert " ++ show ts1 ++ " to " ++ show ts2)  checkGeneralMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> Variance ->-  GeneralInstance -> GeneralInstance -> m ()-checkGeneralMatch r f Invariant ts1 ts2 = do+  GeneralInstance -> GeneralInstance -> m (MergeTree InferredTypeGuess)+checkGeneralMatch r f v (SingleType (JustInferredType p1)) t2 = do+  compileWarningM $ "Treating inferred parameter " ++ show p1 ++ " on the left as a regular parameter"+  checkGeneralMatch r f v (SingleType $ JustParamName p1) t2+checkGeneralMatch _ _ v t1 (SingleType (JustInferredType p2)) =+  return $ mergeLeaf $ InferredTypeGuess p2 t1 v+checkGeneralMatch r f Invariant ts1 ts2 =   -- This ensures that any and all behave as expected in Invariant positions.-  checkGeneralType (checkSingleMatch r f Covariant) ts1 ts2-  checkGeneralType (checkSingleMatch r f Covariant) ts2 ts1+  mergeAllM [checkGeneralMatch r f Covariant     ts1 ts2,+             checkGeneralMatch r f Contravariant ts1 ts2] checkGeneralMatch r f Contravariant ts1 ts2 =-  checkGeneralType (checkSingleMatch r f Covariant) ts2 ts1-checkGeneralMatch r f Covariant ts1 ts2 =-  checkGeneralType (checkSingleMatch r f Covariant) ts1 ts2+  -- NOTE: ts1 and ts2 can't be swapped in checkSingleMatch due to type+  -- inference; however, checkGeneralType is sensitive to which side the empty+  -- union or intersection is on.+  checkGeneralType (flip $ checkSingleMatch r f Contravariant) ts2 ts1+checkGeneralMatch r f v ts1 ts2 = checkGeneralType (checkSingleMatch r f v) ts1 ts2  checkSingleMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> Variance ->-  TypeInstanceOrParam -> TypeInstanceOrParam -> m ()+  TypeInstanceOrParam -> TypeInstanceOrParam -> m (MergeTree InferredTypeGuess)+checkSingleMatch r f v (JustInferredType p1) t2 = do+  compileWarningM $ "Treating inferred parameter " ++ show p1 ++ " on the left as a regular parameter"+  checkSingleMatch r f v (JustParamName p1) t2+checkSingleMatch _ _ v t1 (JustInferredType p2) =+  return $ mergeLeaf $ InferredTypeGuess p2 (SingleType t1) v checkSingleMatch r f v (JustTypeInstance t1) (JustTypeInstance t2) =   checkInstanceToInstance r f v t1 t2 checkSingleMatch r f v (JustParamName p1) (JustTypeInstance t2) =@@ -303,80 +342,105 @@   checkParamToParam r f v p1 p2  checkInstanceToInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>-  r -> ParamFilters -> Variance -> TypeInstance -> TypeInstance -> m ()+  r -> ParamFilters -> Variance -> TypeInstance -> TypeInstance -> m (MergeTree InferredTypeGuess) checkInstanceToInstance r f Invariant t1 t2     | t1 == t2 = mergeDefaultM     | otherwise =       -- Implicit equality, inferred by t1 <-> t2.       mergeAllM [checkInstanceToInstance r f Covariant     t1 t2,                  checkInstanceToInstance r f Contravariant t1 t2]-checkInstanceToInstance r f Contravariant t1 t2 =-  checkInstanceToInstance r f Covariant t2 t1+checkInstanceToInstance r f Contravariant t1@(TypeInstance n1 ps1) t2@(TypeInstance n2 ps2)+  | n1 == n2 = do+    paired <- processPairs alwaysPair ps1 ps2+    let zipped = Positional paired+    variance <- fmap (fmap (composeVariance Contravariant)) $ trVariance r n1+    processPairsM (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance zipped+  | otherwise = do+    ps2' <- trRefines r t2 n1+    checkInstanceToInstance r f Contravariant t1 (TypeInstance n1 ps2') checkInstanceToInstance r f Covariant t1@(TypeInstance n1 ps1) t2@(TypeInstance n2 ps2)   | n1 == n2 = do     paired <- processPairs alwaysPair ps1 ps2     let zipped = Positional paired-    variance <- trVariance r n1-    -- NOTE: Covariant is identity, so v2 has technically been composed with it.-    processPairs_ (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance zipped >> mergeDefaultM+    variance <- fmap (fmap (composeVariance Covariant)) $ trVariance r n1+    processPairsM (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance zipped   | otherwise = do     ps1' <- trRefines r t1 n2     checkInstanceToInstance r f Covariant (TypeInstance n2 ps1') t2  checkParamToInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>-  r -> ParamFilters -> Variance -> ParamName -> TypeInstance -> m ()+  r -> ParamFilters -> Variance -> ParamName -> TypeInstance -> m (MergeTree InferredTypeGuess) checkParamToInstance r f Invariant n1 t2 =   -- Implicit equality, inferred by n1 <-> t2.   mergeAllM [checkParamToInstance r f Covariant     n1 t2,              checkParamToInstance r f Contravariant n1 t2]-checkParamToInstance r f Contravariant p1 t2 =-  checkInstanceToParam r f Covariant t2 p1-checkParamToInstance r f Covariant n1 t2@(TypeInstance _ _) = do+checkParamToInstance r f v@Contravariant n1 t2@(TypeInstance _ _) = do+  cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n1+  mergeAnyM (map checkConstraintToInstance cs2) `reviseErrorM`+    ("No filters imply " ++ show t2 ++ " <- " ++ show n1 ++ " in " ++ show v ++ " contexts")+  where+    checkConstraintToInstance (TypeFilter FilterAllows t) =+      -- F -> x implies T -> x only if T -> F+      checkSingleMatch r f v t (JustTypeInstance t2)+    checkConstraintToInstance f2 =+      -- x -> F cannot imply T -> x+      compileErrorM $ "Constraint " ++ viewTypeFilter n1 f2 +++                      " does not imply " ++ show t2 ++ " <- " ++ show n1+checkParamToInstance r f v@Covariant n1 t2@(TypeInstance _ _) = do   cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n1-  mergeAnyM (map checkConstraintToInstance cs1) `reviseError`-    ("No filters imply " ++ show n1 ++ " -> " ++ show t2)+  mergeAnyM (map checkConstraintToInstance cs1) `reviseErrorM`+    ("No filters imply " ++ show n1 ++ " -> " ++ show t2 ++ " in " ++ show v ++ " contexts")   where     checkConstraintToInstance (TypeFilter FilterRequires t) =       -- x -> F implies x -> T only if F -> T-      checkSingleMatch r f Covariant t (JustTypeInstance t2)+      checkSingleMatch r f v t (JustTypeInstance t2)     checkConstraintToInstance f2 =       -- F -> x cannot imply x -> T       -- DefinesInstance cannot be converted to TypeInstance-      compileError $ "Constraint " ++ viewTypeFilter n1 f2 ++-                    " does not imply " ++ show n1 ++ " -> " ++ show t2+      compileErrorM $ "Constraint " ++ viewTypeFilter n1 f2 +++                      " does not imply " ++ show n1 ++ " -> " ++ show t2  checkInstanceToParam :: (MergeableM m, CompileErrorM m, TypeResolver r) =>-  r -> ParamFilters -> Variance -> TypeInstance -> ParamName -> m ()+  r -> ParamFilters -> Variance -> TypeInstance -> ParamName -> m (MergeTree InferredTypeGuess) checkInstanceToParam r f Invariant t1 n2 =   -- Implicit equality, inferred by t1 <-> n2.   mergeAllM [checkInstanceToParam r f Covariant     t1 n2,              checkInstanceToParam r f Contravariant t1 n2]-checkInstanceToParam r f Contravariant t1 p2 =-  checkParamToInstance r f Covariant p2 t1-checkInstanceToParam r f Covariant t1@(TypeInstance _ _) n2 = do+checkInstanceToParam r f v@Contravariant t1@(TypeInstance _ _) n2 = do+  cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n2+  mergeAnyM (map checkInstanceToConstraint cs1) `reviseErrorM`+    ("No filters imply " ++ show n2 ++ " <- " ++ show t1 ++ " in " ++ show v ++ " contexts")+  where+    checkInstanceToConstraint (TypeFilter FilterRequires t) =+      -- x -> F implies x -> T only if F -> T+      checkSingleMatch r f v (JustTypeInstance t1) t+    checkInstanceToConstraint f2 =+      -- F -> x cannot imply x -> T+      -- DefinesInstance cannot be converted to TypeInstance+      compileErrorM $ "Constraint " ++ viewTypeFilter n2 f2 +++                      " does not imply " ++ show n2 ++ " <- " ++ show t1+checkInstanceToParam r f v@Covariant t1@(TypeInstance _ _) n2 = do   cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n2-  mergeAnyM (map checkInstanceToConstraint cs2) `reviseError`-    ("No filters imply " ++ show t1 ++ " -> " ++ show n2)+  mergeAnyM (map checkInstanceToConstraint cs2) `reviseErrorM`+    ("No filters imply " ++ show t1 ++ " -> " ++ show n2 ++ " in " ++ show v ++ " contexts")   where     checkInstanceToConstraint (TypeFilter FilterAllows t) =       -- F -> x implies T -> x only if T -> F-      checkSingleMatch r f Covariant (JustTypeInstance t1) t+      checkSingleMatch r f v (JustTypeInstance t1) t     checkInstanceToConstraint f2 =       -- x -> F cannot imply T -> x-      compileError $ "Constraint " ++ viewTypeFilter n2 f2 ++-                    " does not imply " ++ show t1 ++ " -> " ++ show n2+      compileErrorM $ "Constraint " ++ viewTypeFilter n2 f2 +++                      " does not imply " ++ show t1 ++ " -> " ++ show n2  checkParamToParam :: (MergeableM m, CompileErrorM m, TypeResolver r) =>-  r -> ParamFilters -> Variance -> ParamName -> ParamName -> m ()+  r -> ParamFilters -> Variance -> ParamName -> ParamName -> m (MergeTree InferredTypeGuess) checkParamToParam r f Invariant n1 n2     | n1 == n2 = mergeDefaultM     | otherwise =       -- Implicit equality, inferred by n1 <-> n2.       mergeAllM [checkParamToParam r f Covariant     n1 n2,                  checkParamToParam r f Contravariant n1 n2]-checkParamToParam r f Contravariant n1 n2 =-  checkParamToParam r f Covariant n2 n1-checkParamToParam r f Covariant n1 n2+checkParamToParam r f v n1 n2   | n1 == n2 = mergeDefaultM   | otherwise = do     cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n1@@ -384,44 +448,59 @@     let typeFilters = [(c1,c2) | c1 <- cs1, c2 <- cs2] ++                       [(self1,c2) | c2 <- cs2] ++                       [(c1,self2) | c1 <- cs1]-    mergeAnyM (map (\(c1,c2) -> checkConstraintToConstraint c1 c2) typeFilters) `reviseError`+    mergeAnyM (map (\(c1,c2) -> checkConstraintToConstraint v c1 c2) typeFilters) `reviseErrorM`       ("No filters imply " ++ show n1 ++ " -> " ++ show n2)     where-      self1 = TypeFilter FilterRequires (JustParamName n1)-      self2 = TypeFilter FilterAllows   (JustParamName n2)-      checkConstraintToConstraint (TypeFilter FilterRequires t1) (TypeFilter FilterAllows t2)+      self1+        | v == Covariant = TypeFilter FilterRequires (JustParamName n1)+        | otherwise      = TypeFilter FilterAllows   (JustParamName n1)+      self2+        | v == Covariant = TypeFilter FilterAllows   (JustParamName n2)+        | otherwise      = TypeFilter FilterRequires (JustParamName n2)+      checkConstraintToConstraint Covariant (TypeFilter FilterRequires t1) (TypeFilter FilterAllows t2)         | t1 == (JustParamName n1) && t2 == (JustParamName n2) =-          compileError $ "Infinite recursion in " ++ show n1 ++ " -> " ++ show n2+          compileErrorM $ "Infinite recursion in " ++ show n1 ++ " -> " ++ show n2         -- x -> F1, F2 -> y implies x -> y only if F1 -> F2         | otherwise = checkSingleMatch r f Covariant t1 t2-      checkConstraintToConstraint f1 f2 =+      checkConstraintToConstraint Covariant f1 f2 =         -- x -> F1, y -> F2 cannot imply x -> y         -- F1 -> x, F1 -> y cannot imply x -> y         -- F1 -> x, y -> F2 cannot imply x -> y-        compileError $ "Constraints " ++ viewTypeFilter n1 f1 ++ " and " ++-                      viewTypeFilter n2 f2 ++ " do not imply " ++-                      show n1 ++ " -> " ++ show n2+        compileErrorM $ "Constraints " ++ viewTypeFilter n1 f1 ++ " and " +++                        viewTypeFilter n2 f2 ++ " do not imply " +++                        show n1 ++ " -> " ++ show n2+      checkConstraintToConstraint Contravariant (TypeFilter FilterAllows t1) (TypeFilter FilterRequires t2)+        | t1 == (JustParamName n1) && t2 == (JustParamName n2) =+          compileErrorM $ "Infinite recursion in " ++ show n1 ++ " <- " ++ show n2+        -- x <- F1, F2 <- y implies x <- y only if F1 <- F2+        | otherwise = checkSingleMatch r f Contravariant t1 t2+      checkConstraintToConstraint Contravariant f1 f2 =+        -- x <- F1, y <- F2 cannot imply x <- y+        -- F1 <- x, F1 <- y cannot imply x <- y+        -- F1 <- x, y <- F2 cannot imply x <- y+        compileErrorM $ "Constraints " ++ viewTypeFilter n1 f1 ++ " and " +++                        viewTypeFilter n2 f2 ++ " do not imply " +++                        show n1 ++ " <- " ++ show n2+      checkConstraintToConstraint _ _ _ = undefined  validateGeneralInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> GeneralInstance -> m ()-validateGeneralInstance _ _ (TypeMerge _ ts)-  | length ts == 1 = compileError $ "Unions and intersections must have at least 2 types to avoid ambiguity"-validateGeneralInstance r f (TypeMerge MergeIntersect ts) =-  mergeAllM (map (validateGeneralInstance r f) ts)-validateGeneralInstance r f (TypeMerge _ ts) =-  mergeAllM (map (validateGeneralInstance r f) ts)+validateGeneralInstance r f (TypeMerge _ ts)+  | length ts == 1 = compileErrorM $ "Unions and intersections must have at least 2 types to avoid ambiguity"+  | otherwise      = mergeAllM (map (validateGeneralInstance r f) ts) validateGeneralInstance r f (SingleType (JustTypeInstance t)) =   validateTypeInstance r f t validateGeneralInstance _ f (SingleType (JustParamName n)) =   when (not $ n `Map.member` f) $-    compileError $ "Param " ++ show n ++ " does not exist"+    compileErrorM $ "Param " ++ show n ++ " does not exist"+validateGeneralInstance _ _ t = compileErrorM $ "Type " ++ show t ++ " contains unresolved types"  validateTypeInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> TypeInstance -> m () validateTypeInstance r f t@(TypeInstance _ ps) = do   fa <- trTypeFilters r t   processPairs_ (validateAssignment r f) ps fa-  mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseError`+  mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseErrorM`     ("Recursive error in " ++ show t)  validateDefinesInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -429,7 +508,7 @@ validateDefinesInstance r f t@(DefinesInstance _ ps) = do   fa <- trDefinesFilters r t   processPairs_ (validateAssignment r f) ps fa-  mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseError`+  mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseErrorM`     ("Recursive error in " ++ show t)  validateTypeFilter :: (MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -442,20 +521,21 @@ validateAssignment :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> GeneralInstance -> [TypeFilter] -> m () validateAssignment r f t fs = mergeAllM (map (checkFilter t) fs) where-  checkFilter t1 (TypeFilter FilterRequires t2) = do-    checkGeneralMatch r f Covariant t1 (SingleType t2)-  checkFilter t1 (TypeFilter FilterAllows t2) = do-    checkGeneralMatch r f Contravariant t1 (SingleType t2)+  checkFilter t1 (TypeFilter FilterRequires t2) =+    noInferredTypes $ checkGeneralMatch r f Covariant t1 (SingleType t2)+  checkFilter t1 (TypeFilter FilterAllows t2) =+    noInferredTypes $ checkGeneralMatch r f Contravariant t1 (SingleType t2)   checkFilter t1@(TypeMerge _ _) (DefinesFilter t2) =-    compileError $ "Merged type " ++ show t1 ++ " cannot satisfy defines constraint " ++ show t2+    compileErrorM $ "Merged type " ++ show t1 ++ " cannot satisfy defines constraint " ++ show t2   checkFilter (SingleType t1) (DefinesFilter f2) = checkDefinesFilter f2 t1   checkDefinesFilter f2@(DefinesInstance n2 _) (JustTypeInstance t1) = do     ps1' <- trDefines r t1 n2     checkDefinesMatch r f f2 (DefinesInstance n2 ps1')   checkDefinesFilter f2 (JustParamName n1) = do       fs1 <- fmap (map dfType . filter isDefinesFilter) $ f `filterLookup` n1-      mergeAnyM (map (checkDefinesMatch r f f2) fs1) `reviseError`+      mergeAnyM (map (checkDefinesMatch r f f2) fs1) `reviseErrorM`         ("No filters imply " ++ show n1 ++ " defines " ++ show f2)+  checkDefinesFilter _ t2 = compileErrorM $ "Type " ++ show t2 ++ " contains unresolved types"  checkDefinesMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> DefinesInstance -> DefinesInstance -> m ()@@ -464,8 +544,7 @@     paired <- processPairs alwaysPair ps1 ps2     variance <- trVariance r n2     processPairs_ (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance (Positional paired)-    mergeDefaultM-  | otherwise = compileError $ "Constraint " ++ show f1 ++ " does not imply " ++ show f2+  | otherwise = compileErrorM $ "Constraint " ++ show f1 ++ " does not imply " ++ show f2  validateInstanceVariance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamVariances -> Variance -> GeneralInstance -> m ()@@ -479,9 +558,10 @@   mergeAllM (map (validateInstanceVariance r vm v) ts) validateInstanceVariance _ vm v (SingleType (JustParamName n)) =   case n `Map.lookup` vm of-      Nothing -> compileError $ "Param " ++ show n ++ " is undefined"+      Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined"       (Just v0) -> when (not $ v0 `paramAllowsVariance` v) $-                        compileError $ "Param " ++ show n ++ " cannot be " ++ show v+                        compileErrorM $ "Param " ++ show n ++ " cannot be " ++ show v+validateInstanceVariance _ _ _ t = compileErrorM $ "Type " ++ show t ++ " contains unresolved types"  validateDefinesVariance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamVariances -> Variance -> DefinesInstance -> m ()@@ -500,17 +580,18 @@   (ParamName -> m GeneralInstance) -> GeneralInstance -> m GeneralInstance uncheckedSubInstance replace = subAll where   subAll (TypeMerge MergeUnion ts) = do-    gs <- collectAllOrErrorM $ map subAll ts+    gs <- mapErrorsM subAll ts     return (TypeMerge MergeUnion gs)   subAll (TypeMerge MergeIntersect ts) = do-    gs <- collectAllOrErrorM $ map subAll ts+    gs <- mapErrorsM subAll ts     return (TypeMerge MergeIntersect gs)   subAll (SingleType t) = subInstance t   subInstance (JustTypeInstance (TypeInstance n (Positional ts))) = do-    gs <- collectAllOrErrorM $ map subAll ts+    gs <- mapErrorsM subAll ts     let t2 = SingleType $ JustTypeInstance $ TypeInstance n (Positional gs)     return (t2)   subInstance (JustParamName n) = replace n+  subInstance t = compileErrorM $ "Type " ++ show t ++ " contains unresolved types"  uncheckedSubFilter :: (MergeableM m, CompileErrorM m) =>   (ParamName -> m GeneralInstance) -> TypeFilter -> m TypeFilter@@ -518,15 +599,15 @@   t' <- uncheckedSubInstance replace (SingleType t)   return (TypeFilter d (stType t')) uncheckedSubFilter replace (DefinesFilter (DefinesInstance n ts)) = do-  ts' <- collectAllOrErrorM $ map (uncheckedSubInstance replace) (pValues ts)+  ts' <- mapErrorsM (uncheckedSubInstance replace) (pValues ts)   return (DefinesFilter (DefinesInstance n (Positional ts')))  uncheckedSubFilters :: (MergeableM m, CompileErrorM m) =>   (ParamName -> m GeneralInstance) -> ParamFilters -> m ParamFilters uncheckedSubFilters replace fa = do-  fa' <- collectAllOrErrorM $ map subParam $ Map.toList fa+  fa' <- mapErrorsM subParam $ Map.toList fa   return $ Map.fromList fa'   where     subParam (n,fs) = do-      fs' <- collectAllOrErrorM $ map (uncheckedSubFilter replace) fs+      fs' <- mapErrorsM (uncheckedSubFilter replace) fs       return (n,fs')

@@ -285,9 +285,9 @@ define Test {   run () {     Builder<String> builder <- String$builder()-    \ Testing$check<String>(builder.build(),"")-    \ Testing$check<String>(builder.append("xyz").build(),"xyz")-    \ Testing$check<String>(builder.append("123").build(),"xyz123")+    \ Testing$check<?>(builder.build(),"")+    \ Testing$check<?>(builder.append("xyz").build(),"xyz")+    \ Testing$check<?>(builder.append("123").build(),"xyz123")   } } 

@@ -14,9 +14,9 @@ The compiler errors should look something like this:  ```text-Compiler errors:-Public category Type ["tests/check-defs/public.0rp" (line 19, column 1)] is defined 2 times-  Defined at "tests/check-defs/private2.0rx" (line 19, column 1)-  Defined at "tests/check-defs/private1.0rx" (line 19, column 1)-Public category Undefined ["tests/check-defs/public.0rp" (line 21, column 1)] has not been defined or declared external+Zeolite execution failed.+  Category Type ["tests/check-defs/public.0rp" (line 19, column 1)] is defined 2 times+    Defined at "tests/check-defs/private2.0rx" (line 19, column 1)+    Defined at "tests/check-defs/private1.0rx" (line 19, column 1)+  Category Undefined ["tests/check-defs/public.0rp" (line 21, column 1)] has not been defined or declared external ```

@@ -102,7 +102,7 @@  define Test {   run () {-    \ Testing$check<Int>($ExprLookup[INT_EXPR]$,4)+    \ Testing$check<?>($ExprLookup[INT_EXPR]$,4)   } } @@ -117,7 +117,7 @@  define Test {   run () {-    \ Testing$check<Int>(ExprLookup$intExpr(),4)+    \ Testing$check<?>(ExprLookup$intExpr(),4)   } } @@ -134,7 +134,7 @@   @category String macroLocalVar <- "hello"    run () {-    \ Testing$check<String>($ExprLookup[LOCAL_VAR]$,"hello")+    \ Testing$check<?>($ExprLookup[LOCAL_VAR]$,"hello")   } } @@ -166,7 +166,7 @@  define Test {   run () {-    \ Testing$check<Int>(ExprLookup$localVar(),99)+    \ Testing$check<?>(ExprLookup$localVar(),99)   } } @@ -181,7 +181,7 @@  define Test {   run () {-    \ Testing$check<Int>($ExprLookup[META_VAR]$,20)+    \ Testing$check<?>($ExprLookup[META_VAR]$,20)   } } @@ -196,7 +196,7 @@  define Test {   run () {-    \ Testing$check<String>($ExprLookup[INT_EXPR]$.formatted(),"4")+    \ Testing$check<?>($ExprLookup[INT_EXPR]$.formatted(),"4")   } } 

@@ -0,0 +1,219 @@+/* -----------------------------------------------------------------------------+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 "simple inference" {+  success Test$run()+}++define Test {+  run () {+    Int value <- get<?>(10)+  }++  @type get<#x> (#x) -> (#x)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "inference mismatch" {+  error+  require "String"+  require "Int"+}++define Test {+  run () {+    String value <- get<?>(10)+  }++  @type get<#x> (#x) -> (#x)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "nested inference" {+  success Test$run()+}++concrete Type<#x> {+  @type create () -> (Type<#x>)+}++define Type {+  create () {+    return Type<#x>{ }+  }+}++define Test {+  run () {+    Type<Int> value <- get<?>(Type<Int>$create())+  }++  @type get<#x> (Type<#x>) -> (Type<#x>)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "simple inference with qualification" {+  success Test$run()+}++define Test {+  run () {+    Int value <- Test$get<?>(10)+  }++  @type get<#x> (#x) -> (#x)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "inference mismatch with qualification" {+  error+  require "String"+  require "Int"+}++define Test {+  run () {+    String value <- Test$get<?>(10)+  }++  @type get<#x> (#x) -> (#x)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "nested inference with qualification" {+  success Test$run()+}++concrete Type<#x> {+  @type create () -> (Type<#x>)+}++define Type {+  create () {+    return Type<#x>{ }+  }+}++define Test {+  run () {+    Type<Int> value <- Test$get<?>(Type<Int>$create())+  }++  @type get<#x> (Type<#x>) -> (Type<#x>)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "inference conflict" {+  error+  require "String"+  require "Int"+}++concrete Type<#x> {+  @type create () -> (Type<#x>)+}++define Type {+  create () {+    return Type<#x>{ }+  }+}++define Test {+  run () {+    Type<Int> value <- get<?>(Type<Int>$create(),"bad")+  }++  @type get<#x> (Type<#x>,#x) -> (Type<#x>)+  get (x,_) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "inference from filter" {+  error+  require "Formatted"+  require "String"+  require "value2"+  exclude "value1"+}++define Test {+  run () {+    Formatted value1 <- get<?>("value")+    String    value2 <- get<?>("value")+  }++  @type get<#x>+    #x allows Formatted+  (#x) -> (#x)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}