diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/base/category-source.hpp b/base/category-source.hpp --- a/base/category-source.hpp +++ b/base/category-source.hpp @@ -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 target); diff --git a/base/logging.hpp b/base/logging.hpp --- a/base/logging.hpp +++ b/base/logging.hpp @@ -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 diff --git a/base/types.hpp b/base/types.hpp --- a/base/types.hpp +++ b/base/types.hpp @@ -230,4 +230,22 @@ std::vector> 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_ diff --git a/bin/unit-tests.hs b/bin/unit-tests.hs --- a/bin/unit-tests.hs +++ b/bin/unit-tests.hs @@ -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 (> 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:" diff --git a/example/parser/.zeolite-module b/example/parser/.zeolite-module --- a/example/parser/.zeolite-module +++ b/example/parser/.zeolite-module @@ -5,5 +5,6 @@ ] private_deps: [ "lib/file" + "lib/testing" ] mode: incremental {} diff --git a/example/parser/README.md b/example/parser/README.md --- a/example/parser/README.md +++ b/example/parser/README.md @@ -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 diff --git a/example/parser/parser-test.0rt b/example/parser/parser-test.0rt --- a/example/parser/parser-test.0rt +++ b/example/parser/parser-test.0rt @@ -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 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) } diff --git a/example/parser/test-data.0rp b/example/parser/test-data.0rp --- a/example/parser/test-data.0rp +++ b/example/parser/test-data.0rp @@ -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) - @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) } diff --git a/example/parser/test-data.0rx b/example/parser/test-data.0rx --- a/example/parser/test-data.0rx +++ b/example/parser/test-data.0rx @@ -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) } define TestDataParser { diff --git a/lib/file/.zeolite-module b/lib/file/.zeolite-module --- a/lib/file/.zeolite-module +++ b/lib/file/.zeolite-module @@ -3,6 +3,9 @@ public_deps: [ "lib/util" ] +private_deps: [ + "lib/testing" +] extra_files: [ category_source { source: "file/Category_RawFileReader.cpp" diff --git a/lib/file/helpers.0rp b/lib/file/helpers.0rp new file mode 100644 --- /dev/null +++ b/lib/file/helpers.0rp @@ -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) +} diff --git a/lib/file/helpers.0rx b/lib/file/helpers.0rx new file mode 100644 --- /dev/null +++ b/lib/file/helpers.0rx @@ -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) + } +} diff --git a/lib/file/tests.0rt b/lib/file/tests.0rt --- a/lib/file/tests.0rt +++ b/lib/file/tests.0rt @@ -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 { diff --git a/src/Base/CompileError.hs b/src/Base/CompileError.hs deleted file mode 100644 --- a/src/Base/CompileError.hs +++ /dev/null @@ -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 - -( m a -> String -> m a -() :: CompileErrorM m => String -> m a -> m a -(??>) = flip withContextM -infixr 1 ??> - -( m a -> String -> m a -() :: 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 diff --git a/src/Base/CompileInfo.hs b/src/Base/CompileInfo.hs deleted file mode 100644 --- a/src/Base/CompileInfo.hs +++ /dev/null @@ -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' 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) diff --git a/src/Base/CompilerError.hs b/src/Base/CompilerError.hs new file mode 100644 --- /dev/null +++ b/src/Base/CompilerError.hs @@ -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 + +( m a -> String -> m a +() :: ErrorContextM m => String -> m a -> m a +(??>) = flip withContextM +infixr 1 ??> + +( m a -> String -> m a +() :: 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 diff --git a/src/Base/CompilerMessage.hs b/src/Base/CompilerMessage.hs new file mode 100644 --- /dev/null +++ b/src/Base/CompilerMessage.hs @@ -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 diff --git a/src/Base/GeneralType.hs b/src/Base/GeneralType.hs new file mode 100644 --- /dev/null +++ b/src/Base/GeneralType.hs @@ -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 .) diff --git a/src/Base/MergeTree.hs b/src/Base/MergeTree.hs --- a/src/Base/MergeTree.hs +++ b/src/Base/MergeTree.hs @@ -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 diff --git a/src/Base/Positional.hs b/src/Base/Positional.hs new file mode 100644 --- /dev/null +++ b/src/Base/Positional.hs @@ -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)" diff --git a/src/Base/TrackedErrors.hs b/src/Base/TrackedErrors.hs new file mode 100644 --- /dev/null +++ b/src/Base/TrackedErrors.hs @@ -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' 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) diff --git a/src/Cli/Compiler.hs b/src/Cli/Compiler.hs --- a/src/Cli/Compiler.hs +++ b/src/Cli/Compiler.hs @@ -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 diff --git a/src/Cli/ParseCompileOptions.hs b/src/Cli/ParseCompileOptions.hs --- a/src/Cli/ParseCompileOptions.hs +++ b/src/Cli/ParseCompileOptions.hs @@ -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 diff --git a/src/Cli/Programs.hs b/src/Cli/Programs.hs --- a/src/Cli/Programs.hs +++ b/src/Cli/Programs.hs @@ -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) diff --git a/src/Cli/RunCompiler.hs b/src/Cli/RunCompiler.hs --- a/src/Cli/RunCompiler.hs +++ b/src/Cli/RunCompiler.hs @@ -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) 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 { diff --git a/src/Cli/TestRunner.hs b/src/Cli/TestRunner.hs --- a/src/Cli/TestRunner.hs +++ b/src/Cli/TestRunner.hs @@ -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) - (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 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 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 diff --git a/src/Compilation/CompilerState.hs b/src/Compilation/CompilerState.hs --- a/src/Compilation/CompilerState.hs +++ b/src/Compilation/CompilerState.hs @@ -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 -( CompilerState a m b -> String -> CompilerState a m b -() :: CompileErrorM m => String -> CompilerState a m b -> CompilerState a m b -(???>) s x = mapStateT (s ??>) x -infixr 1 ???> - -( CompilerState a m b -> String -> CompilerState a m b -() :: 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 diff --git a/src/Compilation/ProcedureContext.hs b/src/Compilation/ProcedureContext.hs --- a/src/Compilation/ProcedureContext.hs +++ b/src/Compilation/ProcedureContext.hs @@ -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 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) (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 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)) +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) diff --git a/src/Compilation/ScopeContext.hs b/src/Compilation/ScopeContext.hs --- a/src/Compilation/ScopeContext.hs +++ b/src/Compilation/ScopeContext.hs @@ -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 diff --git a/src/CompilerCxx/Category.hs b/src/CompilerCxx/Category.hs --- a/src/CompilerCxx/Category.hs +++ b/src/CompilerCxx/Category.hs @@ -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 diff --git a/src/CompilerCxx/CategoryContext.hs b/src/CompilerCxx/CategoryContext.hs --- a/src/CompilerCxx/CategoryContext.hs +++ b/src/CompilerCxx/CategoryContext.hs @@ -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 diff --git a/src/CompilerCxx/Code.hs b/src/CompilerCxx/Code.hs --- a/src/CompilerCxx/Code.hs +++ b/src/CompilerCxx/Code.hs @@ -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 diff --git a/src/CompilerCxx/Procedure.hs b/src/CompilerCxx/Procedure.hs --- a/src/CompilerCxx/Procedure.hs +++ b/src/CompilerCxx/Procedure.hs @@ -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 [] > 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 $ 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) 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 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' 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) 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 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 +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>(" ++ 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) 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 (" " ++) diff --git a/src/Config/LoadConfig.hs b/src/Config/LoadConfig.hs --- a/src/Config/LoadConfig.hs +++ b/src/Config/LoadConfig.hs @@ -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 diff --git a/src/Config/LocalConfig.hs b/src/Config/LocalConfig.hs --- a/src/Config/LocalConfig.hs +++ b/src/Config/LocalConfig.hs @@ -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) diff --git a/src/Module/CompileMetadata.hs b/src/Module/CompileMetadata.hs --- a/src/Module/CompileMetadata.hs +++ b/src/Module/CompileMetadata.hs @@ -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], diff --git a/src/Module/ParseMetadata.hs b/src/Module/ParseMetadata.hs --- a/src/Module/ParseMetadata.hs +++ b/src/Module/ParseMetadata.hs @@ -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 diff --git a/src/Module/Paths.hs b/src/Module/Paths.hs --- a/src/Module/Paths.hs +++ b/src/Module/Paths.hs @@ -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 diff --git a/src/Module/ProcessMetadata.hs b/src/Module/ProcessMetadata.hs --- a/src/Module/ProcessMetadata.hs +++ b/src/Module/ProcessMetadata.hs @@ -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 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 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 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 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) 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 diff --git a/src/Parser/Common.hs b/src/Parser/Common.hs --- a/src/Parser/Common.hs +++ b/src/Parser/Common.hs @@ -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 diff --git a/src/Parser/DefinedCategory.hs b/src/Parser/DefinedCategory.hs --- a/src/Parser/DefinedCategory.hs +++ b/src/Parser/DefinedCategory.hs @@ -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" diff --git a/src/Parser/IntegrationTest.hs b/src/Parser/IntegrationTest.hs --- a/src/Parser/IntegrationTest.hs +++ b/src/Parser/IntegrationTest.hs @@ -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 diff --git a/src/Parser/Pragma.hs b/src/Parser/Pragma.hs --- a/src/Parser/Pragma.hs +++ b/src/Parser/Pragma.hs @@ -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 []" diff --git a/src/Parser/Procedure.hs b/src/Parser/Procedure.hs --- a/src/Parser/Procedure.hs +++ b/src/Parser/Procedure.hs @@ -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 diff --git a/src/Parser/SourceFile.hs b/src/Parser/SourceFile.hs --- a/src/Parser/SourceFile.hs +++ b/src/Parser/SourceFile.hs @@ -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 = [] diff --git a/src/Parser/TextParser.hs b/src/Parser/TextParser.hs new file mode 100644 --- /dev/null +++ b/src/Parser/TextParser.hs @@ -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 diff --git a/src/Parser/TypeCategory.hs b/src/Parser/TypeCategory.hs --- a/src/Parser/TypeCategory.hs +++ b/src/Parser/TypeCategory.hs @@ -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 diff --git a/src/Parser/TypeInstance.hs b/src/Parser/TypeInstance.hs --- a/src/Parser/TypeInstance.hs +++ b/src/Parser/TypeInstance.hs @@ -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 diff --git a/src/Test/Common.hs b/src/Test/Common.hs --- a/src/Test/Common.hs +++ b/src/Test/Common.hs @@ -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 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 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) [a] -> [a] -> CompileInfo () +containsAtLeast :: (Ord a, Show a) => [a] -> [a] -> TrackedErrors () containsAtLeast actual expected = (mapErrorsM_ (checkInActual $ Set.fromList actual) expected) [a] -> [a] -> CompileInfo () +containsAtMost :: (Ord a, Show a) => [a] -> [a] -> TrackedErrors () containsAtMost actual expected = (mapErrorsM_ (checkInExpected $ Set.fromList expected) actual) 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) diff --git a/src/Test/CompileInfo.hs b/src/Test/CompileInfo.hs deleted file mode 100644 --- a/src/Test/CompileInfo.hs +++ /dev/null @@ -1,120 +0,0 @@ -{- ----------------------------------------------------------------------------- -Copyright 2020 Kevin P. Barry - -Licensed under the Apache License, Version 2.0 (the "License"); -you may not use this file except in compliance with the License. -You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - -Unless required by applicable law or agreed to in writing, software -distributed under the License is distributed on an "AS IS" BASIS, -WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -See the License for the specific language governing permissions and -limitations under the License. ------------------------------------------------------------------------------ -} - --- Author: Kevin P. Barry [ta0kira@gmail.com] - -{-# LANGUAGE Safe #-} - -module Test.CompileInfo (tests) where - -import Base.CompileError -import Base.CompileInfo - - -tests :: [IO (CompileInfo ())] -tests = [ - checkSuccess 'a' (return 'a'), - checkError "error\n" (compileErrorM "error" :: CompileInfoIO Char), - checkError "" (compileErrorM "" :: CompileInfoIO Char), - - checkSuccess ['a','b'] (collectAllM [return 'a',return 'b']), - checkSuccess [] (collectAllM [] :: CompileInfoIO [Char]), - checkError "error1\nerror2\n" (collectAllM [compileErrorM "error1",return 'b',compileErrorM "error2"]), - - checkSuccess "ab" (collectAnyM [return 'a',return 'b']), - checkSuccess "" (collectAnyM [] :: CompileInfoIO [Char]), - checkSuccess "b" (collectAnyM [compileErrorM "error1",return 'b',compileErrorM "error2"]), - - checkSuccess 'a' (collectFirstM [return 'a',return 'b']), - checkError "" (collectFirstM [] :: CompileInfoIO Char), - checkSuccess 'b' (collectFirstM [compileErrorM "error1",return 'b',compileErrorM "error2"]), - - checkSuccessAndWarnings "warning1\nwarning2\n" () - (compileWarningM "warning1" >> return () >> compileWarningM "warning2"), - checkErrorAndWarnings "warning1\n" "error\n" - (compileWarningM "warning1" >> compileErrorM "error" >> compileWarningM "warning2" :: CompileInfoIO ()), - - checkSuccess ['a','b'] (sequence [return 'a',return 'b']), - checkSuccess [] (sequence [] :: CompileInfoIO [Char]), - checkError "error1\n" (sequence [compileErrorM "error1",return 'b',compileErrorM "error2"]), - - checkSuccess 'a' (return 'a' `withContextM` "message"), - checkError "message\n error\n" (compileErrorM "error" `withContextM` "message" :: CompileInfoIO ()), - checkSuccessAndWarnings "message\n warning\n" () - (compileWarningM "warning" `withContextM` "message" :: CompileInfoIO ()), - checkErrorAndWarnings "message\n warning\n" "message\n error\n" - ((compileWarningM "warning" >> compileErrorM "error") `withContextM` "message" :: CompileInfoIO ()), - checkSuccessAndWarnings "" () (return () `withContextM` "message"), - checkErrorAndWarnings "" "message\n" (compileErrorM "" `withContextM` "message" :: CompileInfoIO ()), - - checkSuccess 'a' (return 'a' `summarizeErrorsM` "message"), - checkError "message\n error\n" (compileErrorM "error" `summarizeErrorsM` "message" :: CompileInfoIO ()), - checkSuccessAndWarnings "warning\n" () - (compileWarningM "warning" `summarizeErrorsM` "message" :: CompileInfoIO ()), - checkErrorAndWarnings "warning\n" "message\n error\n" - ((compileWarningM "warning" >> compileErrorM "error") `summarizeErrorsM` "message" :: CompileInfoIO ()), - checkSuccessAndWarnings "" () (return () `summarizeErrorsM` "message"), - checkErrorAndWarnings "" "message\n" (compileErrorM "" `summarizeErrorsM` "message" :: CompileInfoIO ()), - - checkSuccessAndWarnings "error\n" () - (asCompileWarnings $ compileErrorM "error" :: CompileInfoIO ()), - checkErrorAndWarnings "" "warning\n" - (asCompileError $ compileWarningM "warning" :: CompileInfoIO ()), - - checkSuccess 'a' (compileBackgroundM "background" >> return 'a'), - checkError "error\n background\n" - (compileBackgroundM "background" >> compileErrorM "error" :: CompileInfoIO ()), - checkError "error\n background\n" - (collectAllM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO [()]), - checkError "error\n background\n" - (collectFirstM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO ()), - - checkSuccess 'a' ((resetBackgroundM $ compileBackgroundM "background") >> return 'a'), - checkError "error\n" - ((resetBackgroundM $ compileBackgroundM "background") >> compileErrorM "error" :: CompileInfoIO ()) - ] - -checkSuccess :: (Eq a, Show a) => a -> CompileInfoIO a -> IO (CompileInfo ()) -checkSuccess x y = do - y' <- toCompileInfo y - if isCompileError y' || getCompileSuccess y' == x - then return $ y' >> return () - else return $ compileErrorM $ "Expected value " ++ show x ++ " but got value " ++ show (getCompileSuccess y') - -checkError :: (Eq a, Show a) => String -> CompileInfoIO a -> IO (CompileInfo ()) -checkError e y = do - y' <- toCompileInfo y - if not (isCompileError y') - then return $ compileErrorM $ "Expected error \"" ++ e ++ "\" but got value " ++ show (getCompileSuccess y') - else if show (getCompileError y') == e - then return $ return () - else return $ compileErrorM $ "Expected error \"" ++ e ++ "\" but got error \"" ++ show (getCompileError y') ++ "\"" - -checkSuccessAndWarnings :: (Eq a, Show a) => String -> a -> CompileInfoIO a -> IO (CompileInfo ()) -checkSuccessAndWarnings w x y = do - y' <- toCompileInfo y - outcome <- checkSuccess x y - if show (getCompileWarnings y') == w - then return $ outcome >> return () - else return $ compileErrorM $ "Expected warnings " ++ show w ++ " but got warnings \"" ++ show (getCompileWarnings y') ++ "\"" - -checkErrorAndWarnings :: (Eq a, Show a) => String -> String -> CompileInfoIO a -> IO (CompileInfo ()) -checkErrorAndWarnings w e y = do - y' <- toCompileInfo y - outcome <- checkError e y - if show (getCompileWarnings y') == w - then return $ outcome >> return () - else return $ compileErrorM $ "Expected warnings " ++ show w ++ " but got warnings \"" ++ show (getCompileWarnings y') ++ "\"" diff --git a/src/Test/DefinedCategory.hs b/src/Test/DefinedCategory.hs --- a/src/Test/DefinedCategory.hs +++ b/src/Test/DefinedCategory.hs @@ -16,21 +16,19 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-} - module Test.DefinedCategory (tests) where import System.FilePath -import Text.Parsec -import Base.CompileError -import Base.CompileInfo +import Base.CompilerError +import Base.TrackedErrors import Parser.DefinedCategory () +import Parser.TextParser (SourceContext) import Test.Common import Types.DefinedCategory -tests :: [IO (CompileInfo ())] +tests :: [IO (TrackedErrors ())] tests = [ checkParseSuccess ("testfiles" "definitions.0rx"), checkParseSuccess ("testfiles" "internal_inheritance.0rx"), @@ -38,23 +36,23 @@ checkParseSuccess ("testfiles" "internal_filters.0rx") ] -checkParseSuccess :: String -> IO (CompileInfo ()) +checkParseSuccess :: String -> IO (TrackedErrors ()) checkParseSuccess f = do contents <- loadFile f - let parsed = readMulti f contents :: CompileInfo [DefinedCategory SourcePos] + let parsed = readMulti f contents :: TrackedErrors [DefinedCategory SourceContext] return $ check parsed where check c - | isCompileError c = compileErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompilerError c) | otherwise = return () -checkParseFail :: String -> IO (CompileInfo ()) +checkParseFail :: String -> IO (TrackedErrors ()) checkParseFail f = do contents <- loadFile f - let parsed = readMulti f contents :: CompileInfo [DefinedCategory SourcePos] + let parsed = readMulti f contents :: TrackedErrors [DefinedCategory SourceContext] return $ check parsed where check c - | isCompileError c = return () - | otherwise = compileErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++ - show (getCompileSuccess c) ++ "\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++ + show (getCompilerSuccess c) ++ "\n" diff --git a/src/Test/IntegrationTest.hs b/src/Test/IntegrationTest.hs --- a/src/Test/IntegrationTest.hs +++ b/src/Test/IntegrationTest.hs @@ -16,31 +16,29 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-} - module Test.IntegrationTest (tests) where import Control.Monad (when) import System.FilePath -import Text.Parsec -import Base.CompileError -import Base.CompileInfo +import Base.CompilerError +import Base.TrackedErrors import Parser.Common import Parser.IntegrationTest () +import Parser.TextParser import Test.Common import Types.DefinedCategory import Types.IntegrationTest import Types.TypeCategory -tests :: [IO (CompileInfo ())] +tests :: [IO (TrackedErrors ())] tests = [ checkFileContents ("testfiles" "basic_compiles_test.0rt") (\t -> do let h = itHeader t - when (not $ isExpectCompiles $ ithResult h) $ compileErrorM "Expected ExpectCompiles" + when (not $ isExpectCompiles $ ithResult h) $ compilerErrorM "Expected ExpectCompiles" checkEquals (ithTestName h) "basic compiles test" containsExactly (getRequirePattern $ ithResult h) [ OutputPattern OutputCompiler "pattern in output 1", @@ -58,7 +56,7 @@ ("testfiles" "basic_error_test.0rt") (\t -> do let h = itHeader t - when (not $ isExpectCompileError $ ithResult h) $ compileErrorM "Expected ExpectCompileError" + when (not $ isExpectCompilerError $ ithResult h) $ compilerErrorM "Expected ExpectCompilerError" checkEquals (ithTestName h) "basic error test" containsExactly (getRequirePattern $ ithResult h) [ OutputPattern OutputCompiler "pattern in output 1", @@ -76,7 +74,7 @@ ("testfiles" "basic_crash_test.0rt") (\t -> do let h = itHeader t - when (not $ isExpectRuntimeError $ ithResult h) $ compileErrorM "Expected ExpectRuntimeError" + when (not $ isExpectRuntimeError $ ithResult h) $ compilerErrorM "Expected ExpectRuntimeError" checkEquals (ithTestName h) "basic crash test" containsExactly (getRequirePattern $ ithResult h) [ OutputPattern OutputAny "pattern in output 1", @@ -94,7 +92,7 @@ ("testfiles" "basic_success_test.0rt") (\t -> do let h = itHeader t - when (not $ isExpectRuntimeSuccess $ ithResult h) $ compileErrorM "Expected ExpectRuntimeSuccess" + when (not $ isExpectRuntimeSuccess $ ithResult h) $ compilerErrorM "Expected ExpectRuntimeSuccess" checkEquals (ithTestName h) "basic success test" containsExactly (getRequirePattern $ ithResult h) [ OutputPattern OutputAny "pattern in output 1", @@ -110,11 +108,11 @@ ] checkFileContents :: - String -> (IntegrationTest SourcePos -> CompileInfo ()) -> IO (CompileInfo ()) -checkFileContents f o = toCompileInfo $ do + String -> (IntegrationTest SourceContext -> TrackedErrors ()) -> IO (TrackedErrors ()) +checkFileContents f o = toTrackedErrors $ do s <- errorFromIO $ loadFile f - t <- runParserE (between optionalSpace endOfDoc sourceParser) f s - fromCompileInfo $ o t [String] extractCategoryNames = map (show . getCategoryName) . itCategory diff --git a/src/Test/MergeTree.hs b/src/Test/MergeTree.hs --- a/src/Test/MergeTree.hs +++ b/src/Test/MergeTree.hs @@ -16,20 +16,18 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-} - module Test.MergeTree (tests) where import Control.Monad (when) import Data.Char (toUpper) -import Base.CompileError -import Base.CompileInfo +import Base.CompilerError +import Base.TrackedErrors import Base.MergeTree import Base.Mergeable -tests :: [IO (CompileInfo ())] +tests :: [IO (TrackedErrors ())] tests = [ checkMatch (mergeAny $ fmap mergeLeaf [2,4,6]) (fmap (*2)) (mergeAny $ map mergeLeaf [1..3] :: MergeTree Int), @@ -158,35 +156,35 @@ mergeAll [mergeLeaf 'a',mergeLeaf 'b']) ] -oddError :: Int -> CompileInfo Int +oddError :: Int -> TrackedErrors Int oddError x = do - when (odd x) $ compileErrorM $ show x ++ " is odd" + when (odd x) $ compilerErrorM $ show x ++ " is odd" return x -oddError2 :: Int -> CompileInfo [Int] +oddError2 :: Int -> TrackedErrors [Int] oddError2 = fmap (:[]) . oddError -checkMatch :: (Eq b, Show b) => b -> (a -> b) -> a -> IO (CompileInfo ()) +checkMatch :: (Eq b, Show b) => b -> (a -> b) -> a -> IO (TrackedErrors ()) checkMatch x f y = let y' = f y in return $ if x /= y' - then compileErrorM $ "Expected " ++ show x ++ " but got " ++ show y' + then compilerErrorM $ "Expected " ++ show x ++ " but got " ++ show y' else return () -checkMatch2 :: (Eq a, Show a) => a -> a -> a -> IO (CompileInfo ()) +checkMatch2 :: (Eq a, Show a) => a -> a -> a -> IO (TrackedErrors ()) checkMatch2 x y z = return $ do - when (x /= z) $ compileErrorM $ "Expected " ++ show x ++ " but got " ++ show z - when (y == z) $ compileErrorM $ "Expected something besides " ++ show y + when (x /= z) $ compilerErrorM $ "Expected " ++ show x ++ " but got " ++ show z + when (y == z) $ compilerErrorM $ "Expected something besides " ++ show y -checkSuccess :: (Eq b, Show b) => b -> (a -> CompileInfo b) -> a -> IO (CompileInfo ()) +checkSuccess :: (Eq b, Show b) => b -> (a -> TrackedErrors b) -> a -> IO (TrackedErrors ()) checkSuccess x f y = let y' = f y in - return $ if isCompileError y' || getCompileSuccess y' == x + return $ if isCompilerError y' || getCompilerSuccess y' == x then y' >> return () - else compileErrorM $ "Expected value " ++ show x ++ " but got value " ++ show (getCompileSuccess y') + else compilerErrorM $ "Expected value " ++ show x ++ " but got value " ++ show (getCompilerSuccess y') -checkError :: Show b => String -> (a -> CompileInfo b) -> a -> IO (CompileInfo ()) +checkError :: Show b => String -> (a -> TrackedErrors b) -> a -> IO (TrackedErrors ()) checkError e f y = let y' = f y in - return $ if not (isCompileError y') - then compileErrorM $ "Expected error \"" ++ e ++ "\" but got value " ++ show (getCompileSuccess y') - else if show (getCompileError y') == e + return $ if not (isCompilerError y') + then compilerErrorM $ "Expected error \"" ++ e ++ "\" but got value " ++ show (getCompilerSuccess y') + else if show (getCompilerError y') == e then return () - else compileErrorM $ "Expected error \"" ++ e ++ "\" but got error \"" ++ show (getCompileError y') ++ "\"" + else compilerErrorM $ "Expected error \"" ++ e ++ "\" but got error \"" ++ show (getCompilerError y') ++ "\"" diff --git a/src/Test/ParseMetadata.hs b/src/Test/ParseMetadata.hs --- a/src/Test/ParseMetadata.hs +++ b/src/Test/ParseMetadata.hs @@ -19,17 +19,17 @@ module Test.ParseMetadata (tests) where import Control.Monad (when) -import Text.Regex.TDFA -- Not safe! +import Text.Regex.TDFA -import Base.CompileError -import Base.CompileInfo +import Base.CompilerError +import Base.Positional +import Base.TrackedErrors import Cli.CompileOptions import Cli.Programs (VersionHash(..)) import Module.CompileMetadata import Module.ParseMetadata import System.FilePath import Test.Common -import Types.Positional import Types.Pragma import Types.Procedure import Types.TypeCategory (FunctionName(..),Namespace(..)) @@ -160,7 +160,7 @@ } } -tests :: [IO (CompileInfo ())] +tests :: [IO (TrackedErrors ())] tests = [ checkWriteThenRead hugeCompileMetadata, @@ -378,31 +378,31 @@ checkParsesAs ("testfiles" "module-cache.txt") (== hugeCompileMetadata) ] -checkWriteThenRead :: (Eq a, Show a, ConfigFormat a) => a -> IO (CompileInfo ()) +checkWriteThenRead :: (Eq a, Show a, ConfigFormat a) => a -> IO (TrackedErrors ()) checkWriteThenRead m = return $ do text <- fmap spamComments $ autoWriteConfig m m' <- autoReadConfig "(string)" text >>\n\n" ++ text ++ "\n<<< Serialized\n\n" when (m' /= m) $ - compileErrorM $ "Failed to match after write/read\n" ++ + compilerErrorM $ "Failed to match after write/read\n" ++ "Before:\n" ++ show m ++ "\n" ++ "After:\n" ++ show m' ++ "\n" ++ "Intermediate:\n" ++ text where spamComments = unlines . map (++ " // spam") . lines -checkWriteFail :: ConfigFormat a => String -> a -> IO (CompileInfo ()) +checkWriteFail :: ConfigFormat a => String -> a -> IO (TrackedErrors ()) checkWriteFail p m = return $ do let m' = autoWriteConfig m check m' where check c - | isCompileError c = do - let text = show (getCompileError c) + | isCompilerError c = do + let text = show (getCompilerError c) when (not $ text =~ p) $ - compileErrorM $ "Expected pattern " ++ show p ++ " in error output but got\n" ++ text + compilerErrorM $ "Expected pattern " ++ show p ++ " in error output but got\n" ++ text | otherwise = - compileErrorM $ "Expected write failure but got\n" ++ getCompileSuccess c + compilerErrorM $ "Expected write failure but got\n" ++ getCompilerSuccess c -checkParsesAs :: (Show a, ConfigFormat a) => String -> (a -> Bool) -> IO (CompileInfo ()) +checkParsesAs :: (Show a, ConfigFormat a) => String -> (a -> Bool) -> IO (TrackedErrors ()) checkParsesAs f m = do contents <- loadFile f let parsed = autoReadConfig f contents @@ -411,6 +411,6 @@ check x contents = do x' <- x > some asciiChar) "keyword string" "string", + checkParseFail (keyword "keyword" >> some asciiChar) "keywordstring", + checkParseFail (keyword "keyword" >> some asciiChar) "keyword_string", + checkParsesAs + ((fmap Left $ keyword "keyword" >> some asciiChar) <|> (fmap Right $ some asciiChar)) + "keywordstring" + (Right "keywordstring"), + + checkParsesAs (operator ">>??!" >> many asciiChar) ">>??! !!" "!!", + checkParseFail (operator ">>??!" >> many asciiChar) ">>??!!!" ] -checkParsesAs :: (Eq a, Show a) => ParserE CompileInfo a -> [Char] -> a -> IO (CompileInfo ()) +checkParsesAs :: (Eq a, Show a) => TextParser a -> [Char] -> a -> IO (TrackedErrors ()) checkParsesAs p s m = return $ do let parsed = readSingleWith p "(string)" s check parsed e <- parsed when (e /= m) $ - compileErrorM $ show s ++ " does not parse as " ++ show m ++ ":\n" ++ show e + compilerErrorM $ show s ++ " does not parse as " ++ show m ++ ":\n" ++ show e where check c - | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompilerError c) | otherwise = return () -checkParseFail :: Show a => ParserE CompileInfo a -> [Char] -> IO (CompileInfo ()) +checkParseFail :: Show a => TextParser a -> [Char] -> IO (TrackedErrors ()) checkParseFail p s = do let parsed = readSingleWith p "(string)" s return $ check parsed where check c - | isCompileError c = return () - | otherwise = compileErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ - show (getCompileSuccess c) ++ "\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ + show (getCompilerSuccess c) ++ "\n" diff --git a/src/Test/Pragma.hs b/src/Test/Pragma.hs --- a/src/Test/Pragma.hs +++ b/src/Test/Pragma.hs @@ -19,18 +19,17 @@ module Test.Pragma (tests) where import Control.Monad (when) -import Text.Parsec -import Text.Regex.TDFA -- Not safe! +import Text.Regex.TDFA -import Base.CompileError -import Base.CompileInfo -import Parser.Common +import Base.CompilerError +import Base.TrackedErrors import Parser.Pragma +import Parser.TextParser import Test.Common import Types.Pragma -tests :: [IO (CompileInfo ())] +tests :: [IO (TrackedErrors ())] tests = [ checkParsesAs "$ModuleOnly$" (fmap (:[]) pragmaModuleOnly) (\e -> case e of @@ -98,27 +97,27 @@ checkParseError "$ExprLookup[ \"bad stuff\" ]$" "macro name" pragmaExprLookup ] -checkParsesAs :: String -> ParserE CompileInfo [Pragma SourcePos] -> ([Pragma SourcePos] -> Bool) -> IO (CompileInfo ()) +checkParsesAs :: String -> TextParser [Pragma SourceContext] -> ([Pragma SourceContext] -> Bool) -> IO (TrackedErrors ()) checkParsesAs s p m = return $ do let parsed = readSingleWith p "(string)" s check parsed e <- parsed when (not $ m e) $ - compileErrorM $ "No match in '" ++ s ++ "':\n" ++ show e + compilerErrorM $ "No match in '" ++ s ++ "':\n" ++ show e where check c - | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompilerError c) | otherwise = return () -checkParseError :: String -> String -> ParserE CompileInfo (Pragma SourcePos) -> IO (CompileInfo ()) +checkParseError :: String -> String -> TextParser (Pragma SourceContext) -> IO (TrackedErrors ()) checkParseError s m p = return $ do let parsed = readSingleWith p "(string)" s check parsed where check c - | isCompileError c = do - let text = show (getCompileError c) + | isCompilerError c = do + let text = show (getCompilerError c) when (not $ text =~ m) $ - compileErrorM $ "Expected pattern " ++ show m ++ " in error output but got\n" ++ text + compilerErrorM $ "Expected pattern " ++ show m ++ " in error output but got\n" ++ text | otherwise = - compileErrorM $ "Expected write failure but got\n" ++ show (getCompileSuccess c) + compilerErrorM $ "Expected write failure but got\n" ++ show (getCompilerSuccess c) diff --git a/src/Test/Procedure.hs b/src/Test/Procedure.hs --- a/src/Test/Procedure.hs +++ b/src/Test/Procedure.hs @@ -16,25 +16,23 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-} - module Test.Procedure (tests) where import Control.Monad import System.FilePath -import Text.Parsec -import Base.CompileError -import Base.CompileInfo +import Base.CompilerError +import Base.Positional +import Base.TrackedErrors import Parser.Procedure () +import Parser.TextParser (SourceContext) import Test.Common -import Types.Positional import Types.Procedure import Types.TypeCategory import Types.TypeInstance -tests :: [IO (CompileInfo ())] +tests :: [IO (TrackedErrors ())] tests = [ checkParseSuccess ("testfiles" "procedures.0rx"), @@ -404,54 +402,54 @@ _ -> False) ] -checkParseSuccess :: String -> IO (CompileInfo ()) +checkParseSuccess :: String -> IO (TrackedErrors ()) checkParseSuccess f = do contents <- loadFile f - let parsed = readMulti f contents :: CompileInfo [ExecutableProcedure SourcePos] + let parsed = readMulti f contents :: TrackedErrors [ExecutableProcedure SourceContext] return $ check parsed where check c - | isCompileError c = compileErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompilerError c) | otherwise = return () -checkParseFail :: String -> IO (CompileInfo ()) +checkParseFail :: String -> IO (TrackedErrors ()) checkParseFail f = do contents <- loadFile f - let parsed = readMulti f contents :: CompileInfo [ExecutableProcedure SourcePos] + let parsed = readMulti f contents :: TrackedErrors [ExecutableProcedure SourceContext] return $ check parsed where check c - | isCompileError c = return () - | otherwise = compileErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++ - show (getCompileSuccess c) ++ "\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++ + show (getCompilerSuccess c) ++ "\n" -checkShortParseSuccess :: String -> IO (CompileInfo ()) +checkShortParseSuccess :: String -> IO (TrackedErrors ()) checkShortParseSuccess s = do - let parsed = readSingle "(string)" s :: CompileInfo (Statement SourcePos) + let parsed = readSingle "(string)" s :: TrackedErrors (Statement SourceContext) return $ check parsed where check c - | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompilerError c) | otherwise = return () -checkShortParseFail :: String -> IO (CompileInfo ()) +checkShortParseFail :: String -> IO (TrackedErrors ()) checkShortParseFail s = do - let parsed = readSingle "(string)" s :: CompileInfo (Statement SourcePos) + let parsed = readSingle "(string)" s :: TrackedErrors (Statement SourceContext) return $ check parsed where check c - | isCompileError c = return () - | otherwise = compileErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ - show (getCompileSuccess c) ++ "\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ + show (getCompilerSuccess c) ++ "\n" -checkParsesAs :: String -> (Expression SourcePos -> Bool) -> IO (CompileInfo ()) +checkParsesAs :: String -> (Expression SourceContext -> Bool) -> IO (TrackedErrors ()) checkParsesAs s m = return $ do - let parsed = readSingle "(string)" s :: CompileInfo (Expression SourcePos) + let parsed = readSingle "(string)" s :: TrackedErrors (Expression SourceContext) check parsed e <- parsed when (not $ m e) $ - compileErrorM $ "No match in '" ++ s ++ "':\n" ++ show e + compilerErrorM $ "No match in '" ++ s ++ "':\n" ++ show e where check c - | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompilerError c) | otherwise = return () diff --git a/src/Test/SourceFile.hs b/src/Test/SourceFile.hs --- a/src/Test/SourceFile.hs +++ b/src/Test/SourceFile.hs @@ -16,31 +16,29 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-} - module Test.SourceFile (tests) where import System.FilePath -import Base.CompileError -import Base.CompileInfo +import Base.CompilerError +import Base.TrackedErrors import Parser.SourceFile import Test.Common -tests :: [IO (CompileInfo ())] +tests :: [IO (TrackedErrors ())] tests = [ checkParseSuccess ("testfiles" "public.0rp") parsePublicSource, checkParseSuccess ("testfiles" "internal.0rx") parseInternalSource, checkParseSuccess ("testfiles" "test.0rt") parseTestSource ] -checkParseSuccess :: String -> ((FilePath,String) -> CompileInfo a) -> IO (CompileInfo ()) +checkParseSuccess :: String -> ((FilePath,String) -> TrackedErrors a) -> IO (TrackedErrors ()) checkParseSuccess f p = do contents <- loadFile f let parsed = p (f,contents) return $ check parsed where check c - | isCompileError c = compileErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompilerError c) | otherwise = return () diff --git a/src/Test/TrackedErrors.hs b/src/Test/TrackedErrors.hs new file mode 100644 --- /dev/null +++ b/src/Test/TrackedErrors.hs @@ -0,0 +1,120 @@ +{- ----------------------------------------------------------------------------- +Copyright 2020 Kevin P. Barry + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +----------------------------------------------------------------------------- -} + +-- Author: Kevin P. Barry [ta0kira@gmail.com] + +{-# LANGUAGE Safe #-} + +module Test.TrackedErrors (tests) where + +import Base.CompilerError +import Base.TrackedErrors + + +tests :: [IO (TrackedErrors ())] +tests = [ + checkSuccess 'a' (return 'a'), + checkError "error\n" (compilerErrorM "error" :: TrackedErrorsIO Char), + checkError "" (compilerErrorM "" :: TrackedErrorsIO Char), + + checkSuccess ['a','b'] (collectAllM [return 'a',return 'b']), + checkSuccess [] (collectAllM [] :: TrackedErrorsIO [Char]), + checkError "error1\nerror2\n" (collectAllM [compilerErrorM "error1",return 'b',compilerErrorM "error2"]), + + checkSuccess "ab" (collectAnyM [return 'a',return 'b']), + checkSuccess "" (collectAnyM [] :: TrackedErrorsIO [Char]), + checkSuccess "b" (collectAnyM [compilerErrorM "error1",return 'b',compilerErrorM "error2"]), + + checkSuccess 'a' (collectFirstM [return 'a',return 'b']), + checkError "" (collectFirstM [] :: TrackedErrorsIO Char), + checkSuccess 'b' (collectFirstM [compilerErrorM "error1",return 'b',compilerErrorM "error2"]), + + checkSuccessAndWarnings "warning1\nwarning2\n" () + (compilerWarningM "warning1" >> return () >> compilerWarningM "warning2"), + checkErrorAndWarnings "warning1\n" "error\n" + (compilerWarningM "warning1" >> compilerErrorM "error" >> compilerWarningM "warning2" :: TrackedErrorsIO ()), + + checkSuccess ['a','b'] (sequence [return 'a',return 'b']), + checkSuccess [] (sequence [] :: TrackedErrorsIO [Char]), + checkError "error1\n" (sequence [compilerErrorM "error1",return 'b',compilerErrorM "error2"]), + + checkSuccess 'a' (return 'a' `withContextM` "message"), + checkError "message\n error\n" (compilerErrorM "error" `withContextM` "message" :: TrackedErrorsIO ()), + checkSuccessAndWarnings "message\n warning\n" () + (compilerWarningM "warning" `withContextM` "message" :: TrackedErrorsIO ()), + checkErrorAndWarnings "message\n warning\n" "message\n error\n" + ((compilerWarningM "warning" >> compilerErrorM "error") `withContextM` "message" :: TrackedErrorsIO ()), + checkSuccessAndWarnings "" () (return () `withContextM` "message"), + checkErrorAndWarnings "" "message\n" (compilerErrorM "" `withContextM` "message" :: TrackedErrorsIO ()), + + checkSuccess 'a' (return 'a' `summarizeErrorsM` "message"), + checkError "message\n error\n" (compilerErrorM "error" `summarizeErrorsM` "message" :: TrackedErrorsIO ()), + checkSuccessAndWarnings "warning\n" () + (compilerWarningM "warning" `summarizeErrorsM` "message" :: TrackedErrorsIO ()), + checkErrorAndWarnings "warning\n" "message\n error\n" + ((compilerWarningM "warning" >> compilerErrorM "error") `summarizeErrorsM` "message" :: TrackedErrorsIO ()), + checkSuccessAndWarnings "" () (return () `summarizeErrorsM` "message"), + checkErrorAndWarnings "" "message\n" (compilerErrorM "" `summarizeErrorsM` "message" :: TrackedErrorsIO ()), + + checkSuccessAndWarnings "error\n" () + (asCompilerWarnings $ compilerErrorM "error" :: TrackedErrorsIO ()), + checkErrorAndWarnings "" "warning\n" + (asCompilerError $ compilerWarningM "warning" :: TrackedErrorsIO ()), + + checkSuccess 'a' (compilerBackgroundM "background" >> return 'a'), + checkError "error\n background\n" + (compilerBackgroundM "background" >> compilerErrorM "error" :: TrackedErrorsIO ()), + checkError "error\n background\n" + (collectAllM [compilerBackgroundM "background"] >> compilerErrorM "error" :: TrackedErrorsIO [()]), + checkError "error\n background\n" + (collectFirstM [compilerBackgroundM "background"] >> compilerErrorM "error" :: TrackedErrorsIO ()), + + checkSuccess 'a' ((resetBackgroundM $ compilerBackgroundM "background") >> return 'a'), + checkError "error\n" + ((resetBackgroundM $ compilerBackgroundM "background") >> compilerErrorM "error" :: TrackedErrorsIO ()) + ] + +checkSuccess :: (Eq a, Show a) => a -> TrackedErrorsIO a -> IO (TrackedErrors ()) +checkSuccess x y = do + y' <- toTrackedErrors y + if isCompilerError y' || getCompilerSuccess y' == x + then return $ y' >> return () + else return $ compilerErrorM $ "Expected value " ++ show x ++ " but got value " ++ show (getCompilerSuccess y') + +checkError :: (Eq a, Show a) => String -> TrackedErrorsIO a -> IO (TrackedErrors ()) +checkError e y = do + y' <- toTrackedErrors y + if not (isCompilerError y') + then return $ compilerErrorM $ "Expected error \"" ++ e ++ "\" but got value " ++ show (getCompilerSuccess y') + else if show (getCompilerError y') == e + then return $ return () + else return $ compilerErrorM $ "Expected error \"" ++ e ++ "\" but got error \"" ++ show (getCompilerError y') ++ "\"" + +checkSuccessAndWarnings :: (Eq a, Show a) => String -> a -> TrackedErrorsIO a -> IO (TrackedErrors ()) +checkSuccessAndWarnings w x y = do + y' <- toTrackedErrors y + outcome <- checkSuccess x y + if show (getCompilerWarnings y') == w + then return $ outcome >> return () + else return $ compilerErrorM $ "Expected warnings " ++ show w ++ " but got warnings \"" ++ show (getCompilerWarnings y') ++ "\"" + +checkErrorAndWarnings :: (Eq a, Show a) => String -> String -> TrackedErrorsIO a -> IO (TrackedErrors ()) +checkErrorAndWarnings w e y = do + y' <- toTrackedErrors y + outcome <- checkError e y + if show (getCompilerWarnings y') == w + then return $ outcome >> return () + else return $ compilerErrorM $ "Expected warnings " ++ show w ++ " but got warnings \"" ++ show (getCompilerWarnings y') ++ "\"" diff --git a/src/Test/TypeCategory.hs b/src/Test/TypeCategory.hs --- a/src/Test/TypeCategory.hs +++ b/src/Test/TypeCategory.hs @@ -16,29 +16,28 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-} module Test.TypeCategory (tests) where import Control.Arrow import System.FilePath -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.GeneralType +import Base.Positional +import Base.TrackedErrors +import Parser.TextParser (SourceContext) import Parser.TypeCategory () import Test.Common import Types.Builtin -import Types.GeneralType -import Types.Positional import Types.TypeCategory import Types.TypeInstance import Types.Variance -tests :: [IO (CompileInfo ())] +tests :: [IO (TrackedErrors ())] tests = [ checkSingleParseSuccess ("testfiles" "value_interface.0rx"), checkSingleParseSuccess ("testfiles" "type_interface.0rx"), @@ -1126,19 +1125,19 @@ [("[Type1|Type4]","#x")]) ] -getRefines :: Map.Map CategoryName (AnyCategory c) -> String -> CompileInfo [String] +getRefines :: Map.Map CategoryName (AnyCategory c) -> String -> TrackedErrors [String] getRefines tm n = case (CategoryName n) `Map.lookup` tm of (Just t) -> return $ map (show . vrType) (getCategoryRefines t) - _ -> compileErrorM $ "Type " ++ n ++ " not found" + _ -> compilerErrorM $ "Type " ++ n ++ " not found" -getDefines :: Map.Map CategoryName (AnyCategory c) -> String -> CompileInfo [String] +getDefines :: Map.Map CategoryName (AnyCategory c) -> String -> TrackedErrors [String] getDefines tm n = case (CategoryName n) `Map.lookup` tm of (Just t) -> return $ map (show . vdType) (getCategoryDefines t) - _ -> compileErrorM $ "Type " ++ n ++ " not found" + _ -> compilerErrorM $ "Type " ++ n ++ " not found" -getTypeRefines :: Show c => [AnyCategory c] -> String -> String -> CompileInfo [String] +getTypeRefines :: Show c => [AnyCategory c] -> String -> String -> TrackedErrors [String] getTypeRefines ts s n = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta @@ -1146,7 +1145,7 @@ Positional rs <- trRefines r t (CategoryName n) return $ map show rs -getTypeDefines :: Show c => [AnyCategory c] -> String -> String -> CompileInfo [String] +getTypeDefines :: Show c => [AnyCategory c] -> String -> String -> TrackedErrors [String] getTypeDefines ts s n = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta @@ -1154,14 +1153,14 @@ Positional ds <- trDefines r t (CategoryName n) return $ map show ds -getTypeVariance :: Show c => [AnyCategory c] -> String -> CompileInfo [Variance] +getTypeVariance :: Show c => [AnyCategory c] -> String -> TrackedErrors [Variance] getTypeVariance ts n = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta (Positional vs) <- trVariance r (CategoryName n) return vs -getTypeFilters :: Show c => [AnyCategory c] -> String -> CompileInfo [[String]] +getTypeFilters :: Show c => [AnyCategory c] -> String -> TrackedErrors [[String]] getTypeFilters ts s = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta @@ -1169,7 +1168,7 @@ Positional vs <- trTypeFilters r t return $ map (map show) vs -getTypeDefinesFilters :: Show c => [AnyCategory c] -> String -> CompileInfo [[String]] +getTypeDefinesFilters :: Show c => [AnyCategory c] -> String -> TrackedErrors [[String]] getTypeDefinesFilters ts s = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta @@ -1188,98 +1187,98 @@ scrapeSingle (ValueConcrete _ _ n _ _ ds _ _) = map ((,) n . vdType) ds scrapeSingle _ = [] -checkPaired :: Show a => (a -> a -> CompileInfo ()) -> [a] -> [a] -> CompileInfo () +checkPaired :: Show a => (a -> a -> TrackedErrors ()) -> [a] -> [a] -> TrackedErrors () checkPaired f actual expected | length actual /= length expected = - compileErrorM $ "Different item counts: " ++ show actual ++ " (actual) vs. " ++ + compilerErrorM $ "Different item counts: " ++ show actual ++ " (actual) vs. " ++ show expected ++ " (expected)" | otherwise = mapErrorsM_ check (zip3 actual expected ([1..] :: [Int])) where check (a,e,n) = f a e [a] -> [a] -> CompileInfo () +containsPaired :: (Eq a, Show a) => [a] -> [a] -> TrackedErrors () containsPaired = checkPaired checkSingle where checkSingle a e | a == e = return () - | otherwise = compileErrorM $ show a ++ " (actual) vs. " ++ show e ++ " (expected)" + | otherwise = compilerErrorM $ show a ++ " (actual) vs. " ++ show e ++ " (expected)" -checkOperationSuccess :: String -> ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) +checkOperationSuccess :: String -> ([AnyCategory SourceContext] -> TrackedErrors a) -> IO (TrackedErrors ()) checkOperationSuccess f o = do contents <- loadFile f - let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos] + let parsed = readMulti f contents :: TrackedErrors [AnyCategory SourceContext] return $ check (parsed >>= o >> return ()) where check x = x ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) +checkOperationFail :: String -> ([AnyCategory SourceContext] -> TrackedErrors a) -> IO (TrackedErrors ()) checkOperationFail f o = do contents <- loadFile f - let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos] + let parsed = readMulti f contents :: TrackedErrors [AnyCategory SourceContext] return $ check (parsed >>= o >> return ()) where check c - | isCompileError c = return () - | otherwise = compileErrorM $ "Check " ++ f ++ ": Expected failure but got\n" ++ - show (getCompileSuccess c) ++ "\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ "Check " ++ f ++ ": Expected failure but got\n" ++ + show (getCompilerSuccess c) ++ "\n" -checkSingleParseSuccess :: String -> IO (CompileInfo ()) +checkSingleParseSuccess :: String -> IO (TrackedErrors ()) checkSingleParseSuccess f = do contents <- loadFile f - let parsed = readSingle f contents :: CompileInfo (AnyCategory SourcePos) + let parsed = readSingle f contents :: TrackedErrors (AnyCategory SourceContext) return $ check parsed where check c - | isCompileError c = compileErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse " ++ f ++ ":\n" ++ show (getCompilerError c) | otherwise = return () -checkSingleParseFail :: String -> IO (CompileInfo ()) +checkSingleParseFail :: String -> IO (TrackedErrors ()) checkSingleParseFail f = do contents <- loadFile f - let parsed = readSingle f contents :: CompileInfo (AnyCategory SourcePos) + let parsed = readSingle f contents :: TrackedErrors (AnyCategory SourceContext) return $ check parsed where check c - | isCompileError c = return () - | otherwise = compileErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++ - show (getCompileSuccess c) ++ "\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ "Parse " ++ f ++ ": Expected failure but got\n" ++ + show (getCompilerSuccess c) ++ "\n" -checkShortParseSuccess :: String -> IO (CompileInfo ()) +checkShortParseSuccess :: String -> IO (TrackedErrors ()) checkShortParseSuccess s = do - let parsed = readSingle "(string)" s :: CompileInfo (AnyCategory SourcePos) + let parsed = readSingle "(string)" s :: TrackedErrors (AnyCategory SourceContext) return $ check parsed where check c - | isCompileError c = compileErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ "Parse '" ++ s ++ "':\n" ++ show (getCompilerError c) | otherwise = return () -checkShortParseFail :: String -> IO (CompileInfo ()) +checkShortParseFail :: String -> IO (TrackedErrors ()) checkShortParseFail s = do - let parsed = readSingle "(string)" s :: CompileInfo (AnyCategory SourcePos) + let parsed = readSingle "(string)" s :: TrackedErrors (AnyCategory SourceContext) return $ check parsed where check c - | isCompileError c = return () - | otherwise = compileErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ - show (getCompileSuccess c) ++ "\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ + show (getCompilerSuccess c) ++ "\n" -checkInferenceSuccess :: CategoryMap SourcePos -> [(String, [String])] -> - [String] -> [(String,String)] -> [(String,String)] -> CompileInfo () +checkInferenceSuccess :: CategoryMap SourceContext -> [(String, [String])] -> + [String] -> [(String,String)] -> [(String,String)] -> TrackedErrors () checkInferenceSuccess tm pa is ts gs = checkInferenceCommon check tm pa is ts gs where prefix = show ts ++ " " ++ showParams pa check gs2 c - | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileWarnings c) ++ show (getCompileError c) - | otherwise = getCompileSuccess c `containsExactly` gs2 + | isCompilerError c = compilerErrorM $ prefix ++ ":\n" ++ show (getCompilerWarnings c) ++ show (getCompilerError c) + | otherwise = getCompilerSuccess c `containsExactly` gs2 -checkInferenceFail :: CategoryMap SourcePos -> [(String, [String])] -> - [String] -> [(String,String)] -> CompileInfo () +checkInferenceFail :: CategoryMap SourceContext -> [(String, [String])] -> + [String] -> [(String,String)] -> TrackedErrors () checkInferenceFail tm pa is ts = checkInferenceCommon check tm pa is ts [] where prefix = show ts ++ " " ++ showParams pa check _ c - | isCompileError c = return () - | otherwise = compileErrorM $ prefix ++ ": Expected failure\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ prefix ++ ": Expected failure\n" -checkInferenceCommon :: ([InferredTypeGuess] -> CompileInfo [InferredTypeGuess] -> CompileInfo ()) -> - CategoryMap SourcePos -> [(String,[String])] -> [String] -> - [(String,String)] -> [(String,String)] -> CompileInfo () +checkInferenceCommon :: ([InferredTypeGuess] -> TrackedErrors [InferredTypeGuess] -> TrackedErrors ()) -> + CategoryMap SourceContext -> [(String,[String])] -> [String] -> + [(String,String)] -> [(String,String)] -> TrackedErrors () checkInferenceCommon check tm pa is ts gs = checked GeneralInstance -> IO (CompileInfo ()) +checkParseSuccess :: String -> GeneralInstance -> IO (TrackedErrors ()) checkParseSuccess x y = return $ do t <- readSingle "(string)" x IO (CompileInfo ()) +checkParseFail :: String -> IO (TrackedErrors ()) checkParseFail x = return $ do - let t = readSingle "(string)" x :: CompileInfo GeneralInstance - when (not $ isCompileError t) $ - compileErrorM $ "Expected failure to parse " ++ show x ++ - " but got " ++ show (getCompileSuccess t) + let t = readSingle "(string)" x :: TrackedErrors GeneralInstance + when (not $ isCompilerError t) $ + compilerErrorM $ "Expected failure to parse " ++ show x ++ + " but got " ++ show (getCompilerSuccess t) -checkSimpleConvertSuccess :: String -> String -> IO (CompileInfo ()) +checkSimpleConvertSuccess :: String -> String -> IO (TrackedErrors ()) checkSimpleConvertSuccess = checkConvertSuccess [] -checkSimpleConvertFail :: String -> String -> IO (CompileInfo ()) +checkSimpleConvertFail :: String -> String -> IO (TrackedErrors ()) checkSimpleConvertFail = checkConvertFail [] -checkConvertSuccess :: [(String, [String])] -> String -> String -> IO (CompileInfo ()) +checkConvertSuccess :: [(String, [String])] -> String -> String -> IO (TrackedErrors ()) checkConvertSuccess pa x y = return checked where prefix = x ++ " -> " ++ y ++ " " ++ showParams pa checked = do ([t1,t2],pa2) <- parseTheTest pa [x,y] check $ checkValueAssignment Resolver pa2 t1 t2 check c - | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileError c) + | isCompilerError c = compilerErrorM $ prefix ++ ":\n" ++ show (getCompilerError c) | otherwise = return () checkInferenceSuccess :: [(String, [String])] -> [String] -> String -> - String -> MergeTree (String,String,Variance) -> IO (CompileInfo ()) + String -> MergeTree (String,String,Variance) -> IO (TrackedErrors ()) checkInferenceSuccess pa is x y gs = checkInferenceCommon check pa is x y gs where prefix = x ++ " -> " ++ y ++ " " ++ showParams pa check gs2 c - | isCompileError c = compileErrorM $ prefix ++ ":\n" ++ show (getCompileError c) - | otherwise = getCompileSuccess c `checkEquals` gs2 + | isCompilerError c = compilerErrorM $ prefix ++ ":\n" ++ show (getCompilerError c) + | otherwise = getCompilerSuccess c `checkEquals` gs2 checkInferenceFail :: [(String, [String])] -> [String] -> String -> - String -> IO (CompileInfo ()) + String -> IO (TrackedErrors ()) checkInferenceFail pa is x y = checkInferenceCommon check pa is x y (mergeAll []) where prefix = x ++ " -> " ++ y ++ " " ++ showParams pa check _ c - | isCompileError c = return () - | otherwise = compileErrorM $ prefix ++ ": Expected failure\n" + | isCompilerError c = return () + | otherwise = compilerErrorM $ prefix ++ ": Expected failure\n" checkInferenceCommon :: - (MergeTree InferredTypeGuess -> CompileInfo (MergeTree InferredTypeGuess) -> CompileInfo ()) -> + (MergeTree InferredTypeGuess -> TrackedErrors (MergeTree InferredTypeGuess) -> TrackedErrors ()) -> [(String, [String])] -> [String] -> String -> String -> - MergeTree (String,String,Variance) -> IO (CompileInfo ()) + MergeTree (String,String,Variance) -> IO (TrackedErrors ()) checkInferenceCommon check pa is x y gs = return $ checked String -> String -> IO (CompileInfo ()) +checkConvertFail :: [(String, [String])] -> String -> String -> IO (TrackedErrors ()) checkConvertFail pa x y = return checked where prefix = x ++ " /> " ++ y ++ " " ++ showParams pa checked = do ([t1,t2],pa2) <- parseTheTest pa [x,y] check $ checkValueAssignment Resolver pa2 t1 t2 - 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" data Resolver = Resolver @@ -953,7 +951,7 @@ -- Type5 is concrete, somewhat arbitrarily. trConcrete _ = \t -> return (t == type5) -getParams :: CompileErrorM m => +getParams :: CollectErrorsM m => Map.Map CategoryName (Map.Map CategoryName (InstanceParams -> InstanceParams)) -> TypeInstance -> CategoryName -> m InstanceParams getParams ma (TypeInstance n1 ps1) n2 = do @@ -961,17 +959,17 @@ f <- mapLookup ra n2 TypeInstance -> m InstanceFilters +getTypeFilters :: CollectErrorsM m => TypeInstance -> m InstanceFilters getTypeFilters (TypeInstance n ps) = "In type filters lookup" ??> do f <- mapLookup typeFilters n return $ f ps -getDefinesFilters :: CompileErrorM m => DefinesInstance -> m InstanceFilters +getDefinesFilters :: CollectErrorsM m => DefinesInstance -> m InstanceFilters getDefinesFilters (DefinesInstance n ps) = "In defines filters lookup" ??> do f <- mapLookup definesFilters n return $ f ps -mapLookup :: (Ord n, Show n, CompileErrorM m) => Map.Map n a -> n -> m a +mapLookup :: (Ord n, Show n, CollectErrorsM m) => Map.Map n a -> n -> m a mapLookup ma n = resolve $ n `Map.lookup` ma where resolve (Just x) = return x - resolve _ = compileErrorM $ "Map key " ++ show n ++ " not found" + resolve _ = compilerErrorM $ "Map key " ++ show n ++ " not found" diff --git a/src/Types/DefinedCategory.hs b/src/Types/DefinedCategory.hs --- a/src/Types/DefinedCategory.hs +++ b/src/Types/DefinedCategory.hs @@ -32,9 +32,9 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Base.CompileError +import Base.CompilerError +import Base.Positional import Types.Function -import Types.Positional import Types.Procedure import Types.TypeCategory import Types.TypeInstance @@ -77,7 +77,7 @@ vvWritable :: Bool } -setInternalFunctions :: (Show c, CompileErrorM m, TypeResolver r) => +setInternalFunctions :: (Show c, CollectErrorsM m, TypeResolver r) => r -> AnyCategory c -> [ScopedFunction c] -> m (Map.Map FunctionName (ScopedFunction c)) setInternalFunctions r t fs = do @@ -98,7 +98,7 @@ checkFunctionConvert r fm pm f0' f' return $ Map.insert n (ScopedFunction (c++c2) n t2 s as rs ps fs2 ([f0]++ms++ms2)) fa' -pairProceduresToFunctions :: (Show c, CompileErrorM m) => +pairProceduresToFunctions :: (Show c, CollectErrorsM m) => Map.Map FunctionName (ScopedFunction c) -> [ExecutableProcedure c] -> m [(ScopedFunction c,ExecutableProcedure c)] pairProceduresToFunctions fa ps = do @@ -111,7 +111,7 @@ case epName p `Map.lookup` pa' of Nothing -> return () -- TODO: The error might show things in the wrong order. - (Just p0) -> compileErrorM $ "Procedure " ++ show (epName p) ++ + (Just p0) -> compilerErrorM $ "Procedure " ++ show (epName p) ++ formatFullContextBrace (epContext p) ++ " is already defined" ++ formatFullContextBrace (epContext p0) @@ -121,11 +121,11 @@ p <- getPair (n `Map.lookup` fa2) (n `Map.lookup` pa) return (p:ps2') getPair (Just f) Nothing = - compileErrorM $ "Function " ++ show (sfName f) ++ + compilerErrorM $ "Function " ++ show (sfName f) ++ formatFullContextBrace (sfContext f) ++ " has no procedure definition" getPair Nothing (Just p) = - compileErrorM $ "Procedure " ++ show (epName p) ++ + compilerErrorM $ "Procedure " ++ show (epName p) ++ formatFullContextBrace (epContext p) ++ " does not correspond to a function" getPair (Just f) (Just p) = do @@ -146,7 +146,7 @@ return (f,p) getPair _ _ = undefined -mapMembers :: (Show c, CompileErrorM m) => +mapMembers :: (Show c, CollectErrorsM m) => [DefinedMember c] -> m (Map.Map VariableName (VariableValue c)) mapMembers ms = foldr update (return Map.empty) ms where update m ma = do @@ -154,14 +154,14 @@ case dmName m `Map.lookup` ma' of Nothing -> return () -- TODO: The error might show things in the wrong order. - (Just m0) -> compileErrorM $ "Member " ++ show (dmName m) ++ + (Just m0) -> compilerErrorM $ "Member " ++ show (dmName m) ++ formatFullContextBrace (dmContext m) ++ " is already defined" ++ formatFullContextBrace (vvContext m0) return $ Map.insert (dmName m) (VariableValue (dmContext m) (dmScope m) (dmType m) True) ma' -- TODO: Most of this duplicates parts of flattenAllConnections. -mergeInternalInheritance :: (Show c, CompileErrorM m) => +mergeInternalInheritance :: (Show c, CollectErrorsM m) => CategoryMap c -> DefinedCategory c -> m (CategoryMap c) mergeInternalInheritance tm d = do let rs2 = dcRefines d diff --git a/src/Types/Function.hs b/src/Types/Function.hs --- a/src/Types/Function.hs +++ b/src/Types/Function.hs @@ -29,9 +29,9 @@ import Control.Monad (when) import qualified Data.Map as Map -import Base.CompileError -import Types.GeneralType -import Types.Positional +import Base.CompilerError +import Base.GeneralType +import Base.Positional import Types.TypeInstance import Types.Variance @@ -54,7 +54,7 @@ where showFilters (n,fs) = map (\f -> show n ++ " " ++ show f ++ " ") fs -validatateFunctionType :: (CompileErrorM m, TypeResolver r) => +validatateFunctionType :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> ParamVariances -> FunctionType -> m () validatateFunctionType r fm vm (FunctionType as rs ps fa) = do mapErrorsM_ checkCount $ group $ sort $ pValues ps @@ -69,11 +69,11 @@ where allVariances = Map.union vm (Map.fromList $ zip (pValues ps) (repeat Invariant)) checkCount xa@(x:_:_) = - compileErrorM $ "Function parameter " ++ show x ++ " occurs " ++ show (length xa) ++ " times" + compilerErrorM $ "Function parameter " ++ show x ++ " occurs " ++ show (length xa) ++ " times" checkCount _ = return () checkHides n = when (n `Map.member` fm) $ - compileErrorM $ "Function parameter " ++ show n ++ " hides a category-level parameter" + compilerErrorM $ "Function parameter " ++ show n ++ " hides a category-level parameter" checkFilterType fa2 (n,f) = validateTypeFilter r fa2 f do - when (isWeakValue ta) $ compileErrorM "Weak values not allowed as argument types" + when (isWeakValue ta) $ compilerErrorM "Weak values not allowed as argument types" validateGeneralInstance r fa2 t validateInstanceVariance r allVariances Contravariant t checkReturn fa2 ta@(ValueType _ t) = ("In return " ++ show ta) ??> do - when (isWeakValue ta) $ compileErrorM "Weak values not allowed as return types" + when (isWeakValue ta) $ compilerErrorM "Weak values not allowed as return types" validateGeneralInstance r fa2 t validateInstanceVariance r allVariances Covariant t -assignFunctionParams :: (CompileErrorM m, TypeResolver r) => +assignFunctionParams :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> ParamValues -> Positional GeneralInstance -> FunctionType -> m FunctionType assignFunctionParams r fm pm ts (FunctionType as rs ps fa) = do @@ -111,7 +111,7 @@ where assignFilters fm2 fs = mapErrorsM (uncheckedSubFilter $ getValueForParam fm2) fs -checkFunctionConvert :: (CompileErrorM m, TypeResolver r) => +checkFunctionConvert :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> ParamValues -> FunctionType -> FunctionType -> m () checkFunctionConvert r fm pm (FunctionType as1 rs1 ps1 fa1) ff2 = do mapped <- fmap Map.fromList $ processPairs alwaysPair ps1 fa1 diff --git a/src/Types/GeneralType.hs b/src/Types/GeneralType.hs deleted file mode 100644 --- a/src/Types/GeneralType.hs +++ /dev/null @@ -1,78 +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 Safe #-} -{-# LANGUAGE TypeFamilies #-} - -module Types.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 .) diff --git a/src/Types/IntegrationTest.hs b/src/Types/IntegrationTest.hs --- a/src/Types/IntegrationTest.hs +++ b/src/Types/IntegrationTest.hs @@ -26,7 +26,7 @@ OutputScope(..), getExcludePattern, getRequirePattern, - isExpectCompileError, + isExpectCompilerError, isExpectCompiles, isExpectRuntimeError, isExpectRuntimeSuccess, @@ -54,7 +54,7 @@ } data ExpectedResult c = - ExpectCompileError { + ExpectCompilerError { eceContext :: [c], eceRequirePattern :: [OutputPattern], eceExcludePattern :: [OutputPattern] @@ -88,9 +88,9 @@ isExpectCompiles (ExpectCompiles _ _ _) = True isExpectCompiles _ = False -isExpectCompileError :: ExpectedResult c -> Bool -isExpectCompileError (ExpectCompileError _ _ _) = True -isExpectCompileError _ = False +isExpectCompilerError :: ExpectedResult c -> Bool +isExpectCompilerError (ExpectCompilerError _ _ _) = True +isExpectCompilerError _ = False isExpectRuntimeError :: ExpectedResult c -> Bool isExpectRuntimeError (ExpectRuntimeError _ _ _) = True @@ -102,12 +102,12 @@ getRequirePattern :: ExpectedResult c -> [OutputPattern] getRequirePattern (ExpectCompiles _ rs _) = rs -getRequirePattern (ExpectCompileError _ rs _) = rs +getRequirePattern (ExpectCompilerError _ rs _) = rs getRequirePattern (ExpectRuntimeError _ rs _) = rs getRequirePattern (ExpectRuntimeSuccess _ rs _) = rs getExcludePattern :: ExpectedResult c -> [OutputPattern] getExcludePattern (ExpectCompiles _ _ es) = es -getExcludePattern (ExpectCompileError _ _ es) = es +getExcludePattern (ExpectCompilerError _ _ es) = es getExcludePattern (ExpectRuntimeError _ _ es) = es getExcludePattern (ExpectRuntimeSuccess _ _ es) = es diff --git a/src/Types/Positional.hs b/src/Types/Positional.hs deleted file mode 100644 --- a/src/Types/Positional.hs +++ /dev/null @@ -1,70 +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] - -module Types.Positional ( - Positional(..), - alwaysPair, - processPairs, - processPairs_, - processPairsM, - processPairsT, -) where - -import Control.Monad.Trans (MonadTrans(..)) - -import Base.CompileError -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, CompileErrorM 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, CompileErrorM m) => - (a -> b -> m c) -> Positional a -> Positional b -> m c -processPairsM f x y = fmap mergeAll $ processPairs f x y - -processPairs_ :: (Show a, Show b, CompileErrorM m) => - (a -> b -> m c) -> Positional a -> Positional b -> m () -processPairs_ f xs ys = processPairs f xs ys >> return () - -processPairsT :: (MonadTrans t, Monad (t m), Show a, Show b, CompileErrorM 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, CompileErrorM m) => [a] -> [b] -> m c -mismatchError ps1 ps2 = compileErrorM $ "Count mismatch: " ++ show ps1 ++ - " (expected) vs. " ++ show ps2 ++ " (actual)" diff --git a/src/Types/Procedure.hs b/src/Types/Procedure.hs --- a/src/Types/Procedure.hs +++ b/src/Types/Procedure.hs @@ -47,13 +47,14 @@ getStatementContext, isDiscardedInput, isLiteralCategory, + isRawCodeLine, isUnnamedReturns, ) where import Data.List (intercalate) +import Base.Positional import Types.Pragma -import Types.Positional import Types.TypeCategory import Types.TypeInstance @@ -160,9 +161,14 @@ FailCall [c] (Expression c) | IgnoreValues [c] (Expression c) | Assignment [c] (Positional (Assignable c)) (Expression c) | - NoValueExpression [c] (VoidExpression c) + NoValueExpression [c] (VoidExpression c) | + RawCodeLine String deriving (Show) +isRawCodeLine :: Statement c -> Bool +isRawCodeLine (RawCodeLine _) = True +isRawCodeLine _ = False + getStatementContext :: Statement c -> [c] getStatementContext (EmptyReturn c) = c getStatementContext (ExplicitReturn c _) = c @@ -172,6 +178,7 @@ getStatementContext (IgnoreValues c _) = c getStatementContext (Assignment c _ _) = c getStatementContext (NoValueExpression c _) = c +getStatementContext (RawCodeLine _) = [] data Assignable c = CreateVariable [c] ValueType VariableName | @@ -202,7 +209,7 @@ deriving (Show) data ScopedBlock c = - ScopedBlock [c] (Procedure c) (Maybe (Procedure c)) (Statement c) + ScopedBlock [c] (Procedure c) (Maybe (Procedure c)) [c] (Statement c) deriving (Show) data Expression c = diff --git a/src/Types/TypeCategory.hs b/src/Types/TypeCategory.hs --- a/src/Types/TypeCategory.hs +++ b/src/Types/TypeCategory.hs @@ -88,12 +88,12 @@ 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.Mergeable +import Base.Positional import Types.Function -import Types.GeneralType -import Types.Positional import Types.TypeInstance import Types.Variance @@ -335,7 +335,7 @@ let pa = Map.fromList $ map (\r -> (tiName r,tiParams r)) $ map vrType $ getCategoryRefines t ps2 <- case n2 `Map.lookup` pa of (Just x) -> return x - _ -> compileErrorM $ "Category " ++ show n1 ++ " does not refine " ++ show n2 + _ -> compilerErrorM $ "Category " ++ show n1 ++ " does not refine " ++ show n2 fmap Positional $ mapErrorsM (subAllParams assigned) $ pValues ps2 trDefines (CategoryResolver tm) (TypeInstance n1 ps1) n2 = do (_,t) <- getValueCategory tm ([],n1) @@ -344,7 +344,7 @@ let pa = Map.fromList $ map (\r -> (diName r,diParams r)) $ map vdType $ getCategoryDefines t ps2 <- case n2 `Map.lookup` pa of (Just x) -> return x - _ -> compileErrorM $ "Category " ++ show n1 ++ " does not define " ++ show n2 + _ -> compilerErrorM $ "Category " ++ show n1 ++ " does not define " ++ show n2 fmap Positional $ mapErrorsM (subAllParams assigned) $ pValues ps2 trVariance (CategoryResolver tm) n = do (_,t) <- getCategory tm ([],n) @@ -381,7 +381,7 @@ | f x == ValueScope = (cs,ts,x:vs) | otherwise = (cs,ts,vs) -checkFilters :: CompileErrorM m => +checkFilters :: CollectErrorsM m => AnyCategory c -> Positional GeneralInstance -> m (Positional [TypeFilter]) checkFilters t ps = do let params = map vpParam $ getCategoryParams t @@ -401,54 +401,54 @@ (Just x) -> return x _ -> return [] -subAllParams :: CompileErrorM m => +subAllParams :: CollectErrorsM m => ParamValues -> GeneralInstance -> m GeneralInstance subAllParams pa = uncheckedSubInstance (getValueForParam pa) type CategoryMap c = Map.Map CategoryName (AnyCategory c) -getCategory :: (Show c, CompileErrorM m) => +getCategory :: (Show c, CollectErrorsM m) => CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c) getCategory tm (c,n) = case n `Map.lookup` tm of (Just t) -> return (c,t) - _ -> compileErrorM $ "Type " ++ show n ++ context ++ " not found" + _ -> compilerErrorM $ "Type " ++ show n ++ context ++ " not found" where context | null c = "" | otherwise = formatFullContextBrace c -getValueCategory :: (Show c, CompileErrorM m) => +getValueCategory :: (Show c, CollectErrorsM m) => CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c) getValueCategory tm (c,n) = do (c2,t) <- getCategory tm (c,n) if isValueInterface t || isValueConcrete t then return (c2,t) - else compileErrorM $ "Category " ++ show n ++ + else compilerErrorM $ "Category " ++ show n ++ " cannot be used as a value" ++ formatFullContextBrace c -getInstanceCategory :: (Show c, CompileErrorM m) => +getInstanceCategory :: (Show c, CollectErrorsM m) => CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c) getInstanceCategory tm (c,n) = do (c2,t) <- getCategory tm (c,n) if isInstanceInterface t then return (c2,t) - else compileErrorM $ "Category " ++ show n ++ + else compilerErrorM $ "Category " ++ show n ++ " cannot be used as a type interface" ++ formatFullContextBrace c -getConcreteCategory :: (Show c, CompileErrorM m) => +getConcreteCategory :: (Show c, CollectErrorsM m) => CategoryMap c -> ([c],CategoryName) -> m ([c],AnyCategory c) getConcreteCategory tm (c,n) = do (c2,t) <- getCategory tm (c,n) if isValueConcrete t then return (c2,t) - else compileErrorM $ "Category " ++ show n ++ + else compilerErrorM $ "Category " ++ show n ++ " cannot be used as concrete" ++ formatFullContextBrace c -includeNewTypes :: (Show c, CompileErrorM m) => +includeNewTypes :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m (CategoryMap c) includeNewTypes tm0 ts = do checkConnectionCycles tm0 ts @@ -459,18 +459,18 @@ checkCategoryInstances tm0 ts3 declareAllTypes tm0 ts3 -declareAllTypes :: (Show c, CompileErrorM m) => +declareAllTypes :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m (CategoryMap c) declareAllTypes tm0 = foldr (\t tm -> tm >>= update t) (return tm0) where update t tm = case getCategoryName t `Map.lookup` tm of - (Just t2) -> compileErrorM $ "Type " ++ show (getCategoryName t) ++ + (Just t2) -> compilerErrorM $ "Type " ++ show (getCategoryName t) ++ formatFullContextBrace (getCategoryContext t) ++ " has already been declared" ++ formatFullContextBrace (getCategoryContext t2) _ -> return $ Map.insert (getCategoryName t) t tm -getFilterMap :: CompileErrorM m => [ValueParam c] -> [ParamFilter c] -> m ParamFilters +getFilterMap :: CollectErrorsM m => [ValueParam c] -> [ParamFilter c] -> m ParamFilters getFilterMap ps fs = do mirrored <- fmap concat $ mapErrorsM maybeMirror fs return $ getFilters mirrored $ zip (Set.toList pa) (repeat []) where @@ -487,32 +487,32 @@ getFilters fs2 pa0 = let fs' = map (\f -> (pfParam f,pfFilter f)) fs2 in Map.fromListWith (++) $ map (second (:[])) fs' ++ pa0 -getCategoryFilterMap :: CompileErrorM m => AnyCategory c -> m ParamFilters +getCategoryFilterMap :: CollectErrorsM m => AnyCategory c -> m ParamFilters getCategoryFilterMap t = getFilterMap (getCategoryParams t) (getCategoryFilters t) -- TODO: Use this where it's needed in this file. -getFunctionFilterMap :: CompileErrorM m => ScopedFunction c -> m ParamFilters +getFunctionFilterMap :: CollectErrorsM m => ScopedFunction c -> m ParamFilters getFunctionFilterMap f = getFilterMap (pValues $ sfParams f) (sfFilters f) getCategoryParamMap :: AnyCategory c -> ParamValues getCategoryParamMap t = let ps = map vpParam $ getCategoryParams t in Map.fromList $ zip ps (map (singleType . JustParamName False) ps) -disallowBoundedParams :: CompileErrorM m => ParamFilters -> m () +disallowBoundedParams :: CollectErrorsM m => ParamFilters -> m () disallowBoundedParams = mapErrorsM_ checkBounds . Map.toList where checkBounds (p,fs) = do let (lb,ub) = foldr splitBounds (minBound,maxBound) fs when (lb /= minBound && ub /= maxBound) $ ("Param " ++ show p ++ " cannot have both lower and upper bounds") !!> collectAllM_ [ - compileErrorM $ "Lower bound: " ++ show lb, - compileErrorM $ "Upper bound: " ++ show ub + compilerErrorM $ "Lower bound: " ++ show lb, + compilerErrorM $ "Upper bound: " ++ show ub ] splitBounds (TypeFilter FilterRequires t) (lb,ub) = (lb,t<&&>ub) splitBounds (TypeFilter FilterAllows t) (lb,ub) = (t<||>lb,ub) splitBounds _ bs = bs -checkConnectedTypes :: (Show c, CompileErrorM m) => +checkConnectedTypes :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m () checkConnectedTypes tm0 ts = do tm <- declareAllTypes tm0 ts @@ -535,44 +535,44 @@ checkSingle _ _ = return () valueRefinesInstanceError c n (c2,t) | isInstanceInterface t = - compileErrorM $ "Value interface " ++ show n ++ formatFullContextBrace c ++ + compilerErrorM $ "Value interface " ++ show n ++ formatFullContextBrace c ++ " cannot refine type interface " ++ show (iiName t) ++ formatFullContextBrace c2 | otherwise = return () valueRefinesConcreteError c n (c2,t) | isValueConcrete t = - compileErrorM $ "Value interface " ++ show n ++ formatFullContextBrace c ++ + compilerErrorM $ "Value interface " ++ show n ++ formatFullContextBrace c ++ " cannot refine concrete type " ++ show (getCategoryName t) ++ formatFullContextBrace c2 | otherwise = return () concreteRefinesInstanceError c n (c2,t) | isInstanceInterface t = - compileErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ + compilerErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ " cannot refine instance interface " ++ show (getCategoryName t) ++ formatFullContextBrace c2 ++ " => use defines instead" | otherwise = return () concreteDefinesValueError c n (c2,t) | isValueInterface t = - compileErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ + compilerErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ " cannot define value interface " ++ show (getCategoryName t) ++ formatFullContextBrace c2 ++ " => use refines instead" | otherwise = return () concreteRefinesConcreteError c n (c2,t) | isValueConcrete t = - compileErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ + compilerErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ " cannot refine concrete type " ++ show (getCategoryName t) ++ formatFullContextBrace c2 | otherwise = return () concreteDefinesConcreteError c n (c2,t) | isValueConcrete t = - compileErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ + compilerErrorM $ "Concrete type " ++ show n ++ formatFullContextBrace c ++ " cannot define concrete type " ++ show (getCategoryName t) ++ formatFullContextBrace c2 | otherwise = return () -checkConnectionCycles :: (Show c, CompileErrorM m) => +checkConnectionCycles :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m () checkConnectionCycles tm0 ts = collectAllM_ (map (checker []) ts) where tm = Map.union tm0 $ Map.fromList $ zip (map getCategoryName ts) ts @@ -589,11 +589,11 @@ checker _ _ = return () failIfCycle n c us = when (n `Set.member` (Set.fromList us)) $ - compileErrorM $ "Category " ++ show n ++ formatFullContextBrace c ++ + compilerErrorM $ "Category " ++ show n ++ formatFullContextBrace c ++ " refers back to itself: " ++ intercalate " -> " (map show (us ++ [n])) -checkParamVariances :: (Show c, CompileErrorM m) => +checkParamVariances :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m () checkParamVariances tm0 ts = do tm <- declareAllTypes tm0 ts @@ -621,7 +621,7 @@ mapErrorsM_ (checkFilterVariance r vm) fa noDuplicates c n ps = collectAllM_ (map checkCount $ group $ sort $ map vpParam ps) where checkCount xa@(x:_:_) = - compileErrorM $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++ + compilerErrorM $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++ " times in " ++ show n ++ formatFullContextBrace c checkCount _ = return () checkRefine r vm (ValueRefine c t) = @@ -633,29 +633,29 @@ checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterRequires t)) = ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) ??> do case n `Map.lookup` vs of - Just Contravariant -> compileErrorM $ "Contravariant param " ++ show n ++ + Just Contravariant -> compilerErrorM $ "Contravariant param " ++ show n ++ " cannot have a requires filter" - Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined" + Nothing -> compilerErrorM $ "Param " ++ show n ++ " is undefined" _ -> return () validateInstanceVariance r vs Contravariant t checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterAllows t)) = ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) ??> do case n `Map.lookup` vs of - Just Covariant -> compileErrorM $ "Covariant param " ++ show n ++ + Just Covariant -> compilerErrorM $ "Covariant param " ++ show n ++ " cannot have an allows filter" - Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined" + Nothing -> compilerErrorM $ "Param " ++ show n ++ " is undefined" _ -> return () validateInstanceVariance r vs Covariant t checkFilterVariance r vs (ParamFilter c n f@(DefinesFilter t)) = ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) ??> do case n `Map.lookup` vs of - Just Contravariant -> compileErrorM $ "Contravariant param " ++ show n ++ + Just Contravariant -> compilerErrorM $ "Contravariant param " ++ show n ++ " cannot have a defines filter" - Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined" + Nothing -> compilerErrorM $ "Param " ++ show n ++ " is undefined" _ -> return () validateDefinesVariance r vs Contravariant t -checkCategoryInstances :: (Show c, CompileErrorM m) => +checkCategoryInstances :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m () checkCategoryInstances tm0 ts = do tm <- declareAllTypes tm0 ts @@ -672,7 +672,7 @@ mapErrorsM_ (validateCategoryFunction r t) (getCategoryFunctions t) checkFilterParam pa (ParamFilter c n _) = when (not $ n `Set.member` pa) $ - compileErrorM $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist" + compilerErrorM $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist" checkRefine r fm (ValueRefine c t) = validateTypeInstance r fm t +validateCategoryFunction :: (Show c, CollectErrorsM m, TypeResolver r) => r -> AnyCategory c -> ScopedFunction c -> m () validateCategoryFunction r t f = do fm <- getCategoryFilterMap t @@ -701,7 +701,7 @@ | otherwise = "In function inherited from " ++ show (sfType f) ++ formatFullContextBrace (getCategoryContext t) ++ ":\n---\n" ++ show f ++ "\n---\n" -topoSortCategories :: (Show c, CompileErrorM m) => +topoSortCategories :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m [AnyCategory c] topoSortCategories tm0 ts = do tm <- declareAllTypes tm0 ts @@ -719,7 +719,7 @@ update _ ta _ = return ([],ta) -- For fixed x, if f y x succeeds for some y then x is removed. -mergeObjects :: CompileErrorM m => (a -> a -> m b) -> [a] -> m [a] +mergeObjects :: CollectErrorsM m => (a -> a -> m b) -> [a] -> m [a] mergeObjects f = merge [] where merge cs [] = return cs merge cs (x:xs) = do @@ -727,49 +727,49 @@ merge (cs ++ ys) xs where check x2 = x2 `f` x >> return [] -mergeRefines :: (CompileErrorM m, TypeResolver r) => +mergeRefines :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> [ValueRefine c] -> m [ValueRefine c] mergeRefines r f = mergeObjects check where check (ValueRefine _ t1@(TypeInstance n1 _)) (ValueRefine _ t2@(TypeInstance n2 _)) - | n1 /= n2 = compileErrorM $ show t1 ++ " and " ++ show t2 ++ " are incompatible" + | n1 /= n2 = compilerErrorM $ show t1 ++ " and " ++ show t2 ++ " are incompatible" | otherwise = noInferredTypes $ checkGeneralMatch r f Covariant (singleType $ JustTypeInstance $ t1) (singleType $ JustTypeInstance $ t2) -mergeDefines :: (CompileErrorM m, TypeResolver r) => +mergeDefines :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> [ValueDefine c] -> m [ValueDefine c] mergeDefines r f = mergeObjects check where check (ValueDefine _ t1@(DefinesInstance n1 _)) (ValueDefine _ t2@(DefinesInstance n2 _)) - | n1 /= n2 = compileErrorM $ show t1 ++ " and " ++ show t2 ++ " are incompatible" + | n1 /= n2 = compilerErrorM $ show t1 ++ " and " ++ show t2 ++ " are incompatible" | otherwise = do checkDefinesMatch r f t1 t2 return () -noDuplicateRefines :: (Show c, CompileErrorM m) => +noDuplicateRefines :: (Show c, CollectErrorsM m) => [c] -> CategoryName -> [ValueRefine c] -> m () noDuplicateRefines c n rs = do let names = map (\r -> (tiName $ vrType r,r)) rs noDuplicateCategories c n names -noDuplicateDefines :: (Show c, CompileErrorM m) => +noDuplicateDefines :: (Show c, CollectErrorsM m) => [c] -> CategoryName -> [ValueDefine c] -> m () noDuplicateDefines c n ds = do let names = map (\d -> (diName $ vdType d,d)) ds noDuplicateCategories c n names -noDuplicateCategories :: (Show c, Show a, CompileErrorM m) => +noDuplicateCategories :: (Show c, Show a, CollectErrorsM m) => [c] -> CategoryName -> [(CategoryName,a)] -> m () noDuplicateCategories c n ns = mapErrorsM_ checkCount $ groupBy (\x y -> fst x == fst y) $ sortBy (\x y -> fst x `compare` fst y) ns where checkCount xa@(x:_:_) = - compileErrorM $ "Category " ++ show (fst x) ++ " occurs " ++ show (length xa) ++ + compilerErrorM $ "Category " ++ show (fst x) ++ " occurs " ++ show (length xa) ++ " times in " ++ show n ++ formatFullContextBrace c ++ " :\n---\n" ++ intercalate "\n---\n" (map (show . snd) xa) checkCount _ = return () -flattenAllConnections :: (Show c, CompileErrorM m) => +flattenAllConnections :: (Show c, CollectErrorsM m) => CategoryMap c -> [AnyCategory c] -> m [AnyCategory c] flattenAllConnections tm0 ts = do -- We need to process all refines before type-checking can be done. @@ -843,7 +843,7 @@ return () checkConvert _ _ _ _ = return () -mergeFunctions :: (Show c, CompileErrorM m, TypeResolver r) => +mergeFunctions :: (Show c, CollectErrorsM m, TypeResolver r) => r -> CategoryMap c -> ParamValues -> ParamFilters -> [ValueRefine c] -> [ValueDefine c] -> [ScopedFunction c] -> m [ScopedFunction c] mergeFunctions r tm pm fm rs ds fs = do @@ -872,14 +872,14 @@ -- Inherited without an override. tryMerge _ _ n (Just is) Nothing | length is == 1 = return $ head is - | otherwise = compileErrorM $ "Function " ++ show n ++ " is inherited " ++ + | otherwise = compilerErrorM $ "Function " ++ show n ++ " is inherited " ++ show (length is) ++ " times:\n---\n" ++ intercalate "\n---\n" (map show is) -- Not inherited. tryMerge r2 fm2 n Nothing es = tryMerge r2 fm2 n (Just []) es -- Explicit override, possibly inherited. tryMerge r2 fm2 n (Just is) (Just es) - | length es /= 1 = compileErrorM $ "Function " ++ show n ++ " is declared " ++ + | length es /= 1 = compilerErrorM $ "Function " ++ show n ++ " is declared " ++ show (length es) ++ " times:\n---\n" ++ intercalate "\n---\n" (map show es) | otherwise = do @@ -889,7 +889,7 @@ where checkMerge r3 fm3 f1 f2 | sfScope f1 /= sfScope f2 = - compileErrorM $ "Cannot merge " ++ show (sfScope f2) ++ " with " ++ + compilerErrorM $ "Cannot merge " ++ show (sfScope f2) ++ " with " ++ show (sfScope f1) ++ " in function merge:\n---\n" ++ show f2 ++ "\n ->\n" ++ show f1 | otherwise = @@ -962,7 +962,7 @@ instance Show c => Show (PassedValue c) where show (PassedValue c t) = show t ++ formatFullContextBrace c -parsedToFunctionType :: (Show c, CompileErrorM m) => +parsedToFunctionType :: (Show c, CollectErrorsM m) => ScopedFunction c -> m FunctionType parsedToFunctionType (ScopedFunction c n _ _ as rs ps fa _) = do let as' = Positional $ map pvType $ pValues as @@ -976,7 +976,7 @@ pa = Set.fromList $ map vpParam $ pValues ps checkFilter f = when (not $ (pfParam f) `Set.member` pa) $ - compileErrorM $ "Filtered param " ++ show (pfParam f) ++ + compilerErrorM $ "Filtered param " ++ show (pfParam f) ++ " is not defined for function " ++ show n ++ formatFullContextBrace c getFilters fm2 n2 = @@ -984,11 +984,11 @@ (Just fs) -> fs _ -> [] -uncheckedSubFunction :: (Show c, CompileErrorM m) => +uncheckedSubFunction :: (Show c, CollectErrorsM m) => ParamValues -> ScopedFunction c -> m (ScopedFunction c) uncheckedSubFunction = unfixedSubFunction . fmap fixTypeParams -unfixedSubFunction :: (Show c, CompileErrorM m) => +unfixedSubFunction :: (Show c, CollectErrorsM m) => ParamValues -> ScopedFunction c -> m (ScopedFunction c) unfixedSubFunction pa ff@(ScopedFunction c n t s as rs ps fa ms) = ("In function:\n---\n" ++ show ff ++ "\n---\n") ??> do @@ -1019,7 +1019,7 @@ show (PatternMatch Contravariant l r) = show l ++ " <- " ++ show r show (PatternMatch Invariant l r) = show l ++ " <-> " ++ show r -inferParamTypes :: (CompileErrorM m, TypeResolver r) => +inferParamTypes :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> ParamValues -> [PatternMatch ValueType] -> m (MergeTree InferredTypeGuess) inferParamTypes r f ps ts = do @@ -1052,7 +1052,7 @@ guGuesses :: [GuessRange a] } -mergeInferredTypes :: (CompileErrorM m, TypeResolver r) => +mergeInferredTypes :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> ParamFilters -> ParamValues -> MergeTree InferredTypeGuess -> m [InferredTypeGuess] mergeInferredTypes r f ff ps gs0 = do @@ -1085,7 +1085,7 @@ hiZ <- tryMerge Contravariant hiX hiY return [GuessRange loZ hiZ] else return [] - convertsTo t1 t2 = isCompileSuccessM $ checkGeneralMatch r f Covariant t1 t2 + convertsTo t1 t2 = isCompilerSuccessM $ checkGeneralMatch r f Covariant t1 t2 tryMerge v t1 t2 = collectFirstM [ checkGeneralMatch r f v t1 t2 >> return t2, checkGeneralMatch r f v t2 t1 >> return t1, @@ -1128,8 +1128,8 @@ (True,_,_) -> return lo (_,True,False) -> return lo (_,False,True) -> return hi - _ -> compileErrorM (show g) compilerErrorM (show g) do let checkLo = checkSubFilters i lo let checkHi = checkSubFilters i hi - pLo <- isCompileErrorM checkLo - pHi <- isCompileErrorM checkHi + pLo <- isCompilerErrorM checkLo + pHi <- isCompilerErrorM checkHi case (pLo,pHi) of - (True,True) -> collectAllM_ [checkLo,checkHi] >> compileErrorM "" + (True,True) -> collectAllM_ [checkLo,checkHi] >> compilerErrorM "" (True,_) -> return $ GuessRange hi hi (_,True) -> return $ GuessRange lo lo _ -> return $ GuessRange lo hi diff --git a/src/Types/TypeInstance.hs b/src/Types/TypeInstance.hs --- a/src/Types/TypeInstance.hs +++ b/src/Types/TypeInstance.hs @@ -75,11 +75,11 @@ import Data.List (intercalate) import qualified Data.Map as Map -import Base.CompileError +import Base.CompilerError +import Base.GeneralType import Base.MergeTree import Base.Mergeable -import Types.GeneralType -import Types.Positional +import Base.Positional import Types.Variance @@ -266,22 +266,22 @@ class TypeResolver r where -- Performs parameter substitution for refines. - trRefines :: CompileErrorM m => + trRefines :: CollectErrorsM m => r -> TypeInstance -> CategoryName -> m InstanceParams -- Performs parameter substitution for defines. - trDefines :: CompileErrorM m => + trDefines :: CollectErrorsM m => r -> TypeInstance -> CategoryName -> m InstanceParams -- Get the parameter variances for the category. - trVariance :: CompileErrorM m => + trVariance :: CollectErrorsM m => r -> CategoryName -> m InstanceVariances -- Gets filters for the assigned parameters. - trTypeFilters :: CompileErrorM m => + trTypeFilters :: CollectErrorsM m => r -> TypeInstance -> m InstanceFilters -- Gets filters for the assigned parameters. - trDefinesFilters :: CompileErrorM m => + trDefinesFilters :: CollectErrorsM m => r -> DefinesInstance -> m InstanceFilters -- Returns True if the type is concrete. - trConcrete :: CompileErrorM m => + trConcrete :: CollectErrorsM m => r -> CategoryName -> m Bool data AnyTypeResolver = forall r. TypeResolver r => AnyTypeResolver r @@ -294,18 +294,18 @@ trDefinesFilters (AnyTypeResolver r) = trDefinesFilters r trConcrete (AnyTypeResolver r) = trConcrete r -filterLookup :: CompileErrorM m => +filterLookup :: ErrorContextM m => ParamFilters -> ParamName -> m [TypeFilter] filterLookup ps n = resolve $ n `Map.lookup` ps where resolve (Just x) = return x - resolve _ = compileErrorM $ "Param " ++ show n ++ " not found" + resolve _ = compilerErrorM $ "Param " ++ show n ++ " not found" -getValueForParam :: CompileErrorM m => +getValueForParam :: ErrorContextM m => ParamValues -> ParamName -> m GeneralInstance getValueForParam pa n = case n `Map.lookup` pa of (Just x) -> return x - _ -> compileErrorM $ "Param " ++ show n ++ " does not exist" + _ -> compilerErrorM $ "Param " ++ show n ++ " does not exist" fixTypeParams :: GeneralInstance -> GeneralInstance fixTypeParams = setParamsFixed True @@ -324,20 +324,20 @@ mapTypeGuesses = reduceMergeTree mergeAny mergeAll leafToMap where leafToMap i = Map.fromList [(itgParam i,mergeLeaf i)] -noInferredTypes :: CompileErrorM m => m (MergeTree InferredTypeGuess) -> m () +noInferredTypes :: CollectErrorsM m => m (MergeTree InferredTypeGuess) -> m () noInferredTypes g = do g' <- g let gm = mapTypeGuesses g' "Type inference is not allowed here" !!> (mapErrorsM_ format $ Map.elems gm) where - format = compileErrorM . reduceMergeTree showAny showAll show + format = compilerErrorM . reduceMergeTree showAny showAll show showAny gs = "Any of [ " ++ intercalate ", " gs ++ " ]" showAll gs = "All of [ " ++ intercalate ", " gs ++ " ]" -checkValueAssignment :: (CompileErrorM m, TypeResolver r) => +checkValueAssignment :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> ValueType -> ValueType -> m () checkValueAssignment r f t1 t2 = noInferredTypes $ checkValueTypeMatch r f Covariant t1 t2 -checkValueTypeMatch :: (CompileErrorM m, TypeResolver r) => +checkValueTypeMatch :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> Variance -> ValueType -> ValueType -> m (MergeTree InferredTypeGuess) checkValueTypeMatch r f v ts1@(ValueType r1 t1) ts2@(ValueType r2 t2) = result +checkGeneralMatch :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> Variance -> GeneralInstance -> GeneralInstance -> m (MergeTree InferredTypeGuess) checkGeneralMatch r f v t1 t2 = do @@ -366,7 +366,7 @@ pairMergeTree mergeAnyM mergeAllM (checkSingleMatch r f Covariant) t1 t2 matchInferredRight = matchOnlyLeaf t2 >>= inferFrom inferFrom (JustInferredType p) = return $ mergeLeaf $ InferredTypeGuess p t1 v - inferFrom _ = compileErrorM "" + inferFrom _ = compilerErrorM "" bothSingle = do t1' <- matchOnlyLeaf t1 t2' <- matchOnlyLeaf t2 @@ -376,11 +376,11 @@ Just (t1',t2') -> checkSingleMatch r f v t1' t2' Nothing -> matchNormal v -checkSingleMatch :: (CompileErrorM m, TypeResolver r) => +checkSingleMatch :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> Variance -> TypeInstanceOrParam -> TypeInstanceOrParam -> m (MergeTree InferredTypeGuess) checkSingleMatch _ _ _ (JustInferredType p1) _ = - compileErrorM $ "Inferred parameter " ++ show p1 ++ " is not allowed on the left" + compilerErrorM $ "Inferred parameter " ++ show p1 ++ " is not allowed on the left" checkSingleMatch _ _ v t1 (JustInferredType p2) = return $ mergeLeaf $ InferredTypeGuess p2 (singleType t1) v checkSingleMatch r f v (JustTypeInstance t1) (JustTypeInstance t2) = @@ -392,7 +392,7 @@ checkSingleMatch r f v (JustParamName _ p1) (JustParamName _ p2) = checkParamToParam r f v p1 p2 -checkInstanceToInstance :: (CompileErrorM m, TypeResolver r) => +checkInstanceToInstance :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> Variance -> TypeInstance -> TypeInstance -> m (MergeTree InferredTypeGuess) checkInstanceToInstance r f v t1@(TypeInstance n1 ps1) t2@(TypeInstance n2 ps2) | n1 == n2 = do @@ -405,9 +405,9 @@ | v == Contravariant = do ps2' <- trRefines r t2 n1 checkInstanceToInstance r f Contravariant t1 (TypeInstance n1 ps2') - | otherwise = compileErrorM $ "Category " ++ show n2 ++ " is required but got " ++ show n1 + | otherwise = compilerErrorM $ "Category " ++ show n2 ++ " is required but got " ++ show n1 -checkParamToInstance :: (CompileErrorM m, TypeResolver r) => +checkParamToInstance :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> Variance -> ParamName -> TypeInstance -> m (MergeTree InferredTypeGuess) checkParamToInstance r f Invariant n1 t2 = -- Implicit equality, inferred by n1 <-> t2. @@ -425,7 +425,7 @@ checkGeneralMatch r f v t (singleType $ JustTypeInstance t2) checkConstraintToInstance f2 = -- x -> F cannot imply T -> x - compileErrorM $ "Constraint " ++ viewTypeFilter n1 f2 ++ + compilerErrorM $ "Constraint " ++ viewTypeFilter n1 f2 ++ " does not imply " ++ show t2 ++ " <- " ++ show n1 checkParamToInstance r f v@Covariant n1 t2@(TypeInstance _ _) = do cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n1 @@ -438,10 +438,10 @@ checkConstraintToInstance f2 = -- F -> x cannot imply x -> T -- DefinesInstance cannot be converted to TypeInstance - compileErrorM $ "Constraint " ++ viewTypeFilter n1 f2 ++ + compilerErrorM $ "Constraint " ++ viewTypeFilter n1 f2 ++ " does not imply " ++ show n1 ++ " -> " ++ show t2 -checkInstanceToParam :: (CompileErrorM m, TypeResolver r) => +checkInstanceToParam :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> Variance -> TypeInstance -> ParamName -> m (MergeTree InferredTypeGuess) checkInstanceToParam r f Invariant t1 n2 = -- Implicit equality, inferred by t1 <-> n2. @@ -460,7 +460,7 @@ checkInstanceToConstraint f2 = -- F -> x cannot imply x -> T -- DefinesInstance cannot be converted to TypeInstance - compileErrorM $ "Constraint " ++ viewTypeFilter n2 f2 ++ + compilerErrorM $ "Constraint " ++ viewTypeFilter n2 f2 ++ " does not imply " ++ show n2 ++ " <- " ++ show t1 checkInstanceToParam r f v@Covariant t1@(TypeInstance _ _) n2 = do cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n2 @@ -472,10 +472,10 @@ checkGeneralMatch r f v (singleType $ JustTypeInstance t1) t checkInstanceToConstraint f2 = -- x -> F cannot imply T -> x - compileErrorM $ "Constraint " ++ viewTypeFilter n2 f2 ++ + compilerErrorM $ "Constraint " ++ viewTypeFilter n2 f2 ++ " does not imply " ++ show t1 ++ " -> " ++ show n2 -checkParamToParam :: (CompileErrorM m, TypeResolver r) => +checkParamToParam :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> Variance -> ParamName -> ParamName -> m (MergeTree InferredTypeGuess) checkParamToParam r f Invariant n1 n2 | n1 == n2 = return maxBound @@ -506,58 +506,58 @@ | otherwise = TypeFilter FilterRequires selfParam2 checkConstraintToConstraint Covariant (TypeFilter FilterRequires t1) (TypeFilter FilterAllows t2) | t1 == selfParam1 && t2 == selfParam2 = - compileErrorM $ "Infinite recursion in " ++ show n1 ++ " -> " ++ show n2 + compilerErrorM $ "Infinite recursion in " ++ show n1 ++ " -> " ++ show n2 -- x -> F1, F2 -> y implies x -> y only if F1 -> F2 | otherwise = checkGeneralMatch r f Covariant t1 t2 checkConstraintToConstraint Covariant f1 f2 = -- x -> F1, y -> F2 cannot imply x -> y -- F1 -> x, F1 -> y cannot imply x -> y -- F1 -> x, y -> F2 cannot imply x -> y - compileErrorM $ "Constraints " ++ viewTypeFilter n1 f1 ++ " and " ++ + compilerErrorM $ "Constraints " ++ viewTypeFilter n1 f1 ++ " and " ++ viewTypeFilter n2 f2 ++ " do not imply " ++ show n1 ++ " -> " ++ show n2 checkConstraintToConstraint Contravariant (TypeFilter FilterAllows t1) (TypeFilter FilterRequires t2) | t1 == selfParam1 && t2 == selfParam2 = - compileErrorM $ "Infinite recursion in " ++ show n1 ++ " <- " ++ show n2 + compilerErrorM $ "Infinite recursion in " ++ show n1 ++ " <- " ++ show n2 -- x <- F1, F2 <- y implies x <- y only if F1 <- F2 | otherwise = checkGeneralMatch r f Contravariant t1 t2 checkConstraintToConstraint Contravariant f1 f2 = -- x <- F1, y <- F2 cannot imply x <- y -- F1 <- x, F1 <- y cannot imply x <- y -- F1 <- x, y <- F2 cannot imply x <- y - compileErrorM $ "Constraints " ++ viewTypeFilter n1 f1 ++ " and " ++ + compilerErrorM $ "Constraints " ++ viewTypeFilter n1 f1 ++ " and " ++ viewTypeFilter n2 f2 ++ " do not imply " ++ show n1 ++ " <- " ++ show n2 checkConstraintToConstraint _ _ _ = undefined -validateGeneralInstance :: (CompileErrorM m, TypeResolver r) => +validateGeneralInstance :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> GeneralInstance -> m () validateGeneralInstance r f = reduceMergeTree collectAllM_ collectAllM_ validateSingle where validateSingle (JustTypeInstance t) = validateTypeInstance r f t validateSingle (JustParamName _ n) = when (not $ n `Map.member` f) $ - compileErrorM $ "Param " ++ show n ++ " does not exist" - validateSingle (JustInferredType n) = compileErrorM $ "Inferred param " ++ show n ++ " is not allowed here" + compilerErrorM $ "Param " ++ show n ++ " does not exist" + validateSingle (JustInferredType n) = compilerErrorM $ "Inferred param " ++ show n ++ " is not allowed here" -validateTypeInstance :: (CompileErrorM m, TypeResolver r) => +validateTypeInstance :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> TypeInstance -> m () validateTypeInstance r f t@(TypeInstance _ ps) = do fa <- trTypeFilters r t processPairs_ (validateAssignment r f) ps fa mapErrorsM_ (validateGeneralInstance r f) (pValues ps) +validateDefinesInstance :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> DefinesInstance -> m () validateDefinesInstance r f t@(DefinesInstance _ ps) = do fa <- trDefinesFilters r t processPairs_ (validateAssignment r f) ps fa mapErrorsM_ (validateGeneralInstance r f) (pValues ps) +validateTypeFilter :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> TypeFilter -> m () validateTypeFilter r f (TypeFilter _ t) = validateGeneralInstance r f t validateTypeFilter r f (DefinesFilter t) = validateDefinesInstance r f t -validateAssignment :: (CompileErrorM m, TypeResolver r) => +validateAssignment :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> GeneralInstance -> [TypeFilter] -> m () validateAssignment r f t fs = mapErrorsM_ checkWithMessage fs where checkWithMessage f2 = checkFilter t f2 +checkDefinesMatch :: (CollectErrorsM m, TypeResolver r) => r -> ParamFilters -> DefinesInstance -> DefinesInstance -> m () checkDefinesMatch r f f2@(DefinesInstance n2 ps2) f1@(DefinesInstance n1 ps1) | n1 == n2 = do paired <- processPairs alwaysPair ps1 ps2 variance <- trVariance r n2 processPairs_ (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance (Positional paired) - | otherwise = compileErrorM $ "Constraint " ++ show f1 ++ " does not imply " ++ show f2 + | otherwise = compilerErrorM $ "Constraint " ++ show f1 ++ " does not imply " ++ show f2 -validateInstanceVariance :: (CompileErrorM m, TypeResolver r) => +validateInstanceVariance :: (CollectErrorsM m, TypeResolver r) => r -> ParamVariances -> Variance -> GeneralInstance -> m () validateInstanceVariance r vm v = reduceMergeTree collectAllM_ collectAllM_ validateSingle where validateSingle (JustTypeInstance (TypeInstance n ps)) = do @@ -596,26 +596,26 @@ mapErrorsM_ (\(v2,p) -> validateInstanceVariance r vm (v `composeVariance` v2) p) paired validateSingle (JustParamName _ n) = case n `Map.lookup` vm of - Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined" + Nothing -> compilerErrorM $ "Param " ++ show n ++ " is undefined" (Just v0) -> when (not $ v0 `allowsVariance` v) $ - compileErrorM $ "Param " ++ show n ++ " cannot be " ++ show v + compilerErrorM $ "Param " ++ show n ++ " cannot be " ++ show v validateSingle (JustInferredType n) = - compileErrorM $ "Inferred param " ++ show n ++ " is not allowed here" + compilerErrorM $ "Inferred param " ++ show n ++ " is not allowed here" -validateDefinesVariance :: (CompileErrorM m, TypeResolver r) => +validateDefinesVariance :: (CollectErrorsM m, TypeResolver r) => r -> ParamVariances -> Variance -> DefinesInstance -> m () validateDefinesVariance r vm v (DefinesInstance n ps) = do vs <- trVariance r n paired <- processPairs alwaysPair vs ps mapErrorsM_ (\(v2,p) -> validateInstanceVariance r vm (v `composeVariance` v2) p) paired -uncheckedSubValueType :: CompileErrorM m => +uncheckedSubValueType :: CollectErrorsM m => (ParamName -> m GeneralInstance) -> ValueType -> m ValueType uncheckedSubValueType replace (ValueType s t) = do t' <- uncheckedSubInstance replace t return $ ValueType s t' -uncheckedSubInstance :: CompileErrorM m => (ParamName -> m GeneralInstance) -> +uncheckedSubInstance :: CollectErrorsM m => (ParamName -> m GeneralInstance) -> GeneralInstance -> m GeneralInstance uncheckedSubInstance replace = reduceMergeTree subAny subAll subSingle where -- NOTE: Don't use mergeAnyM because it will fail if the union is empty. @@ -626,13 +626,13 @@ subSingle (JustInferredType n) = replace n subSingle (JustTypeInstance t) = fmap (singleType . JustTypeInstance) $ uncheckedSubSingle replace t -uncheckedSubSingle :: CompileErrorM m => (ParamName -> m GeneralInstance) -> +uncheckedSubSingle :: CollectErrorsM m => (ParamName -> m GeneralInstance) -> TypeInstance -> m TypeInstance uncheckedSubSingle replace (TypeInstance n (Positional ts)) = do ts' <- mapErrorsM (uncheckedSubInstance replace) ts return $ TypeInstance n (Positional ts') -uncheckedSubFilter :: CompileErrorM m => +uncheckedSubFilter :: CollectErrorsM m => (ParamName -> m GeneralInstance) -> TypeFilter -> m TypeFilter uncheckedSubFilter replace (TypeFilter d t) = do t' <- uncheckedSubInstance replace t @@ -641,7 +641,7 @@ ts' <- mapErrorsM (uncheckedSubInstance replace) (pValues ts) return (DefinesFilter (DefinesInstance n (Positional ts'))) -uncheckedSubFilters :: CompileErrorM m => +uncheckedSubFilters :: CollectErrorsM m => (ParamName -> m GeneralInstance) -> ParamFilters -> m ParamFilters uncheckedSubFilters replace fa = do fa' <- mapErrorsM subParam $ Map.toList fa diff --git a/tests/conditionals.0rt b/tests/conditionals.0rt --- a/tests/conditionals.0rt +++ b/tests/conditionals.0rt @@ -58,7 +58,7 @@ testcase "assign if/elif condition" { error - require "value.+before return" + require "value.+initialized" } define Value { @@ -77,8 +77,8 @@ testcase "different in if and else" { error - require "value1.+before return" - require "value2.+before return" + require "value1.+initialized" + require "value2.+initialized" } define Value { @@ -97,7 +97,7 @@ testcase "missing in if" { error - require "value.+before return" + require "value.+initialized" } define Value { @@ -117,7 +117,7 @@ testcase "missing in elif" { error - require "value.+before return" + require "value.+initialized" } define Value { @@ -137,7 +137,7 @@ testcase "missing in else" { error - require "value.+before return" + require "value.+initialized" } define Value { @@ -158,7 +158,7 @@ testcase "missing in implicit else" { error - require "value.+before return" + require "value.+initialized" } define Value { @@ -173,6 +173,29 @@ } concrete Value {} + + +testcase "branch jump skips validation of named return" { + compiles +} + +concrete Test {} + +define Test { + @value process () -> (Bool) + process () (value) { + while (true) { + if (true) { + // This skips past fail(value) below. + break + } else { + value <- true + } + fail(value) + } + return false + } +} testcase "crash in if" { diff --git a/tests/named-returns.0rt b/tests/named-returns.0rt --- a/tests/named-returns.0rt +++ b/tests/named-returns.0rt @@ -47,7 +47,7 @@ testcase "assign after logical" { error - require "value" + require "value.+initialized" } concrete Test {} @@ -137,6 +137,35 @@ @category process () -> (Int) process () (value) { return value + } +} + + +testcase "explicit return with named" { + compiles +} + +concrete Test {} + +define Test { + @category process () -> (Int) + process () (value) { + return 1 + } +} + + +testcase "empty return with named" { + error + require "value.+initialized" +} + +concrete Test {} + +define Test { + @category process () -> (Int) + process () (value) { + return _ } } diff --git a/tests/regressions.0rt b/tests/regressions.0rt --- a/tests/regressions.0rt +++ b/tests/regressions.0rt @@ -17,6 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] testcase "Issue #73 is fixed" { + // https://github.com/ta0kira/zeolite/issues/73 success } @@ -57,6 +58,7 @@ testcase "Issue #73 (2) is fixed" { + // https://github.com/ta0kira/zeolite/issues/73 error require "from Base" require "#x hides" @@ -82,4 +84,95 @@ define Child { call1 (_) {} call2 (_) {} +} + + +testcase "Issue #121 is fixed" { + // https://github.com/ta0kira/zeolite/issues/121 + success +} + +unittest test { + Int count <- 0 + + scoped { + count <- count+1 + } cleanup { + // Previously, the scoped block was prepended to the cleanup block, due to + // a change that precompiled scoped+in to allow use of named returns. + count <- count+1 + } in { + count <- count+1 + } + + // The count here would be 4 if scoped was prepended to cleanup. + \ Testing.checkEquals(count,3) +} + + +testcase "Issue #122 is fixed: break" { + // https://github.com/ta0kira/zeolite/issues/122 + error + require "cleanup" + require "message.+initialized" +} + +unittest test { + \ Type.call() +} + +concrete Type { + @type call () -> (String) +} + +define Type { + call () (message) { + while (true) { + cleanup { + fail(message) + } in { + if (true) { + // There should be an error here (referring back to fail(message) + // above) because message might not be set. + break + } + message <- "message" + } + } + return "return" + } +} + + +testcase "Issue #122 is fixed: continue" { + // https://github.com/ta0kira/zeolite/issues/122 + error + require "cleanup" + require "message.+initialized" +} + +unittest test { + \ Type.call() +} + +concrete Type { + @type call () -> (String) +} + +define Type { + call () (message) { + while (true) { + cleanup { + fail(message) + } in { + if (true) { + // There should be an error here (referring back to fail(message) + // above) because message might not be set. + continue + } + message <- "message" + } + } + return "return" + } } diff --git a/tests/scoped.0rt b/tests/scoped.0rt --- a/tests/scoped.0rt +++ b/tests/scoped.0rt @@ -203,7 +203,6 @@ unittest test { String value, _ <- Test.get() - fail(value) } concrete Test { @@ -217,11 +216,37 @@ value <- "failed" cleanup { fail(value) - } in return "message", 1 + } in { + return "message", 1 + } } } +testcase "top-level assignment sets named return for cleanup" { + crash + require "message" + exclude "failed" +} + +unittest test { + String value <- Test.get() +} + +concrete Test { + @type get () -> (String) +} + +define Test { + get () (value) { + value <- "failed" + cleanup { + fail(value) + } in value <- "message" + } +} + + testcase "cannot refer to cleanup variables" { error require "value.+not defined" @@ -361,6 +386,20 @@ } +testcase "cleanup can refer to top-level in variables" { + success +} + +unittest test { + scoped { + } cleanup { + value <- 1 + } in Int value <- 2 + + \ Testing.checkEquals(value,1) +} + + testcase "cleanup cannot refer to later variables" { error require "value.+not defined" @@ -370,10 +409,27 @@ scoped { } cleanup { value <- 1 - } in Int value <- 2 + } in {} + + Int value <- 2 } +testcase "cleanup cannot refer to nested in variables" { + error + require "value.+not defined" +} + +unittest test { + scoped { + } cleanup { + value <- 1 + } in { + Int value <- 2 + } +} + + testcase "cleanup not merged" { error require "value.+not defined" @@ -564,6 +620,44 @@ } +testcase "partial cleanup with while and continue" { + success +} + +unittest test { + Int called <- 0 + Int x <- 0 + Int y <- 0 + Int z <- 0 + cleanup { + x <- 1 + } in { + while ((called <- called+1) < 3) { + if (called > 1) { + \ Testing.checkEquals(y,2) + \ Testing.checkEquals(z,3) + } + cleanup { + y <- 2 + } in if (true) { + cleanup { + z <- 3 + } in if (true) { + continue + } + } + } + \ Testing.checkEquals(called,3) + \ Testing.checkEquals(x,0) + \ Testing.checkEquals(y,2) + \ Testing.checkEquals(z,3) + } + \ Testing.checkEquals(x,1) + \ Testing.checkEquals(y,2) + \ Testing.checkEquals(z,3) +} + + testcase "full cleanup with while and return" { success } @@ -637,6 +731,22 @@ cleanup { value <- "error" } in return "message" + } +} + + +testcase "named return check in cleanup skipped if unreachable" { + compiles +} + +concrete Test {} + +define Test { + @type get () -> (String) + get () (value) { + cleanup { + fail(value) + } in fail("message") } } diff --git a/tests/tracing.0rt b/tests/tracing.0rt --- a/tests/tracing.0rt +++ b/tests/tracing.0rt @@ -42,6 +42,34 @@ } } +testcase "NoTrace works in cleanup" { + crash + require "message" + require "Test\.error" + exclude "Test\.noTrace" +} + +unittest test { + \ Test.noTrace() +} + +concrete Test { + @type noTrace () -> () +} + +define Test { + noTrace () { $NoTrace$ + \ error() + } + + @type error () -> () + error () { + cleanup { + fail("message") + } in {} + } +} + testcase "TraceCreation captures trace" { crash diff --git a/tests/unreachable.0rt b/tests/unreachable.0rt --- a/tests/unreachable.0rt +++ b/tests/unreachable.0rt @@ -21,28 +21,20 @@ require compiler "unreachable" } -concrete Test {} - -define Test { - @category failedReturn () -> (Int) - failedReturn () { - fail("Failed") - return 1 - } +unittest test { + fail("Failed") + \ empty } + testcase "unreachable not compiled" { compiles + require compiler "unreachable" } -concrete Test {} - -define Test { - @category failedReturn () -> (Int) - failedReturn () { - fail("Failed") - \ foo() - } +unittest test { + fail("Failed") + \ foo() } @@ -99,76 +91,56 @@ } -testcase "warning statement after cleanup fail" { - crash - require compiler "unreachable" - require "message" +testcase "unreachable in cleanup does not affect in block" { + error + require compiler "foo" } unittest test { - \ Test:failedReturn() -} - -concrete Test { - @category failedReturn () -> (Int) -} - -define Test { - failedReturn () { - scoped { - } cleanup { - fail("message") - } in \ empty - return 2 - } + scoped { + } cleanup { + fail("message") + } in \ foo() } -testcase "warning statement in cleanup after scoped fail" { - crash +testcase "warning statement after cleanup fail" { + compiles require compiler "unreachable" - require "message" } unittest test { - \ Test:failedReturn() -} - -concrete Test { - @category failedReturn () -> () -} - -define Test { - failedReturn () { - scoped { - fail("message") - } cleanup { - \ empty - } in {} - } + scoped { + } cleanup { + fail("message") + } in \ empty + \ foo() } -testcase "warning statement in cleanup after in fail" { - crash +testcase "warning statement in cleanup after scoped fail" { + compiles require compiler "unreachable" - require "message" } unittest test { - \ Test:failedReturn() + scoped { + fail("message") + } cleanup { + \ empty + } in {} } -concrete Test { - @category failedReturn () -> () + +testcase "no warning statement in cleanup after in fail" { + compiles + exclude compiler "unreachable" } -define Test { - failedReturn () { - cleanup { - \ empty - } in fail("message") - } +unittest test { + cleanup { + \ empty + } in fail("message") } diff --git a/tests/while.0rt b/tests/while.0rt --- a/tests/while.0rt +++ b/tests/while.0rt @@ -18,7 +18,7 @@ testcase "assign while" { error - require "value.+before return" + require "value.+initialized" } @value interface Value {} @@ -37,7 +37,7 @@ testcase "assign while condition" { error - require "value.+before return" + require "value.+initialized" } @value interface Value {} @@ -252,6 +252,21 @@ } } +unittest cleanupAfterContinue { + Int value <- 0 + scoped { + value <- 1 + } cleanup { + value <- 2 + } in while (value < 3) { + value <- 3 + continue + } + if (value != 2) { + fail(value) + } +} + concrete CleanupBeforeReturn { @type create () -> (CleanupBeforeReturn) @value call () -> (Int) @@ -315,4 +330,118 @@ concrete Test { @type run () -> () +} + + +testcase "cleanup cannot use uninitialized named return" { + error + require "cleanup" + require "message.+initialized" +} + +unittest test { + \ Type.call() +} + +concrete Type { + @type call () -> (String) +} + +define Type { + call () (message) { + while (true) { + cleanup { + fail(message) + } in {} + } + return "return" + } +} + + +testcase "break not allowed in cleanup" { + error + require "cleanup" + require "break" +} + +unittest test { + while(true) { + cleanup { + break + } in {} + } +} + + +testcase "continue not allowed in cleanup" { + error + require "cleanup" + require "continue" +} + +unittest test { + while(true) { + cleanup { + continue + } in {} + } +} + + +testcase "procedure nesting preserves required named returns" { + error + require "cleanup" + require "message.+initialized" +} + +unittest test { + \ Type.call() +} + +concrete Type { + @type call () -> (String) +} + +define Type { + call () (message) { + while (true) { + cleanup { + if (true) { + fail(message) + } else { + } + } in { + } + } + return "return" + } +} + + +testcase "no error for cleanup without named returns" { + compiles +} + +unittest test { + \ Type.call() +} + +concrete Type { + @type call () -> (String) +} + +define Type { + call () (message) { + while (true) { + cleanup { + } in { + if (true) { + break + } + message <- "message" + } + } + return "return" + } } diff --git a/zeolite-lang.cabal b/zeolite-lang.cabal --- a/zeolite-lang.cabal +++ b/zeolite-lang.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: zeolite-lang -version: 0.10.0.0 +version: 0.11.0.0 synopsis: Zeolite is a statically-typed, general-purpose programming language. description: @@ -87,6 +87,7 @@ lib/file/.zeolite-module, lib/file/*.0rp, lib/file/*.0rt, + lib/file/*.0rx, lib/file/*.cpp, lib/math/.zeolite-module, lib/math/*.0rp, @@ -178,10 +179,13 @@ library zeolite-internal import: defaults - exposed-modules: Base.CompileError, - Base.CompileInfo, + exposed-modules: Base.CompilerError, + Base.CompilerMessage, + Base.GeneralType, Base.MergeTree, Base.Mergeable, + Base.Positional, + Base.TrackedErrors, Cli.CompileOptions, Cli.Compiler, Cli.ParseCompileOptions, @@ -208,10 +212,10 @@ Parser.Pragma, Parser.Procedure, Parser.SourceFile, + Parser.TextParser, Parser.TypeCategory, Parser.TypeInstance, Test.Common, - Test.CompileInfo, Test.DefinedCategory, Test.IntegrationTest, Test.MergeTree, @@ -220,14 +224,13 @@ Test.Pragma, Test.Procedure, Test.SourceFile, + Test.TrackedErrors, Test.TypeCategory, Test.TypeInstance, Types.Builtin, Types.DefinedCategory, Types.Function, - Types.GeneralType, Types.IntegrationTest, - Types.Positional, Types.Pragma, Types.Procedure, Types.TypeCategory, @@ -246,15 +249,17 @@ MultiParamTypeClasses, Safe, ScopedTypeVariables, - TypeFamilies + TypeFamilies, + TypeSynonymInstances, + Unsafe build-depends: base >= 4.9 && < 4.15, containers >= 0.3 && < 0.7, directory >= 1.2.3 && < 1.4, filepath >= 1.0 && < 1.5, hashable >= 1.0 && < 1.4, + megaparsec >= 7.0 && < 9.1, mtl >= 1.0 && < 2.3, - parsec >= 3.0 && < 3.2, parser-combinators >= 0.2 && < 2.0, regex-tdfa >= 1.0 && < 1.4, time >= 1.0 && < 1.11,