zeolite-lang 0.7.0.2 → 0.7.1.0

raw patch · 22 files changed

+1021/−929 lines, 22 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• bin/zeolite-setup.hs +8/−2
• bin/zeolite.hs +3/−3
• src/Cli/CompileMetadata.hs +0/−115
• src/Cli/Compiler.hs +4/−4
• src/Cli/ParseMetadata.hs +0/−382
• src/Cli/ProcessMetadata.hs +0/−390
• src/Cli/RunCompiler.hs +3/−3
• src/Cli/TestRunner.hs +4/−4
• src/Module/CompileMetadata.hs +115/−0
• src/Module/ParseMetadata.hs +382/−0
• src/Module/ProcessMetadata.hs +390/−0
• src/Parser/Pragma.hs +7/−2
• src/Parser/Procedure.hs +6/−0
• src/Test/ParseMetadata.hs +2/−2
• src/Test/Pragma.hs +5/−0
• src/Types/Function.hs +2/−2
• src/Types/Pragma.hs +13/−4
• src/Types/TypeCategory.hs +18/−12
• tests/expr-lookup.0rt +16/−0
• tests/regressions.0rt +29/−0
• zeolite-lang.cabal +4/−4

@@ -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

@@ -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 = []       }     }

@@ -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 

@@ -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-      ]

@@ -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

@@ -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)

@@ -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) <??-    ("Could not parse metadata from \"" ++ p ++ "\"; please reconfigure")--isPathUpToDate :: VersionHash -> ForceMode -> FilePath -> CompileInfoIO Bool-isPathUpToDate h f p = do-  m <- errorFromIO $ toCompileInfo $ loadDepsCommon f h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p]-  return $ not $ isCompileError m--isPathConfigured :: FilePath -> 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 <?? ("In data for " ++ p)-  writeCachedFile p' "" metadataFilename m'--writeRecompile :: FilePath -> ModuleConfig -> CompileInfoIO ()-writeRecompile p m = do-  p' <- errorFromIO $ canonicalizePath p-  let f = p </> moduleFilename-  errorFromIO $ hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"."-  m' <- autoWriteConfig m <?? ("In data for " ++ p)-  errorFromIO $ writeFile f m'--eraseCachedData :: FilePath -> 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) <??-            ("Could not parse metadata from \"" ++ p ++ "\"; please recompile")--fixPath :: FilePath -> 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]

@@ -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 ()

@@ -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

@@ -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+      ]

@@ -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)

@@ -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) <??+    ("Could not parse metadata from \"" ++ p ++ "\"; please reconfigure")++isPathUpToDate :: VersionHash -> ForceMode -> FilePath -> CompileInfoIO Bool+isPathUpToDate h f p = do+  m <- errorFromIO $ toCompileInfo $ loadDepsCommon f h Map.empty Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p]+  return $ not $ isCompileError m++isPathConfigured :: FilePath -> 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 <?? ("In data for " ++ p)+  writeCachedFile p' "" metadataFilename m'++writeRecompile :: FilePath -> ModuleConfig -> CompileInfoIO ()+writeRecompile p m = do+  p' <- errorFromIO $ canonicalizePath p+  let f = p </> moduleFilename+  errorFromIO $ hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"."+  m' <- autoWriteConfig m <?? ("In data for " ++ p)+  errorFromIO $ writeFile f m'++eraseCachedData :: FilePath -> 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) <??+            ("Could not parse metadata from \"" ++ p ++ "\"; please recompile")++fixPath :: FilePath -> 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]

@@ -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 []"

@@ -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

@@ -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

@@ -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

@@ -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 <?? ("In filter " ++ show n ++ " " ++ show f)     checkFilterVariance (n,f@(TypeFilter FilterRequires t)) =

@@ -26,6 +26,7 @@   isExprLookup,   isModuleOnly,   isNoTrace,+  isSourceContext,   isTestsOnly,   isTraceCreation, ) where@@ -44,6 +45,9 @@     pelContext :: [c],     pelName :: String   } |+  PragmaSourceContext {+    pscContext :: c+  } |   PragmaTracing {     ptContext :: [c],     ptType :: TraceType@@ -56,10 +60,11 @@   deriving (Show)  getPragmaContext :: Pragma c -> [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

@@ -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

@@ -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 () -> ()+}

@@ -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 (_) {}+}

@@ -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,