zeolite-lang 0.4.1.1 → 0.5.0.0

raw patch · 51 files changed

+1806/−723 lines, 51 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +19/−0
• base/category-source.hpp +3/−2
• bin/unit-tests.hs +18/−14
• bin/zeolite-setup.hs +7/−8
• bin/zeolite.hs +1/−1
• lib/math/tests.0rt +24/−24
• src/Cli/CompileMetadata.hs +29/−24
• src/Cli/CompileOptions.hs +25/−21
• src/Cli/Compiler.hs +261/−306
• src/Cli/ParseCompileOptions.hs +9/−3
• src/Cli/ParseMetadata.hs +68/−56
• src/Cli/ProcessMetadata.hs +83/−62
• src/Cli/RunCompiler.hs +188/−0
• src/Cli/TestRunner.hs +33/−38
• src/CompilerCxx/Category.hs +123/−72
• src/CompilerCxx/Naming.hs +4/−0
• src/CompilerCxx/Procedure.hs +9/−1
• src/Config/LoadConfig.hs +48/−21
• src/Config/Paths.hs +0/−1
• src/Config/Programs.hs +7/−1
• src/Parser/Common.hs +26/−6
• src/Parser/Pragma.hs +76/−0
• src/Parser/SourceFile.hs +33/−6
• src/Test/ParseMetadata.hs +77/−39
• src/Test/Pragma.hs +102/−0
• src/Test/Procedure.hs +1/−1
• src/Test/SourceFile.hs +46/−0
• src/Test/testfiles/internal.0rx +5/−0
• src/Test/testfiles/public.0rp +4/−0
• src/Test/testfiles/test.0rt +11/−0
• src/Types/DefinedCategory.hs +1/−1
• src/Types/Pragma.hs +54/−0
• tests/.zeolite-module +1/−1
• tests/cli-tests.sh +102/−13
• tests/helpers.0rp +2/−0
• tests/helpers.0rx +2/−0
• tests/local.0rp +21/−0
• tests/module-only/.zeolite-module +6/−0
• tests/module-only/README.md +20/−0
• tests/module-only/internal/.zeolite-module +3/−0
• tests/module-only/internal/private.0rp +21/−0
• tests/module-only/internal/public.0rp +19/−0
• tests/module-only/private.0rx +24/−0
• tests/reduce.0rt +76/−0
• tests/simple.0rt +15/−0
• tests/tests-only/.zeolite-module +3/−0
• tests/tests-only/README.md +19/−0
• tests/tests-only/private.0rx +21/−0
• tests/tests-only/public1.0rp +21/−0
• tests/tests-only/public2.0rp +19/−0
• zeolite-lang.cabal +16/−1

@@ -1,5 +1,24 @@ # Revision history for zeolite-lang +## 0.5.0.0  -- 2020-05-12++* **[new]** Adds compiler support for pragmas, which will allow compiler+  features that aren't a part of the language:++  - **[new]** `$ModuleOnly$` pragma for `.0rp` files, which limits their+    visibility to the modules that own them.++  - **[new]** `$TestsOnly$` pragma for `.0rp` files, which limits their+    visibility to `.0rt` files, and `.0rx` files that also use `$TestsOnly$`.++* **[new]** Adds support for global seach paths for dependencies via a+  plain-text file at `$(zeolite --get-path)/global-paths`. This can be used to+  set up a separate directory for general-use Zeolite modules.++* **[breaking]** Better handling of symbols from dependencies. This might break+  code that inavertently relied on broken visibility. In particular, `..` in a+  dependency path precludes it from resolving to a system module.+ ## 0.4.1.0  -- 2020-05-05  * **[new]** Adds a compiler mode (`--show-deps`) to display the symbolic

@@ -148,8 +148,6 @@     return target->Dispatch(target, label, params, args);   } -  virtual std::string CategoryName() const = 0;-   static bool Present(S<TypeValue> target);   static S<TypeValue> Require(S<TypeValue> target);   static S<TypeValue> Strong(W<TypeValue> target);@@ -165,6 +163,9 @@   protected:   TypeValue() = default;++  // NOTE: For some reason, making this private causes a segfault.+  virtual std::string CategoryName() const = 0;    virtual bool Present() const; 

@@ -18,24 +18,28 @@  import Base.CompileError import Test.Common-import qualified Test.DefinedCategory as DefinedCategoryTest-import qualified Test.IntegrationTest as IntegrationTestTest-import qualified Test.ParseMetadata   as ParseMetadataTest-import qualified Test.Parser          as ParserTest-import qualified Test.Procedure       as ProcedureTest-import qualified Test.TypeCategory    as TypeCategoryTest-import qualified Test.TypeInstance    as TypeInstanceTest+import qualified Test.DefinedCategory as TestDefinedCategory+import qualified Test.IntegrationTest as TestIntegrationTest+import qualified Test.ParseMetadata   as TestParseMetadata+import qualified Test.Parser          as TestParser+import qualified Test.Pragma          as TestPragma+import qualified Test.Procedure       as TestProcedure+import qualified Test.SourceFile      as TestSourceFile+import qualified Test.TypeCategory    as TestTypeCategory+import qualified Test.TypeInstance    as TestTypeInstance   main :: IO () main = runAllTests $ concat [-    labelWith "DefinedCategoryTest" DefinedCategoryTest.tests,-    labelWith "TypeInstanceTest"    TypeInstanceTest.tests,-    labelWith "ParseMetadataTest"   ParseMetadataTest.tests,-    labelWith "ParserTest"          ParserTest.tests,-    labelWith "TypeCategoryTest"    TypeCategoryTest.tests,-    labelWith "ProcedureTest"       ProcedureTest.tests,-    labelWith "IntegrationTestTest" IntegrationTestTest.tests+    labelWith "DefinedCategory" TestDefinedCategory.tests,+    labelWith "IntegrationTest" TestIntegrationTest.tests,+    labelWith "ParseMetadata"   TestParseMetadata.tests,+    labelWith "Parser"          TestParser.tests,+    labelWith "Pragma"          TestPragma.tests,+    labelWith "Procedure"       TestProcedure.tests,+    labelWith "SourceFile"      TestSourceFile.tests,+    labelWith "TypeCategory"    TestTypeCategory.tests,+    labelWith "TypeInstance"    TestTypeInstance.tests   ]  labelWith :: CompileErrorM m => String -> [IO (m ())] -> [IO (m ())]

@@ -23,7 +23,7 @@ import System.IO  import Cli.CompileOptions-import Cli.Compiler+import Cli.RunCompiler import Config.LoadConfig  @@ -53,10 +53,6 @@ libraries :: [String] libraries = [     "base",-    "tests/visibility/internal",-    "tests/visibility",-    "tests/visibility2/internal",-    "tests/visibility2",     "tests",     "lib/util",     "lib/file",@@ -78,7 +74,10 @@         ucCxxOptions = options,         ucArBinary = archiver       },-      lcResolver = SimpleResolver+      lcResolver = SimpleResolver {+        srVisibleSystem = ["lib"],+        srExtraPaths = []+      }     }   return config @@ -122,11 +121,11 @@       coHelp = HelpNotNeeded,       coPublicDeps = [],       coPrivateDeps = [],-      coSources = libraries,+      coPaths = libraries,       coExtraFiles = [],       coExtraPaths = [],       coSourcePrefix = path,-      coMode = CompileRecompile,+      coMode = CompileRecompileRecursive,       coForce = ForceAll     }   runCompiler options

@@ -23,8 +23,8 @@  import Base.CompileError import Cli.CompileOptions-import Cli.Compiler import Cli.ParseCompileOptions -- Not safe, due to Text.Regex.TDFA.+import Cli.RunCompiler import Compilation.CompileInfo  

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

@@ -30,23 +30,28 @@ import Data.List (nub)  import Cli.CompileOptions+import Config.Programs (VersionHash)+import Types.TypeCategory (Namespace)+import Types.TypeInstance (CategoryName)   data CompileMetadata =   CompileMetadata {-    cmVersionHash :: String,-    cmPath :: String,-    cmNamespace :: String, -- TODO: Use Namespace here?-    cmPublicDeps :: [String],-    cmPrivateDeps :: [String],-    cmCategories :: [String],-    cmSubdirs :: [String],-    cmPublicFiles :: [String],-    cmPrivateFiles :: [String],-    cmTestFiles :: [String],-    cmHxxFiles :: [String],-    cmCxxFiles :: [String],-    cmLinkFlags :: [String],+    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)@@ -55,21 +60,21 @@   CategoryObjectFile {     cofCategory :: CategoryIdentifier,     cofRequires :: [CategoryIdentifier],-    cofFiles :: [String]+    cofFiles :: [FilePath]   } |   OtherObjectFile {-    oofFile :: String+    oofFile :: FilePath   }   deriving (Eq,Show)  data CategoryIdentifier =   CategoryIdentifier {-    ciPath :: String,-    ciCategory :: String,-    ciNamespace :: String+    ciPath :: FilePath,+    ciCategory :: CategoryName,+    ciNamespace :: Namespace   } |   UnresolvedCategory {-    ucCategory :: String+    ucCategory :: CategoryName   }   deriving (Eq,Ord,Show) @@ -84,12 +89,12 @@  data ModuleConfig =   ModuleConfig {-    rmRoot :: String,-    rmPath :: String,-    rmPublicDeps :: [String],-    rmPrivateDeps :: [String],+    rmRoot :: FilePath,+    rmPath :: FilePath,+    rmPublicDeps :: [FilePath],+    rmPrivateDeps :: [FilePath],     rmExtraFiles :: [ExtraSource],-    rmExtraPaths :: [String],+    rmExtraPaths :: [FilePath],     rmMode :: CompileMode   }   deriving (Eq,Show)

@@ -38,19 +38,23 @@   maybeDisableHelp, ) where +import Types.TypeCategory (FunctionName)+import Types.TypeInstance (CategoryName) + data CompileOptions =   CompileOptions {     coHelp :: HelpMode,-    coPublicDeps :: [String],-    coPrivateDeps :: [String],-    coSources :: [String],+    coPublicDeps :: [FilePath],+    coPrivateDeps :: [FilePath],+    coPaths :: [FilePath],     coExtraFiles :: [ExtraSource],-    coExtraPaths :: [String],-    coSourcePrefix :: String,+    coExtraPaths :: [FilePath],+    coSourcePrefix :: FilePath,     coMode :: CompileMode,     coForce :: ForceMode-  } deriving (Show)+  }+  deriving (Show)  emptyCompileOptions :: CompileOptions emptyCompileOptions =@@ -58,7 +62,7 @@     coHelp = HelpUnspecified,     coPublicDeps = [],     coPrivateDeps = [],-    coSources = [],+    coPaths = [],     coExtraFiles = [],     coExtraPaths = [],     coSourcePrefix = "",@@ -68,12 +72,12 @@  data ExtraSource =   CategorySource {-    csSource :: String,-    csCategories :: [String],-    csDepCategories :: [String]+    csSource :: FilePath,+    csCategories :: [CategoryName],+    csDepCategories :: [CategoryName]   } |   OtherSource {-    osSource :: String+    osSource :: FilePath   }   deriving (Eq,Show) @@ -81,32 +85,32 @@ getSourceFile (CategorySource s _ _) = s getSourceFile (OtherSource s)        = s -getSourceCategories :: ExtraSource -> [String]+getSourceCategories :: ExtraSource -> [CategoryName] getSourceCategories (CategorySource _ cs _) = cs getSourceCategories (OtherSource _)         = [] -getSourceDeps :: ExtraSource -> [String]+getSourceDeps :: ExtraSource -> [CategoryName] getSourceDeps (CategorySource _ _ ds) = ds getSourceDeps (OtherSource _)         = []  data HelpMode = HelpNeeded | HelpNotNeeded | HelpUnspecified deriving (Eq,Show) -data ForceMode = DoNotForce | AllowRecompile | ForceRecompile | ForceAll deriving (Eq,Ord,Show)+data ForceMode = DoNotForce | ForceAll deriving (Eq,Ord,Show)  data CompileMode =   CompileBinary {-    cbCategory :: String,-    cbFunction :: String,-    cbOutputName :: String,+    cbCategory :: CategoryName,+    cbFunction :: FunctionName,+    cbOutputName :: FilePath,     cbLinkFlags :: [String]   } |   CompileFast {-    cfCategory :: String,-    cfFunction :: String,-    cfSource :: String+    cfCategory :: CategoryName,+    cfFunction :: FunctionName,+    cfSource :: FilePath   } |   ExecuteTests {-    etInclude :: [String]+    etInclude :: [FilePath]   } |   CompileIncremental {     ciLinkFlags :: [String]

@@ -17,21 +17,25 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  module Cli.Compiler (-  runCompiler,+  LoadedTests(..),+  ModuleSpec(..),+  compileModule,+  createModuleTemplates,+  runModuleTests, ) where -import Control.Monad (when)+import Control.Monad (foldM,when) import Data.Either (partitionEithers)-import Data.List (intercalate,isSuffixOf,nub,sort)+import Data.List (isSuffixOf,nub,sort) import System.Directory import System.Exit import System.FilePath-import System.Posix.Temp (mkdtemp,mkstemps)+import System.Posix.Temp (mkstemps) import System.IO+import Text.Parsec (SourcePos) import qualified Data.Set as Set  import Base.CompileError-import Base.Mergeable import Cli.CompileMetadata import Cli.CompileOptions import Cli.ProcessMetadata@@ -45,230 +49,134 @@ import Parser.SourceFile import Types.Builtin import Types.DefinedCategory+import Types.Pragma import Types.TypeCategory import Types.TypeInstance  -runCompiler :: CompileOptions -> IO ()-runCompiler (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp) f) = do-  (backend,resolver) <- loadConfig-  base <- resolveBaseModule resolver-  ds' <- sequence $ map (preloadModule backend base) ds-  let possibleTests = Set.fromList $ concat $ map getTestsFromPreload ds'-  case Set.toList $ allowTests `Set.difference` possibleTests of-       [] -> return ()-       ts -> do-         hPutStr stderr $ "Some test files do not occur in the selected modules: " ++-                          intercalate ", " (map show ts) ++ "\n"-         exitFailure-  allResults <- fmap concat $ sequence $ map (runTests backend base) ds'-  let passed = sum $ map (fst . fst) allResults-  let failed = sum $ map (snd . fst) allResults-  processResults passed failed (mergeAllM $ map snd allResults) where-    preloadModule b base d = do-      m <- loadMetadata (p </> d)-      (fr0,deps0) <- loadPublicDeps (getCompilerHash b) [base]-      checkAllowedStale fr0 f-      (fr1,deps1) <- loadTestingDeps (getCompilerHash b) (p </> d)-      checkAllowedStale fr1 f-      (fr2,deps2) <- loadPrivateDeps (getCompilerHash b) (deps0++deps1)-      checkAllowedStale fr2 f-      return (d,m,deps0++deps1,deps2)-    getTestsFromPreload (_,m,_,_) = cmTestFiles m-    allowTests = Set.fromList tp-    isTestAllowed t = if null allowTests then True else t `Set.member` allowTests-    runTests :: CompilerBackend b => b -> String ->-                (String,CompileMetadata,[CompileMetadata],[CompileMetadata]) ->-                IO [((Int,Int),CompileInfo ())]-    runTests b base (d,m,deps1,deps2) = do-      let paths = base:(getIncludePathsForDeps deps1)-      let ss = fixPaths $ getSourceFilesForDeps deps1-      let os = getObjectFilesForDeps deps2-      ss' <- zipWithContents p ss-      ts' <- zipWithContents p (map (d </>) $ filter isTestAllowed $ cmTestFiles m)-      tm <- return $ do-        cs <- fmap concat $ collectAllOrErrorM $ map parsePublicSource ss'-        includeNewTypes defaultCategories cs-      if isCompileError tm-         then return [((0,0),tm >> return ())]-         else sequence $ map (runSingleTest b paths (m:deps1) os (getCompileSuccess tm)) ts'-    processResults passed failed rs-      | isCompileError rs = do-          hPutStr stderr $ "\nTest errors:\n" ++ (show $ getCompileError rs)-          hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)"-          hPutStrLn stderr $ "Zeolite tests failed."-          exitFailure-      | otherwise = do-          hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)"-          hPutStrLn stderr $ "Zeolite tests passed."-runCompiler (CompileOptions h is is2 _ _ _ p (CompileFast c fn f2) f) = do-  dir <- mkdtemp "/tmp/zfast_"-  absolute <- canonicalizePath p-  f2' <- canonicalizePath (p </> f2)-  let config = ModuleConfig {-      rmRoot = absolute,-      rmPath = dir,-      rmPublicDeps = is,-      rmPrivateDeps = is2,-      rmExtraFiles = [OtherSource f2'],-      rmExtraPaths = [],-      rmMode = (CompileBinary c fn (absolute </> c) [])-    }-  writeRecompile dir config-  runCompiler (CompileOptions h [] [] [dir] [] [] "" CompileRecompile f)-  removeDirectoryRecursive dir-runCompiler (CompileOptions h _ _ ds _ _ p CompileRecompileRecursive f) = do-  recursiveSequence Set.empty ds where-    recursiveSequence da (d0:ds2) = do-      d <- canonicalizePath (p </> d0)-      rm <- tryLoadRecompile d-      case rm of-           Nothing -> do-             hPutStrLn stderr $ "Path " ++ d ++ " does not have a valid configuration."-             exitFailure-           Just m -> when (not $ rmPath m `Set.member` da) $ do-             let ds3 = map (\d2 -> d </> d2) (rmPublicDeps m ++ rmPrivateDeps m)-             let da' = rmPath m `Set.insert` da-             recursiveSequence da' (ds3 ++ ds2)-             runCompiler (CompileOptions h [] [] [d] [] [] "" CompileRecompile f)-    recursiveSequence _ _ = return ()-runCompiler (CompileOptions h _ _ ds _ _ p CompileRecompile f) = do-  (backend,_) <- loadConfig-  fmap mergeAll $ sequence $ map (recompileSingle $ getCompilerHash backend) ds where-    recompileSingle h2 d0 = do-      let d = p </> d0-      rm <- tryLoadRecompile d-      upToDate <- isPathUpToDate h2 d-      maybeCompile rm upToDate where-        maybeCompile Nothing _ = do-          hPutStrLn stderr $ "Path " ++ d0 ++ " does not have a valid configuration."-          exitFailure-        maybeCompile (Just rm') upToDate-          | f < ForceAll && upToDate = hPutStrLn stderr $ "Path " ++ d0 ++ " is up to date."-          | otherwise = do-              let (ModuleConfig p2 d is is2 es ep m) = rm'-              -- In case the module is manually configured with a p such as "..",-              -- since the absolute path might not be known ahead of time.-              absolute <- canonicalizePath (p </> d0)-              let fixed = fixPath (absolute </> p2)-              let recompile = CompileOptions {-                  coHelp = h,-                  coPublicDeps = is,-                  coPrivateDeps = is2,-                  coSources = [d],-                  coExtraFiles = es,-                  coExtraPaths = ep,-                  coSourcePrefix = fixed,-                  coMode = m,-                  coForce = if f == ForceAll then ForceRecompile else AllowRecompile-                }-              runCompiler recompile-runCompiler (CompileOptions _ is is2 [d] es ep p m f) = do+data ModuleSpec =+  ModuleSpec {+    msRoot :: FilePath,+    msPath :: FilePath,+    msPublicDeps :: [FilePath],+    msPrivateDeps :: [FilePath],+    msPublicFiles :: [FilePath],+    msPrivateFiles :: [FilePath],+    msTestFiles :: [FilePath],+    msExtraFiles :: [ExtraSource],+    msExtraPaths :: [FilePath],+    msMode :: CompileMode,+    msForce :: ForceMode+  }+  deriving (Show)++data LoadedTests =+  LoadedTests {+    ltRoot :: FilePath,+    ltPath :: FilePath,+    ltMetadata :: CompileMetadata,+    ltPublicDeps :: [CompileMetadata],+    ltPrivateDeps :: [CompileMetadata]+  }+  deriving (Show)++compileModule :: ModuleSpec -> IO ()+compileModule (ModuleSpec p d is is2 ps xs ts es ep m f) = do   (backend,resolver) <- loadConfig+  let hash = getCompilerHash backend   as  <- fmap fixPaths $ sequence $ map (resolveModule resolver (p </> d)) is   as2 <- fmap fixPaths $ sequence $ map (resolveModule resolver (p </> d)) is2-  (fr,deps) <- loadPublicDeps (getCompilerHash backend) (as ++ as2)-  checkAllowedStale fr f-  if isCreateTemplates m-      then do-        base <- resolveBaseModule resolver-        (fr2,bpDeps) <- loadPublicDeps (getCompilerHash backend) [base]-        checkAllowedStale fr2 f-        processTemplates (bpDeps ++ deps)-      else do-        ((paths2,deps2),ms) <- processPath backend resolver deps as as2-        createBinary backend resolver paths2 (deps2:deps) m ms+  (fr1,deps1) <- loadPublicDeps hash as+  checkAllowedStale fr1 f+  (fr2,deps2) <- loadPublicDeps hash as2+  checkAllowedStale fr2 f+  base <- resolveBaseModule resolver+  actual <- resolveModule resolver p d+  isBase <- isBaseModule resolver actual+  -- Lazy dependency loading, in case we're compiling base.+  deps1' <- if isBase+               then return deps1+               else do+                 (fr3,bpDeps) <- loadPublicDeps hash [base]+                 checkAllowedStale fr3 f+                 return $ bpDeps ++ deps1+  ns0 <- createPublicNamespace p d+  let ex = concat $ map getSourceCategories es+  cm <- loadLanguageModule p ns0 ex ps deps1' deps2+  xa <- fmap collectAllOrErrorM $ sequence $ map (loadPrivateSource p) xs+  let fs = compileAll cm xa+  eraseCachedData (p </> d)+  when (isCompileError fs) $ do+    formatWarnings fs+    hPutStr stderr $ "Compiler errors:\n" ++ (show $ getCompileError fs)+    hPutStrLn stderr $ "Zeolite compilation failed."+    exitFailure+  formatWarnings fs+  let (pc,tc,mf,fs') = getCompileSuccess fs+  let ps2 = map takeFileName ps+  let xs2 = map takeFileName xs+  let ts2 = map takeFileName ts+  let paths = map (\ns -> getCachedPath (p </> d) ns "") $ nub $ filter (not . null) $ map show $ [ns0] ++ map coNamespace fs'+  paths' <- sequence $ map canonicalizePath paths+  s0 <- canonicalizePath $ getCachedPath (p </> d) (show ns0) ""+  let paths2 = base:(getIncludePathsForDeps (deps1' ++ deps2)) ++ ep' ++ paths'+  let hxx   = filter (isSuffixOf ".hpp" . coFilename)       fs'+  let other = filter (not . isSuffixOf ".hpp" . coFilename) fs'+  os1 <- sequence $ map (writeOutputFile backend (show ns0) paths2) $ hxx ++ other+  let files = map (\f2 -> getCachedPath (p </> d) (show $ coNamespace f2) (coFilename f2)) fs' +++              map (\f2 -> p </> getSourceFile f2) es+  files' <- sequence $ map checkOwnedFile files+  os2 <- fmap concat $ sequence $ map (compileExtraSource backend (show ns0) paths2) es+  let (hxx',cxx,os') = sortCompiledFiles files'+  let (osCat,osOther) = partitionEithers os2+  path <- canonicalizePath $ p </> d+  let os1' = resolveObjectDeps (deps1' ++ deps2) path path (os1 ++ osCat)+  let cm2 = CompileMetadata {+      cmVersionHash = hash,+      cmPath = path,+      cmNamespace = ns0,+      cmPublicDeps = as,+      cmPrivateDeps = as2,+      cmPublicCategories = sort pc,+      cmPrivateCategories = sort tc,+      cmSubdirs = [s0],+      cmPublicFiles = sort ps2,+      cmPrivateFiles = sort xs2,+      cmTestFiles = sort ts2,+      cmHxxFiles = sort hxx',+      cmCxxFiles = sort cxx,+      cmBinaries = [],+      cmLinkFlags = getLinkFlags m,+      cmObjectFiles = os1' ++ osOther ++ map OtherObjectFile os'+    }+  bs <- createBinary backend resolver paths' (cm2:(deps1' ++ deps2)) m mf+  let cm2' = CompileMetadata {+      cmVersionHash = cmVersionHash cm2,+      cmPath = cmPath cm2,+      cmNamespace = cmNamespace cm2,+      cmPublicDeps = cmPublicDeps cm2,+      cmPrivateDeps = cmPrivateDeps cm2,+      cmPublicCategories = cmPublicCategories cm2,+      cmPrivateCategories = cmPrivateCategories cm2,+      cmSubdirs = cmSubdirs cm2,+      cmPublicFiles = cmPublicFiles cm2,+      cmPrivateFiles = cmPrivateFiles cm2,+      cmTestFiles = cmTestFiles cm2,+      cmHxxFiles = cmHxxFiles cm2,+      cmCxxFiles = cmCxxFiles cm2,+      cmBinaries = bs,+      cmLinkFlags = cmLinkFlags cm2,+      cmObjectFiles = cmObjectFiles cm2+    }+  writeMetadata (p </> d) cm2'   hPutStrLn stderr $ "Zeolite compilation succeeded." where+    compileAll cm xa = do+      (cm',(pc,tc)) <- cm+      xa' <- xa+      (xx1,xx2) <- compileLanguageModule cm' xa'+      ms <- maybeCreateMain cm' xa' m+      return (pc,tc,ms,xx1++xx2)     ep' = fixPaths $ map (p </>) ep-    processPath b r deps as as2 = do-      isConfigured <- isPathConfigured d-      when (isConfigured && f == DoNotForce) $ do-        hPutStrLn stderr $ "Module " ++ d ++ " has an existing configuration. " ++-                           "Recompile with -r or use -f to overwrite the config."-        exitFailure-      eraseCachedData (p </> d)-      absolute <- canonicalizePath p-      let rm = ModuleConfig {-        rmRoot = absolute,-        rmPath = d,-        rmPublicDeps = as,-        rmPrivateDeps = as2,-        rmExtraFiles = es,-        rmExtraPaths = ep,-        rmMode = m-      }-      when (f == DoNotForce || f == ForceAll) $ writeRecompile (p </> d) rm-      (ps,xs,ts) <- findSourceFiles p d-      ps2 <- sequence $ map canonicalizePath $ filter (isSuffixOf ".0rp") $ map ((p </>) . getSourceFile) es-      xs2 <- sequence $ map canonicalizePath $ filter (isSuffixOf ".0rx") $ map ((p </>) . getSourceFile) es-      ts2 <- sequence $ map canonicalizePath $ filter (isSuffixOf ".0rt") $ map ((p </>) . getSourceFile) es-      base <- resolveBaseModule r-      actual <- resolveModule r p d-      isBase <- isBaseModule r actual-      -- Lazy dependency loading, in case we're compiling base.-      deps2 <- if isBase-                  then return deps-                  else do-                    (fr,bpDeps) <- loadPublicDeps (getCompilerHash b) [base]-                    checkAllowedStale fr f-                    return $ bpDeps ++ deps-      let ss = fixPaths $ getSourceFilesForDeps deps2-      ss' <- zipWithContents p ss-      let paths = base:(getIncludePathsForDeps deps2)-      ps' <- zipWithContents p (ps ++ ps2)-      xs' <- zipWithContents p (xs ++ xs2)-      ns0 <- canonicalizePath (p </> d) >>= return . StaticNamespace . publicNamespace-      let ns2 = map StaticNamespace $ filter (not . null) $ getNamespacesForDeps deps-      let fs = compileAll ns0 ns2 ss' ps' xs'-      writeOutput b paths ns0 deps2 as as2-                  (map takeFileName ps ++ ps2)-                  (map takeFileName xs ++ xs2)-                  (map takeFileName ts ++ ts2) fs-    writeOutput b paths ns0 deps as as2 ps xs ts fs-      | isCompileError fs = do-          formatWarnings fs-          hPutStr stderr $ "Compiler errors:\n" ++ (show $ getCompileError fs)-          hPutStrLn stderr $ "Zeolite compilation failed."-          exitFailure-      | otherwise = do-          formatWarnings fs-          let (pc,mf,fs') = getCompileSuccess fs-          let ss = map (\ns -> getCachedPath (p </> d) ns "") $ nub $ filter (not . null) $ map show $ [ns0] ++ map coNamespace fs'-          ss' <- sequence $ map canonicalizePath ss-          s0 <- canonicalizePath $ getCachedPath (p </> d) (show ns0) ""-          let paths' = paths ++ ep' ++ ss'-          let hxx   = filter (isSuffixOf ".hpp" . coFilename)       fs'-          let other = filter (not . isSuffixOf ".hpp" . coFilename) fs'-          os1 <- sequence $ map (writeOutputFile b (show ns0) paths') $ hxx ++ other-          let files = map (\f2 -> getCachedPath (p </> d) (show $ coNamespace f2) (coFilename f2)) fs' ++-                      map (\f2 -> p </> getSourceFile f2) es-          files' <- sequence $ map checkOwnedFile files-          os2 <- fmap concat $ sequence $ map (compileExtraSource b (show ns0) paths') es-          let (hxx',cxx,os') = sortCompiledFiles files'-          let (osCat,osOther) = partitionEithers os2-          path <- canonicalizePath $ p </> d-          let os1' = resolveObjectDeps path (os1 ++ osCat) deps-          let cm = CompileMetadata {-              cmVersionHash = getCompilerHash b,-              cmPath = path,-              cmNamespace = show ns0,-              cmPublicDeps = as,-              cmPrivateDeps = as2,-              cmCategories = sort $ map show pc,-              cmSubdirs = [s0],-              cmPublicFiles = sort ps,-              cmPrivateFiles = sort xs,-              cmTestFiles = sort ts,-              cmHxxFiles = sort hxx',-              cmCxxFiles = sort cxx,-              cmLinkFlags = getLinkFlags m,-              cmObjectFiles = os1' ++ osOther ++ map OtherObjectFile os'-            }-          when (not $ isCreateTemplates m) $ writeMetadata (p </> d) cm-          return ((ss',cm),mf)-    formatWarnings c-      | null $ getCompileWarnings c = return ()-      | otherwise = hPutStr stderr $ "Compiler warnings:\n" ++ (concat $ map (++ "\n") (getCompileWarnings c))     writeOutputFile b ns0 paths ca@(CxxOutput _ f2 ns _ _ content) = do       hPutStrLn stderr $ "Writing file " ++ f2       writeCachedFile (p </> d) (show ns) f2 $ concat $ map (++ "\n") content@@ -295,18 +203,18 @@            Just o  -> return [Right $ OtherObjectFile o]            Nothing -> return []     fakeCxxForSource ns ds2 c = CxxOutput {-        coCategory = Just (CategoryName c),+        coCategory = Just c,         coFilename = "",         coNamespace = ns',         coUsesNamespace = [ns'],-        coUsesCategory = map CategoryName ds2,+        coUsesCategory = ds2,         coOutput = []       } where         ns' = if null ns then NoNamespace else StaticNamespace ns     checkOwnedFile f2 = do       exists <- doesFileExist f2       when (not exists) $ do-        hPutStrLn stderr $ "Owned file \"" ++ f2 ++ "\" does not exist."+        hPutStrLn stderr $ "Owned file " ++ f2 ++ " does not exist."         hPutStrLn stderr $ "Zeolite compilation failed."         exitFailure       canonicalizePath f2@@ -318,76 +226,16 @@           fmap Just $ runCxxCommand b command       | isSuffixOf ".a" f2 || isSuffixOf ".o" f2 = return (Just f2)       | otherwise = return Nothing-    processTemplates deps = do-      (ps,xs,_) <- findSourceFiles p d-      ps' <- zipWithContents p ps-      xs' <- zipWithContents p xs-      let ss = fixPaths $ getSourceFilesForDeps deps-      ss' <- zipWithContents p ss-      let ts = createTemplates ss' ps' xs' :: CompileInfo [CxxOutput]-      if isCompileError ts-         then do-           formatWarnings ts-           hPutStr stderr $ "Compiler errors:\n" ++ (show $ getCompileError ts)-           hPutStrLn stderr $ "Zeolite compilation failed."-           exitFailure-         else do-           formatWarnings ts-           sequence_ $ map writeTemplate $ getCompileSuccess ts-    createTemplates is3 cs ds2 = do-      tm1 <- addIncludes defaultCategories is3-      cs' <- fmap concat $ collectAllOrErrorM $ map parsePublicSource cs-      let cs'' = map (setCategoryNamespace DynamicNamespace) cs'-      tm2 <- includeNewTypes tm1 cs''-      da <- collectAllOrErrorM $ map parseInternalSource ds2-      let ds2' = concat $ map snd da-      let cs2 = concat $ map fst da-      tm3 <- includeNewTypes tm2 cs2-      let ca = Set.fromList $ map getCategoryName $ filter isValueConcrete cs'-      let ca' = foldr Set.delete ca $ map dcName ds2'-      collectAllOrErrorM $ map (compileConcreteTemplate tm3) $ Set.toList ca'-    writeTemplate (CxxOutput _ n _ _ _ content) = do-      let n' = p </> d </> n-      exists <- doesFileExist n'-      if exists && f /= ForceAll-         then hPutStrLn stderr $ "Skipping existing file " ++ n-         else do-           hPutStrLn stderr $ "Writing file " ++ n-           writeFile n' $ concat $ map (++ "\n") content-    compileAll ns0 ns2 is3 cs ds2 = do-      tm1 <- addIncludes defaultCategories is3-      cs' <- fmap concat $ collectAllOrErrorM $ map parsePublicSource cs-      let cs'' = map (setCategoryNamespace ns0) cs'-      xa <- collectAllOrErrorM $ map parsePrivate ds2-      let cm = CategoryModule {-          cnBase = tm1,-          cnNamespaces = ns0:ns2,-          cnPublic = cs'',-          cnPrivate = xa,-          cnExternal = concat $ map getSourceCategories es-        }-      xx <- compileCategoryModule cm-      let pc = map getCategoryName cs''-      ms <- maybeCreateMain cm m-      return (pc,ms,xx)-    parsePrivate ds = do-      let ns1 = StaticNamespace $ privateNamespace (p </> fst ds)-      (cs,ds') <- parseInternalSource ds-      let cs' = map (setCategoryNamespace ns1) cs-      return $ PrivateSource ns1 cs' ds'-    addIncludes tm fs = do-      cs <- fmap concat $ collectAllOrErrorM $ map parsePublicSource fs-      includeNewTypes tm cs     createBinary b r paths deps (CompileBinary n _ o lf) ms       | length ms > 1 = do-        hPutStrLn stderr $ "Multiple matches for main category " ++ n ++ "."+        hPutStrLn stderr $ "Multiple matches for main category " ++ show n ++ "."         exitFailure       | length ms == 0 = do-        hPutStrLn stderr $ "Main category " ++ n ++ " not found."+        hPutStrLn stderr $ "Main category " ++ show n ++ " not found."         exitFailure       | otherwise = do           f0 <- if null o-                   then canonicalizePath $ p </> d </> n+                   then canonicalizePath $ p </> d </> show n                    else canonicalizePath $ p </> d </> o           let (CxxOutput _ _ _ ns2 req content) = head ms           -- TODO: Create a helper or a constant or something.@@ -395,34 +243,141 @@           hPutStr h $ concat $ map (++ "\n") content           hClose h           base <- resolveBaseModule r-          (_,bpDeps) <- loadPublicDeps (getCompilerHash b) [base]-          (_,deps2) <- loadPrivateDeps (getCompilerHash b) (bpDeps ++ deps)+          (fr,deps2)  <- loadPrivateDeps (getCompilerHash b) deps+          checkAllowedStale fr f           let lf' = lf ++ getLinkFlagsForDeps deps2-          let paths' = fixPaths $ paths ++ base:(getIncludePathsForDeps deps2)-          let os    = getObjectFilesForDeps deps2+          let paths' = fixPaths $ paths ++ base:(getIncludePathsForDeps deps)+          let os     = getObjectFilesForDeps deps2           let ofr = getObjectFileResolver os           let os' = ofr ns2 req           let command = CompileToBinary o' os' f0 paths' lf'           hPutStrLn stderr $ "Creating binary " ++ f0           _ <- runCxxCommand b command           removeFile o'-    createBinary _ _ _ _ _ _ = return ()-    maybeCreateMain cm (CompileBinary n f2 _ _) =-      fmap (:[]) $ compileModuleMain cm (CategoryName n) (FunctionName f2)-    maybeCreateMain _ _ = return []-runCompiler co = do-  hPutStrLn stderr $ "Unsupported compiler options: " ++ show co-  exitFailure+          return [f0]+    createBinary _ _ _ _ _ _ = return []+    maybeCreateMain cm2 xs2 (CompileBinary n f2 _ _) =+      fmap (:[]) $ compileModuleMain cm2 xs2 n f2+    maybeCreateMain _ _ _ = return [] -checkAllowedStale :: Bool -> ForceMode -> IO ()-checkAllowedStale fr f = do-  when (not fr && f < ForceRecompile) $ do-    hPutStrLn stderr $ "Some dependencies are out of date. " ++-                       "Recompile them or use -f to force."-    exitFailure+createModuleTemplates :: FilePath -> FilePath -> [CompileMetadata] -> [CompileMetadata] -> IO ()+createModuleTemplates p d deps1 deps2 = do+  ns0 <- createPublicNamespace p d+  (ps,xs,_) <- findSourceFiles p d+  cm <- fmap (fmap fst) $ loadLanguageModule p ns0 [] ps deps1 deps2+  xs' <- zipWithContents p xs+  let ts = createTemplates cm xs'+  if isCompileError ts+      then do+        formatWarnings ts+        hPutStr stderr $ "Compiler errors:\n" ++ (show $ getCompileError ts)+        hPutStrLn stderr $ "Zeolite compilation failed."+        exitFailure+      else do+        formatWarnings ts+        sequence_ $ map writeTemplate $ getCompileSuccess ts where+  createTemplates cm xs = do+    (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _) <- cm+    ds <- collectAllOrErrorM $ map parseInternalSource xs+    let ds2 = concat $ map (\(_,_,d2) -> d2) ds+    tm <- foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1]+    let cs = filter isValueConcrete $ cs1++ps1++ts1+    let ca = Set.fromList $ map getCategoryName $ filter isValueConcrete cs+    let ca' = foldr Set.delete ca $ map dcName ds2+    collectAllOrErrorM $ map (compileConcreteTemplate tm) $ Set.toList ca'+  writeTemplate (CxxOutput _ n _ _ _ content) = do+    let n' = p </> d </> n+    exists <- doesFileExist n'+    if exists+        then hPutStrLn stderr $ "Skipping existing file " ++ n+        else do+          hPutStrLn stderr $ "Writing file " ++ n+          writeFile n' $ concat $ map (++ "\n") content -fixPaths :: [String] -> [String]-fixPaths = nub . map fixPath+runModuleTests :: CompilerBackend b => b -> FilePath -> [FilePath] -> LoadedTests -> IO [((Int,Int),CompileInfo ())]+runModuleTests b base tp (LoadedTests p d m deps1 deps2) = do+  let paths = base:(getIncludePathsForDeps deps1)+  mapM_ showSkipped $ filter (not . isTestAllowed) $ cmTestFiles m+  ts' <- zipWithContents p $ map (d </>) $ filter isTestAllowed $ cmTestFiles m+  path <- canonicalizePath (p </> d)+  cm <- fmap (fmap fst) $ loadLanguageModule path NoNamespace [] [] deps1 []+  if isCompileError cm+      then return [((0,0),cm >> return ())]+      else sequence $ map (runSingleTest b (getCompileSuccess cm) path paths (m:deps2)) ts' where+    allowTests = Set.fromList tp+    isTestAllowed t = if null allowTests then True else t `Set.member` allowTests+    showSkipped f = do+      hPutStrLn stderr $ "Skipping tests in " ++ f ++ " due to explicit test filter." -zipWithContents :: String -> [String] -> IO [(String,String)]+createPublicNamespace :: FilePath -> FilePath -> IO Namespace+createPublicNamespace p d = canonicalizePath (p </> d) >>= return . StaticNamespace . publicNamespace++createPrivateNamespace :: FilePath -> FilePath -> IO Namespace+createPrivateNamespace p f = canonicalizePath (p </> f) >>= return . StaticNamespace . publicNamespace++formatWarnings :: CompileInfo a -> IO ()+formatWarnings c+  | null $ getCompileWarnings c = return ()+  | otherwise = hPutStr stderr $ "Compiler warnings:\n" ++ (concat $ map (++ "\n") (getCompileWarnings c))++zipWithContents :: FilePath -> [FilePath] -> IO [(FilePath,String)] zipWithContents p fs = fmap (zip $ map fixPath fs) $ sequence $ map (readFile . (p </>)) fs++loadPrivateSource :: CompileErrorM m => FilePath -> FilePath -> IO (m (PrivateSource SourcePos))+loadPrivateSource p f = do+  [f'] <- zipWithContents p [f]+  ns <- createPrivateNamespace p f+  return $ do+    (pragmas,cs,ds) <- parseInternalSource f'+    let cs' = map (setCategoryNamespace ns) cs+    let testing = any isTestsOnly pragmas+    return $ PrivateSource ns testing cs' ds++loadLanguageModule :: CompileErrorM m => FilePath -> Namespace -> [CategoryName] ->+  [FilePath] -> [CompileMetadata] -> [CompileMetadata] ->+  IO (m (LanguageModule SourcePos,([CategoryName],[CategoryName])))+loadLanguageModule p ns2 ex fs deps1 deps2 = do+  m0 <- fmap merge $ sequence $ map processAll deps1+  m1 <- fmap merge $ sequence $ map processAll deps2+  m2 <- loadAllPublic "" fs+  return $ construct m0 m1 m2 where+    ns0 = filter (not . isNoNamespace) $ getNamespacesForDeps deps1+    ns1 = filter (not . isNoNamespace) $ getNamespacesForDeps deps2+    construct m0 m1 m2 = do+      (ps0,_,tsA0,_)      <- m0+      (ps1,_,tsA1,_)      <- m1+      (ps2,xs2,tsA2,tsB2) <- m2+      let cm = LanguageModule {+          lmPublicNamespaces = ns0,+          lmPrivateNamespaces = ns1,+          lmLocalNamespaces = [ns2],+          lmPublicDeps = ps0,+          lmPrivateDeps = ps1,+          lmTestingDeps = tsA0++tsA1,+          lmPublicLocal = map (setCategoryNamespace ns2) ps2,+          lmPrivateLocal = map (setCategoryNamespace ns2) xs2,+          lmTestingLocal = map (setCategoryNamespace ns2) $ tsA2 ++ tsB2,+          lmExternal = ex+        }+      return (cm,(map getCategoryName $ ps2++tsA2,map getCategoryName $ xs2++tsB2))+    loadPublic p2 p3 = parsePublicSource p3 >>= return . uncurry (partition p2)+    partition p2 pragmas cs+      -- Allow ModuleOnly when the path is the same. Only needed for tests.+      | p2 == p && (any isTestsOnly pragmas) = ([],[],cs,[])+      | p2 == p                              = (cs,[],[],[])+      | (any isModuleOnly pragmas) && (any isTestsOnly pragmas) = ([],[],[],cs)+      | (any isTestsOnly pragmas)                               = ([],[],cs,[])+      | (any isModuleOnly pragmas)                              = ([],cs,[],[])+      | otherwise                                               = (cs,[],[],[])+    processAll dep = do+      let dep' = getSourceFilesForDeps [dep]+      loadAllPublic (cmPath dep) dep'+    merge as = do+      as' <- collectAllOrErrorM as+      return $ foldl merge4 ([],[],[],[]) as'+    loadAllPublic p2 fs2 = do+      fs2' <- zipWithContents p fs2+      return $ do+        as <- collectAllOrErrorM $ map (loadPublic p2) fs2'+        return $ foldl merge4 ([],[],[],[]) as+    merge4 (ps1,xs1,tsA1,tsB1) (ps2,xs2,tsA2,tsB2) = (ps1++ps2,xs1++xs2,tsA1++tsA2,tsB1++tsB2)

@@ -35,6 +35,8 @@ import Cli.CompileOptions import Cli.ProcessMetadata import Config.LoadConfig (compilerVersion,rootPath)+import Types.TypeCategory (FunctionName(..))+import Types.TypeInstance (CategoryName(..))   optionHelpText :: [String]@@ -105,7 +107,9 @@       hPutStrLn stdout $ show p'       mapM_ showDep (cmObjectFiles m)     showDep (CategoryObjectFile c ds _) = do-      mapM_ (\d -> hPutStrLn stdout $ "  " ++ ciCategory c ++ " -> " ++ ciCategory d ++ " " ++ show (ciPath d)) ds+      mapM_ (\d -> hPutStrLn stdout $ "  " ++ show (ciCategory c) +++                                      " -> " ++ show (ciCategory d) +++                                      " " ++ show (ciPath d)) ds     showDep _ = return () tryFastModes _ = return () @@ -162,7 +166,8 @@         (t,fn) <- check $ break (== '.') c         checkCategoryName n2 t  "-m"         checkFunctionName n2 fn "-m"-        return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (CompileBinary t fn "" []) f) where+        let m2 = CompileBinary (CategoryName t) (FunctionName fn) "" []+        return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p m2 f) where           check (t,"")     = return (t,defaultMainFunc)           check (t,'.':fn) = return (t,fn)           check _          = argError n2 c $ "Invalid entry point."@@ -176,7 +181,8 @@         checkCategoryName n2 t  "--fast"         checkFunctionName n2 fn "--fast"         when (not $ isSuffixOf ".0rx" f2) $ argError n3 f2 $ "Must specify a .0rx source file."-        return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (CompileFast t fn f2) f) where+        let m2 = CompileFast (CategoryName t) (FunctionName fn) f2+        return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p m2 f) where           check (t,"")     = return (t,defaultMainFunc)           check (t,'.':fn) = return (t,fn)           check _          = argError n2 c $ "Invalid entry point."

@@ -29,12 +29,13 @@ import Base.CompileError import Cli.CompileMetadata import Cli.CompileOptions+import Config.Programs (VersionHash(..)) import Parser.Common import Parser.TypeCategory () import Parser.TypeInstance () import Text.Regex.TDFA -- Not safe!-import Types.TypeCategory (FunctionName)-import Types.TypeInstance (CategoryName)+import Types.TypeCategory (FunctionName(..),Namespace(..))+import Types.TypeInstance (CategoryName(..))   class ConfigFormat a where@@ -66,40 +67,42 @@ prependFirst s0 (s:ss) = (s0 ++ s):ss prependFirst s0 _      = [s0] -validateCategoryName :: CompileErrorM m => String -> m ()+validateCategoryName :: CompileErrorM m => CategoryName -> m () validateCategoryName c =-    when (not $ c =~ "^[A-Z][A-Za-z0-9]*$") $-      compileError $ "Invalid category name: \"" ++ c ++ "\""+    when (not $ show c =~ "^[A-Z][A-Za-z0-9]*$") $+      compileError $ "Invalid category name: \"" ++ show c ++ "\"" -parseCategoryName :: Parser String-parseCategoryName = fmap show (sourceParser :: Parser CategoryName)+parseCategoryName :: Parser CategoryName+parseCategoryName = sourceParser :: Parser CategoryName -validateFunctionName :: CompileErrorM m => String -> m ()+validateFunctionName :: CompileErrorM m => FunctionName -> m () validateFunctionName f =-    when (not $ f =~ "^[a-z][A-Za-z0-9]*$") $-      compileError $ "Invalid function name: \"" ++ f ++ "\""+    when (not $ show f =~ "^[a-z][A-Za-z0-9]*$") $+      compileError $ "Invalid function name: \"" ++ show f ++ "\"" -parseFunctionName :: Parser String-parseFunctionName = fmap show (sourceParser :: Parser FunctionName)+parseFunctionName :: Parser FunctionName+parseFunctionName = sourceParser :: Parser FunctionName -validateHash :: CompileErrorM m => String -> m ()+validateHash :: CompileErrorM m => VersionHash -> m () validateHash h =-    when (not $ h =~ "^[A-Za-z0-9]+$") $-      compileError $ "Version hash must be a hex string: \"" ++ h ++ "\""+    when (not $ show h =~ "^[A-Za-z0-9]+$") $+      compileError $ "Version hash must be a hex string: \"" ++ show h ++ "\"" -parseHash :: Parser String-parseHash = labeled "version hash" $ sepAfter (many1 hexDigit)+parseHash :: Parser VersionHash+parseHash = labeled "version hash" $ sepAfter (fmap VersionHash $ many1 hexDigit) -validateNamespace :: CompileErrorM m => String -> m ()-validateNamespace ns =-    when (not $ ns =~ "^[A-Za-z][A-Za-z0-9_]*$") $-      compileError $ "Invalid category namespace: \"" ++ ns ++ "\""+maybeShowNamespace :: CompileErrorM m => String -> Namespace -> m [String]+maybeShowNamespace l (StaticNamespace ns) = do+  when (not $ ns =~ "^[A-Za-z][A-Za-z0-9_]*$") $+    compileError $ "Invalid category namespace: \"" ++ ns ++ "\""+  return [l ++ " " ++ ns]+maybeShowNamespace _ _ = return [] -parseNamespace :: Parser String+parseNamespace :: Parser Namespace parseNamespace = labeled "namespace" $ do-    b <- lower-    e <- sepAfter $ many (alphaNum <|> char '_')-    return (b:e)+  b <- lower+  e <- sepAfter $ many (alphaNum <|> char '_')+  return $ StaticNamespace (b:e)  parseQuoted :: Parser String parseQuoted = labeled "quoted string" $ do@@ -125,39 +128,45 @@  instance ConfigFormat CompileMetadata where   readConfig = do-    h <-   parseRequired "version_hash:"  parseHash-    p <-   parseRequired "path:"          parseQuoted-    ns <-  parseRequired "namespace:"     parseNamespace-    is <-  parseRequired "public_deps:"   (parseList parseQuoted)-    is2 <- parseRequired "private_deps:"  (parseList parseQuoted)-    cs <-  parseRequired "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)-    lf  <- parseRequired "link_flags:"    (parseList parseQuoted)-    os <-  parseRequired "object_files:"  (parseList readConfig)-    return (CompileMetadata h p ns is is2 cs ds ps xs ts hxx cxx lf os)+    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)-    validateNamespace (cmNamespace m)-    _ <- collectAllOrErrorM $ map validateCategoryName (cmCategories m)+    namespace <- maybeShowNamespace "namespace:" (cmNamespace m)+    _ <- collectAllOrErrorM $ map validateCategoryName (cmPublicCategories m)+    _ <- collectAllOrErrorM $ map validateCategoryName (cmPrivateCategories m)     objects <- fmap concat $ collectAllOrErrorM $ map writeConfig $ cmObjectFiles m     return $ [-        "version_hash: " ++ (cmVersionHash m),-        "path: " ++ (show $ cmPath m),-        "namespace: " ++ (cmNamespace m),+        "version_hash: " ++ (show $ cmVersionHash m),+        "path: " ++ (show $ cmPath m)+      ] ++ namespace ++ [         "public_deps: ["       ] ++ indents (map show $ cmPublicDeps m) ++ [         "]",         "private_deps: ["       ] ++ indents (map show $ cmPrivateDeps m) ++ [         "]",-        "categories: ["-      ] ++ indents (cmCategories m) ++ [+        "public_categories: ["+      ] ++ indents (map show $ cmPublicCategories m) ++ [         "]",+        "private_categories: ["+      ] ++ indents (map show $ cmPrivateCategories m) ++ [+        "]",         "subdirs: ["       ] ++ indents (map show $ cmSubdirs m) ++ [         "]",@@ -176,6 +185,9 @@         "cxx_files: ["       ] ++ indents (map show $ cmCxxFiles m) ++ [         "]",+        "binaries: ["+      ] ++ indents (map show $ cmBinaries m) ++ [+        "]",         "link_flags: ["       ] ++ indents (map show $ cmLinkFlags m) ++ [         "]",@@ -227,7 +239,7 @@       sepAfter (string_ "category")       structOpen       c <-  parseRequired "name:"      parseCategoryName-      ns <- parseRequired "namespace:" parseNamespace+      ns <- parseOptional "namespace:" NoNamespace parseNamespace       p <-  parseRequired "path:"      parseQuoted       structClose       return (CategoryIdentifier p c ns)@@ -239,17 +251,17 @@       return (UnresolvedCategory c)   writeConfig (CategoryIdentifier p c ns) = do     validateCategoryName c-    validateNamespace ns+    namespace <- maybeShowNamespace "namespace:" ns     return $ [         "category {",-        indent $ "name: " ++ c,-        indent $ "namespace: " ++ ns,+        indent $ "name: " ++ show c+      ] ++ indents namespace ++ [         indent $ "path: " ++ show p,         "}"       ]   writeConfig (UnresolvedCategory c) = do     validateCategoryName c-    return $ ["unresolved { " ++ "name: " ++ c ++ " " ++ "}"]+    return $ ["unresolved { " ++ "name: " ++ show c ++ " " ++ "}"]  instance ConfigFormat ModuleConfig where   readConfig = do@@ -301,10 +313,10 @@         "category_source {",         indent ("source: " ++ show f),         indent "categories: ["-      ] ++ (indents . indents) cs ++ [+      ] ++ (indents . indents . map show) cs ++ [         indent "]",         indent "requires: ["-      ] ++ (indents . indents) ds ++ [+      ] ++ (indents . indents . map show) ds ++ [         indent "]",         "}"       ]@@ -332,8 +344,8 @@     validateFunctionName f     return $ [         "binary {",-        indent ("category: " ++ c),-        indent ("function: " ++ f),+        indent ("category: " ++ show c),+        indent ("function: " ++ show f),         indent ("output: " ++ show o),         indent ("link_flags: [")       ] ++ (indents . indents) (map show lf) ++ [

@@ -17,11 +17,12 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  module Cli.ProcessMetadata (-  allowedExtraTypes,+  checkAllowedStale,   createCachePath,   eraseCachedData,   findSourceFiles,   fixPath,+  fixPaths,   getCachedPath,   getCacheRelativePath,   getIncludePathsForDeps,@@ -48,7 +49,7 @@  import Control.Applicative ((<|>)) import Control.Monad (when)-import Data.List (isSuffixOf)+import Data.List (nub,isSuffixOf) import Data.Maybe (isJust) import System.Directory import System.Exit (exitFailure)@@ -59,26 +60,32 @@  import Base.CompileError import Cli.CompileMetadata+import Cli.CompileOptions import Cli.ParseMetadata -- Not safe, due to Text.Regex.TDFA. import Compilation.CompileInfo import CompilerCxx.Category (CxxOutput(..))+import Config.Programs (VersionHash(..)) import Types.TypeCategory import Types.TypeInstance  -cachedDataPath :: String+cachedDataPath :: FilePath cachedDataPath = ".zeolite-cache" -recompileFilename :: String-recompileFilename = ".zeolite-module"+moduleFilename :: FilePath+moduleFilename = ".zeolite-module" -metadataFilename :: String+metadataFilename :: FilePath metadataFilename = "compile-metadata" -allowedExtraTypes :: [String]-allowedExtraTypes = [".hpp",".cpp",".h",".cc",".a",".o"]+checkAllowedStale :: Bool -> ForceMode -> IO ()+checkAllowedStale fr f = do+  when (not fr && f < ForceAll) $ do+    hPutStrLn stderr $ "Some dependencies are out of date. " +++                       "Recompile them or use -f to force."+    exitFailure -loadMetadata :: String -> IO CompileMetadata+loadMetadata :: FilePath -> IO CompileMetadata loadMetadata p = do   let f = p </> cachedDataPath </> metadataFilename   isFile <- doesFileExist p@@ -102,13 +109,13 @@        exitFailure      else return (getCompileSuccess m) -tryLoadMetadata :: String -> IO (Maybe CompileMetadata)+tryLoadMetadata :: FilePath -> IO (Maybe CompileMetadata) tryLoadMetadata p = tryLoadData $ (p </> cachedDataPath </> metadataFilename) -tryLoadRecompile :: String -> IO (Maybe ModuleConfig)-tryLoadRecompile p = tryLoadData $ (p </> recompileFilename)+tryLoadRecompile :: FilePath -> IO (Maybe ModuleConfig)+tryLoadRecompile p = tryLoadData $ (p </> moduleFilename) -tryLoadData :: ConfigFormat a => String -> IO (Maybe a)+tryLoadData :: ConfigFormat a => FilePath -> IO (Maybe a) tryLoadData f = do   filePresent <- doesFileExist f   if not filePresent@@ -123,7 +130,7 @@            return Nothing          else return $ Just (getCompileSuccess m) -isPathUpToDate :: String -> String -> IO Bool+isPathUpToDate :: VersionHash -> FilePath -> IO Bool isPathUpToDate h p = do   m <- tryLoadMetadata p   case m of@@ -132,13 +139,13 @@          (fr,_) <- loadDepsCommon True h Set.empty (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p]          return fr -isPathConfigured :: String -> IO Bool+isPathConfigured :: FilePath -> IO Bool isPathConfigured p = do   -- Just for error messages.   _ <- tryLoadRecompile p-  doesFileExist (p </> recompileFilename)+  doesFileExist (p </> moduleFilename) -writeMetadata :: String -> CompileMetadata -> IO ()+writeMetadata :: FilePath -> CompileMetadata -> IO () writeMetadata p m = do   p' <- canonicalizePath p   hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"."@@ -150,10 +157,10 @@        exitFailure      else writeCachedFile p' "" metadataFilename (getCompileSuccess m') -writeRecompile :: String -> ModuleConfig -> IO ()+writeRecompile :: FilePath -> ModuleConfig -> IO () writeRecompile p m = do   p' <- canonicalizePath p-  let f = p </> recompileFilename+  let f = p </> moduleFilename   hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"."   let m' = autoWriteConfig m   if isCompileError m'@@ -166,31 +173,31 @@        when exists $ removeFile f        writeFile f (getCompileSuccess m') -eraseCachedData :: String -> IO ()+eraseCachedData :: FilePath -> IO () eraseCachedData p = do   let d  = p </> cachedDataPath   dirExists <- doesDirectoryExist d   when dirExists $ removeDirectoryRecursive d -createCachePath :: String -> IO ()+createCachePath :: FilePath -> IO () createCachePath p = do   let f = p </> cachedDataPath   exists <- doesDirectoryExist f   when (not exists) $ createDirectoryIfMissing False f -writeCachedFile :: String -> String -> String -> String -> IO ()+writeCachedFile :: FilePath -> String -> FilePath -> String -> IO () writeCachedFile p ns f c = do   createCachePath p   createDirectoryIfMissing False $ p </> cachedDataPath </> ns   writeFile (getCachedPath p ns f) c -getCachedPath :: String -> String -> String -> String+getCachedPath :: FilePath -> String -> FilePath -> FilePath getCachedPath p ns f = fixPath $ p </> cachedDataPath </> ns </> f -getCacheRelativePath :: String -> String+getCacheRelativePath :: FilePath -> FilePath getCacheRelativePath f = ".." </> f -findSourceFiles :: String -> String -> IO ([String],[String],[String])+findSourceFiles :: FilePath -> FilePath -> IO ([FilePath],[FilePath],[FilePath]) findSourceFiles p0 p = do   let absolute = p0 </> p   isFile <- doesFileExist absolute@@ -207,17 +214,17 @@   let ts = filter (isSuffixOf ".0rt") ds   return (ps,xs,ts) -getRealPathsForDeps :: [CompileMetadata] -> [String]+getRealPathsForDeps :: [CompileMetadata] -> [FilePath] getRealPathsForDeps = map cmPath -getSourceFilesForDeps :: [CompileMetadata] -> [String]+getSourceFilesForDeps :: [CompileMetadata] -> [FilePath] getSourceFilesForDeps = concat . map extract where   extract m = map (cmPath m </>) (cmPublicFiles m) -getNamespacesForDeps :: [CompileMetadata] -> [String]-getNamespacesForDeps = filter (not . null) . map cmNamespace+getNamespacesForDeps :: [CompileMetadata] -> [Namespace]+getNamespacesForDeps = filter (not . isNoNamespace) . map cmNamespace -getIncludePathsForDeps :: [CompileMetadata] -> [String]+getIncludePathsForDeps :: [CompileMetadata] -> [FilePath] getIncludePathsForDeps = concat . map cmSubdirs  getLinkFlagsForDeps :: [CompileMetadata] -> [String]@@ -226,23 +233,21 @@ getObjectFilesForDeps :: [CompileMetadata] -> [ObjectFile] getObjectFilesForDeps = concat . map cmObjectFiles -loadPublicDeps :: String -> [String] -> IO (Bool,[CompileMetadata])+loadPublicDeps :: VersionHash -> [FilePath] -> IO (Bool,[CompileMetadata]) loadPublicDeps h = loadDepsCommon False h Set.empty cmPublicDeps -loadTestingDeps :: String -> String -> IO (Bool,[CompileMetadata])-loadTestingDeps h p = do-  m <- loadMetadata p-  loadDepsCommon False h Set.empty cmPublicDeps (p:cmPrivateDeps m)+loadTestingDeps :: VersionHash -> CompileMetadata -> IO (Bool,[CompileMetadata])+loadTestingDeps h m = loadDepsCommon False h (Set.fromList [cmPath m]) cmPublicDeps (cmPublicDeps m ++ cmPrivateDeps m) -loadPrivateDeps :: String -> [CompileMetadata] -> IO (Bool,[CompileMetadata])+loadPrivateDeps :: VersionHash -> [CompileMetadata] -> IO (Bool,[CompileMetadata]) loadPrivateDeps h ms = do   (fr,new) <- loadDepsCommon False h pa (\m -> cmPublicDeps m ++ cmPrivateDeps m) paths   return (fr,ms ++ new) where     paths = concat $ map (\m -> cmPublicDeps m ++ cmPrivateDeps m) ms     pa = Set.fromList $ map cmPath ms -loadDepsCommon :: Bool -> String -> Set.Set String->-  (CompileMetadata -> [String]) -> [String] -> IO (Bool,[CompileMetadata])+loadDepsCommon :: Bool -> VersionHash -> Set.Set FilePath ->+  (CompileMetadata -> [FilePath]) -> [FilePath] -> IO (Bool,[CompileMetadata]) loadDepsCommon s h pa0 f ps = fmap snd $ fixedPaths >>= collect (pa0,(True,[])) where   fixedPaths = sequence $ map canonicalizePath ps   collect xa@(pa,(fr,xs)) (p:ps2)@@ -259,7 +264,7 @@         collect (p `Set.insert` pa,(sameVersion && fresh && fr,xs ++ [m])) (ps2 ++ f m)   collect xa _ = return xa -fixPath :: String -> String+fixPath :: FilePath -> FilePath fixPath = foldl (</>) "" . process [] . map dropSlash . splitPath where   dropSlash "/" = "/"   dropSlash d@@ -272,7 +277,10 @@   process rs        (d:ds)    = process (d:rs) ds   process rs        _         = reverse rs -sortCompiledFiles :: [String] -> ([String],[String],[String])+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)@@ -283,23 +291,24 @@     | isSuffixOf ".o"   f = (hxx,cxx,os++[f])     | otherwise = fs -checkModuleVersionHash :: String -> CompileMetadata -> Bool+checkModuleVersionHash :: VersionHash -> CompileMetadata -> Bool checkModuleVersionHash h m = cmVersionHash m == h -checkModuleFreshness :: Bool -> String -> CompileMetadata -> IO Bool-checkModuleFreshness s p (CompileMetadata _ p2 _ is is2 _ _ ps xs ts hxx cxx _ _) = do+checkModuleFreshness :: Bool -> FilePath -> CompileMetadata -> IO Bool+checkModuleFreshness s p (CompileMetadata _ p2 _ is is2 _ _ _ ps xs ts hxx cxx bs _ _) = do   time <- getModificationTime $ getCachedPath p "" metadataFilename   (ps2,xs2,ts2) <- findSourceFiles p ""   let e1 = checkMissing ps ps2   let e2 = checkMissing xs xs2   let e3 = checkMissing ts ts2-  rm <- check time (p </> recompileFilename)-  f1 <- sequence $ map (\p3 -> check time $ getCachedPath p3 "" metadataFilename) $ is ++ is2-  f2 <- sequence $ map (check time . (p2 </>)) $ ps ++ xs-  f3 <- sequence $ map (check time . getCachedPath p2 "") $ hxx ++ cxx-  let fresh = not $ any id $ [rm,e1,e2,e3] ++ f1 ++ f2 ++ f3+  rm <- checkInput time (p </> moduleFilename)+  f1 <- sequence $ map (\p3 -> checkInput time $ getCachedPath p3 "" metadataFilename) $ is ++ is2+  f2 <- sequence $ map (checkInput time . (p2 </>)) $ ps ++ xs+  f3 <- sequence $ map (checkInput time . getCachedPath p2 "") $ hxx ++ cxx+  f4 <- sequence $ map checkOutput bs+  let fresh = not $ any id $ [rm,e1,e2,e3] ++ f1 ++ f2 ++ f3 ++ f4   return fresh where-    check time f = do+    checkInput time f = do       exists <- doesFileOrDirExist f       if not exists          then do@@ -309,9 +318,16 @@            time2 <- getModificationTime f            if time2 > time               then do-                when (not s) $ hPutStrLn stderr $ "Required path \"" ++ f ++ "\" is out of date."+                when (not s) $ hPutStrLn stderr $ "Required path \"" ++ f ++ "\" is newer than cached data."                 return True               else return False+    checkOutput f = do+      exists <- doesFileExist f+      if not exists+         then do+           when (not s) $ hPutStrLn stderr $ "Output file \"" ++ f ++ "\" is missing."+           return True+         else return False     checkMissing s0 s1 = not $ null $ (Set.fromList s1) `Set.difference` (Set.fromList s0)     doesFileOrDirExist f2 = do       existF <- doesFileExist f2@@ -319,7 +335,7 @@         then return True         else doesDirectoryExist f2 -getObjectFileResolver :: [ObjectFile] -> [Namespace] -> [CategoryName] -> [String]+getObjectFileResolver :: [ObjectFile] -> [Namespace] -> [CategoryName] -> [FilePath] getObjectFileResolver os ns ds = resolved ++ nonCategories where   categories    = filter isCategoryObjectFile os   nonCategories = map oofFile $ filter (not . isCategoryObjectFile) os@@ -327,10 +343,10 @@   keyByCategory2 o = ((ciCategory $ cofCategory o,ciNamespace $ cofCategory o),o)   objectMap = Map.fromList $ map keyBySpec categories   keyBySpec o = (cofCategory o,o)-  directDeps = concat $ map (resolveDep2 . show) ds+  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 . (:[])) (map show ns ++ [""])+    allChecks = map (\n -> (d,n) `Map.lookup` categoryMap >>= return . (:[])) (ns ++ [NoNamespace])     unwrap (Just xs) = xs     unwrap _         = []   (_,_,resolved) = collectAll Set.empty Set.empty directResolved@@ -345,33 +361,38 @@              fs' = (filter (not . flip elem fa') fs) ++ fs0            _ -> collectAll ca fa cs -resolveObjectDeps :: String -> [([String],CxxOutput)] -> [CompileMetadata] -> [ObjectFile]-resolveObjectDeps p os deps = resolvedCategories ++ nonCategories where+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-  categoriesToIds dep = map (\c -> CategoryIdentifier (cmPath dep) c (cmNamespace dep)) (cmCategories dep)-  cxxToId (CxxOutput (Just c) _ ns _ _ _) = CategoryIdentifier p (show c) (show ns)+  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 (map show ns2 ++ publicNamespaces) . show) ds+      rs = concat $ map (resolveDep categoryMap (ns2 ++ publicNamespaces)) ds -resolveCategoryDeps :: [String] -> [CompileMetadata] -> [CategoryIdentifier]+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 -> ((String,String),CategoryIdentifier)+keyByCategory :: CategoryIdentifier -> ((CategoryName,Namespace),CategoryIdentifier) keyByCategory c = ((ciCategory c,ciNamespace c),c) -resolveDep :: Map.Map (String,String) CategoryIdentifier -> [String] -> String -> [CategoryIdentifier]+resolveDep :: Map.Map (CategoryName,Namespace) CategoryIdentifier ->+  [Namespace] -> CategoryName -> [CategoryIdentifier] resolveDep cm (n:ns) d =   case (d,n) `Map.lookup` cm of        Just xs -> [xs]

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

@@ -41,13 +41,12 @@ import Parser.SourceFile import Types.IntegrationTest import Types.TypeCategory-import Types.TypeInstance  -runSingleTest :: CompilerBackend b => b -> [String] -> [CompileMetadata] ->-                 [ObjectFile] -> CategoryMap SourcePos -> (String,String) ->-                 IO ((Int,Int),CompileInfo ())-runSingleTest b paths deps os tm (f,s) = do+runSingleTest :: CompilerBackend b => b -> LanguageModule SourcePos ->+  FilePath -> [FilePath] -> [CompileMetadata] -> (String,String) ->+  IO ((Int,Int),CompileInfo ())+runSingleTest b cm p paths deps (f,s) = do   hPutStrLn stderr $ "\nExecuting tests from " ++ f   allResults <- checkAndRun (parseTestSource (f,s))   return $ second (flip reviseError $ "\nIn test file " ++ f) allResults where@@ -56,10 +55,11 @@         hPutStrLn stderr $ "Failed to parse tests in " ++ f         return ((0,1),ts >> return ())       | otherwise = do-        allResults <- sequence $ map runSingle $ getCompileSuccess ts-        let passed = length $ filter (not . isCompileError) allResults-        let failed = length $ filter isCompileError allResults-        return ((passed,failed),mergeAllM allResults)+          let (_,ts') = getCompileSuccess ts+          allResults <- sequence $ map runSingle ts'+          let passed = length $ filter (not . isCompileError) allResults+          let failed = length $ filter isCompileError allResults+          return ((passed,failed),mergeAllM allResults)     runSingle t = do       let name = ithTestName $ itHeader t       let context = formatFullContextBrace (ithContext $ itHeader t)@@ -72,9 +72,9 @@       return outcome      run (ExpectCompileError _ rs es) cs ds = do-      let result = compileAll Nothing cs ds :: CompileInfo ([CategoryName],[String],Namespace,[CxxOutput])+      let result = compileAll Nothing cs ds       if not $ isCompileError result-         then return $ compileError "Expected compiler error"+         then undefined  -- Should be caught in compileAll.          else return $ do            let warnings = getCompileWarnings result            let errors = show $ getCompileError result@@ -100,13 +100,13 @@          else mergeAllM [cr,ce]      execute s2 e rs es cs ds = do-      let result = compileAll (Just e) cs ds :: CompileInfo ([CategoryName],[String],Namespace,[CxxOutput])+      let result = compileAll (Just e) cs ds       if isCompileError result          then return $ result >> return ()          else do            let warnings = getCompileWarnings result-           let (req,main,ns,fs) = getCompileSuccess result-           (dir,binaryName) <- createBinary main req [ns] fs+           let (xx,main) = getCompileSuccess result+           (dir,binaryName) <- createBinary main xx            let command = TestCommand binaryName (takeDirectory binaryName)            (TestCommandResult s2' out err) <- runTestCommand b command            case (s2,s2') of@@ -118,26 +118,19 @@                   return result2      compileAll e cs ds = do-      let ns0 = map (StaticNamespace . cmNamespace) deps       let ns1 = StaticNamespace $ privateNamespace s       let cs' = map (setCategoryNamespace ns1) cs-      let cm = CategoryModule {-          cnBase = tm,-          cnNamespaces = ns0,-          cnPublic = [],-          cnPrivate = [PrivateSource {-              psNamespace = ns1,-              psCategory = cs',-              psDefine = ds-            }],-          cnExternal = []+      let xs = PrivateSource {+          psNamespace = ns1,+          psTesting = True,+          psCategory = cs',+          psDefine = ds         }-      xx <- compileCategoryModule cm-      tm' <- includeNewTypes tm cs'-      (req,main) <- case e of-                         Just e2 -> createTestFile tm' e2-                         Nothing -> return ([],[])-      return (req,main,ns1,xx)+      (_,xx) <- compileLanguageModule cm [xs]+      main <- case e of+                   Just e2 -> compileTestMain cm xs e2+                   Nothing -> compileError "Expected compiler error"+      return (xx,main)      checkRequired rs comp err out = mergeAllM $ map (checkSubsetForRegex True  comp err out) rs     checkExcluded es comp err out = mergeAllM $ map (checkSubsetForRegex False comp err out) es@@ -154,19 +147,21 @@       let found = any (=~ r) ms       when (found && not expected) $ compileError $ "Pattern \"" ++ r ++ "\" present in " ++ n       when (not found && expected) $ compileError $ "Pattern \"" ++ r ++ "\" missing from " ++ n-    createBinary c req ns fs = do+    createBinary (CxxOutput _ f2 _ ns req content) xx = do       dir <- mkdtemp "/tmp/ztest_"       hPutStrLn stderr $ "Writing temporary files to " ++ dir-      sources <- sequence $ map (writeSingleFile dir) fs-      let sources' = resolveObjectDeps dir sources deps-      let main   = dir </> "testcase.cpp"+      sources <- sequence $ map (writeSingleFile dir) xx+      -- TODO: Cache CompileMetadata here for debugging failures.+      let sources' = resolveObjectDeps deps p dir sources+      let main   = dir </> f2       let binary = dir </> "testcase"-      writeFile main $ concat $ map (++ "\n") c-      let lf = getLinkFlagsForDeps deps+      writeFile main $ concat $ map (++ "\n") content+      let flags = getLinkFlagsForDeps deps       let paths' = nub $ map fixPath (dir:paths)+      let os  = getObjectFilesForDeps deps       let ofr = getObjectFileResolver (sources' ++ os)       let os' = ofr ns req-      let command = CompileToBinary main os' binary paths' lf+      let command = CompileToBinary main os' binary paths' flags       file <- runCxxCommand b command       return (dir,file)     writeSingleFile d ca@(CxxOutput _ f2 _ _ _ content) = do

@@ -20,19 +20,19 @@ {-# LANGUAGE Safe #-}  module CompilerCxx.Category (-  CategoryModule(..),   CxxOutput(..),+  LanguageModule(..),   PrivateSource(..),-  createMainFile,-  createTestFile,   compileCategoryDeclaration,-  compileCategoryModule,+  compileLanguageModule,   compileConcreteDefinition,   compileConcreteTemplate,   compileInterfaceDefinition,   compileModuleMain,+  compileTestMain, ) where +import Control.Monad (foldM) import Data.List (intercalate,sortBy) import Prelude hiding (pi) import qualified Data.Map as Map@@ -46,6 +46,7 @@ import CompilerCxx.Code import CompilerCxx.Naming import CompilerCxx.Procedure+import Types.Builtin import Types.DefinedCategory import Types.GeneralType import Types.Positional@@ -64,62 +65,99 @@     coUsesCategory :: [CategoryName],     coOutput :: [String]   }+  deriving (Show) -data CategoryModule c =-  CategoryModule {-    cnBase :: CategoryMap c,-    cnNamespaces :: [Namespace],-    cnPublic :: [AnyCategory c],-    cnPrivate :: [PrivateSource c],-    cnExternal :: [String]+data LanguageModule c =+  LanguageModule {+    lmPublicNamespaces :: [Namespace],+    lmPrivateNamespaces :: [Namespace],+    lmLocalNamespaces :: [Namespace],+    lmPublicDeps :: [AnyCategory c],+    lmPrivateDeps :: [AnyCategory c],+    lmTestingDeps :: [AnyCategory c],+    lmPublicLocal :: [AnyCategory c],+    lmPrivateLocal :: [AnyCategory c],+    lmTestingLocal :: [AnyCategory c],+    lmExternal :: [CategoryName]   }  data PrivateSource c =   PrivateSource {     psNamespace :: Namespace,+    psTesting :: Bool,     psCategory :: [AnyCategory c],     psDefine :: [DefinedCategory c]   } -compileCategoryModule :: (Show c, CompileErrorM m, MergeableM m) =>-  CategoryModule c -> m [CxxOutput]-compileCategoryModule (CategoryModule tm ns cs xa ex) = do+compileLanguageModule :: (Show c, CompileErrorM m, MergeableM m) =>+  LanguageModule c -> [PrivateSource c] -> m ([CxxOutput],[CxxOutput])+compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 ex) xa = do   checkSupefluous $ Set.toList $ (Set.fromList ex) `Set.difference` ca-  tm' <- includeNewTypes tm cs-  hxx <- collectAllOrErrorM $ map (compileCategoryDeclaration tm' ns) cs-  let interfaces = filter (not . isValueConcrete) cs-  cxx <- collectAllOrErrorM $ map compileInterfaceDefinition interfaces-  xa2 <- collectAllOrErrorM $ map (compileInternal ns) xa-  let xx = concat $ map snd xa2-  let dm = mapByName $ concat $ map fst xa2-  checkDefined dm ex $ filter isValueConcrete cs-  return $ hxx ++ cxx ++ xx where-    compileInternal ns0 (PrivateSource ns1 cs2 ds) = do-      let cs' = cs++cs2-      checkLocals ds (ex ++ map (show . getCategoryName) cs')+  (hxx1,cxx1) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmPublic  nsPublic)  cs1+  (hxx2,cxx2) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmPrivate nsPrivate) ps1+  (hxx3,cxx3) <- fmap mergeGeneratedP $ collectAllOrErrorM $ map (compileSourceP tmTesting nsTesting) ts1+  (ds,xx) <- fmap mergeGeneratedX $ collectAllOrErrorM $ map compileSourceX xa+  -- TODO: This should account for a name clash between a category declared in a+  -- TestsOnly .0rp and one declared in a non-TestOnly .0rx.+  let dm = mapByName ds+  checkDefined dm ex $ filter isValueConcrete (cs1 ++ ps1 ++ ts1)+  return (hxx1 ++ hxx2 ++ hxx3 ++ cxx1 ++ cxx2 ++ cxx3,xx) where+    tmPublic  = foldM includeNewTypes defaultCategories [cs0,cs1]+    tmPrivate = tmPublic  >>= \tm -> foldM includeNewTypes tm [ps0,ps1]+    tmTesting = tmPrivate >>= \tm -> foldM includeNewTypes tm [ts0,ts1]+    nsPublic = ns0 ++ ns2+    nsPrivate = nsPublic ++ ns1+    nsTesting = nsPrivate+    compileSourceP tm ns c = do+      tm' <- tm+      hxx <- compileCategoryDeclaration tm' ns c+      cxx <- if isValueConcrete c+                then return []+                else compileInterfaceDefinition c >>= return . (:[])+      return (hxx,cxx)+    mergeGeneratedP ((hxx,cxx):ps) = let (hxx2,cxx2) = mergeGeneratedP ps in (hxx:hxx2,cxx++cxx2)+    mergeGeneratedP _              = ([],[])+    compileSourceX (PrivateSource ns testing cs2 ds) = do+      tm <- if testing+               then tmTesting+               else tmPrivate+      let ns4 = if testing+                then nsTesting+                else nsPrivate+      let cs = if testing+                  then cs1 ++ ps1 ++ ts1+                  else cs1 ++ ps1+      checkLocals ds (ex ++ map getCategoryName (cs2 ++ cs))       let dm = mapByName ds       checkDefined dm [] $ filter isValueConcrete cs2-      tm' <- includeNewTypes tm cs'-      hxx <- collectAllOrErrorM $ map (compileCategoryDeclaration tm' ns0) cs2+      tm' <- includeNewTypes tm cs2+      -- Ensures that there isn't an inavertent collision when resolving+      -- dependencies for the module later on.+      tmTesting' <- tmTesting+      _ <- includeNewTypes tmTesting' cs2 `reviseError` "In a module source that is conditionally public"+      hxx <- collectAllOrErrorM $ map (compileCategoryDeclaration tm' ns4) cs2       let interfaces = filter (not . isValueConcrete) cs2       cxx1 <- collectAllOrErrorM $ map compileInterfaceDefinition interfaces-      cxx2 <- collectAllOrErrorM $ map (compileDefinition tm' (ns1:ns)) ds+      cxx2 <- collectAllOrErrorM $ map (compileDefinition tm' (ns:ns4)) ds       return (ds,hxx ++ cxx1 ++ cxx2)-    compileDefinition tm2 ns2 d = do-      tm2' <- mergeInternalInheritance tm2 d-      compileConcreteDefinition tm2' ns2 d+    mergeGeneratedX ((ds,xx):xs2) = let (ds2,xx2) = mergeGeneratedX xs2 in (ds++ds2,xx++xx2)+    mergeGeneratedX _             = ([],[])+    compileDefinition tm ns4 d = do+      tm' <- mergeInternalInheritance tm d+      let refines = dcName d `Map.lookup` tm >>= return . getCategoryRefines+      compileConcreteDefinition tm' ns4 refines d     mapByName = Map.fromListWith (++) . map (\d -> (dcName d,[d]))-    ca = Set.fromList $ map (show . getCategoryName) $ filter isValueConcrete cs+    ca = Set.fromList $ map getCategoryName $ filter isValueConcrete (cs1 ++ ps1 ++ ts1)     checkLocals ds cs2 = mergeAllM $ map (checkLocal $ Set.fromList cs2) ds     checkLocal cs2 d =-      if (show $ dcName d) `Set.member` cs2+      if dcName d `Set.member` cs2          then return ()          else compileError ("Definition for " ++ show (dcName d) ++                             formatFullContextBrace (dcContext d) ++-                            " does not correspond to a category in this module")+                            " does not correspond to a visible category in this module")     checkDefined dm ex2 = mergeAllM . map (checkSingle dm (Set.fromList ex2))     checkSingle dm es t =-      case ((show $ getCategoryName t) `Set.member` es, getCategoryName t `Map.lookup` dm) of+      case (getCategoryName t `Set.member` es, getCategoryName t `Map.lookup` dm) of            (False,Just [_]) -> return ()            (True,Nothing)   -> return ()            (True,Just [d]) ->@@ -138,25 +176,32 @@     checkSupefluous es2       | null es2 = return ()       | otherwise = compileError $ "External categories either not concrete or not present: " ++-                                   intercalate ", " es2+                                   intercalate ", " (map show es2) +compileTestMain :: (Show c, CompileErrorM m, MergeableM m) =>+  LanguageModule c -> PrivateSource c -> Expression c -> m CxxOutput+compileTestMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _) ts2 e = do+  tm' <- tm+  (req,main) <- createTestFile tm' e+  return $ CxxOutput Nothing testFilename NoNamespace ([psNamespace ts2]++ns0++ns1++ns2) req main where+  tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1,psCategory ts2]+ compileModuleMain :: (Show c, CompileErrorM m, MergeableM m) =>-  CategoryModule c -> CategoryName -> FunctionName -> m CxxOutput-compileModuleMain (CategoryModule tm _ cs xa _) n f = do-  xx <- fmap concat $ collectAllOrErrorM $ filter (not . isCompileError) $ map maybeCompileMain xa-  reconcile xx where-    maybeCompileMain (PrivateSource _ cs2 ds) = do-      let cs' = cs++cs2-      tm' <- includeNewTypes tm cs'-      let dm = Set.fromList $ map dcName ds-      if n `Set.member` dm-         then do-           (ns2,main) <- createMainFile tm' n f-           return [CxxOutput Nothing mainFilename NoNamespace [ns2] [n] main]-         else return []-    reconcile [x] = return x+  LanguageModule c -> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput+compileModuleMain (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1 _) xa n f = do+  let resolved = filter (\d -> dcName d == n) $ concat $ map psDefine xa+  reconcile resolved+  tm' <- tm+  let cs = filter (\c -> getCategoryName c == n) $ concat $ map psCategory xa+  tm'' <- includeNewTypes tm' cs+  (ns,main) <- createMainFile tm'' n f+  return $ CxxOutput Nothing mainFilename NoNamespace ([ns]++ns0++ns1++ns2) [n] main where+    tm = foldM includeNewTypes defaultCategories [cs0,cs1,ps0,ps1,ts0,ts1]+    reconcile [_] = return ()     reconcile []  = compileErrorM $ "No matches for main category " ++ show n-    reconcile _   = compileErrorM $ "Multiple matches for main category " ++ show n+    reconcile ds  =+      flip reviseError ("Multiple matches for main category " ++ show n) $+        mergeAllM $ map (\d -> compileError $ "Defined at " ++ formatFullContext (dcContext d)) ds  compileCategoryDeclaration :: (Show c, CompileErrorM m, MergeableM m) =>   CategoryMap c -> [Namespace] -> AnyCategory c -> m CxxOutput@@ -198,7 +243,7 @@ compileInterfaceDefinition :: MergeableM m => AnyCategory c -> m CxxOutput compileInterfaceDefinition t = do   te <- typeConstructor-  commonDefineAll t [] emptyCode emptyCode emptyCode te []+  commonDefineAll t [] Nothing emptyCode emptyCode emptyCode te []   where     typeConstructor = do       let ps = map vpParam $ getCategoryParams t@@ -214,7 +259,7 @@   CategoryMap c -> CategoryName -> m CxxOutput compileConcreteTemplate ta n = do   (_,t) <- getConcreteCategory ta ([],n)-  compileConcreteDefinition ta [] (defined t) `reviseError` ("In generated template for " ++ show n) where+  compileConcreteDefinition ta [] Nothing (defined t) `reviseError` ("In generated template for " ++ show n) where     defined t = DefinedCategory {         dcContext = [],         dcName = getCategoryName t,@@ -242,8 +287,8 @@     funcName f = show (sfType f) ++ "." ++ show (sfName f)  compileConcreteDefinition :: (Show c, CompileErrorM m, MergeableM m) =>-  CategoryMap c -> [Namespace] -> DefinedCategory c -> m CxxOutput-compileConcreteDefinition ta ns dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do+  CategoryMap c -> [Namespace] -> Maybe [ValueRefine c] -> DefinedCategory c -> m CxxOutput+compileConcreteDefinition ta ns rs dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do   (_,t) <- getConcreteCategory ta (c,n)   let r = CategoryResolver ta   [cp,tp,vp] <- getProcedureScopes ta dd@@ -296,7 +341,7 @@       return $ mergeAll $ map fst tf,       mergeAllM $ map (createMember r allFilters) tm     ]-  commonDefineAll t ns top bottom ce te fe+  commonDefineAll t ns rs top bottom ce te fe   where     disallowTypeMembers :: (Show c, CompileErrorM m, MergeableM m) =>       [DefinedMember c] -> m ()@@ -390,17 +435,20 @@         ] ++ createFunctionDispatch n ValueScope fs2 ++ ["}"]  commonDefineAll :: MergeableM m =>-  AnyCategory c -> [Namespace] -> CompiledData [String] -> CompiledData [String] ->-  CompiledData [String] -> CompiledData [String] ->+  AnyCategory c -> [Namespace] -> Maybe [ValueRefine c] -> CompiledData [String] ->+  CompiledData [String] -> CompiledData [String] -> CompiledData [String] ->   [ScopedFunction c] -> m CxxOutput-commonDefineAll t ns top bottom ce te fe = do+commonDefineAll t ns rs top bottom ce te fe = do   let filename = sourceFilename name   (CompiledData req out) <- fmap (addNamespace t) $ mergeAllM $ [       return $ CompiledData (Set.fromList (name:getCategoryMentions t)) [],       return $ mergeAll [createCollection,createAllLabels]     ] ++ conditionalContent-  let inherited = Set.fromList $ (map (tiName . vrType) $ getCategoryRefines t) ++-                                 (map (diName . vdType) $ getCategoryDefines t)+  let rs' = case rs of+                 Nothing -> []+                 Just rs2 -> rs2+  let inherited = Set.unions $ (map (categoriesFromRefine . vrType) (getCategoryRefines t ++ rs')) +++                               (map (categoriesFromDefine . vdType) $ getCategoryDefines t)   let includes = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $                    Set.toList $ Set.union req inherited   return $ CxxOutput (Just $ getCategoryName t)@@ -419,7 +467,7 @@         return top,         commonDefineCategory t ce,         return $ onlyCodes getInternal,-        commonDefineType t te,+        commonDefineType t rs te,         defineInternalType name paramCount,         return bottom,         return $ onlyCode $ "}  // namespace",@@ -524,8 +572,11 @@     name = getCategoryName t  commonDefineType :: MergeableM m =>-  AnyCategory c -> CompiledData [String] -> m (CompiledData [String])-commonDefineType t extra = do+  AnyCategory c -> Maybe [ValueRefine c] -> CompiledData [String] -> m (CompiledData [String])+commonDefineType t rs extra = do+  let rs' = case rs of+                 Nothing -> getCategoryRefines t+                 Just rs2 -> rs2   mergeAllM [       return $ CompiledData depends [],       return $ onlyCode $ "struct " ++ typeName (getCategoryName t) ++ " : public " ++ typeBase ++ " {",@@ -534,7 +585,7 @@       return $ indentCompiled $ onlyCode $ categoryName (getCategoryName t) ++ "& parent;",       return $ indentCompiled createParams,       return $ indentCompiled canConvertFrom,-      return $ indentCompiled typeArgsForParent,+      return $ indentCompiled $ typeArgsForParent rs',       return $ indentCompiled extra,       return $ onlyCode "};"     ]@@ -567,16 +618,16 @@         "  if (!TypeInstance::CanConvert(*args[" ++ show i ++ "], " ++ paramName p ++ ")) return false;",         "  if (!TypeInstance::CanConvert(" ++ paramName p ++ ", *args[" ++ show i ++ "])) return false;"       ]-    typeArgsForParent+    typeArgsForParent rs2       | isInstanceInterface t = emptyCode       | otherwise = onlyCodes $ [           "bool TypeArgsForParent(" ++           "const TypeCategory& category, " ++           "std::vector<const TypeInstance*>& args) const final {"-        ] ++ allCats ++ ["  return false;","}"]+        ] ++ allCats rs2 ++ ["  return false;","}"]     myType = (getCategoryName t,map (SingleType . JustParamName . fst) params)-    refines = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType $ getCategoryRefines t-    allCats = concat $ map singleCat (myType:refines)+    refines rs2 = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType rs2+    allCats rs2 = concat $ map singleCat (myType:refines rs2)     singleCat (t2,ps) = [         "  if (&category == &" ++ categoryGetter t2 ++ "()) {",         "    args = std::vector<const TypeInstance*>{" ++ expanded ++ "};",@@ -729,8 +780,8 @@                         fromDefines (getCategoryDefines t) ++                         fromFunctions (getCategoryFunctions t) ++                         fromFilters (getCategoryFilters t) where-  fromRefines rs = fromGenerals $ map (SingleType . JustTypeInstance . vrType) rs-  fromDefines ds = concat $ map (fromDefine . vdType) ds+  fromRefines rs = Set.toList $ Set.unions $ map (categoriesFromRefine . vrType) rs+  fromDefines ds = Set.toList $ Set.unions $ map (categoriesFromDefine . vdType) ds   fromDefine (DefinesInstance d ps) = d:(fromGenerals $ pValues ps)   fromFunctions fs = concat $ map fromFunction fs   fromFunction (ScopedFunction _ _ t2 _ as rs _ fs _) =

@@ -41,6 +41,7 @@   qualifiedTypeGetter,   sourceFilename,   tableName,+  testFilename,   typeCreator,   typeGetter,   typeName,@@ -66,6 +67,9 @@  mainFilename :: String mainFilename = "main.cpp"++testFilename :: String+testFilename = "test.cpp"  baseHeaderIncludes :: [String] baseHeaderIncludes = ["#include \"category-header.hpp\""]

@@ -23,6 +23,8 @@  module CompilerCxx.Procedure (   categoriesFromTypes,+  categoriesFromDefine,+  categoriesFromRefine,   compileExecutableProcedure,   compileMainProcedure,   compileExpression,@@ -635,7 +637,7 @@ compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do   r <- csResolver   fa <- csAllFilters-  lift $ validateGeneralInstance r fa (SingleType t)+  lift $ validateGeneralInstance r fa (SingleType t) `reviseError` ("In function call at " ++ formatFullContext c)   f' <- csGetTypeFunction c (Just $ SingleType t) n   when (sfScope f' /= TypeScope) $ lift $ compileError $ "Function " ++ show n ++                                           " cannot be used as a type function" ++@@ -826,6 +828,12 @@   getAll (TypeMerge _ ps) = concat $ map getAll ps   getAll (SingleType (JustTypeInstance (TypeInstance t ps))) = t:(concat $ map getAll $ pValues ps)   getAll _ = []++categoriesFromRefine :: TypeInstance -> Set.Set CategoryName+categoriesFromRefine (TypeInstance t ps) = t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps)++categoriesFromDefine :: DefinesInstance -> Set.Set CategoryName+categoriesFromDefine (DefinesInstance t ps) = t `Set.insert` (Set.unions $ map categoriesFromTypes $ pValues ps)  expandParams :: (CompilerContext c m s a) =>   Positional GeneralInstance -> CompilerState a m String

@@ -33,8 +33,8 @@  import Control.Monad (when) import Data.Hashable (hash)-import Data.List (intercalate,isSuffixOf)-import Data.Version (showVersion)+import Data.List (intercalate,isPrefixOf,isSuffixOf)+import Data.Version (showVersion,versionBranch) import GHC.IO.Handle import Numeric (showHex) import System.Directory@@ -49,14 +49,19 @@  loadConfig :: IO (Backend,Resolver) loadConfig = do-  f <- localConfigPath-  isFile <- doesFileExist f+  configFile <- localConfigPath+  isFile <- doesFileExist configFile   when (not isFile) $ do     hPutStrLn stderr "Zeolite has not been configured. Please run zeolite-setup."     exitFailure-  c <- readFile f-  lc <- check $ (reads c :: [(LocalConfig,String)])-  return (lcBackend lc,lcResolver lc) where+  configString <- readFile configFile+  lc <- check $ (reads configString :: [(LocalConfig,String)])+  pathsFile <- globalPathsPath+  pathsExists <- doesFileExist pathsFile+  paths <- if pathsExists+              then readFile pathsFile >>= return . lines+              else return []+  return (lcBackend lc,addPaths (lcResolver lc) paths) where     check [(cm,"")] = return cm     check [(cm,"\n")] = return cm     check _ = do@@ -71,13 +76,18 @@  data Backend =   UnixBackend {-    ucCxxBinary :: String,+    ucCxxBinary :: FilePath,     ucCxxOptions :: [String],-    ucArBinary :: String+    ucArBinary :: FilePath   }   deriving (Read,Show) -data Resolver = SimpleResolver deriving (Read,Show)+data Resolver =+  SimpleResolver {+    srVisibleSystem :: [FilePath],+    srExtraPaths :: [FilePath]+  }+  deriving (Read,Show)  data LocalConfig =   LocalConfig {@@ -86,12 +96,21 @@   }   deriving (Read,Show) -localConfigFilename :: String+localConfigFilename :: FilePath localConfigFilename = ".local-config" +globalPathsFilename :: FilePath+globalPathsFilename = "global-paths"+ localConfigPath :: IO FilePath localConfigPath = getDataFileName localConfigFilename >>= canonicalizePath +globalPathsPath :: IO FilePath+globalPathsPath = getDataFileName globalPathsFilename >>= canonicalizePath++addPaths :: Resolver -> [FilePath] -> Resolver+addPaths (SimpleResolver ls ps) ps2 = SimpleResolver ls (ps ++ ps2)+ instance CompilerBackend Backend where   runCxxCommand (UnixBackend cb co ab) (CompileToObject s p nm ns ps e) = do     objName <- canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".o")@@ -126,15 +145,16 @@     err <- readFile errF     removeFile errF     let success = case status of-                      Just (Exited ExitSuccess) -> True-                      _ -> False+                       Just (Exited ExitSuccess) -> True+                       _ -> False     return $ TestCommandResult success (lines out) (lines err) where       execWithCapture h1 h2 = do         when (not $ null p) $ setCurrentDirectory p         hDuplicateTo h1 stdout         hDuplicateTo h2 stderr         executeFile b True [] Nothing-  getCompilerHash b = flip showHex "" $ abs $ hash $ compilerVersion ++ show b+  getCompilerHash b = VersionHash $ flip showHex "" $ abs $ hash $ minorVersion ++ show b where+    minorVersion = show $ take 3 $ versionBranch version  executeProcess :: String -> [String] -> IO () executeProcess c os = do@@ -146,15 +166,22 @@        _ -> exitFailure  instance PathResolver Resolver where-  resolveModule SimpleResolver p m = do-    m' <- getDataFileName m-    firstExisting m [p</>m,m']+  resolveModule (SimpleResolver ls ps) p m = do+    let allowGlobal = not (".." `elem` components)+    m0 <- if allowGlobal && any (\l -> isPrefixOf (l ++ "/") m) ls+             then getDataFileName m >>= return . (:[])+             else return []+    let m2 = if allowGlobal+                then map (</> m) ps+                else []+    firstExisting m $ [p</>m] ++ m0 ++ m2 where+      components = map stripSlash $ splitPath m+      stripSlash = reverse . dropWhile (== '/') . reverse   resolveBaseModule _ = do     let m = "base"-    m' <- getDataFileName m-    firstExisting m [m']-  resolveBinary SimpleResolver = canonicalizePath-  isBaseModule r@SimpleResolver f = do+    m0 <- getDataFileName m+    firstExisting m [m0]+  isBaseModule r f = do     b <- resolveBaseModule r     return (f == b) 

@@ -26,5 +26,4 @@ class PathResolver r where   resolveModule :: r -> FilePath -> FilePath -> IO FilePath   resolveBaseModule :: r -> IO FilePath-  resolveBinary :: r -> FilePath -> IO FilePath   isBaseModule :: r -> FilePath -> IO Bool

@@ -23,13 +23,19 @@   CxxCommand(..),   TestCommand(..),   TestCommandResult(..),+  VersionHash(..), ) where   class CompilerBackend b where   runCxxCommand :: b -> CxxCommand -> IO String   runTestCommand :: b -> TestCommand -> IO TestCommandResult-  getCompilerHash :: b -> String+  getCompilerHash :: b -> VersionHash++newtype VersionHash = VersionHash String deriving (Eq)++instance Show VersionHash where+  show (VersionHash h) = h  data CxxCommand =   CompileToObject {

@@ -47,8 +47,8 @@   kwFail,   kwFalse,   kwIf,-  kwIn,   kwIgnore,+  kwIn,   kwInterface,   kwOptional,   kwPresent,@@ -57,8 +57,8 @@   kwRequire,   kwRequires,   kwReturn,-  kwSelf,   kwScoped,+  kwSelf,   kwStrong,   kwTestcase,   kwTrue,@@ -71,6 +71,7 @@   kwWhile,   labeled,   lineComment,+  lineEnd,   merge2,   merge3,   noKeywords,@@ -83,6 +84,10 @@   parseHex,   parseOct,   parseSubOne,+  pragmaArgsEnd,+  pragmaArgsStart,+  pragmaEnd,+  pragmaStart,   put12,   put13,   put22,@@ -91,12 +96,12 @@   regexChar,   requiredSpace,   sepAfter,-  sepAfter_,   sepAfter1,-  string_,-  stringChar,+  sepAfter_,   statementEnd,   statementStart,+  stringChar,+  string_,   typeSymbolGet,   valueSymbolGet, ) where@@ -319,9 +324,12 @@ string_ :: String -> Parser () string_ = (>> return ()) . string +lineEnd :: Parser ()+lineEnd = (endOfLine >> return ()) <|> endOfDoc+ lineComment :: Parser String lineComment = between (string_ "//")-                      endOfLine+                      lineEnd                       (many $ satisfy (/= '\n'))  blockComment :: Parser String@@ -359,6 +367,18 @@ notAllowed :: Parser a -> String -> Parser () -- Based on implementation of notFollowedBy. notAllowed p s = (try p >> fail s) <|> return ()++pragmaStart :: Parser ()+pragmaStart = string_ "$"++pragmaEnd :: Parser ()+pragmaEnd = string_ "$"++pragmaArgsStart :: Parser ()+pragmaArgsStart = string_ "["++pragmaArgsEnd :: Parser ()+pragmaArgsEnd = string_ "]"  operator :: String -> Parser String operator o = labeled o $ do

@@ -0,0 +1,76 @@+{- -----------------------------------------------------------------------------+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 Parser.Pragma (+  parsePragmas,+  pragmaComment,+  pragmaModuleOnly,+  pragmaTestsOnly+) where++import Control.Monad (when)+import Text.Parsec+import Text.Parsec.String++import Parser.Common+import Types.Pragma+++parsePragmas :: [Parser a] -> Parser [a]+parsePragmas = many . foldr ((<|>)) unknownPragma++pragmaModuleOnly :: Parser (Pragma SourcePos)+pragmaModuleOnly = autoPragma "ModuleOnly" $ Left parseAt where+  parseAt c = PragmaVisibility [c] ModuleOnly++pragmaTestsOnly :: Parser (Pragma SourcePos)+pragmaTestsOnly = autoPragma "TestsOnly" $ Left parseAt where+  parseAt c = PragmaVisibility [c] TestsOnly++pragmaComment :: Parser (Pragma SourcePos)+pragmaComment = autoPragma "Comment" $ Right parseAt where+  parseAt c = do+    string_ "\""+    ss <- manyTill stringChar (string_ "\"")+    optionalSpace+    return $ PragmaComment [c] ss++unknownPragma :: Parser a+unknownPragma = do+  try pragmaStart+  p <- many1 alphaNum+  fail $ "Pragma " ++ p ++ " is not supported in this context"++autoPragma :: String -> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a+autoPragma p f = do+  c <- getPosition+  try $ pragmaStart >> string_ p+  hasArgs <- (pragmaArgsStart >> optionalSpace >> return True) <|> return False+  x <- delegate hasArgs f c+  if hasArgs+     then do+       extra <- manyTill anyChar (string_ "]$")+       when (not $ null extra) $ fail $ "Content unused by pragma " ++ p ++ ": " ++ extra+     else sepAfter pragmaEnd+  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 []"

@@ -25,32 +25,59 @@ ) where  import Text.Parsec+import Text.Parsec.String  import Base.CompileError import Parser.Common import Parser.DefinedCategory import Parser.IntegrationTest ()+import Parser.Pragma import Parser.TypeCategory () import Types.DefinedCategory import Types.IntegrationTest+import Types.Pragma import Types.TypeCategory   parseInternalSource :: CompileErrorM m =>-  (String,String) -> m ([AnyCategory SourcePos],[DefinedCategory SourcePos])+  (FilePath,String) -> m ([Pragma SourcePos],[AnyCategory SourcePos],[DefinedCategory SourcePos]) parseInternalSource (f,s) = unwrap parsed where-  parsed = parse (between optionalSpace endOfDoc parseAnySource) f s+  parsed = parse (between optionalSpace endOfDoc withPragmas) f s   unwrap (Left e)  = compileError (show e)   unwrap (Right t) = return t+  withPragmas = do+    pragmas <- parsePragmas internalSourcePragmas+    optionalSpace+    (cs,ds) <- parseAnySource+    return (pragmas,cs,ds) -parsePublicSource :: CompileErrorM m => (String,String) -> m [AnyCategory SourcePos]+parsePublicSource :: CompileErrorM m => (FilePath,String) -> m ([Pragma SourcePos],[AnyCategory SourcePos]) parsePublicSource (f,s) = unwrap parsed where-  parsed = parse (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s+  parsed = parse (between optionalSpace endOfDoc withPragmas) f s   unwrap (Left e)  = compileError (show e)   unwrap (Right t) = return t+  withPragmas = do+    pragmas <- parsePragmas publicSourcePragmas+    optionalSpace+    cs <- sepBy sourceParser optionalSpace+    return (pragmas,cs) -parseTestSource :: CompileErrorM m => (String,String) -> m [IntegrationTest SourcePos]+parseTestSource :: CompileErrorM m => (FilePath,String) -> m ([Pragma SourcePos],[IntegrationTest SourcePos]) parseTestSource (f,s) = unwrap parsed where-  parsed = parse (between optionalSpace endOfDoc (sepBy sourceParser optionalSpace)) f s+  parsed = parse (between optionalSpace endOfDoc withPragmas) f s   unwrap (Left e)  = compileError (show e)   unwrap (Right t) = return t+  withPragmas = do+    pragmas <- parsePragmas testSourcePragmas+    optionalSpace+    ts <- sepBy sourceParser optionalSpace+    return (pragmas,ts)++publicSourcePragmas :: [Parser (Pragma SourcePos)]+publicSourcePragmas = [pragmaModuleOnly,pragmaTestsOnly]++internalSourcePragmas :: [Parser (Pragma SourcePos)]+internalSourcePragmas = [pragmaTestsOnly]++testSourcePragmas :: [Parser (Pragma SourcePos)]+testSourcePragmas = []

@@ -26,13 +26,16 @@ import Cli.CompileMetadata import Cli.CompileOptions import Cli.ParseMetadata+import Config.Programs (VersionHash(..))+import Types.TypeCategory (FunctionName(..),Namespace(..))+import Types.TypeInstance (CategoryName(..))  tests :: [IO (CompileInfo ())] tests = [     checkWriteThenRead $ CompileMetadata {-      cmVersionHash = "0123456789ABCDEFabcdef",+      cmVersionHash = VersionHash "0123456789ABCDEFabcdef",       cmPath = "/home/project/special",-      cmNamespace = "public_ABCDEF",+      cmNamespace = StaticNamespace "public_ABCDEF",       cmPublicDeps = [         "/home/project/public-dep1",         "/home/project/public-dep2"@@ -41,10 +44,14 @@         "/home/project/private-dep1",         "/home/project/private-dep2"       ],-      cmCategories = [-        "MyCategory",-        "MyOtherCategory"+      cmPublicCategories = [+        CategoryName "MyCategory",+        CategoryName "MyOtherCategory"       ],+      cmPrivateCategories = [+        CategoryName "PrivateCategory",+        CategoryName "PrivateOtherCategory"+      ],       cmSubdirs = [         "/home/project/special/subdir1",         "/home/project/special/subdir2"@@ -69,6 +76,10 @@         "/home/project/special/category1.cpp",         "/home/project/special/category2.cpp"       ],+      cmBinaries = [+        "/home/project/special/binary1",+        "/home/project/special/binary2"+      ],       cmLinkFlags = [         "-lm",         "-ldl"@@ -77,17 +88,17 @@         CategoryObjectFile {           cofCategory = CategoryIdentifier {             ciPath = "/home/project/special",-            ciCategory = "SpecialCategory",-            ciNamespace = "public_ABCDEF"+            ciCategory = CategoryName "SpecialCategory",+            ciNamespace = StaticNamespace "public_ABCDEF"           },           cofRequires = [             CategoryIdentifier {               ciPath = "/home/project/private-dep1",-              ciCategory = "PrivateCategory",-              ciNamespace = "private_123456"+              ciCategory = CategoryName "PrivateCategory",+              ciNamespace = NoNamespace             },             UnresolvedCategory {-              ucCategory = "UnresolvedCategory"+              ucCategory = CategoryName "UnresolvedCategory"             }           ],           cofFiles = [@@ -99,58 +110,85 @@     },      checkWriteFail "bad hash" $ CompileMetadata {-      cmVersionHash = "bad hash",+      cmVersionHash = VersionHash "bad hash",       cmPath = "/home/project/special",-      cmNamespace = "public_ABCDEF",+      cmNamespace = NoNamespace,       cmPublicDeps = [],       cmPrivateDeps = [],-      cmCategories = [],+      cmPublicCategories = [],+      cmPrivateCategories = [],       cmSubdirs = [],       cmPublicFiles = [],       cmPrivateFiles = [],       cmTestFiles = [],       cmHxxFiles = [],       cmCxxFiles = [],+      cmBinaries = [],       cmLinkFlags = [],       cmObjectFiles = []     },      checkWriteFail "bad namespace" $ CompileMetadata {-      cmVersionHash = "0123456789ABCDEFabcdef",+      cmVersionHash = VersionHash "0123456789ABCDEFabcdef",       cmPath = "/home/project/special",-      cmNamespace = "bad namespace",+      cmNamespace = StaticNamespace "bad namespace",       cmPublicDeps = [],       cmPrivateDeps = [],-      cmCategories = [],+      cmPublicCategories = [],+      cmPrivateCategories = [],       cmSubdirs = [],       cmPublicFiles = [],       cmPrivateFiles = [],       cmTestFiles = [],       cmHxxFiles = [],       cmCxxFiles = [],+      cmBinaries = [],       cmLinkFlags = [],       cmObjectFiles = []     },      checkWriteFail "bad category" $ CompileMetadata {-      cmVersionHash = "0123456789ABCDEFabcdef",+      cmVersionHash = VersionHash "0123456789ABCDEFabcdef",       cmPath = "/home/project/special",-      cmNamespace = "public_ABCDEF",+      cmNamespace = NoNamespace,       cmPublicDeps = [],       cmPrivateDeps = [],-      cmCategories = [-        "bad category"+      cmPublicCategories = [+        CategoryName "bad category"       ],+      cmPrivateCategories = [],       cmSubdirs = [],       cmPublicFiles = [],       cmPrivateFiles = [],       cmTestFiles = [],       cmHxxFiles = [],       cmCxxFiles = [],+      cmBinaries = [],       cmLinkFlags = [],       cmObjectFiles = []     }, +    checkWriteFail "bad category" $ CompileMetadata {+      cmVersionHash = VersionHash "0123456789ABCDEFabcdef",+      cmPath = "/home/project/special",+      cmNamespace = NoNamespace,+      cmPublicDeps = [],+      cmPrivateDeps = [],+      cmPublicCategories = [],+      cmPrivateCategories = [+        CategoryName "bad category"+      ],+      cmSubdirs = [],+      cmPublicFiles = [],+      cmPrivateFiles = [],+      cmTestFiles = [],+      cmHxxFiles = [],+      cmCxxFiles = [],+      cmBinaries = [],+      cmLinkFlags = [],+      cmObjectFiles = []+    },+     checkWriteThenRead $ ModuleConfig {       rmRoot = "/home/projects",       rmPath = "special",@@ -166,12 +204,12 @@         CategorySource {           csSource = "extra1.cpp",           csCategories = [-            "Category1",-            "Category2"+            CategoryName "Category1",+            CategoryName "Category2"           ],           csDepCategories = [-            "DepCategory1",-            "DepCategory2"+            CategoryName "DepCategory1",+            CategoryName "DepCategory2"           ]         },         OtherSource {@@ -193,7 +231,7 @@     checkWriteFail "bad category" $ CategorySource {       csSource = "extra1.cpp",       csCategories = [-        "bad category"+        CategoryName "bad category"       ],       csDepCategories = []     },@@ -202,50 +240,50 @@       csSource = "extra1.cpp",       csCategories = [],       csDepCategories = [-        "bad category"+        CategoryName "bad category"       ]     },      checkWriteFail "bad category" $ CategoryIdentifier {       ciPath = "/home/project/special",-      ciCategory = "bad category",-      ciNamespace = "public_ABCDEF"+      ciCategory = CategoryName "bad category",+      ciNamespace = NoNamespace     },      checkWriteFail "bad namespace" $ CategoryIdentifier {       ciPath = "/home/project/special",-      ciCategory = "bad namespace",-      ciNamespace = "SpecialCategory"+      ciCategory = CategoryName "SpecialCategory",+      ciNamespace = StaticNamespace "bad namespace"     },      checkWriteFail "bad category" $ UnresolvedCategory {-      ucCategory = "bad category"+      ucCategory = CategoryName "bad category"     },      checkWriteThenRead $ CompileBinary {-      cbCategory = "SpecialCategory",-      cbFunction = "specialFunction",+      cbCategory = CategoryName "SpecialCategory",+      cbFunction = FunctionName "specialFunction",       cbOutputName = "binary",       cbLinkFlags = []     },      checkWriteFail "bad category" $ CompileBinary {-      cbCategory = "bad category",-      cbFunction = "specialFunction",+      cbCategory = CategoryName "bad category",+      cbFunction = FunctionName "specialFunction",       cbOutputName = "binary",       cbLinkFlags = []     },      checkWriteFail "bad function" $ CompileBinary {-      cbCategory = "SpecialCategory",-      cbFunction = "bad function",+      cbCategory = CategoryName "SpecialCategory",+      cbFunction = FunctionName "bad function",       cbOutputName = "binary",       cbLinkFlags = []     },      checkWriteFail "compile mode" $ CompileFast {-      cfCategory = "SpecialCategory",-      cfFunction = "specialFunction",+      cfCategory = CategoryName "SpecialCategory",+      cfFunction = FunctionName "specialFunction",       cfSource = "source.0rx"     }, 

@@ -0,0 +1,102 @@+{- -----------------------------------------------------------------------------+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 Test.Pragma (tests) where++import Control.Monad (when)+import Text.Parsec+import Text.Parsec.String+import Text.Regex.TDFA -- Not safe!++import Base.CompileError+import Compilation.CompileInfo+import Parser.Pragma+import Test.Common+import Types.Pragma+++tests :: [IO (CompileInfo ())]+tests = [+    checkParsesAs "$ModuleOnly$" (fmap (:[]) pragmaModuleOnly)+      (\e -> case e of+                  [PragmaVisibility _ ModuleOnly] -> True+                  _ -> False),++    checkParsesAs "$TestsOnly$" (fmap (:[]) pragmaTestsOnly)+      (\e -> case e of+                  [PragmaVisibility _ TestsOnly] -> True+                  _ -> False),++    checkParsesAs "$Comment[ \"this is a pragma with args\" ]$" (fmap (:[]) pragmaComment)+      (\e -> case e of+                  [PragmaComment _ "this is a pragma with args"] -> True+                  _ -> False),++    checkParsesAs "/*only comments*/" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly])+      (\e -> case e of+                  [] -> True+                  _ -> False),++    checkParsesAs "$ModuleOnly$  // comment" (parsePragmas [pragmaTestsOnly,pragmaModuleOnly])+      (\e -> case e of+                  [PragmaVisibility _ ModuleOnly] -> True+                  _ -> False),++    checkParsesAs "$TestsOnly$  /*comment*/" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly])+      (\e -> case e of+                  [PragmaVisibility _ TestsOnly] -> True+                  _ -> False),++    checkParsesAs "$TestsOnly$\n$TestsOnly$\n$ModuleOnly$" (parsePragmas [pragmaModuleOnly,pragmaTestsOnly])+      (\e -> case e of+                  [PragmaVisibility _ TestsOnly,+                   PragmaVisibility _ TestsOnly,+                   PragmaVisibility _ ModuleOnly] -> True+                  _ -> False),++    checkParseError "$ModuleOnly[ extra ]$" "does not allow arguments" pragmaModuleOnly,++    checkParseError "$TestsOnly[ extra ]$" "does not allow arguments" pragmaTestsOnly,++    checkParseError "$Comment$" "requires arguments" pragmaComment+  ]++checkParsesAs :: String -> Parser [Pragma SourcePos] -> ([Pragma SourcePos] -> Bool) -> IO (CompileInfo ())+checkParsesAs s p m = return $ do+  let parsed = readSingleWith p "(string)" s+  check parsed+  e <- parsed+  when (not $ m e) $+    compileError $ "No match in '" ++ s ++ "':\n" ++ show e+  where+    check c+      | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c)+      | otherwise = return ()++checkParseError :: String -> String -> Parser (Pragma SourcePos) -> IO (CompileInfo ())+checkParseError s m p = return $ do+  let parsed = readSingleWith p "(string)" s+  check parsed+  where+    check c+      | isCompileError c = do+          let text = show (getCompileError c)+          when (not $ text =~ m) $+            compileError $ "Expected pattern " ++ show m ++ " in error output but got\n" ++ text+      | otherwise =+          compileError $ "Expected write failure but got\n" ++ show (getCompileSuccess c)

@@ -439,7 +439,7 @@       | otherwise = compileError $ "Parse '" ++ s ++ "': Expected failure but got\n" ++                                    show (getCompileSuccess c) ++ "\n" -checkParsesAs :: [Char] -> (Expression SourcePos -> Bool) -> IO (CompileInfo ())+checkParsesAs :: String -> (Expression SourcePos -> Bool) -> IO (CompileInfo ()) checkParsesAs s m = return $ do   let parsed = readSingle "(string)" s :: CompileInfo (Expression SourcePos)   check parsed

@@ -0,0 +1,46 @@+{- -----------------------------------------------------------------------------+Copyright 2020 Kevin P. Barry++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+----------------------------------------------------------------------------- -}++-- Author: Kevin P. Barry [ta0kira@gmail.com]++{-# LANGUAGE Safe #-}++module Test.SourceFile (tests) where++import System.FilePath++import Base.CompileError+import Compilation.CompileInfo+import Parser.SourceFile+import Test.Common+++tests :: [IO (CompileInfo ())]+tests = [+    checkParseSuccess ("testfiles" </> "public.0rp")   parsePublicSource,+    checkParseSuccess ("testfiles" </> "internal.0rx") parseInternalSource,+    checkParseSuccess ("testfiles" </> "test.0rt")     parseTestSource+  ]++checkParseSuccess :: String -> ((FilePath,String) -> CompileInfo a) -> IO (CompileInfo ())+checkParseSuccess f p = do+  contents <- loadFile f+  let parsed = p (f,contents)+  return $ check parsed+  where+    check c+      | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c)+      | otherwise = return ()

@@ -0,0 +1,5 @@+$TestsOnly$++concrete Type {}++define Type {}

@@ -0,0 +1,4 @@+$ModuleOnly$+$TestsOnly$++concrete Type {}

@@ -0,0 +1,11 @@+testcase "test" {+  success Test$run()+}++concrete Test {+  @type run () -> ()+}++define Test {+  run () {}+}

@@ -165,7 +165,7 @@ mergeInternalInheritance tm d = do   let rs2 = dcRefines d   let ds2 = dcDefines d-  (_,t@(ValueConcrete c ns n ps rs ds vs fs)) <- getConcreteCategory tm ([],dcName d)+  (_,t@(ValueConcrete c ns n ps rs ds vs fs)) <- getConcreteCategory tm (dcContext d,dcName d)   let c2 = ValueConcrete c ns n ps (rs++rs2) (ds++ds2) vs fs   let tm' = Map.insert (dcName d) c2 tm   let r = CategoryResolver tm'

@@ -0,0 +1,54 @@+{- -----------------------------------------------------------------------------+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 Types.Pragma (+  CodeVisibility(..),+  Pragma(..),+  getPragmaContext,+  isModuleOnly,+  isTestsOnly,+) where+++data CodeVisibility = ModuleOnly | TestsOnly deriving (Show)++data Pragma c =+  PragmaVisibility {+    pvContext :: [c],+    pvScopes :: CodeVisibility+  } |+  -- This is mostly for testing purposes.+  PragmaComment {+    pcContext :: [c],+    pcComment :: String+  }+  deriving (Show)++getPragmaContext :: Pragma c -> [c]+getPragmaContext (PragmaVisibility c _) = c+getPragmaContext (PragmaComment c _)    = c++isModuleOnly :: Pragma c -> Bool+isModuleOnly (PragmaVisibility _ ModuleOnly) = True+isModuleOnly _                               = False++isTestsOnly :: Pragma c -> Bool+isTestsOnly (PragmaVisibility _ TestsOnly) = True+isTestsOnly _                              = False

@@ -1,6 +1,6 @@ root: ".." path: "tests"-public_deps: [+private_deps: [   "visibility"   "visibility2" ]

@@ -20,6 +20,8 @@  set -e -u +PROGRAM=$(basename "$0")+ if [ $# -lt 1 ]; then   echo "$0: Pass the command to execute the zeolite CLI." 1>&2   exit 1@@ -27,8 +29,12 @@  ZEOLITE=("$@") +show_message() {+  echo -e "[$PROGRAM]" "$@" 1>&2+}+ execute() {-  echo "Executing:" $(printf ' %q' "$@") 1>&2+  show_message "Executing:" $(printf ' %q' "$@")   "$@" 2>&1 } @@ -36,24 +42,57 @@   execute "${ZEOLITE[@]}" "$@" } -ZEOLITE_PATH=$(do_zeolite --get-path | grep '^/')+create_file() {+  show_message "Creating file $1"+  cat > "$1"+}   test_check_defs() {   local output=$(do_zeolite -p "$ZEOLITE_PATH" -r tests/check-defs || true)-  if ! echo "$output" | egrep -q "Type .+ is defined 2 times"; then-    echo 'Expected Type definition error from tests/check-defs:' 1>&2+  if ! echo "$output" | egrep -q 'Type .+ is defined 2 times'; then+    show_message 'Expected Type definition error from tests/check-defs:'     echo "$output" 1>&2     return 1   fi-  if ! echo "$output" | egrep -q "Undefined .+ has not been defined"; then-    echo 'Expected Undefined definition error from tests/check-defs:' 1>&2+  if ! echo "$output" | egrep -q 'Undefined .+ has not been defined'; then+    show_message 'Expected Undefined definition error from tests/check-defs:'     echo "$output" 1>&2     return 1   fi }  +test_tests_only() {+  local output=$(do_zeolite -p "$ZEOLITE_PATH" -r tests/tests-only || true)+  if ! echo "$output" | egrep -q 'Definition for Type1 .+ visible category'; then+    show_message 'Expected Type1 definition error from tests/tests-only:'+    echo "$output" 1>&2+    return 1+  fi+  if echo "$output" | egrep -q 'Type2'; then+    show_message 'Unexpected Type2 definition error from tests/tests-only:'+    echo "$output" 1>&2+    return 1+  fi+}+++test_module_only() {+  local output=$(do_zeolite -p "$ZEOLITE_PATH" -R tests/module-only || true)+  if ! echo "$output" | egrep -q 'Type1 not found'; then+    show_message 'Expected Type1 definition error from tests/module-only:'+    echo "$output" 1>&2+    return 1+  fi+  if echo "$output" | egrep -q 'Type2 not found'; then+    show_message 'Unexpected Type2 definition error from tests/module-only:'+    echo "$output" 1>&2+    return 1+  fi+}++ test_templates() {   execute rm -f $ZEOLITE_PATH/tests/templates/Category_Templated.cpp   do_zeolite -p "$ZEOLITE_PATH" --templates tests/templates@@ -66,7 +105,7 @@   local temp=$(execute mktemp -d)   local category='HelloWorld'   local file="$temp/hello-world.0rx"-  cat > "$file" <<END+  create_file "$file" <<END // $file  concrete $category {@@ -84,28 +123,78 @@   do_zeolite -i lib/util --fast $category "$file"   local output=$(execute "$PWD/$category")   if ! echo "$output" | fgrep -xq 'Hello World'; then-    echo 'Expected "Hello World" in program output:' 1>&2+    show_message 'Expected "Hello World" in program output:'     echo "$output" 1>&2     return 1   fi+  execute rm -r "$temp" "$PWD/$category" || true }  +test_bad_system_include() {+  local temp=$(execute mktemp -d)+  local prev=$PWD+  execute cd "$temp"+  local output=$(do_zeolite -i lib/../tests -c "$temp" || true)+  execute cd "$prev"+  if ! echo "$output" | egrep -q 'Could not find .+tests'; then+    show_message 'Expected error finding "tests":'+    echo "$output" 1>&2+    return 1+  fi+  execute rm -r "$temp" || true+}+++test_global_include() {+  local global="$ZEOLITE_PATH/global-paths"+  if [ -f "$global" ]; then+    show_message "Skipping test that overwrites existing $global."+    return 0+  fi+  local temp0=$(execute mktemp -d)+  execute mkdir "$temp0/fakedep"+  do_zeolite -p "$temp0" -c 'fakedep'+  create_file "$global" <<< "$temp0"+  local temp=$(execute mktemp -d)+  local prev=$PWD+  execute cd "$temp"+  do_zeolite -i fakedep -c "$temp" || { execute cd "$prev"; execute rm "$global"; return 1; }+  execute cd "$prev"+  execute rm -r "$temp0" "$temp" "$global" || true+}++ run_all() {+  ZEOLITE_PATH=$(do_zeolite --get-path | grep '^/')+  echo 1>&2   local failed=0   for t in "$@"; do-    echo -e "Testing $t >>>\n" 1>&2+    show_message "Testing $t >>>"+    echo 1>&2     if ! "$t"; then       failed=1     fi-    echo -e "\n<<< Testing $t\n" 1>&2+    echo 1>&2+    show_message "<<< Testing $t"+    echo 1>&2   done   if (($failed)); then-    echo 'One or more tests failed.' 1>&2+    show_message 'One or more tests failed.'     return 1   else-    echo 'All tests passed.' 1>&2+    show_message 'All tests passed.'   fi } -run_all test_check_defs test_templates test_fast 1>&2+ALL_TESTS=(+  test_check_defs+  test_tests_only+  test_module_only+  test_templates+  test_fast+  test_bad_system_include+  test_global_include+)++run_all "${ALL_TESTS[@]}" 1>&2

@@ -16,6 +16,8 @@  // Author: Kevin P. Barry [ta0kira@gmail.com] +$TestsOnly$+ concrete Testing {   @type check<#x>     #x requires Formatted

@@ -16,6 +16,8 @@  // Author: Kevin P. Barry [ta0kira@gmail.com] +$TestsOnly$+ define Testing {   check (x,y) {     if (!#x$equals(x,y)) {

@@ -0,0 +1,21 @@+/* -----------------------------------------------------------------------------+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]++$ModuleOnly$++@value interface ModuleOnly {}

@@ -0,0 +1,6 @@+root: "../.."+path: "tests/module-only"+private_deps: [+  "internal"+]+mode: incremental {}

@@ -0,0 +1,20 @@+# `$ModuleOnly$` Pragma Test++Compiling this module should **always fail**. It tests that the `$ModuleOnly$`+pragma limits visibility to only `.0rx` and `.0rt` sources in the same module,+and `.0rp` sources in the same module that also have the `$ModuleOnly$` pragma.++To compile:++```shell+ZEOLITE_PATH=$(zeolite --get-path)+zeolite -p $ZEOLITE_PATH -R tests/module-only+```++The compiler errors should look something like this:++```text+Compiler errors:+In creation of val1 at "tests/module-only/private.0rx" (line 22, column 3)+  Type Type1 not found+```

@@ -0,0 +1,3 @@+root: "../../.."+path: "tests/module-only/internal"+mode: incremental {}

@@ -0,0 +1,21 @@+/* -----------------------------------------------------------------------------+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]++$ModuleOnly$++@value interface Type1 {}

@@ -0,0 +1,19 @@+/* -----------------------------------------------------------------------------+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]++@value interface Type2 {}

@@ -0,0 +1,24 @@+/* -----------------------------------------------------------------------------+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]++concrete Test {}++define Test {+  @value Type1 val1+  @value Type2 val2+}

@@ -826,3 +826,79 @@ concrete Test {   @type run () -> () }+++testcase "reduce from interface" {+  success Test$run()+}++@value interface Base0 {+}++@value interface Base1 {+  refines Base0+}++concrete Value {+  refines Base1+  @type create () -> (Value)+}++define Value {+  create () {+    return Value{ }+  }+}++define Test {+  run () {+    if (!present(reduce<Base1,Base0>(Value$create()))) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "reduce with internal override" {+  success Test$run()+}++@value interface Base0 {}++@value interface Base1 {+  refines Base0+}++@value interface Base2<|#x> {}++concrete Value {+  refines Base2<Base0>+  @type create () -> (Value)+}++define Value {+  refines Base2<Base1>++  create () {+    return Value{ }+  }+}++define Test {+  run () {+    if (!present(reduce<Value,Base2<Base0>>(Value$create()))) {+      fail("Failed")+    }+    if (present(reduce<Value,Base2<Base1>>(Value$create()))) {+      fail("Failed")+    }+  }+}++concrete Test {+  @type run () -> ()+}

@@ -105,3 +105,18 @@     \ Type<Type<Type<Int>>>$call()   } }+++testcase "ModuleOnly is visible to tests" {+  success Test$execute()+}++concrete Test {+  @type execute () -> ()+}++define Test {+  execute () {+    optional ModuleOnly value <- empty+  }+}

@@ -0,0 +1,3 @@+root: "../.."+path: "tests/tests-only"+mode: incremental {}

@@ -0,0 +1,19 @@+# `$TestsOnly$` Pragma Test++Compiling this module should **always fail**. It tests that the `$TestsOnly$`+pragma limits visibility to only `.0rx` sources that also have the `$TestsOnly$`+pragma, as well as all `.0rt` sources.++To compile:++```shell+ZEOLITE_PATH=$(zeolite --get-path)+zeolite -p $ZEOLITE_PATH -r tests/tests-only+```++The compiler errors should look something like this:++```text+Compiler errors:+Definition for Type1 ["tests/tests-only/private.0rx" (line 19, column 1)] does not correspond to a visible category in this module+```

@@ -0,0 +1,21 @@+/* -----------------------------------------------------------------------------+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]++define Type1 {}++define Type2 {}

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

@@ -0,0 +1,19 @@+/* -----------------------------------------------------------------------------+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]++concrete Type2 {}

@@ -1,7 +1,7 @@ cabal-version:       2.2  name:                zeolite-lang-version:             0.4.1.1+version:             0.5.0.0 synopsis:            Zeolite is a statically-typed, general-purpose programming language.  description:@@ -60,6 +60,7 @@                      GHC == 8.0.2  extra-source-files:  ChangeLog.md,+                     src/Test/testfiles/*.0rp,                      src/Test/testfiles/*.0rt,                      src/Test/testfiles/*.0rx @@ -101,10 +102,19 @@                      tests/check-defs/.zeolite-module,                      tests/check-defs/*.0rp,                      tests/check-defs/*.0rx,+                     tests/module-only/README.md,+                     tests/module-only/.zeolite-module,+                     tests/module-only/*.0rx,+                     tests/module-only/internal/.zeolite-module,+                     tests/module-only/internal/*.0rp,                      tests/templates/README.md,                      tests/templates/.zeolite-module,                      tests/templates/*.0rp,                      tests/templates/*.0rt,+                     tests/tests-only/README.md,+                     tests/tests-only/.zeolite-module,+                     tests/tests-only/*.0rp,+                     tests/tests-only/*.0rx,                      tests/visibility/.zeolite-module,                      tests/visibility/*.0rp,                      tests/visibility/*.0rx,@@ -137,6 +147,7 @@                        Cli.ParseCompileOptions,                        Cli.ParseMetadata,                        Cli.ProcessMetadata,+                       Cli.RunCompiler,                        Cli.TestRunner,                        Compilation.CompileInfo,                        Compilation.CompilerState,@@ -153,6 +164,7 @@                        Parser.Common,                        Parser.DefinedCategory,                        Parser.IntegrationTest,+                       Parser.Pragma,                        Parser.Procedure,                        Parser.SourceFile,                        Parser.TypeCategory,@@ -162,7 +174,9 @@                        Test.IntegrationTest,                        Test.ParseMetadata,                        Test.Parser,+                       Test.Pragma,                        Test.Procedure,+                       Test.SourceFile,                        Test.TypeCategory,                        Test.TypeInstance,                        Types.Builtin,@@ -171,6 +185,7 @@                        Types.GeneralType,                        Types.IntegrationTest,                        Types.Positional,+                       Types.Pragma,                        Types.Procedure,                        Types.TypeCategory,                        Types.TypeInstance,