diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # Revision history for zeolite-lang +## 0.7.1.0 -- 2020-07-13 + +### Language + +* **[new]** Adds the `$SourceContext$` macro, which inserts a `String` with + info about source file and code location. + +* **[fix]** Adds context to error messages related to inherited functions that + have not been overridden. + ## 0.7.0.2 -- 2020-05-21 ### Language diff --git a/bin/zeolite-setup.hs b/bin/zeolite-setup.hs --- a/bin/zeolite-setup.hs +++ b/bin/zeolite-setup.hs @@ -61,6 +61,12 @@ "lib/math" ] +includePaths :: [String] +includePaths = ["lib"] + +cxxFlags :: [String] +cxxFlags = ["-O2", "-std=c++11"] + createConfig :: IO LocalConfig createConfig = do clang <- findExecutables clangBinary @@ -69,7 +75,7 @@ compiler <- promptChoice "Which clang-compatible C++ compiler should be used?" (clang ++ gcc) archiver <- promptChoice "Which ar-compatible archiver should be used?" ar -- Cannot be overridden at this point. - let options = ["-O2", "-std=c++11"] + let options = cxxFlags let config = LocalConfig { lcBackend = UnixBackend { ucCxxBinary = compiler, @@ -77,7 +83,7 @@ ucArBinary = archiver }, lcResolver = SimpleResolver { - srVisibleSystem = ["lib"], + srVisibleSystem = includePaths, srExtraPaths = [] } } diff --git a/bin/zeolite.hs b/bin/zeolite.hs --- a/bin/zeolite.hs +++ b/bin/zeolite.hs @@ -24,13 +24,13 @@ import qualified Data.Map as Map import Base.CompileError -import Cli.CompileMetadata +import Base.CompileInfo import Cli.CompileOptions -import Cli.ProcessMetadata import Cli.ParseCompileOptions -- Not safe, due to Text.Regex.TDFA. import Cli.Programs import Cli.RunCompiler -import Base.CompileInfo +import Module.CompileMetadata +import Module.ProcessMetadata import Config.LoadConfig import Config.LocalConfig diff --git a/src/Cli/CompileMetadata.hs b/src/Cli/CompileMetadata.hs deleted file mode 100644 --- a/src/Cli/CompileMetadata.hs +++ /dev/null @@ -1,115 +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 Cli.CompileMetadata ( - CategoryIdentifier(..), - CompileMetadata(..), - ModuleConfig(..), - ObjectFile(..), - isCategoryObjectFile, - mergeObjectFiles, -) where - -import Data.List (nub) -import Text.Parsec (SourcePos) - -import Cli.CompileOptions -import Cli.Programs (VersionHash) -import Types.Procedure (Expression) -import Types.TypeCategory (Namespace) -import Types.TypeInstance (CategoryName) - - -data CompileMetadata = - CompileMetadata { - cmVersionHash :: VersionHash, - cmPath :: FilePath, - cmNamespace :: Namespace, - cmPublicDeps :: [FilePath], - cmPrivateDeps :: [FilePath], - cmPublicCategories :: [CategoryName], - cmPrivateCategories :: [CategoryName], - cmSubdirs :: [FilePath], - cmPublicFiles :: [FilePath], - cmPrivateFiles :: [FilePath], - cmTestFiles :: [FilePath], - cmHxxFiles :: [FilePath], - cmCxxFiles :: [FilePath], - cmBinaries :: [FilePath], - cmLinkFlags :: [FilePath], - cmObjectFiles :: [ObjectFile] - } - deriving (Eq,Show) - -data ObjectFile = - CategoryObjectFile { - cofCategory :: CategoryIdentifier, - cofRequires :: [CategoryIdentifier], - cofFiles :: [FilePath] - } | - OtherObjectFile { - oofFile :: FilePath - } - deriving (Eq,Show) - -data CategoryIdentifier = - CategoryIdentifier { - ciPath :: FilePath, - ciCategory :: CategoryName, - ciNamespace :: Namespace - } | - UnresolvedCategory { - ucCategory :: CategoryName - } - deriving (Eq,Ord,Show) - -mergeObjectFiles :: ObjectFile -> ObjectFile -> ObjectFile -mergeObjectFiles (CategoryObjectFile c rs1 fs1) (CategoryObjectFile _ rs2 fs2) = - CategoryObjectFile c (nub $ rs1 ++ rs2) (nub $ fs1 ++ fs2) -mergeObjectFiles o _ = o - -isCategoryObjectFile :: ObjectFile -> Bool -isCategoryObjectFile (CategoryObjectFile _ _ _) = True -isCategoryObjectFile (OtherObjectFile _) = False - -data ModuleConfig = - ModuleConfig { - rmRoot :: FilePath, - rmPath :: FilePath, - rmExprMap :: [(String,Expression SourcePos)], - rmPublicDeps :: [FilePath], - rmPrivateDeps :: [FilePath], - rmExtraFiles :: [ExtraSource], - rmExtraPaths :: [FilePath], - rmMode :: CompileMode - } - deriving (Show) - -instance Eq ModuleConfig where - (ModuleConfig pA dA _ isA is2A esA epA mA) == (ModuleConfig pB dB _ isB is2B esB epB mB) = - all id [ - pA == pB, - dA == dB, - isA == isB, - is2A == is2B, - esA == esB, - epA == epB, - mA == mB - ] diff --git a/src/Cli/Compiler.hs b/src/Cli/Compiler.hs --- a/src/Cli/Compiler.hs +++ b/src/Cli/Compiler.hs @@ -36,16 +36,16 @@ import qualified Data.Set as Set import Base.CompileError -import Cli.CompileMetadata +import Base.CompileInfo import Cli.CompileOptions import Cli.Paths -import Cli.ProcessMetadata import Cli.Programs import Cli.TestRunner -- Not safe, due to Text.Regex.TDFA. -import Base.CompileInfo import Compilation.ProcedureContext (ExprMap) import CompilerCxx.Category import CompilerCxx.Naming +import Module.CompileMetadata +import Module.ProcessMetadata import Parser.SourceFile import Types.Builtin import Types.DefinedCategory @@ -282,7 +282,7 @@ createPublicNamespace p d = (errorFromIO $ canonicalizePath (p d)) >>= return . StaticNamespace . publicNamespace createPrivateNamespace :: FilePath -> FilePath -> CompileInfoIO Namespace -createPrivateNamespace p f = (errorFromIO $ canonicalizePath (p f)) >>= return . StaticNamespace . publicNamespace +createPrivateNamespace p f = (errorFromIO $ canonicalizePath (p f)) >>= return . StaticNamespace . privateNamespace zipWithContents :: FilePath -> [FilePath] -> CompileInfoIO [(FilePath,String)] zipWithContents p fs = fmap (zip $ map fixPath fs) $ mapM (errorFromIO . readFile . (p )) fs diff --git a/src/Cli/ParseMetadata.hs b/src/Cli/ParseMetadata.hs deleted file mode 100644 --- a/src/Cli/ParseMetadata.hs +++ /dev/null @@ -1,382 +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] - -module Cli.ParseMetadata ( - ConfigFormat, - autoReadConfig, - autoWriteConfig, -) where - -import Control.Monad (when) -import Text.Parsec -import Text.Parsec.String - -import Base.CompileError -import Cli.CompileMetadata -import Cli.CompileOptions -import Cli.Programs (VersionHash(..)) -import Parser.Common -import Parser.Procedure () -import Parser.Pragma (parseMacroName) -import Parser.TypeCategory () -import Parser.TypeInstance () -import Text.Regex.TDFA -- Not safe! -import Types.Procedure (Expression) -import Types.TypeCategory (FunctionName(..),Namespace(..)) -import Types.TypeInstance (CategoryName(..)) - - -class ConfigFormat a where - readConfig :: Parser a - writeConfig :: CompileErrorM m => a -> m [String] - -autoReadConfig :: (ConfigFormat a, CompileErrorM m) => String -> String -> m a -autoReadConfig f s = unwrap parsed where - parsed = parse (between optionalSpace endOfDoc readConfig) f s - unwrap (Left e) = compileErrorM (show e) - unwrap (Right t) = return t - -autoWriteConfig :: (ConfigFormat a, CompileErrorM m) => a -> m String -autoWriteConfig = fmap unlines . writeConfig - -structOpen :: Parser () -structOpen = sepAfter (string_ "{") - -structClose :: Parser () -structClose = sepAfter (string_ "}") - -indents :: [String] -> [String] -indents = map indent - -indent :: String -> String -indent = (" " ++) - -prependFirst :: String -> [String] -> [String] -prependFirst s0 (s:ss) = (s0 ++ s):ss -prependFirst s0 _ = [s0] - -validateCategoryName :: CompileErrorM m => CategoryName -> m () -validateCategoryName c = - when (not $ show c =~ "^[A-Z][A-Za-z0-9]*$") $ - compileErrorM $ "Invalid category name: \"" ++ show c ++ "\"" - -parseCategoryName :: Parser CategoryName -parseCategoryName = sourceParser :: Parser CategoryName - -validateFunctionName :: CompileErrorM m => FunctionName -> m () -validateFunctionName f = - when (not $ show f =~ "^[a-z][A-Za-z0-9]*$") $ - compileErrorM $ "Invalid function name: \"" ++ show f ++ "\"" - -parseFunctionName :: Parser FunctionName -parseFunctionName = sourceParser :: Parser FunctionName - -validateHash :: CompileErrorM m => VersionHash -> m () -validateHash h = - when (not $ show h =~ "^[A-Za-z0-9]+$") $ - compileErrorM $ "Version hash must be a hex string: \"" ++ show h ++ "\"" - -parseHash :: Parser VersionHash -parseHash = labeled "version hash" $ sepAfter (fmap VersionHash $ many1 hexDigit) - -maybeShowNamespace :: CompileErrorM 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 ++ "\"" - return [l ++ " " ++ ns] -maybeShowNamespace _ _ = return [] - -parseNamespace :: Parser Namespace -parseNamespace = labeled "namespace" $ do - b <- lower - e <- sepAfter $ many (alphaNum <|> char '_') - return $ StaticNamespace (b:e) - -parseQuoted :: Parser String -parseQuoted = labeled "quoted string" $ do - string_ "\"" - ss <- manyTill stringChar (string_ "\"") - optionalSpace - return ss - -parseList :: Parser a -> Parser [a] -parseList p = labeled "list" $ do - sepAfter (string_ "[") - xs <- manyTill (sepAfter p) (string_ "]") - optionalSpace - return xs - -parseOptional :: String -> a -> Parser a -> Parser a -parseOptional l def p = parseRequired l p <|> return def - -parseRequired :: String -> Parser a -> Parser a -parseRequired l p = do - try $ sepAfter (string_ l) - p - -instance ConfigFormat CompileMetadata where - readConfig = do - h <- parseRequired "version_hash:" parseHash - p <- parseRequired "path:" parseQuoted - ns <- parseOptional "namespace:" NoNamespace parseNamespace - is <- parseRequired "public_deps:" (parseList parseQuoted) - is2 <- parseRequired "private_deps:" (parseList parseQuoted) - cs1 <- parseRequired "public_categories:" (parseList parseCategoryName) - cs2 <- parseRequired "private_categories:" (parseList parseCategoryName) - ds <- parseRequired "subdirs:" (parseList parseQuoted) - ps <- parseRequired "public_files:" (parseList parseQuoted) - xs <- parseRequired "private_files:" (parseList parseQuoted) - ts <- parseRequired "test_files:" (parseList parseQuoted) - hxx <- parseRequired "hxx_files:" (parseList parseQuoted) - cxx <- parseRequired "cxx_files:" (parseList parseQuoted) - bs <- parseRequired "binaries:" (parseList parseQuoted) - lf <- parseRequired "link_flags:" (parseList parseQuoted) - os <- parseRequired "object_files:" (parseList readConfig) - return (CompileMetadata h p ns is is2 cs1 cs2 ds ps xs ts hxx cxx bs lf os) - writeConfig m = do - validateHash (cmVersionHash m) - namespace <- maybeShowNamespace "namespace:" (cmNamespace m) - _ <- mapErrorsM validateCategoryName (cmPublicCategories m) - _ <- mapErrorsM validateCategoryName (cmPrivateCategories m) - objects <- fmap concat $ mapErrorsM writeConfig $ cmObjectFiles m - return $ [ - "version_hash: " ++ (show $ cmVersionHash m), - "path: " ++ (show $ cmPath m) - ] ++ namespace ++ [ - "public_deps: [" - ] ++ indents (map show $ cmPublicDeps m) ++ [ - "]", - "private_deps: [" - ] ++ indents (map show $ cmPrivateDeps m) ++ [ - "]", - "public_categories: [" - ] ++ indents (map show $ cmPublicCategories m) ++ [ - "]", - "private_categories: [" - ] ++ indents (map show $ cmPrivateCategories m) ++ [ - "]", - "subdirs: [" - ] ++ indents (map show $ cmSubdirs m) ++ [ - "]", - "public_files: [" - ] ++ indents (map show $ cmPublicFiles m) ++ [ - "]", - "private_files: [" - ] ++ indents (map show $ cmPrivateFiles m) ++ [ - "]", - "test_files: [" - ] ++ indents (map show $ cmTestFiles m) ++ [ - "]", - "hxx_files: [" - ] ++ indents (map show $ cmHxxFiles m) ++ [ - "]", - "cxx_files: [" - ] ++ indents (map show $ cmCxxFiles m) ++ [ - "]", - "binaries: [" - ] ++ indents (map show $ cmBinaries m) ++ [ - "]", - "link_flags: [" - ] ++ indents (map show $ cmLinkFlags m) ++ [ - "]", - "object_files: [" - ] ++ indents objects ++ [ - "]" - ] - -instance ConfigFormat ObjectFile where - readConfig = category <|> other where - category = do - sepAfter (string_ "category_object") - structOpen - c <- parseRequired "category:" readConfig - rs <- parseRequired "requires:" (parseList readConfig) - fs <- parseRequired "files:" (parseList parseQuoted) - structClose - return (CategoryObjectFile c rs fs) - other = do - sepAfter (string_ "other_object") - structOpen - f <- parseRequired "file:" parseQuoted - structClose - return (OtherObjectFile f) - writeConfig (CategoryObjectFile c rs fs) = do - category <- writeConfig c - requires <- fmap concat $ mapErrorsM writeConfig rs - return $ [ - "category_object {" - ] ++ indents ("category: " `prependFirst` category) ++ [ - indent "requires: [" - ] ++ (indents . indents) requires ++ [ - indent "]", - indent "files: [" - ] ++ (indents . indents) (map show fs) ++ [ - indent "]", - "}" - ] - writeConfig (OtherObjectFile f) = do - return $ [ - "other_object {", - indent ("file: " ++ show f), - "}" - ] - -instance ConfigFormat CategoryIdentifier where - readConfig = category <|> unresolved where - category = do - sepAfter (string_ "category") - structOpen - c <- parseRequired "name:" parseCategoryName - ns <- parseOptional "namespace:" NoNamespace parseNamespace - p <- parseRequired "path:" parseQuoted - structClose - return (CategoryIdentifier p c ns) - unresolved = do - sepAfter (string_ "unresolved") - structOpen - c <- parseRequired "name:" parseCategoryName - structClose - return (UnresolvedCategory c) - writeConfig (CategoryIdentifier p c ns) = do - validateCategoryName c - namespace <- maybeShowNamespace "namespace:" ns - return $ [ - "category {", - indent $ "name: " ++ show c - ] ++ indents namespace ++ [ - indent $ "path: " ++ show p, - "}" - ] - writeConfig (UnresolvedCategory c) = do - validateCategoryName c - return $ ["unresolved { " ++ "name: " ++ show c ++ " " ++ "}"] - -instance ConfigFormat ModuleConfig where - readConfig = do - p <- parseOptional "root:" "" parseQuoted - d <- parseRequired "path:" parseQuoted - em <- parseOptional "expression_map:" [] (parseList parseExprMacro) - is <- parseOptional "public_deps:" [] (parseList parseQuoted) - is2 <- parseOptional "private_deps:" [] (parseList parseQuoted) - es <- parseOptional "extra_files:" [] (parseList readConfig) - ep <- parseOptional "include_paths:" [] (parseList parseQuoted) - m <- parseRequired "mode:" readConfig - return (ModuleConfig p d em is is2 es ep m) - writeConfig m = do - extra <- fmap concat $ mapErrorsM writeConfig $ rmExtraFiles m - mode <- writeConfig (rmMode m) - when (not $ null $ rmExprMap m) $ compileErrorM "Only empty expression maps are allowed when writing" - return $ [ - "root: " ++ show (rmRoot m), - "path: " ++ show (rmPath m), - "expression_map: [", - -- NOTE: expression_map isn't output because that would require making - -- all Expression serializable. - "]", - "public_deps: [" - ] ++ indents (map show $ rmPublicDeps m) ++ [ - "]", - "private_deps: [" - ] ++ indents (map show $ rmPrivateDeps m) ++ [ - "]", - "extra_files: [" - ] ++ indents extra ++ [ - "]", - "include_paths: [" - ] ++ indents (map show $ rmExtraPaths m) ++ [ - "]" - ] ++ "mode: " `prependFirst` mode - -instance ConfigFormat ExtraSource where - readConfig = category <|> other where - category = do - sepAfter (string_ "category_source") - structOpen - f <- parseRequired "source:" parseQuoted - cs <- parseOptional "categories:" [] (parseList parseCategoryName) - ds <- parseOptional "requires:" [] (parseList parseCategoryName) - structClose - return (CategorySource f cs ds) - other = do - f <- parseQuoted - return (OtherSource f) - writeConfig (CategorySource f cs ds) = do - _ <- mapErrorsM validateCategoryName cs - _ <- mapErrorsM validateCategoryName ds - return $ [ - "category_source {", - indent ("source: " ++ show f), - indent "categories: [" - ] ++ (indents . indents . map show) cs ++ [ - indent "]", - indent "requires: [" - ] ++ (indents . indents . map show) ds ++ [ - indent "]", - "}" - ] - writeConfig (OtherSource f) = return [show f] - -instance ConfigFormat CompileMode where - readConfig = labeled "compile mode" $ binary <|> incremental where - binary = do - sepAfter (string_ "binary") - structOpen - c <- parseRequired "category:" parseCategoryName - f <- parseRequired "function:" parseFunctionName - o <- parseOptional "output:" "" parseQuoted - lf <- parseOptional "link_flags:" [] (parseList parseQuoted) - structClose - return (CompileBinary c f o lf) - incremental = do - sepAfter (string_ "incremental") - structOpen - lf <- parseOptional "link_flags:" [] (parseList parseQuoted) - structClose - return (CompileIncremental lf) - writeConfig (CompileBinary c f o lf) = do - validateCategoryName c - validateFunctionName f - return $ [ - "binary {", - indent ("category: " ++ show c), - indent ("function: " ++ show f), - indent ("output: " ++ show o), - indent ("link_flags: [") - ] ++ (indents . indents) (map show lf) ++ [ - indent "]", - "}" - ] - writeConfig (CompileIncremental lf) = do - return $ [ - "incremental {", - indent ("link_flags: [") - ] ++ (indents . indents) (map show lf) ++ [ - indent "]", - "}" - ] - writeConfig CompileUnspecified = writeConfig (CompileIncremental []) - writeConfig _ = compileErrorM "Invalid compile mode" - -parseExprMacro :: Parser (String,Expression SourcePos) -parseExprMacro = do - sepAfter (string_ "expression_macro") - structOpen - n <- parseRequired "name:" parseMacroName - e <- parseRequired "expression:" sourceParser - structClose - return (n,e) diff --git a/src/Cli/ProcessMetadata.hs b/src/Cli/ProcessMetadata.hs deleted file mode 100644 --- a/src/Cli/ProcessMetadata.hs +++ /dev/null @@ -1,390 +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] - -module Cli.ProcessMetadata ( - MetadataMap, - createCachePath, - eraseCachedData, - findSourceFiles, - fixPath, - fixPaths, - getCachedPath, - getCacheRelativePath, - getExprMap, - getIncludePathsForDeps, - getLinkFlagsForDeps, - getNamespacesForDeps, - getObjectFilesForDeps, - getObjectFileResolver, - getRealPathsForDeps, - getSourceFilesForDeps, - isPathConfigured, - isPathUpToDate, - loadModuleMetadata, - loadPrivateDeps, - loadPublicDeps, - loadRecompile, - loadTestingDeps, - mapMetadata, - resolveCategoryDeps, - resolveObjectDeps, - sortCompiledFiles, - writeCachedFile, - writeMetadata, - writeRecompile, -) where - -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Data.List (nub,isSuffixOf) -import Data.Maybe (isJust) -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 Cli.CompileMetadata -import Cli.CompileOptions -import Cli.ParseMetadata -- Not safe, due to Text.Regex.TDFA. -import Cli.Programs (VersionHash(..)) -import Base.CompileInfo -import Compilation.ProcedureContext (ExprMap) -import CompilerCxx.Category (CxxOutput(..)) -import Types.Procedure (Expression(Literal),ValueLiteral(..)) -import Types.TypeCategory -import Types.TypeInstance - - -cachedDataPath :: FilePath -cachedDataPath = ".zeolite-cache" - -moduleFilename :: FilePath -moduleFilename = ".zeolite-module" - -metadataFilename :: FilePath -metadataFilename = "compile-metadata" - -type MetadataMap = Map.Map FilePath CompileMetadata - -mapMetadata :: [CompileMetadata] -> MetadataMap -mapMetadata cs = Map.fromList $ zip (map cmPath cs) cs - -loadRecompile :: FilePath -> CompileInfoIO ModuleConfig -loadRecompile p = do - let f = p moduleFilename - isFile <- errorFromIO $ doesFileExist p - when isFile $ compileErrorM $ "Path \"" ++ p ++ "\" is not a directory" - isDir <- errorFromIO $ doesDirectoryExist p - when (not isDir) $ compileErrorM $ "Path \"" ++ p ++ "\" does not exist" - filePresent <- errorFromIO $ doesFileExist f - when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been configured yet" - c <- errorFromIO $ readFile f - (autoReadConfig f c) ForceMode -> FilePath -> CompileInfoIO Bool -isPathUpToDate h f p = do - m <- errorFromIO $ toCompileInfo $ loadDepsCommon f h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p] - return $ not $ isCompileError m - -isPathConfigured :: FilePath -> CompileInfoIO Bool -isPathConfigured p = do - m <- errorFromIO $ toCompileInfo $ loadRecompile p - return $ not $ isCompileError m - -writeMetadata :: FilePath -> CompileMetadata -> CompileInfoIO () -writeMetadata p m = do - p' <- errorFromIO $ canonicalizePath p - errorFromIO $ hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"." - m' <- autoWriteConfig m ModuleConfig -> CompileInfoIO () -writeRecompile p m = do - p' <- errorFromIO $ canonicalizePath p - let f = p moduleFilename - errorFromIO $ hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"." - m' <- autoWriteConfig m CompileInfoIO () -eraseCachedData p = do - let d = p cachedDataPath - dirExists <- errorFromIO $ doesDirectoryExist d - when dirExists $ errorFromIO $ removeDirectoryRecursive d - -createCachePath :: FilePath -> CompileInfoIO () -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 p ns f c = do - createCachePath p - errorFromIO $ createDirectoryIfMissing False $ p cachedDataPath ns - errorFromIO $ writeFile (getCachedPath p ns f) c - -getCachedPath :: FilePath -> String -> FilePath -> FilePath -getCachedPath p ns f = fixPath $ p cachedDataPath ns f - -getCacheRelativePath :: FilePath -> FilePath -getCacheRelativePath f = ".." f - -findSourceFiles :: FilePath -> FilePath -> CompileInfoIO ([FilePath],[FilePath],[FilePath]) -findSourceFiles p0 p = do - let absolute = p0 p - isFile <- errorFromIO $ doesFileExist absolute - when isFile $ compileErrorM $ "Path \"" ++ absolute ++ "\" is not a directory" - isDir <- errorFromIO $ doesDirectoryExist absolute - when (not isDir) $ compileErrorM $ "Path \"" ++ absolute ++ "\" does not exist" - ds <- errorFromIO $ getDirectoryContents absolute >>= return . map (p ) - let ps = filter (isSuffixOf ".0rp") ds - let xs = filter (isSuffixOf ".0rx") ds - let ts = filter (isSuffixOf ".0rt") ds - return (ps,xs,ts) - -getExprMap :: FilePath -> ModuleConfig -> CompileInfoIO (ExprMap SourcePos) -getExprMap p m = do - path <- errorFromIO $ canonicalizePath (p rmRoot m rmPath m) - let defaults = [("MODULE_PATH",Literal (StringLiteral [] path))] - return $ Map.fromList $ rmExprMap m ++ defaults - -getRealPathsForDeps :: [CompileMetadata] -> [FilePath] -getRealPathsForDeps = map cmPath - -getSourceFilesForDeps :: [CompileMetadata] -> [FilePath] -getSourceFilesForDeps = concat . map extract where - extract m = map (cmPath m ) (cmPublicFiles m) - -getNamespacesForDeps :: [CompileMetadata] -> [Namespace] -getNamespacesForDeps = filter (not . isNoNamespace) . map cmNamespace - -getIncludePathsForDeps :: [CompileMetadata] -> [FilePath] -getIncludePathsForDeps = concat . map cmSubdirs - -getLinkFlagsForDeps :: [CompileMetadata] -> [String] -getLinkFlagsForDeps = concat . map cmLinkFlags - -getObjectFilesForDeps :: [CompileMetadata] -> [ObjectFile] -getObjectFilesForDeps = concat . map cmObjectFiles - -loadModuleMetadata :: VersionHash -> ForceMode -> MetadataMap -> FilePath -> - CompileInfoIO CompileMetadata -loadModuleMetadata h f ca = fmap head . loadDepsCommon f h ca Set.empty (const []) . (:[]) - -loadPublicDeps :: VersionHash -> ForceMode -> MetadataMap -> [FilePath] -> - CompileInfoIO [CompileMetadata] -loadPublicDeps h f ca = loadDepsCommon f h ca Set.empty cmPublicDeps - -loadTestingDeps :: VersionHash -> ForceMode -> MetadataMap -> CompileMetadata -> - CompileInfoIO [CompileMetadata] -loadTestingDeps h f ca m = loadDepsCommon f h ca (Set.fromList [cmPath m]) cmPublicDeps (cmPublicDeps m ++ cmPrivateDeps m) - -loadPrivateDeps :: VersionHash -> ForceMode -> MetadataMap -> [CompileMetadata] -> - CompileInfoIO [CompileMetadata] -loadPrivateDeps h f ca ms = do - new <- loadDepsCommon f h ca pa (\m -> cmPublicDeps m ++ cmPrivateDeps m) paths - return $ ms ++ new where - paths = concat $ map (\m -> cmPublicDeps m ++ cmPrivateDeps m) ms - pa = Set.fromList $ map cmPath ms - -loadDepsCommon :: ForceMode -> VersionHash -> MetadataMap -> Set.Set FilePath -> - (CompileMetadata -> [FilePath]) -> [FilePath] -> CompileInfoIO [CompileMetadata] -loadDepsCommon f h ca pa0 getDeps ps = do - (_,processed) <- fixedPaths >>= collect (pa0,[]) - mapErrorsM check processed where - enforce = f /= ForceAll - fixedPaths = mapM (errorFromIO . canonicalizePath) ps - collect xa@(pa,xs) (p:ps2) - | p `Set.member` pa = collect xa ps2 - | otherwise = do - let continue m ds = collect (p `Set.insert` pa,xs ++ [m]) (ps2 ++ ds) - case p `Map.lookup` ca of - Just m2 -> continue m2 [] - Nothing -> do - errorFromIO $ hPutStrLn stderr $ "Loading metadata for dependency \"" ++ p ++ "\"." - m2 <- loadMetadata ca p - let ds = getDeps m2 - continue m2 ds - collect xa _ = return xa - check m - | cmPath m `Map.member` ca = return m - | otherwise = do - fresh <- checkModuleFreshness (cmPath m) m - let sameVersion = checkModuleVersionHash h m - when (enforce && not fresh) $ - compileErrorM $ "Module \"" ++ cmPath m ++ "\" is out of date and should be recompiled" - when (enforce && not sameVersion) $ - compileErrorM $ "Module \"" ++ cmPath m ++ "\" was compiled with a different compiler setup" - return m - -loadMetadata :: MetadataMap -> FilePath -> CompileInfoIO CompileMetadata -loadMetadata ca p = do - path <- errorFromIO $ canonicalizePath p - case path `Map.lookup` ca of - Just cm -> return cm - Nothing -> do - let f = p cachedDataPath metadataFilename - isFile <- errorFromIO $ doesFileExist p - when isFile $ compileErrorM $ "Path \"" ++ p ++ "\" is not a directory" - isDir <- errorFromIO $ doesDirectoryExist p - when (not isDir) $ compileErrorM $ "Path \"" ++ p ++ "\" does not exist" - filePresent <- errorFromIO $ doesFileExist f - when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been compiled yet" - c <- errorFromIO $ readFile f - (autoReadConfig f c) FilePath -fixPath = foldl () "" . process [] . map dropSlash . splitPath where - dropSlash "/" = "/" - dropSlash d - | isSuffixOf "/" d = reverse $ tail $ reverse d - | otherwise = d - process rs (".":ds) = process rs ds - process ("..":rs) ("..":ds) = process ("..":"..":rs) ds - process ("/":[]) ("..":ds) = process ("/":[]) ds - process (_:rs) ("..":ds) = process rs ds - process rs (d:ds) = process (d:rs) ds - process rs _ = reverse rs - -fixPaths :: [FilePath] -> [FilePath] -fixPaths = nub . map fixPath - -sortCompiledFiles :: [FilePath] -> ([FilePath],[FilePath],[FilePath]) -sortCompiledFiles = foldl split ([],[],[]) where - split fs@(hxx,cxx,os) f - | isSuffixOf ".hpp" f = (hxx++[f],cxx,os) - | isSuffixOf ".h" f = (hxx++[f],cxx,os) - | isSuffixOf ".cpp" f = (hxx,cxx++[f],os) - | isSuffixOf ".cc" f = (hxx,cxx++[f],os) - | isSuffixOf ".a" f = (hxx,cxx,os++[f]) - | isSuffixOf ".o" f = (hxx,cxx,os++[f]) - | otherwise = fs - -checkModuleVersionHash :: VersionHash -> CompileMetadata -> Bool -checkModuleVersionHash h m = cmVersionHash m == h - -checkModuleFreshness :: FilePath -> CompileMetadata -> CompileInfoIO Bool -checkModuleFreshness p (CompileMetadata _ p2 _ is is2 _ _ _ ps xs ts hxx cxx bs _ _) = do - time <- errorFromIO $ getModificationTime $ getCachedPath p "" metadataFilename - (ps2,xs2,ts2) <- findSourceFiles p "" - let e1 = checkMissing ps ps2 - let e2 = checkMissing xs xs2 - let e3 = checkMissing ts ts2 - rm <- checkInput time (p moduleFilename) - f1 <- mapErrorsM (\p3 -> checkInput time $ getCachedPath p3 "" metadataFilename) $ is ++ is2 - f2 <- mapErrorsM (checkInput time . (p2 )) $ ps ++ xs - f3 <- mapErrorsM (checkInput time . getCachedPath p2 "") $ hxx ++ cxx - f4 <- mapErrorsM checkOutput bs - let fresh = not $ any id $ [rm,e1,e2,e3] ++ f1 ++ f2 ++ f3 ++ f4 - return fresh where - checkInput time f = do - exists <- doesFileOrDirExist f - if not exists - then do - compileWarningM $ "Required path \"" ++ f ++ "\" is missing" - return True - else do - time2 <- errorFromIO $ getModificationTime f - if time2 > time - then do - compileWarningM $ "Required path \"" ++ f ++ "\" is newer than cached data" - return True - else return False - checkOutput f = do - exists <- errorFromIO $ doesFileExist f - if not exists - then do - compileWarningM $ "Output file \"" ++ f ++ "\" is missing" - return True - else return False - checkMissing s0 s1 = not $ null $ (Set.fromList s1) `Set.difference` (Set.fromList s0) - doesFileOrDirExist f2 = do - existF <- errorFromIO $ doesFileExist f2 - if existF - then return True - else errorFromIO $ doesDirectoryExist f2 - -getObjectFileResolver :: [ObjectFile] -> [Namespace] -> [CategoryName] -> [FilePath] -getObjectFileResolver os ns ds = resolved ++ nonCategories where - categories = filter isCategoryObjectFile os - nonCategories = map oofFile $ filter (not . isCategoryObjectFile) os - categoryMap = Map.fromList $ map keyByCategory2 categories - keyByCategory2 o = ((ciCategory $ cofCategory o,ciNamespace $ cofCategory o),o) - objectMap = Map.fromList $ map keyBySpec categories - keyBySpec o = (cofCategory o,o) - directDeps = concat $ map resolveDep2 ds - directResolved = map cofCategory directDeps - resolveDep2 d = unwrap $ foldl (<|>) Nothing allChecks <|> Just [] where - allChecks = map (\n -> (d,n) `Map.lookup` categoryMap >>= return . (:[])) (ns ++ [NoNamespace]) - unwrap (Just xs) = xs - unwrap _ = [] - (_,_,resolved) = collectAll Set.empty Set.empty directResolved - collectAll ca fa [] = (ca,fa,[]) - collectAll ca fa (c:cs) - | c `Set.member` ca = collectAll ca fa cs - | otherwise = - case c `Map.lookup` objectMap of - Just (CategoryObjectFile _ ds2 fs) -> (ca',fa'',fs') where - (ca',fa',fs0) = collectAll (c `Set.insert` ca) fa (ds2 ++ cs) - fa'' = fa' `Set.union` (Set.fromList fs) - fs' = (filter (not . flip elem fa') fs) ++ fs0 - _ -> collectAll ca fa cs - -resolveObjectDeps :: [CompileMetadata] -> FilePath -> FilePath -> [([FilePath],CxxOutput)] -> [ObjectFile] -resolveObjectDeps deps p d os = resolvedCategories ++ nonCategories where - categories = filter (isJust . coCategory . snd) os - publicNamespaces = getNamespacesForDeps deps - nonCategories = map OtherObjectFile $ concat $ map fst $ filter (not . isJust . coCategory . snd) os - resolvedCategories = Map.elems $ Map.fromListWith mergeObjectFiles $ map resolveCategory categories - categoryMap = Map.fromList $ directCategories ++ depCategories - directCategories = map (keyByCategory . cxxToId) $ map snd categories - depCategories = map keyByCategory $ concat (map categoriesToIds deps) - getCats dep - -- Allow ModuleOnly when the path is the same. Only needed for tests. - | cmPath dep == p = cmPrivateCategories dep ++ cmPublicCategories dep - | otherwise = cmPublicCategories dep - categoriesToIds dep = map (\c -> CategoryIdentifier (cmPath dep) c (cmNamespace dep)) $ getCats dep - cxxToId (CxxOutput (Just c) _ ns _ _ _) = CategoryIdentifier d c ns - cxxToId _ = undefined - resolveCategory (fs,ca@(CxxOutput _ _ _ ns2 ds _)) = - (cxxToId ca,CategoryObjectFile (cxxToId ca) (filter (/= cxxToId ca) rs) fs) where - rs = concat $ map (resolveDep categoryMap (ns2 ++ publicNamespaces)) ds - -resolveCategoryDeps :: [CategoryName] -> [CompileMetadata] -> [CategoryIdentifier] -resolveCategoryDeps cs deps = resolvedCategories where - publicNamespaces = getNamespacesForDeps deps - resolvedCategories = concat $ map (resolveDep categoryMap publicNamespaces) cs - categoryMap = Map.fromList depCategories - depCategories = map (keyByCategory . cofCategory) $ filter isCategoryObjectFile $ concat $ map cmObjectFiles deps - -keyByCategory :: CategoryIdentifier -> ((CategoryName,Namespace),CategoryIdentifier) -keyByCategory c = ((ciCategory c,ciNamespace c),c) - -resolveDep :: Map.Map (CategoryName,Namespace) CategoryIdentifier -> - [Namespace] -> CategoryName -> [CategoryIdentifier] -resolveDep cm (n:ns) d = - case (d,n) `Map.lookup` cm of - Just xs -> [xs] - Nothing -> resolveDep cm ns d -resolveDep _ _ d = [UnresolvedCategory d] diff --git a/src/Cli/RunCompiler.hs b/src/Cli/RunCompiler.hs --- a/src/Cli/RunCompiler.hs +++ b/src/Cli/RunCompiler.hs @@ -29,14 +29,14 @@ import qualified Data.Set as Set import Base.CompileError +import Base.CompileInfo import Base.Mergeable -import Cli.CompileMetadata import Cli.CompileOptions import Cli.Compiler import Cli.Paths -import Cli.ProcessMetadata import Cli.Programs -import Base.CompileInfo +import Module.CompileMetadata +import Module.ProcessMetadata runCompiler :: (PathIOHandler r, CompilerBackend b) => r -> b -> CompileOptions -> CompileInfoIO () diff --git a/src/Cli/TestRunner.hs b/src/Cli/TestRunner.hs --- a/src/Cli/TestRunner.hs +++ b/src/Cli/TestRunner.hs @@ -31,13 +31,13 @@ import Text.Regex.TDFA -- Not safe! import Base.CompileError +import Base.CompileInfo import Base.Mergeable -import Cli.CompileMetadata -import Cli.ProcessMetadata import Cli.Programs -import Base.CompileInfo import CompilerCxx.Category import CompilerCxx.Naming +import Module.CompileMetadata +import Module.ProcessMetadata import Parser.SourceFile import Types.IntegrationTest import Types.TypeCategory @@ -129,7 +129,7 @@ (_,xx) <- compileLanguageModule cm [xs] main <- case e of Just e2 -> compileTestMain cm xs e2 - Nothing -> compileErrorM "Expected compiler error" + Nothing -> compileErrorM "" return (xx,main) checkRequired rs comp err out = mergeAllM $ map (checkSubsetForRegex True comp err out) rs diff --git a/src/Module/CompileMetadata.hs b/src/Module/CompileMetadata.hs new file mode 100644 --- /dev/null +++ b/src/Module/CompileMetadata.hs @@ -0,0 +1,115 @@ +{- ----------------------------------------------------------------------------- +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 Module.CompileMetadata ( + CategoryIdentifier(..), + CompileMetadata(..), + ModuleConfig(..), + ObjectFile(..), + isCategoryObjectFile, + mergeObjectFiles, +) where + +import Data.List (nub) +import Text.Parsec (SourcePos) + +import Cli.CompileOptions +import Cli.Programs (VersionHash) +import Types.Procedure (Expression) +import Types.TypeCategory (Namespace) +import Types.TypeInstance (CategoryName) + + +data CompileMetadata = + CompileMetadata { + cmVersionHash :: VersionHash, + cmPath :: FilePath, + cmNamespace :: Namespace, + cmPublicDeps :: [FilePath], + cmPrivateDeps :: [FilePath], + cmPublicCategories :: [CategoryName], + cmPrivateCategories :: [CategoryName], + cmSubdirs :: [FilePath], + cmPublicFiles :: [FilePath], + cmPrivateFiles :: [FilePath], + cmTestFiles :: [FilePath], + cmHxxFiles :: [FilePath], + cmCxxFiles :: [FilePath], + cmBinaries :: [FilePath], + cmLinkFlags :: [FilePath], + cmObjectFiles :: [ObjectFile] + } + deriving (Eq,Show) + +data ObjectFile = + CategoryObjectFile { + cofCategory :: CategoryIdentifier, + cofRequires :: [CategoryIdentifier], + cofFiles :: [FilePath] + } | + OtherObjectFile { + oofFile :: FilePath + } + deriving (Eq,Show) + +data CategoryIdentifier = + CategoryIdentifier { + ciPath :: FilePath, + ciCategory :: CategoryName, + ciNamespace :: Namespace + } | + UnresolvedCategory { + ucCategory :: CategoryName + } + deriving (Eq,Ord,Show) + +mergeObjectFiles :: ObjectFile -> ObjectFile -> ObjectFile +mergeObjectFiles (CategoryObjectFile c rs1 fs1) (CategoryObjectFile _ rs2 fs2) = + CategoryObjectFile c (nub $ rs1 ++ rs2) (nub $ fs1 ++ fs2) +mergeObjectFiles o _ = o + +isCategoryObjectFile :: ObjectFile -> Bool +isCategoryObjectFile (CategoryObjectFile _ _ _) = True +isCategoryObjectFile (OtherObjectFile _) = False + +data ModuleConfig = + ModuleConfig { + rmRoot :: FilePath, + rmPath :: FilePath, + rmExprMap :: [(String,Expression SourcePos)], + rmPublicDeps :: [FilePath], + rmPrivateDeps :: [FilePath], + rmExtraFiles :: [ExtraSource], + rmExtraPaths :: [FilePath], + rmMode :: CompileMode + } + deriving (Show) + +instance Eq ModuleConfig where + (ModuleConfig pA dA _ isA is2A esA epA mA) == (ModuleConfig pB dB _ isB is2B esB epB mB) = + all id [ + pA == pB, + dA == dB, + isA == isB, + is2A == is2B, + esA == esB, + epA == epB, + mA == mB + ] diff --git a/src/Module/ParseMetadata.hs b/src/Module/ParseMetadata.hs new file mode 100644 --- /dev/null +++ b/src/Module/ParseMetadata.hs @@ -0,0 +1,382 @@ +{- ----------------------------------------------------------------------------- +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] + +module Module.ParseMetadata ( + ConfigFormat, + autoReadConfig, + autoWriteConfig, +) where + +import Control.Monad (when) +import Text.Parsec +import Text.Parsec.String + +import Base.CompileError +import Cli.CompileOptions +import Cli.Programs (VersionHash(..)) +import Module.CompileMetadata +import Parser.Common +import Parser.Procedure () +import Parser.Pragma (parseMacroName) +import Parser.TypeCategory () +import Parser.TypeInstance () +import Text.Regex.TDFA -- Not safe! +import Types.Procedure (Expression) +import Types.TypeCategory (FunctionName(..),Namespace(..)) +import Types.TypeInstance (CategoryName(..)) + + +class ConfigFormat a where + readConfig :: Parser a + writeConfig :: CompileErrorM m => a -> m [String] + +autoReadConfig :: (ConfigFormat a, CompileErrorM m) => String -> String -> m a +autoReadConfig f s = unwrap parsed where + parsed = parse (between optionalSpace endOfDoc readConfig) f s + unwrap (Left e) = compileErrorM (show e) + unwrap (Right t) = return t + +autoWriteConfig :: (ConfigFormat a, CompileErrorM m) => a -> m String +autoWriteConfig = fmap unlines . writeConfig + +structOpen :: Parser () +structOpen = sepAfter (string_ "{") + +structClose :: Parser () +structClose = sepAfter (string_ "}") + +indents :: [String] -> [String] +indents = map indent + +indent :: String -> String +indent = (" " ++) + +prependFirst :: String -> [String] -> [String] +prependFirst s0 (s:ss) = (s0 ++ s):ss +prependFirst s0 _ = [s0] + +validateCategoryName :: CompileErrorM m => CategoryName -> m () +validateCategoryName c = + when (not $ show c =~ "^[A-Z][A-Za-z0-9]*$") $ + compileErrorM $ "Invalid category name: \"" ++ show c ++ "\"" + +parseCategoryName :: Parser CategoryName +parseCategoryName = sourceParser :: Parser CategoryName + +validateFunctionName :: CompileErrorM m => FunctionName -> m () +validateFunctionName f = + when (not $ show f =~ "^[a-z][A-Za-z0-9]*$") $ + compileErrorM $ "Invalid function name: \"" ++ show f ++ "\"" + +parseFunctionName :: Parser FunctionName +parseFunctionName = sourceParser :: Parser FunctionName + +validateHash :: CompileErrorM m => VersionHash -> m () +validateHash h = + when (not $ show h =~ "^[A-Za-z0-9]+$") $ + compileErrorM $ "Version hash must be a hex string: \"" ++ show h ++ "\"" + +parseHash :: Parser VersionHash +parseHash = labeled "version hash" $ sepAfter (fmap VersionHash $ many1 hexDigit) + +maybeShowNamespace :: CompileErrorM 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 ++ "\"" + return [l ++ " " ++ ns] +maybeShowNamespace _ _ = return [] + +parseNamespace :: Parser Namespace +parseNamespace = labeled "namespace" $ do + b <- lower + e <- sepAfter $ many (alphaNum <|> char '_') + return $ StaticNamespace (b:e) + +parseQuoted :: Parser String +parseQuoted = labeled "quoted string" $ do + string_ "\"" + ss <- manyTill stringChar (string_ "\"") + optionalSpace + return ss + +parseList :: Parser a -> Parser [a] +parseList p = labeled "list" $ do + sepAfter (string_ "[") + xs <- manyTill (sepAfter p) (string_ "]") + optionalSpace + return xs + +parseOptional :: String -> a -> Parser a -> Parser a +parseOptional l def p = parseRequired l p <|> return def + +parseRequired :: String -> Parser a -> Parser a +parseRequired l p = do + try $ sepAfter (string_ l) + p + +instance ConfigFormat CompileMetadata where + readConfig = do + h <- parseRequired "version_hash:" parseHash + p <- parseRequired "path:" parseQuoted + ns <- parseOptional "namespace:" NoNamespace parseNamespace + is <- parseRequired "public_deps:" (parseList parseQuoted) + is2 <- parseRequired "private_deps:" (parseList parseQuoted) + cs1 <- parseRequired "public_categories:" (parseList parseCategoryName) + cs2 <- parseRequired "private_categories:" (parseList parseCategoryName) + ds <- parseRequired "subdirs:" (parseList parseQuoted) + ps <- parseRequired "public_files:" (parseList parseQuoted) + xs <- parseRequired "private_files:" (parseList parseQuoted) + ts <- parseRequired "test_files:" (parseList parseQuoted) + hxx <- parseRequired "hxx_files:" (parseList parseQuoted) + cxx <- parseRequired "cxx_files:" (parseList parseQuoted) + bs <- parseRequired "binaries:" (parseList parseQuoted) + lf <- parseRequired "link_flags:" (parseList parseQuoted) + os <- parseRequired "object_files:" (parseList readConfig) + return (CompileMetadata h p ns is is2 cs1 cs2 ds ps xs ts hxx cxx bs lf os) + writeConfig m = do + validateHash (cmVersionHash m) + namespace <- maybeShowNamespace "namespace:" (cmNamespace m) + _ <- mapErrorsM validateCategoryName (cmPublicCategories m) + _ <- mapErrorsM validateCategoryName (cmPrivateCategories m) + objects <- fmap concat $ mapErrorsM writeConfig $ cmObjectFiles m + return $ [ + "version_hash: " ++ (show $ cmVersionHash m), + "path: " ++ (show $ cmPath m) + ] ++ namespace ++ [ + "public_deps: [" + ] ++ indents (map show $ cmPublicDeps m) ++ [ + "]", + "private_deps: [" + ] ++ indents (map show $ cmPrivateDeps m) ++ [ + "]", + "public_categories: [" + ] ++ indents (map show $ cmPublicCategories m) ++ [ + "]", + "private_categories: [" + ] ++ indents (map show $ cmPrivateCategories m) ++ [ + "]", + "subdirs: [" + ] ++ indents (map show $ cmSubdirs m) ++ [ + "]", + "public_files: [" + ] ++ indents (map show $ cmPublicFiles m) ++ [ + "]", + "private_files: [" + ] ++ indents (map show $ cmPrivateFiles m) ++ [ + "]", + "test_files: [" + ] ++ indents (map show $ cmTestFiles m) ++ [ + "]", + "hxx_files: [" + ] ++ indents (map show $ cmHxxFiles m) ++ [ + "]", + "cxx_files: [" + ] ++ indents (map show $ cmCxxFiles m) ++ [ + "]", + "binaries: [" + ] ++ indents (map show $ cmBinaries m) ++ [ + "]", + "link_flags: [" + ] ++ indents (map show $ cmLinkFlags m) ++ [ + "]", + "object_files: [" + ] ++ indents objects ++ [ + "]" + ] + +instance ConfigFormat ObjectFile where + readConfig = category <|> other where + category = do + sepAfter (string_ "category_object") + structOpen + c <- parseRequired "category:" readConfig + rs <- parseRequired "requires:" (parseList readConfig) + fs <- parseRequired "files:" (parseList parseQuoted) + structClose + return (CategoryObjectFile c rs fs) + other = do + sepAfter (string_ "other_object") + structOpen + f <- parseRequired "file:" parseQuoted + structClose + return (OtherObjectFile f) + writeConfig (CategoryObjectFile c rs fs) = do + category <- writeConfig c + requires <- fmap concat $ mapErrorsM writeConfig rs + return $ [ + "category_object {" + ] ++ indents ("category: " `prependFirst` category) ++ [ + indent "requires: [" + ] ++ (indents . indents) requires ++ [ + indent "]", + indent "files: [" + ] ++ (indents . indents) (map show fs) ++ [ + indent "]", + "}" + ] + writeConfig (OtherObjectFile f) = do + return $ [ + "other_object {", + indent ("file: " ++ show f), + "}" + ] + +instance ConfigFormat CategoryIdentifier where + readConfig = category <|> unresolved where + category = do + sepAfter (string_ "category") + structOpen + c <- parseRequired "name:" parseCategoryName + ns <- parseOptional "namespace:" NoNamespace parseNamespace + p <- parseRequired "path:" parseQuoted + structClose + return (CategoryIdentifier p c ns) + unresolved = do + sepAfter (string_ "unresolved") + structOpen + c <- parseRequired "name:" parseCategoryName + structClose + return (UnresolvedCategory c) + writeConfig (CategoryIdentifier p c ns) = do + validateCategoryName c + namespace <- maybeShowNamespace "namespace:" ns + return $ [ + "category {", + indent $ "name: " ++ show c + ] ++ indents namespace ++ [ + indent $ "path: " ++ show p, + "}" + ] + writeConfig (UnresolvedCategory c) = do + validateCategoryName c + return $ ["unresolved { " ++ "name: " ++ show c ++ " " ++ "}"] + +instance ConfigFormat ModuleConfig where + readConfig = do + p <- parseOptional "root:" "" parseQuoted + d <- parseRequired "path:" parseQuoted + em <- parseOptional "expression_map:" [] (parseList parseExprMacro) + is <- parseOptional "public_deps:" [] (parseList parseQuoted) + is2 <- parseOptional "private_deps:" [] (parseList parseQuoted) + es <- parseOptional "extra_files:" [] (parseList readConfig) + ep <- parseOptional "include_paths:" [] (parseList parseQuoted) + m <- parseRequired "mode:" readConfig + return (ModuleConfig p d em is is2 es ep m) + writeConfig m = do + extra <- fmap concat $ mapErrorsM writeConfig $ rmExtraFiles m + mode <- writeConfig (rmMode m) + when (not $ null $ rmExprMap m) $ compileErrorM "Only empty expression maps are allowed when writing" + return $ [ + "root: " ++ show (rmRoot m), + "path: " ++ show (rmPath m), + "expression_map: [", + -- NOTE: expression_map isn't output because that would require making + -- all Expression serializable. + "]", + "public_deps: [" + ] ++ indents (map show $ rmPublicDeps m) ++ [ + "]", + "private_deps: [" + ] ++ indents (map show $ rmPrivateDeps m) ++ [ + "]", + "extra_files: [" + ] ++ indents extra ++ [ + "]", + "include_paths: [" + ] ++ indents (map show $ rmExtraPaths m) ++ [ + "]" + ] ++ "mode: " `prependFirst` mode + +instance ConfigFormat ExtraSource where + readConfig = category <|> other where + category = do + sepAfter (string_ "category_source") + structOpen + f <- parseRequired "source:" parseQuoted + cs <- parseOptional "categories:" [] (parseList parseCategoryName) + ds <- parseOptional "requires:" [] (parseList parseCategoryName) + structClose + return (CategorySource f cs ds) + other = do + f <- parseQuoted + return (OtherSource f) + writeConfig (CategorySource f cs ds) = do + _ <- mapErrorsM validateCategoryName cs + _ <- mapErrorsM validateCategoryName ds + return $ [ + "category_source {", + indent ("source: " ++ show f), + indent "categories: [" + ] ++ (indents . indents . map show) cs ++ [ + indent "]", + indent "requires: [" + ] ++ (indents . indents . map show) ds ++ [ + indent "]", + "}" + ] + writeConfig (OtherSource f) = return [show f] + +instance ConfigFormat CompileMode where + readConfig = labeled "compile mode" $ binary <|> incremental where + binary = do + sepAfter (string_ "binary") + structOpen + c <- parseRequired "category:" parseCategoryName + f <- parseRequired "function:" parseFunctionName + o <- parseOptional "output:" "" parseQuoted + lf <- parseOptional "link_flags:" [] (parseList parseQuoted) + structClose + return (CompileBinary c f o lf) + incremental = do + sepAfter (string_ "incremental") + structOpen + lf <- parseOptional "link_flags:" [] (parseList parseQuoted) + structClose + return (CompileIncremental lf) + writeConfig (CompileBinary c f o lf) = do + validateCategoryName c + validateFunctionName f + return $ [ + "binary {", + indent ("category: " ++ show c), + indent ("function: " ++ show f), + indent ("output: " ++ show o), + indent ("link_flags: [") + ] ++ (indents . indents) (map show lf) ++ [ + indent "]", + "}" + ] + writeConfig (CompileIncremental lf) = do + return $ [ + "incremental {", + indent ("link_flags: [") + ] ++ (indents . indents) (map show lf) ++ [ + indent "]", + "}" + ] + writeConfig CompileUnspecified = writeConfig (CompileIncremental []) + writeConfig _ = compileErrorM "Invalid compile mode" + +parseExprMacro :: Parser (String,Expression SourcePos) +parseExprMacro = do + sepAfter (string_ "expression_macro") + structOpen + n <- parseRequired "name:" parseMacroName + e <- parseRequired "expression:" sourceParser + structClose + return (n,e) diff --git a/src/Module/ProcessMetadata.hs b/src/Module/ProcessMetadata.hs new file mode 100644 --- /dev/null +++ b/src/Module/ProcessMetadata.hs @@ -0,0 +1,390 @@ +{- ----------------------------------------------------------------------------- +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] + +module Module.ProcessMetadata ( + MetadataMap, + createCachePath, + eraseCachedData, + findSourceFiles, + fixPath, + fixPaths, + getCachedPath, + getCacheRelativePath, + getExprMap, + getIncludePathsForDeps, + getLinkFlagsForDeps, + getNamespacesForDeps, + getObjectFilesForDeps, + getObjectFileResolver, + getRealPathsForDeps, + getSourceFilesForDeps, + isPathConfigured, + isPathUpToDate, + loadModuleMetadata, + loadPrivateDeps, + loadPublicDeps, + loadRecompile, + loadTestingDeps, + mapMetadata, + resolveCategoryDeps, + resolveObjectDeps, + sortCompiledFiles, + writeCachedFile, + writeMetadata, + writeRecompile, +) where + +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Data.List (nub,isSuffixOf) +import Data.Maybe (isJust) +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 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 Types.Procedure (Expression(Literal),ValueLiteral(..)) +import Types.TypeCategory +import Types.TypeInstance + + +cachedDataPath :: FilePath +cachedDataPath = ".zeolite-cache" + +moduleFilename :: FilePath +moduleFilename = ".zeolite-module" + +metadataFilename :: FilePath +metadataFilename = "compile-metadata" + +type MetadataMap = Map.Map FilePath CompileMetadata + +mapMetadata :: [CompileMetadata] -> MetadataMap +mapMetadata cs = Map.fromList $ zip (map cmPath cs) cs + +loadRecompile :: FilePath -> CompileInfoIO ModuleConfig +loadRecompile p = do + let f = p moduleFilename + isFile <- errorFromIO $ doesFileExist p + when isFile $ compileErrorM $ "Path \"" ++ p ++ "\" is not a directory" + isDir <- errorFromIO $ doesDirectoryExist p + when (not isDir) $ compileErrorM $ "Path \"" ++ p ++ "\" does not exist" + filePresent <- errorFromIO $ doesFileExist f + when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been configured yet" + c <- errorFromIO $ readFile f + (autoReadConfig f c) ForceMode -> FilePath -> CompileInfoIO Bool +isPathUpToDate h f p = do + m <- errorFromIO $ toCompileInfo $ loadDepsCommon f h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p] + return $ not $ isCompileError m + +isPathConfigured :: FilePath -> CompileInfoIO Bool +isPathConfigured p = do + m <- errorFromIO $ toCompileInfo $ loadRecompile p + return $ not $ isCompileError m + +writeMetadata :: FilePath -> CompileMetadata -> CompileInfoIO () +writeMetadata p m = do + p' <- errorFromIO $ canonicalizePath p + errorFromIO $ hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"." + m' <- autoWriteConfig m ModuleConfig -> CompileInfoIO () +writeRecompile p m = do + p' <- errorFromIO $ canonicalizePath p + let f = p moduleFilename + errorFromIO $ hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"." + m' <- autoWriteConfig m CompileInfoIO () +eraseCachedData p = do + let d = p cachedDataPath + dirExists <- errorFromIO $ doesDirectoryExist d + when dirExists $ errorFromIO $ removeDirectoryRecursive d + +createCachePath :: FilePath -> CompileInfoIO () +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 p ns f c = do + createCachePath p + errorFromIO $ createDirectoryIfMissing False $ p cachedDataPath ns + errorFromIO $ writeFile (getCachedPath p ns f) c + +getCachedPath :: FilePath -> String -> FilePath -> FilePath +getCachedPath p ns f = fixPath $ p cachedDataPath ns f + +getCacheRelativePath :: FilePath -> FilePath +getCacheRelativePath f = ".." f + +findSourceFiles :: FilePath -> FilePath -> CompileInfoIO ([FilePath],[FilePath],[FilePath]) +findSourceFiles p0 p = do + let absolute = p0 p + isFile <- errorFromIO $ doesFileExist absolute + when isFile $ compileErrorM $ "Path \"" ++ absolute ++ "\" is not a directory" + isDir <- errorFromIO $ doesDirectoryExist absolute + when (not isDir) $ compileErrorM $ "Path \"" ++ absolute ++ "\" does not exist" + ds <- errorFromIO $ getDirectoryContents absolute >>= return . map (p ) + let ps = filter (isSuffixOf ".0rp") ds + let xs = filter (isSuffixOf ".0rx") ds + let ts = filter (isSuffixOf ".0rt") ds + return (ps,xs,ts) + +getExprMap :: FilePath -> ModuleConfig -> CompileInfoIO (ExprMap SourcePos) +getExprMap p m = do + path <- errorFromIO $ canonicalizePath (p rmRoot m rmPath m) + let defaults = [("MODULE_PATH",Literal (StringLiteral [] path))] + return $ Map.fromList $ rmExprMap m ++ defaults + +getRealPathsForDeps :: [CompileMetadata] -> [FilePath] +getRealPathsForDeps = map cmPath + +getSourceFilesForDeps :: [CompileMetadata] -> [FilePath] +getSourceFilesForDeps = concat . map extract where + extract m = map (cmPath m ) (cmPublicFiles m) + +getNamespacesForDeps :: [CompileMetadata] -> [Namespace] +getNamespacesForDeps = filter (not . isNoNamespace) . map cmNamespace + +getIncludePathsForDeps :: [CompileMetadata] -> [FilePath] +getIncludePathsForDeps = concat . map cmSubdirs + +getLinkFlagsForDeps :: [CompileMetadata] -> [String] +getLinkFlagsForDeps = concat . map cmLinkFlags + +getObjectFilesForDeps :: [CompileMetadata] -> [ObjectFile] +getObjectFilesForDeps = concat . map cmObjectFiles + +loadModuleMetadata :: VersionHash -> ForceMode -> MetadataMap -> FilePath -> + CompileInfoIO CompileMetadata +loadModuleMetadata h f ca = fmap head . loadDepsCommon f h ca Set.empty (const []) . (:[]) + +loadPublicDeps :: VersionHash -> ForceMode -> MetadataMap -> [FilePath] -> + CompileInfoIO [CompileMetadata] +loadPublicDeps h f ca = loadDepsCommon f h ca Set.empty cmPublicDeps + +loadTestingDeps :: VersionHash -> ForceMode -> MetadataMap -> CompileMetadata -> + CompileInfoIO [CompileMetadata] +loadTestingDeps h f ca m = loadDepsCommon f h ca (Set.fromList [cmPath m]) cmPublicDeps (cmPublicDeps m ++ cmPrivateDeps m) + +loadPrivateDeps :: VersionHash -> ForceMode -> MetadataMap -> [CompileMetadata] -> + CompileInfoIO [CompileMetadata] +loadPrivateDeps h f ca ms = do + new <- loadDepsCommon f h ca pa (\m -> cmPublicDeps m ++ cmPrivateDeps m) paths + return $ ms ++ new where + paths = concat $ map (\m -> cmPublicDeps m ++ cmPrivateDeps m) ms + pa = Set.fromList $ map cmPath ms + +loadDepsCommon :: ForceMode -> VersionHash -> MetadataMap -> Set.Set FilePath -> + (CompileMetadata -> [FilePath]) -> [FilePath] -> CompileInfoIO [CompileMetadata] +loadDepsCommon f h ca pa0 getDeps ps = do + (_,processed) <- fixedPaths >>= collect (pa0,[]) + mapErrorsM check processed where + enforce = f /= ForceAll + fixedPaths = mapM (errorFromIO . canonicalizePath) ps + collect xa@(pa,xs) (p:ps2) + | p `Set.member` pa = collect xa ps2 + | otherwise = do + let continue m ds = collect (p `Set.insert` pa,xs ++ [m]) (ps2 ++ ds) + case p `Map.lookup` ca of + Just m2 -> continue m2 [] + Nothing -> do + errorFromIO $ hPutStrLn stderr $ "Loading metadata for dependency \"" ++ p ++ "\"." + m2 <- loadMetadata ca p + let ds = getDeps m2 + continue m2 ds + collect xa _ = return xa + check m + | cmPath m `Map.member` ca = return m + | otherwise = do + fresh <- checkModuleFreshness (cmPath m) m + let sameVersion = checkModuleVersionHash h m + when (enforce && not fresh) $ + compileErrorM $ "Module \"" ++ cmPath m ++ "\" is out of date and should be recompiled" + when (enforce && not sameVersion) $ + compileErrorM $ "Module \"" ++ cmPath m ++ "\" was compiled with a different compiler setup" + return m + +loadMetadata :: MetadataMap -> FilePath -> CompileInfoIO CompileMetadata +loadMetadata ca p = do + path <- errorFromIO $ canonicalizePath p + case path `Map.lookup` ca of + Just cm -> return cm + Nothing -> do + let f = p cachedDataPath metadataFilename + isFile <- errorFromIO $ doesFileExist p + when isFile $ compileErrorM $ "Path \"" ++ p ++ "\" is not a directory" + isDir <- errorFromIO $ doesDirectoryExist p + when (not isDir) $ compileErrorM $ "Path \"" ++ p ++ "\" does not exist" + filePresent <- errorFromIO $ doesFileExist f + when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been compiled yet" + c <- errorFromIO $ readFile f + (autoReadConfig f c) FilePath +fixPath = foldl () "" . process [] . map dropSlash . splitPath where + dropSlash "/" = "/" + dropSlash d + | isSuffixOf "/" d = reverse $ tail $ reverse d + | otherwise = d + process rs (".":ds) = process rs ds + process ("..":rs) ("..":ds) = process ("..":"..":rs) ds + process ("/":[]) ("..":ds) = process ("/":[]) ds + process (_:rs) ("..":ds) = process rs ds + process rs (d:ds) = process (d:rs) ds + process rs _ = reverse rs + +fixPaths :: [FilePath] -> [FilePath] +fixPaths = nub . map fixPath + +sortCompiledFiles :: [FilePath] -> ([FilePath],[FilePath],[FilePath]) +sortCompiledFiles = foldl split ([],[],[]) where + split fs@(hxx,cxx,os) f + | isSuffixOf ".hpp" f = (hxx++[f],cxx,os) + | isSuffixOf ".h" f = (hxx++[f],cxx,os) + | isSuffixOf ".cpp" f = (hxx,cxx++[f],os) + | isSuffixOf ".cc" f = (hxx,cxx++[f],os) + | isSuffixOf ".a" f = (hxx,cxx,os++[f]) + | isSuffixOf ".o" f = (hxx,cxx,os++[f]) + | otherwise = fs + +checkModuleVersionHash :: VersionHash -> CompileMetadata -> Bool +checkModuleVersionHash h m = cmVersionHash m == h + +checkModuleFreshness :: FilePath -> CompileMetadata -> CompileInfoIO Bool +checkModuleFreshness p (CompileMetadata _ p2 _ is is2 _ _ _ ps xs ts hxx cxx bs _ _) = do + time <- errorFromIO $ getModificationTime $ getCachedPath p "" metadataFilename + (ps2,xs2,ts2) <- findSourceFiles p "" + let e1 = checkMissing ps ps2 + let e2 = checkMissing xs xs2 + let e3 = checkMissing ts ts2 + rm <- checkInput time (p moduleFilename) + f1 <- mapErrorsM (\p3 -> checkInput time $ getCachedPath p3 "" metadataFilename) $ is ++ is2 + f2 <- mapErrorsM (checkInput time . (p2 )) $ ps ++ xs + f3 <- mapErrorsM (checkInput time . getCachedPath p2 "") $ hxx ++ cxx + f4 <- mapErrorsM checkOutput bs + let fresh = not $ any id $ [rm,e1,e2,e3] ++ f1 ++ f2 ++ f3 ++ f4 + return fresh where + checkInput time f = do + exists <- doesFileOrDirExist f + if not exists + then do + compileWarningM $ "Required path \"" ++ f ++ "\" is missing" + return True + else do + time2 <- errorFromIO $ getModificationTime f + if time2 > time + then do + compileWarningM $ "Required path \"" ++ f ++ "\" is newer than cached data" + return True + else return False + checkOutput f = do + exists <- errorFromIO $ doesFileExist f + if not exists + then do + compileWarningM $ "Output file \"" ++ f ++ "\" is missing" + return True + else return False + checkMissing s0 s1 = not $ null $ (Set.fromList s1) `Set.difference` (Set.fromList s0) + doesFileOrDirExist f2 = do + existF <- errorFromIO $ doesFileExist f2 + if existF + then return True + else errorFromIO $ doesDirectoryExist f2 + +getObjectFileResolver :: [ObjectFile] -> [Namespace] -> [CategoryName] -> [FilePath] +getObjectFileResolver os ns ds = resolved ++ nonCategories where + categories = filter isCategoryObjectFile os + nonCategories = map oofFile $ filter (not . isCategoryObjectFile) os + categoryMap = Map.fromList $ map keyByCategory2 categories + keyByCategory2 o = ((ciCategory $ cofCategory o,ciNamespace $ cofCategory o),o) + objectMap = Map.fromList $ map keyBySpec categories + keyBySpec o = (cofCategory o,o) + directDeps = concat $ map resolveDep2 ds + directResolved = map cofCategory directDeps + resolveDep2 d = unwrap $ foldl (<|>) Nothing allChecks <|> Just [] where + allChecks = map (\n -> (d,n) `Map.lookup` categoryMap >>= return . (:[])) (ns ++ [NoNamespace]) + unwrap (Just xs) = xs + unwrap _ = [] + (_,_,resolved) = collectAll Set.empty Set.empty directResolved + collectAll ca fa [] = (ca,fa,[]) + collectAll ca fa (c:cs) + | c `Set.member` ca = collectAll ca fa cs + | otherwise = + case c `Map.lookup` objectMap of + Just (CategoryObjectFile _ ds2 fs) -> (ca',fa'',fs') where + (ca',fa',fs0) = collectAll (c `Set.insert` ca) fa (ds2 ++ cs) + fa'' = fa' `Set.union` (Set.fromList fs) + fs' = (filter (not . flip elem fa') fs) ++ fs0 + _ -> collectAll ca fa cs + +resolveObjectDeps :: [CompileMetadata] -> FilePath -> FilePath -> [([FilePath],CxxOutput)] -> [ObjectFile] +resolveObjectDeps deps p d os = resolvedCategories ++ nonCategories where + categories = filter (isJust . coCategory . snd) os + publicNamespaces = getNamespacesForDeps deps + nonCategories = map OtherObjectFile $ concat $ map fst $ filter (not . isJust . coCategory . snd) os + resolvedCategories = Map.elems $ Map.fromListWith mergeObjectFiles $ map resolveCategory categories + categoryMap = Map.fromList $ directCategories ++ depCategories + directCategories = map (keyByCategory . cxxToId) $ map snd categories + depCategories = map keyByCategory $ concat (map categoriesToIds deps) + getCats dep + -- Allow ModuleOnly when the path is the same. Only needed for tests. + | cmPath dep == p = cmPrivateCategories dep ++ cmPublicCategories dep + | otherwise = cmPublicCategories dep + categoriesToIds dep = map (\c -> CategoryIdentifier (cmPath dep) c (cmNamespace dep)) $ getCats dep + cxxToId (CxxOutput (Just c) _ ns _ _ _) = CategoryIdentifier d c ns + cxxToId _ = undefined + resolveCategory (fs,ca@(CxxOutput _ _ _ ns2 ds _)) = + (cxxToId ca,CategoryObjectFile (cxxToId ca) (filter (/= cxxToId ca) rs) fs) where + rs = concat $ map (resolveDep categoryMap (ns2 ++ publicNamespaces)) ds + +resolveCategoryDeps :: [CategoryName] -> [CompileMetadata] -> [CategoryIdentifier] +resolveCategoryDeps cs deps = resolvedCategories where + publicNamespaces = getNamespacesForDeps deps + resolvedCategories = concat $ map (resolveDep categoryMap publicNamespaces) cs + categoryMap = Map.fromList depCategories + depCategories = map (keyByCategory . cofCategory) $ filter isCategoryObjectFile $ concat $ map cmObjectFiles deps + +keyByCategory :: CategoryIdentifier -> ((CategoryName,Namespace),CategoryIdentifier) +keyByCategory c = ((ciCategory c,ciNamespace c),c) + +resolveDep :: Map.Map (CategoryName,Namespace) CategoryIdentifier -> + [Namespace] -> CategoryName -> [CategoryIdentifier] +resolveDep cm (n:ns) d = + case (d,n) `Map.lookup` cm of + Just xs -> [xs] + Nothing -> resolveDep cm ns d +resolveDep _ _ d = [UnresolvedCategory d] diff --git a/src/Parser/Pragma.hs b/src/Parser/Pragma.hs --- a/src/Parser/Pragma.hs +++ b/src/Parser/Pragma.hs @@ -25,6 +25,7 @@ pragmaExprLookup, pragmaNoTrace, pragmaModuleOnly, + pragmaSourceContext, pragmaTestsOnly, pragmaTraceCreation, ) where @@ -57,6 +58,10 @@ name <- parseMacroName return $ PragmaExprLookup [c] name +pragmaSourceContext :: Parser (Pragma SourcePos) +pragmaSourceContext = autoPragma "SourceContext" $ Left parseAt where + parseAt c = PragmaSourceContext c + pragmaNoTrace :: Parser (Pragma SourcePos) pragmaNoTrace = autoPragma "NoTrace" $ Left parseAt where parseAt c = PragmaTracing [c] NoTrace @@ -98,5 +103,5 @@ return x where delegate False (Left f2) c = return $ f2 c delegate True (Right f2) c = f2 c - delegate _ (Left _) _ = fail $ "Pragma " ++ p ++ " does not allow arguments with []" - delegate _ (Right _) _ = fail $ "Pragma " ++ p ++ " requires arguments with []" + delegate _ (Left _) _ = fail $ "Pragma " ++ p ++ " does not allow arguments using []" + delegate _ (Right _) _ = fail $ "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 @@ -427,6 +427,7 @@ variableOrUnqualified <|> builtinCall <|> builtinValue <|> + sourceContext <|> exprLookup <|> try typeOrCategoryCall <|> typeCall where @@ -455,6 +456,11 @@ c <- getPosition n <- builtinValues return $ NamedVariable (OutputValue [c] (VariableName n)) + sourceContext = do + pragma <- pragmaSourceContext + case pragma of + (PragmaSourceContext c) -> return $ ParensExpression [c] $ Literal (StringLiteral [c] (show c)) + _ -> undefined -- Should be caught above. exprLookup = do pragma <- pragmaExprLookup case pragma of diff --git a/src/Test/ParseMetadata.hs b/src/Test/ParseMetadata.hs --- a/src/Test/ParseMetadata.hs +++ b/src/Test/ParseMetadata.hs @@ -23,10 +23,10 @@ import Base.CompileError import Base.CompileInfo -import Cli.CompileMetadata import Cli.CompileOptions -import Cli.ParseMetadata import Cli.Programs (VersionHash(..)) +import Module.CompileMetadata +import Module.ParseMetadata import System.FilePath import Test.Common import Types.Positional diff --git a/src/Test/Pragma.hs b/src/Test/Pragma.hs --- a/src/Test/Pragma.hs +++ b/src/Test/Pragma.hs @@ -42,6 +42,11 @@ [PragmaVisibility _ TestsOnly] -> True _ -> False), + checkParsesAs "$SourceContext$" (fmap (:[]) pragmaSourceContext) + (\e -> case e of + [PragmaSourceContext _] -> True + _ -> False), + checkParsesAs "$NoTrace$" (fmap (:[]) pragmaNoTrace) (\e -> case e of [PragmaTracing _ NoTrace] -> True diff --git a/src/Types/Function.hs b/src/Types/Function.hs --- a/src/Types/Function.hs +++ b/src/Types/Function.hs @@ -70,11 +70,11 @@ where allVariances = Map.union vm (Map.fromList $ zip (pValues ps) (repeat Invariant)) checkCount xa@(x:_:_) = - compileErrorM $ "Param " ++ show x ++ " occurs " ++ show (length xa) ++ " times" + compileErrorM $ "Function parameter " ++ show x ++ " occurs " ++ show (length xa) ++ " times" checkCount _ = return () checkHides n = when (n `Map.member` fm) $ - compileErrorM $ "Param " ++ show n ++ " hides another param in a higher scope" + compileErrorM $ "Function parameter " ++ show n ++ " hides a category-level parameter" checkFilterType fa2 (n,f) = validateTypeFilter r fa2 f [c] -getPragmaContext (PragmaVisibility c _) = c -getPragmaContext (PragmaExprLookup c _) = c -getPragmaContext (PragmaTracing c _) = c -getPragmaContext (PragmaComment c _) = c +getPragmaContext (PragmaVisibility c _) = c +getPragmaContext (PragmaExprLookup c _) = c +getPragmaContext (PragmaSourceContext c) = [c] +getPragmaContext (PragmaTracing c _) = c +getPragmaContext (PragmaComment c _) = c isModuleOnly :: Pragma c -> Bool isModuleOnly (PragmaVisibility _ ModuleOnly) = True @@ -68,6 +73,10 @@ isExprLookup :: Pragma c -> Bool isExprLookup (PragmaExprLookup _ _) = True isExprLookup _ = False + +isSourceContext :: Pragma c -> Bool +isSourceContext (PragmaSourceContext _) = True +isSourceContext _ = False isNoTrace :: Pragma c -> Bool isNoTrace (PragmaTracing _ NoTrace) = True diff --git a/src/Types/TypeCategory.hs b/src/Types/TypeCategory.hs --- a/src/Types/TypeCategory.hs +++ b/src/Types/TypeCategory.hs @@ -652,13 +652,18 @@ validateCategoryFunction r t f = do let fm = getCategoryFilterMap t let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t - ("In function:\n---\n" ++ show f ++ "\n---\n") ??> do + message ??> do funcType <- parsedToFunctionType f case sfScope f of CategoryScope -> validatateFunctionType r Map.empty Map.empty funcType TypeScope -> validatateFunctionType r fm vm funcType ValueScope -> validatateFunctionType r fm vm funcType _ -> return () + where + message + | getCategoryName t == sfType f = "In function:\n---\n" ++ show f ++ "\n---\n" + | otherwise = "In function inherited from " ++ show (sfType f) ++ + formatFullContextBrace (getCategoryContext t) ++ ":\n---\n" ++ show f ++ "\n---\n" topoSortCategories :: (Show c, MergeableM m, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m [AnyCategory c] @@ -678,7 +683,7 @@ update _ ta _ = return ([],ta) mergeObjects :: (MergeableM m, CompileErrorM m) => - (a -> a -> m ()) -> [a] -> m [a] + (a -> a -> m b) -> [a] -> m [a] mergeObjects f = merge [] where merge cs [] = return cs merge cs (x:xs) = do @@ -944,7 +949,6 @@ (Just fs) -> fs _ -> [] - uncheckedSubFunction :: (Show c, MergeableM m, CompileErrorM m) => ParamValues -> ScopedFunction c -> m (ScopedFunction c) uncheckedSubFunction = unfixedSubFunction . fmap fixTypeParams @@ -1011,12 +1015,12 @@ mapErrorsM reduce $ Map.toList gs' where reduce (i,is) = do is' <- reduceMergeTree anyOp allOp leafOp is - let is2 = foldr (:) [] is' - case is2 of - [] -> undefined -- Shouldn't happen. - [i2] -> return i2 + case is' of + [i2] -> noInferred i2 >> return i2 is3 -> compileErrorM $ "Could not reconcile guesses for " ++ show i ++ ": " ++ show is3 - leafOp i = noInferred i >> return [i] + -- Skip filtering out inferred types here, in case the guess can be replaced + -- with something better that doesn't have an inferred type. + leafOp i = return [i] anyOp = mergeObjects anyCheck . sortBy lessGeneral allOp = mergeObjects allCheck . sortBy moreGeneral noInferred (InferredTypeGuess n t _) = @@ -1024,9 +1028,11 @@ compileErrorM $ "Guess " ++ show t ++ " for parameter " ++ show n ++ " contains inferred types" lessGeneral x y = itgVariance y `compare` itgVariance x moreGeneral x y = itgVariance x `compare` itgVariance y - anyCheck (InferredTypeGuess _ g1 v1) (InferredTypeGuess _ g2 _) = + anyCheck ga@(InferredTypeGuess _ g1 v1) (InferredTypeGuess _ g2 _) = do + noInferred ga -- Find the least-general guess: If g1 can be replaced with g2, prefer g1. - noInferredTypes $ checkGeneralMatch r f v1 g1 g2 - allCheck (InferredTypeGuess _ g1 _) (InferredTypeGuess _ g2 v2) = + checkGeneralMatch r f v1 g1 g2 + allCheck ga@(InferredTypeGuess _ g1 _) (InferredTypeGuess _ g2 v2) = do + noInferred ga -- Find the most-general guess: If g2 can be replaced with g1, prefer g1. - noInferredTypes $ checkGeneralMatch r f v2 g2 g1 + checkGeneralMatch r f v2 g2 g1 diff --git a/tests/expr-lookup.0rt b/tests/expr-lookup.0rt --- a/tests/expr-lookup.0rt +++ b/tests/expr-lookup.0rt @@ -203,3 +203,19 @@ concrete Test { @type run () -> () } + + +testcase "source context" { + crash Test$run() + require "tests/expr-lookup\.0rt" +} + +define Test { + run () { + fail($SourceContext$) + } +} + +concrete Test { + @type run () -> () +} diff --git a/tests/regressions.0rt b/tests/regressions.0rt --- a/tests/regressions.0rt +++ b/tests/regressions.0rt @@ -50,3 +50,32 @@ return Value<#z>{ } } } + + +testcase "Issue #73 (2) is fixed" { + error + require "from Base" + require "#x hides" + require "call1" + exclude "call2" +} + +@value interface Base { + call1<#x> (#x) -> () + call2<#x> (#x) -> () +} + +concrete Child<#x> { + refines Base + + // call1 is inherited with #x, which conflicts with #x in Child. + // @value call1<#y> (#y) -> () + + // call2 explicitly overrides #x with #y. + @value call2<#y> (#y) -> () +} + +define Child { + call1 (_) {} + call2 (_) {} +} 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.7.0.2 +version: 0.7.1.0 synopsis: Zeolite is a statically-typed, general-purpose programming language. description: @@ -151,13 +151,10 @@ Base.CompileInfo, Base.MergeTree, Base.Mergeable, - Cli.CompileMetadata, Cli.CompileOptions, Cli.Compiler, Cli.ParseCompileOptions, - Cli.ParseMetadata, Cli.Paths, - Cli.ProcessMetadata, Cli.Programs, Cli.RunCompiler, Cli.TestRunner, @@ -171,6 +168,9 @@ CompilerCxx.Procedure, Config.LoadConfig, Config.LocalConfig, + Module.CompileMetadata, + Module.ParseMetadata, + Module.ProcessMetadata, Parser.Common, Parser.DefinedCategory, Parser.IntegrationTest,