zeolite-lang 0.10.0.0 → 0.11.0.0

raw patch · 80 files changed

+2928/−2245 lines, 80 filesdep +megaparsecdep −parsecPVP ok

version bump matches the API change (PVP)

Dependencies added: megaparsec

Dependencies removed: parsec

API changes (from Hackage documentation)

Files

• ChangeLog.md +42/−0
• base/category-source.hpp +3/−3
• base/logging.hpp +5/−0
• base/types.hpp +18/−0
• bin/unit-tests.hs +5/−5
• bin/zeolite-setup.hs +2/−2
• bin/zeolite.hs +8/−8
• example/parser/.zeolite-module +1/−0
• example/parser/README.md +1/−1
• example/parser/parser-test.0rt +6/−26
• example/parser/test-data.0rp +8/−3
• example/parser/test-data.0rx +0/−8
• lib/file/.zeolite-module +3/−0
• lib/file/helpers.0rp +23/−0
• lib/file/helpers.0rx +29/−0
• lib/file/tests.0rt +50/−28
• src/Base/CompileError.hs +0/−108
• src/Base/CompileInfo.hs +0/−300
• src/Base/CompilerError.hs +136/−0
• src/Base/CompilerMessage.hs +88/−0
• src/Base/GeneralType.hs +78/−0
• src/Base/MergeTree.hs +5/−5
• src/Base/Positional.hs +72/−0
• src/Base/TrackedErrors.hs +259/−0
• src/Cli/Compiler.hs +17/−17
• src/Cli/ParseCompileOptions.hs +10/−10
• src/Cli/Programs.hs +3/−3
• src/Cli/RunCompiler.hs +9/−9
• src/Cli/TestRunner.hs +40/−40
• src/Compilation/CompilerState.hs +49/−59
• src/Compilation/ProcedureContext.hs +157/−89
• src/Compilation/ScopeContext.hs +5/−5
• src/CompilerCxx/Category.hs +28/−28
• src/CompilerCxx/CategoryContext.hs +12/−9
• src/CompilerCxx/Code.hs +1/−1
• src/CompilerCxx/Procedure.hs +214/−199
• src/Config/LoadConfig.hs +4/−4
• src/Config/LocalConfig.hs +5/−5
• src/Module/CompileMetadata.hs +2/−4
• src/Module/ParseMetadata.hs +30/−30
• src/Module/Paths.hs +6/−6
• src/Module/ProcessMetadata.hs +46/−46
• src/Parser/Common.hs +126/−149
• src/Parser/DefinedCategory.hs +16/−19
• src/Parser/IntegrationTest.hs +33/−39
• src/Parser/Pragma.hs +22/−25
• src/Parser/Procedure.hs +104/−105
• src/Parser/SourceFile.hs +12/−15
• src/Parser/TextParser.hs +70/−0
• src/Parser/TypeCategory.hs +33/−36
• src/Parser/TypeInstance.hs +30/−37
• src/Test/Common.hs +35/−36
• src/Test/CompileInfo.hs +0/−120
• src/Test/DefinedCategory.hs +12/−14
• src/Test/IntegrationTest.hs +12/−14
• src/Test/MergeTree.hs +19/−21
• src/Test/ParseMetadata.hs +14/−14
• src/Test/Parser.hs +23/−13
• src/Test/Pragma.hs +13/−14
• src/Test/Procedure.hs +25/−27
• src/Test/SourceFile.hs +5/−7
• src/Test/TrackedErrors.hs +120/−0
• src/Test/TypeCategory.hs +53/−54
• src/Test/TypeInstance.hs +33/−35
• src/Types/DefinedCategory.hs +10/−10
• src/Types/Function.hs +10/−10
• src/Types/GeneralType.hs +0/−78
• src/Types/IntegrationTest.hs +7/−7
• src/Types/Positional.hs +0/−70
• src/Types/Procedure.hs +10/−3
• src/Types/TypeCategory.hs +71/−71
• src/Types/TypeInstance.hs +55/−55
• tests/conditionals.0rt +30/−7
• tests/named-returns.0rt +30/−1
• tests/regressions.0rt +93/−0
• tests/scoped.0rt +113/−3
• tests/tracing.0rt +28/−0
• tests/unreachable.0rt +37/−65
• tests/while.0rt +131/−2
• zeolite-lang.cabal +13/−8

@@ -1,5 +1,44 @@ # Revision history for zeolite-lang +## 0.11.0.0  -- 2020-12-09++### Compiler CLI++* **[breaking]** Switches from [`parsec`][parsec] to [`megaparsec`][megaparsec]+  for parsing, to allow for better structuring of compile-time error messages.+  This should not affect syntax acceptance, but it has additional transitive+  dependencies that might prevent installation of `zeolite`.++### Language++* **[breaking]** Several `cleanup` fixes:++  * **[fix]** Fixes a bug in `cleanup` that caused the `scoped` block to be+    prepended to it when it was inlined in the `in` block.++  * **[fix]** Fixes a bug where `cleanup` might use an uninitialized named+    return when inlined at a `break` or `continue` statement in a `while` loop.+    Such situations will now cause a compilation error. Previously, this could+    have allowed an uninitialized value to be passed around, which would only be+    noticed with a `Function called on null value` failure at some point.++  * **[fix]** Fixes inlining of `cleanup` blocks when `continue` is used inside+    of the `in` block. Previously, `cleanup` was skipped when `continue` was+    used inside of the respective `in` block.++  * **[breaking]** Disallows explicit `break` and `continue` inside of `cleanup`+    blocks. Previously this was allowed (but `return` wasn't), which led to+    ambiguity when the `in` block contained a `return`.++  * **[new]** Allows `cleanup` to refer to variables created at the top level of+    the `in` block.++    ```text+    cleanup {+      \ foo(bar)                    // bar is created below+    } in Type bar <- Type.create()  // cleanup is inlined after this+    ```+ ## 0.10.0.0  -- 2020-12-05  ### Language@@ -379,3 +418,6 @@ ## 0.1.0.0  -- 2020-04-27  * First version. Released on an unsuspecting world.++[megaparsec]: https://hackage.haskell.org/package/megaparsec+[parsec]: https://hackage.haskell.org/package/parsec

@@ -57,7 +57,7 @@  public:   inline ReturnTuple Call(const CategoryFunction& label,                           const ParamTuple& params, const ValueTuple& args) {-    return Dispatch(label, params, args);+    return FAIL_WHEN_NULL(Dispatch(label, params, FAIL_WHEN_NULL(args)));   }    virtual std::string CategoryName() const = 0;@@ -80,7 +80,7 @@     if (target == nullptr) {       FAIL() << "Function called on null value";     }-    return target->Dispatch(target, label, params, args);+    return FAIL_WHEN_NULL(target->Dispatch(target, label, params, FAIL_WHEN_NULL(args)));   }    virtual std::string CategoryName() const = 0;@@ -159,7 +159,7 @@     if (target == nullptr) {       FAIL() << "Function called on null value";     }-    return target->Dispatch(target, label, params, args);+    return FAIL_WHEN_NULL(target->Dispatch(target, label, params, FAIL_WHEN_NULL(args)));   }    static bool Present(S<TypeValue> target);

@@ -84,6 +84,9 @@   #define TRACE_CREATION \     TraceCreation trace_creation(TypeInstance::TypeName(parent), creation_context_); +  #define FAIL_WHEN_NULL(value) \+    FailWhenNull(value)+ #else    #define TRACE_FUNCTION(name)@@ -97,6 +100,8 @@   #define CAPTURE_CREATION    #define TRACE_CREATION++  #define FAIL_WHEN_NULL(value) value  #endif 

@@ -230,4 +230,22 @@   std::vector<S<TypeInstance>> params_; }; +inline ReturnTuple FailWhenNull(ReturnTuple values) {+  for (int i = 0; i < values.Size(); ++i) {+    if (values.At(i) == nullptr) {+      FAIL() << "Value at return tuple position " << i << " is null";+    }+  }+  return values;+}++inline const ValueTuple& FailWhenNull(const ValueTuple& values) {+  for (int i = 0; i < values.Size(); ++i) {+    if (values.At(i) == nullptr) {+      FAIL() << "Value at arg tuple position " << i << " is null";+    }+  }+  return values;+}+ #endif  // TYPES_HPP_

@@ -16,10 +16,10 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] -import Base.CompileError-import Base.CompileInfo+import Base.TrackedErrors+import Base.CompilerError import Test.Common-import qualified Test.CompileInfo     as TestCompileInfo+import qualified Test.TrackedErrors   as TestTrackedErrors import qualified Test.DefinedCategory as TestDefinedCategory import qualified Test.IntegrationTest as TestIntegrationTest import qualified Test.MergeTree       as TestMergeTree@@ -34,7 +34,7 @@  main :: IO () main = runAllTests $ concat [-    labelWith "CompileInfo"     TestCompileInfo.tests,+    labelWith "TrackedErrors"   TestTrackedErrors.tests,     labelWith "DefinedCategory" TestDefinedCategory.tests,     labelWith "IntegrationTest" TestIntegrationTest.tests,     labelWith "MergeTree"       TestMergeTree.tests,@@ -47,5 +47,5 @@     labelWith "TypeInstance"    TestTypeInstance.tests   ] -labelWith :: String -> [IO (CompileInfo ())] -> [IO (CompileInfo ())]+labelWith :: String -> [IO (TrackedErrors ())] -> [IO (TrackedErrors ())] labelWith s ts = map (\(n,t) -> fmap (<?? "In " ++ s ++ " (#" ++ show n ++ "):") t) (zip ([1..] :: [Int]) ts)

@@ -22,7 +22,7 @@ import System.Exit import System.IO -import Base.CompileInfo+import Base.TrackedErrors import Cli.CompileOptions import Cli.RunCompiler import Config.LoadConfig@@ -137,4 +137,4 @@       coMode = CompileRecompileRecursive,       coForce = ForceAll     }-  tryCompileInfoIO "Warnings:" "Zeolite setup failed:" $ runCompiler resolver backend options+  tryTrackedErrorsIO "Warnings:" "Zeolite setup failed:" $ runCompiler resolver backend options

@@ -23,10 +23,10 @@ import System.IO import qualified Data.Map as Map -import Base.CompileError-import Base.CompileInfo+import Base.CompilerError+import Base.TrackedErrors import Cli.CompileOptions-import Cli.ParseCompileOptions -- Not safe, due to Text.Regex.TDFA.+import Cli.ParseCompileOptions import Cli.Programs import Cli.RunCompiler import Module.CompileMetadata@@ -43,12 +43,12 @@   compile options   hPutStrLn stderr "Zeolite execution succeeded." where     compile co-      | isCompileError co = do-          hPutStr stderr $ show $ getCompileError co+      | isCompilerError co = do+          hPutStr stderr $ show $ getCompilerError co           hPutStrLn stderr "Use the -h option to show help."           exitFailure       | otherwise = tryZeoliteIO $ do-          let co' = getCompileSuccess co+          let co' = getCompilerSuccess co           (resolver,backend) <- loadConfig           when (HelpNotNeeded /= (coHelp co')) $ errorFromIO $ showHelp >> exitFailure           runCompiler resolver backend co'@@ -91,5 +91,5 @@     showDep _ = return () tryFastModes _ = return () -tryZeoliteIO :: CompileInfoIO a -> IO a-tryZeoliteIO = tryCompileInfoIO "Warnings (ignored):" "Zeolite execution failed:"+tryZeoliteIO :: TrackedErrorsIO a -> IO a+tryZeoliteIO = tryTrackedErrorsIO "Warnings (ignored):" "Zeolite execution failed:"

@@ -5,5 +5,6 @@ ] private_deps: [   "lib/file"+  "lib/testing" ] mode: incremental {}

@@ -5,7 +5,7 @@  This example demonstrates parsing text using a parser-combinator approach inspired by [`parsec`][parsec]. (The Haskell library that the `zeolite` compiler-uses to parse source and config files.)+originally used to parse source and config files.)  ## Notes 

@@ -3,31 +3,11 @@ }  unittest test {-  TestData data <- TestData.parseFrom(Helpers.loadTestData()).getValue()--  if (data.getName() != "example data") {-    fail(data.getName())-  }--  if (data.getDescription() != "THIS_IS_A_TOKEN") {-    fail(data.getDescription())-  }--  if (data.getBoolean() != false) {-    fail(data.getBoolean())-  }-}--concrete Helpers {-  @type loadTestData () -> (String)-}+  String raw <- FileTesting.forceReadFile($ExprLookup[MODULE_PATH]$ + "/test-data.txt")+  ErrorOr<TestData> errorOrData <- TestDataParser.create() `ParseState:consumeAll<?>` raw+  TestData data <- errorOrData.getValue() -define Helpers {-  loadTestData () {-    scoped {-      RawFileReader reader <- RawFileReader.open($ExprLookup[MODULE_PATH]$ + "/test-data.txt")-    } cleanup {-      \ reader.freeResource()-    } in return TextReader.readAll(reader)-  }+  \ Testing.checkEquals<?>(data.getName(),"example data")+  \ Testing.checkEquals<?>(data.getDescription(),"THIS_IS_A_TOKEN")+  \ Testing.checkEquals<?>(data.getBoolean(),false) }

@@ -3,11 +3,16 @@ /* A contrived object for test data.  */ concrete TestData {-  // Parses the test-data.txt file using a one-off format.-  @type parseFrom (String)             -> (ErrorOr<TestData>)-  @type create    (String,String,Bool) -> (TestData)+  @type create (String,String,Bool) -> (TestData)    @value getName        () -> (String)   @value getDescription () -> (String)   @value getBoolean     () -> (Bool)+}+++/* Parses the test-data.txt file using a one-off format.+ */+concrete TestDataParser {+  @type create () -> (Parser<TestData>) }

@@ -5,10 +5,6 @@   @value String description   @value Bool   boolean -  parseFrom (data) {-    return TestDataParser.create() `ParseState:consumeAll<?>` data-  }-   create (name,description,boolean) {     return TestData{ name, description, boolean }   }@@ -24,10 +20,6 @@   getBoolean () {     return boolean   }-}--concrete TestDataParser {-  @type create () -> (Parser<TestData>) }  define TestDataParser {

@@ -3,6 +3,9 @@ public_deps: [   "lib/util" ]+private_deps: [+  "lib/testing"+] extra_files: [   category_source {     source: "file/Category_RawFileReader.cpp"

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

@@ -0,0 +1,29 @@+/* -----------------------------------------------------------------------------+Copyright 2020 Kevin P. Barry++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+----------------------------------------------------------------------------- */++// Author: Kevin P. Barry [ta0kira@gmail.com]++$TestsOnly$++define FileTesting {+  forceReadFile (file) {+    scoped {+      RawFileReader reader <- RawFileReader.open(file)+    } cleanup {+      \ reader.freeResource()+    } in return TextReader.readAll(reader)+  }+}

@@ -21,42 +21,64 @@ }  unittest readWrite {-  RawFileWriter writer <- RawFileWriter.open("testfile")-  if (present(writer.getFileError())) {-    fail(require(writer.getFileError()))-  }-  RawFileReader reader <- RawFileReader.open("testfile")-  if (present(reader.getFileError())) {-    fail(require(reader.getFileError()))-  }-   String data <- "this is some\x00data" -  Int writeSize <- writer.writeBlock(data)-  if (writeSize != data.readSize()) {-    fail(writeSize)-  }-  if (present(writer.getFileError())) {-    fail(require(writer.getFileError()))+  scoped {+    RawFileWriter writer <- RawFileWriter.open("testfile")+  } cleanup {+    \ writer.freeResource()+  } in {+    if (present(writer.getFileError())) {+      fail(require(writer.getFileError()))+    }+    Int writeSize <- writer.writeBlock(data)+    if (writeSize != data.readSize()) {+      fail(writeSize)+    }+    if (present(writer.getFileError())) {+      fail(require(writer.getFileError()))+    }   }    scoped {-    String data2 <- reader.readBlock(8)-  } in if (data2 != "this is ") {-    fail("\"" + data2 + "\"")+    RawFileReader reader <- RawFileReader.open("testfile")+  } cleanup {+    \ reader.freeResource()+  } in {+    if (present(reader.getFileError())) {+      fail(require(reader.getFileError()))+    }++    scoped {+      String data2 <- reader.readBlock(8)+    } in if (data2 != "this is ") {+      fail("\"" + data2 + "\"")+    }+    scoped {+      String data2 <- reader.readBlock(20)+    } in if (data2 != "some\x00data") {+      fail("\"" + data2 + "\"")+    }+    if (present(reader.getFileError())) {+      fail(require(reader.getFileError()))+    }++    if (!reader.pastEnd()) {+      fail("more data in file")+    }   }+}++unittest forceRead {+  String data <- "test data"+   scoped {-    String data2 <- reader.readBlock(20)-  } in if (data2 != "some\x00data") {-    fail("\"" + data2 + "\"")-  }-  if (present(reader.getFileError())) {-    fail(require(reader.getFileError()))-  }+    RawFileWriter writer <- RawFileWriter.open("testfile")+  } cleanup {+    \ writer.freeResource()+  } in \ writer.writeBlock(data) -  if (!reader.pastEnd()) {-    fail("more data in file")-  }+  \ Testing.checkEquals<?>(FileTesting.forceReadFile("testfile"),data) }  unittest readEmpty {

@@ -1,108 +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 Base.CompileError (-  CompileErrorM(..),-  (<??),-  (??>),-  (<!!),-  (!!>),-  collectAllM_,-  collectFirstM_,-  errorFromIO,-  isCompileErrorM,-  isCompileSuccessM,-  mapErrorsM,-  mapErrorsM_,-) where--import Control.Monad.IO.Class-import System.IO.Error (catchIOError)--#if MIN_VERSION_base(4,13,0)-import Control.Monad.Fail ()-#elif MIN_VERSION_base(4,9,0)-import Control.Monad.Fail-#endif----- For some GHC versions, pattern-matching failures require MonadFail.-#if MIN_VERSION_base(4,9,0)-class (Monad m, MonadFail m) => CompileErrorM m where-#else-class Monad m => CompileErrorM m where-#endif-  compileErrorM :: String -> m a-  collectAllM :: Foldable f => f (m a) -> m [a]-  collectAnyM :: Foldable f => f (m a) -> m [a]-  collectFirstM :: Foldable f => f (m a) -> m a-  withContextM :: m a -> String -> m a-  withContextM c _ = c-  summarizeErrorsM :: m a -> String -> m a-  summarizeErrorsM e _ = e-  compileWarningM :: String -> m ()-  compileWarningM _ = return ()-  compileBackgroundM :: String -> m ()-  compileBackgroundM _ = return ()-  resetBackgroundM :: m a -> m a-  resetBackgroundM = id--(<??) :: CompileErrorM m => m a -> String -> m a-(<??) = withContextM-infixl 1 <??--(??>) :: CompileErrorM m => String -> m a -> m a-(??>) = flip withContextM-infixr 1 ??>--(<!!) :: CompileErrorM m => m a -> String -> m a-(<!!) = summarizeErrorsM-infixl 1 <!!--(!!>) :: CompileErrorM m => String -> m a -> m a-(!!>) = flip summarizeErrorsM-infixr 1 !!>--collectAllM_ :: (Foldable f, CompileErrorM m) => f (m a) -> m ()-collectAllM_ = fmap (const ()) . collectAllM--collectFirstM_ :: (Foldable f, CompileErrorM m) => f (m a) -> m ()-collectFirstM_ = fmap (const ()) . collectFirstM--mapErrorsM :: CompileErrorM m => (a -> m b) -> [a] -> m [b]-mapErrorsM f = collectAllM . map f--mapErrorsM_ :: CompileErrorM m => (a -> m b) -> [a] -> m ()-mapErrorsM_ f = collectAllM_ . map f--isCompileErrorM :: CompileErrorM m => m a -> m Bool-isCompileErrorM x = collectFirstM [x >> return False,return True]--isCompileSuccessM :: CompileErrorM m => m a -> m Bool-isCompileSuccessM x = collectFirstM [x >> return True,return False]--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

@@ -1,300 +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 Base.CompileInfo (-  CompileInfo,-  CompileInfoIO,-  CompileMessage,-  asCompileError,-  asCompileWarnings,-  fromCompileInfo,-  getCompileError,-  getCompileErrorT,-  getCompileSuccess,-  getCompileSuccessT,-  getCompileWarnings,-  getCompileWarningsT,-  isCompileError,-  isCompileErrorT,-  isEmptyCompileMessage,-  toCompileInfo,-  tryCompileInfoIO,-) where--import Control.Applicative-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---type CompileInfo = CompileInfoT Identity--type CompileInfoIO = CompileInfoT IO--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 -> CompileMessage-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 CompileMessage-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--isEmptyCompileMessage :: CompileMessage -> Bool-isEmptyCompileMessage (CompileMessage "" ws) = all isEmptyCompileMessage ws-isEmptyCompileMessage _                      = False--fromCompileInfo :: Monad m => CompileInfo a -> CompileInfoT m a-fromCompileInfo x = runIdentity $ do-  x' <- citState x-  return $ CompileInfoT $ return x'--asCompileWarnings :: Monad m => CompileInfo a -> CompileInfoT m ()-asCompileWarnings x = runIdentity $ do-  x' <- citState x-  return $ CompileInfoT $ return $-    case x' of-         (CompileFail ws es)      -> CompileSuccess (ws `mergeMessages` es) [] ()-         (CompileSuccess ws bs _) -> CompileSuccess ws bs ()--asCompileError :: Monad m => CompileInfo a -> CompileInfoT m ()-asCompileError x = runIdentity $ do-  x' <- citState x-  return $ CompileInfoT $ return $-    case x' of-         (CompileSuccess ws bs _) -> includeBackground bs $ CompileFail emptyMessage ws-         (CompileFail ws es)      -> CompileFail ws es--toCompileInfo :: Monad m => CompileInfoT m a -> m (CompileInfo a)-toCompileInfo x = do-  x' <- citState x-  return $ CompileInfoT $ return x'--tryCompileInfoIO :: String -> String -> CompileInfoIO a -> IO a-tryCompileInfoIO warn err x = do-  x' <- toCompileInfo x-  let w = getCompileWarnings $ x' <?? warn-  let e = getCompileError    $ x' <?? err-  if isCompileError x'-     then do-       hPutStr stderr $ show w-       hPutStr stderr $ show e-       exitFailure-     else do-       hPutStr stderr $ show w-       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 :: CompileMessage,-    cfErrors :: CompileMessage-  } |-  CompileSuccess {-    csWarnings :: CompileMessage,-    csBackground :: [String],-    csData :: a-  }--instance Show a => Show (CompileInfoState a) where-  show = format where-    format (CompileFail w e) = intercalate "\n" $ errors ++ warnings where-      errors   = showAs "Errors:"   $ lines $ show e-      warnings = showAs "Warnings:" $ lines $ show w-    format (CompileSuccess w b x) = intercalate "\n" $ content ++ warnings ++ background where-      content    = [show x]-      warnings   = showAs "Warnings:" $ lines $ show w-      background = showAs "Background:" b-    showAs m = (m:) . map ("  " ++)--instance Show a => Show (CompileInfo a) where-  show = show . runIdentity . citState--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 b d -> return $ CompileSuccess w b (f d)--instance (Applicative m, Monad m) => Applicative (CompileInfoT m) where-  pure = CompileInfoT .return . CompileSuccess emptyMessage []-  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 `mergeMessages` w) (addBackground (getBackground i) e)-         (CompileSuccess w1 b1 f2,CompileSuccess w2 b2 d) ->-           return $ CompileSuccess (w1 `mergeMessages` w2) (b1 ++ b2) (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 b d -> do-           d2 <- citState $ f d-           return $ includeBackground b $ includeWarnings 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 emptyMessage [])--instance MonadIO m => MonadIO (CompileInfoT m) where-  liftIO = lift . liftIO--instance Monad m => CompileErrorM (CompileInfoT m) where-  compileErrorM e = CompileInfoT $ return $ CompileFail emptyMessage $ CompileMessage e []-  collectAllM = combineResults (select . splitErrorsAndData) where-    select ([],xs2,bs,ws) = CompileSuccess (CompileMessage "" ws) bs xs2-    select (es,_,bs,ws)   = CompileFail (CompileMessage "" ws) $ addBackground bs $ CompileMessage "" es-  collectAnyM = combineResults (select . splitErrorsAndData) where-    select (_,xs2,bs,ws) = CompileSuccess (CompileMessage "" ws) bs xs2-  collectFirstM = combineResults (select . splitErrorsAndData) where-    select (_,x:_,bs,ws) = CompileSuccess (CompileMessage "" ws) bs x-    select (es,_,bs,ws)  = CompileFail (CompileMessage "" ws) $ addBackground bs $ CompileMessage "" es-  withContextM x c = CompileInfoT $ do-    x' <- citState x-    case x' of-         CompileFail w e        -> return $ CompileFail (pushWarningScope c w) (pushErrorScope c e)-         CompileSuccess w bs x2 -> return $ CompileSuccess (pushWarningScope c w) bs x2-  summarizeErrorsM x e2 = CompileInfoT $ do-    x' <- citState x-    case x' of-         CompileFail w e -> return $ CompileFail w (pushErrorScope e2 e)-         x2 -> return x2-  compileWarningM w = CompileInfoT (return $ CompileSuccess (CompileMessage w []) [] ())-  compileBackgroundM b = CompileInfoT (return $ CompileSuccess emptyMessage [b] ())-  resetBackgroundM x = CompileInfoT $ do-    x' <- citState x-    case x' of-         CompileSuccess w _ d -> return $ CompileSuccess w [] d-         x2                   -> return x2--combineResults :: (Monad m, Foldable f) =>-  ([CompileInfoState a] -> CompileInfoState b) -> f (CompileInfoT m a) -> CompileInfoT m b-combineResults f = CompileInfoT . fmap f . sequence . map citState . foldr (:) []--emptyMessage :: CompileMessage-emptyMessage = CompileMessage "" []--pushErrorScope :: String -> CompileMessage -> CompileMessage-pushErrorScope e2 ea@(CompileMessage e ms)-  | null e            = CompileMessage e2 ms-  | otherwise         = CompileMessage e2 [ea]--pushWarningScope :: String -> CompileMessage -> CompileMessage-pushWarningScope e2 ea-  | isEmptyCompileMessage ea = emptyMessage  -- Skip the scope if there isn't already a warning.-  | otherwise                = pushErrorScope e2 ea--mergeMessages :: CompileMessage -> CompileMessage -> CompileMessage-mergeMessages (CompileMessage "" []) e2                       = e2-mergeMessages e1                     (CompileMessage "" [])   = e1-mergeMessages (CompileMessage "" es1) (CompileMessage "" es2) = CompileMessage "" (es1 ++ es2)-mergeMessages e1                      (CompileMessage "" es2) = CompileMessage "" ([e1] ++ es2)-mergeMessages (CompileMessage "" es1) e2                      = CompileMessage "" (es1 ++ [e2])-mergeMessages e1                      e2                      = CompileMessage "" [e1,e2]--addBackground :: [String] -> CompileMessage -> CompileMessage-addBackground b (CompileMessage e es) = CompileMessage e (es ++ map (flip CompileMessage []) b)--getWarnings :: CompileInfoState a -> CompileMessage-getWarnings (CompileFail w _)      = w-getWarnings (CompileSuccess w _ _) = w--includeWarnings :: CompileMessage -> CompileInfoState a -> CompileInfoState a-includeWarnings = update where-  update w (CompileSuccess w2 b d) = CompileSuccess (w `mergeMessages` w2) b d-  update w (CompileFail w2 e)      = CompileFail (w `mergeMessages` w2) e--getBackground :: CompileInfoState a -> [String]-getBackground (CompileSuccess _ b _) = b-getBackground _                      = []--includeBackground :: [String] -> CompileInfoState a -> CompileInfoState a-includeBackground b  (CompileFail w e)       = CompileFail w (addBackground b e)-includeBackground b1 (CompileSuccess w b2 d) = CompileSuccess w (b1 ++ b2) d--splitErrorsAndData :: Foldable f => f (CompileInfoState a) -> ([CompileMessage],[a],[String],[CompileMessage])-splitErrorsAndData = foldr partition ([],[],[],[]) where-  partition (CompileFail w e)      (es,ds,bs,ws) = (e:es,ds,bs,w:ws)-  partition (CompileSuccess w b d) (es,ds,bs,ws) = (es,d:ds,b++bs,w:ws)

@@ -0,0 +1,136 @@+{- -----------------------------------------------------------------------------+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.CompilerError (+  CollectErrorsM(..),+  ErrorContextM(..),+  ErrorContextT(..),+  (<??),+  (??>),+  (<!!),+  (!!>),+  collectAllM_,+  collectFirstM_,+  errorFromIO,+  isCompilerError,+  isCompilerErrorM,+  isCompilerSuccess,+  isCompilerSuccessM,+  mapErrorsM,+  mapErrorsM_,+) where++import Control.Monad.IO.Class+import Control.Monad.Trans+import Control.Monad.Trans.State (StateT,mapStateT)+import Data.Functor.Identity+import System.IO.Error (catchIOError)++#if MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ()+#elif MIN_VERSION_base(4,9,0)+import Control.Monad.Fail+#endif+++-- For some GHC versions, pattern-matching failures require MonadFail.+#if MIN_VERSION_base(4,9,0)+class (Monad m, MonadFail m) => ErrorContextM m where+#else+class Monad m => ErrorContextM m where+#endif+  compilerErrorM :: String -> m a+  withContextM :: m a -> String -> m a+  withContextM c _ = c+  summarizeErrorsM :: m a -> String -> m a+  summarizeErrorsM e _ = e+  compilerWarningM :: String -> m ()+  compilerWarningM _ = return ()+  compilerBackgroundM :: String -> m ()+  compilerBackgroundM _ = return ()+  resetBackgroundM :: m a -> m a+  resetBackgroundM = id++class ErrorContextM m => CollectErrorsM m where+  collectAllM :: Foldable f => f (m a) -> m [a]+  collectAnyM :: Foldable f => f (m a) -> m [a]+  collectFirstM :: Foldable f => f (m a) -> m a++class MonadTrans t => ErrorContextT t where+  isCompilerErrorT :: (Monad m, ErrorContextM (t m)) => t m a -> m Bool+  isCompilerSuccessT :: (Monad m, ErrorContextM (t m)) => t m a -> m Bool+  isCompilerSuccessT = fmap not . isCompilerErrorT++(<??) :: ErrorContextM m => m a -> String -> m a+(<??) = withContextM+infixl 1 <??++(??>) :: ErrorContextM m => String -> m a -> m a+(??>) = flip withContextM+infixr 1 ??>++(<!!) :: ErrorContextM m => m a -> String -> m a+(<!!) = summarizeErrorsM+infixl 1 <!!++(!!>) :: ErrorContextM m => String -> m a -> m a+(!!>) = flip summarizeErrorsM+infixr 1 !!>++collectAllM_ :: (Foldable f, CollectErrorsM m) => f (m a) -> m ()+collectAllM_ = fmap (const ()) . collectAllM++collectFirstM_ :: (Foldable f, CollectErrorsM m) => f (m a) -> m ()+collectFirstM_ = fmap (const ()) . collectFirstM++mapErrorsM :: CollectErrorsM m => (a -> m b) -> [a] -> m [b]+mapErrorsM f = collectAllM . map f++mapErrorsM_ :: CollectErrorsM m => (a -> m b) -> [a] -> m ()+mapErrorsM_ f = collectAllM_ . map f++isCompilerError :: (ErrorContextT t, ErrorContextM (t Identity)) => t Identity a -> Bool+isCompilerError = runIdentity . isCompilerErrorT++isCompilerSuccess :: (ErrorContextT t, ErrorContextM (t Identity)) => t Identity a -> Bool+isCompilerSuccess = runIdentity . isCompilerSuccessT++isCompilerErrorM :: CollectErrorsM m => m a -> m Bool+isCompilerErrorM x = collectFirstM [x >> return False,return True]++isCompilerSuccessM :: CollectErrorsM m => m a -> m Bool+isCompilerSuccessM x = collectFirstM [x >> return True,return False]++errorFromIO :: (MonadIO m, ErrorContextM 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)   -> compilerErrorM e++instance ErrorContextM m => ErrorContextM (StateT a m) where+  compilerErrorM      = lift . compilerErrorM+  withContextM        = flip $ mapStateT . (??>)+  summarizeErrorsM    = flip $ mapStateT . (!!>)+  compilerWarningM    = lift . compilerWarningM+  compilerBackgroundM = lift . compilerBackgroundM+  resetBackgroundM    = mapStateT resetBackgroundM

@@ -0,0 +1,88 @@+{- -----------------------------------------------------------------------------+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 Safe #-}++module Base.CompilerMessage (+  CompilerMessage,+  compilerMessage,+  compilerMessages,+  prefixCompilerMessages,+  pushErrorScope,+  pushWarningScope,+) where++import Data.List (intercalate)+import Prelude hiding (foldr)++#if MIN_VERSION_base(4,11,0)+#else+import Data.Semigroup+#endif+++data CompilerMessage =+  CompilerMessage {+    cmMessage :: String,+    cmNested :: [CompilerMessage]+  }+  deriving (Eq,Ord)++compilerMessage :: String -> CompilerMessage+compilerMessage = flip CompilerMessage []++compilerMessages :: [CompilerMessage] -> CompilerMessage+compilerMessages = CompilerMessage ""++instance Semigroup CompilerMessage where+  (CompilerMessage "" [])  <> e2                       = e2+  e1                       <> (CompilerMessage "" [])  = e1+  (CompilerMessage "" es1) <> (CompilerMessage "" es2) = CompilerMessage "" (es1 ++ es2)+  e1                       <> (CompilerMessage "" es2) = CompilerMessage "" ([e1] ++ es2)+  (CompilerMessage "" es1) <> e2                       = CompilerMessage "" (es1 ++ [e2])+  e1                       <> e2                       = CompilerMessage "" [e1,e2]++instance Monoid CompilerMessage where+  mempty = CompilerMessage "" []+  mappend = (<>)++instance Show CompilerMessage where+  show = format "" where+    format indent (CompilerMessage [] ms) =+      concat (map (format indent) ms)+    format indent (CompilerMessage m ms) =+      (doIndent indent m) ++ "\n" ++ concat (map (format $ indent ++ "  ") ms)+    doIndent indent s = intercalate "\n" $ map (indent ++) $ lines s++pushErrorScope :: String -> CompilerMessage -> CompilerMessage+pushErrorScope e2 ea@(CompilerMessage e ms)+  | null e    = CompilerMessage e2 ms+  | otherwise = CompilerMessage e2 [ea]++pushWarningScope :: String -> CompilerMessage -> CompilerMessage+pushWarningScope e2 ea+  | isEmpty ea = mempty  -- Skip the scope if there isn't already a warning.+  | otherwise  = pushErrorScope e2 ea++prefixCompilerMessages :: [String] -> CompilerMessage -> CompilerMessage+prefixCompilerMessages b (CompilerMessage e es) = CompilerMessage e (es ++ map (flip CompilerMessage []) b)++isEmpty :: CompilerMessage -> Bool+isEmpty (CompilerMessage "" ws) = all isEmpty ws+isEmpty _                       = False

@@ -0,0 +1,78 @@+{- -----------------------------------------------------------------------------+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 Safe #-}+{-# LANGUAGE TypeFamilies #-}++module Base.GeneralType (+  GeneralType,+  dualGeneralType,+  mapGeneralType,+  singleType,+) where++import qualified Data.Set as Set++import Base.MergeTree+import Base.Mergeable+++data GeneralType a =+  SingleType {+    stType :: a+  } |+  AllowAnyOf {+    aaoTypes :: Set.Set (GeneralType a)+  } |+  RequireAllOf {+    raoTypes :: Set.Set (GeneralType a)+  }+  deriving (Eq,Ord)++singleType :: (Eq a, Ord a) => a -> GeneralType a+singleType = SingleType++instance (Eq a, Ord a) => Mergeable (GeneralType a) where+  mergeAny = unnest . foldr (Set.union . flattenAny) Set.empty where+    flattenAny (AllowAnyOf xs) = xs+    flattenAny x               = Set.fromList [x]+    unnest xs = case Set.toList xs of+                     [x] -> x+                     _ -> AllowAnyOf xs+  mergeAll = unnest . foldr (Set.union . flattenAll) Set.empty where+    flattenAll (RequireAllOf xs) = xs+    flattenAll x                 = Set.fromList [x]+    unnest xs = case Set.toList xs of+                     [x] -> x+                     _ -> RequireAllOf xs++instance (Eq a, Ord a) => PreserveMerge (GeneralType a) where+  type T (GeneralType a) = a+  convertMerge f (AllowAnyOf   xs) = mergeAny $ map (convertMerge f) $ Set.toList xs+  convertMerge f (RequireAllOf xs) = mergeAll $ map (convertMerge f) $ Set.toList xs+  convertMerge f (SingleType x)    = f x++instance (Eq a, Ord a) => Bounded (GeneralType a) where+  minBound = mergeAny Nothing  -- all+  maxBound = mergeAll Nothing  -- any++dualGeneralType :: (Eq a, Ord a) => GeneralType a -> GeneralType a+dualGeneralType = reduceMergeTree mergeAll mergeAny singleType++mapGeneralType :: (Eq a, Ord a, Eq b, Ord b) => (a -> b) -> GeneralType a -> GeneralType b+mapGeneralType = reduceMergeTree mergeAny mergeAll . (singleType .)

@@ -31,7 +31,7 @@  import Data.List (intercalate) -import Base.CompileError+import Base.CompilerError import Base.Mergeable  @@ -131,13 +131,13 @@   minBound = mergeAny Nothing   maxBound = mergeAll Nothing -mergeAnyM :: (PreserveMerge a, CompileErrorM m) => [m a] -> m a+mergeAnyM :: (PreserveMerge a, CollectErrorsM m) => [m a] -> m a mergeAnyM xs = do   collectFirstM_ xs   fmap mergeAny $ collectAnyM xs -mergeAllM :: (PreserveMerge a, CompileErrorM m) => [m a] -> m a+mergeAllM :: (PreserveMerge a, CollectErrorsM m) => [m a] -> m a mergeAllM = fmap mergeAll . collectAllM -matchOnlyLeaf :: (PreserveMerge a, CompileErrorM m) => a -> m (T a)-matchOnlyLeaf = reduceMergeTree (const $ compileErrorM "") (const $ compileErrorM "") return+matchOnlyLeaf :: (PreserveMerge a, CollectErrorsM m) => a -> m (T a)+matchOnlyLeaf = reduceMergeTree (const $ compilerErrorM "") (const $ compilerErrorM "") return

@@ -0,0 +1,72 @@+{- -----------------------------------------------------------------------------+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 Safe #-}++module Base.Positional (+  Positional(..),+  alwaysPair,+  processPairs,+  processPairs_,+  processPairsM,+  processPairsT,+) where++import Control.Monad.Trans (MonadTrans(..))++import Base.CompilerError+import Base.Mergeable+++newtype Positional a =+  Positional {+    pValues :: [a]+  }+  deriving (Eq,Ord,Show)++instance Functor Positional where+  fmap f = Positional . fmap f . pValues++alwaysPair :: Monad m => a -> b -> m (a,b)+alwaysPair x y = return (x,y)++processPairs :: (Show a, Show b, CollectErrorsM m) =>+  (a -> b -> m c) -> Positional a -> Positional b -> m [c]+processPairs f (Positional ps1) (Positional ps2)+  | length ps1 == length ps2 =+    mapErrorsM (uncurry f) (zip ps1 ps2)+  | otherwise = mismatchError ps1 ps2++processPairsM :: (Show a, Show b, Mergeable c, CollectErrorsM 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, CollectErrorsM m) =>+  (a -> b -> m c) -> Positional a -> Positional b -> m ()+processPairs_ f xs ys = processPairs f xs ys >> return ()++processPairsT :: (MonadTrans t, Monad (t m), Show a, Show b, ErrorContextM m) =>+  (a -> b -> t m c) -> Positional a -> Positional b -> t m [c]+processPairsT f (Positional ps1) (Positional ps2)+  | length ps1 == length ps2 =+    sequence $ map (uncurry f) (zip ps1 ps2)+  | otherwise = lift $ mismatchError ps1 ps2++mismatchError :: (Show a, Show b, ErrorContextM m) => [a] -> [b] -> m c+mismatchError ps1 ps2 = compilerErrorM $ "Count mismatch: " ++ show ps1 +++                                        " (expected) vs. " ++ show ps2 ++ " (actual)"

@@ -0,0 +1,259 @@+{- -----------------------------------------------------------------------------+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.TrackedErrors (+  TrackedErrors,+  TrackedErrorsIO,+  asCompilerError,+  asCompilerWarnings,+  fromTrackedErrors,+  getCompilerError,+  getCompilerErrorT,+  getCompilerSuccess,+  getCompilerSuccessT,+  getCompilerWarnings,+  getCompilerWarningsT,+  toTrackedErrors,+  tryTrackedErrorsIO,+) where++import Control.Applicative+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++#if MIN_VERSION_base(4,11,0)+#else+import Data.Semigroup+#endif++import Base.CompilerError+import Base.CompilerMessage+++type TrackedErrors = TrackedErrorsT Identity++type TrackedErrorsIO = TrackedErrorsT IO++data TrackedErrorsT m a =+  TrackedErrorsT {+    citState :: m (TrackedErrorsState a)+  }++getCompilerError :: TrackedErrors a -> CompilerMessage+getCompilerError = runIdentity . getCompilerErrorT++getCompilerSuccess :: TrackedErrors a -> a+getCompilerSuccess = runIdentity . getCompilerSuccessT++getCompilerWarnings :: TrackedErrors a -> CompilerMessage+getCompilerWarnings = runIdentity . getCompilerWarningsT++getCompilerErrorT :: Monad m => TrackedErrorsT m a -> m CompilerMessage+getCompilerErrorT = fmap cfErrors . citState++getCompilerSuccessT :: Monad m => TrackedErrorsT m a -> m a+getCompilerSuccessT = fmap csData . citState++getCompilerWarningsT :: Monad m => TrackedErrorsT m a -> m CompilerMessage+getCompilerWarningsT = fmap getWarnings . citState++fromTrackedErrors :: Monad m => TrackedErrors a -> TrackedErrorsT m a+fromTrackedErrors x = runIdentity $ do+  x' <- citState x+  return $ TrackedErrorsT $ return x'++asCompilerWarnings :: Monad m => TrackedErrors a -> TrackedErrorsT m ()+asCompilerWarnings x = runIdentity $ do+  x' <- citState x+  return $ TrackedErrorsT $ return $+    case x' of+         (CompilerFail ws es)      -> CompilerSuccess (ws <> es) [] ()+         (CompilerSuccess ws bs _) -> CompilerSuccess ws bs ()++asCompilerError :: Monad m => TrackedErrors a -> TrackedErrorsT m ()+asCompilerError x = runIdentity $ do+  x' <- citState x+  return $ TrackedErrorsT $ return $+    case x' of+         (CompilerSuccess ws bs _) -> includeBackground bs $ CompilerFail mempty ws+         (CompilerFail ws es)      -> CompilerFail ws es++toTrackedErrors :: Monad m => TrackedErrorsT m a -> m (TrackedErrors a)+toTrackedErrors x = do+  x' <- citState x+  return $ TrackedErrorsT $ return x'++tryTrackedErrorsIO :: String -> String -> TrackedErrorsIO a -> IO a+tryTrackedErrorsIO warn err x = do+  x' <- toTrackedErrors x+  let w = getCompilerWarnings $ x' <?? warn+  let e = getCompilerError    $ x' <?? err+  if isCompilerError x'+     then do+       hPutStr stderr $ show w+       hPutStr stderr $ show e+       exitFailure+     else do+       hPutStr stderr $ show w+       return $ getCompilerSuccess x'++data TrackedErrorsState a =+  CompilerFail {+    cfWarnings :: CompilerMessage,+    cfErrors :: CompilerMessage+  } |+  CompilerSuccess {+    csWarnings :: CompilerMessage,+    csBackground :: [String],+    csData :: a+  }++instance Show a => Show (TrackedErrorsState a) where+  show = format where+    format (CompilerFail w e) = intercalate "\n" $ errors ++ warnings where+      errors   = showAs "Errors:"   $ lines $ show e+      warnings = showAs "Warnings:" $ lines $ show w+    format (CompilerSuccess w b x) = intercalate "\n" $ content ++ warnings ++ background where+      content    = [show x]+      warnings   = showAs "Warnings:" $ lines $ show w+      background = showAs "Background:" b+    showAs m = (m:) . map ("  " ++)++instance Show a => Show (TrackedErrors a) where+  show = show . runIdentity . citState++instance (Functor m, Monad m) => Functor (TrackedErrorsT m) where+  fmap f x = TrackedErrorsT $ do+    x' <- citState x+    case x' of+         CompilerFail w e      -> return $ CompilerFail w e -- Not the same a.+         CompilerSuccess w b d -> return $ CompilerSuccess w b (f d)++instance (Applicative m, Monad m) => Applicative (TrackedErrorsT m) where+  pure = TrackedErrorsT .return . CompilerSuccess mempty []+  f <*> x = TrackedErrorsT $ do+    f' <- citState f+    x' <- citState x+    case (f',x') of+         (CompilerFail w e,_) ->+           return $ CompilerFail w e -- Not the same a.+         (i,CompilerFail w e) ->+           return $ CompilerFail (getWarnings i <> w) (prefixCompilerMessages (getBackground i) e)+         (CompilerSuccess w1 b1 f2,CompilerSuccess w2 b2 d) ->+           return $ CompilerSuccess (w1 <> w2) (b1 ++ b2) (f2 d)++instance Monad m => Monad (TrackedErrorsT m) where+  x >>= f = TrackedErrorsT $ do+    x' <- citState x+    case x' of+         CompilerFail w e -> return $ CompilerFail w e -- Not the same a.+         CompilerSuccess w b d -> do+           d2 <- citState $ f d+           return $ includeBackground b $ includeWarnings w d2+  return = pure++#if MIN_VERSION_base(4,9,0)+instance Monad m => MonadFail (TrackedErrorsT m) where+  fail = compilerErrorM+#endif++instance MonadTrans TrackedErrorsT where+  lift = TrackedErrorsT . fmap (CompilerSuccess mempty [])++instance MonadIO m => MonadIO (TrackedErrorsT m) where+  liftIO = lift . liftIO++instance Monad m => ErrorContextM (TrackedErrorsT m) where+  compilerErrorM e = TrackedErrorsT $ return $ CompilerFail mempty $ compilerMessage e+  withContextM x c = TrackedErrorsT $ do+    x' <- citState x+    case x' of+         CompilerFail w e        -> return $ CompilerFail (pushWarningScope c w) (pushErrorScope c e)+         CompilerSuccess w bs x2 -> return $ CompilerSuccess (pushWarningScope c w) bs x2+  summarizeErrorsM x e2 = TrackedErrorsT $ do+    x' <- citState x+    case x' of+         CompilerFail w e -> return $ CompilerFail w (pushErrorScope e2 e)+         x2 -> return x2+  compilerWarningM w = TrackedErrorsT (return $ CompilerSuccess (compilerMessage w) [] ())+  compilerBackgroundM b = TrackedErrorsT (return $ CompilerSuccess mempty [b] ())+  resetBackgroundM x = TrackedErrorsT $ do+    x' <- citState x+    case x' of+         CompilerSuccess w _ d -> return $ CompilerSuccess w [] d+         x2                   -> return x2++instance Monad m => CollectErrorsM (TrackedErrorsT m) where+  collectAllM = combineResults (select . splitErrorsAndData) where+    select ([],xs2,bs,ws) = CompilerSuccess (compilerMessages ws) bs xs2+    select (es,_,bs,ws)   = CompilerFail (compilerMessages ws) $ prefixCompilerMessages bs $ compilerMessages es+  collectAnyM = combineResults (select . splitErrorsAndData) where+    select (_,xs2,bs,ws) = CompilerSuccess (compilerMessages ws) bs xs2+  collectFirstM = combineResults (select . splitErrorsAndData) where+    select (_,x:_,bs,ws) = CompilerSuccess (compilerMessages ws) bs x+    select (es,_,bs,ws)  = CompilerFail (compilerMessages ws) $ prefixCompilerMessages bs $ compilerMessages es++instance ErrorContextT TrackedErrorsT where+  isCompilerErrorT x = do+    x' <- citState x+    case x' of+         CompilerFail _ _ -> return True+         _               -> return False++combineResults :: (Monad m, Foldable f) =>+  ([TrackedErrorsState a] -> TrackedErrorsState b) -> f (TrackedErrorsT m a) -> TrackedErrorsT m b+combineResults f = TrackedErrorsT . fmap f . sequence . map citState . foldr (:) []++getWarnings :: TrackedErrorsState a -> CompilerMessage+getWarnings (CompilerFail w _)      = w+getWarnings (CompilerSuccess w _ _) = w++includeWarnings :: CompilerMessage -> TrackedErrorsState a -> TrackedErrorsState a+includeWarnings = update where+  update w (CompilerSuccess w2 b d) = CompilerSuccess (w <> w2) b d+  update w (CompilerFail w2 e)      = CompilerFail (w <> w2) e++getBackground :: TrackedErrorsState a -> [String]+getBackground (CompilerSuccess _ b _) = b+getBackground _                      = []++includeBackground :: [String] -> TrackedErrorsState a -> TrackedErrorsState a+includeBackground b  (CompilerFail w e)       = CompilerFail w (prefixCompilerMessages b e)+includeBackground b1 (CompilerSuccess w b2 d) = CompilerSuccess w (b1 ++ b2) d++splitErrorsAndData :: Foldable f => f (TrackedErrorsState a) -> ([CompilerMessage],[a],[String],[CompilerMessage])+splitErrorsAndData = foldr partition ([],[],[],[]) where+  partition (CompilerFail w e)      (es,ds,bs,ws) = (e:es,ds,bs,w:ws)+  partition (CompilerSuccess w b d) (es,ds,bs,ws) = (es,d:ds,b++bs,w:ws)

@@ -32,15 +32,14 @@ import System.FilePath import System.Posix.Temp (mkstemps) import System.IO-import Text.Parsec (SourcePos) import qualified Data.Map as Map import qualified Data.Set as Set -import Base.CompileError-import Base.CompileInfo+import Base.CompilerError+import Base.TrackedErrors import Cli.CompileOptions import Cli.Programs-import Cli.TestRunner -- Not safe, due to Text.Regex.TDFA.+import Cli.TestRunner import Compilation.ProcedureContext (ExprMap) import CompilerCxx.Category import CompilerCxx.Naming@@ -48,6 +47,7 @@ import Module.Paths import Module.ProcessMetadata import Parser.SourceFile+import Parser.TextParser (SourceContext) import Types.Builtin import Types.DefinedCategory import Types.Pragma@@ -60,7 +60,7 @@   ModuleSpec {     msRoot :: FilePath,     msPath :: FilePath,-    msExprMap :: ExprMap SourcePos,+    msExprMap :: ExprMap SourceContext,     msPublicDeps :: [FilePath],     msPrivateDeps :: [FilePath],     msPublicFiles :: [FilePath],@@ -78,13 +78,13 @@     ltRoot :: FilePath,     ltPath :: FilePath,     ltMetadata :: CompileMetadata,-    ltExprMap :: ExprMap SourcePos,+    ltExprMap :: ExprMap SourceContext,     ltPublicDeps :: [CompileMetadata],     ltPrivateDeps :: [CompileMetadata]   }   deriving (Show) -compileModule :: (PathIOHandler r, CompilerBackend b) => r -> b -> ModuleSpec -> CompileInfoIO ()+compileModule :: (PathIOHandler r, CompilerBackend b) => r -> b -> ModuleSpec -> TrackedErrorsIO () 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@@ -221,7 +221,7 @@            Nothing -> return []     checkOwnedFile f2 = do       exists <- errorFromIO $ doesFileExist f2-      when (not exists) $ compileErrorM $ "Owned file " ++ f2 ++ " does not exist."+      when (not exists) $ compilerErrorM $ "Owned file " ++ f2 ++ " does not exist."       errorFromIO $ canonicalizePath f2     compileExtraFile e (ns0,ns1) paths f2       | isSuffixOf ".cpp" f2 || isSuffixOf ".cc" f2 = do@@ -233,8 +233,8 @@       | isSuffixOf ".a" f2 || isSuffixOf ".o" f2 = return (Just f2)       | otherwise = return Nothing     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."+      | length ms >  1 = compilerErrorM $ "Multiple matches for main category " ++ show n ++ "."+      | length ms == 0 = compilerErrorM $ "Main category " ++ show n ++ " not found."       | otherwise = do           f0 <- if null o                    then errorFromIO $ canonicalizePath $ p </> d </> show n@@ -262,7 +262,7 @@     maybeCreateMain _ _ _ = return []  createModuleTemplates :: PathIOHandler r => r -> FilePath -> FilePath ->-  [CompileMetadata] -> [CompileMetadata] -> CompileInfoIO ()+  [CompileMetadata] -> [CompileMetadata] -> TrackedErrorsIO () createModuleTemplates resolver p d deps1 deps2 = do   (ps,xs,_) <- findSourceFiles p d   (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _ _ _) <-@@ -281,13 +281,13 @@     let n' = p </> d </> n     exists <- errorFromIO $ doesFileExist n'     if exists-        then compileWarningM $ "Skipping existing file " ++ n+        then compilerWarningM $ "Skipping existing file " ++ n         else do           errorFromIO $ hPutStrLn stderr $ "Writing file " ++ n           errorFromIO $ writeFile n' $ concat $ map (++ "\n") content  runModuleTests :: (PathIOHandler r, CompilerBackend b) => r -> b -> FilePath ->-  [FilePath] -> LoadedTests -> CompileInfoIO [((Int,Int),CompileInfo ())]+  [FilePath] -> LoadedTests -> TrackedErrorsIO [((Int,Int),TrackedErrors ())] runModuleTests resolver backend base tp (LoadedTests p d m em deps1 deps2) = do   let paths = base:(cmPublicSubdirs m ++ cmPrivateSubdirs m ++ getIncludePathsForDeps deps1)   mapErrorsM_ showSkipped $ filter (not . isTestAllowed) $ cmTestFiles m@@ -297,9 +297,9 @@   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 = compileWarningM $ "Skipping tests in " ++ f ++ " due to explicit test filter."+    showSkipped f = compilerWarningM $ "Skipping tests in " ++ f ++ " due to explicit test filter." -loadPrivateSource :: PathIOHandler r => r -> VersionHash -> FilePath -> FilePath -> CompileInfoIO (PrivateSource SourcePos)+loadPrivateSource :: PathIOHandler r => r -> VersionHash -> FilePath -> FilePath -> TrackedErrorsIO (PrivateSource SourceContext) loadPrivateSource resolver h p f = do   [f'] <- zipWithContents resolver p [f]   time <- errorFromIO getZonedTime@@ -333,11 +333,11 @@   apply = foldr filter  warnPublic :: PathIOHandler r => r -> FilePath -> [CategoryName] ->-  [CategoryName] -> [ObjectFile] -> [FilePath] -> CompileInfoIO ()+  [CategoryName] -> [ObjectFile] -> [FilePath] -> TrackedErrorsIO () warnPublic resolver p pc dc os = mapErrorsM_ checkPublic where   checkPublic d = do     d2 <- resolveModule resolver p d-    when (not $ d2 `Set.member` neededPublic) $ compileWarningM $ "Dependency \"" ++ d ++ "\" does not need to be public"+    when (not $ d2 `Set.member` neededPublic) $ compilerWarningM $ "Dependency \"" ++ d ++ "\" does not need to be public"   pc' = Set.fromList pc   dc' = Set.fromList dc   neededPublic = Set.fromList $ concat $ map checkDep os

@@ -24,9 +24,9 @@  import Control.Monad (when) import Data.List (isSuffixOf)-import Text.Regex.TDFA -- Not safe!+import Text.Regex.TDFA -import Base.CompileError+import Base.CompilerError import Cli.CompileOptions import Types.TypeCategory (FunctionName(..)) import Types.TypeInstance (CategoryName(..))@@ -77,13 +77,13 @@ defaultMainFunc :: String defaultMainFunc = "run" -parseCompileOptions :: CompileErrorM m => [String] -> m CompileOptions+parseCompileOptions :: CollectErrorsM 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 = compileErrorM $ "Argument " ++ show n ++ " (\"" ++ o ++ "\"): " ++ m+  argError n o m = compilerErrorM $ "Argument " ++ show n ++ " (\"" ++ o ++ "\"): " ++ m   checkPathName n f o     | f =~ "^(/[^/]+|[^-/][^/]*)(/[^/]+)*$" = return ()     | null o    = argError n f "Invalid file path."@@ -204,21 +204,21 @@         checkPathName n d ""         return (os,CompileOptions (maybeDisableHelp h) is is2 (ds ++ [d]) es ep p m f) -validateCompileOptions :: CompileErrorM m => CompileOptions -> m CompileOptions+validateCompileOptions :: CollectErrorsM m => CompileOptions -> m CompileOptions validateCompileOptions co@(CompileOptions h is is2 ds _ _ _ m _)   | h /= HelpNotNeeded = return co    | (not $ null $ is ++ is2) && (isExecuteTests m) =-    compileErrorM "Include paths (-i/-I) are not allowed in test mode (-t)."+    compilerErrorM "Include paths (-i/-I) are not allowed in test mode (-t)."    | (not $ null $ is ++ is2) && (isCompileRecompile m) =-    compileErrorM "Include paths (-i/-I) are not allowed in recompile mode (-r/-R)."+    compilerErrorM "Include paths (-i/-I) are not allowed in recompile mode (-r/-R)."    | (length ds /= 0) && (isCompileFast m) =-    compileErrorM "Input path is not allowed with fast mode (--fast)."+    compilerErrorM "Input path is not allowed with fast mode (--fast)."   | null ds && (not $ isCompileFast m) =-    compileErrorM "Please specify at least one input path."+    compilerErrorM "Please specify at least one input path."   | (length ds > 1) && (not $ isCompileRecompile m) && (not $ isExecuteTests m) =-    compileErrorM "Multiple input paths are only allowed with recompile mode (-r/-R) and test mode (-t)."+    compilerErrorM "Multiple input paths are only allowed with recompile mode (-r/-R) and test mode (-t)."    | otherwise = return co

@@ -28,12 +28,12 @@  import Control.Monad.IO.Class -import Base.CompileError+import Base.CompilerError   class CompilerBackend b where-  runCxxCommand   :: (MonadIO m, CompileErrorM m) => b -> CxxCommand -> m String-  runTestCommand  :: (MonadIO m, CompileErrorM m) => b -> TestCommand -> m TestCommandResult+  runCxxCommand   :: (MonadIO m, ErrorContextM m) => b -> CxxCommand -> m String+  runTestCommand  :: (MonadIO m, ErrorContextM m) => b -> TestCommand -> m TestCommandResult   getCompilerHash :: b -> VersionHash  newtype VersionHash = VersionHash String deriving (Eq)

@@ -29,8 +29,8 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Base.CompileError-import Base.CompileInfo+import Base.CompilerError+import Base.TrackedErrors import Cli.CompileOptions import Cli.Compiler import Cli.Programs@@ -39,7 +39,7 @@ import Module.ProcessMetadata  -runCompiler :: (PathIOHandler r, CompilerBackend b) => r -> b -> CompileOptions -> CompileInfoIO ()+runCompiler :: (PathIOHandler r, CompilerBackend b) => r -> b -> CompileOptions -> TrackedErrorsIO () runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp) f) = do   base <- resolveBaseModule resolver   ts <- fmap snd $ foldM (preloadTests base) (Map.empty,[]) ds@@ -65,11 +65,11 @@       let possibleTests = Set.fromList $ concat $ map (cmTestFiles . ltMetadata) ts       case Set.toList $ (Set.fromList tp) `Set.difference` possibleTests of           [] -> return ()-          fs -> compileErrorM $ "Some test files do not occur in the selected modules: " +++          fs -> compilerErrorM $ "Some test files do not occur in the selected modules: " ++                                 intercalate ", " (map show fs) ++ "\n"     processResults passed failed rs-      | isCompileError rs =-        (fromCompileInfo rs) <!!+      | isCompilerError rs =+        (fromTrackedErrors rs) <!!           "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)"       | otherwise =         errorFromIO $ hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)"@@ -112,7 +112,7 @@       isSystem <- isSystemModule r p2 d0       if isSystem          then do-           compileWarningM $ "Skipping system dependency " ++ d0 ++ " for " ++ p2 ++ "."+           compilerWarningM $ "Skipping system dependency " ++ d0 ++ " for " ++ p2 ++ "."            return da          else do            d <- errorFromIO $ canonicalizePath (p2 </> d0)@@ -132,7 +132,7 @@       d <- errorFromIO $ canonicalizePath (p </> d0)       upToDate <- isPathUpToDate compilerHash f d       if f < ForceAll && upToDate-         then compileWarningM $ "Path " ++ d0 ++ " is up to date"+         then compilerWarningM $ "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 "..",@@ -175,7 +175,7 @@     as2 <- fmap fixPaths $ mapErrorsM (resolveModule resolver (p </> d)) is2     isConfigured <- isPathConfigured p d     when (isConfigured && f == DoNotForce) $ do-      compileErrorM $ "Module " ++ d ++ " has an existing configuration. " +++      compilerErrorM $ "Module " ++ d ++ " has an existing configuration. " ++                       "Recompile with -r or use -f to overwrite the config."     absolute <- errorFromIO $ canonicalizePath p     let rm = ModuleConfig {

@@ -28,12 +28,11 @@ import System.IO import System.Posix.Temp (mkdtemp) import System.FilePath-import Text.Parsec-import Text.Regex.TDFA -- Not safe!+import Text.Regex.TDFA import qualified Data.Map as Map -import Base.CompileError-import Base.CompileInfo+import Base.CompilerError+import Base.TrackedErrors import Cli.Programs import CompilerCxx.Category import CompilerCxx.Naming@@ -41,24 +40,25 @@ import Module.Paths import Module.ProcessMetadata import Parser.SourceFile+import Parser.TextParser (SourceContext) import Types.IntegrationTest import Types.Procedure import Types.TypeCategory  -runSingleTest :: CompilerBackend b => b -> LanguageModule SourcePos ->+runSingleTest :: CompilerBackend b => b -> LanguageModule SourceContext ->   FilePath -> [FilePath] -> [CompileMetadata] -> (String,String) ->-  CompileInfoIO ((Int,Int),CompileInfo ())+  TrackedErrorsIO ((Int,Int),TrackedErrors ()) runSingleTest b cm p paths deps (f,s) = do   errorFromIO $ hPutStrLn stderr $ "\nExecuting tests from " ++ f   allResults <- checkAndRun (parseTestSource (f,s))   return $ second (("\nIn test file " ++ f) ??>) allResults where     checkAndRun ts-      | isCompileError ts = do+      | isCompilerError ts = do         errorFromIO $ hPutStrLn stderr $ "Failed to parse tests in " ++ f         return ((0,1),ts >> return ())       | otherwise = do-          let (_,ts') = getCompileSuccess ts+          let (_,ts') = getCompilerSuccess ts           allResults <- mapErrorsM runSingle ts'           let passed = sum $ map (fst . fst) allResults           let failed = sum $ map (snd . fst) allResults@@ -70,43 +70,43 @@       let context = formatFullContextBrace (ithContext $ itHeader t)       let scope = "\nIn testcase \"" ++ ithTestName (itHeader t) ++ "\"" ++ context       errorFromIO $ hPutStrLn stderr $ "\n*** Executing testcase " ++ name ++ " ***"-      result <- toCompileInfo $ run (ithResult $ itHeader t) (ithArgs $ itHeader t) (itCategory t) (itDefinition t) (itTests t)-      if isCompileError result+      result <- toTrackedErrors $ run (ithResult $ itHeader t) (ithArgs $ itHeader t) (itCategory t) (itDefinition t) (itTests t)+      if isCompilerError result          then return ((0,1),scope ??> (result >> return ()))          else do-           let allResults = getCompileSuccess result-           let passed = length $ filter (not . isCompileError) allResults-           let failed = length $ filter isCompileError allResults+           let allResults = getCompilerSuccess result+           let passed = length $ filter (not . isCompilerError) allResults+           let failed = length $ filter isCompilerError allResults            let combined = scope ??> collectAllM_ allResults            if failed > 0              then errorFromIO $ hPutStrLn stderr $ "*** Some tests in testcase " ++ name ++ " failed ***"              else errorFromIO $ hPutStrLn stderr $ "*** All tests in testcase " ++ name ++ " passed ***"            return ((passed,failed),combined) -    run (ExpectCompileError _ rs es) args cs ds ts = do+    run (ExpectCompilerError _ rs es) args cs ds ts = do       let result = compileAll args cs ds ts-      if not $ isCompileError result-         then compileErrorM "Expected compilation failure"+      if not $ isCompilerError result+         then compilerErrorM "Expected compilation failure"          else fmap (:[]) $ return $ do-           let warnings = show $ getCompileWarnings result-           let errors   = show $ getCompileError result+           let warnings = show $ getCompilerWarnings result+           let errors   = show $ getCompilerError result            checkContent rs es (lines warnings ++ lines errors) [] []      run (ExpectCompiles _ rs es) args cs ds ts = do       let result = compileAll args cs ds ts-      if isCompileError result-         then fromCompileInfo result >> return []+      if isCompilerError result+         then fromTrackedErrors result >> return []          else fmap (:[]) $ return $ do-           let warnings = show $ getCompileWarnings result+           let warnings = show $ getCompilerWarnings result            checkContent rs es (lines warnings) [] []      run (ExpectRuntimeError _ rs es) args cs ds ts = do-      when (length ts /= 1) $ compileErrorM "Exactly one unittest is required when crash is expected"+      when (length ts /= 1) $ compilerErrorM "Exactly one unittest is required when crash is expected"       uniqueTestNames ts       execute False rs es args cs ds ts      run (ExpectRuntimeSuccess _ rs es) args cs ds ts = do-      when (null ts) $ compileErrorM "At least one unittest is required when success is expected"+      when (null ts) $ compilerErrorM "At least one unittest is required when success is expected"       uniqueTestNames ts       execute True rs es args cs ds ts @@ -115,14 +115,14 @@       let ce = checkExcluded es comp err out       let compError = if null comp                          then return ()-                         else (mapErrorsM_ compileErrorM comp) <?? "\nOutput from compiler:"+                         else (mapErrorsM_ compilerErrorM comp) <?? "\nOutput from compiler:"       let errError = if null err                         then return ()-                        else (mapErrorsM_ compileErrorM err) <?? "\nOutput to stderr from test:"+                        else (mapErrorsM_ compilerErrorM err) <?? "\nOutput to stderr from test:"       let outError = if null out                         then return ()-                        else (mapErrorsM_ compileErrorM out) <?? "\nOutput to stdout from test:"-      if isCompileError cr || isCompileError ce+                        else (mapErrorsM_ compilerErrorM out) <?? "\nOutput to stdout from test:"+      if isCompilerError cr || isCompilerError ce          then collectAllM_ [cr,ce,compError,errError,outError]          else collectAllM_ [cr,ce] @@ -131,30 +131,30 @@       mapErrorsM_ testClash $ Map.toList ts'     testClash (_,[_]) = return ()     testClash (n,ts) = "unittest " ++ show n ++ " is defined multiple times" !!>-      (mapErrorsM_ (compileErrorM . ("Defined at " ++) . formatFullContext) $ sort $ map tpContext ts)+      (mapErrorsM_ (compilerErrorM . ("Defined at " ++) . formatFullContext) $ sort $ map tpContext ts)      execute s2 rs es args cs ds ts = do       let result = compileAll args cs ds ts-      if isCompileError result+      if isCompilerError result          then return [result >> return ()]          else do-           let (xx,main,fs) = getCompileSuccess result+           let (xx,main,fs) = getCompilerSuccess result            (dir,binaryName) <- createBinary main xx-           results <- liftIO $ sequence $ map (toCompileInfo . executeTest binaryName rs es result s2) fs-           when (not $ any isCompileError results) $ errorFromIO $ removeDirectoryRecursive dir+           results <- liftIO $ sequence $ map (toTrackedErrors . executeTest binaryName rs es result s2) fs+           when (not $ any isCompilerError results) $ errorFromIO $ removeDirectoryRecursive dir            return results      executeTest binary rs es res s2 (f2,c) = printOutcome $ "\nIn unittest " ++ show f2 ++ formatFullContextBrace c ??> do       let command = TestCommand binary (takeDirectory binary) [show f2]       (TestCommandResult s2' out err) <- runTestCommand b command       case (s2,s2') of-           (True,False) -> collectAllM_ $ (asCompileError res):(map compileErrorM $ err ++ out)-           (False,True) -> collectAllM_ [compileErrorM "Expected runtime failure",-                                         asCompileError res <?? "\nOutput from compiler:"]-           _ -> fromCompileInfo $ checkContent rs es (lines $ show $ getCompileWarnings res) err out+           (True,False) -> collectAllM_ $ (asCompilerError res):(map compilerErrorM $ err ++ out)+           (False,True) -> collectAllM_ [compilerErrorM "Expected runtime failure",+                                         asCompilerError res <?? "\nOutput from compiler:"]+           _ -> fromTrackedErrors $ checkContent rs es (lines $ show $ getCompilerWarnings res) err out       where         printOutcome outcome = do-          failed <- isCompileErrorM outcome+          failed <- isCompilerErrorM outcome           if failed              then errorFromIO $ hPutStrLn stderr $ "--- unittest " ++ show f2 ++ " failed ---"              else errorFromIO $ hPutStrLn stderr $ "--- unittest " ++ show f2 ++ " passed ---"@@ -175,11 +175,11 @@       checkForRegex expected err r "test stderr"     checkSubsetForRegex expected _ _ out (OutputPattern OutputStdout r) =       checkForRegex expected out r "test stdout"-    checkForRegex :: Bool -> [String] -> String -> String -> CompileInfo ()+    checkForRegex :: Bool -> [String] -> String -> String -> TrackedErrors ()     checkForRegex expected ms r n = do       let found = any (=~ r) ms-      when (found && not expected) $ compileErrorM $ "Pattern \"" ++ r ++ "\" present in " ++ n-      when (not found && expected) $ compileErrorM $ "Pattern \"" ++ r ++ "\" missing from " ++ n+      when (found && not expected) $ compilerErrorM $ "Pattern \"" ++ r ++ "\" present in " ++ n+      when (not found && expected) $ compilerErrorM $ "Pattern \"" ++ r ++ "\" missing from " ++ n     createBinary (CxxOutput _ f2 _ ns req content) xx = do       dir <- errorFromIO $ mkdtemp "/tmp/ztest_"       errorFromIO $ hPutStrLn stderr $ "Writing temporary files to " ++ dir

@@ -23,7 +23,7 @@ {-# LANGUAGE ScopedTypeVariables #-}  module Compilation.CompilerState (-  CleanupSetup(..),+  CleanupBlock(..),   CompilerContext(..),   CompiledData(..),   CompilerState,@@ -32,11 +32,10 @@   JumpType(..),   MemberValue(..),   ReturnVariable(..),-  (<???),-  (???>),-  (<!!!),-  (!!!>),+  UsedVariable(..),   concatM,+  csAddRequired,+  csAddUsed,   csAddVariable,   csAllFilters,   csCheckValueInit,@@ -60,7 +59,6 @@   csRegisterReturn,   csReleaseExprMacro,   csReserveExprMacro,-  csRequiresTypes,   csResolver,   csSameType,   csSetJumpType,@@ -69,14 +67,13 @@   csStartLoop,   csUpdateAssigned,   csWrite,+  emptyCleanupBlock,   getCleanContext,-  isLoopBoundary,-  resetBackgroundStateT,   runDataCompiler, ) where  import Control.Monad.Trans (lift)-import Control.Monad.Trans.State (StateT(..),execStateT,get,mapStateT,put)+import Control.Monad.Trans.State (StateT(..),execStateT,get,put) import Data.Functor import Prelude hiding (foldr) import qualified Data.Set as Set@@ -86,9 +83,9 @@ import Data.Semigroup #endif -import Base.CompileError+import Base.CompilerError+import Base.Positional import Types.DefinedCategory-import Types.Positional import Types.Pragma (MacroName) import Types.Procedure import Types.TypeCategory@@ -103,29 +100,30 @@   ccSameType :: a -> TypeInstance -> m Bool   ccAllFilters :: a -> m ParamFilters   ccGetParamScope :: a -> ParamName -> m SymbolScope-  ccRequiresTypes :: a -> Set.Set CategoryName -> m a+  ccAddRequired :: a -> Set.Set CategoryName -> m a   ccGetRequired :: a -> m (Set.Set CategoryName)   ccGetCategoryFunction :: a -> [c] -> Maybe CategoryName -> FunctionName -> m (ScopedFunction c)   ccGetTypeFunction :: a -> [c] -> Maybe GeneralInstance -> FunctionName -> m (ScopedFunction c)   ccCheckValueInit :: a -> [c] -> TypeInstance -> ExpressionType -> Positional GeneralInstance -> m ()-  ccGetVariable :: a -> [c] -> VariableName -> m (VariableValue c)-  ccAddVariable :: a -> [c] -> VariableName -> VariableValue c -> m a-  ccCheckVariableInit :: a -> [c] -> VariableName -> m ()+  ccGetVariable :: a -> UsedVariable c -> m (VariableValue c)+  ccAddVariable :: a -> UsedVariable c -> VariableValue c -> m a+  ccCheckVariableInit :: a -> [UsedVariable c] -> m ()   ccWrite :: a -> s -> m a   ccGetOutput :: a -> m s   ccClearOutput :: a -> m a   ccUpdateAssigned :: a -> VariableName -> m a+  ccAddUsed :: a -> UsedVariable c -> m a   ccInheritReturns :: a -> [a] -> m a   ccRegisterReturn :: a -> [c] -> Maybe ExpressionType -> m a   ccPrimNamedReturns :: a -> m [ReturnVariable]   ccIsUnreachable :: a -> m Bool   ccIsNamedReturns :: a -> m Bool-  ccSetJumpType :: a -> JumpType -> m a+  ccSetJumpType :: a -> [c] -> JumpType -> m a   ccStartLoop :: a -> LoopSetup s -> m a   ccGetLoop :: a -> m (LoopSetup s)   ccStartCleanup :: a -> m a-  ccPushCleanup :: a -> CleanupSetup a s -> m a-  ccGetCleanup :: a -> JumpType -> m (CleanupSetup a s)+  ccPushCleanup :: a -> a -> m a+  ccGetCleanup :: a -> JumpType -> m (CleanupBlock c s)   ccExprLookup :: a -> [c] -> MacroName -> m (Expression c)   ccReserveExprMacro :: a -> [c] -> MacroName -> m a   ccReleaseExprMacro :: a -> [c] -> MacroName -> m a@@ -156,17 +154,25 @@   } |   NotInLoop -data CleanupSetup a s =-  CleanupSetup {-    csReturnContext :: [a],-    csCleanup :: s-  } |-  LoopBoundary+data UsedVariable c =+  UsedVariable {+    uvContext :: [c],+    uvName :: VariableName+  }+  deriving (Show) -isLoopBoundary :: CleanupSetup a s -> Bool-isLoopBoundary LoopBoundary = True-isLoopBoundary _            = False+data CleanupBlock c s =+  CleanupBlock {+    csCleanup :: s,+    csUsesVars :: [UsedVariable c],+    csJumpType :: JumpType,+    csRequires :: Set.Set CategoryName+  }+  deriving (Show) +emptyCleanupBlock :: Monoid s => CleanupBlock c s+emptyCleanupBlock = CleanupBlock mempty [] NextStatement Set.empty+ data JumpType =   NextStatement |   JumpContinue |@@ -179,25 +185,6 @@ instance Show c => Show (VariableValue c) where   show (VariableValue c _ t _) = show t ++ formatFullContextBrace c -(<???) :: CompileErrorM m => CompilerState a m b -> String -> CompilerState a m b-(<???) x s = mapStateT (<?? s) x-infixl 1 <???--(???>) :: CompileErrorM m => String -> CompilerState a m b -> CompilerState a m b-(???>) s x = mapStateT (s ??>) x-infixr 1 ???>--(<!!!) :: CompileErrorM m => CompilerState a m b -> String -> CompilerState a m b-(<!!!) x s = mapStateT (<!! s) x-infixl 1 <!!!--(!!!>) :: CompileErrorM m => String -> CompilerState a m b -> CompilerState a m b-(!!!>) s x = mapStateT (s !!>) x-infixr 1 !!!>--resetBackgroundStateT :: CompileErrorM m => CompilerState a m b -> CompilerState a m b-resetBackgroundStateT x = mapStateT resetBackgroundM x- csCurrentScope :: CompilerContext c m s a => CompilerState a m SymbolScope csCurrentScope = fmap ccCurrentScope get >>= lift @@ -213,8 +200,8 @@ csGetParamScope :: CompilerContext c m s a => ParamName -> CompilerState a m SymbolScope csGetParamScope n = fmap (\x -> ccGetParamScope x n) get >>= lift -csRequiresTypes :: CompilerContext c m s a => Set.Set CategoryName -> CompilerState a m ()-csRequiresTypes ns = fmap (\x -> ccRequiresTypes x ns) get >>= lift >>= put+csAddRequired :: CompilerContext c m s a => Set.Set CategoryName -> CompilerState a m ()+csAddRequired ns = fmap (\x -> ccAddRequired x ns) get >>= lift >>= put  csGetRequired :: CompilerContext c m s a => CompilerState a m (Set.Set CategoryName) csGetRequired = fmap ccGetRequired get >>= lift@@ -232,16 +219,16 @@ csCheckValueInit c t as ps = fmap (\x -> ccCheckValueInit x c t as ps) get >>= lift  csGetVariable :: CompilerContext c m s a =>-  [c] -> VariableName -> CompilerState a m (VariableValue c)-csGetVariable c n = fmap (\x -> ccGetVariable x c n) get >>= lift+  UsedVariable c -> CompilerState a m (VariableValue c)+csGetVariable v = fmap (\x -> ccGetVariable x v) get >>= lift  csAddVariable :: CompilerContext c m s a =>-  [c] -> VariableName -> VariableValue c -> CompilerState a m ()-csAddVariable c n t = fmap (\x -> ccAddVariable x c n t) get >>= lift >>= put+  UsedVariable c -> VariableValue c -> CompilerState a m ()+csAddVariable v t = fmap (\x -> ccAddVariable x v t) get >>= lift >>= put  csCheckVariableInit :: CompilerContext c m s a =>-  [c] -> VariableName -> CompilerState a m ()-csCheckVariableInit c n = fmap (\x -> ccCheckVariableInit x c n) get >>= lift+  [UsedVariable c] -> CompilerState a m ()+csCheckVariableInit vs = fmap (\x -> ccCheckVariableInit x vs) get >>= lift  csWrite :: CompilerContext c m s a => s -> CompilerState a m () csWrite o = fmap (\x -> ccWrite x o) get >>= lift >>= put@@ -255,6 +242,9 @@ csUpdateAssigned :: CompilerContext c m s a => VariableName -> CompilerState a m () csUpdateAssigned n = fmap (\x -> ccUpdateAssigned x n) get >>= lift >>= put +csAddUsed :: CompilerContext c m s a => UsedVariable c -> CompilerState a m ()+csAddUsed n = fmap (\x -> ccAddUsed x n) get >>= lift >>= put+ csInheritReturns :: CompilerContext c m s a => [a] -> CompilerState a m () csInheritReturns xs = fmap (\x -> ccInheritReturns x xs) get >>= lift >>= put @@ -271,8 +261,8 @@ csIsNamedReturns :: CompilerContext c m s a => CompilerState a m Bool csIsNamedReturns = fmap ccIsNamedReturns get >>= lift -csSetJumpType :: CompilerContext c m s a => JumpType -> CompilerState a m ()-csSetJumpType j = fmap (\x -> ccSetJumpType x j) get >>= lift >>= put+csSetJumpType :: CompilerContext c m s a => [c] -> JumpType -> CompilerState a m ()+csSetJumpType c j = fmap (\x -> ccSetJumpType x c j) get >>= lift >>= put  csStartLoop :: CompilerContext c m s a => LoopSetup s -> CompilerState a m () csStartLoop l = fmap (\x -> ccStartLoop x l) get >>= lift >>= put@@ -283,10 +273,10 @@ csGetLoop :: CompilerContext c m s a => CompilerState a m (LoopSetup s) csGetLoop = fmap ccGetLoop get >>= lift -csPushCleanup :: CompilerContext c m s a => CleanupSetup a s -> CompilerState a m ()+csPushCleanup :: CompilerContext c m s a => a -> CompilerState a m () csPushCleanup l = fmap (\x -> ccPushCleanup x l) get >>= lift >>= put -csGetCleanup :: CompilerContext c m s a => JumpType -> CompilerState a m (CleanupSetup a s)+csGetCleanup :: CompilerContext c m s a => JumpType -> CompilerState a m (CleanupBlock c s) csGetCleanup j = fmap (\x -> ccGetCleanup x j) get >>= lift  csExprLookup :: CompilerContext c m s a => [c] -> MacroName -> CompilerState a m (Expression c)@@ -329,7 +319,7 @@       cdOutput = output     } -concatM :: (Semigroup s, Monoid s, CompileErrorM m) => [m (CompiledData s)] -> m (CompiledData s)+concatM :: (Semigroup s, Monoid s, CollectErrorsM m) => [m (CompiledData s)] -> m (CompiledData s) concatM = fmap mconcat . collectAllM  getCleanContext :: CompilerContext c m s a => CompilerState a m a

@@ -29,15 +29,16 @@ ) where  import Control.Monad (when)+import Data.Maybe (fromJust,isJust) import qualified Data.Map as Map import qualified Data.Set as Set -import Base.CompileError+import Base.CompilerError+import Base.GeneralType import Base.MergeTree+import Base.Positional import Compilation.CompilerState import Types.DefinedCategory-import Types.GeneralType-import Types.Positional import Types.Pragma (MacroName) import Types.Procedure import Types.TypeCategory@@ -66,8 +67,9 @@     pcOutput :: [String],     pcDisallowInit :: Bool,     pcLoopSetup :: LoopSetup [String],-    pcCleanupSetup :: [CleanupSetup (ProcedureContext c) [String]],+    pcCleanupBlocks :: [Maybe (CleanupBlock c [String])],     pcInCleanup :: Bool,+    pcUsedVars :: [UsedVariable c],     pcExprMap :: ExprMap c,     pcReservedMacros :: [(MacroName,[c])],     pcNoTrace :: Bool@@ -84,8 +86,9 @@     vnTypes :: Positional (PassedValue c),     vnRemaining :: Map.Map VariableName (PassedValue c)   }+  deriving (Show) -instance (Show c, CompileErrorM m) =>+instance (Show c, CollectErrorsM m) =>   CompilerContext c m [String] (ProcedureContext c) where   ccCurrentScope = return . pcScope   ccResolver = return . AnyTypeResolver . CategoryResolver . pcCategories@@ -95,8 +98,8 @@   ccGetParamScope ctx p = do     case p `Map.lookup` pcParamScopes ctx of             (Just s) -> return s-            _ -> compileErrorM $ "Param " ++ show p ++ " does not exist"-  ccRequiresTypes ctx ts = return $+            _ -> compilerErrorM $ "Param " ++ show p ++ " does not exist"+  ccAddRequired ctx ts = return $     ProcedureContext {       pcScope = pcScope ctx,       pcType = pcType ctx,@@ -118,8 +121,9 @@       pcOutput = pcOutput ctx,       pcDisallowInit = pcDisallowInit ctx,       pcLoopSetup = pcLoopSetup ctx,-      pcCleanupSetup = pcCleanupSetup ctx,+      pcCleanupBlocks = pcCleanupBlocks ctx,       pcInCleanup = pcInCleanup ctx,+      pcUsedVars = pcUsedVars ctx,       pcExprMap = pcExprMap ctx,       pcReservedMacros = pcReservedMacros ctx,       pcNoTrace = pcNoTrace ctx@@ -137,13 +141,13 @@         checkFunction $ n `Map.lookup` fa     checkFunction (Just f) = do       when (pcDisallowInit ctx && t == pcType ctx && pcScope ctx == CategoryScope) $-        compileErrorM $ "Function " ++ show n +++        compilerErrorM $ "Function " ++ show n ++                        " disallowed during initialization" ++ formatFullContextBrace c       when (sfScope f /= CategoryScope) $-        compileErrorM $ "Function " ++ show n ++ " in " ++ show t ++ " cannot be used as a category function"+        compilerErrorM $ "Function " ++ show n ++ " in " ++ show t ++ " cannot be used as a category function"       return f     checkFunction _ =-      compileErrorM $ "Category " ++ show t +++      compilerErrorM $ "Category " ++ show t ++                      " does not have a category function named " ++ show n ++                      formatFullContextBrace c   ccGetTypeFunction ctx c t n = getFunction t where@@ -152,7 +156,7 @@       let ps = fmap (singleType . JustParamName False . vpParam) $ pcExtParams ctx       getFunction (Just $ singleType $ JustTypeInstance $ TypeInstance (pcType ctx) ps)     getFromAny _ =-      compileErrorM $ "Use explicit type conversion to call " ++ show n ++ " from " ++ show t+      compilerErrorM $ "Use explicit type conversion to call " ++ show n ++ " from " ++ show t     getFromAll ts = do       collectFirstM ts <!!         "Function " ++ show n ++ " not available for type " ++ show t ++ formatFullContextBrace c@@ -160,7 +164,7 @@       fa <- ccAllFilters ctx       fs <- case p `Map.lookup` fa of                 (Just fs) -> return fs-                _ -> compileErrorM $ "Param " ++ show p ++ " does not exist"+                _ -> compilerErrorM $ "Param " ++ show p ++ " does not exist"       let ts = map tfType $ filter isRequiresFilter fs       let ds = map dfType $ filter isDefinesFilter  fs       collectFirstM (map (getFunction . Just) ts ++ map checkDefine ds) <!!@@ -175,7 +179,7 @@         let params = Positional $ map vpParam $ getCategoryParams ca         let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca         subAndCheckFunction (tiName t2) params (tiParams t2) $ n `Map.lookup` fa-    getFromSingle _ = compileErrorM $ "Type " ++ show t ++ " contains unresolved types"+    getFromSingle _ = compilerErrorM $ "Type " ++ show t ++ " contains unresolved types"     checkDefine t2 = do       (_,ca) <- getCategory (pcCategories ctx) (c,diName t2)       let params = Positional $ map vpParam $ getCategoryParams ca@@ -183,22 +187,22 @@       subAndCheckFunction (diName t2) params (diParams t2) $ n `Map.lookup` fa     subAndCheckFunction t2 ps1 ps2 (Just f) = do       when (pcDisallowInit ctx && t2 == pcType ctx) $-        compileErrorM $ "Function " ++ show n +++        compilerErrorM $ "Function " ++ show n ++                        " disallowed during initialization" ++ formatFullContextBrace c       when (sfScope f == CategoryScope) $-        compileErrorM $ "Function " ++ show n ++ " in " ++ show t2 +++        compilerErrorM $ "Function " ++ show n ++ " in " ++ show t2 ++                        " is a category function" ++ formatFullContextBrace c       paired <- processPairs alwaysPair ps1 ps2 <??         "In external function call at " ++ formatFullContext c       let assigned = Map.fromList paired       uncheckedSubFunction assigned f     subAndCheckFunction t2 _ _ _ =-      compileErrorM $ "Category " ++ show t2 +++      compilerErrorM $ "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 =-      compileErrorM $ "Category " ++ show (pcType ctx) ++ " cannot initialize values from " +++      compilerErrorM $ "Category " ++ show (pcType ctx) ++ " cannot initialize values from " ++                      show t ++ formatFullContextBrace c     | otherwise = "In initialization at " ++ formatFullContext c ??> do       let t' = TypeInstance (pcType ctx) as@@ -231,17 +235,17 @@         subSingle pa (DefinedMember c2 _ t2 n _) = do           t2' <- uncheckedSubValueType (getValueForParam pa) t2           return $ MemberValue c2 n t2'-  ccGetVariable ctx c n =+  ccGetVariable ctx (UsedVariable c n) =     case n `Map.lookup` pcVariables ctx of           (Just v) -> return v-          _ -> compileErrorM $ "Variable " ++ show n ++ " is not defined" ++-                               formatFullContextBrace c-  ccAddVariable ctx c n t = do+          _ -> compilerErrorM $ "Variable " ++ show n ++ " is not defined" +++                                formatFullContextBrace c+  ccAddVariable ctx (UsedVariable c n) t = do     case n `Map.lookup` pcVariables ctx of           Nothing -> return ()-          (Just v) -> compileErrorM $ "Variable " ++ show n ++-                                      formatFullContextBrace c ++-                                      " is already defined: " ++ show v+          (Just v) -> compilerErrorM $ "Variable " ++ show n +++                                       formatFullContextBrace c +++                                       " is already defined: " ++ show v     return $ ProcedureContext {         pcScope = pcScope ctx,         pcType = pcType ctx,@@ -263,17 +267,25 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,+        pcCleanupBlocks = pcCleanupBlocks ctx,         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }-  ccCheckVariableInit ctx c n =-    case pcReturns ctx of-         ValidateNames _ _ na -> when (n `Map.member` na) $-           compileErrorM $ "Named return " ++ show n ++ " might not be initialized" ++ formatFullContextBrace c-         _ -> return ()+  ccCheckVariableInit ctx vs+    -- Returns are checked during cleanup inlining.+    | pcInCleanup ctx = return ()+    | otherwise =+        case pcReturns ctx of+             ValidateNames _ _ na -> mapErrorsM_ (checkSingle na) vs+             _ -> return ()+        where+          checkSingle na (UsedVariable c n) =+             when (n `Map.member` na) $+               compilerErrorM $ "Named return " ++ show n +++                                " might not be initialized" ++ formatFullContextBrace c   ccWrite ctx ss = return $     ProcedureContext {       pcScope = pcScope ctx,@@ -296,8 +308,9 @@       pcOutput = pcOutput ctx ++ ss,       pcDisallowInit = pcDisallowInit ctx,       pcLoopSetup = pcLoopSetup ctx,-      pcCleanupSetup = pcCleanupSetup ctx,+      pcCleanupBlocks = pcCleanupBlocks ctx,       pcInCleanup = pcInCleanup ctx,+      pcUsedVars = pcUsedVars ctx,       pcExprMap = pcExprMap ctx,       pcReservedMacros = pcReservedMacros ctx,       pcNoTrace = pcNoTrace ctx@@ -324,8 +337,9 @@         pcOutput = [],         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,+        pcCleanupBlocks = pcCleanupBlocks ctx,         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx@@ -352,13 +366,44 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,+        pcCleanupBlocks = pcCleanupBlocks ctx,         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx       }     update _ = return ctx+  ccAddUsed ctx v+    | pcInCleanup ctx = return $ ProcedureContext {+          pcScope = pcScope ctx,+          pcType = pcType ctx,+          pcExtParams = pcExtParams ctx,+          pcIntParams = pcIntParams ctx,+          pcMembers = pcMembers ctx,+          pcCategories = pcCategories ctx,+          pcAllFilters = pcAllFilters ctx,+          pcExtFilters = pcExtFilters ctx,+          pcIntFilters = pcIntFilters ctx,+          pcParamScopes = pcParamScopes ctx,+          pcFunctions = pcFunctions ctx,+          pcVariables = pcVariables ctx,+          pcReturns = pcReturns ctx,+          pcJumpType = pcJumpType ctx,+          pcIsNamed = pcIsNamed ctx,+          pcPrimNamed = pcPrimNamed ctx,+          pcRequiredTypes = pcRequiredTypes ctx,+          pcOutput = pcOutput ctx,+          pcDisallowInit = pcDisallowInit ctx,+          pcLoopSetup = pcLoopSetup ctx,+          pcCleanupBlocks = pcCleanupBlocks ctx,+          pcInCleanup = pcInCleanup ctx,+          pcUsedVars = v:(pcUsedVars ctx),+          pcExprMap = pcExprMap ctx,+          pcReservedMacros = pcReservedMacros ctx,+          pcNoTrace = pcNoTrace ctx+        }+    | otherwise = return ctx   ccInheritReturns ctx cs = return $ ProcedureContext {       pcScope = pcScope ctx,       pcType = pcType ctx,@@ -380,26 +425,26 @@       pcOutput = pcOutput ctx,       pcDisallowInit = pcDisallowInit ctx,       pcLoopSetup = pcLoopSetup ctx,-      pcCleanupSetup = pcCleanupSetup ctx,+      pcCleanupBlocks = pcCleanupBlocks ctx,       pcInCleanup = pcInCleanup ctx,+      pcUsedVars = used,       pcExprMap = pcExprMap ctx,       pcReservedMacros = pcReservedMacros ctx,       pcNoTrace = pcNoTrace ctx     }     where+      used = pcUsedVars ctx ++ (concat $ map pcUsedVars cs)       (returns,jump) = combineSeries (pcReturns ctx,pcJumpType ctx) inherited       combineSeries (r@(ValidatePositions _),j1) (_,j2) = (r,max j1 j2)       combineSeries (_,j1) (r@(ValidatePositions _),j2) = (r,max j1 j2)       combineSeries (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ Map.intersection ra1 ra2,max j1 j2)       inherited = foldr combineParallel (ValidateNames (Positional []) (Positional []) Map.empty,JumpMax) $ zip (map pcReturns cs) (map pcJumpType cs)-      combineParallel (_,j1) (r,j2)-        -- Ignore a branch if it jumps to a higher scope.-        | (if pcInCleanup ctx then j1 > JumpReturn else j1 > NextStatement) = (r,min j1 j2)+      -- Ignore a branch if it jumps to a higher scope.+      combineParallel (_,j1) (r,j2) | j1 > NextStatement = (r,min j1 j2)       combineParallel (ValidateNames ns ts ra1,j1) (ValidateNames _ _ ra2,j2) = (ValidateNames ns ts $ Map.union ra1 ra2,min j1 j2)       combineParallel (r@(ValidatePositions _),j1) (_,j2) = (r,min j1 j2)       combineParallel (_,j1) (r@(ValidatePositions _),j2) = (r,min j1 j2)   ccRegisterReturn ctx c vs = do-    when (pcInCleanup ctx) $ compileErrorM $ "Explicit return at " ++ formatFullContext c ++ " not allowed in cleanup"     returns <- check (pcReturns ctx)     return $ ProcedureContext {         pcScope = pcScope ctx,@@ -422,8 +467,9 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,+        pcCleanupBlocks = pcCleanupBlocks ctx,         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx@@ -451,42 +497,50 @@              Just _  -> check (ValidatePositions ts) >> return ()              Nothing -> mapErrorsM_ alwaysError $ Map.toList ra         return (ValidateNames ns ts Map.empty)-      alwaysError (n,t) = compileErrorM $ "Named return " ++ show n ++ " (" ++ show t ++-                                          ") might not have been set before return at " ++-                                          formatFullContext c+      alwaysError (n,_) = compilerErrorM $ "Named return " ++ show n +++                                           " might not be initialized" +++                                           formatFullContextBrace c   ccPrimNamedReturns = return . pcPrimNamed   ccIsUnreachable ctx     | pcInCleanup ctx = return $ pcJumpType ctx > JumpReturn     | otherwise       = return $ pcJumpType ctx > NextStatement   ccIsNamedReturns = return . pcIsNamed-  ccSetJumpType ctx j =-    return $ ProcedureContext {-        pcScope = pcScope ctx,-        pcType = pcType ctx,-        pcExtParams = pcExtParams ctx,-        pcIntParams = pcIntParams ctx,-        pcMembers = pcMembers ctx,-        pcCategories = pcCategories ctx,-        pcAllFilters = pcAllFilters ctx,-        pcExtFilters = pcExtFilters ctx,-        pcIntFilters = pcIntFilters ctx,-        pcParamScopes = pcParamScopes ctx,-        pcFunctions = pcFunctions ctx,-        pcVariables = pcVariables ctx,-        pcReturns = pcReturns ctx,-        pcJumpType = j,-        pcIsNamed = pcIsNamed ctx,-        pcPrimNamed = pcPrimNamed ctx,-        pcRequiredTypes = pcRequiredTypes ctx,-        pcOutput = pcOutput ctx,-        pcDisallowInit = pcDisallowInit ctx,-        pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,-        pcInCleanup = pcInCleanup ctx,-        pcExprMap = pcExprMap ctx,-        pcReservedMacros = pcReservedMacros ctx,-        pcNoTrace = pcNoTrace ctx-      }+  ccSetJumpType ctx c j+    | pcInCleanup ctx && j == JumpBreak =+        compilerErrorM $ "Explicit break at " ++ formatFullContext c ++ " not allowed in cleanup"+    | pcInCleanup ctx && j == JumpContinue =+        compilerErrorM $ "Explicit continue at " ++ formatFullContext c ++ " not allowed in cleanup"+    | pcInCleanup ctx && j == JumpReturn =+        compilerErrorM $ "Explicit return at " ++ formatFullContext c ++ " not allowed in cleanup"+    | otherwise =+      return $ ProcedureContext {+          pcScope = pcScope ctx,+          pcType = pcType ctx,+          pcExtParams = pcExtParams ctx,+          pcIntParams = pcIntParams ctx,+          pcMembers = pcMembers ctx,+          pcCategories = pcCategories ctx,+          pcAllFilters = pcAllFilters ctx,+          pcExtFilters = pcExtFilters ctx,+          pcIntFilters = pcIntFilters ctx,+          pcParamScopes = pcParamScopes ctx,+          pcFunctions = pcFunctions ctx,+          pcVariables = pcVariables ctx,+          pcReturns = pcReturns ctx,+          pcJumpType = max j (pcJumpType ctx),+          pcIsNamed = pcIsNamed ctx,+          pcPrimNamed = pcPrimNamed ctx,+          pcRequiredTypes = pcRequiredTypes ctx,+          pcOutput = pcOutput ctx,+          pcDisallowInit = pcDisallowInit ctx,+          pcLoopSetup = pcLoopSetup ctx,+          pcCleanupBlocks = pcCleanupBlocks ctx,+          pcInCleanup = pcInCleanup ctx,+          pcUsedVars = pcUsedVars ctx,+          pcExprMap = pcExprMap ctx,+          pcReservedMacros = pcReservedMacros ctx,+          pcNoTrace = pcNoTrace ctx+        }   ccStartLoop ctx l =     return $ ProcedureContext {         pcScope = pcScope ctx,@@ -509,8 +563,9 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = l,-        pcCleanupSetup = LoopBoundary:(pcCleanupSetup ctx),+        pcCleanupBlocks = Nothing:(pcCleanupBlocks ctx),         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx@@ -539,8 +594,9 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,+        pcCleanupBlocks = pcCleanupBlocks ctx,         pcInCleanup = True,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx@@ -552,7 +608,7 @@         case n `Map.lookup` vs of              Just (VariableValue c s@LocalScope t _) -> Map.insert n (VariableValue c s t False) vs              _ -> vs-  ccPushCleanup ctx cs =+  ccPushCleanup ctx ctx2 =     return $ ProcedureContext {         pcScope = pcScope ctx,         pcType = pcType ctx,@@ -574,21 +630,30 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = cs:(pcCleanupSetup ctx),+        pcCleanupBlocks = (Just cleanup):(pcCleanupBlocks ctx),         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx-      }+      } where+        cleanup = CleanupBlock (pcOutput ctx2) (pcUsedVars ctx2) (pcJumpType ctx2) (pcRequiredTypes ctx2)   ccGetCleanup ctx j = return combined where     combined-      | j == JumpReturn                   = combine $ filter    (not . isLoopBoundary) $ pcCleanupSetup ctx-      | j == JumpBreak || j == JumpReturn = combine $ takeWhile (not . isLoopBoundary) $ pcCleanupSetup ctx-      | otherwise = CleanupSetup [] []-    combine cs = CleanupSetup (concat $ map csReturnContext cs) (concat $ map csCleanup cs)+      | j == NextStatement =+          case pcCleanupBlocks ctx of+               ((Just b):_) -> b+               _            -> emptyCleanupBlock+      | j == JumpReturn                     = combine $ map fromJust $ filter    isJust $ pcCleanupBlocks ctx+      | j == JumpBreak || j == JumpContinue = combine $ map fromJust $ takeWhile isJust $ pcCleanupBlocks ctx+      | otherwise = emptyCleanupBlock+    combine cs = CleanupBlock (concat $ map csCleanup cs)+                              (concat $ map csUsesVars cs)+                              (foldr max NextStatement (map csJumpType cs))+                              (Set.unions $ map csRequires cs)   ccExprLookup ctx c n =     case n `Map.lookup` pcExprMap ctx of-         Nothing -> compileErrorM $ "Env expression " ++ show n ++ " is not defined" ++ formatFullContextBrace c+         Nothing -> compilerErrorM $ "Env expression " ++ show n ++ " is not defined" ++ formatFullContextBrace c          Just e -> do            checkReserved (pcReservedMacros ctx) [(n,c)]            return e@@ -598,7 +663,7 @@         | n2 /= n = checkReserved ms (m:rs)         | otherwise = (mapErrorsM_ singleError (m:rs)) <!!             "Expression macro " ++ show n ++ " references itself"-      singleError (n2,c2) = compileErrorM $ show n2 ++ " expanded at " ++ formatFullContext c2+      singleError (n2,c2) = compilerErrorM $ show n2 ++ " expanded at " ++ formatFullContext c2   ccReserveExprMacro ctx c n =     return $ ProcedureContext {         pcScope = pcScope ctx,@@ -621,8 +686,9 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,+        pcCleanupBlocks = pcCleanupBlocks ctx,         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = ((n,c):pcReservedMacros ctx),         pcNoTrace = pcNoTrace ctx@@ -649,8 +715,9 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,+        pcCleanupBlocks = pcCleanupBlocks ctx,         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = filter ((/= n) . fst) $ pcReservedMacros ctx,         pcNoTrace = pcNoTrace ctx@@ -677,15 +744,16 @@         pcOutput = pcOutput ctx,         pcDisallowInit = pcDisallowInit ctx,         pcLoopSetup = pcLoopSetup ctx,-        pcCleanupSetup = pcCleanupSetup ctx,+        pcCleanupBlocks = pcCleanupBlocks ctx,         pcInCleanup = pcInCleanup ctx,+        pcUsedVars = pcUsedVars ctx,         pcExprMap = pcExprMap ctx,         pcReservedMacros = pcReservedMacros ctx,         pcNoTrace = t       }   ccGetNoTrace = return . pcNoTrace -updateReturnVariables :: (Show c, CompileErrorM m) =>+updateReturnVariables :: (Show c, CollectErrorsM m) =>   (Map.Map VariableName (VariableValue c)) ->   Positional (PassedValue c) -> ReturnValues c ->   m (Map.Map VariableName (VariableValue c))@@ -699,12 +767,12 @@           va' <- va           case ovName r `Map.lookup` va' of                Nothing -> return $ Map.insert (ovName r) (VariableValue c LocalScope t True) va'-               (Just v) -> compileErrorM $ "Variable " ++ show (ovName r) +++               (Just v) -> compilerErrorM $ "Variable " ++ show (ovName r) ++                                           formatFullContextBrace (ovContext r) ++                                           " is already defined" ++                                           formatFullContextBrace (vvContext v) -updateArgVariables :: (Show c, CompileErrorM m) =>+updateArgVariables :: (Show c, CollectErrorsM m) =>   (Map.Map VariableName (VariableValue c)) ->   Positional (PassedValue c) -> ArgValues c ->   m (Map.Map VariableName (VariableValue c))@@ -716,7 +784,7 @@       va' <- va       case ivName a `Map.lookup` va' of             Nothing -> return $ Map.insert (ivName a) (VariableValue c LocalScope t False) va'-            (Just v) -> compileErrorM $ "Variable " ++ show (ivName a) +++            (Just v) -> compilerErrorM $ "Variable " ++ show (ivName a) ++                                        formatFullContextBrace (ivContext a) ++                                        " is already defined" ++                                        formatFullContextBrace (vvContext v)

@@ -30,11 +30,11 @@ import Prelude hiding (pi) import qualified Data.Map as Map -import Base.CompileError+import Base.CompilerError+import Base.GeneralType+import Base.Positional import Compilation.ProcedureContext import Types.DefinedCategory-import Types.GeneralType-import Types.Positional import Types.Procedure import Types.TypeCategory import Types.TypeInstance@@ -64,7 +64,7 @@   (ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> a) -> ProcedureScope c -> [a] applyProcedureScope f (ProcedureScope ctx fs) = map (uncurry (f ctx)) fs -getProcedureScopes :: (Show c, CompileErrorM m) =>+getProcedureScopes :: (Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c -> DefinedCategory c -> m [ProcedureScope c] getProcedureScopes ta em (DefinedCategory c n pi _ _ fi ms ps fs) = do   (_,t) <- getConcreteCategory ta (c,n)@@ -109,7 +109,7 @@     checkParam pm p =       case vpParam p `Map.lookup` pm of            Nothing -> return ()-           (Just c2) -> compileErrorM $ "Internal param " ++ show (vpParam p) +++           (Just c2) -> compilerErrorM $ "Internal param " ++ show (vpParam p) ++                                         formatFullContextBrace (vpContext p) ++                                         " is already defined at " ++                                         formatFullContext c2

@@ -44,8 +44,10 @@ import Data.Semigroup #endif -import Base.CompileError+import Base.CompilerError+import Base.GeneralType import Base.MergeTree+import Base.Positional import Compilation.CompilerState import Compilation.ProcedureContext (ExprMap) import Compilation.ScopeContext@@ -55,8 +57,6 @@ import CompilerCxx.Procedure import Types.Builtin import Types.DefinedCategory-import Types.GeneralType-import Types.Positional import Types.Pragma import Types.Procedure import Types.TypeCategory@@ -99,7 +99,7 @@     psDefine :: [DefinedCategory c]   } -compileLanguageModule :: (Show c, CompileErrorM m) =>+compileLanguageModule :: (Show c, CollectErrorsM m) =>   LanguageModule c -> [PrivateSource c] -> m [CxxOutput] compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex ss em) xa = do   checkSupefluous $ Set.toList $ (Set.fromList ex) `Set.difference` ca@@ -166,7 +166,7 @@     checkLocals ds cs2 = mapErrorsM_ (checkLocal $ Set.fromList cs2) ds     checkLocal cs2 d =       when (not $ dcName d `Set.member` cs2) $-        compileErrorM ("Definition for " ++ show (dcName d) +++        compilerErrorM ("Definition for " ++ show (dcName d) ++                        formatFullContextBrace (dcContext d) ++                        " does not correspond to a visible category in this module")     checkTests ds ps = do@@ -176,7 +176,7 @@       case dcName d `Map.lookup` pa of            Nothing -> return ()            Just c  ->-             compileErrorM ("Category " ++ show (dcName d) +++             compilerErrorM ("Category " ++ show (dcName d) ++                             formatFullContextBrace (dcContext d) ++                             " was not declared as $TestsOnly$" ++ formatFullContextBrace c)     checkDefined dm ex2 = mapErrorsM_ (checkSingle dm (Set.fromList ex2))@@ -185,27 +185,27 @@            (False,Just [_]) -> return ()            (True,Nothing)   -> return ()            (True,Just [d]) ->-             compileErrorM ("Category " ++ show (getCategoryName t) +++             compilerErrorM ("Category " ++ show (getCategoryName t) ++                            formatFullContextBrace (getCategoryContext t) ++                            " was declared external but is also defined at " ++ formatFullContext (dcContext d))            (False,Nothing) ->-             compileErrorM ("Category " ++ show (getCategoryName t) +++             compilerErrorM ("Category " ++ show (getCategoryName t) ++                            formatFullContextBrace (getCategoryContext t) ++                            " has not been defined or declared external")            (_,Just ds) ->              ("Category " ++ show (getCategoryName t) ++               formatFullContextBrace (getCategoryContext t) ++               " is defined " ++ show (length ds) ++ " times") !!>-                mapErrorsM_ (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds+                mapErrorsM_ (\d -> compilerErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds     checkSupefluous es2       | null es2 = return ()-      | otherwise = compileErrorM $ "External categories either not concrete or not present: " +++      | otherwise = compilerErrorM $ "External categories either not concrete or not present: " ++                                     intercalate ", " (map show es2)     checkStreamlined =  mapErrorsM_  streamlinedError $ Set.toList $ Set.difference (Set.fromList ss) (Set.fromList ex)     streamlinedError n =-      compileErrorM $ "Category " ++ show n ++ " cannot be streamlined because it was not declared external"+      compilerErrorM $ "Category " ++ show n ++ " cannot be streamlined because it was not declared external" -compileTestsModule :: (Show c, CompileErrorM m) =>+compileTestsModule :: (Show c, CollectErrorsM m) =>   LanguageModule c -> Namespace -> [String] -> [AnyCategory c] -> [DefinedCategory c] ->   [TestProcedure c] -> m ([CxxOutput],CxxOutput,[(FunctionName,[c])]) compileTestsModule cm ns args cs ds ts = do@@ -219,7 +219,7 @@   (main,fs) <- compileTestMain cm args xs ts   return (xx,main,fs) -compileTestMain :: (Show c, CompileErrorM m) =>+compileTestMain :: (Show c, CollectErrorsM m) =>   LanguageModule c -> [String] -> PrivateSource c -> [TestProcedure c] ->   m (CxxOutput,[(FunctionName,[c])]) compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _ _ em) args ts2 tests = do@@ -230,7 +230,7 @@   return (output,tests') where   tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1,psCategory ts2] -compileModuleMain :: (Show c, CompileErrorM m) =>+compileModuleMain :: (Show c, CollectErrorsM m) =>   LanguageModule c -> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 _ cs1 ps1 _ _ _ em) xa n f = do   let resolved = filter (\d -> dcName d == n) $ concat $ map psDefine $ filter (not . psTesting) xa@@ -242,12 +242,12 @@   return $ CxxOutput Nothing mainFilename NoNamespace (ns `Set.insert` Set.unions [ns0,ns1,ns2]) (Set.fromList [n]) main where     tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1]     reconcile [_] = return ()-    reconcile []  = compileErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)"+    reconcile []  = compilerErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)"     reconcile ds  =       "Multiple matches for main category " ++ show n !!>-        mapErrorsM_ (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds+        mapErrorsM_ (\d -> compilerErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds -compileCategoryDeclaration :: (Show c, CompileErrorM m) =>+compileCategoryDeclaration :: (Show c, CollectErrorsM m) =>   Bool -> CategoryMap c -> Set.Set Namespace -> AnyCategory c -> m CxxOutput compileCategoryDeclaration testing _ ns t =   return $ CxxOutput (Just $ getCategoryName t)@@ -285,7 +285,7 @@       | isInstanceInterface t = []       | otherwise             = declareGetType t -compileInterfaceDefinition :: CompileErrorM m => Bool -> AnyCategory c -> m CxxOutput+compileInterfaceDefinition :: CollectErrorsM m => Bool -> AnyCategory c -> m CxxOutput compileInterfaceDefinition testing t = do   te <- typeConstructor   commonDefineAll testing t Set.empty Nothing emptyCode emptyCode emptyCode te []@@ -300,7 +300,7 @@       let allInit = intercalate ", " $ initParent:initPassed       return $ onlyCode $ typeName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" -compileConcreteTemplate :: (Show c, CompileErrorM m) =>+compileConcreteTemplate :: (Show c, CollectErrorsM m) =>   Bool -> CategoryMap c -> CategoryName -> m CxxOutput compileConcreteTemplate testing ta n = do   (_,t) <- getConcreteCategory ta ([],n)@@ -332,7 +332,7 @@       ]     funcName f = show (sfType f) ++ "." ++ show (sfName f) -compileConcreteStreamlined :: (Show c, CompileErrorM m) =>+compileConcreteStreamlined :: (Show c, CollectErrorsM m) =>   Bool -> CategoryMap c -> CategoryName -> m [CxxOutput] compileConcreteStreamlined testing ta n =  "In streamlined compilation of " ++ show n ??> do   (_,t) <- getConcreteCategory ta ([],n)@@ -354,7 +354,7 @@                       []   return [hxx,cxx] -compileConcreteDefinition :: (Show c, CompileErrorM m) =>+compileConcreteDefinition :: (Show c, CollectErrorsM m) =>   Bool -> CategoryMap c -> ExprMap c -> Set.Set Namespace -> Maybe [ValueRefine c] ->   DefinedCategory c -> m CxxOutput compileConcreteDefinition testing ta em ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do@@ -413,11 +413,11 @@     ] ++ map (return . snd) (cf ++ tf ++ vf)   commonDefineAll testing t ns rs top bottom ce te fe   where-    disallowTypeMembers :: (Show c, CompileErrorM m) =>+    disallowTypeMembers :: (Show c, CollectErrorsM m) =>       [DefinedMember c] -> m ()     disallowTypeMembers tm =       collectAllM_ $ flip map tm-        (\m -> compileErrorM $ "Member " ++ show (dmName m) +++        (\m -> compilerErrorM $ "Member " ++ show (dmName m) ++                                " is not allowed to be @type-scoped" ++                                formatFullContextBrace (dmContext m))     createParams = concatM $ map createParam pi@@ -503,7 +503,7 @@       | any isTraceCreation $ concat $ map (epPragmas . snd) vp = [captureCreationTrace]       | otherwise = [] -commonDefineAll :: CompileErrorM m =>+commonDefineAll :: CollectErrorsM m =>   Bool -> AnyCategory c -> Set.Set Namespace -> Maybe [ValueRefine c] ->   CompiledData [String] -> CompiledData [String] -> CompiledData [String] ->   CompiledData [String] -> [ScopedFunction c] -> m CxxOutput@@ -641,7 +641,7 @@     | s == ValueScope    = "  return TypeValue::Dispatch(self, label, params, args);"     | otherwise = undefined -commonDefineCategory :: CompileErrorM m =>+commonDefineCategory :: CollectErrorsM m =>   AnyCategory c -> CompiledData [String] -> m (CompiledData [String]) commonDefineCategory t extra = do   concatM $ [@@ -653,7 +653,7 @@   where     name = getCategoryName t -commonDefineType :: CompileErrorM m =>+commonDefineType :: CollectErrorsM m =>   AnyCategory c -> Maybe [ValueRefine c] -> CompiledData [String] -> m (CompiledData [String]) commonDefineType t rs extra = do   let rs' = case rs of@@ -831,7 +831,7 @@       depIncludes req2 = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $                            Set.toList req2 -createMainFile :: (Show c, CompileErrorM m) =>+createMainFile :: (Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String]) createMainFile tm em n f = "In the creation of the main binary procedure" ??> do   ca <- compileMainProcedure tm em expr@@ -843,7 +843,7 @@     expr = Expression [] (TypeCall [] mainType funcCall) []     argv = onlyCode "ProgramArgv program_argv(argc, argv);" -createTestFile :: (Show c, CompileErrorM m) =>+createTestFile :: (Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c  -> [String] -> [TestProcedure c] -> m (CompiledData [String]) createTestFile tm em args ts = "In the creation of the test binary procedure" ??> do   ts' <- fmap mconcat $ mapErrorsM (compileTestProcedure tm em) ts

@@ -28,20 +28,20 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Base.CompileError+import Base.CompilerError+import Base.GeneralType+import Base.Positional import Compilation.CompilerState import Compilation.ProcedureContext import Compilation.ScopeContext import CompilerCxx.Code import Types.DefinedCategory-import Types.GeneralType-import Types.Positional import Types.Procedure import Types.TypeCategory import Types.TypeInstance  -getContextForInit :: (Show c, CompileErrorM m) =>+getContextForInit :: (Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c -> AnyCategory c -> DefinedCategory c ->   SymbolScope -> m (ProcedureContext c) getContextForInit tm em t d s = do@@ -79,14 +79,15 @@       pcOutput = [],       pcDisallowInit = True,       pcLoopSetup = NotInLoop,-      pcCleanupSetup = [],+      pcCleanupBlocks = [],       pcInCleanup = False,+      pcUsedVars = [],       pcExprMap = em,       pcReservedMacros = [],       pcNoTrace = False     } -getProcedureContext :: (Show c, CompileErrorM m) =>+getProcedureContext :: (Show c, CollectErrorsM m) =>   ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> m (ProcedureContext c) getProcedureContext (ScopeContext tm t ps pi ms pa fi fa va em)                     ff@(ScopedFunction _ _ _ s as1 rs1 ps1 fs _)@@ -141,8 +142,9 @@       pcOutput = [],       pcDisallowInit = False,       pcLoopSetup = NotInLoop,-      pcCleanupSetup = [],+      pcCleanupBlocks = [],       pcInCleanup = False,+      pcUsedVars = [],       pcExprMap = em,       pcReservedMacros = [],       pcNoTrace = False@@ -150,7 +152,7 @@   where     pairOutput (PassedValue c1 t2) (OutputValue c2 n2) = return $ (n2,PassedValue (c2++c1) t2) -getMainContext :: CompileErrorM m => CategoryMap c -> ExprMap c -> m (ProcedureContext c)+getMainContext :: CollectErrorsM m => CategoryMap c -> ExprMap c -> m (ProcedureContext c) getMainContext tm em = return $ ProcedureContext {     pcScope = LocalScope,     pcType = CategoryNone,@@ -172,8 +174,9 @@     pcOutput = [],     pcDisallowInit = False,     pcLoopSetup = NotInLoop,-    pcCleanupSetup = [],+    pcCleanupBlocks = [],     pcInCleanup = False,+    pcUsedVars = [],     pcExprMap = em,     pcReservedMacros = [],     pcNoTrace = False

@@ -64,10 +64,10 @@ import Data.List (intercalate) import qualified Data.Set as Set +import Base.Positional import Compilation.CompilerState import CompilerCxx.Naming import Types.Builtin-import Types.Positional import Types.TypeCategory import Types.TypeInstance 

@@ -41,8 +41,10 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Base.CompileError+import Base.CompilerError+import Base.GeneralType import Base.MergeTree+import Base.Positional import Compilation.CompilerState import Compilation.ProcedureContext (ExprMap) import Compilation.ScopeContext@@ -52,8 +54,6 @@ import Types.Builtin import Types.DefinedCategory import Types.Function-import Types.GeneralType-import Types.Positional import Types.Pragma import Types.Procedure import Types.TypeCategory@@ -61,11 +61,11 @@ import Types.Variance  -compileExecutableProcedure :: (Show c, CompileErrorM m) =>+compileExecutableProcedure :: (Show c, CollectErrorsM m) =>   ScopeContext c -> ScopedFunction c -> ExecutableProcedure c ->   m (CompiledData [String],CompiledData [String]) compileExecutableProcedure ctx ff@(ScopedFunction _ _ _ s as1 rs1 ps1 _ _)-                               pp@(ExecutableProcedure c0 pragmas c n as2 rs2 p) = do+                               pp@(ExecutableProcedure c pragmas c2 n as2 rs2 p) = do   ctx' <- getProcedureContext ctx ff pp   output <- runDataCompiler compileWithReturn ctx'   procedureTrace <- setProcedureTrace@@ -78,7 +78,7 @@       compileProcedure ctx0 p >>= put       unreachable <- csIsUnreachable       when (not unreachable) $-        doImplicitReturn [] <???+        doImplicitReturn c2 <??           "In implicit return from " ++ show n ++ formatFullContextBrace c     wrapProcedure output pt ct =       mconcat [@@ -123,8 +123,8 @@     setCreationTrace       | not $ any isTraceCreation pragmas = return []       | s /= ValueScope =-          (compileWarningM $ "Creation tracing ignored for " ++ show s ++-             " functions" ++ formatFullContextBrace c0) >> return []+          (compilerWarningM $ "Creation tracing ignored for " ++ show s +++            " functions" ++ formatFullContextBrace c) >> return []       | otherwise = return [showCreationTrace]     defineReturns       | isUnnamedReturns rs2 = []@@ -143,29 +143,29 @@         variableProxyType t2 ++ " " ++ variableName (ovName n2) ++         " = " ++ writeStoredVariable t2 (UnwrappedSingle $ "returns.At(" ++ show i ++ ")") ++ ";" -compileCondition :: (Show c, CompileErrorM m,+compileCondition :: (Show c, CollectErrorsM m,                      CompilerContext c m [String] a) =>   a -> [c] -> Expression c -> CompilerState a m String compileCondition ctx c e = do-  (e',ctx') <- resetBackgroundStateT $ lift $ runStateT compile ctx-  lift (ccGetRequired ctx') >>= csRequiresTypes+  (e',ctx') <- resetBackgroundM $ lift $ runStateT compile ctx+  lift (ccGetRequired ctx') >>= csAddRequired   noTrace <- csGetNoTrace   if noTrace      then return e'      else return $ predTraceContext c ++ e'   where-    compile = "In condition at " ++ formatFullContext c ???> do+    compile = "In condition at " ++ formatFullContext c ??> do       (ts,e') <- compileExpression e-      lift $ checkCondition ts+      checkCondition ts       return $ useAsUnboxed PrimBool e'       where         checkCondition (Positional [t]) | t == boolRequiredValue = return ()         checkCondition (Positional ts) =-          compileErrorM $ "Conditionals must have exactly one Bool return but found {" ++-                         intercalate "," (map show ts) ++ "}"+          compilerErrorM $ "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.-compileProcedure :: (Show c, CompileErrorM m,+compileProcedure :: (Show c, CollectErrorsM m,                      CompilerContext c m [String] a) =>   a -> Procedure c -> CompilerState a m a compileProcedure ctx (Procedure _ ss) = do@@ -173,22 +173,22 @@   return ctx' where     compile s = do       unreachable <- csIsUnreachable-      if unreachable-         then lift $ compileWarningM $ "Statement at " ++-                                       formatFullContext (getStatementContext s) ++-                                       " is unreachable (skipping compilation)"+      if unreachable && not (isRawCodeLine s)+         then compilerWarningM $ "Statement at " +++                                 formatFullContext (getStatementContext s) +++                                 " is unreachable (skipping compilation)"          else do-           s' <- resetBackgroundStateT $ compileStatement s+           s' <- resetBackgroundM $ compileStatement s            return s' -maybeSetTrace :: (Show c, CompileErrorM m,+maybeSetTrace :: (Show c, CollectErrorsM m,                   CompilerContext c m [String] a) =>   [c] -> CompilerState a m () maybeSetTrace c = do   noTrace <- csGetNoTrace   when (not noTrace) $ csWrite $ setTraceContext c -compileStatement :: (Show c, CompileErrorM m,+compileStatement :: (Show c, CollectErrorsM m,                      CompilerContext c m [String] a) =>   Statement c -> CompilerState a m () compileStatement (EmptyReturn c) = do@@ -202,58 +202,54 @@     getReturn [(_,(Positional ts,e))] = do       csRegisterReturn c $ Just (Positional ts)       maybeSetTrace c-      autoPositionalCleanup e+      autoPositionalCleanup c e     -- Multi-expression => must all be singles.     getReturn rs = do-      lift (mapErrorsM_ checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) <???+      lift (mapErrorsM_ checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) <??         ("In return at " ++ formatFullContext c)       csRegisterReturn c $ Just $ Positional $ map (head . pValues . fst . snd) rs       let e = OpaqueMulti $ "ReturnTuple(" ++ intercalate "," (map (useAsUnwrapped . snd . snd) rs) ++ ")"       maybeSetTrace c-      autoPositionalCleanup e+      autoPositionalCleanup c e     checkArity (_,Positional [_]) = return ()     checkArity (i,Positional ts)  =-      compileErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"+      compilerErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1" compileStatement (LoopBreak c) = do   loop <- csGetLoop   case loop of        NotInLoop ->-         lift $ compileErrorM $ "Using break outside of while is no allowed" ++ formatFullContextBrace c+         compilerErrorM $ "Using break outside of while is no allowed" ++ formatFullContextBrace c        _ -> return ()-  (CleanupSetup cs ss) <- csGetCleanup JumpBreak-  sequence_ $ map (csInheritReturns . (:[])) cs-  csWrite ss-  csSetJumpType JumpBreak+  csSetJumpType c JumpBreak+  get >>= autoInsertCleanup c JumpBreak   csWrite ["break;"] compileStatement (LoopContinue c) = do   loop <- csGetLoop   case loop of        NotInLoop ->-         lift $ compileErrorM $ "Using continue outside of while is no allowed" ++ formatFullContextBrace c+         compilerErrorM $ "Using continue outside of while is no allowed" ++ formatFullContextBrace c        _ -> return ()-  (CleanupSetup cs ss) <- csGetCleanup JumpContinue-  sequence_ $ map (csInheritReturns . (:[])) cs-  csWrite ss-  csSetJumpType JumpContinue+  csSetJumpType c JumpContinue+  get >>= autoInsertCleanup c JumpContinue   csWrite $ ["{"] ++ lsUpdate loop ++ ["}","continue;"] compileStatement (FailCall c e) = do-  csRequiresTypes (Set.fromList [BuiltinFormatted,BuiltinString])+  csAddRequired (Set.fromList [BuiltinFormatted,BuiltinString])   e' <- compileExpression e   when (length (pValues $ fst e') /= 1) $-    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e0) = e'   r <- csResolver   fa <- csAllFilters   lift $ (checkValueAssignment r fa t0 formattedRequiredValue) <??     "In fail call at " ++ formatFullContext c-  csSetJumpType JumpFailCall+  csSetJumpType c JumpFailCall   maybeSetTrace c   csWrite ["BUILTIN_FAIL(" ++ useAsUnwrapped e0 ++ ")"] compileStatement (IgnoreValues c e) = do   (_,e') <- compileExpression e   maybeSetTrace c   csWrite ["(void) (" ++ useAsWhatever e' ++ ");"]-compileStatement (Assignment c as e) = message ???> do+compileStatement (Assignment c as e) = message ??> do   (ts,e') <- compileExpression e   r <- csResolver   fa <- csAllFilters@@ -272,21 +268,21 @@       csWrite ["}"]     getVariableType (CreateVariable _ t _) _ = return t     getVariableType (ExistingVariable (InputValue c2 n)) _ = do-      (VariableValue _ _ t _) <- csGetVariable c2 n+      (VariableValue _ _ t _) <- csGetVariable (UsedVariable c2 n)       return t     getVariableType (ExistingVariable (DiscardInput _)) t = return t     createVariable r fa (CreateVariable c2 t1 n) t2 =-      "In creation of " ++ show n ++ " at " ++ formatFullContext c2 ???> do-        -- TODO: Call csRequiresTypes for t1. (Maybe needs a helper function.)+      "In creation of " ++ show n ++ " at " ++ formatFullContext c2 ??> do+        -- TODO: Call csAddRequired for t1. (Maybe needs a helper function.)         lift $ collectAllM_ [validateGeneralInstance r fa (vtType t1),                              checkValueAssignment r fa t2 t1]-        csAddVariable c2 n (VariableValue c2 LocalScope t1 True)+        csAddVariable (UsedVariable c2 n) (VariableValue c2 LocalScope t1 True)         csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"]     createVariable r fa (ExistingVariable (InputValue c2 n)) t2 =-      "In assignment to " ++ show n ++ " at " ++ formatFullContext c2 ???> do-        (VariableValue _ _ t1 w) <- csGetVariable c2 n-        when (not w) $ lift $ compileErrorM $ "Cannot assign to read-only variable " ++-                                              show n ++ formatFullContextBrace c2+      "In assignment to " ++ show n ++ " at " ++ formatFullContext c2 ??> do+        (VariableValue _ _ t1 w) <- csGetVariable (UsedVariable c2 n)+        when (not w) $ compilerErrorM $ "Cannot assign to read-only variable " +++                                        show n ++ formatFullContextBrace c2         -- TODO: Also show original context.         lift $ (checkValueAssignment r fa t2 t1)         csUpdateAssigned n@@ -294,7 +290,7 @@     assignSingle (_,t,CreateVariable _ _ n) e2 =       csWrite [variableName n ++ " = " ++ writeStoredVariable t e2 ++ ";"]     assignSingle (_,t,ExistingVariable (InputValue c2 n)) e2 = do-      (VariableValue _ s _ _) <- csGetVariable c2 n+      (VariableValue _ s _ _) <- csGetVariable (UsedVariable c2 n)       scoped <- autoScope s       csWrite [scoped ++ variableName n ++ " = " ++ writeStoredVariable t e2 ++ ";"]     assignSingle _ _ = return ()@@ -302,30 +298,31 @@       csWrite [variableName n ++ " = " ++                writeStoredVariable t (UnwrappedSingle $ "r.At(" ++ show i ++ ")") ++ ";"]     assignMulti (i,t,ExistingVariable (InputValue _ n)) = do-      (VariableValue _ s _ _) <- csGetVariable c n+      (VariableValue _ s _ _) <- csGetVariable (UsedVariable c n)       scoped <- autoScope s       csWrite [scoped ++ variableName n ++ " = " ++                writeStoredVariable t (UnwrappedSingle $ "r.At(" ++ show i ++ ")") ++ ";"]     assignMulti _ = return () compileStatement (NoValueExpression _ v) = compileVoidExpression v+compileStatement (RawCodeLine s) = csWrite [s] -compileRegularInit :: (Show c, CompileErrorM m,+compileRegularInit :: (Show c, CollectErrorsM m,                        CompilerContext c m [String] a) =>   DefinedMember c -> CompilerState a m () compileRegularInit (DefinedMember _ _ _ _ Nothing) = return ()-compileRegularInit (DefinedMember c2 s t n2 (Just e)) = resetBackgroundStateT $ do-  csAddVariable c2 n2 (VariableValue c2 s t True)+compileRegularInit (DefinedMember c2 s t n2 (Just e)) = resetBackgroundM $ do+  csAddVariable (UsedVariable c2 n2) (VariableValue c2 s t True)   let assign = Assignment c2 (Positional [ExistingVariable (InputValue c2 n2)]) e   compileStatement assign -compileLazyInit :: (Show c, CompileErrorM m,+compileLazyInit :: (Show c, CollectErrorsM m,                    CompilerContext c m [String] a) =>   DefinedMember c -> CompilerState a m () compileLazyInit (DefinedMember _ _ _ _ Nothing) = return ()-compileLazyInit (DefinedMember c _ t1 n (Just e)) = resetBackgroundStateT $ do+compileLazyInit (DefinedMember c _ t1 n (Just e)) = resetBackgroundM $ do   (ts,e') <- compileExpression e   when (length (pValues ts) /= 1) $-    lift $ compileErrorM $ "Expected single return in initializer" ++ formatFullContextBrace (getExpressionContext e)+    compilerErrorM $ "Expected single return in initializer" ++ formatFullContextBrace (getExpressionContext e)   r <- csResolver   fa <- csAllFilters   let Positional [t2] = ts@@ -333,7 +330,7 @@     "In initialization of " ++ show n ++ " at " ++ formatFullContext c   csWrite [variableName n ++ "([this]() { return " ++ writeStoredVariable t1 e' ++ "; })"] -compileVoidExpression :: (Show c, CompileErrorM m,+compileVoidExpression :: (Show c, CollectErrorsM m,                          CompilerContext c m [String] a) =>   VoidExpression c -> CompilerState a m () compileVoidExpression (Conditional ie) = compileIfElifElse ie@@ -343,22 +340,20 @@ compileVoidExpression (Unconditional p) = do   ctx0 <- getCleanContext   ctx <- compileProcedure ctx0 p-  (lift $ ccGetRequired ctx) >>= csRequiresTypes   csWrite ["{"]-  (lift $ ccGetOutput ctx) >>= csWrite+  autoInlineOutput ctx   csWrite ["}"]-  csInheritReturns [ctx] -compileIfElifElse :: (Show c, CompileErrorM m,+compileIfElifElse :: (Show c, CollectErrorsM m,                       CompilerContext c m [String] a) =>   IfElifElse c -> CompilerState a m () compileIfElifElse (IfStatement c e p es) = do   ctx0 <- getCleanContext   e' <- compileCondition ctx0 c e   ctx <- compileProcedure ctx0 p-  (lift $ ccGetRequired ctx) >>= csRequiresTypes+  (lift $ ccGetRequired ctx) >>= csAddRequired   csWrite ["if (" ++ e' ++ ") {"]-  (lift $ ccGetOutput ctx) >>= csWrite+  getAndIndentOutput ctx >>= csWrite   csWrite ["}"]   cs <- unwind es   csInheritReturns (ctx:cs)@@ -367,24 +362,24 @@       ctx0 <- getCleanContext       e2' <- compileCondition ctx0 c2 e2       ctx <- compileProcedure ctx0 p2-      (lift $ ccGetRequired ctx) >>= csRequiresTypes+      (lift $ ccGetRequired ctx) >>= csAddRequired       csWrite ["else if (" ++ e2' ++ ") {"]-      (lift $ ccGetOutput ctx) >>= csWrite+      getAndIndentOutput ctx >>= csWrite       csWrite ["}"]       cs <- unwind es2       return $ ctx:cs     unwind (ElseStatement _ p2) = do       ctx0 <- getCleanContext       ctx <- compileProcedure ctx0 p2-      (lift $ ccGetRequired ctx) >>= csRequiresTypes+      (lift $ ccGetRequired ctx) >>= csAddRequired       csWrite ["else {"]-      (lift $ ccGetOutput ctx) >>= csWrite+      getAndIndentOutput ctx >>= csWrite       csWrite ["}"]       return [ctx]     unwind TerminateConditional = fmap (:[]) get compileIfElifElse _ = undefined -compileWhileLoop :: (Show c, CompileErrorM m,+compileWhileLoop :: (Show c, CollectErrorsM m,                      CompilerContext c m [String] a) =>   WhileLoop c -> CompilerState a m () compileWhileLoop (WhileLoop c e p u) = do@@ -394,62 +389,52 @@                 Just p2 -> do                   ctx1 <- lift $ ccStartLoop ctx0 (LoopSetup [])                   ctx2 <- compileProcedure ctx1 p2-                  (lift $ ccGetRequired ctx2) >>= csRequiresTypes-                  p2' <- lift $ ccGetOutput ctx2+                  (lift $ ccGetRequired ctx2) >>= csAddRequired+                  p2' <- getAndIndentOutput ctx2                   lift $ ccStartLoop ctx0 (LoopSetup p2')                 _ -> lift $ ccStartLoop ctx0 (LoopSetup [])   (LoopSetup u') <- lift $ ccGetLoop ctx0'   ctx <- compileProcedure ctx0' p-  (lift $ ccGetRequired ctx) >>= csRequiresTypes+  (lift $ ccGetRequired ctx) >>= csAddRequired   csWrite ["while (" ++ e' ++ ") {"]-  (lift $ ccGetOutput ctx) >>= csWrite+  getAndIndentOutput ctx >>= csWrite   csWrite $ ["{"] ++ u' ++ ["}"]   csWrite ["}"] -compileScopedBlock :: (Show c, CompileErrorM m,+compileScopedBlock :: (Show c, CollectErrorsM m,                        CompilerContext c m [String] a) =>   ScopedBlock c -> CompilerState a m ()-compileScopedBlock s = do+compileScopedBlock s@(ScopedBlock _ _ _ c2 _) = do   let (vs,p,cl,st) = rewriteScoped s+  -- Capture context so we can discard scoped variable names.+  ctx0 <- getCleanContext   r <- csResolver   fa <- csAllFilters   sequence_ $ map (createVariable r fa) vs-  -- Compile the scoped block for the base context of the statement and the-  -- cleanup block.-  ctxP0 <- getCleanContext >>= flip compileProcedure p-  -- Precompile the statement to get static analysis of returns, for use when-  -- compiling the cleanup block. The output will be discarded; the statement is-  -- compiled with cleanup below.-  ctxCl0 <- do-    ctxS0 <- lift $ execStateT (sequence $ map showVariable vs) ctxP0-    ctxS0' <- compileProcedure ctxS0 (Procedure [] [st])-    lift $ ccInheritReturns ctxP0 [ctxS0']-  (ctxP,cl',ctxCl) <--    case cl of-         Just p2@(Procedure c _) -> do-           ctxCl0' <- lift $ ccStartCleanup ctxCl0-           ctxCl <- compileProcedure ctxCl0' p2 <??? "In cleanup starting at " ++ formatFullContext c-           p2' <- lift $ ccGetOutput ctxCl-           noTrace <- csGetNoTrace-           let p2'' = if noTrace-                         then []-                         else ["{",startCleanupTracing] ++ p2' ++ ["}"]-           ctxP <- lift $ ccPushCleanup ctxP0 (CleanupSetup [ctxCl] p2'')-           return (ctxP,p2'',ctxCl)-         Nothing -> return (ctxP0,[],ctxP0)+  ctxP0 <- compileProcedure ctx0 p   -- Make variables to be created visible *after* p has been compiled so that p   -- can't refer to them.-  ctxP' <- lift $ execStateT (sequence $ map showVariable vs) ctxP+  ctxP <- lift $ execStateT (sequence $ map showVariable vs) ctxP0+  ctxCl0 <- lift $ ccClearOutput ctxP >>= ccStartCleanup+  ctxP' <-+    case cl of+         -- Insert cleanup into the context for the in block.+         Just (Procedure c ss) -> do+           noTrace <- csGetNoTrace+           let trace = if noTrace then [] else [RawCodeLine startCleanupTracing]+           let p2' = Procedure c $ [RawCodeLine "{"] ++ trace ++ ss ++ [RawCodeLine "}"]+           ctxCl <- compileProcedure ctxCl0 p2' <?? "In cleanup starting at " ++ formatFullContext c+           ctxP' <- lift $ ccPushCleanup ctxP ctxCl+           return ctxP'+         -- Insert an empty cleanup so that it can be used below.+         Nothing -> lift $ ccPushCleanup ctxP ctxCl0   ctxS <- compileProcedure ctxP' (Procedure [] [st])-  (lift $ ccGetRequired ctxS)  >>= csRequiresTypes-  (lift $ ccGetRequired ctxCl) >>= csRequiresTypes-  csInheritReturns [ctxS]-  csInheritReturns [ctxCl]   csWrite ["{"]-  (lift $ ccGetOutput ctxS) >>= csWrite-  -- Skip fallthrough cleanup if the emitted output will be unreachable.-  unreachable <- lift $ ccIsUnreachable ctxCl0-  when (not unreachable) $ csWrite cl'+  autoInlineOutput ctxS+  -- NOTE: Keep this after inlining the in block in case the in block contains a+  -- jump. (If it does, the cleanup will already be inlined.)+  unreachable <- csIsUnreachable+  when (not unreachable) $ autoInsertCleanup c2 NextStatement ctxP'   csWrite ["}"]   sequence_ $ map showVariable vs   where@@ -458,61 +443,61 @@         "In creation of " ++ show n ++ " at " ++ formatFullContext c       csWrite [variableStoredType t ++ " " ++ variableName n ++ ";"]     showVariable (c,t,n) = do-      -- TODO: Call csRequiresTypes for t. (Maybe needs a helper function.)-      csAddVariable c n (VariableValue c LocalScope t True)+      -- TODO: Call csAddRequired for t. (Maybe needs a helper function.)+      csAddVariable (UsedVariable c n) (VariableValue c LocalScope t True)     -- Don't merge if the second scope has cleanup, so that the latter can't     -- refer to variables defined in the first scope.-    rewriteScoped (ScopedBlock _ p cl@(Just _)+    rewriteScoped (ScopedBlock _ p cl@(Just _) _                                s2@(NoValueExpression _ (WithScope-                                   (ScopedBlock _ _ (Just _) _)))) =+                                   (ScopedBlock _ _ (Just _) _ _)))) =       ([],p,cl,s2)     -- Merge chained scoped sections into a single section.-    rewriteScoped (ScopedBlock c (Procedure c2 ss1) cl1+    rewriteScoped (ScopedBlock c (Procedure c3 ss1) cl1 c4                                (NoValueExpression _ (WithScope-                                (ScopedBlock _ (Procedure _ ss2) cl2 s2)))) =-      rewriteScoped $ ScopedBlock c (Procedure c2 $ ss1 ++ ss2) (cl1 <|> cl2) s2+                                (ScopedBlock _ (Procedure _ ss2) cl2 _ s2)))) =+      rewriteScoped $ ScopedBlock c (Procedure c3 $ ss1 ++ ss2) (cl1 <|> cl2) c4 s2     -- Gather to-be-created variables.-    rewriteScoped (ScopedBlock _ p cl (Assignment c2 vs e)) =-      (created,p,cl,Assignment c2 (Positional existing) e) where+    rewriteScoped (ScopedBlock _ p cl _ (Assignment c3 vs e)) =+      (created,p,cl,Assignment c3 (Positional existing) e) where         (created,existing) = foldr update ([],[]) (pValues vs)         update (CreateVariable c t n) (cs,es) = ((c,t,n):cs,(ExistingVariable $ InputValue c n):es)         update e2 (cs,es) = (cs,e2:es)     -- Merge the statement into the scoped block.-    rewriteScoped (ScopedBlock _ p cl s2) =+    rewriteScoped (ScopedBlock _ p cl _ s2) =       ([],p,cl,s2) -compileExpression :: (Show c, CompileErrorM m,+compileExpression :: (Show c, CollectErrorsM m,                       CompilerContext c m [String] a) =>   Expression c -> CompilerState a m (ExpressionType,ExprValue) compileExpression = compile where   compile (Literal (StringLiteral _ l)) = do-    csRequiresTypes (Set.fromList [BuiltinString])+    csAddRequired (Set.fromList [BuiltinString])     return (Positional [stringRequiredValue],UnboxedPrimitive PrimString $ "PrimString_FromLiteral(" ++ escapeChars l ++ ")")   compile (Literal (CharLiteral _ l)) = do-    csRequiresTypes (Set.fromList [BuiltinChar])+    csAddRequired (Set.fromList [BuiltinChar])     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 $ compileErrorM $+    csAddRequired (Set.fromList [BuiltinInt])+    when (l > 2^(64 :: Integer) - 1) $ compilerErrorM $       "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 $ compileErrorM $+    csAddRequired (Set.fromList [BuiltinInt])+    when (l > 2^(63 :: Integer) - 1) $ compilerErrorM $       "Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit signed"-    when ((-l) > (2^(63 :: Integer) - 2)) $ lift $ compileErrorM $+    when ((-l) > (2^(63 :: Integer) - 2)) $ compilerErrorM $       "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-    csRequiresTypes (Set.fromList [BuiltinFloat])+    csAddRequired (Set.fromList [BuiltinFloat])     -- TODO: Check bounds.     return (Positional [floatRequiredValue],UnboxedPrimitive PrimFloat $ "PrimFloat(" ++ show l ++ "E" ++ show e ++ ")")   compile (Literal (BoolLiteral _ True)) = do-    csRequiresTypes (Set.fromList [BuiltinBool])+    csAddRequired (Set.fromList [BuiltinBool])     return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "true")   compile (Literal (BoolLiteral _ False)) = do-    csRequiresTypes (Set.fromList [BuiltinBool])+    csAddRequired (Set.fromList [BuiltinBool])     return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "false")   compile (Literal (EmptyLiteral _)) = do     return (Positional [emptyValue],UnwrappedSingle "Var_empty")@@ -539,11 +524,11 @@         | o == "!" = doNot t e2         | o == "-" = doNeg t e2         | o == "~" = doComp t e2-        | otherwise = lift $ compileErrorM $ "Unknown unary operator \"" ++ o ++ "\" " +++        | otherwise = compilerErrorM $ "Unknown unary operator \"" ++ o ++ "\" " ++                                              formatFullContextBrace c       doNot t e2 = do         when (t /= boolRequiredValue) $-          lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary ! operator" +++          compilerErrorM $ "Cannot use " ++ show t ++ " with unary ! operator" ++                                  formatFullContextBrace c         return $ (Positional [boolRequiredValue],UnboxedPrimitive PrimBool $ "!" ++ useAsUnboxed PrimBool e2)       doNeg t e2@@ -551,12 +536,12 @@                                             UnboxedPrimitive PrimInt $ "-" ++ useAsUnboxed PrimInt e2)         | t == floatRequiredValue = return $ (Positional [floatRequiredValue],                                              UnboxedPrimitive PrimFloat $ "-" ++ useAsUnboxed PrimFloat e2)-        | otherwise = lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary - operator" +++        | otherwise = compilerErrorM $ "Cannot use " ++ show t ++ " with unary - operator" ++                                              formatFullContextBrace c       doComp t e2         | t == intRequiredValue = return $ (Positional [intRequiredValue],                                             UnboxedPrimitive PrimInt $ "~" ++ useAsUnboxed PrimInt e2)-        | otherwise = lift $ compileErrorM $ "Cannot use " ++ show t ++ " with unary ~ operator" +++        | otherwise = compilerErrorM $ "Cannot use " ++ show t ++ " with unary ~ operator" ++                                              formatFullContextBrace c   compile (InitializeValue c t ps es) = do     es' <- sequence $ map compileExpression $ pValues es@@ -583,7 +568,7 @@                 "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")       checkArity (_,Positional [_]) = return ()       checkArity (i,Positional ts)  =-        compileErrorM $ "Initializer position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"+        compilerErrorM $ "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) =@@ -601,7 +586,7 @@   isolateExpression e = do     ctx <- getCleanContext     (e',ctx') <- lift $ runStateT (compileExpression e) ctx-    (lift $ ccGetRequired ctx') >>= csRequiresTypes+    (lift $ ccGetRequired ctx') >>= csAddRequired     return e'   arithmetic1 = Set.fromList ["*","/"]   arithmetic2 = Set.fromList ["%"]@@ -618,7 +603,7 @@     where       bind t1 t2         | t1 /= t2 =-          lift $ compileErrorM $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " +++          compilerErrorM $ "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)@@ -649,7 +634,7 @@         | o `Set.member` equals && t1 == boolRequiredValue = do           return (Positional [boolRequiredValue],glueInfix PrimBool PrimBool e1 o e2)         | otherwise =-          lift $ compileErrorM $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " +++          compilerErrorM $ "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@@ -659,7 +644,7 @@     r <- csResolver     fa <- csAllFilters     let vt = ValueType RequiredValue $ singleType $ JustTypeInstance t-    (lift $ checkValueAssignment r fa t' vt) <???+    (lift $ checkValueAssignment r fa t' vt) <??       "In converted call at " ++ formatFullContext c     f' <- lookupValueFunction vt f     compileFunctionCall (Just $ useAsUnwrapped e') f' f@@ -670,40 +655,42 @@     compileFunctionCall (Just $ useAsUnwrapped e') f' f   requireSingle _ [t] = return t   requireSingle c2 ts =-    lift $ compileErrorM $ "Function call requires 1 return but found but found {" +++    compilerErrorM $ "Function call requires 1 return but found but found {" ++                             intercalate "," (map show ts) ++ "}" ++ formatFullContextBrace c2 -lookupValueFunction :: (Show c, CompileErrorM m,+lookupValueFunction :: (Show c, CollectErrorsM m,                         CompilerContext c m [String] a) =>   ValueType -> FunctionCall c -> CompilerState a m (ScopedFunction c) lookupValueFunction (ValueType WeakValue t) (FunctionCall c _ _ _) =-  lift $ compileErrorM $ "Use strong to convert " ++ show t +++  compilerErrorM $ "Use strong to convert " ++ show t ++                         " to optional first" ++ formatFullContextBrace c lookupValueFunction (ValueType OptionalValue t) (FunctionCall c _ _ _) =-  lift $ compileErrorM $ "Use require to convert " ++ show t +++  compilerErrorM $ "Use require to convert " ++ show t ++                         " to required first" ++ formatFullContextBrace c lookupValueFunction (ValueType RequiredValue t) (FunctionCall c n _ _) =   csGetTypeFunction c (Just t) n -compileExpressionStart :: (Show c, CompileErrorM m,+compileExpressionStart :: (Show c, CollectErrorsM m,                            CompilerContext c m [String] a) =>   ExpressionStart c -> CompilerState a m (ExpressionType,ExprValue) compileExpressionStart (NamedVariable (OutputValue c n)) = do-  (VariableValue _ s t _) <- csGetVariable c n-  csCheckVariableInit c n+  let var = UsedVariable c n+  (VariableValue _ s t _) <- csGetVariable var+  csCheckVariableInit [var]+  csAddUsed var   scoped <- autoScope s   let lazy = s == CategoryScope   return (Positional [t],readStoredVariable lazy t (scoped ++ variableName n)) compileExpressionStart (NamedMacro c n) = do   e <- csExprLookup c n   csReserveExprMacro c n-  e' <- compileExpression e <??? "In expansion of " ++ show n ++ " at " ++ formatFullContext c+  e' <- compileExpression e <?? "In expansion of " ++ show n ++ " at " ++ formatFullContext c   -- NOTE: This will be skipped if expression compilation fails.   csReleaseExprMacro c n   return e' compileExpressionStart (CategoryCall c t f@(FunctionCall _ n _ _)) = do   f' <- csGetCategoryFunction c (Just t) n-  csRequiresTypes $ Set.fromList [t,sfType f']+  csAddRequired $ Set.fromList [t,sfType f']   t' <- expandCategory t   compileFunctionCall (Just t') f' f compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do@@ -711,49 +698,49 @@   fa <- csAllFilters   lift $ validateGeneralInstance r fa (singleType t) <?? "In function call at " ++ formatFullContext c   f' <- csGetTypeFunction c (Just $ singleType t) n-  when (sfScope f' /= TypeScope) $ lift $ compileErrorM $ "Function " ++ show n +++  when (sfScope f' /= TypeScope) $ compilerErrorM $ "Function " ++ show n ++                                           " cannot be used as a type function" ++                                           formatFullContextBrace c-  csRequiresTypes $ Set.unions $ map categoriesFromTypes [singleType t]-  csRequiresTypes $ Set.fromList [sfType f']+  csAddRequired $ Set.unions $ map categoriesFromTypes [singleType t]+  csAddRequired $ Set.fromList [sfType f']   t' <- expandGeneralInstance $ singleType t   compileFunctionCall (Just t') f' f compileExpressionStart (UnqualifiedCall c f@(FunctionCall _ n _ _)) = do   ctx <- get   f' <- lift $ collectFirstM [tryCategory ctx,tryNonCategory ctx]-  csRequiresTypes $ Set.fromList [sfType f']+  csAddRequired $ Set.fromList [sfType f']   compileFunctionCall Nothing f' f   where     tryCategory ctx = ccGetCategoryFunction ctx c Nothing n     tryNonCategory ctx = do       f' <- ccGetTypeFunction ctx c Nothing n       s <- ccCurrentScope ctx-      when (sfScope f' > s) $ compileErrorM $+      when (sfScope f' > s) $ compilerErrorM $         "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])+  csAddRequired (Set.fromList [BuiltinBool])   when (length (pValues ps) /= 0) $-    lift $ compileErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c   when (length (pValues es) /= 1) $-    lift $ compileErrorM $ "Expected 1 argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 1 argument" ++ formatFullContextBrace c   es' <- sequence $ map compileExpression $ pValues es   when (length (pValues $ fst $ head es') /= 1) $-    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'   when (isWeakValue t0) $-    lift $ compileErrorM $ "Weak values not allowed here" ++ formatFullContextBrace c+    compilerErrorM $ "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 $ compileErrorM $ "Expected 2 type parameters" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 2 type parameters" ++ formatFullContextBrace c   when (length (pValues es) /= 1) $-    lift $ compileErrorM $ "Expected 1 argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 1 argument" ++ formatFullContextBrace c   es' <- sequence $ map compileExpression $ pValues es   when (length (pValues $ fst $ head es') /= 1) $-    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'   [t1,t2] <- lift $ disallowInferred ps   r <- csResolver@@ -765,31 +752,31 @@   -- TODO: If t1 -> t2 then just return e without a Reduce call.   t1' <- expandGeneralInstance t1   t2' <- expandGeneralInstance t2-  csRequiresTypes $ categoriesFromTypes t1-  csRequiresTypes $ categoriesFromTypes t2+  csAddRequired $ categoriesFromTypes t1+  csAddRequired $ categoriesFromTypes t2   return $ (Positional [ValueType OptionalValue t2],             UnwrappedSingle $ typeBase ++ "::Reduce(" ++ t1' ++ ", " ++ t2' ++ ", " ++ useAsUnwrapped e ++ ")") compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinRequire ps es)) = do   when (length (pValues ps) /= 0) $-    lift $ compileErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c   when (length (pValues es) /= 1) $-    lift $ compileErrorM $ "Expected 1 argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 1 argument" ++ formatFullContextBrace c   es' <- sequence $ map compileExpression $ pValues es   when (length (pValues $ fst $ head es') /= 1) $-    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'   when (isWeakValue t0) $-    lift $ compileErrorM $ "Weak values not allowed here" ++ formatFullContextBrace c+    compilerErrorM $ "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 $ compileErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 0 type parameters" ++ formatFullContextBrace c   when (length (pValues es) /= 1) $-    lift $ compileErrorM $ "Expected 1 argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 1 argument" ++ formatFullContextBrace c   es' <- sequence $ map compileExpression $ pValues es   when (length (pValues $ fst $ head es') /= 1) $-    lift $ compileErrorM $ "Expected single return in argument" ++ formatFullContextBrace c+    compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'   let t1 = Positional [ValueType OptionalValue (vtType t0)]   if isWeakValue t0@@ -798,22 +785,22 @@      else return (t1,e) compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinTypename ps es)) = do   when (length (pValues ps) /= 1) $-    lift $ compileErrorM $ "Expected 1 type parameter" ++ formatFullContextBrace c+    compilerErrorM $ "Expected 1 type parameter" ++ formatFullContextBrace c   when (length (pValues es) /= 0) $-    lift $ compileErrorM $ "Expected 0 arguments" ++ formatFullContextBrace c+    compilerErrorM $ "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 [t]+  csAddRequired $ 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 $ compileErrorM $ "Cannot assign to read-only variable " +++  (VariableValue _ s t0 w) <- csGetVariable (UsedVariable c n)+  when (not w) $ compilerErrorM $ "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@@ -826,17 +813,17 @@   return (Positional [t0],readStoredVariable lazy t0 $ "(" ++ scoped ++ variableName n ++                                                      " = " ++ writeStoredVariable t0 e' ++ ")") -disallowInferred :: (Show c, CompileErrorM m) => Positional (InstanceOrInferred c) -> m [GeneralInstance]+disallowInferred :: (Show c, CollectErrorsM 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+    compilerErrorM $ "Type inference is not allowed in reduce calls" ++ formatFullContextBrace c -compileFunctionCall :: (Show c, CompileErrorM m,+compileFunctionCall :: (Show c, CollectErrorsM m,                         CompilerContext c m [String] a) =>   Maybe String -> ScopedFunction c -> FunctionCall c ->   CompilerState a m (ExpressionType,ExprValue)-compileFunctionCall e f (FunctionCall c _ ps es) = message ???> do+compileFunctionCall e f (FunctionCall c _ ps es) = message ??> do   r <- csResolver   fa <- csAllFilters   es' <- sequence $ map compileExpression $ pValues es@@ -848,8 +835,8 @@   -- Called an extra time so arg count mismatches have reasonable errors.   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])+  csAddRequired $ Set.unions $ map categoriesFromTypes $ pValues ps2+  csAddRequired (Set.fromList [sfType f])   params <- expandParams2 ps2   scope <- csCurrentScope   scoped <- autoScope (sfScope f)@@ -858,7 +845,7 @@   where     message = "In call to " ++ show (sfName f) ++ " at " ++ formatFullContext c     backgroundMessage (n,(InferredInstance c2),t) =-      compileBackgroundM $ "Parameter " ++ show n ++ " (from " ++ show (sfType f) ++ "." +++      compilerBackgroundM $ "Parameter " ++ show n ++ " (from " ++ show (sfType f) ++ "." ++         show (sfName f) ++ ") inferred as " ++ show t ++ " at " ++ formatFullContext c2     backgroundMessage _ = return ()     assemble Nothing _ ValueScope ValueScope ps2 es2 =@@ -885,11 +872,11 @@       return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")     checkArity (_,Positional [_]) = return ()     checkArity (i,Positional ts)  =-      compileErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"+      compilerErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1"     checkArg r fa t0 (i,t1) = do       checkValueAssignment r fa t1 t0 <?? "In argument " ++ show i ++ " to " ++ show (sfName f) -guessParamsFromArgs :: (Show c, CompileErrorM m, TypeResolver r) =>+guessParamsFromArgs :: (Show c, CollectErrorsM m, TypeResolver r) =>   r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->   Positional ValueType -> m (Positional GeneralInstance) guessParamsFromArgs r fa f ps ts = do@@ -903,12 +890,12 @@     subPosition pa2 p =       case (vpParam p) `Map.lookup` pa2 of            Just t  -> return t-           Nothing -> compileErrorM $ "Something went wrong inferring " +++           Nothing -> compilerErrorM $ "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) =>+compileMainProcedure :: (Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c -> Expression c -> m (CompiledData [String]) compileMainProcedure tm em e = do   ctx <- getMainContext tm em@@ -918,7 +905,7 @@       ctx0 <- getCleanContext       compileProcedure ctx0 procedure >>= put -compileTestProcedure :: (Show c, CompileErrorM m) =>+compileTestProcedure :: (Show c, CollectErrorsM m) =>   CategoryMap c -> ExprMap c -> TestProcedure c -> m (CompiledData [String]) compileTestProcedure tm em (TestProcedure c n p) = do   ctx <- getMainContext tm em@@ -935,7 +922,7 @@       ctx0 <- getCleanContext       compileProcedure ctx0 p >>= put -selectTestFromArgv1 :: CompileErrorM m => [FunctionName] -> m ([String],CompiledData [String])+selectTestFromArgv1 :: CollectErrorsM m => [FunctionName] -> m ([String],CompiledData [String]) selectTestFromArgv1 fs = return (includes,allCode) where   allCode = mconcat [       initMap,@@ -986,13 +973,13 @@ categoriesFromDefine :: DefinesInstance -> Set.Set CategoryName categoriesFromDefine (DefinesInstance t ps) = t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps) -expandParams :: (CompileErrorM m, CompilerContext c m s a) =>+expandParams :: (CollectErrorsM 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 ", " ps' ++ ")" -expandParams2 :: (CompileErrorM m, CompilerContext c m s a) =>+expandParams2 :: (CollectErrorsM m, CompilerContext c m s a) =>   Positional GeneralInstance -> CompilerState a m String expandParams2 ps = do   ps' <- sequence $ map expandGeneralInstance $ pValues ps@@ -1002,7 +989,7 @@   CategoryName -> CompilerState a m String expandCategory t = return $ categoryGetter t ++ "()" -expandGeneralInstance :: (CompileErrorM m, CompilerContext c m s a) =>+expandGeneralInstance :: (CollectErrorsM m, CompilerContext c m s a) =>   GeneralInstance -> CompilerState a m String expandGeneralInstance t   | t == minBound = return $ allGetter ++ "()"@@ -1022,15 +1009,15 @@     ps' <- sequence ps     return $ "(L_get<S<const " ++ typeBase ++ ">>(" ++ intercalate "," ps' ++ "))" -doImplicitReturn :: (CompileErrorM m, Show c, CompilerContext c m [String] a) =>+doImplicitReturn :: (CollectErrorsM m, Show c, CompilerContext c m [String] a) =>   [c] -> CompilerState a m () doImplicitReturn c = do   named <- csIsNamedReturns-  (CleanupSetup cs ss) <- csGetCleanup JumpReturn-  when (not $ null ss) $ do-    sequence_ $ map (csInheritReturns . (:[])) cs-    csWrite ss   csRegisterReturn c Nothing+  (CleanupBlock ss _ _ req) <- csGetCleanup JumpReturn+  csAddRequired req+  csSetJumpType c JumpReturn+  csWrite ss   if not named      then csWrite ["return ReturnTuple(0);"]      else do@@ -1041,15 +1028,16 @@     assign (ReturnVariable i n t) =       "returns.At(" ++ show i ++ ") = " ++ useAsUnwrapped (readStoredVariable False t $ variableName n) ++ ";" -autoPositionalCleanup :: (CompileErrorM m, CompilerContext c m [String] a) =>-  ExprValue -> CompilerState a m ()-autoPositionalCleanup e = do-  (CleanupSetup cs ss) <- csGetCleanup JumpReturn+autoPositionalCleanup :: (CollectErrorsM m, CompilerContext c m [String] a) =>+  [c] -> ExprValue -> CompilerState a m ()+autoPositionalCleanup c e = do+  (CleanupBlock ss _ _ req) <- csGetCleanup JumpReturn+  csAddRequired req+  csSetJumpType c JumpReturn   if null ss      then csWrite ["return " ++ useAsReturns e ++ ";"]      else do        named <- csIsNamedReturns-       sequence_ $ map (csInheritReturns . (:[])) cs        if named           then do             csWrite ["returns = " ++ useAsReturns e ++ ";"]@@ -1059,3 +1047,30 @@             csWrite ["{","ReturnTuple returns = " ++ useAsReturns e ++ ";"]             csWrite ss             csWrite ["return returns;","}"]++autoInsertCleanup :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) =>+  [c] -> JumpType -> a -> CompilerState a m ()+autoInsertCleanup c j ctx = do+  (CleanupBlock ss vs jump req) <- lift $ ccGetCleanup ctx j+  lift (ccCheckVariableInit ctx vs) <?? "In inlining of cleanup block after statement at " ++ formatFullContext c+  let vs2 = map (\(UsedVariable c0 v) -> UsedVariable (c ++ c0) v) vs+  -- This is needed in case a cleanup is inlined within another cleanup, e.g.,+  -- e.g., if the latter has a break statement.+  sequence_ $ map csAddUsed $ vs2+  csWrite ss+  csAddRequired req+  csSetJumpType c jump++autoInlineOutput :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) =>+  a -> CompilerState a m ()+autoInlineOutput ctx = do+  (lift $ ccGetRequired ctx) >>= csAddRequired+  getAndIndentOutput ctx >>= csWrite+  csInheritReturns [ctx]++getAndIndentOutput :: (Show c, CollectErrorsM m, CompilerContext c m [String] a) =>+  a -> CompilerState a m [String]+getAndIndentOutput ctx = fmap indentCode (lift $ ccGetOutput ctx)++indentCode :: [String] -> [String]+indentCode = map ("  " ++)

@@ -27,17 +27,17 @@ import Control.Monad.IO.Class import System.Directory -import Base.CompileError+import Base.CompilerError import Config.LocalConfig  import Paths_zeolite_lang (getDataFileName)  -loadConfig :: (MonadIO m, CompileErrorM m) => m (Resolver,Backend)+loadConfig :: (MonadIO m, ErrorContextM m) => m (Resolver,Backend) loadConfig = do   configFile <- liftIO localConfigPath   isFile <- liftIO $ doesFileExist configFile-  when (not isFile) $ compileErrorM "Zeolite has not been configured. Please run zeolite-setup."+  when (not isFile) $ compilerErrorM "Zeolite has not been configured. Please run zeolite-setup."   configString <- liftIO $ readFile configFile   lc <- check $ (reads configString :: [(LocalConfig,String)])   pathsFile   <- liftIO $ globalPathsPath@@ -48,7 +48,7 @@   return (addPaths (lcResolver lc) paths,lcBackend lc) where     check [(cm,"")]   = return cm     check [(cm,"\n")] = return cm-    check _ = compileErrorM "Zeolite configuration is corrupt. Please rerun zeolite-setup."+    check _ = compilerErrorM "Zeolite configuration is corrupt. Please rerun zeolite-setup."  localConfigPath :: IO FilePath localConfigPath = getDataFileName localConfigFilename >>= canonicalizePath

@@ -41,7 +41,7 @@ import System.Posix.Process (ProcessStatus(..),executeFile,forkProcess,getProcessStatus) import System.Posix.Temp (mkstemps) -import Base.CompileError+import Base.CompilerError import Cli.Programs import Module.Paths @@ -120,7 +120,7 @@   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 :: (MonadIO m, ErrorContextM m) => String -> [String] -> m () executeProcess c os = do   errorFromIO $ hPutStrLn stderr $ "Executing: " ++ intercalate " " (c:os)   pid    <- errorFromIO $ forkProcess $ executeFile c True os Nothing@@ -129,7 +129,7 @@        Just (Exited ExitSuccess) -> return ()        _ -> do          errorFromIO $ hPutStrLn stderr $ "Execution of " ++ c ++ " failed"-         compileErrorM $ "Execution of " ++ c ++ " failed"+         compilerErrorM $ "Execution of " ++ c ++ " failed"  instance PathIOHandler Resolver where   resolveModule r p m = do@@ -165,11 +165,11 @@     components = map stripSlash $ splitPath m     stripSlash = reverse . dropWhile (== '/') . reverse -firstExisting :: (MonadIO m, CompileErrorM m) => FilePath -> [FilePath] -> m FilePath+firstExisting :: (MonadIO m, ErrorContextM m) => FilePath -> [FilePath] -> m FilePath firstExisting m ps = do   p <- errorFromIO $ findModule ps   case p of-       Nothing -> compileErrorM $ "Could not find path " ++ m+       Nothing -> compilerErrorM $ "Could not find path " ++ m        Just p2 -> return p2  findModule :: [FilePath] -> IO (Maybe FilePath)

@@ -16,8 +16,6 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-}- module Module.CompileMetadata (   CategoryIdentifier(..),   CompileMetadata(..),@@ -28,10 +26,10 @@ ) where  import Data.List (nub)-import Text.Parsec (SourcePos)  import Cli.CompileOptions import Cli.Programs (VersionHash)+import Parser.TextParser (SourceContext) import Types.Pragma (MacroName) import Types.Procedure (Expression) import Types.TypeCategory (Namespace)@@ -96,7 +94,7 @@   ModuleConfig {     mcRoot :: FilePath,     mcPath :: FilePath,-    mcExprMap :: [(MacroName,Expression SourcePos)],+    mcExprMap :: [(MacroName,Expression SourceContext)],     mcPublicDeps :: [FilePath],     mcPrivateDeps :: [FilePath],     mcExtraFiles :: [ExtraSource],

@@ -24,17 +24,17 @@  import Control.Applicative.Permutations import Control.Monad (when)-import Text.Parsec -import Base.CompileError+import Base.CompilerError import Cli.CompileOptions import Cli.Programs (VersionHash(..)) import Module.CompileMetadata import Parser.Common import Parser.Procedure ()+import Parser.TextParser import Parser.TypeCategory () import Parser.TypeInstance ()-import Text.Regex.TDFA -- Not safe!+import Text.Regex.TDFA import Types.Pragma (MacroName) import Types.Procedure (Expression) import Types.TypeCategory (FunctionName(..),Namespace(..))@@ -42,19 +42,19 @@   class ConfigFormat a where-  readConfig :: CompileErrorM m => ParserE m a-  writeConfig :: CompileErrorM m => a -> m [String]+  readConfig :: TextParser a+  writeConfig :: CollectErrorsM m => a -> m [String] -autoReadConfig :: (ConfigFormat a, CompileErrorM m) => String -> String -> m a-autoReadConfig f s = runParserE (between optionalSpace endOfDoc readConfig) f s+autoReadConfig :: (ConfigFormat a, ErrorContextM m) => String -> String -> m a+autoReadConfig f s = runTextParser (between optionalSpace endOfDoc readConfig) f s -autoWriteConfig ::  (ConfigFormat a, CompileErrorM m) => a -> m String+autoWriteConfig ::  (ConfigFormat a, CollectErrorsM m) => a -> m String autoWriteConfig = fmap unlines . writeConfig -structOpen :: Monad m => ParserE m ()+structOpen :: TextParser () structOpen = sepAfter (string_ "{") -structClose :: Monad m => ParserE m ()+structClose :: TextParser () structClose = sepAfter (string_ "}")  indents :: [String] -> [String]@@ -67,57 +67,57 @@ prependFirst s0 (s:ss) = (s0 ++ s):ss prependFirst s0 _      = [s0] -validateCategoryName :: CompileErrorM m => CategoryName -> m ()+validateCategoryName :: ErrorContextM m => CategoryName -> m () validateCategoryName c =     when (not $ show c =~ "^[A-Z][A-Za-z0-9]*$") $-      compileErrorM $ "Invalid category name: \"" ++ show c ++ "\""+      compilerErrorM $ "Invalid category name: \"" ++ show c ++ "\"" -validateFunctionName :: CompileErrorM m => FunctionName -> m ()+validateFunctionName :: ErrorContextM m => FunctionName -> m () validateFunctionName f =     when (not $ show f =~ "^[a-z][A-Za-z0-9]*$") $-      compileErrorM $ "Invalid function name: \"" ++ show f ++ "\""+      compilerErrorM $ "Invalid function name: \"" ++ show f ++ "\"" -validateHash :: CompileErrorM m => VersionHash -> m ()+validateHash :: ErrorContextM m => VersionHash -> m () validateHash h =     when (not $ show h =~ "^[A-Za-z0-9]+$") $-      compileErrorM $ "Version hash must be a hex string: \"" ++ show h ++ "\""+      compilerErrorM $ "Version hash must be a hex string: \"" ++ show h ++ "\"" -parseHash :: Monad m => ParserE m VersionHash-parseHash = labeled "version hash" $ sepAfter (fmap VersionHash $ many1 hexDigit)+parseHash :: TextParser VersionHash+parseHash = labeled "version hash" $ sepAfter (fmap VersionHash $ some hexDigitChar) -maybeShowNamespace :: CompileErrorM m => String -> Namespace -> m [String]+maybeShowNamespace :: ErrorContextM m => String -> Namespace -> m [String] maybeShowNamespace l (StaticNamespace ns) = do   when (not $ ns =~ "^[A-Za-z][A-Za-z0-9_]*$") $-    compileErrorM $ "Invalid category namespace: \"" ++ ns ++ "\""+    compilerErrorM $ "Invalid category namespace: \"" ++ ns ++ "\""   return [l ++ " " ++ ns] maybeShowNamespace _ _ = return [] -parseNamespace :: Monad m => ParserE m Namespace+parseNamespace :: TextParser Namespace parseNamespace = labeled "namespace" $ do-  b <- lower-  e <- sepAfter $ many (alphaNum <|> char '_')+  b <- lowerChar+  e <- sepAfter $ many (alphaNumChar <|> char '_')   return $ StaticNamespace (b:e) -parseQuoted :: Monad m => ParserE m String+parseQuoted :: TextParser String parseQuoted = labeled "quoted string" $ do   string_ "\""   ss <- manyTill stringChar (string_ "\"")   optionalSpace   return ss -parseList :: Monad m => ParserE m a -> ParserE m [a]+parseList :: TextParser a -> TextParser [a] parseList p = labeled "list" $ do   sepAfter (string_ "[")   xs <- manyTill (sepAfter p) (string_ "]")   optionalSpace   return xs -parseOptional :: Monad m => String -> a -> ParserE m a -> Permutation (ParserE m) a+parseOptional :: String -> a -> TextParser a -> Permutation (TextParser) a parseOptional l def p = toPermutationWithDefault def $ do     try $ sepAfter (string_ l)     p -parseRequired :: Monad m => String -> ParserE m a -> Permutation (ParserE m) a+parseRequired :: String -> TextParser a -> Permutation (TextParser) a parseRequired l p = toPermutation $ do     try $ sepAfter (string_ l)     p@@ -281,7 +281,7 @@   writeConfig (ModuleConfig p d em is is2 es ep m) = do     es' <- fmap concat $ mapErrorsM writeConfig es     m' <- writeConfig m-    when (not $ null em) $ compileErrorM "Only empty expression maps are allowed when writing"+    when (not $ null em) $ compilerErrorM "Only empty expression maps are allowed when writing"     return $ [         "root: " ++ show p,         "path: " ++ show d,@@ -374,9 +374,9 @@         "}"       ]   writeConfig CompileUnspecified = writeConfig (CompileIncremental [])-  writeConfig _ = compileErrorM "Invalid compile mode"+  writeConfig _ = compilerErrorM "Invalid compile mode" -parseExprMacro :: CompileErrorM m => ParserE m (MacroName,Expression SourcePos)+parseExprMacro :: TextParser (MacroName,Expression SourceContext) parseExprMacro = do   sepAfter (string_ "expression_macro")   structOpen

@@ -28,15 +28,15 @@ import Data.List (nub,isSuffixOf) import System.FilePath -import Base.CompileError+import Base.CompilerError   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-  zipWithContents   :: (MonadIO m, CompileErrorM m) => r -> FilePath -> [FilePath] -> m [(FilePath,String)]+  resolveModule     :: (MonadIO m, CollectErrorsM m) => r -> FilePath -> FilePath -> m FilePath+  isSystemModule    :: (MonadIO m, CollectErrorsM m) => r -> FilePath -> FilePath -> m Bool+  resolveBaseModule :: (MonadIO m, CollectErrorsM m) => r -> m FilePath+  isBaseModule      :: (MonadIO m, CollectErrorsM m) => r -> FilePath -> m Bool+  zipWithContents   :: (MonadIO m, CollectErrorsM m) => r -> FilePath -> [FilePath] -> m [(FilePath,String)]  fixPath :: FilePath -> FilePath fixPath = foldl (</>) "" . process [] . map dropSlash . splitPath where

@@ -55,20 +55,20 @@ import System.Directory import System.FilePath import System.IO-import Text.Parsec (SourcePos) import qualified Data.Map as Map import qualified Data.Set as Set -import Base.CompileError-import Base.CompileInfo+import Base.CompilerError+import Base.TrackedErrors import Cli.CompileOptions import Cli.Programs (VersionHash(..)) import Compilation.ProcedureContext (ExprMap) import CompilerCxx.Category (CxxOutput(..)) import Module.CompileMetadata-import Module.ParseMetadata -- Not safe, due to Text.Regex.TDFA.+import Module.ParseMetadata import Module.Paths import Parser.SourceFile+import Parser.TextParser (SourceContext) import Types.Pragma import Types.Procedure (Expression(Literal),ValueLiteral(..)) import Types.TypeCategory@@ -89,46 +89,46 @@ mapMetadata :: [CompileMetadata] -> MetadataMap mapMetadata cs = Map.fromList $ zip (map cmPath cs) cs -loadRecompile :: FilePath -> CompileInfoIO ModuleConfig+loadRecompile :: FilePath -> TrackedErrorsIO ModuleConfig loadRecompile p = do   let f = p </> moduleFilename   isFile <- errorFromIO $ doesFileExist p-  when isFile $ compileErrorM $ "Path \"" ++ p ++ "\" is not a directory"+  when isFile $ compilerErrorM $ "Path \"" ++ p ++ "\" is not a directory"   isDir <- errorFromIO $ doesDirectoryExist p-  when (not isDir) $ compileErrorM $ "Path \"" ++ p ++ "\" does not exist"+  when (not isDir) $ compilerErrorM $ "Path \"" ++ p ++ "\" does not exist"   filePresent <- errorFromIO $ doesFileExist f-  when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been configured yet"+  when (not filePresent) $ compilerErrorM $ "Module \"" ++ p ++ "\" has not been configured yet"   c <- errorFromIO $ readFile f   m <- autoReadConfig f c <!!     "Could not parse metadata from \"" ++ p ++ "\"; please reconfigure"   p0 <- errorFromIO $ canonicalizePath p   let p1 = mcRoot m </> mcPath m   p2 <- errorFromIO $ canonicalizePath $ p0 </> p1-  when (p2 /= p0) $ compileErrorM $ "Expected module path from " ++ f +++  when (p2 /= p0) $ compilerErrorM $ "Expected module path from " ++ f ++                                     " to match " ++ moduleFilename ++                                     " location but got " ++ p2 ++                                     " (resolved from root: \"" ++ mcRoot m ++                                     "\" and path: \"" ++ mcPath m ++ "\")"   return m -isPathUpToDate :: VersionHash -> ForceMode -> FilePath -> CompileInfoIO Bool+isPathUpToDate :: VersionHash -> ForceMode -> FilePath -> TrackedErrorsIO 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+  m <- errorFromIO $ toTrackedErrors $ loadDepsCommon f h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p]+  return $ not $ isCompilerError m -isPathConfigured :: FilePath -> FilePath -> CompileInfoIO Bool+isPathConfigured :: FilePath -> FilePath -> TrackedErrorsIO Bool isPathConfigured p d = do-  m <- errorFromIO $ toCompileInfo $ loadRecompile (p </> d)-  return $ not $ isCompileError m+  m <- errorFromIO $ toTrackedErrors $ loadRecompile (p </> d)+  return $ not $ isCompilerError m -writeMetadata :: FilePath -> CompileMetadata -> CompileInfoIO ()+writeMetadata :: FilePath -> CompileMetadata -> TrackedErrorsIO () writeMetadata p m = do   p' <- errorFromIO $ canonicalizePath p   errorFromIO $ hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"."   m' <- autoWriteConfig m <?? "In data for " ++ p   writeCachedFile p' "" metadataFilename m' -writeRecompile :: FilePath -> ModuleConfig -> CompileInfoIO ()+writeRecompile :: FilePath -> ModuleConfig -> TrackedErrorsIO () writeRecompile p m = do   p' <- errorFromIO $ canonicalizePath p   let f = p </> moduleFilename@@ -136,19 +136,19 @@   m' <- autoWriteConfig m <?? "In data for " ++ p   errorFromIO $ writeFile f m' -eraseCachedData :: FilePath -> CompileInfoIO ()+eraseCachedData :: FilePath -> TrackedErrorsIO () eraseCachedData p = do   let d  = p </> cachedDataPath   dirExists <- errorFromIO $ doesDirectoryExist d   when dirExists $ errorFromIO $ removeDirectoryRecursive d -createCachePath :: FilePath -> CompileInfoIO ()+createCachePath :: FilePath -> TrackedErrorsIO () createCachePath p = do   let f = p </> cachedDataPath   exists <- errorFromIO $ doesDirectoryExist f   when (not exists) $ errorFromIO $ createDirectoryIfMissing False f -writeCachedFile :: FilePath -> String -> FilePath -> String -> CompileInfoIO ()+writeCachedFile :: FilePath -> String -> FilePath -> String -> TrackedErrorsIO () writeCachedFile p ns f c = do   createCachePath p   errorFromIO $ createDirectoryIfMissing False $ p </> cachedDataPath </> ns@@ -160,20 +160,20 @@ getCacheRelativePath :: FilePath -> FilePath getCacheRelativePath f = ".." </> f -findSourceFiles :: FilePath -> FilePath -> CompileInfoIO ([FilePath],[FilePath],[FilePath])+findSourceFiles :: FilePath -> FilePath -> TrackedErrorsIO ([FilePath],[FilePath],[FilePath]) findSourceFiles p0 p = do   let absolute = p0 </> p   isFile <- errorFromIO $ doesFileExist absolute-  when isFile $ compileErrorM $ "Path \"" ++ absolute ++ "\" is not a directory"+  when isFile $ compilerErrorM $ "Path \"" ++ absolute ++ "\" is not a directory"   isDir <- errorFromIO $ doesDirectoryExist absolute-  when (not isDir) $ compileErrorM $ "Path \"" ++ absolute ++ "\" does not exist"+  when (not isDir) $ compilerErrorM $ "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 -> CompileInfoIO (ExprMap SourcePos)+getExprMap :: FilePath -> ModuleConfig -> TrackedErrorsIO (ExprMap SourceContext) getExprMap p m = do   path <- errorFromIO $ canonicalizePath (p </> mcRoot m </> mcPath m)   let defaults = [(MacroName "MODULE_PATH",Literal (StringLiteral [] path))]@@ -199,19 +199,19 @@ getObjectFilesForDeps = concat . map cmObjectFiles  loadModuleMetadata :: VersionHash -> ForceMode -> MetadataMap -> FilePath ->-  CompileInfoIO CompileMetadata+  TrackedErrorsIO CompileMetadata loadModuleMetadata h f ca = fmap head . loadDepsCommon f h ca Set.empty (const []) . (:[])  loadPublicDeps :: VersionHash -> ForceMode -> MetadataMap -> [FilePath] ->-  CompileInfoIO [CompileMetadata]+  TrackedErrorsIO [CompileMetadata] loadPublicDeps h f ca = loadDepsCommon f h ca Set.empty cmPublicDeps  loadTestingDeps :: VersionHash -> ForceMode -> MetadataMap -> CompileMetadata ->-  CompileInfoIO [CompileMetadata]+  TrackedErrorsIO [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]+  TrackedErrorsIO [CompileMetadata] loadPrivateDeps h f ca ms = do   new <- loadDepsCommon f h ca pa (\m -> cmPublicDeps m ++ cmPrivateDeps m) paths   return $ ms ++ new where@@ -219,7 +219,7 @@     pa = Set.fromList $ map cmPath ms  loadDepsCommon :: ForceMode -> VersionHash -> MetadataMap -> Set.Set FilePath ->-  (CompileMetadata -> [FilePath]) -> [FilePath] -> CompileInfoIO [CompileMetadata]+  (CompileMetadata -> [FilePath]) -> [FilePath] -> TrackedErrorsIO [CompileMetadata] loadDepsCommon f h ca pa0 getDeps ps = do   (_,processed) <- fixedPaths >>= collect (pa0,[])   let cached = Map.union ca (Map.fromList processed)@@ -243,15 +243,15 @@       | otherwise = do           p' <- errorFromIO $ canonicalizePath p           when (cmPath m /= p') $-            compileErrorM $ "Module \"" ++ p ++ "\" has an invalid cache path and must be recompiled"-          fresh <- errorFromIO $ toCompileInfo $ checkModuleFreshness h cm p m <!!+            compilerErrorM $ "Module \"" ++ p ++ "\" has an invalid cache path and must be recompiled"+          fresh <- errorFromIO $ toTrackedErrors $ checkModuleFreshness h cm p m <!!             "Module \"" ++ p ++ "\" is out of date and should be recompiled"           if enforce-             then fromCompileInfo   fresh-             else asCompileWarnings fresh+             then fromTrackedErrors   fresh+             else asCompilerWarnings fresh           return m -loadMetadata :: MetadataMap -> FilePath -> CompileInfoIO CompileMetadata+loadMetadata :: MetadataMap -> FilePath -> TrackedErrorsIO CompileMetadata loadMetadata ca p = do   path <- errorFromIO $ canonicalizePath p   case path `Map.lookup` ca of@@ -259,11 +259,11 @@        Nothing -> do          let f = p </> cachedDataPath </> metadataFilename          isFile <- errorFromIO $ doesFileExist p-         when isFile $ compileErrorM $ "Path \"" ++ p ++ "\" is not a directory"+         when isFile $ compilerErrorM $ "Path \"" ++ p ++ "\" is not a directory"          isDir <- errorFromIO $ doesDirectoryExist p-         when (not isDir) $ compileErrorM $ "Path \"" ++ p ++ "\" does not exist"+         when (not isDir) $ compilerErrorM $ "Path \"" ++ p ++ "\" does not exist"          filePresent <- errorFromIO $ doesFileExist f-         when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been compiled yet"+         when (not filePresent) $ compilerErrorM $ "Module \"" ++ p ++ "\" has not been compiled yet"          c <- errorFromIO $ readFile f          (autoReadConfig f c) <!!             "Could not parse metadata from \"" ++ p ++ "\"; please recompile"@@ -282,7 +282,7 @@ checkModuleVersionHash :: VersionHash -> CompileMetadata -> Bool checkModuleVersionHash h m = cmVersionHash m == h -checkModuleFreshness :: VersionHash -> MetadataMap -> FilePath -> CompileMetadata -> CompileInfoIO ()+checkModuleFreshness :: VersionHash -> MetadataMap -> FilePath -> CompileMetadata -> TrackedErrorsIO () checkModuleFreshness h ca p m@(CompileMetadata _ p2 _ _ is is2 _ _ _ _ ps xs ts hxx cxx bs _ os) = do   time <- errorFromIO $ getModificationTime $ getCachedPath p "" metadataFilename   (ps2,xs2,ts2) <- findSourceFiles p ""@@ -303,15 +303,15 @@   where     checkHash =       when (not $ checkModuleVersionHash h m) $-        compileErrorM $ "Module \"" ++ p ++ "\" was compiled with a different compiler setup"+        compilerErrorM $ "Module \"" ++ p ++ "\" was compiled with a different compiler setup"     checkInput time f = do       exists <- doesFileOrDirExist f-      when (not exists) $ compileErrorM $ "Required path \"" ++ f ++ "\" is missing"+      when (not exists) $ compilerErrorM $ "Required path \"" ++ f ++ "\" is missing"       time2 <- errorFromIO $ getModificationTime f-      when (time2 > time) $ compileErrorM $ "Required path \"" ++ f ++ "\" is newer than cached data"+      when (time2 > time) $ compilerErrorM $ "Required path \"" ++ f ++ "\" is newer than cached data"     checkOutput f = do       exists <- errorFromIO $ doesFileExist f-      when (not exists) $ compileErrorM $ "Output file \"" ++ f ++ "\" is missing"+      when (not exists) $ compilerErrorM $ "Output file \"" ++ f ++ "\" is missing"     checkDep time dep = do       cm <- loadMetadata ca dep       mapErrorsM_ (checkInput time . (cmPath cm </>)) $ cmPublicFiles cm@@ -322,12 +322,12 @@     checkRequire (CategoryIdentifier d c ns) = do       cm <- loadMetadata ca d       when (cmPath cm /= p2 && ns /= cmPublicNamespace cm) $-        compileErrorM $ "Required category " ++ show c ++ " is newer than cached data"+        compilerErrorM $ "Required category " ++ show c ++ " is newer than cached data"     checkRequire (UnresolvedCategory c) =-      compileErrorM $ "Required category " ++ show c ++ " is unresolved"+      compilerErrorM $ "Required category " ++ show c ++ " is unresolved"     checkMissing s0 s1 = do       let missing = Set.toList $ Set.fromList s1 `Set.difference` Set.fromList s0-      mapErrorsM_ (\f -> compileErrorM $ "Required path \"" ++ f ++ "\" has not been compiled") missing+      mapErrorsM_ (\f -> compilerErrorM $ "Required path \"" ++ f ++ "\" has not been compiled") missing     doesFileOrDirExist f2 = do       existF <- errorFromIO $ doesFileExist f2       if existF@@ -400,7 +400,7 @@  loadModuleGlobals :: PathIOHandler r => r -> FilePath -> (Namespace,Namespace) -> [FilePath] ->   Maybe CompileMetadata -> [CompileMetadata] -> [CompileMetadata] ->-  CompileInfoIO ([WithVisibility (AnyCategory SourcePos)])+  TrackedErrorsIO ([WithVisibility (AnyCategory SourceContext)]) loadModuleGlobals r p (ns0,ns1) fs m deps1 deps2 = do   let public = Set.fromList $ map cmPath deps1   let deps2' = filter (\cm -> not $ cmPath cm `Set.member` public) deps2

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

@@ -17,18 +17,17 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}  module Parser.DefinedCategory ( ) where  import Control.Monad (when) import Prelude hiding (pi)-import Text.Parsec -import Base.CompileError+import Base.CompilerError import Parser.Common import Parser.Procedure ()+import Parser.TextParser import Parser.TypeCategory import Parser.TypeInstance () import Types.DefinedCategory@@ -38,9 +37,9 @@ import Types.Variance  -instance ParseFromSource (DefinedCategory SourcePos) where+instance ParseFromSource (DefinedCategory SourceContext) where   sourceParser = labeled "defined concrete category" $ do-    c <- getPosition+    c <- getSourceContext     kwDefine     n <- sourceParser     sepAfter (string_ "{")@@ -53,7 +52,7 @@       parseRefinesDefines = fmap merge2 $ sepBy refineOrDefine optionalSpace       refineOrDefine = labeled "refine or define" $ put12 singleRefine <|> put22 singleDefine       parseInternalParams = labeled "internal params" $ do-        try kwTypes+        kwTypes         pi <- between (sepAfter $ string_ "<")                       (sepAfter $ string_ ">")                       (sepBy singleParam (sepAfter $ string_ ","))@@ -65,13 +64,13 @@         sepAfter (string_ "}")         return fi       singleParam = labeled "param declaration" $ do-        c <- getPosition+        c <- getSourceContext         n <- sourceParser         return $ ValueParam [c] n Invariant -instance ParseFromSource (DefinedMember SourcePos) where+instance ParseFromSource (DefinedMember SourceContext) where   sourceParser = labeled "defined member" $ do-    c <- getPosition+    c <- getSourceContext     (s,t) <- try parseType     n <- sourceParser     e <- if s == ValueScope@@ -88,10 +87,10 @@         t <- sourceParser         return (s,t) -parseMemberProcedureFunction :: CompileErrorM m =>-  CategoryName -> ParserE m ([DefinedMember SourcePos],-                             [ExecutableProcedure SourcePos],-                             [ScopedFunction SourcePos])+parseMemberProcedureFunction ::+  CategoryName -> TextParser ([DefinedMember SourceContext],+                             [ExecutableProcedure SourceContext],+                             [ScopedFunction SourceContext]) parseMemberProcedureFunction n = do   (ms,ps,fs) <- parseAny3 (catchUnscopedType <|> sourceParser) sourceParser singleFunction   let ps2 = ps ++ map snd fs@@ -99,13 +98,11 @@   return (ms,ps2,fs2) where     singleFunction = labeled "function" $ do       f <- parseScopedFunction parseScope (return n)-      c <- getPosition       p <- labeled ("definition of function " ++ show (sfName f)) $ sourceParser       when (sfName f /= epName p) $-        parseErrorM c $ "expecting definition of function " ++ show (sfName f) ++-                        " but got definition of " ++ show (epName p)+        compilerErrorM $ "expecting definition of function " ++ show (sfName f) +++                         " but got definition of " ++ show (epName p)       return (f,p)     catchUnscopedType = labeled "" $ do-      c <- getPosition-      _ <- try sourceParser :: CompileErrorM m => ParserE m ValueType-      parseErrorM c "members must have an explicit @value or @category scope"+      _ <- try sourceParser :: TextParser ValueType+      compilerErrorM "members must have an explicit @value or @category scope"

@@ -17,23 +17,21 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}  module Parser.IntegrationTest ( ) where -import Text.Parsec- import Parser.Common import Parser.DefinedCategory () import Parser.Procedure ()+import Parser.TextParser import Parser.TypeCategory () import Types.IntegrationTest  -instance ParseFromSource (IntegrationTestHeader SourcePos) where+instance ParseFromSource (IntegrationTestHeader SourceContext) where   sourceParser = labeled "testcase" $ do-    c <- getPosition+    c <- getSourceContext     sepAfter kwTestcase     string_ "\""     name <- manyTill stringChar (string_ "\"")@@ -44,58 +42,54 @@     sepAfter (string_ "}")     return $ IntegrationTestHeader [c] name args result where       resultCompiles = labeled "compiles expectation" $ do-        c <- getPosition-        try $ sepAfter (keyword "compiles")+        c <- getSourceContext+        keyword "compiles"         (req,exc) <- requireOrExclude         return $ ExpectCompiles [c] req exc       resultError = labeled "error expectation" $ do-        c <- getPosition-        sepAfter (keyword "error")+        c <- getSourceContext+        keyword "error"         (req,exc) <- requireOrExclude-        return $ ExpectCompileError [c] req exc+        return $ ExpectCompilerError [c] req exc       resultCrash = labeled "crash expectation" $ do-        c <- getPosition-        try $ sepAfter (keyword "crash")+        c <- getSourceContext+        keyword "crash"         (req,exc) <- requireOrExclude         return $ ExpectRuntimeError [c] req exc       resultSuccess = labeled "success expectation" $ do-        c <- getPosition-        sepAfter (keyword "success")+        c <- getSourceContext+        keyword "success"         (req,exc) <- requireOrExclude         return $ ExpectRuntimeSuccess [c] req exc       parseArgs = labeled "testcase args" $ do-        sepAfter (keyword "args")+        keyword "args"         many (sepAfter quotedString)-      requireOrExclude = parsed >>= return . foldr merge empty where-        empty = ([],[])-        merge (cs1,ds1) (cs2,ds2) = (cs1++cs2,ds1++ds2)-        parsed = sepBy anyType optionalSpace-        anyType = require <|> exclude where-          require = do-            sepAfter (keyword "require")-            s <- outputScope-            string_ "\""-            r <- fmap concat $ manyTill regexChar (string_ "\"")-            optionalSpace-            return ([OutputPattern s r],[])-          exclude = do-            sepAfter (keyword "exclude")-            s <- outputScope-            string_ "\""-            e <- fmap concat $ manyTill regexChar (string_ "\"")-            optionalSpace-            return ([],[OutputPattern s e])+      requireOrExclude = parseAny2 require exclude where+        require = do+          keyword "require"+          s <- outputScope+          string_ "\""+          r <- fmap concat $ manyTill regexChar (string_ "\"")+          optionalSpace+          return $ OutputPattern s r+        exclude = do+          keyword "exclude"+          s <- outputScope+          string_ "\""+          e <- fmap concat $ manyTill regexChar (string_ "\"")+          optionalSpace+          return $ OutputPattern s e       outputScope = try anyScope <|>                     try compilerScope <|>                     try stderrScope <|>                     try stdoutScope <|>                     return OutputAny-      anyScope      = sepAfter (keyword "any")      >> return OutputAny-      compilerScope = sepAfter (keyword "compiler") >> return OutputCompiler-      stderrScope   = sepAfter (keyword "stderr")   >> return OutputStderr-      stdoutScope   = sepAfter (keyword "stdout")   >> return OutputStdout+      anyScope      = keyword "any"      >> return OutputAny+      compilerScope = keyword "compiler" >> return OutputCompiler+      stderrScope   = keyword "stderr"   >> return OutputStderr+      stdoutScope   = keyword "stdout"   >> return OutputStdout -instance ParseFromSource (IntegrationTest SourcePos) where+instance ParseFromSource (IntegrationTest SourceContext) where   sourceParser = labeled "integration test" $ do     h <- sourceParser     (cs,ds,ts) <- parseAny3 sourceParser sourceParser sourceParser

@@ -16,8 +16,6 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-}- module Parser.Pragma (   parsePragmas,   pragmaComment,@@ -30,50 +28,50 @@ ) where  import Control.Monad (when)-import Text.Parsec -import Base.CompileError+import Base.CompilerError import Parser.Common+import Parser.TextParser import Types.Pragma  -parsePragmas :: CompileErrorM m => [ParserE m a] -> ParserE m [a]+parsePragmas :: [TextParser a] -> TextParser [a] parsePragmas = many . foldr ((<|>)) unknownPragma -pragmaModuleOnly :: CompileErrorM m => ParserE m (Pragma SourcePos)+pragmaModuleOnly :: TextParser (Pragma SourceContext) pragmaModuleOnly = autoPragma "ModuleOnly" $ Left parseAt where   parseAt c = PragmaVisibility [c] ModuleOnly  instance ParseFromSource MacroName where   sourceParser = labeled "macro name" $ do-    h <- upper <|> char '_'-    t <- many (upper <|> digit <|> char '_')+    h <- upperChar <|> char '_'+    t <- many (upperChar <|> digitChar <|> char '_')     optionalSpace     return $ MacroName (h:t) -pragmaExprLookup :: CompileErrorM m => ParserE m (Pragma SourcePos)+pragmaExprLookup :: TextParser (Pragma SourceContext) pragmaExprLookup = autoPragma "ExprLookup" $ Right parseAt where   parseAt c = do     name <- sourceParser     return $ PragmaExprLookup [c] name -pragmaSourceContext :: CompileErrorM m => ParserE m (Pragma SourcePos)+pragmaSourceContext :: TextParser (Pragma SourceContext) pragmaSourceContext = autoPragma "SourceContext" $ Left parseAt where   parseAt c = PragmaSourceContext c -pragmaNoTrace :: CompileErrorM m => ParserE m (Pragma SourcePos)+pragmaNoTrace :: TextParser (Pragma SourceContext) pragmaNoTrace = autoPragma "NoTrace" $ Left parseAt where   parseAt c = PragmaTracing [c] NoTrace -pragmaTraceCreation :: CompileErrorM m => ParserE m (Pragma SourcePos)+pragmaTraceCreation :: TextParser (Pragma SourceContext) pragmaTraceCreation = autoPragma "TraceCreation" $ Left parseAt where   parseAt c = PragmaTracing [c] TraceCreation -pragmaTestsOnly :: CompileErrorM m => ParserE m (Pragma SourcePos)+pragmaTestsOnly :: TextParser (Pragma SourceContext) pragmaTestsOnly = autoPragma "TestsOnly" $ Left parseAt where   parseAt c = PragmaVisibility [c] TestsOnly -pragmaComment :: CompileErrorM m => ParserE m (Pragma SourcePos)+pragmaComment :: TextParser (Pragma SourceContext) pragmaComment = autoPragma "Comment" $ Right parseAt where   parseAt c = do     string_ "\""@@ -81,27 +79,26 @@     optionalSpace     return $ PragmaComment [c] ss -unknownPragma :: CompileErrorM m => ParserE m a+unknownPragma :: TextParser a unknownPragma = do-  c <- getPosition   try pragmaStart-  p <- many1 alphaNum-  parseErrorM c $ "pragma " ++ p ++ " is not supported in this context"+  p <- some alphaNumChar+  compilerErrorM $ "pragma " ++ p ++ " is not supported in this context" -autoPragma :: CompileErrorM m => String -> Either (SourcePos -> a) (SourcePos -> ParserE m a) -> ParserE m a+autoPragma :: String -> Either (SourceContext -> a) (SourceContext -> TextParser a) -> TextParser a autoPragma p f = do-  c <- getPosition-  try $ pragmaStart >> string_ p >> notFollowedBy alphaNum+  c <- getSourceContext+  try $ pragmaStart >> string_ p >> notFollowedBy alphaNumChar   hasArgs <- (pragmaArgsStart >> optionalSpace >> return True) <|> return False   x <- delegate hasArgs f c   if hasArgs      then do-       extra <- manyTill anyChar (string_ "]$")-       when (not $ null extra) $ parseErrorM c $ "content unused by pragma " ++ p ++ ": " ++ extra+       extra <- manyTill asciiChar (string_ "]$")+       when (not $ null extra) $ compilerErrorM $ "content unused by pragma " ++ p ++ ": " ++ extra        optionalSpace      else sepAfter pragmaEnd   return x where     delegate False (Left f2)  c = return $ f2 c     delegate True  (Right f2) c = f2 c-    delegate _     (Left _)   c = parseErrorM c $ "pragma " ++ p ++ " does not allow arguments using []"-    delegate _     (Right _)  c = parseErrorM c $ "pragma " ++ p ++ " requires arguments using []"+    delegate _     (Left _)   _ = compilerErrorM $ "pragma " ++ p ++ " does not allow arguments using []"+    delegate _     (Right _)  _ = compilerErrorM $ "pragma " ++ p ++ " requires arguments using []"

@@ -18,42 +18,40 @@  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}  module Parser.Procedure ( ) where -import Control.Applicative (empty)-import Text.Parsec import qualified Data.Set as Set -import Base.CompileError+import Base.CompilerError+import Base.Positional import Parser.Common import Parser.Pragma+import Parser.TextParser import Parser.TypeCategory () import Parser.TypeInstance ()-import Types.Positional import Types.Pragma import Types.Procedure import Types.TypeCategory  -instance ParseFromSource (ExecutableProcedure SourcePos) where+instance ParseFromSource (ExecutableProcedure SourceContext) where   sourceParser = labeled "executable procedure" $ do-    c <- getPosition+    c <- getSourceContext     n <- try sourceParser     as <- sourceParser     rs <- sourceParser     sepAfter (string_ "{")     pragmas <- parsePragmas [pragmaNoTrace,pragmaTraceCreation]     pp <- sourceParser-    c2 <- getPosition+    c2 <- getSourceContext     sepAfter (string_ "}")     return $ ExecutableProcedure [c] pragmas [c2] n as rs pp -instance ParseFromSource (TestProcedure SourcePos) where+instance ParseFromSource (TestProcedure SourceContext) where   sourceParser = labeled "test procedure" $ do-    c <- getPosition+    c <- getSourceContext     kwUnittest     n <- try sourceParser     sepAfter (string_ "{")@@ -61,58 +59,58 @@     sepAfter (string_ "}")     return $ TestProcedure [c] n pp -instance ParseFromSource (ArgValues SourcePos) where+instance ParseFromSource (ArgValues SourceContext) where   sourceParser = labeled "procedure arguments" $ do-    c <- getPosition+    c <- getSourceContext     as <- between (sepAfter $ string_ "(")                   (sepAfter $ string_ ")")                   (sepBy sourceParser (sepAfter $ string_ ","))     return $ ArgValues [c] (Positional as) -instance ParseFromSource (ReturnValues SourcePos) where+instance ParseFromSource (ReturnValues SourceContext) where   sourceParser = labeled "procedure returns" $ namedReturns <|> unnamedReturns where     namedReturns = do-      c <- getPosition+      c <- getSourceContext       rs <- between (sepAfter $ string_ "(")                     (sepAfter $ string_ ")")                     (sepBy sourceParser (sepAfter $ string_ ","))       return $ NamedReturns [c] (Positional rs)     unnamedReturns = do-      c <- getPosition+      c <- getSourceContext       notFollowedBy (string_ "(")       return $ UnnamedReturns [c]  instance ParseFromSource VariableName where   sourceParser = labeled "variable name" $ do     noKeywords-    b <- lower-    e <- sepAfter $ many alphaNum+    b <- lowerChar+    e <- sepAfter $ many alphaNumChar     return $ VariableName (b:e) -instance ParseFromSource (InputValue SourcePos) where+instance ParseFromSource (InputValue SourceContext) where   sourceParser = labeled "input variable" $ variable <|> discard where     variable = do-      c <- getPosition+      c <- getSourceContext       v <- sourceParser       return $ InputValue [c] v     discard = do-      c <- getPosition+      c <- getSourceContext       sepAfter (string_ "_")       return $ DiscardInput [c] -instance ParseFromSource (OutputValue SourcePos) where+instance ParseFromSource (OutputValue SourceContext) where   sourceParser = labeled "output variable" $ do-    c <- getPosition+    c <- getSourceContext     v <- sourceParser     return $ OutputValue [c] v -instance ParseFromSource (Procedure SourcePos) where+instance ParseFromSource (Procedure SourceContext) where   sourceParser = labeled "procedure" $ do-    c <- getPosition+    c <- getSourceContext     rs <- sepBy sourceParser optionalSpace     return $ Procedure [c] rs -instance ParseFromSource (Statement SourcePos) where+instance ParseFromSource (Statement SourceContext) where   sourceParser = parseReturn <|>                  parseBreak <|>                  parseContinue <|>@@ -121,56 +119,56 @@                  parseAssign <|>                  parseIgnore where     parseAssign = labeled "statement" $ do-      c <- getPosition+      c <- getSourceContext       as <- sepBy sourceParser (sepAfter $ string_ ",")       assignOperator       e <- sourceParser       statementEnd       return $ Assignment [c] (Positional as) e     parseBreak = labeled "break" $ do-      c <- getPosition-      try kwBreak+      c <- getSourceContext+      kwBreak       return $ LoopBreak [c]     parseContinue = labeled "continue" $ do-      c <- getPosition-      try kwContinue+      c <- getSourceContext+      kwContinue       return $ LoopContinue [c]     parseFailCall = do-      c <- getPosition-      try kwFail+      c <- getSourceContext+      kwFail       e <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser       return $ FailCall [c] e     parseIgnore = do-      c <- getPosition+      c <- getSourceContext       statementStart       e <- sourceParser       statementEnd       return $ IgnoreValues [c] e     parseReturn = labeled "return" $ do-      c <- getPosition-      try kwReturn+      c <- getSourceContext+      kwReturn       emptyReturn c <|> multiReturn c-    multiReturn :: CompileErrorM m => SourcePos -> ParserE m (Statement SourcePos)+    multiReturn :: SourceContext -> TextParser (Statement SourceContext)     multiReturn c = do       rs <- sepBy sourceParser (sepAfter $ string_ ",")       statementEnd       return $ ExplicitReturn [c] (Positional rs)-    emptyReturn :: CompileErrorM m => SourcePos -> ParserE m (Statement SourcePos)+    emptyReturn :: SourceContext -> TextParser (Statement SourceContext)     emptyReturn c = do       kwIgnore       statementEnd       return $ EmptyReturn [c]     parseVoid = do-      c <- getPosition+      c <- getSourceContext       e <- sourceParser       return $ NoValueExpression [c] e -instance ParseFromSource (Assignable SourcePos) where+instance ParseFromSource (Assignable SourceContext) where   sourceParser = existing <|> create where     create = labeled "variable creation" $ do       t <- sourceParser       strayFuncCall <|> return ()-      c <- getPosition+      c <- getSourceContext       n <- sourceParser       return $ CreateVariable [c] t n     existing = labeled "variable name" $ do@@ -178,11 +176,10 @@       strayFuncCall <|> return ()       return $ ExistingVariable n     strayFuncCall = do-      c <- getPosition       valueSymbolGet <|> typeSymbolGet <|> categorySymbolGet-      parseErrorM c "function returns must be explicitly handled"+      compilerErrorM "function returns must be explicitly handled" -instance ParseFromSource (VoidExpression SourcePos) where+instance ParseFromSource (VoidExpression SourceContext) where   sourceParser = conditional <|> loop <|> scoped where     conditional = do       e <- sourceParser@@ -194,10 +191,10 @@       e <- sourceParser       return $ WithScope e -instance ParseFromSource (IfElifElse SourcePos) where+instance ParseFromSource (IfElifElse SourceContext) where   sourceParser = labeled "if-elif-else" $ do-    c <- getPosition-    try kwIf >> parseIf c+    c <- getSourceContext+    kwIf >> parseIf c     where       parseIf c = do         i <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser@@ -205,54 +202,56 @@         next <- parseElif <|> parseElse <|> return TerminateConditional         return $ IfStatement [c] i p next       parseElif = do-        c <- getPosition-        try kwElif >> parseIf c+        c <- getSourceContext+        kwElif >> parseIf c       parseElse = do-        c <- getPosition-        try kwElse+        c <- getSourceContext+        kwElse         p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser         return $ ElseStatement [c] p -instance ParseFromSource (WhileLoop SourcePos) where+instance ParseFromSource (WhileLoop SourceContext) where   sourceParser = labeled "while" $ do-    c <- getPosition-    try kwWhile+    c <- getSourceContext+    kwWhile     i <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser     p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser     u <- fmap Just parseUpdate <|> return Nothing     return $ WhileLoop [c] i p u     where       parseUpdate = do-        try kwUpdate+        kwUpdate         between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser -instance ParseFromSource (ScopedBlock SourcePos) where+instance ParseFromSource (ScopedBlock SourceContext) where   sourceParser = scoped <|> justCleanup where     scoped = labeled "scoped" $ do-      c <- getPosition-      try kwScoped+      c <- getSourceContext+      kwScoped       p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser       cl <- fmap Just parseCleanup <|> return Nothing       kwIn+      c2 <- getSourceContext       -- TODO: If there's a parse error in an otherwise-valid {} then the actual       -- error might look like a multi-assignment issue.       s <- unconditional <|> sourceParser-      return $ ScopedBlock [c] p cl s+      return $ ScopedBlock [c] p cl [c2] s     justCleanup = do-      c <- getPosition+      c <- getSourceContext       cl <- parseCleanup       kwIn+      c2 <- getSourceContext       s <- sourceParser <|> unconditional-      return $ ScopedBlock [c] (Procedure [] []) (Just cl) s+      return $ ScopedBlock [c] (Procedure [] []) (Just cl) [c2] s     parseCleanup = do-      try kwCleanup+      kwCleanup       between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser     unconditional = do-      c <- getPosition+      c <- getSourceContext       p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser       return $ NoValueExpression [c] (Unconditional p) -unaryOperator :: Monad m => ParserE m (Operator c)+unaryOperator :: TextParser (Operator c) unaryOperator = op >>= return . NamedOperator where   op = labeled "unary operator" $ foldr (<|>) empty $ map (try . operator) ops   ops = logicalUnary ++ arithUnary ++ bitwiseUnary@@ -266,7 +265,7 @@ bitwiseUnary :: [String] bitwiseUnary = ["~"] -infixOperator :: Monad m => ParserE m (Operator c)+infixOperator :: TextParser (Operator c) infixOperator = op >>= return . NamedOperator where   op = labeled "binary operator" $ foldr (<|>) empty $ map (try . operator) ops   ops = compareInfix ++ logicalInfix ++ addInfix ++ subInfix ++ multInfix ++ bitwiseInfix ++ bitshiftInfix@@ -302,22 +301,22 @@     | o `Set.member` Set.fromList logicalInfix = 5   infixOrder _ = 3 -functionOperator :: CompileErrorM m => ParserE m (Operator SourcePos)+functionOperator :: TextParser (Operator SourceContext) functionOperator = do-  c <- getPosition+  c <- getSourceContext   infixFuncStart   q <- sourceParser   infixFuncEnd   return $ FunctionOperator [c] q -instance ParseFromSource (Expression SourcePos) where+instance ParseFromSource (Expression SourceContext) where   sourceParser = do     e <- notInfix     asInfix [e] [] <|> return e     where       notInfix = literal <|> unary <|> initalize <|> expression       asInfix es os = do-        c <- getPosition+        c <- getSourceContext         o <- infixOperator <|> functionOperator         e2 <- notInfix         let es' = es ++ [e2]@@ -336,24 +335,24 @@         l <- sourceParser         return $ Literal l       unary = do-        c <- getPosition+        c <- getSourceContext         o <- unaryOperator <|> functionOperator         e <- notInfix         return $ UnaryExpression [c] o e       expression = labeled "expression" $ do-        c <- getPosition+        c <- getSourceContext         s <- sourceParser         vs <- many sourceParser         return $ Expression [c] s vs       initalize = do-        c <- getPosition+        c <- getSourceContext         t <- try $ do  -- Avoids consuming the type name if { isn't present.           t2 <- sourceParser           sepAfter (labeled "@value initializer" $ string_ "{")           return t2         withParams c t <|> withoutParams c t       withParams c t = do-        try kwTypes+        kwTypes         ps <- between (sepAfter $ string_ "<")                       (sepAfter $ string_ ">")                       (sepBy sourceParser (sepAfter $ string_ ","))@@ -365,31 +364,31 @@         sepAfter (string_ "}")         return $ InitializeValue [c] t (Positional []) (Positional as) -instance ParseFromSource (FunctionQualifier SourcePos) where+instance ParseFromSource (FunctionQualifier SourceContext) where   -- TODO: This is probably better done iteratively.   sourceParser = valueFunc <|> categoryFunc <|> typeFunc where     valueFunc = do-      c <- getPosition+      c <- getSourceContext       q <- try sourceParser       valueSymbolGet       return $ ValueFunction [c] q     categoryFunc = do-      c <- getPosition+      c <- getSourceContext       q <- try $ do  -- Avoids consuming the type name if : isn't present.         q2 <- sourceParser         categorySymbolGet         return q2       return $ CategoryFunction [c] q     typeFunc = do-      c <- getPosition+      c <- getSourceContext       q <- try sourceParser       typeSymbolGet       return $ TypeFunction [c] q -instance ParseFromSource (FunctionSpec SourcePos) where+instance ParseFromSource (FunctionSpec SourceContext) where   sourceParser = try qualified <|> unqualified where     qualified = do-      c <- getPosition+      c <- getSourceContext       q <- sourceParser       n <- sourceParser       ps <- try $ between (sepAfter $ string_ "<")@@ -397,25 +396,25 @@                           (sepBy sourceParser (sepAfter $ string_ ",")) <|> return []       return $ FunctionSpec [c] q n (Positional ps)     unqualified = do-      c <- getPosition+      c <- getSourceContext       n <- sourceParser       ps <- try $ between (sepAfter $ string_ "<")                           (sepAfter $ string_ ">")                           (sepBy sourceParser (sepAfter $ string_ ",")) <|> return []       return $ FunctionSpec [c] UnqualifiedFunction n (Positional ps) -instance ParseFromSource (InstanceOrInferred SourcePos) where+instance ParseFromSource (InstanceOrInferred SourceContext) where   sourceParser = assigned <|> inferred where     assigned = do-      c <- getPosition+      c <- getSourceContext       t <- sourceParser       return $ AssignedInstance [c] t     inferred = do-      c <- getPosition+      c <- getSourceContext       sepAfter_ inferredParam       return $ InferredInstance [c] -parseFunctionCall :: CompileErrorM m => SourcePos -> FunctionName -> ParserE m (FunctionCall SourcePos)+parseFunctionCall :: SourceContext -> FunctionName -> TextParser (FunctionCall SourceContext) parseFunctionCall c n = do   -- NOTE: try is needed here so that < operators work when the left side is   -- just a variable name, e.g., x < y.@@ -427,7 +426,7 @@                 (sepBy sourceParser (sepAfter $ string_ ","))   return $ FunctionCall [c] n (Positional ps) (Positional es) -builtinFunction :: Monad m => ParserE m FunctionName+builtinFunction :: TextParser FunctionName builtinFunction = foldr (<|>) empty $ map try [     kwPresent >> return BuiltinPresent,     kwReduce >> return BuiltinReduce,@@ -436,7 +435,7 @@     kwTypename >> return BuiltinTypename   ] -instance ParseFromSource (ExpressionStart SourcePos) where+instance ParseFromSource (ExpressionStart SourceContext) where   sourceParser = labeled "expression start" $                  parens <|>                  variableOrUnqualified <|>@@ -447,28 +446,28 @@                  categoryCall <|>                  typeCall where     parens = do-      c <- getPosition+      c <- getSourceContext       sepAfter (string_ "(")       e <- try (assign c) <|> expr c       sepAfter (string_ ")")       return e-    assign :: CompileErrorM m => SourcePos -> ParserE m (ExpressionStart SourcePos)+    assign :: SourceContext -> TextParser (ExpressionStart SourceContext)     assign c = do       n <- sourceParser       assignOperator       e <- sourceParser       return $ InlineAssignment [c] n e-    expr :: CompileErrorM m => SourcePos -> ParserE m (ExpressionStart SourcePos)+    expr :: SourceContext -> TextParser (ExpressionStart SourceContext)     expr c = do       e <- sourceParser       return $ ParensExpression [c] e     builtinCall = do-      c <- getPosition+      c <- getSourceContext       n <- builtinFunction       f <- parseFunctionCall c n       return $ BuiltinCall [c] f     builtinValue = do-      c <- getPosition+      c <- getSourceContext       n <- builtinValues       return $ NamedVariable (OutputValue [c] (VariableName n))     sourceContext = do@@ -482,8 +481,8 @@            (PragmaExprLookup c name) -> return $ NamedMacro c name            _ -> undefined  -- Should be caught above.     variableOrUnqualified = do-      c <- getPosition-      n <- sourceParser :: CompileErrorM m => ParserE m VariableName+      c <- getSourceContext+      n <- sourceParser :: TextParser VariableName       asUnqualifiedCall c n <|> asVariable c n     asVariable c n = do       return $ NamedVariable (OutputValue [c] n)@@ -491,7 +490,7 @@       f <- parseFunctionCall c (FunctionName (vnName n))       return $ UnqualifiedCall [c] f     categoryCall = do-      c <- getPosition+      c <- getSourceContext       t <- try $ do  -- Avoids consuming the type name if : isn't present.         t2 <- sourceParser         categorySymbolGet@@ -500,14 +499,14 @@       f <- parseFunctionCall c n       return $ CategoryCall [c] t f     typeCall = do-      c <- getPosition+      c <- getSourceContext       t <- try sourceParser       typeSymbolGet       n <- sourceParser       f <- parseFunctionCall c n       return $ TypeCall [c] t f -instance ParseFromSource (ValueLiteral SourcePos) where+instance ParseFromSource (ValueLiteral SourceContext) where   sourceParser = labeled "literal" $                  stringLiteral <|>                  charLiteral <|>@@ -516,19 +515,19 @@                  boolLiteral <|>                  emptyLiteral where     stringLiteral = do-      c <- getPosition+      c <- getSourceContext       ss <- quotedString       optionalSpace       return $ StringLiteral [c] ss     charLiteral = do-      c <- getPosition+      c <- getSourceContext       string_ "'"       ch <- stringChar <|> char '"'       string_ "'"       optionalSpace       return $ CharLiteral [c] ch     escapedInteger = do-      c <- getPosition+      c <- getSourceContext       escapeStart       b <- oneOf "bBoOdDxX"       d <- case b of@@ -544,7 +543,7 @@       optionalSpace       return $ IntegerLiteral [c] True d     integerOrDecimal = do-      c <- getPosition+      c <- getSourceContext       d <- parseDec       decimal c d <|> integer c d     decimal c d = do@@ -562,24 +561,24 @@       optionalSpace       return $ IntegerLiteral [c] False d     boolLiteral = do-      c <- getPosition+      c <- getSourceContext       b <- try $ (kwTrue >> return True) <|> (kwFalse >> return False)       return $ BoolLiteral [c] b     emptyLiteral = do-      c <- getPosition-      try kwEmpty+      c <- getSourceContext+      kwEmpty       return $ EmptyLiteral [c] -instance ParseFromSource (ValueOperation SourcePos) where+instance ParseFromSource (ValueOperation SourceContext) where   sourceParser = try valueCall <|> try conversion where     valueCall = labeled "function call" $ do-      c <- getPosition+      c <- getSourceContext       valueSymbolGet       n <- sourceParser       f <- parseFunctionCall c n       return $ ValueCall [c] f     conversion = labeled "type conversion" $ do-      c <- getPosition+      c <- getSourceContext       valueSymbolGet       t <- sourceParser -- NOTE: Should not need try here.       typeSymbolGet

@@ -16,21 +16,18 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-}- module Parser.SourceFile (   parseInternalSource,   parsePublicSource,   parseTestSource, ) where -import Text.Parsec--import Base.CompileError+import Base.CompilerError import Parser.Common import Parser.DefinedCategory () import Parser.IntegrationTest () import Parser.Pragma+import Parser.TextParser import Parser.TypeCategory () import Types.DefinedCategory import Types.IntegrationTest@@ -38,36 +35,36 @@ import Types.TypeCategory  -parseInternalSource :: CompileErrorM m =>-  (FilePath,String) -> m ([Pragma SourcePos],[AnyCategory SourcePos],[DefinedCategory SourcePos])-parseInternalSource (f,s) = runParserE (between optionalSpace endOfDoc withPragmas) f s where+parseInternalSource :: ErrorContextM m =>+  (FilePath,String) -> m ([Pragma SourceContext],[AnyCategory SourceContext],[DefinedCategory SourceContext])+parseInternalSource (f,s) = runTextParser (between optionalSpace endOfDoc withPragmas) f s where   withPragmas = do     pragmas <- parsePragmas internalSourcePragmas     optionalSpace     (cs,ds) <- parseAny2 sourceParser sourceParser     return (pragmas,cs,ds) -parsePublicSource :: CompileErrorM m => (FilePath,String) -> m ([Pragma SourcePos],[AnyCategory SourcePos])-parsePublicSource (f,s) = runParserE (between optionalSpace endOfDoc withPragmas) f s where+parsePublicSource :: ErrorContextM m => (FilePath,String) -> m ([Pragma SourceContext],[AnyCategory SourceContext])+parsePublicSource (f,s) = runTextParser (between optionalSpace endOfDoc withPragmas) f s where   withPragmas = do     pragmas <- parsePragmas publicSourcePragmas     optionalSpace     cs <- sepBy sourceParser optionalSpace     return (pragmas,cs) -parseTestSource :: CompileErrorM m => (FilePath,String) -> m ([Pragma SourcePos],[IntegrationTest SourcePos])-parseTestSource (f,s) = runParserE (between optionalSpace endOfDoc withPragmas) f s where+parseTestSource :: ErrorContextM m => (FilePath,String) -> m ([Pragma SourceContext],[IntegrationTest SourceContext])+parseTestSource (f,s) = runTextParser (between optionalSpace endOfDoc withPragmas) f s where   withPragmas = do     pragmas <- parsePragmas testSourcePragmas     optionalSpace     ts <- sepBy sourceParser optionalSpace     return (pragmas,ts) -publicSourcePragmas :: CompileErrorM m => [ParserE m (Pragma SourcePos)]+publicSourcePragmas :: [TextParser (Pragma SourceContext)] publicSourcePragmas = [pragmaModuleOnly,pragmaTestsOnly] -internalSourcePragmas :: CompileErrorM m => [ParserE m (Pragma SourcePos)]+internalSourcePragmas :: [TextParser (Pragma SourceContext)] internalSourcePragmas = [pragmaTestsOnly] -testSourcePragmas :: CompileErrorM m => [ParserE m (Pragma SourcePos)]+testSourcePragmas :: [TextParser (Pragma SourceContext)] testSourcePragmas = []

@@ -0,0 +1,70 @@+{- -----------------------------------------------------------------------------+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 FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- Older versions of Text.Megaparsec are Unsafe. This makes sure that the+-- compiler catches imports into Safe sources when a newer version is used.+{-# LANGUAGE Unsafe #-}++module Parser.TextParser (+  module Text.Megaparsec,+  module Text.Megaparsec.Char,+  SourceContext,+  TextParser,+  getSourceContext,+  runTextParser,+) where++import Data.Char (isSpace)+import Data.List (dropWhileEnd)+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Data.Set as Set++import Base.CompilerError+import Base.CompilerMessage+++type TextParser = Parsec CompilerMessage String++instance ErrorContextM TextParser where+  compilerErrorM = customFailure . compilerMessage+  withContextM     x e = region (mapParseError (pushErrorScope e) . promoteError) x+  summarizeErrorsM x e = region (mapParseError (pushErrorScope e) . promoteError) x++instance ShowErrorComponent CompilerMessage where+  showErrorComponent = show++runTextParser :: ErrorContextM m => TextParser a -> String -> String -> m a+runTextParser p n s = case parse p n s of+                           Left e  -> compilerErrorM $ dropWhileEnd isSpace $ errorBundlePretty e+                           Right x -> return x++newtype SourceContext = SourceContext SourcePos deriving (Eq,Ord)++instance Show SourceContext where+  show (SourceContext (SourcePos f l c)) =+    "line " ++ show (unPos l) ++ " column " ++ show (unPos c) ++ " of " ++ "\"" ++ f ++ "\""++getSourceContext :: TextParser SourceContext+getSourceContext = fmap SourceContext getSourcePos++promoteError :: ParseError String CompilerMessage -> ParseError String CompilerMessage+promoteError e@(TrivialError i _ _) = FancyError i $ Set.fromList [ErrorCustom $ compilerMessage $ parseErrorTextPretty e]+promoteError e = e

@@ -17,7 +17,6 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}  module Parser.TypeCategory (   parseFilters,@@ -28,23 +27,21 @@   singleRefine, ) where -import Text.Parsec--import Base.CompileError+import Base.Positional import Parser.Common+import Parser.TextParser import Parser.TypeInstance ()-import Types.Positional import Types.TypeCategory import Types.TypeInstance import Types.Variance  -instance ParseFromSource (AnyCategory SourcePos) where+instance ParseFromSource (AnyCategory SourceContext) where   sourceParser = parseValue <|> parseInstance <|> parseConcrete where     open = sepAfter (string_ "{")     close = sepAfter (string_ "}")     parseValue = labeled "value interface" $ do-      c <- getPosition+      c <- getSourceContext       try $ kwValue >> kwInterface       n <- sourceParser       ps <- parseCategoryParams@@ -54,7 +51,7 @@       close       return $ ValueInterface [c] NoNamespace n ps rs vs fs     parseInstance = labeled "type interface" $ do-      c <- getPosition+      c <- getSourceContext       try $ kwType >> kwInterface       n <- sourceParser       ps <- parseCategoryParams@@ -64,8 +61,8 @@       close       return $ InstanceInterface [c] NoNamespace n ps vs fs     parseConcrete = labeled "concrete type" $ do-      c <- getPosition-      try kwConcrete+      c <- getSourceContext+      kwConcrete       n <- sourceParser       ps <- parseCategoryParams       open@@ -74,7 +71,7 @@       close       return $ ValueConcrete [c] NoNamespace n ps rs ds vs fs -parseCategoryParams :: CompileErrorM m => ParserE m [ValueParam SourcePos]+parseCategoryParams :: TextParser [ValueParam SourceContext] parseCategoryParams = do   (con,inv,cov) <- none <|> try fixedOnly <|> try noFixed <|> try explicitFixed   return $ map (apply Contravariant) con ++@@ -109,45 +106,45 @@                      (sepBy singleParam (sepAfter $ string_ ","))       return (con,inv,cov)     singleParam = labeled "param declaration" $ do-      c <- getPosition+      c <- getSourceContext       n <- sourceParser       return (c,n)     apply v (c,n) = ValueParam [c] n v -singleRefine :: CompileErrorM m => ParserE m (ValueRefine SourcePos)+singleRefine :: TextParser (ValueRefine SourceContext) singleRefine = do-  c <- getPosition-  try kwRefines+  c <- getSourceContext+  kwRefines   t <- sourceParser   return $ ValueRefine [c] t -singleDefine :: CompileErrorM m => ParserE m (ValueDefine SourcePos)+singleDefine :: TextParser (ValueDefine SourceContext) singleDefine = do-  c <- getPosition-  try kwDefines+  c <- getSourceContext+  kwDefines   t <- sourceParser   return $ ValueDefine [c] t -singleFilter :: CompileErrorM m => ParserE m (ParamFilter SourcePos)+singleFilter :: TextParser (ParamFilter SourceContext) singleFilter = try $ do-  c <- getPosition+  c <- getSourceContext   n <- sourceParser   f <- sourceParser   return $ ParamFilter [c] n f -parseCategoryRefines :: CompileErrorM m => ParserE m [ValueRefine SourcePos]+parseCategoryRefines :: TextParser [ValueRefine SourceContext] parseCategoryRefines = sepAfter $ sepBy singleRefine optionalSpace -parseFilters :: CompileErrorM m => ParserE m [ParamFilter SourcePos]+parseFilters :: TextParser [ParamFilter SourceContext] parseFilters = sepBy singleFilter optionalSpace -parseRefinesFilters :: CompileErrorM m => ParserE m ([ValueRefine SourcePos],[ParamFilter SourcePos])+parseRefinesFilters :: TextParser ([ValueRefine SourceContext],[ParamFilter SourceContext]) parseRefinesFilters = parsed >>= return . merge2 where   parsed = sepBy anyType optionalSpace   anyType = labeled "refine or param filter" $ put12 singleRefine <|> put22 singleFilter -parseRefinesDefinesFilters :: CompileErrorM m =>-  ParserE m ([ValueRefine SourcePos],[ValueDefine SourcePos],[ParamFilter SourcePos])+parseRefinesDefinesFilters ::+  TextParser ([ValueRefine SourceContext],[ValueDefine SourceContext],[ParamFilter SourceContext]) parseRefinesDefinesFilters = parsed >>= return . merge3 where   parsed = sepBy anyType optionalSpace   anyType =@@ -156,14 +153,14 @@ instance ParseFromSource FunctionName where   sourceParser = labeled "function name" $ do     noKeywords-    b <- lower-    e <- sepAfter $ many alphaNum+    b <- lowerChar+    e <- sepAfter $ many alphaNumChar     return $ FunctionName (b:e) -parseScopedFunction :: CompileErrorM m =>-  ParserE m SymbolScope -> ParserE m CategoryName -> ParserE m (ScopedFunction SourcePos)+parseScopedFunction ::+  TextParser SymbolScope -> TextParser CategoryName -> TextParser (ScopedFunction SourceContext) parseScopedFunction sp tp = labeled "function" $ do-  c <- getPosition+  c <- getSourceContext   (s,t,n) <- try parseName   ps <- fmap Positional $ noParams <|> someParams   fa <- parseFilters@@ -182,25 +179,25 @@                          (sepAfter $ string_ ">")                          (sepBy singleParam (sepAfter $ string ","))     singleParam = labeled "param declaration" $ do-      c <- getPosition+      c <- getSourceContext       n <- sourceParser       return $ ValueParam [c] n Invariant     typeList l = between (sepAfter $ string_ "(")                          (sepAfter $ string_ ")")                          (sepBy (labeled l $ singleType) (sepAfter $ string ","))     singleType = do-      c <- getPosition+      c <- getSourceContext       t <- sourceParser       return $ PassedValue [c] t -parseScope :: Monad m => ParserE m SymbolScope+parseScope :: TextParser SymbolScope parseScope = try categoryScope <|> try typeScope <|> valueScope -categoryScope :: Monad m => ParserE m SymbolScope+categoryScope :: TextParser SymbolScope categoryScope = kwCategory >> return CategoryScope -typeScope :: Monad m => ParserE m SymbolScope+typeScope :: TextParser SymbolScope typeScope = kwType >> return TypeScope -valueScope :: Monad m => ParserE m SymbolScope+valueScope :: TextParser SymbolScope valueScope = kwValue >> return ValueScope

@@ -17,23 +17,22 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}  module Parser.TypeInstance ( ) where  import Control.Applicative ((<|>))-import Text.Parsec hiding ((<|>)) +import Base.GeneralType import Base.Mergeable (mergeAll,mergeAny)+import Base.Positional import Parser.Common-import Types.GeneralType-import Types.Positional+import Parser.TextParser hiding ((<|>),single) import Types.TypeInstance   instance ParseFromSource GeneralInstance where-  sourceParser = try allT <|> try anyT <|> intersectOrUnion <|> single where+  sourceParser = single <|> allT <|> anyT <|> intersectOrUnion where     allT = labeled "all" $ do       kwAll       return minBound@@ -42,19 +41,17 @@       return maxBound     intersectOrUnion = labeled "union or intersection" $ do       sepAfter $ string_ "["-      t1 <- labeled "type" $ sepAfter sourceParser+      t1 <- labeled "type" $ sourceParser       t <- intersect t1 <|> union t1       sepAfter $ string_ "]"       return t     intersect t1 = do-      ts <- many1 (sepAfter (string_ "&") >> labeled "type" sourceParser)+      ts <- some (sepAfter (string_ "&") >> labeled "type" sourceParser)       return $ mergeAll (t1:ts)     union t1 = do-      ts <- many1 (sepAfter (string_ "|") >> labeled "type" sourceParser)+      ts <- some (sepAfter (string_ "|") >> labeled "type" sourceParser)       return $ mergeAny (t1:ts)-    single = do-      t <- sourceParser-      return $ singleType t+    single = fmap singleType sourceParser  instance ParseFromSource ValueType where   sourceParser = do@@ -63,41 +60,41 @@     return $ ValueType r t     where       getWeak = labeled "weak" $ do-        try kwWeak+        kwWeak         return WeakValue       getOptional = labeled "optional" $ do-        try kwOptional+        kwOptional         return OptionalValue       getRequired = return RequiredValue  instance ParseFromSource CategoryName where   sourceParser = labeled "type name" $ do     noKeywords-    b <- upper-    e <- sepAfter $ many alphaNum+    b <- upperChar+    e <- sepAfter $ many alphaNumChar     return $ box (b:e)     where       box n-        | n == "Bool"         = BuiltinBool-        | n == "Char"         = BuiltinChar-        | n == "Int"          = BuiltinInt-        | n == "Float"        = BuiltinFloat-        | n == "String"       = BuiltinString-        | n == "Formatted"    = BuiltinFormatted+        | n == "Bool"      = BuiltinBool+        | n == "Char"      = BuiltinChar+        | n == "Int"       = BuiltinInt+        | n == "Float"     = BuiltinFloat+        | n == "String"    = BuiltinString+        | n == "Formatted" = BuiltinFormatted         | otherwise = CategoryName n  instance ParseFromSource ParamName where   sourceParser = labeled "param name" $ do     noKeywords     char_ '#'-    b <- lower-    e <- sepAfter $ many alphaNum+    b <- lowerChar+    e <- sepAfter $ many alphaNumChar     return $ ParamName ('#':b:e)  instance ParseFromSource TypeInstance where-  sourceParser = labeled "type" $ do+  sourceParser = labeled "type instance" $ do     n <- sourceParser-    as <- labeled "type args" $ try args <|> return []+    as <- labeled "type args" $ args <|> return []     return $ TypeInstance n (Positional as)     where       args = between (sepAfter $ string "<")@@ -105,9 +102,9 @@                      (sepBy sourceParser (sepAfter $ string ","))  instance ParseFromSource DefinesInstance where-  sourceParser = labeled "type" $ do+  sourceParser = labeled "type instance" $ do     n <- sourceParser-    as <- labeled "type args" $ try args <|> return []+    as <- labeled "type args" $ args <|> return []     return $ DefinesInstance n (Positional as)     where       args = between (sepAfter $ string "<")@@ -115,25 +112,21 @@                      (sepBy sourceParser (sepAfter $ string ","))  instance ParseFromSource TypeInstanceOrParam where-  sourceParser = try param <|> inst where-    param = labeled "param" $ do-      n <- sourceParser-      return $ JustParamName False n-    inst = labeled "type" $ do-      t <- sourceParser-      return $ JustTypeInstance t+  sourceParser = inst <|> param where+    param = labeled "param" $ fmap (JustParamName False) sourceParser+    inst = labeled "type instance" $ fmap JustTypeInstance sourceParser  instance ParseFromSource TypeFilter where   sourceParser = requires <|> allows <|> defines where     requires = labeled "requires filter" $ do-      try kwRequires+      kwRequires       t <- sourceParser       return $ TypeFilter FilterRequires $ singleType t     allows = labeled "allows filter" $ do-      try kwAllows+      kwAllows       t <- sourceParser       return $ TypeFilter FilterAllows $ singleType t     defines = labeled "defines filter" $ do-      try kwDefines+      kwDefines       t <- sourceParser       return $ DefinesFilter t

@@ -16,8 +16,6 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-}- module Test.Common (   checkDefinesFail,   checkDefinesSuccess,@@ -45,18 +43,19 @@ import System.Exit import System.FilePath import System.IO-import Text.Parsec import qualified Data.Map as Map import qualified Data.Set as Set -import Base.CompileError-import Base.CompileInfo+import Base.CompilerError+import Base.CompilerMessage+import Base.TrackedErrors import Parser.Common+import Parser.TextParser import Parser.TypeInstance () import Types.TypeInstance  -runAllTests :: [IO (CompileInfo ())] -> IO ()+runAllTests :: [IO (TrackedErrors ())] -> IO () runAllTests ts = do   results <- sequence ts   let (es,ps) = partitionEithers $ zipWith numberError ([1..] :: [Int]) results@@ -65,24 +64,24 @@                    show (length es) ++ " tests failed\n"   when (not $ null es) exitFailure -numberError :: a -> CompileInfo b -> Either (a,CompileMessage) b+numberError :: a -> TrackedErrors b -> Either (a,CompilerMessage) b numberError n c-  | isCompileError c = Left (n,getCompileError c)-  | otherwise        = Right (getCompileSuccess c)+  | isCompilerError c = Left (n,getCompilerError c)+  | otherwise        = Right (getCompilerSuccess c)  forceParse :: ParseFromSource a => String -> a-forceParse s = getCompileSuccess $ runParserE sourceParser "(string)" s+forceParse s = getCompilerSuccess $ runTextParser sourceParser "(string)" s -readSingle :: ParseFromSource a => String -> String -> CompileInfo a+readSingle :: ParseFromSource a => String -> String -> TrackedErrors a readSingle  = readSingleWith sourceParser -readSingleWith :: ParserE CompileInfo a -> String -> String -> CompileInfo a-readSingleWith p = runParserE (between nullParse endOfDoc p)+readSingleWith :: TextParser a -> String -> String -> TrackedErrors a+readSingleWith p = runTextParser (between nullParse endOfDoc p) -readMulti :: ParseFromSource a => String -> String -> CompileInfo [a]-readMulti f s = runParserE (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s+readMulti :: ParseFromSource a => String -> String -> TrackedErrors [a]+readMulti f s = runTextParser (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s -parseFilterMap :: [(String,[String])] -> CompileInfo ParamFilters+parseFilterMap :: [(String,[String])] -> TrackedErrors ParamFilters parseFilterMap pa = do   pa2 <- mapErrorsM parseFilters pa   return $ Map.fromList pa2@@ -91,7 +90,7 @@       fs2 <- mapErrorsM (readSingle "(string)") fs       return (ParamName n,fs2) -parseTheTest :: ParseFromSource a => [(String,[String])] -> [String] -> CompileInfo ([a],ParamFilters)+parseTheTest :: ParseFromSource a => [(String,[String])] -> [String] -> TrackedErrors ([a],ParamFilters) parseTheTest pa xs = do   ts <- mapErrorsM (readSingle "(string)") xs   pa2 <- parseFilterMap pa@@ -101,7 +100,7 @@ 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 -> TrackedErrors () checkTypeSuccess r pa x = do   ([t],pa2) <- parseTheTest pa [x]   check $ validateGeneralInstance r pa2 t@@ -109,18 +108,18 @@     prefix = x ++ " " ++ showParams pa     check x2 = x2 <!! prefix ++ ":" -checkTypeFail :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo ()+checkTypeFail :: TypeResolver r => r -> [(String,[String])] -> String -> TrackedErrors () checkTypeFail r pa x = do   ([t],pa2) <- parseTheTest pa [x]   check $ validateGeneralInstance r pa2 t   where     prefix = x ++ " " ++ showParams pa-    check :: CompileInfo a -> CompileInfo ()+    check :: TrackedErrors a -> TrackedErrors ()     check c-      | isCompileError c = return ()-      | otherwise = compileErrorM $ prefix ++ ": Expected failure\n"+      | isCompilerError c = return ()+      | otherwise = compilerErrorM $ prefix ++ ": Expected failure\n" -checkDefinesSuccess :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo ()+checkDefinesSuccess :: TypeResolver r => r -> [(String,[String])] -> String -> TrackedErrors () checkDefinesSuccess r pa x = do   ([t],pa2) <- parseTheTest pa [x]   check $ validateDefinesInstance r pa2 t@@ -128,32 +127,32 @@     prefix = x ++ " " ++ showParams pa     check x2 = x2 <!! prefix ++ ":" -checkDefinesFail :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo ()+checkDefinesFail :: TypeResolver r => r -> [(String,[String])] -> String -> TrackedErrors () checkDefinesFail r pa x = do   ([t],pa2) <- parseTheTest pa [x]   check $ validateDefinesInstance r pa2 t   where     prefix = x ++ " " ++ showParams pa-    check :: CompileInfo a -> CompileInfo ()+    check :: TrackedErrors a -> TrackedErrors ()     check c-      | isCompileError c = return ()-      | otherwise = compileErrorM $ prefix ++ ": Expected failure\n"+      | isCompilerError c = return ()+      | otherwise = compilerErrorM $ prefix ++ ": Expected failure\n" -containsExactly :: (Ord a, Show a) => [a] -> [a] -> CompileInfo ()+containsExactly :: (Ord a, Show a) => [a] -> [a] -> TrackedErrors () containsExactly actual expected = do   containsNoDuplicates actual   containsAtLeast actual expected   containsAtMost actual expected -containsNoDuplicates :: (Ord a, Show a) => [a] -> CompileInfo ()+containsNoDuplicates :: (Ord a, Show a) => [a] -> TrackedErrors () containsNoDuplicates expected =   (mapErrorsM_ checkSingle $ group $ sort expected) <!! show expected   where     checkSingle xa@(x:_:_) =-      compileErrorM $ "Item " ++ show x ++ " occurs " ++ show (length xa) ++ " times"+      compilerErrorM $ "Item " ++ show x ++ " occurs " ++ show (length xa) ++ " times"     checkSingle _ = return () -containsAtLeast :: (Ord a, Show a) => [a] -> [a] -> CompileInfo ()+containsAtLeast :: (Ord a, Show a) => [a] -> [a] -> TrackedErrors () containsAtLeast actual expected =   (mapErrorsM_ (checkInActual $ Set.fromList actual) expected) <!!         show actual ++ " (actual) vs. " ++ show expected ++ " (expected)"@@ -161,9 +160,9 @@     checkInActual va v =       if v `Set.member` va          then return ()-         else compileErrorM $ "Item " ++ show v ++ " was expected but not present"+         else compilerErrorM $ "Item " ++ show v ++ " was expected but not present" -containsAtMost :: (Ord a, Show a) => [a] -> [a] -> CompileInfo ()+containsAtMost :: (Ord a, Show a) => [a] -> [a] -> TrackedErrors () containsAtMost actual expected =   (mapErrorsM_ (checkInExpected $ Set.fromList expected) actual) <!!         show actual ++ " (actual) vs. " ++ show expected ++ " (expected)"@@ -171,12 +170,12 @@     checkInExpected va v =       if v `Set.member` va          then return ()-         else compileErrorM $ "Item " ++ show v ++ " is unexpected"+         else compilerErrorM $ "Item " ++ show v ++ " is unexpected" -checkEquals :: (Eq a, Show a) => a -> a -> CompileInfo ()+checkEquals :: (Eq a, Show a) => a -> a -> TrackedErrors () checkEquals actual expected   | actual == expected = return ()-  | otherwise = compileErrorM $ "Expected " ++ show expected ++ " but got " ++ show actual+  | otherwise = compilerErrorM $ "Expected " ++ show expected ++ " but got " ++ show actual  loadFile :: String -> IO String loadFile f = readFile ("src" </> "Test" </> f)