zeolite-lang 0.22.0.0 → 0.22.1.0

raw patch · 51 files changed

+1512/−454 lines, 51 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +44/−0
• base/src/boxed.cpp +4/−4
• bin/zeolite-setup.hs +25/−18
• bin/zeolite.hs +2/−1
• example/parser/test-data.0rx +1/−7
• lib/container/interfaces.0rp +14/−0
• lib/container/queue.0rp +28/−0
• lib/container/src/auto-tree.0rx +2/−2
• lib/container/src/queue.0rx +71/−0
• lib/container/src/sorting.0rx +1/−1
• lib/container/src/type-map.0rx +2/−2
• lib/container/src/wrappers.0rx +1/−1
• lib/container/test/queue.0rt +52/−0
• lib/math/src/random.0rx +2/−2
• lib/math/src/token.0rx +1/−1
• lib/util/extra.0rp +16/−0
• lib/util/src/counters.0rx +1/−1
• lib/util/src/extra.0rx +34/−4
• lib/util/test/extra.0rt +44/−0
• src/Cli/CompileOptions.hs +43/−24
• src/Cli/Compiler.hs +56/−30
• src/Cli/ParseCompileOptions.hs +75/−61
• src/Cli/Programs.hs +34/−1
• src/Cli/RunCompiler.hs +24/−18
• src/Cli/TestRunner.hs +1/−1
• src/Compilation/ProcedureContext.hs +8/−8
• src/Compilation/ScopeContext.hs +27/−3
• src/CompilerCxx/Code.hs +0/−4
• src/CompilerCxx/CxxFiles.hs +129/−95
• src/CompilerCxx/LanguageModule.hs +27/−22
• src/Config/LocalConfig.hs +73/−20
• src/Module/CompileMetadata.hs +15/−2
• src/Module/ParseMetadata.hs +50/−11
• src/Module/ProcessMetadata.hs +8/−0
• src/Parser/DefinedCategory.hs +5/−1
• src/Test/ParseMetadata.hs +27/−2
• src/Test/testfiles/module-config.txt +12/−0
• src/Types/DefinedCategory.hs +32/−4
• src/Types/TypeCategory.hs +15/−11
• tests/.zeolite-module +15/−0
• tests/Extension_Extension.cpp +80/−0
• tests/cli-tests.sh +22/−16
• tests/extension.0rp +23/−0
• tests/extension.0rt +25/−0
• tests/function-calls.0rt +112/−72
• tests/internal-inheritance.0rt +73/−1
• tests/leak-check/leak-check.0rx +1/−1
• tests/local-rules.0rt +98/−0
• tests/reduce.0rt +51/−0
• tests/simulate-refs/routines.0rx +1/−1
• zeolite-lang.cabal +5/−1

@@ -1,5 +1,49 @@ # Revision history for zeolite-lang +## 0.22.1.0  -- 2022-04-18++### Language++* **[fix]** Fixes checking of parameter variances in the context of internal+  inheritance.++* **[fix]** Fixes regression in inheritance of interfaces where the specified+  params contain unions or intersections, e.g., `refines Foo<[Bar&Baz]>`.++* **[new]** Adds the `$ReadOnlyExcept[...]$` `define` pragma to protect all+  members except those specified.++### Libraries++* **[new]** Adds the `AlwaysEmpty` empty container to `lib/util`.++* **[new]** Adds the `Queue<#x>` `@value interface` and the `SimpleQueue<#x>`+  container to `lib/container`.++### Compiler CLI++* **[fix]** Fixes bug where `extra_files` listed in `.zeolite-module` would fail+  to compile if the module contained no public categories.++* **[new]** Adds the `-j `*`[# parallel]`* flag to `zeolite` to execute+  compilation of C++ files in parallel.++* **[new]** Allows C++ extensions to specify internal inheritance in+  `.zeolite-module`. This is necessary if the implementation needs to pass+  `PARAM_SELF` or `VAR_SELF` as a parent type that is not publicly visible.++  ```text+  // Assumes that Foo is also mentioned in extra_files:.+  extension_specs: [+    category {+      // For Foo<#x>. Do not include the params here.+      name: Foo+      refines: [Bar<#x>]+      defines: [Baz<#x>]+    }+  ]+  ```+ ## 0.22.0.0  -- 2021-12-11  ### Libraries

@@ -28,16 +28,16 @@ #endif  // ZEOLITE_PUBLIC_NAMESPACE  ReturnTuple DispatchBool(PrimBool value, const ValueFunction& label,-                         const ParamsArgs& params_args);+                         const ParamsArgs& params_args) __attribute__((weak));  ReturnTuple DispatchChar(PrimChar value, const ValueFunction& label,-                         const ParamsArgs& params_args);+                         const ParamsArgs& params_args) __attribute__((weak));  ReturnTuple DispatchInt(PrimInt value, const ValueFunction& label,-                        const ParamsArgs& params_args);+                        const ParamsArgs& params_args) __attribute__((weak));  ReturnTuple DispatchFloat(PrimFloat value, const ValueFunction& label,-                          const ParamsArgs& params_args);+                          const ParamsArgs& params_args) __attribute__((weak));  #ifdef ZEOLITE_PUBLIC_NAMESPACE }  // namespace ZEOLITE_PUBLIC_NAMESPACE

@@ -33,11 +33,17 @@   main :: IO ()-main = tryTrackedErrorsIO "" "Zeolite setup failed:" (lift getArgs >>= handle) where-  handle ("--reuse":_) = do+main = tryTrackedErrorsIO "" "Zeolite setup failed:" (lift getArgs >>= handle 1) where+  handle _ ("-j":k:os) = do+    case reads k of+          [(pn,[])] -> if pn > 0+                          then handle pn os+                          else compilerErrorM "Parallel processes (-j) must be > 0."+          _ -> compilerErrorM "Parallel processes (-j) must be > 0."+  handle pn ("--reuse":_) = do     config <- loadConfig-    runWith config-  handle args = do+    runWith pn config+  handle pn args = do     let (cxxSpec:arSpec:_) = (map Just $ args) ++ repeat Nothing     f <- lift $ localConfigPath     isFile <- lift $ doesFileExist f@@ -45,9 +51,9 @@       lift $ hPutStrLn stderr $ "*** WARNING: Local config " ++ f ++ " will be overwritten. ***"     config <- lift $ createConfig cxxSpec arSpec     saveConfig config-    runWith config-  runWith config = do-    initLibraries config+    runWith pn config+  runWith pn config = do+    initLibraries pn config     lift $ hPutStrLn stderr "Setup is now complete!"  clangBinary :: String@@ -152,19 +158,20 @@     exitFailure   hGetLine stdin -initLibraries :: (Resolver,Backend) -> TrackedErrorsIO ()-initLibraries (resolver,backend) = do+initLibraries :: Int -> (Resolver,Backend) -> TrackedErrorsIO ()+initLibraries pn (resolver,backend) = do   path <- lift $ rootPath >>= canonicalizePath   let options = CompileOptions {-      coHelp = HelpNotNeeded,-      coPublicDeps = [],-      coPrivateDeps = [],-      coPaths = libraries,-      coExtraFiles = [],-      coExtraPaths = [],-      coSourcePrefix = path,-      coMode = CompileRecompileRecursive,-      coForce = ForceAll+      _coHelp = HelpNotNeeded,+      _coPublicDeps = [],+      _coPrivateDeps = [],+      _coPaths = libraries,+      _coExtraFiles = [],+      _coExtraPaths = [],+      _coSourcePrefix = path,+      _coMode = CompileRecompileRecursive,+      _coForce = ForceAll,+      _coParallel = pn     }   runCompiler resolver backend options   mapM_ optionalWarning optionalLibraries where

@@ -52,9 +52,10 @@           hPutStrLn stderr "Use the -h option to show help."           exitFailure       | otherwise = tryZeoliteIO $ do+          asCompilerWarnings co           let co' = getCompilerSuccess co           (resolver,backend) <- loadConfig-          when (HelpNotNeeded /= (coHelp co')) $ errorFromIO $ showHelp >> exitFailure+          when (HelpNotNeeded /= (_coHelp co')) $ errorFromIO $ showHelp >> exitFailure           tryCloseStdin           runCompiler resolver backend co' 

@@ -24,13 +24,7 @@  define TestDataParser {   // Mark @category members as read-only, to avoid accidental assignment.-  $ReadOnly[sentenceOrToken,-            acronymOrAardvark,-            fileStart,-            fileEnd,-            nameTag,-            descriptionTag,-            aWordTag]$+  $ReadOnlyExcept[]$    // Mark @category members as hidden, since they should not be used directly.   $Hidden[whitespace,

@@ -29,6 +29,20 @@   pop () -> (#x) } +// Container with queue semantics.+//+// Params:+// - #x: The value type to stack.+@value interface Queue<#x> {+  refines Container++  // Pushes a new value and returns self.+  push (#x) -> (#self)++  // Pops the top value. Crashes if empty. (Check size() before calling.)+  pop () -> (#x)+}+ // Writing to key-value storage. // // Params:

@@ -0,0 +1,28 @@+/* -----------------------------------------------------------------------------+Copyright 2021 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]++// Simple queue implementation.+concrete SimpleQueue<#x> {+  defines Default+  refines Append<#x>+  refines Queue<#x>+  refines Duplicate++  // Create an empty SimpleQueue.+  @type new () -> (#self)+}

@@ -248,7 +248,7 @@ }  define ForwardTreeOrder {-  $ReadOnly[node,prev]$+  $ReadOnlyExcept[]$    @value BinaryTreeNode<#k,#v> node   @value optional ForwardTreeOrder<#k,#v> prev@@ -297,7 +297,7 @@ }  define ReverseTreeOrder {-  $ReadOnly[node,prev]$+  $ReadOnlyExcept[]$    @value BinaryTreeNode<#k,#v> node   @value optional ReverseTreeOrder<#k,#v> prev

@@ -0,0 +1,71 @@+/* -----------------------------------------------------------------------------+Copyright 2021 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 SimpleQueue {+  @value Int size+  @value optional ForwardNode<#x> head+  @value optional ForwardNode<#x> tail++  new () {+    return #self{ 0, empty, empty }+  }++  default () {+    return new()+  }++  duplicate () {+    $ReadOnly[size,head]$+    $Hidden[tail]$+    scoped {+      optional ForwardNode<#x> head2, optional ForwardNode<#x> tail2 <-+        (head `OrderH:copyTo` ForwardNode<#x>.builder()).build()+    } in return #self{ size, head2, tail2 }+  }++  append (x) {+    return push(x)+  }++  push (x) {+    scoped {+      ForwardNode<#x> node <- ForwardNode<#x>.newNode(x)+    } in if (`present` tail) {+      \ require(tail).setNext(node)+      tail <- node+    } else {+      head <- (tail <- node)+    }+    size <- size+1+    return self+  }++  pop () {+    cleanup {+      head <- require(head).next()+      if (! `present` head) {+        tail <- empty+      }+      size <- size-1+    } in return require(head).get()+  }++  size () {+    return size+  }+}

@@ -84,7 +84,7 @@ }  define HeapSort {-  $ReadOnly[seq,compare]$+  $ReadOnlyExcept[]$    @value [ReadAt<#x>&WriteAt<#x>] seq   @value LessThan2<#x> compare

@@ -64,7 +64,7 @@ }  define TypeKey {-  $ReadOnly[counterMutex,index]$+  $ReadOnlyExcept[counter]$    @category Mutex counterMutex <- SpinlockMutex.new()   @category Int   counter      <- 0@@ -111,7 +111,7 @@ }  define GenericValue {-  $ReadOnly[value]$+  $ReadOnlyExcept[]$    @value #x value 

@@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com]  define SimpleKeyValue {-  $ReadOnly[key,value]$+  $ReadOnlyExcept[]$    refines KeyValue<#k,#v> 

@@ -0,0 +1,52 @@+/* -----------------------------------------------------------------------------+Copyright 2021 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]++testcase "SimpleQueue tests" {+  success+}++unittest integrationTest {+  Int max <- 13+  $ReadOnly[max]$+  SimpleQueue<Int> queue <- SimpleQueue<Int>.default()+  traverse (`Counter.zeroIndexed` max -> Int value) {+    \ Testing.checkEquals(queue.size(),value)+    \ queue.append(value)+  }+  traverse (`Counter.zeroIndexed` max -> Int value) {+    \ Testing.checkEquals(queue.size(),max-value)+    \ Testing.checkEquals(queue.pop(),value)+  }+  \ Testing.checkEquals(queue.size(),0)+}++unittest duplicate {+  Int max <- 13+  $ReadOnly[max]$+  SimpleQueue<Int> queue <- `Counter.zeroIndexed` max `OrderH:copyTo` SimpleQueue<Int>.new()+  SimpleQueue<Int> copy <- queue.duplicate()+  \ queue.pop()+  \ queue.pop()+  \ queue.pop()+  $Hidden[queue]$+  traverse (`Counter.zeroIndexed` max -> Int value) {+    \ Testing.checkEquals(copy.size(),max-value)+    \ Testing.checkEquals(copy.pop(),value)+  }+  \ Testing.checkEquals(copy.size(),0)+}

@@ -41,7 +41,7 @@ }  define GenerateConstant {-  $ReadOnly[constant]$+  $ReadOnlyExcept[]$    @value Float constant @@ -55,7 +55,7 @@ }  define RandomCategorical {-  $ReadOnly[categorical,random]$+  $ReadOnlyExcept[]$    @value CategoricalReader<#c> categorical   @value Generator<Float> random

@@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com]  define Token {-  $ReadOnly[mutex,toToken]$+  $ReadOnlyExcept[counter]$    @category Mutex mutex <- SpinlockMutex.new()   @category HashedMap<String,Token> toToken <- HashedMap<String,Token>.new()

@@ -32,6 +32,22 @@   refines Hashed } +// A container that is always empty.+//+// Notes:+// - Get the AlwaysEmpty value using AlwaysEmpty.default().+// - readAt and writeAt will always fail, but most use-cases will check the size+//   before calling either.+concrete AlwaysEmpty {+  immutable+  defines Default+  refines Container+  refines DefaultOrder<all>+  refines Duplicate+  refines ReadAt<all>+  refines WriteAt<any>+}+ // Contains either a value or an error message. // // Params:

@@ -119,7 +119,7 @@ }  define Repeat {-  $ReadOnly[limit,value]$+  $ReadOnlyExcept[current]$    refines Order<#x> 

@@ -1,5 +1,5 @@ /* ------------------------------------------------------------------------------Copyright 2019-2021 Kevin P. Barry+Copyright 2019-2022 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.@@ -44,6 +44,34 @@   } } +define AlwaysEmpty {+  @category AlwaysEmpty singleton <- AlwaysEmpty{ }++  default () {+    return singleton+  }++  size () {+    return 0+  }++  duplicate () {+    return singleton+  }++  defaultOrder () {+    return empty+  }++  readAt (_) {+    fail("container is always empty")+  }++  writeAt (_,_) {+    fail("container is always empty")+  }+}+ define ErrorOr {   @value optional #x maybeValue   @value optional Formatted maybeError@@ -73,10 +101,12 @@   }    convertError () {-    if (!present(maybeError)) {-      fail("no error present to convert")+    scoped {+      optional ErrorOr<all> error <- reduce<#self,ErrorOr<all>>(self)+    } in if (present(error)) {+      return require(error)     } else {-      return ErrorOr<all>{ empty, maybeError }+      fail("no error present to convert")     }   } }

@@ -136,3 +136,47 @@ unittest hashed {   \ Testing.checkEquals(Void.default().duplicate().hashed(),Void.default().hashed()) }+++testcase "AlwaysEmpty tests" {+  success+}++unittest conversions {+  ReadAt<Int>  read  <- AlwaysEmpty.default()+  WriteAt<Int> write <- AlwaysEmpty.default()+}++unittest size {+  \ Testing.checkEquals(AlwaysEmpty.default().size(),0)+}++unittest duplicate {+  \ Testing.checkEquals(AlwaysEmpty.default().duplicate().size(),0)+}++unittest defaultOrder {+  traverse (AlwaysEmpty.default().defaultOrder() -> _) {+    fail("expected empty")+  }+}+++testcase "AlwaysEmpty.readAt fails" {+  crash+  require "empty"+}++unittest readAt {+  \ AlwaysEmpty.default().readAt(0)+}+++testcase "AlwaysEmpty.writeAt fails" {+  crash+  require "empty"+}++unittest readAt {+  \ AlwaysEmpty.default().writeAt(0,123)+}

@@ -16,7 +16,8 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}  module Cli.CompileOptions (   CompileOptions(..),@@ -38,38 +39,39 @@   isCreateTemplates,   isExecuteTests,   maybeDisableHelp,+  -- Generated by Lens >>>+  coExtraFiles,+  coExtraPaths,+  coForce,+  coHelp,+  coMode,+  coParallel,+  coPaths,+  coPrivateDeps,+  coPublicDeps,+  coSourcePrefix,+  -- Generated by Lens <<< ) where +import Lens.Micro.TH (makeLenses)+ import Types.TypeCategory (FunctionName) import Types.TypeInstance (CategoryName)  -data CompileOptions =-  CompileOptions {-    coHelp :: HelpMode,-    coPublicDeps :: [FilePath],-    coPrivateDeps :: [FilePath],-    coPaths :: [FilePath],-    coExtraFiles :: [ExtraSource],-    coExtraPaths :: [FilePath],-    coSourcePrefix :: FilePath,-    coMode :: CompileMode,-    coForce :: ForceMode-  }-  deriving (Show)- emptyCompileOptions :: CompileOptions emptyCompileOptions =   CompileOptions {-    coHelp = HelpUnspecified,-    coPublicDeps = [],-    coPrivateDeps = [],-    coPaths = [],-    coExtraFiles = [],-    coExtraPaths = [],-    coSourcePrefix = "",-    coMode = CompileUnspecified,-    coForce = DoNotForce+    _coHelp = HelpUnspecified,+    _coPublicDeps = [],+    _coPrivateDeps = [],+    _coPaths = [],+    _coExtraFiles = [],+    _coExtraPaths = [],+    _coSourcePrefix = "",+    _coMode = CompileUnspecified,+    _coForce = DoNotForce,+    _coParallel = 0   }  data ExtraSource =@@ -164,3 +166,20 @@ getLinkFlags (CompileBinary _ _ _ _ lf) = lf getLinkFlags (CompileIncremental lf)    = lf getLinkFlags _                          = []++data CompileOptions =+  CompileOptions {+    _coHelp :: HelpMode,+    _coPublicDeps :: [FilePath],+    _coPrivateDeps :: [FilePath],+    _coPaths :: [FilePath],+    _coExtraFiles :: [ExtraSource],+    _coExtraPaths :: [FilePath],+    _coSourcePrefix :: FilePath,+    _coMode :: CompileMode,+    _coForce :: ForceMode,+    _coParallel :: Int+  }+  deriving (Show)++$(makeLenses ''CompileOptions)

@@ -24,6 +24,7 @@   runModuleTests, ) where +import Control.Arrow (first) import Control.Monad (foldM,when) import Data.Either (partitionEithers) import Data.List (isSuffixOf,nub,sort)@@ -66,9 +67,11 @@     msPrivateFiles :: [FilePath],     msTestFiles :: [FilePath],     msExtraFiles :: [ExtraSource],+    msCategories :: [(CategoryName,CategorySpec SourceContext)],     msExtraPaths :: [FilePath],     msMode :: CompileMode,-    msForce :: ForceMode+    msForce :: ForceMode,+    msParallel :: Int   }   deriving (Show) @@ -82,7 +85,7 @@   deriving (Show)  compileModule :: (PathIOHandler r, CompilerBackend b) => r -> b -> ModuleSpec -> TrackedErrorsIO ()-compileModule resolver backend (ModuleSpec p d ee em is is2 ps xs ts es ep m f) = do+compileModule resolver backend (ModuleSpec p d ee em is is2 ps xs ts es cs ep m f pn) = do   as  <- fmap fixPaths $ mapCompilerM (resolveModule resolver (p </> d)) is   as2 <- fmap fixPaths $ mapCompilerM (resolveModule resolver (p </> d)) is2   let ca0 = Map.empty@@ -109,14 +112,15 @@   let ns0 = StaticNamespace $ publicNamespace  $ show compilerHash ++ path   let ns1 = StaticNamespace . privateNamespace $ show time ++ show compilerHash ++ path   let extensions = concat $ map getSourceCategories es-  (cs,private) <- loadModuleGlobals resolver p (ns0,ns1) ps Nothing deps1' deps2-  let cm = createLanguageModule extensions em cs-  let cs2 = filter (not . hasCodeVisibility FromDependency) cs-  let pc = map (getCategoryName . wvData) $ filter (not . hasCodeVisibility ModuleOnly) cs2-  let tc = map (getCategoryName . wvData) $ filter (hasCodeVisibility ModuleOnly)       cs2-  let dc = map (getCategoryName . wvData) $ filter (hasCodeVisibility FromDependency) $ filter (not . hasCodeVisibility ModuleOnly) cs+  (cs2,private) <- loadModuleGlobals resolver p (ns0,ns1) ps Nothing deps1' deps2+  let cm = createLanguageModule extensions em cs2+  let cs2' = filter (not . hasCodeVisibility FromDependency) cs2+  let pc = map (getCategoryName . wvData) $ filter (not . hasCodeVisibility ModuleOnly) cs2'+  let tc = map (getCategoryName . wvData) $ filter (hasCodeVisibility ModuleOnly)       cs2'+  let dc = map (getCategoryName . wvData) $ filter (hasCodeVisibility FromDependency) $ filter (not . hasCodeVisibility ModuleOnly) cs2   xa <- mapCompilerM (loadPrivateSource resolver compilerHash p) xs-  fs <- compileLanguageModule cm xa+  cs' <- foldM includeSpec Map.empty cs+  fs <- compileLanguageModule cm cs' xa   mf <- maybeCreateMain cm xa m   eraseCachedData (p </> d)   pps <- fmap (zip ps) $ mapCompilerM (errorFromIO . canonicalizePath . (p</>)) ps@@ -130,12 +134,12 @@   let paths2 = base:s0:s1:(getIncludePathsForDeps (deps1' ++ deps2)) ++ ep' ++ paths'   let hxx   = filter (isSuffixOf ".hpp" . coFilename)       fs   let other = filter (not . isSuffixOf ".hpp" . coFilename) fs-  os1 <- mapCompilerM (writeOutputFile paths2) $ hxx ++ other+  os1 <- mapCompilerM (writeOutputFile paths2)(hxx ++ other) >>= compileGenerated   let files = map (\f2 -> getCachedPath (p </> d) (show $ coNamespace f2) (coFilename f2)) fs ++               map (\f2 -> p </> getSourceFile f2) es   files' <- mapCompilerM checkOwnedFile files   let ca = Map.fromList $ map (\c -> (getCategoryName c,getCategoryNamespace c)) $ map wvData cs2-  os2 <- fmap concat $ mapCompilerM (compileExtraSource (ns0,ns1) ca paths2) es+  os2 <- mapCompilerM (compileExtraSource (ns0,ns1) ca paths2) es >>= compileExtra   let (hxx',cxx,os') = sortCompiledFiles files'   let (osCat,osOther) = partitionEithers os2   let os1' = resolveObjectDeps (deps1' ++ deps2) path path (os1 ++ osCat)@@ -195,6 +199,13 @@   let traces = Set.unions $ map coPossibleTraces $ hxx ++ other   writePossibleTraces (p </> d) traces where     ep' = fixPaths $ map (p </>) ep+    includeSpec cm (n,cc) = do+      case n `Map.lookup` cm of+           Just cc2 -> compilerErrorM $+             "Internal specs for category " ++ show n ++ formatFullContextBrace (csContext cc) +++             " already defined at " ++ formatFullContextBrace (csContext cc2)+           Nothing -> return ()+      return $ Map.insert n cc cm     writeOutputFile paths ca@(CxxOutput _ f2 ns _ _ _ content) = do       errorFromIO $ hPutStrLn stderr $ "Writing file " ++ f2       writeCachedFile (p </> d) (show ns) f2 $ concat $ map (++ "\n") content@@ -206,16 +217,20 @@            createCachePath (p </> d)            let ms = []            let command = CompileToObject f2' (getCachedPath (p </> d) (show ns) "") ms (p0:p1:paths) False-           o2 <- runCxxCommand backend command-           return $ ([o2],ca)-         else return ([],ca)-    compileExtraSource (ns0,ns1) ca paths (CategorySource f2 cs ds2) = do+           return $ Left (asyncCxxCommand backend command,ca)+         else return $ Right ca+    compileGenerated files = do+      let (compiled,saved) = partitionEithers files+      compiled' <- parallelProcess backend pn compiled+      return $ map ((,) []) saved ++ map (first (:[])) compiled'+    compileExtraSource (ns0,ns1) ca paths (CategorySource f2 cs2 ds2) = do       f2' <- compileExtraFile False (ns0,ns1) paths f2       case f2' of-           Nothing -> return []-           Just o  -> return $ map (\c -> Left $ ([o],fakeCxx c)) cs+           Left process -> return $ Left  (process,Just allFakeCxx)+           Right fs     -> return $ Right (fs,     Just allFakeCxx)       where-        allDeps = Set.fromList (cs ++ ds2)+        allDeps = Set.fromList (cs2 ++ ds2)+        allFakeCxx = map fakeCxx cs2         fakeCxx c = CxxOutput {             coCategory = Just c,             coFilename = "",@@ -228,10 +243,18 @@             coOutput = []           }     compileExtraSource (ns0,ns1) _ paths (OtherSource f2) = do-      f2' <- compileExtraFile True (ns0,ns1) paths f2+      f2' <- compileExtraFile False (ns0,ns1) paths f2       case f2' of-           Just o  -> return [Right $ OtherObjectFile o]-           Nothing -> return []+           Left process -> return $ Left  (process,Nothing)+           Right fs     -> return $ Right (fs,     Nothing)+    compileExtra files = do+      let (compiled,inert) = partitionEithers files+      compiled' <- parallelProcess backend pn compiled+      -- NOTE: Leave inert last in case it contains .a files.+      let files' = map (first (:[])) compiled' ++ inert+      return $ concat $ map expand files' where+        expand (os,Just cxx) = map (Left . (,) os) cxx+        expand (os,Nothing)  = map (Right . OtherObjectFile) os     checkOwnedFile f2 = do       exists <- errorFromIO $ doesFileExist f2       when (not exists) $ compilerErrorM $ "Owned file " ++ f2 ++ " does not exist."@@ -241,10 +264,11 @@           let f2' = p </> f2           createCachePath (p </> d)           let ms = [(publicNamespaceMacro,Just $ show ns0),(privateNamespaceMacro,Just $ show ns1)]-          let command = CompileToObject f2' (getCachedPath (p </> d) (show ns0) "") ms paths e-          fmap Just $ runCxxCommand backend command-      | isSuffixOf ".a" f2 || isSuffixOf ".o" f2 = return (Just f2)-      | otherwise = return Nothing+          objPath <- createCachedDir (p </> d) "extra"+          let command = CompileToObject f2' objPath ms paths e+          return $ Left $ asyncCxxCommand backend command+      | isSuffixOf ".a" f2 || isSuffixOf ".o" f2 = return $ Right [f2]+      | otherwise = return $ Right []     createBinary compilerHash paths deps (CompileBinary n _ lm o lf) [CxxOutput _ _ _ ns2 req _ content] = do       f0 <- if null o                 then errorFromIO $ canonicalizePath $ p </> d </> show n@@ -258,7 +282,7 @@       let paths' = fixPaths $ paths ++ base:(getIncludePathsForDeps deps)       command <- getCommand lm mainAbs f0 deps2 paths'       errorFromIO $ hPutStrLn stderr $ "Creating binary " ++ f0-      f1 <- runCxxCommand backend command+      f1 <- syncCxxCommand backend command       return [f1] where         getCommand LinkStatic mainAbs f0 deps2 paths2 = do           let lf' = lf ++ getLinkFlagsForDeps deps2@@ -281,14 +305,15 @@       -- categories will show up more than once in getObjectFiles.       let objects = (nub $ concat $ map getObjectFiles os) ++ getLibrariesForDeps deps       let command = CompileToShared objects name flags-      fmap (:[]) $ runCxxCommand backend command+      fmap (:[]) $ syncCxxCommand backend command     maybeCreateMain cm2 xs2 (CompileBinary n f2 _ _ _) =       fmap (:[]) $ compileModuleMain cm2 xs2 n f2     maybeCreateMain _ _ _ = return []  createModuleTemplates :: PathIOHandler r => r -> FilePath -> FilePath -> [FilePath] ->-  [CompileMetadata] -> [CompileMetadata] -> TrackedErrorsIO ()-createModuleTemplates resolver p d ds deps1 deps2 = do+  Map.Map CategoryName (CategorySpec SourceContext) ->[CompileMetadata] ->+  [CompileMetadata] -> TrackedErrorsIO ()+createModuleTemplates resolver p d ds cm deps1 deps2 = do   (ps,xs,_) <- findSourceFiles p (d:ds)   (LanguageModule _ _ _ cs0 ps0 ts0 cs1 ps1 ts1 _ _) <-     fmap (createLanguageModule [] Map.empty . fst) $ loadModuleGlobals resolver p (PublicNamespace,PrivateNamespace) ps Nothing deps1 deps2@@ -304,7 +329,8 @@   mapCompilerM_ writeTemplate ts where     generate testing tm n = do       (_,t) <- getConcreteCategory tm ([],n)-      generateStreamlinedTemplate testing tm t+      let spec = Map.findWithDefault (CategorySpec [] [] []) (getCategoryName t) cm+      generateStreamlinedTemplate testing tm t spec     writeTemplate (CxxOutput _ n _ _ _ _ content) = do       let n' = p </> d </> n       exists <- errorFromIO $ doesFileExist n'

@@ -23,6 +23,7 @@ ) where  import Control.Monad (when)+import Lens.Micro import Text.Regex.TDFA  import Base.CompilerError@@ -84,6 +85,7 @@     "",     "Options:",     "  -f: Force an operation that zeolite would otherwise reject.",+    "  -j [# parallel]: Parallel execution of compilation subprocesses.",     "  -i [module]: A single source module to include as a public dependency.",     "  -I [module]: A single source module to include as a private dependency.",     "  -o [binary]: The name of the binary file to create with -m.",@@ -142,48 +144,48 @@    parseSingle _ [] = undefined -  parseSingle (CompileOptions _ is is2 ds es ep p m f) ((_,"-h"):os) =-    return (os,CompileOptions HelpNeeded is is2 ds es ep p m f)+  parseSingle opts ((_,"-h"):os) =+    return (os,opts & coHelp .~ HelpNeeded) -  parseSingle (CompileOptions h is is2 ds es ep p m _) ((_,"-f"):os) =-    return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p m ForceAll)+  parseSingle opts ((_,"-f"):os) =+    return (os,opts & coForce .~ ForceAll) -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-c"):os)-    | m /= CompileUnspecified = argError n "-c" "Compiler mode already set."-    | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (CompileIncremental []) f)+  parseSingle opts ((n,"-c"):os)+    | (opts ^. coMode) /= CompileUnspecified = argError n "-c" "Compiler mode already set."+    | otherwise = return (os,opts & coHelp %~ maybeDisableHelp & coMode .~ (CompileIncremental [])) -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-r"):os)-    | m /= CompileUnspecified = argError n "-r" "Compiler mode already set."-    | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p CompileRecompile f)+  parseSingle opts ((n,"-r"):os)+    | (opts ^. coMode) /= CompileUnspecified = argError n "-r" "Compiler mode already set."+    | otherwise = return (os,opts & coHelp %~ maybeDisableHelp & coMode .~ CompileRecompile) -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-R"):os)-    | m /= CompileUnspecified = argError n "-r" "Compiler mode already set."-    | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p CompileRecompileRecursive f)+  parseSingle opts ((n,"-R"):os)+    | (opts ^. coMode) /= CompileUnspecified = argError n "-R" "Compiler mode already set."+    | otherwise = return (os,opts & coHelp %~ maybeDisableHelp & coMode .~ CompileRecompileRecursive) -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-t"):os)-    | m /= CompileUnspecified = argError n "-t" "Compiler mode already set."-    | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (ExecuteTests [] Nothing) f)+  parseSingle opts ((n,"-t"):os)+    | (opts ^. coMode) /= CompileUnspecified = argError n "-t" "Compiler mode already set."+    | otherwise = return (os,opts & coHelp %~ maybeDisableHelp & coMode .~ (ExecuteTests [] Nothing)) -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"--templates"):os)-    | m /= CompileUnspecified = argError n "-t" "Compiler mode already set."-    | otherwise = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p CreateTemplates f)+  parseSingle opts ((n,"--templates"):os)+    | (opts ^. coMode) /= CompileUnspecified = argError n "--templates" "Compiler mode already set."+    | otherwise = return (os,opts & coHelp %~ maybeDisableHelp & coMode .~ CreateTemplates) -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-m"):os)-    | m /= CompileUnspecified = argError n "-m" "Compiler mode already set."+  parseSingle opts ((n,"-m"):os)+    | (opts ^. coMode) /= CompileUnspecified = argError n "-m" "Compiler mode already set."     | otherwise = update os where       update ((n2,c):os2) =  do         (t,fn) <- check $ break (== '.') c         checkCategoryName n2 t  "-m"         checkFunctionName n2 fn "-m"         let m2 = CompileBinary (CategoryName t) (FunctionName fn) LinkDynamic "" []-        return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p m2 f) where+        return (os2,opts & coHelp %~ maybeDisableHelp & coMode .~ m2) where           check (t,"")     = return (t,defaultMainFunc)           check (t,'.':fn) = return (t,fn)           check _          = argError n2 c $ "Invalid entry point."       update _ = argError n "-m" "Requires a category name." -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"--fast"):os)-    | m /= CompileUnspecified = argError n "--fast" "Compiler mode already set."+  parseSingle opts ((n,"--fast"):os)+    | (opts ^. coMode) /= CompileUnspecified = argError n "--fast" "Compiler mode already set."     | otherwise = update os where       update ((n2,c):(n3,f2):os2) =  do         (t,fn) <- check $ break (== '.') c@@ -191,89 +193,101 @@         checkFunctionName n2 fn "--fast"         when (not $ isPrivateSource f2) $ argError n3 f2 $ "Must specify a .0rx source file."         let m2 = CompileFast (CategoryName t) (FunctionName fn) f2-        return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p m2 f) where+        return (os2,opts & coHelp %~ maybeDisableHelp & coMode .~ m2) where           check (t,"")     = return (t,defaultMainFunc)           check (t,'.':fn) = return (t,fn)           check _          = argError n2 c $ "Invalid entry point."       update _ = argError n "--fast" "Requires a category name and a .0rx file." -  parseSingle (CompileOptions h is is2 ds es ep p (ExecuteTests tp cl) f) ((n,"--log-traces"):os) = update os where-    update ((_,cl2):os2)+  parseSingle opts ((n,"--log-traces"):os) = update (opts ^. coMode) os where+    update (ExecuteTests tp cl) ((_,cl2):os2)       | cl /= Nothing = argError n "--log-traces" "Trace-log filename already set."-      | otherwise = return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (ExecuteTests tp (Just cl2)) f)-    update _ = argError n "--log-traces" "Requires an output filename."-  parseSingle _ ((n,"--log-traces"):_) = argError n "--log-traces" "Set mode to test (-t) first."+      | otherwise = return (os2,opts & coHelp %~ maybeDisableHelp & coMode .~ (ExecuteTests tp (Just cl2)))+    update _ [] = argError n "--log-traces" "Requires an output filename."+    update _ _  = argError n "--log-traces" "Set mode to test (-t) first." -  parseSingle (CompileOptions h is is2 ds es ep p (CompileBinary t fn lm o lf) f) ((n,"-o"):os)-    | not $ null o = argError n "-o" "Output name already set."-    | otherwise = update os where-      update ((n2,o2):os2) = do-        checkPathName n2 o2 "-o"-        return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (CompileBinary t fn lm o2 lf) f)-      update _ = argError n "-o" "Requires an output name."-  parseSingle _ ((n,"-o"):_) = argError n "-o" "Set mode to binary (-m) first."+  parseSingle opts ((n,"-o"):os) = update (opts ^. coMode) os where+    update (CompileBinary t fn lm o lf) ((n2,o2):os2)+      | not $ null o =  argError n "-o" "Output name already set."+      | otherwise = do+          checkPathName n2 o2 "-o"+          return (os2,opts & coHelp %~ maybeDisableHelp & coMode .~ (CompileBinary t fn lm o2 lf))+    update _ [] = argError n "-o" "Requires an output name."+    update _ _  = argError n "-o" "Set mode to binary (-m) first." -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-i"):os) = update os where+  parseSingle opts ((n,"-i"):os) = update os where     update ((n2,d):os2)       | isPublicSource  d = argError n2 d "Cannot directly include .0rp source files."       | isPrivateSource d = argError n2 d "Cannot directly include .0rx source files."       | isTestSource    d = argError n2 d "Cannot directly include .0rt test files."       | otherwise = do           checkPathName n2 d "-i"-          return (os2,CompileOptions (maybeDisableHelp h) (is ++ [d]) is2 ds es ep p m f)+          return (os2,opts & coHelp %~ maybeDisableHelp & coPublicDeps <>~ [d])     update _ = argError n "-i" "Requires a source path." -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-I"):os) = update os where+  parseSingle opts ((n,"-I"):os) = update os where     update ((n2,d):os2)       | isPublicSource  d = argError n2 d "Cannot directly include .0rp source files."       | isPrivateSource d = argError n2 d "Cannot directly include .0rx source files."       | isTestSource    d = argError n2 d "Cannot directly include .0rt test files."       | otherwise = do           checkPathName n2 d "-i"-          return (os2,CompileOptions (maybeDisableHelp h) is (is2 ++ [d]) ds es ep p m f)+          return (os2,opts & coHelp %~ maybeDisableHelp & coPrivateDeps <>~ [d])     update _ = argError n "-I" "Requires a source path." -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,"-p"):os)-    | not $ null p = argError n "-p" "Path prefix already set."+  parseSingle opts ((n,"-p"):os)+    | not $ null (opts ^. coSourcePrefix) = argError n "-p" "Path prefix already set."     | otherwise = update os where       update ((n2,p2):os2) = do         checkPathName n2 p2 "-p"-        return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep p2 m f)+        return (os2,opts & coHelp %~ maybeDisableHelp & coSourcePrefix .~ p2)       update _ = argError n "-p" "Requires a path prefix." +  parseSingle opts ((n,"-j"):os) = update os where+    update ((n2,k):os2) = do+      case reads k of+           [(pn,[])] -> if pn > 0+                           then return (os2,opts & coHelp %~ maybeDisableHelp & coParallel .~ pn)+                           else argError n2 k "Must be > 0."+           _ -> argError n2 k "Not a valid integer."+    update _ = argError n "-j" "Requires an integer > 0."+   parseSingle _ ((n,o@('-':_)):_) = argError n o "Unknown option." -  parseSingle (CompileOptions h is is2 ds es ep p m f) ((n,d):os)+  parseSingle opts ((n,d):os)       | isPublicSource  d = argError n d "Cannot directly include .0rp source files."       | isPrivateSource d = argError n d "Cannot directly include .0rx source files."       | isTestSource    d = do-        when (not $ isExecuteTests m) $-          argError n d "Test mode (-t) must be enabled before listing any .0rt test files."-        checkPathName n d ""-        let (ExecuteTests tp cl) = m-        return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep p (ExecuteTests (tp ++ [d]) cl) f)+        case opts ^. coMode of+             ExecuteTests tp cl -> do+               checkPathName n d ""+               return (os,opts & coHelp %~ maybeDisableHelp & coMode .~ (ExecuteTests (tp ++ [d]) cl))+             _ -> argError n d "Test mode (-t) must be enabled before listing any .0rt test files."       | otherwise = do         checkPathName n d ""-        return (os,CompileOptions (maybeDisableHelp h) is is2 (ds ++ [d]) es ep p m f)+        return (os,opts & coHelp %~ maybeDisableHelp & coPaths <>~ [d])  validateCompileOptions :: CollectErrorsM m => CompileOptions -> m CompileOptions-validateCompileOptions co@(CompileOptions h is is2 ds _ _ _ m _)-  | h /= HelpNotNeeded = return co+validateCompileOptions opts+  | (opts ^. coHelp) /= HelpNotNeeded = return opts -  | isCompileUnspecified m =+  | isCompileUnspecified (opts ^. coMode) =     compilerErrorM "Compiler mode must be specified explicitly." -  | (not $ null $ is ++ is2) && (isExecuteTests m) =+  | (not $ null $ (opts ^. coPublicDeps) ++ (opts ^. coPrivateDeps)) && (isExecuteTests (opts ^. coMode)) =     compilerErrorM "Include paths (-i/-I) are not allowed in test mode (-t)." -  | (not $ null $ is ++ is2) && (isCompileRecompile m) =+  | (not $ null $ (opts ^. coPublicDeps) ++ (opts ^. coPrivateDeps)) && (isCompileRecompile (opts ^. coMode)) =     compilerErrorM "Include paths (-i/-I) are not allowed in recompile mode (-r/-R)." -  | (length ds /= 0) && (isCompileFast m) =+  | (length (opts ^. coPaths) /= 0) && (isCompileFast (opts ^. coMode)) =     compilerErrorM "Input path is not allowed with fast mode (--fast)."-  | null ds && (not $ isCompileFast m) =+  | null (opts ^. coPaths) && (not $ isCompileFast (opts ^. coMode)) =     compilerErrorM "Please specify at least one input path."-  | (length ds > 1) && (not $ isCompileRecompile m) && (not $ isExecuteTests m) =+  | (length (opts ^. coPaths) > 1) && (not $ isCompileRecompile (opts ^. coMode)) && (not $ isExecuteTests (opts ^. coMode)) =     compilerErrorM "Multiple input paths are only allowed with recompile mode (-r/-R) and test mode (-t)." -  | otherwise = return co+  | otherwise = do+    when ((opts ^. coParallel) > 0 && not (isCompileRecompile (opts ^. coMode)) && not (isCompileFast (opts ^. coMode))) $+      compilerWarningM "Parallel processing (-j) has no effect outside of recompile mode (-r/-R) and fast mode (--fast)."+    return opts

@@ -17,6 +17,7 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  {-# LANGUAGE Safe #-}+{-# LANGUAGE TypeFamilies #-}  module Cli.Programs (   CompilerBackend(..),@@ -24,15 +25,22 @@   TestCommand(..),   TestCommandResult(..),   VersionHash(..),+  parallelProcess, ) where +import Control.Concurrent+import Control.Monad (when) import Control.Monad.IO.Class+import Data.Either (partitionEithers)  import Base.CompilerError   class CompilerBackend b where-  runCxxCommand   :: (MonadIO m, CollectErrorsM m) => b -> CxxCommand -> m FilePath+  type AsyncWait b :: *+  syncCxxCommand   :: (MonadIO m, CollectErrorsM m) => b -> CxxCommand -> m FilePath+  asyncCxxCommand   :: (MonadIO m, CollectErrorsM m) => b -> CxxCommand -> m (AsyncWait b)+  waitCxxCommand :: (MonadIO m, CollectErrorsM m) => b -> AsyncWait b -> m (Either (AsyncWait b) FilePath)   runTestCommand  :: (MonadIO m, CollectErrorsM m) => b -> TestCommand -> m TestCommandResult   getCompilerHash :: (MonadIO m, CollectErrorsM m) => b -> m VersionHash @@ -79,3 +87,28 @@     tcrError :: [String]   }   deriving (Show)++parallelProcess :: (CompilerBackend b, MonadIO m, CollectErrorsM m) =>+  b -> Int -> [(m (AsyncWait b),a)] -> m [(FilePath,a)]+parallelProcess b n xs | n < 1 = parallelProcess b 1 xs+parallelProcess b n xs = do+  now <- mapCompilerM start $ take n xs+  let later = drop n xs+  recursive now later where+    start (process,extra) = do+      process' <- process+      return (process',extra)+    wait (process,extra) = do+      process' <- waitCxxCommand b process+      case process' of+           Left process2 -> return $ Left (process2,extra)+           Right path -> return $ Right (path,extra)+    recursive [] _ = return []+    recursive now later = do+      tried <- mapCompilerM wait now+      let (running,done) = partitionEithers tried+      let k = length done+      when (k == 0) $ liftIO $ threadDelay 10000  -- Sleep 10ms to control rate.+      new <- mapCompilerM start $ take k later+      following <- recursive (running ++ new) (drop k later)+      return $ done ++ following

@@ -44,7 +44,7 @@   runCompiler :: (PathIOHandler r, CompilerBackend b) => r -> b -> CompileOptions -> TrackedErrorsIO ()-runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp cl) f) = do+runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p (ExecuteTests tp cl) f _) = do   base <- resolveBaseModule resolver   ts <- fmap snd $ foldM preloadTests (Map.empty,[]) ds   checkTestFilters ts@@ -85,7 +85,7 @@       | otherwise =         errorFromIO $ hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)" -runCompiler resolver backend (CompileOptions _ is is2 _ _ _ p (CompileFast c fn f2) f) = do+runCompiler resolver backend (CompileOptions _ is is2 _ _ _ p (CompileFast c fn f2) f pn) = do   dir <- errorFromIO $ mkdtemp "/tmp/zfast_"   absolute <- errorFromIO $ canonicalizePath p   f2' <- errorFromIO $ canonicalizePath (p </> f2)@@ -97,6 +97,7 @@     mcPublicDeps = [],     mcPrivateDeps = [],     mcExtraFiles = [],+    mcCategories = [],     mcExtraPaths = [],     mcMode = CompileUnspecified   }@@ -112,24 +113,26 @@     msPrivateFiles = [f2'],     msTestFiles = [],     msExtraFiles = [],+    msCategories = [],     msExtraPaths = [],     msMode = (CompileBinary c fn LinkStatic (absolute </> show c) []),-    msForce = f+    msForce = f,+    msParallel = pn   }   compileModule resolver backend spec <?? "In compilation of \"" ++ f2' ++ "\""   errorFromIO $ removeDirectoryRecursive dir -runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p CompileRecompileRecursive f) =-  runRecompileCommon resolver backend f True p ds+runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p CompileRecompileRecursive f pn) =+  runRecompileCommon resolver backend f pn True p ds -runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p CompileRecompile f) =-  runRecompileCommon resolver backend f False p ds+runCompiler resolver backend (CompileOptions _ _ _ ds _ _ p CompileRecompile f pn) =+  runRecompileCommon resolver backend f pn False p ds -runCompiler resolver backend (CompileOptions _ is is2 ds _ _ p CreateTemplates f) = mapM_ compileSingle ds where+runCompiler resolver backend (CompileOptions _ is is2 ds _ _ p CreateTemplates f _) = mapM_ compileSingle ds where   compileSingle d = do     compilerHash <- getCompilerHash backend     d' <- errorFromIO $ canonicalizePath (p </> d)-    (ep,is',is2') <- maybeUseConfig d'+    (ep,is',is2',cm) <- maybeUseConfig d'     as  <- fmap fixPaths $ mapCompilerM (resolveModule resolver d') is'     as2 <- fmap fixPaths $ mapCompilerM (resolveModule resolver d') is2'     isBase <- isBaseModule resolver d'@@ -140,17 +143,17 @@                   loadPublicDeps compilerHash f Map.empty (base:as)     deps2 <- loadPublicDeps compilerHash f (mapMetadata deps1) as2     path <- errorFromIO $ canonicalizePath p-    createModuleTemplates resolver path d ep deps1 deps2 <?? "In module \"" ++ d' ++ "\""+    createModuleTemplates resolver path d ep cm deps1 deps2 <?? "In module \"" ++ d' ++ "\""   maybeUseConfig d2 = do     let rm = loadRecompile d2     isError <- isCompilerErrorM rm     if isError-       then return ([],is,is2)+       then return ([],is,is2,Map.empty)        else do-         (ModuleConfig p2 _ ep _ is3 is4 _ _ _) <- rm-         return (map (p2 </>) ep,nub $ is ++ is3,nub $ is2 ++ is4)+         (ModuleConfig p2 _ ep _ is3 is4  _ cs _ _) <- rm+         return (map ((d2 </> p2) </>) ep,nub $ is ++ is3,nub $ is2 ++ is4,Map.fromList cs) -runCompiler resolver _ (CompileOptions _ is is2 ds es ep p m f) = mapM_ compileSingle ds where+runCompiler resolver _ (CompileOptions _ is is2 ds es ep p m f _) = mapM_ compileSingle ds where   compileSingle d = do     as  <- fmap fixPaths $ mapCompilerM (autoDep (p </> d)) is     as2 <- fmap fixPaths $ mapCompilerM (autoDep (p </> d)) is2@@ -167,6 +170,7 @@       mcPublicDeps = as,       mcPrivateDeps = as2,       mcExtraFiles = es,+      mcCategories = [],       mcExtraPaths = ep,       mcMode = m     }@@ -213,8 +217,8 @@     when (expected /= title) $ compilerErrorM $ "Expected column named \"" ++ expected ++ "\" but found \"" ++ title ++ "\""  runRecompileCommon :: (PathIOHandler r, CompilerBackend b) => r -> b ->-  ForceMode -> Bool -> FilePath -> [FilePath] -> TrackedErrorsIO ()-runRecompileCommon resolver backend f rec p ds = do+  ForceMode -> Int -> Bool -> FilePath -> [FilePath] -> TrackedErrorsIO ()+runRecompileCommon resolver backend f pn rec p ds = do   explicit <- fmap Set.fromList $ mapCompilerM (errorFromIO . canonicalizePath . (p </>)) ds   foldM (recursive resolver explicit) Set.empty (map ((,) p) ds) >> return () where     recursive r explicit da (p2,d0) = do@@ -237,7 +241,7 @@       if f < ForceAll && upToDate          then compilerWarningM $ "Path " ++ d ++ " is up to date"          else do-           rm@(ModuleConfig p2 d2 ee _ is is2 es ep m) <- loadRecompile d+           rm@(ModuleConfig p2 d2 ee _ is is2 es cs ep m) <- loadRecompile d            let fixed = fixPath (d </> p2)            (ps,xs,ts) <- findSourceFiles fixed (d2:ee)            em <- getExprMap d rm@@ -252,8 +256,10 @@              msPrivateFiles = xs,              msTestFiles = ts,              msExtraFiles = es,+             msCategories = cs,              msExtraPaths = ep,              msMode = m,-             msForce = f+             msForce = f,+             msParallel = pn            }            compileModule resolver backend spec <?? "In compilation of module \"" ++ d ++ "\""

@@ -217,7 +217,7 @@       let libraries = getLibrariesForDeps deps       macro <- timeoutMacro timeout       let command = CompileToBinary main (concat (map fst sources) ++ libraries) macro binary paths' flags-      file <- runCxxCommand b command+      file <- syncCxxCommand b command       return (dir,file)     timeoutMacro (Just 0) = return []  -- No timeout.     timeoutMacro Nothing  = return [(testTimeoutMacro,Just "30")]  -- Default timeout.

@@ -146,9 +146,7 @@                  case t of                       Just t0 -> replaceSelfInstance self t0                       Nothing -> return self-    getFunction t' t' >>= onlyFunc t' where-      onlyFunc _ [f] = return f-      onlyFunc t2 fs = collectFirstM $ map (tryMergeFrom fs) fs ++ [multipleMatchError t2 fs]+    getFunction t' t' where       multipleMatchError t2 fs = do         "Multiple matches for function " ++ show n ++ " called on " ++ show t2 ++ formatFullContextBrace c !!>           mapErrorsM (map show fs)@@ -167,12 +165,12 @@       getFunction t0 t2 = reduceMergeTree getFromAny getFromAll (getFromSingle t0) t2       getFromAny fs = do         let (Just t') = t  -- #self will never be a union.-        fs2 <- fmap concat (collectAllM fs) <!! "Function " ++ show n ++ " is not available for type " ++ show t' ++ formatFullContextBrace c+        fs2 <- collectAllM fs <!! "Function " ++ show n ++ " is not available for type " ++ show t' ++ formatFullContextBrace c         case Map.toList $ Map.fromList $ map (\f -> (sfType f,sfContext f)) fs2 of              -- For unions, we want the most general rather than the least              -- general. Since the top level finds the least general, we can              -- only return one match here.-             [_] -> fmap (:[]) $ collectFirstM $ map (tryMergeTo fs2) fs2 ++ [multipleMatchError t' fs2]+             [_] -> collectFirstM $ map (tryMergeTo fs2) fs2 ++ [multipleMatchError t' fs2]              [] -> compilerErrorM $ "Function " ++ show n ++ " is not available for type " ++ show t' ++ formatFullContextBrace c              cs -> "Use an explicit conversion to call " ++ show n ++ " for type " ++ show t' ++ formatFullContextBrace c !!>                mapErrorsM (map (\(t2,c2) -> "Function " ++ show n ++ " in " ++ show t2 ++ formatFullContextBrace c2) cs)@@ -180,7 +178,8 @@         let (Just t') = t  -- #self will never be an intersection.         collectFirstM_ fs <!!           "Function " ++ show n ++ " is not available for type " ++ show t' ++ formatFullContextBrace c-        fmap concat $ collectAnyM fs+        fs2 <- collectAnyM fs+        collectFirstM $ map (tryMergeFrom fs2) fs2 ++ [multipleMatchError t' fs2]       getFromSingle t0 (JustParamName _ p) = do         fa <- ccAllFilters ctx         ff <- case p `Map.lookup` fa of@@ -191,7 +190,8 @@         let fs = map (getFunction t0) ts ++ map (checkDefine t0) ds         collectFirstM_ fs <!!           "Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c-        fmap concat $ collectAnyM fs+        fs2 <- collectAnyM fs+        collectFirstM $ map (tryMergeFrom fs2) fs2 ++ [multipleMatchError p fs2]       getFromSingle t0 (JustTypeInstance t2)         -- Same category as the procedure itself.         | tiName t2 == ctx ^. pcType =@@ -218,7 +218,7 @@         paired <- processPairs alwaysPair ps1 ps2 <??           "In external function call at " ++ formatFullContext c         let assigned = Map.fromList paired-        uncheckedSubFunction assigned f >>= replaceSelfFunction (fixTypeParams t0) >>= return . (:[])+        uncheckedSubFunction assigned f >>= replaceSelfFunction (fixTypeParams t0)       subAndCheckFunction _ t2 _ _ _ =         compilerErrorM $ "Category " ++ show t2 ++                          " does not have a type or value function named " ++ show n ++

@@ -87,10 +87,12 @@   let readOnly2 = if null immutable                      then readOnly                      else Map.fromListWith (++) $ Map.toList readOnly ++ zip valueMembers (repeat immutable)-  cm2 <- mapMembers readOnly2 hidden cm-  tm2 <- mapMembers readOnly2 hidden $ cm ++ tm'-  vm2 <- mapMembers readOnly2 hidden $ cm ++ tm' ++ vm'+  let readOnly3 = Map.union inferredReadOnly readOnly2+  cm2 <- mapMembers readOnly3 hidden cm+  tm2 <- mapMembers readOnly3 hidden $ cm ++ tm'+  vm2 <- mapMembers readOnly3 hidden $ cm ++ tm' ++ vm'   mapCompilerM_ checkPragma pragmas+  warnDuplicateReadOnly   let cv = Map.union cm0 cm2   let tv = Map.union tm0 tm2   let vv = Map.union vm0 vm2@@ -100,11 +102,27 @@   return [ProcedureScope ctxC cp,ProcedureScope ctxT tp',ProcedureScope ctxV vp']   where     message = "In compilation of definition for " ++ show n ++ formatFullContextBrace c+    warnDuplicateReadOnly = do+      let ro  = filter isMembersReadOnly       pragmas+      let roe = filter isMembersReadOnlyExcept pragmas+      case (roe,roe++ro) of+           ([],_)    -> return ()+           ([_],[_]) -> return ()+           (_,ra) -> "ReadOnlyExcept should not be used with other read-only pragmas" ??>+             mapCompilerM_ warnROPragma ra+    warnROPragma (MembersReadOnly       c2 _) = compilerWarningM $ "ReadOnly at " ++ formatFullContext c2+    warnROPragma (MembersReadOnlyExcept c2 _) = compilerWarningM $ "ReadOnlyExcept at " ++ formatFullContext c2+    warnROPragma _ = return ()     checkPragma (MembersReadOnly c2 vs) = do       let missing = Set.toList $ Set.fromList vs `Set.difference` allMembers       mapCompilerM_ (\v -> compilerErrorM $ "Member " ++ show v ++                                             " does not exist (marked ReadOnly at " ++                                             formatFullContext c2 ++ ")") missing+    checkPragma (MembersReadOnlyExcept c2 vs) = do+      let missing = Set.toList $ Set.fromList vs `Set.difference` allMembers+      mapCompilerM_ (\v -> compilerErrorM $ "Member " ++ show v +++                                            " does not exist (marked ReadOnlyExcept at " +++                                            formatFullContext c2 ++ ")") missing     checkPragma (MembersHidden c2 vs) = do       let missing = Set.toList $ Set.fromList vs `Set.difference` allMembers       mapCompilerM_ (\v -> compilerErrorM $ "Member " ++ show v ++@@ -114,6 +132,12 @@     allMembers = Set.fromList $ map dmName ms     valueMembers = map dmName $ filter ((== ValueScope) . dmScope) ms     immutableContext t = head $ (map ciContext $ filter isCategoryImmutable (getCategoryPragmas t)) ++ [[]]+    readOnlyExcept = case filter isMembersReadOnlyExcept pragmas of+                          [] -> Nothing+                          ps2 -> Just (concat $ map mroeContext ps2,Set.fromList $ concat $ map mroeMembers ps2)+    inferredReadOnly = case readOnlyExcept of+                            Nothing -> Map.empty+                            Just (c2,exempt) -> Map.fromList $ flip zip (repeat c2) $ filter (not . (`Set.member` exempt)) $ map dmName ms     readOnly = Map.fromListWith (++) $ concat $ map (\m -> zip (mroMembers m) (repeat $ mroContext m)) $ filter isMembersReadOnly pragmas     hidden   = Map.fromListWith (++) $ concat $ map (\m -> zip (mhMembers m)  (repeat $ mhContext m))  $ filter isMembersHidden   pragmas     firstM f (x,y) = do

@@ -29,7 +29,6 @@   functionLabelType,   hasPrimitiveValue,   indentCompiled,-  integratedCategoryDeps,   isStoredUnboxed,   newFunctionLabel,   noTestsOnlySourceGuard,@@ -131,9 +130,6 @@ hasPrimitiveValue BuiltinFloat = True hasPrimitiveValue BuiltinChar  = True hasPrimitiveValue _            = False--integratedCategoryDeps :: Set.Set CategoryName-integratedCategoryDeps = Set.fromList [BuiltinBool,BuiltinInt,BuiltinFloat,BuiltinChar]  isStoredUnboxed :: ValueType -> Bool isStoredUnboxed t

@@ -17,7 +17,6 @@ -- Author: Kevin P. Barry [ta0kira@gmail.com]  {-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}  module CompilerCxx.CxxFiles (   CxxOutput(..),@@ -54,6 +53,7 @@ import CompilerCxx.Code import CompilerCxx.Naming import CompilerCxx.Procedure+import Module.CompileMetadata (CategorySpec(..)) import Types.Builtin import Types.DefinedCategory import Types.Procedure@@ -97,10 +97,10 @@   return (dec:def)  generateStreamlinedExtension :: (Ord c, Show c, CollectErrorsM m) =>-  Bool -> Set.Set Namespace -> AnyCategory c -> m [CxxOutput]-generateStreamlinedExtension testing ns t = do+  FileContext c -> AnyCategory c -> CategorySpec c -> m [CxxOutput]+generateStreamlinedExtension (FileContext testing tm ns _) t spec = do   dec <- compileCategoryDeclaration testing ns t-  def <- generateCategoryDefinition testing (StreamlinedExtension t ns)+  def <- generateCategoryDefinition testing (StreamlinedExtension (getCategoryName t) tm ns spec)   return (dec:def)  generateVerboseExtension :: (Ord c, Show c, CollectErrorsM m) =>@@ -109,9 +109,9 @@   fmap (:[]) $ compileCategoryDeclaration testing Set.empty t  generateStreamlinedTemplate :: (Ord c, Show c, CollectErrorsM m) =>-  Bool -> CategoryMap c -> AnyCategory c -> m [CxxOutput]-generateStreamlinedTemplate testing tm t =-  generateCategoryDefinition testing (StreamlinedTemplate t tm)+  Bool -> CategoryMap c -> AnyCategory c -> CategorySpec c -> m [CxxOutput]+generateStreamlinedTemplate testing tm t spec =+  generateCategoryDefinition testing (StreamlinedTemplate (getCategoryName t) tm spec)  compileCategoryDeclaration :: (Ord c, Show c, CollectErrorsM m) =>   Bool -> Set.Set Namespace -> AnyCategory c -> m CxxOutput@@ -170,12 +170,15 @@     ncExprMap :: ExprMap c   } |   StreamlinedExtension {-    seCategory :: AnyCategory c,-    ncNamespaces :: Set.Set Namespace+    seType :: CategoryName,+    seCategories :: CategoryMap c,+    seNamespaces :: Set.Set Namespace,+    scSpec :: CategorySpec c   } |   StreamlinedTemplate {-    stCategory :: AnyCategory c,-    stCategories :: CategoryMap c+    stName :: CategoryName,+    stCategories :: CategoryMap c,+    scSpec :: CategorySpec c   }  generateCategoryDefinition :: (Ord c, Show c, CollectErrorsM m) =>@@ -204,50 +207,65 @@                          req'                          traces                          (allowTestsOnly $ addSourceIncludes $ addCategoryHeader t $ addIncludes req' out)-  common (StreamlinedExtension t ns) = sequence [streamlinedHeader,streamlinedSource] where-    streamlinedHeader = do-      let filename = headerStreamlined (getCategoryName t)-      let maybeValue = if hasPrimitiveValue (getCategoryName t)-                          then []-                          else [defineAbstractValue t]-      (CompiledData req traces out) <- fmap (addNamespace t) $ concatM $ [-          defineAbstractCategory t,-          return $ declareInternalType t (length $ getCategoryParams t),-          defineAbstractType t-        ] ++ maybeValue ++ [-          declareAbstractGetters t-        ]-      return $ CxxOutput (Just $ getCategoryName t)-                         filename-                         (getCategoryNamespace t)-                         (getCategoryNamespace t `Set.insert` ns)-                         req-                         traces-                         (headerGuard (getCategoryName t) $ allowTestsOnly $ addTemplateIncludes $ addCategoryHeader t $ addIncludes req out)-    streamlinedSource = do-      let filename = sourceStreamlined (getCategoryName t)-      let (cf,tf,vf) = partitionByScope sfScope $ getCategoryFunctions t-      let maybeValue = if hasPrimitiveValue (getCategoryName t)-                          then []-                          else [defineValueOverrides t (getCategoryFunctions t)]-      (CompiledData req traces out) <- fmap (addNamespace t) $ concatM $ [-          defineFunctions t cf tf vf,-          defineCategoryOverrides t (getCategoryFunctions t),-          defineTypeOverrides     t (getCategoryFunctions t)-        ] ++ maybeValue ++ [-          defineExternalGetters t-        ]-      let req' = Set.unions [req,getCategoryMentions t,integratedCategoryDeps]-      return $ CxxOutput (Just $ getCategoryName t)-                         filename-                         (getCategoryNamespace t)-                         (getCategoryNamespace t `Set.insert` ns)-                         req'-                         traces-                         (addSourceIncludes $ addStreamlinedHeader t $ addIncludes req' out)-  common (StreamlinedTemplate t tm) = fmap (:[]) streamlinedTemplate where+  common (StreamlinedExtension n ta ns (CategorySpec c rs ds)) = do+    ta' <- mergeInternalInheritance ta defined+    (_,t) <- getConcreteCategory ta' ([],n)+    sequence [streamlinedHeader t,streamlinedSource t] where+      defined = DefinedCategory {+          dcContext = c,+          dcPragmas = [],+          dcName = n,+          dcRefines = rs,+          dcDefines = ds,+          dcMembers = [],+          dcProcedures = [],+          dcFunctions = []+        }+      streamlinedHeader t = do+        let filename = headerStreamlined n+        let maybeValue = if hasPrimitiveValue n+                            then []+                            else [defineAbstractValue t]+        (CompiledData req traces out) <- fmap (addNamespace t) $ concatM $ [+            defineAbstractCategory t,+            return $ declareInternalType t (length $ getCategoryParams t),+            defineAbstractType t+          ] ++ maybeValue ++ [+            declareAbstractGetters t+          ]+        return $ CxxOutput (Just $ n)+                           filename+                           (getCategoryNamespace t)+                           (getCategoryNamespace t `Set.insert` ns)+                           req+                           traces+                           (headerGuard n $ allowTestsOnly $ addTemplateIncludes $ addCategoryHeader t $ addIncludes req out)+      streamlinedSource t = do+        let filename = sourceStreamlined n+        let (cf,tf,vf) = partitionByScope sfScope $ getCategoryFunctions t+        let maybeValue = if hasPrimitiveValue n+                            then []+                            else [defineValueOverrides t (getCategoryFunctions t)]+        (CompiledData req traces out) <- fmap (addNamespace t) $ concatM $ [+            defineFunctions t cf tf vf,+            defineCategoryOverrides t (getCategoryFunctions t),+            defineTypeOverrides     t (getCategoryFunctions t)+          ] ++ maybeValue ++ [+            defineExternalGetters t+          ]+        let req' = Set.unions [req,getCategoryMentions t]+        return $ CxxOutput (Just $ n)+                           filename+                           (getCategoryNamespace t)+                           (getCategoryNamespace t `Set.insert` ns)+                           req'+                           traces+                           (addSourceIncludes $ addStreamlinedHeader t $ addIncludes req' out)+  common (StreamlinedTemplate n tm (CategorySpec c rs ds)) = fmap (:[]) streamlinedTemplate where     streamlinedTemplate = do-      [cp,tp,vp] <- getProcedureScopes tm Map.empty defined+      tm' <- mergeInternalInheritance tm defined0+      (_,t) <- getConcreteCategory tm' ([],n)+      [cp,tp,vp] <- getProcedureScopes tm' Map.empty (defined $ getCategoryFunctions t)       let maybeGetter = if hasPrimitiveValue (getCategoryName t)                            then []                            else [declareCustomValueGetter t]@@ -272,15 +290,25 @@                          req'                          traces                          (addTemplateIncludes $ addStreamlinedHeader t $ addIncludes req' out)-    filename = templateStreamlined (getCategoryName t)-    defined = DefinedCategory {+    filename = templateStreamlined n+    defined0 = DefinedCategory {+        dcContext = c,+        dcPragmas = [],+        dcName = n,+        dcRefines = rs,+        dcDefines = ds,+        dcMembers = [],+        dcProcedures = [],+        dcFunctions = []+      }+    defined fs = DefinedCategory {         dcContext = [],         dcPragmas = [],-        dcName = getCategoryName t,-        dcRefines = [],-        dcDefines = [],+        dcName = n,+        dcRefines = rs,+        dcDefines = ds,         dcMembers = [],-        dcProcedures = map defaultFail (getCategoryFunctions t),+        dcProcedures = map defaultFail fs,         dcFunctions = []       }     defaultFail f = ExecutableProcedure {@@ -294,9 +322,9 @@       }     createArg = InputValue [] . VariableName . ("arg" ++) . show     failProcedure f = Procedure [] $ [-        asLineComment $ "TODO: Implement " ++ functionDebugName (getCategoryName t) f ++ "."+        asLineComment $ "TODO: Implement " ++ functionDebugName n f ++ "."       ] ++ map asLineComment (formatFunctionTypes f) ++ [-        RawFailCall (functionDebugName (getCategoryName t) f ++ " is not implemented (see " ++ filename ++ ")")+        RawFailCall (functionDebugName n f ++ " is not implemented (see " ++ filename ++ ")")       ]     asLineComment = NoValueExpression [] . LineComment   common (NativeConcrete t d@(DefinedCategory _ _ _ _ _ ms _ _) ta ns em) = fmap (:[]) singleSource where@@ -326,7 +354,7 @@           defineInternalGetters t,           defineExternalGetters t         ]-      let req' = Set.unions [req,getCategoryMentions t,integratedCategoryDeps]+      let req' = Set.unions [req,getCategoryMentions t]       return $ CxxOutput (Just $ getCategoryName t)                          filename                          (getCategoryNamespace t)@@ -525,21 +553,23 @@       onlyCode "}"     ] where       className = categoryName (getCategoryName t)-  defineTypeOverrides t fs = return $ mconcat [-      onlyCode $ "std::string " ++ className ++ "::CategoryName() const { return parent.CategoryName(); }",-      onlyCode $ "void " ++ className ++ "::BuildTypeName(std::ostream& output) const {",-      defineTypeName params,-      onlyCode "}",-      onlyCode $ "bool " ++ className ++ "::TypeArgsForParent(const CategoryId& category, std::vector<S<const TypeInstance>>& args) const {",-      createTypeArgsForParent t,-      onlyCode $ "}",-      onlyCode $ "ReturnTuple " ++ className ++ "::Dispatch(const TypeFunction& label, const ParamsArgs& params_args) const {",-      createFunctionDispatch t TypeScope fs,-      onlyCode $ "}",-      onlyCode $ "bool " ++ className ++ "::CanConvertFrom(const S<const TypeInstance>& from) const {",-      createCanConvertFrom t,-      onlyCode "}"-    ] where+  defineTypeOverrides t fs = do+    typeArgs <- createTypeArgsForParent t+    return $ mconcat [+        onlyCode $ "std::string " ++ className ++ "::CategoryName() const { return parent.CategoryName(); }",+        onlyCode $ "void " ++ className ++ "::BuildTypeName(std::ostream& output) const {",+        defineTypeName params,+        onlyCode "}",+        onlyCode $ "bool " ++ className ++ "::TypeArgsForParent(const CategoryId& category, std::vector<S<const TypeInstance>>& args) const {",+        typeArgs,+        onlyCode $ "}",+        onlyCode $ "ReturnTuple " ++ className ++ "::Dispatch(const TypeFunction& label, const ParamsArgs& params_args) const {",+        createFunctionDispatch t TypeScope fs,+        onlyCode $ "}",+        onlyCode $ "bool " ++ className ++ "::CanConvertFrom(const S<const TypeInstance>& from) const {",+        createCanConvertFrom t,+        onlyCode "}"+      ] where       className = typeName (getCategoryName t)       params = map vpParam $ getCategoryParams t   defineValueOverrides t fs = return $ mconcat [@@ -852,23 +882,27 @@       checkCov i p = "  if (!TypeInstance::CanConvert(args[" ++ show i ++ "], " ++ paramName p ++ ")) return false;"       checkCon i p = "  if (!TypeInstance::CanConvert(" ++ paramName p ++ ", args[" ++ show i ++ "])) return false;" -createTypeArgsForParent :: AnyCategory c -> CompiledData [String]-createTypeArgsForParent t = onlyCodes $ [-    "  switch (category) {"-  ] ++ categoryCases ++ [-    "    default:",-    "      return false;",-    "  }"-  ] where-    categoryCases = concat $ map singleCase (myType:refines)+createTypeArgsForParent :: CollectErrorsM m => AnyCategory c -> m (CompiledData [String])+createTypeArgsForParent t = do+  categoryCases <- fmap concat $ mapCompilerM singleCase (myType:refines)+  return $ onlyCodes $ [+      "  switch (category) {"+    ] ++ categoryCases ++ [+      "    default:",+      "      return false;",+      "  }"+    ] where     params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t-    myType = (getCategoryName t,map (singleType . JustParamName False . fst) params)+    self = singleFromCategory t+    myType = (getCategoryName t,map (singleType . JustParamName True . fst) params)     refines = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType $ getCategoryRefines t-    singleCase (n2,ps) = [-        "    case " ++ categoryIdName n2 ++ ":",-        "      args = std::vector<S<const TypeInstance>>{" ++ intercalate ", " (map expandLocalType ps) ++ "};",-        "      return true;"-      ]+    singleCase (n2,ps) = do+      ps' <- mapCompilerM (reverseSelfInstance self) ps+      return [+          "    case " ++ categoryIdName n2 ++ ":",+          "      args = std::vector<S<const TypeInstance>>{" ++ intercalate ", " (map expandLocalType ps') ++ "};",+          "      return true;"+        ]  -- Similar to Procedure.expandGeneralInstance but doesn't account for scope. expandLocalType :: GeneralInstance -> String@@ -879,10 +913,10 @@   getAny ts = unionGetter     ++ combine ts   getAll ts = intersectGetter ++ combine ts   getSingle (JustTypeInstance (TypeInstance t2 ps)) =-    typeGetter t2 ++ "(T_get(" ++ intercalate ", " (map expandLocalType $ pValues ps) ++ "))"+    typeGetter t2 ++ "(Params<" ++ show (length $ pValues ps) ++ ">::Type(" ++ intercalate ", " (map expandLocalType $ pValues ps) ++ "))"   getSingle (JustParamName _ p)  = paramName p   getSingle (JustInferredType p) = paramName p-  combine ps = "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps) ++ "))"+  combine ps = "(L_get<S<const " ++ typeBase ++ ">>(" ++ intercalate "," ps ++ "))"  defineCategoryName :: SymbolScope -> CategoryName -> CompiledData [String] defineCategoryName TypeScope     _ = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }"

@@ -16,8 +16,6 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] -{-# LANGUAGE Safe #-}- module CompilerCxx.LanguageModule (   LanguageModule(..),   PrivateSource(..),@@ -36,6 +34,7 @@ import Compilation.ProcedureContext (ExprMap) import CompilerCxx.CxxFiles import CompilerCxx.Naming+import Module.CompileMetadata (CategorySpec(..)) import Types.Builtin import Types.DefinedCategory import Types.Procedure@@ -67,10 +66,11 @@   }  compileLanguageModule :: (Ord c, Show c, CollectErrorsM m) =>-  LanguageModule c -> [PrivateSource c] -> m [CxxOutput]-compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1  ss em) xa = do+  LanguageModule c -> Map.Map CategoryName (CategorySpec c) ->+  [PrivateSource c] -> m [CxxOutput]+compileLanguageModule (LanguageModule ns0 ns1 ns2 cs0 ps0 ts0 cs1 ps1 ts1  ss em) cm xa = do   let dm = mapDefByName $ concat $ map psDefine xa-  checkDefined dm extensions $ filter isValueConcrete (cs1 ++ ps1 ++ ts1)+  checkDefined dm extensions allExternal $ filter isValueConcrete (cs1 ++ ps1 ++ ts1)   checkSupefluous $ Set.toList $ extensions `Set.difference` ca   tmPublic  <- foldM includeNewTypes defaultCategories [cs0,cs1]   tmPrivate <- foldM includeNewTypes tmPublic          [ps0,ps1]@@ -80,20 +80,25 @@     map (generateNativeInterface False nsPrivate) (onlyNativeInterfaces ps1) ++     map (generateNativeInterface True  nsPrivate) (onlyNativeInterfaces ts1)   xxPrivate <- fmap concat $ mapCompilerM (compilePrivate tmPrivate tmTesting) xa-  xxStreamlined <- fmap concat $ mapCompilerM (streamlined tmTesting) $ nub ss+  xxStreamlined <- fmap concat $ mapCompilerM (streamlined tmPrivate tmTesting) $ nub ss   let allFiles = xxInterfaces ++ xxPrivate ++ xxStreamlined   noDuplicateFiles $ map (\f -> (coFilename f,coNamespace f)) allFiles   return allFiles where     nsPublic  = ns0 `Set.union` ns2     nsPrivate = ns1 `Set.union` nsPublic     extensions = Set.fromList ss+    allExternal = Set.unions [extensions,Map.keysSet cm]     testingCats = Set.fromList $ map getCategoryName ts1     onlyNativeInterfaces = filter (not . (`Set.member` extensions) . getCategoryName) . filter (not . isValueConcrete)     localCats = Set.fromList $ map getCategoryName $ cs1 ++ ps1 ++ ts1-    streamlined tm n = do+    streamlined tm0 tm2 n = do       checkLocal localCats ([] :: [String]) n+      let testing = n `Set.member` testingCats+      let tm = if testing then tm2 else tm0       (_,t) <- getConcreteCategory tm ([],n)-      generateStreamlinedExtension (n `Set.member` testingCats) nsPrivate t+      let ctx = FileContext testing tm nsPrivate Map.empty+      let spec = Map.findWithDefault (CategorySpec [] [] []) (getCategoryName t) cm+      generateStreamlinedExtension ctx t spec     compilePrivate tmPrivate tmTesting (PrivateSource ns3 testing cs2 ds) = do       let tm = if testing                   then tmTesting@@ -106,7 +111,7 @@       checkLocals ds $ Map.keysSet tm'       when testing $ checkTests ds (cs1 ++ ps1)       let dm = mapDefByName ds-      checkDefined dm Set.empty $ filter isValueConcrete cs2+      checkDefined dm Set.empty Set.empty $ filter isValueConcrete cs2       xxInterfaces <- fmap concat $ mapCompilerM (generateNativeInterface testing nsPrivate) (filter (not . isValueConcrete) cs2)       xxConcrete   <- fmap concat $ mapCompilerM (generateConcrete cs ctx) ds       return $ xxInterfaces ++ xxConcrete@@ -135,20 +140,20 @@              compilerErrorM ("Category " ++ show (dcName d) ++                             formatFullContextBrace (dcContext d) ++                             " was not declared as $TestsOnly$" ++ formatFullContextBrace c)-    checkDefined dm ext = mapCompilerM_ (checkSingle dm ext)-    checkSingle dm ext t =-      case (getCategoryName t `Set.member` ext,getCategoryName t `Map.lookup` dm) of-           (False,Just [_]) -> return ()-           (True,Nothing)   -> return ()-           (True,Just [d]) ->+    checkDefined dm ext extAll = mapCompilerM_ (checkSingle dm ext extAll)+    checkSingle dm ext extAll t =+      case (getCategoryName t `Set.member` ext,getCategoryName t `Set.member` extAll,getCategoryName t `Map.lookup` dm) of+           (False,False,Just [_]) -> return ()+           (True,_,Nothing) -> return ()+           (False,_,Nothing) ->              compilerErrorM ("Category " ++ show (getCategoryName t) ++-                           formatFullContextBrace (getCategoryContext t) ++-                           " was declared external but is also defined at " ++ formatFullContext (dcContext d))-           (False,Nothing) ->+                             formatFullContextBrace (getCategoryContext t) +++                             " has not been defined or declared external")+           (_,True,Just [d]) ->              compilerErrorM ("Category " ++ show (getCategoryName t) ++-                           formatFullContextBrace (getCategoryContext t) ++-                           " has not been defined or declared external")-           (_,Just ds) ->+                             formatFullContextBrace (getCategoryContext t) +++                             " was declared external but is also defined at " ++ formatFullContext (dcContext d))+           (_,_,Just ds) ->              ("Category " ++ show (getCategoryName t) ++               formatFullContextBrace (getCategoryContext t) ++               " is defined " ++ show (length ds) ++ " times") !!>@@ -174,7 +179,7 @@       psCategory = cs,       psDefine = ds     }-  xx <- compileLanguageModule cm [xs]+  xx <- compileLanguageModule cm Map.empty [xs]   (main,fs) <- compileTestMain cm args xs ts   return (xx,main,fs) 

@@ -16,9 +16,12 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] +{-# LANGUAGE TypeFamilies #-}+ module Config.LocalConfig (   Backend(..),   LocalConfig(..),+  PendingProcess,   Resolver(..),   rootPath,   compilerVersion,@@ -36,8 +39,9 @@ import System.Exit import System.FilePath import System.IO-import System.Posix.Process (ProcessStatus(..),executeFile,forkProcess,getProcessStatus)+import System.Posix.Process import System.Posix.Temp (mkstemps)+import System.Posix.Types (ProcessID)  import Base.CompilerError import Cli.Programs@@ -55,37 +59,73 @@ compilerVersion :: String compilerVersion = showVersion version +data PendingProcess =+  PendingProcess {+    pcContext :: String,+    pcProcess :: ProcessID,+    pcNext :: Either (IO PendingProcess) FilePath+  }+ instance CompilerBackend Backend where-  runCxxCommand = run where+  type AsyncWait Backend = PendingProcess+  syncCxxCommand b compile = asyncCxxCommand b compile >>= waitAll where+    waitAll (PendingProcess context pid next) = do+      blockProcess pid <?? context+      case next of+           Left process -> errorFromIO process >>= waitAll+           Right path -> return path+  asyncCxxCommand = run where     run (UnixBackend cb ff _ _ ab) (CompileToObject s p ms ps e) = do       objName <- errorFromIO $ canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".o")+      arName  <- errorFromIO $ canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".a")       let otherOptions = map (("-I" ++) . normalise) ps ++ map macro ms-      executeProcess cb (ff ++ otherOptions ++ ["-c", s, "-o", objName]) <?? "In compilation of " ++ s-      if e-         then do-           -- Extra files are put into .a since they will be unconditionally-           -- included. This prevents unwanted symbol dependencies.-           arName  <- errorFromIO $ canonicalizePath $ p </> (takeFileName $ dropExtension s ++ ".a")-           executeProcess ab ["-q",arName,objName] <?? "In packaging of " ++ objName-           return arName-         else return objName+      let next = if not e+                    then Right objName+                    else Left $ do+                      pid <- executeProcess ab ["-q",arName,objName]+                      return $ PendingProcess {+                          pcContext = "In archiving of " ++ objName,+                          pcProcess = pid,+                          pcNext = Right arName+                        }+      pid <- errorFromIO $ executeProcess cb (ff ++ otherOptions ++ ["-c", s, "-o", objName])+      return $ PendingProcess {+          pcContext = "In compilation of " ++ s,+          pcProcess = pid,+          pcNext = next+        }     run (UnixBackend cb _ ff _ _) (CompileToShared ss o lf) = do       let arFiles      = filter (isSuffixOf ".a")       ss       let otherFiles   = filter (not . isSuffixOf ".a") ss       let flags = nub lf       let args = ff ++ otherFiles ++ arFiles ++ ["-o", o] ++ flags-      executeProcess cb args <?? "In linking of " ++ o-      return o+      pid <- errorFromIO $ executeProcess cb args+      return $ PendingProcess {+          pcContext = "In linking of " ++ o,+          pcProcess = pid,+          pcNext = Right o+        }     run (UnixBackend cb _ _ ff _) (CompileToBinary m ss ms o ps lf) = do       let arFiles      = filter (isSuffixOf ".a")       ss       let otherFiles   = filter (not . isSuffixOf ".a") ss       let otherOptions = map (("-I" ++) . normalise) ps ++ map macro ms       let flags = nub lf       let args = ff ++ otherOptions ++ m:otherFiles ++ arFiles ++ ["-o", o] ++ flags-      executeProcess cb args <?? "In linking of " ++ o-      return o+      pid <- errorFromIO $ executeProcess cb args+      return $ PendingProcess {+          pcContext = "In linking of " ++ o,+          pcProcess = pid,+          pcNext = Right o+        }     macro (n,Just v)  = "-D" ++ n ++ "=" ++ v     macro (n,Nothing) = "-D" ++ n+  waitCxxCommand _ p@(PendingProcess context pid next) = do+    status <- waitProcess pid <?? context+    if status+       then case next of+                 Left process -> fmap Left $ errorFromIO process+                 Right result -> return $ Right result  -- Not the same Either.+       else return $ Left p   runTestCommand _ (TestCommand b p as) = errorFromIO $ do     (outF,outH) <- mkstemps "/tmp/ztest_" ".txt"     (errF,errH) <- mkstemps "/tmp/ztest_" ".txt"@@ -111,16 +151,29 @@     serialized <- autoWriteConfig b     return $ VersionHash $ flip showHex "" $ abs $ hash $ minorVersion ++ serialized -executeProcess :: (MonadIO m, ErrorContextM m) => String -> [String] -> m ()+executeProcess :: String -> [String] -> IO ProcessID executeProcess c os = do-  errorFromIO $ hPutStrLn stderr $ "Executing: " ++ intercalate " " (c:os)-  pid    <- errorFromIO $ forkProcess $ executeFile c True os Nothing+  hPutStrLn stderr $ "Executing: " ++ intercalate " " (c:os)+  forkProcess $ executeFile c True os Nothing++waitProcess :: (MonadIO m, ErrorContextM m) => ProcessID -> m Bool+waitProcess pid = do+  status <- errorFromIO $ getProcessStatus False True pid+  case status of+       Nothing -> return False+       Just (Exited ExitSuccess) -> return True+       _ -> do+         errorFromIO $ hPutStrLn stderr $ "Command execution failed"+         compilerErrorM $ "Command execution failed"++blockProcess :: (MonadIO m, ErrorContextM m) => ProcessID -> m ()+blockProcess pid = do   status <- errorFromIO $ getProcessStatus True True pid   case status of        Just (Exited ExitSuccess) -> return ()        _ -> do-         errorFromIO $ hPutStrLn stderr $ "Execution of " ++ c ++ " failed"-         compilerErrorM $ "Execution of " ++ c ++ " failed"+         errorFromIO $ hPutStrLn stderr $ "Command execution failed"+         compilerErrorM $ "Command execution failed"  instance PathIOHandler Resolver where   resolveModule r p m = do

@@ -18,6 +18,7 @@  module Module.CompileMetadata (   CategoryIdentifier(..),+  CategorySpec(..),   CompileMetadata(..),   ModuleConfig(..),   ObjectFile(..),@@ -32,7 +33,7 @@ import Cli.Programs (VersionHash) import Parser.TextParser (SourceContext) import Types.Procedure (Expression,MacroName)-import Types.TypeCategory (Namespace)+import Types.TypeCategory import Types.TypeInstance (CategoryName)  @@ -101,6 +102,14 @@ getObjectFiles (CategoryObjectFile _ _ os) = os getObjectFiles (OtherObjectFile o)         = [o] +data CategorySpec c =+  CategorySpec {+    csContext :: [c],+    csRefines :: [ValueRefine c],+    csDefines :: [ValueDefine c]+  }+  deriving (Show)+ data ModuleConfig =   ModuleConfig {     mcRoot :: FilePath,@@ -110,13 +119,14 @@     mcPublicDeps :: [FilePath],     mcPrivateDeps :: [FilePath],     mcExtraFiles :: [ExtraSource],+    mcCategories :: [(CategoryName,CategorySpec SourceContext)],     mcExtraPaths :: [FilePath],     mcMode :: CompileMode   }   deriving (Show)  instance Eq ModuleConfig where-  (ModuleConfig pA dA eeA _ isA is2A esA epA mA) == (ModuleConfig pB dB eeB _ isB is2B esB epB mB) =+  (ModuleConfig pA dA eeA _ isA is2A esA cA epA mA) == (ModuleConfig pB dB eeB _ isB is2B esB cB epB mB) =     all id [         pA == pB,         eeA == eeB,@@ -124,6 +134,9 @@         isA == isB,         is2A == is2B,         esA == esB,+        map fst cA == map fst cB,+        map (map vrType . csRefines . snd) cA == map (map vrType . csRefines . snd) cB,+        map (map vdType . csDefines . snd) cA == map (map vdType . csDefines . snd) cB,         epA == epB,         mA == mB       ]

@@ -16,6 +16,8 @@  -- Author: Kevin P. Barry [ta0kira@gmail.com] +{-# LANGUAGE FlexibleInstances #-}+ module Module.ParseMetadata (   ConfigFormat(..),   autoReadConfig,@@ -45,7 +47,7 @@ import Parser.TypeInstance () import Text.Regex.TDFA import Types.Procedure (Expression,MacroName)-import Types.TypeCategory (FunctionName(..),Namespace(..))+import Types.TypeCategory import Types.TypeInstance (CategoryName(..))  @@ -288,19 +290,21 @@  instance ConfigFormat ModuleConfig where   readConfig = runPermutation $ ModuleConfig-    <$> parseOptional "root:"           "" parseQuoted-    <*> parseRequired "path:"              parseQuoted-    <*> parseOptional "extra_paths:"    [] (parseList parseQuoted)-    <*> parseOptional "expression_map:" [] (parseList parseExprMacro)-    <*> parseOptional "public_deps:"    [] (parseList parseQuoted)-    <*> parseOptional "private_deps:"   [] (parseList parseQuoted)-    <*> parseOptional "extra_files:"    [] (parseList readConfig)-    <*> parseOptional "include_paths:"  [] (parseList parseQuoted)-    <*> parseRequired "mode:"              readConfig-  writeConfig (ModuleConfig p d ee em is is2 es ep m) = do+    <$> parseOptional "root:"            "" parseQuoted+    <*> parseRequired "path:"               parseQuoted+    <*> parseOptional "extra_paths:"     [] (parseList parseQuoted)+    <*> parseOptional "expression_map:"  [] (parseList parseExprMacro)+    <*> parseOptional "public_deps:"     [] (parseList parseQuoted)+    <*> parseOptional "private_deps:"    [] (parseList parseQuoted)+    <*> parseOptional "extra_files:"     [] (parseList readConfig)+    <*> parseOptional "extension_specs:" [] (parseList readConfig)+    <*> parseOptional "include_paths:"   [] (parseList parseQuoted)+    <*> parseRequired "mode:"               readConfig+  writeConfig (ModuleConfig p d ee em is is2 es cs ep m) = do     es' <- fmap concat $ mapCompilerM writeConfig es     m' <- writeConfig m     when (not $ null em) $ compilerErrorM "Only empty expression maps are allowed when writing"+    cs' <- fmap concat $ mapCompilerM writeConfig cs     return $ [         "root: " ++ show p,         "path: " ++ show d,@@ -320,6 +324,9 @@         "extra_files: ["       ] ++ indents es' ++ [         "]",+        "extension_specs: ["+      ] ++ indents cs' ++ [+        "]",         "include_paths: ["       ] ++ indents (map show ep) ++ [         "]"@@ -354,6 +361,38 @@         "}"       ]   writeConfig (OtherSource f) = return [show f]++instance ConfigFormat (CategoryName,CategorySpec SourceContext) where+  readConfig = do+    c <- getSourceContext+    sepAfter (string_ "category")+    structOpen+    s <- runPermutation $ (\n rs ds -> (n,CategorySpec [c] rs ds))+      <$> parseRequired "name:"       sourceParser+      <*> parseOptional "refines:" [] (parseList parseRefine)+      <*> parseOptional "defines:" [] (parseList parseDefine)+    structClose+    return s where+      parseRefine = do+        c <- getSourceContext+        t <- sourceParser+        return $ ValueRefine [c] t+      parseDefine = do+        c <- getSourceContext+        t <- sourceParser+        return $ ValueDefine [c] t+  writeConfig (n,CategorySpec _ rs ds) = do+    return $ [+        "category {",+        indent ("name: " ++ show n),+        indent "refines: ["+      ] ++ (indents . indents . map (show . vrType)) rs ++ [+        indent "]",+        indent "defines: ["+      ] ++ (indents . indents . map (show . vdType)) ds ++ [+        indent "]",+        "}"+      ]  instance ConfigFormat CompileMode where   readConfig = labeled "compile mode" $ binary <|> incremental where

@@ -18,6 +18,7 @@  module Module.ProcessMetadata (   MetadataMap,+  createCachedDir,   createCachePath,   eraseCachedData,   findSourceFiles,@@ -181,6 +182,13 @@   let f = p </> cachedDataPath   exists <- errorFromIO $ doesDirectoryExist f   when (not exists) $ errorFromIO $ createDirectoryIfMissing False f++createCachedDir :: FilePath -> FilePath -> TrackedErrorsIO FilePath+createCachedDir p d = do+  createCachePath p+  let d2 = p </> cachedDataPath </> d+  errorFromIO $ createDirectoryIfMissing False d2+  return d2  writeCachedFile :: FilePath -> String -> FilePath -> String -> TrackedErrorsIO () writeCachedFile p ns f c = do

@@ -49,7 +49,7 @@     return $ DefinedCategory [c] n pragmas ds rs ms ps fs     where       parseRefinesDefines = fmap merge2 $ sepBy refineOrDefine optionalSpace-      singlePragma = readOnly <|> hidden <|> flatCleanup+      singlePragma = readOnly <|> readOnlyExcept <|> hidden <|> flatCleanup       flatCleanup = autoPragma "FlatCleanup" $ Right parseAt where         parseAt c = do           v <- labeled "variable name" sourceParser@@ -58,6 +58,10 @@         parseAt c = do           vs <- labeled "variable names" $ sepBy sourceParser (sepAfter $ string ",")           return $ MembersReadOnly [c] vs+      readOnlyExcept = autoPragma "ReadOnlyExcept" $ Right parseAt where+        parseAt c = do+          vs <- labeled "variable names" $ sepBy sourceParser (sepAfter $ string ",")+          return $ MembersReadOnlyExcept [c] vs       hidden = autoPragma "Hidden" $ Right parseAt where         parseAt c = do           vs <- labeled "variable names" $ sepBy sourceParser (sepAfter $ string ",")

@@ -30,8 +30,8 @@ import System.FilePath import Test.Common import Types.Procedure-import Types.TypeCategory (FunctionName(..),Namespace(..))-import Types.TypeInstance (CategoryName(..))+import Types.TypeCategory+import Types.TypeInstance   hugeCompileMetadata :: CompileMetadata  -- testfiles/module-cache.txt@@ -159,6 +159,30 @@         osSource = "extra2.cpp"       }     ],+    mcCategories = [+      (CategoryName "Category1",CategorySpec {+        csContext = [],+        csRefines = [+          ValueRefine [] (TypeInstance (CategoryName "Base1") (Positional [])),+          ValueRefine [] (TypeInstance (CategoryName "Base2") (Positional []))+        ],+        csDefines = [+          ValueDefine [] (DefinesInstance (CategoryName "Base3") (Positional [])),+          ValueDefine [] (DefinesInstance (CategoryName "Base4") (Positional []))+        ]+      }),+      (CategoryName "Category2",CategorySpec {+        csContext = [],+        csRefines = [+          ValueRefine [] (TypeInstance (CategoryName "Base1") (Positional [])),+          ValueRefine [] (TypeInstance (CategoryName "Base2") (Positional []))+        ],+        csDefines = [+          ValueDefine [] (DefinesInstance (CategoryName "Base3") (Positional [])),+          ValueDefine [] (DefinesInstance (CategoryName "Base4") (Positional []))+        ]+      })+    ],     mcExtraPaths = [       "extra1",       "extra2"@@ -309,6 +333,7 @@       mcPublicDeps = [],       mcPrivateDeps = [],       mcExtraFiles = [],+      mcCategories = [],       mcExtraPaths = [],       mcMode = CompileIncremental {         ciLinkFlags = []

@@ -23,6 +23,18 @@   "extra1"   "extra2" ]+extension_specs: [+  category {+    name: Category1+    refines: [Base1 Base2]+    defines: [Base3 Base4]+  }+  category {+    name: Category2+    refines: [Base1 Base2]+    defines: [Base3 Base4]+  }+] path: "special" extra_files: [   category_source {

@@ -28,6 +28,7 @@   isFlatCleanup,   isMembersHidden,   isMembersReadOnly,+  isMembersReadOnlyExcept,   mapMembers,   mergeInternalInheritance,   pairProceduresToFunctions,@@ -39,11 +40,13 @@ import qualified Data.Set as Set  import Base.CompilerError+import Base.GeneralType import Base.Positional import Types.Function import Types.Procedure import Types.TypeCategory import Types.TypeInstance+import Types.Variance   data DefinedCategory c =@@ -79,6 +82,10 @@     mroContext :: [c],     mroMembers :: [VariableName]   } |+  MembersReadOnlyExcept {+    mroeContext :: [c],+    mroeMembers :: [VariableName]+  } |   MembersHidden {     mhContext :: [c],     mhMembers :: [VariableName]@@ -93,6 +100,10 @@ isMembersReadOnly (MembersReadOnly _ _) = True isMembersReadOnly _                     = False +isMembersReadOnlyExcept :: PragmaDefined c -> Bool+isMembersReadOnlyExcept (MembersReadOnlyExcept _ _) = True+isMembersReadOnlyExcept _                           = False+ isMembersHidden :: PragmaDefined c -> Bool isMembersHidden (MembersHidden _ _) = True isMembersHidden _                   = False@@ -218,7 +229,7 @@ -- TODO: Most of this duplicates parts of flattenAllConnections. mergeInternalInheritance :: (Show c, CollectErrorsM m) =>   CategoryMap c -> DefinedCategory c -> m (CategoryMap c)-mergeInternalInheritance tm d = do+mergeInternalInheritance tm d = "In definition of " ++ show (dcName d) ++ formatFullContextBrace (dcContext d) ??> do   let rs2 = dcRefines d   let ds2 = dcDefines d   (_,t@(ValueConcrete c ns n pg ps rs ds vs fs)) <- getConcreteCategory tm (dcContext d,dcName d)@@ -227,10 +238,14 @@   let r = CategoryResolver tm'   fm <- getCategoryFilterMap t   let pm = getCategoryParamMap t-  rs' <- mergeRefines r fm (rs++rs2)-  noDuplicateRefines [] n rs'+  rs2' <- fmap concat $ mapCompilerM (flattenRefine r) rs2+  rs' <- mergeRefines r fm (rs++rs2')+  noDuplicateRefines (dcContext d) n rs'   ds' <- mergeDefines r fm (ds++ds2)-  noDuplicateDefines [] n ds'+  noDuplicateDefines (dcContext d) n ds'+  let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) ps+  mapCompilerM_ (checkRefinesVariance r vm) rs2+  mapCompilerM_ (checkDefinesVariance r vm) ds2   pg2 <- fmap concat $ mapCompilerM getRefinesPragmas rs2   pg3 <- fmap concat $ mapCompilerM getDefinesPragmas ds2   let fs2 = mergeInternalFunctions fs (dcFunctions d)@@ -262,6 +277,19 @@                sfFilters = sfFilters f,                sfMerges = sfMerges f ++ [f2]              }) fm+    checkRefinesVariance r vm (ValueRefine c t) =+      validateInstanceVariance r vm Covariant (singleType $ JustTypeInstance t) <??+        "In " ++ show t ++ formatFullContextBrace c+    checkDefinesVariance r vm (ValueDefine c t) =+      validateDefinesVariance r vm Covariant t <??+        "In " ++ show t ++ formatFullContextBrace c+    flattenRefine r ra@(ValueRefine c t) = do+      (_,t2) <- getValueCategory tm (c,tiName t)+      rs <- mapCompilerM (singleRefine r ra) (getCategoryRefines t2)+      return (ra:rs)+    singleRefine r (ValueRefine c t) (ValueRefine c2 t2) = do+      ps <- trRefines r t (tiName t2)+      return $ ValueRefine (c++c2) (TypeInstance (tiName t2) ps)  replaceSelfMember :: (Show c, CollectErrorsM m) =>   GeneralInstance -> DefinedMember c -> m (DefinedMember c)

@@ -84,6 +84,7 @@   prependCategoryPragmaContext,   replaceSelfFunction,   setCategoryNamespace,+  singleFromCategory,   topoSortCategories,   uncheckedSubFunction,   validateCategoryFunction,@@ -91,7 +92,7 @@  import Control.Arrow (second) import Control.Monad ((>=>),foldM,when)-import Data.List (group,groupBy,intercalate,nub,nubBy,sort,sortBy)+import Data.List (group,intercalate,nub,nubBy,sort) import qualified Data.Map as Map import qualified Data.Set as Set @@ -248,11 +249,14 @@ getCategoryFunctions (InstanceInterface _ _ _ _ _ fs)   = fs getCategoryFunctions (ValueConcrete _ _ _ _ _ _ _ _ fs) = fs -instanceFromCategory :: AnyCategory c -> GeneralInstance-instanceFromCategory t = singleType $ JustTypeInstance $ TypeInstance n (Positional ps) where+singleFromCategory :: AnyCategory c -> TypeInstance+singleFromCategory t = TypeInstance n (Positional ps) where   n = getCategoryName t   ps = map (singleType . JustParamName True . vpParam) $ getCategoryParams t +instanceFromCategory :: AnyCategory c -> GeneralInstance+instanceFromCategory = singleType . JustTypeInstance . singleFromCategory+ getCategoryDeps :: AnyCategory c -> Set.Set CategoryName getCategoryDeps t = Set.fromList $ filter (/= getCategoryName t) $ refines ++ defines ++ filters ++ functions where   refines = concat $ map (fromInstance . singleType . JustTypeInstance . vrType) $ getCategoryRefines t@@ -779,14 +783,14 @@  noDuplicateCategories :: (Show c, Show a, CollectErrorsM m) =>   [c] -> CategoryName -> [(CategoryName,a)] -> m ()-noDuplicateCategories c n ns =-  mapCompilerM_ checkCount $ groupBy (\x y -> fst x == fst y) $-                               sortBy (\x y -> fst x `compare` fst y) ns where-    checkCount xa@(x:_:_) =-      compilerErrorM $ "Category " ++ show (fst x) ++ " occurs " ++ show (length xa) ++-                       " times in " ++ show n ++ formatFullContextBrace c ++ " :\n---\n" ++-                       intercalate "\n---\n" (map (show . snd) xa)-    checkCount _ = return ()+noDuplicateCategories c n ns = do+  let byName = Map.fromListWith (++) $ map (second (:[])) ns+  mapCompilerM_ checkCount $ Map.toList byName where+    checkCount (_,[_]) = return ()+    checkCount (n2,xs) =+      compilerErrorM $ show n2 ++ " occurs " ++ show (length xs) +++                       " times in " ++ show n ++ formatFullContextBrace c ++ ":\n---\n" +++                       intercalate "\n---\n" (map show xs)  flattenAllConnections :: (Show c, CollectErrorsM m) =>   CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]

@@ -36,4 +36,19 @@   "visibility"   "visibility2" ]+extra_files: [+  // See extension.0rp and extension.0rt.+  category_source {+    source: "tests/Extension_Extension.cpp"+    categories: [Extension]+  }+]+extension_specs: [+  // See extension.0rp and extension.0rt.+  category {+    name: Extension+    refines: [Formatted]+    defines: [Default]+  }+] mode: incremental {}

@@ -0,0 +1,80 @@+/* -----------------------------------------------------------------------------+Copyright 2021 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]++#include "category-source.hpp"+#include "Streamlined_Extension.hpp"+#include "Category_Default.hpp"+#include "Category_Extension.hpp"+#include "Category_Formatted.hpp"+#include "Category_String.hpp"++#ifdef ZEOLITE_PRIVATE_NAMESPACE+namespace ZEOLITE_PRIVATE_NAMESPACE {+#endif  // ZEOLITE_PRIVATE_NAMESPACE++BoxedValue CreateValue_Extension(S<const Type_Extension> parent, const ParamsArgs& params_args);++struct ExtCategory_Extension : public Category_Extension {+};++struct ExtType_Extension : public Type_Extension {+  inline ExtType_Extension(Category_Extension& p, Params<0>::Type params) : Type_Extension(p, params) {}++  ReturnTuple Call_default(const ParamsArgs& params_args) const final {+    TRACE_FUNCTION("Extension.default")+    return ReturnTuple(CreateValue_Extension(PARAM_SELF, PassParamsArgs(Box_String("message"))));+  }++  ReturnTuple Call_execute(const ParamsArgs& params_args) const final {+    TRACE_FUNCTION("Extension.execute")+    BoxedValue value = TypeInstance::Call(PARAM_SELF, Function_Default_default, PassParamsArgs()).At(0);+    return TypeValue::Call(value, Function_Formatted_formatted, PassParamsArgs());+  }+};++struct ExtValue_Extension : public Value_Extension {+  inline ExtValue_Extension(S<const Type_Extension> p, const ParamsArgs& params_args)+    : Value_Extension(std::move(p)), value_(params_args.GetArg(0).AsString()) {}++  ReturnTuple Call_formatted(const ParamsArgs& params_args) final {+    TRACE_FUNCTION("Extension.formatted")+    return ReturnTuple(Box_String(value_));+  }++  const PrimString value_;+};++Category_Extension& CreateCategory_Extension() {+  static auto& category = *new ExtCategory_Extension();+  return category;+}++S<const Type_Extension> CreateType_Extension(const Params<0>::Type& params) {+  static const auto cached = S_get(new ExtType_Extension(CreateCategory_Extension(), Params<0>::Type()));+  return cached;+}++void RemoveType_Extension(const Params<0>::Type& params) {}+BoxedValue CreateValue_Extension(S<const Type_Extension> parent, const ParamsArgs& params_args) {+  return BoxedValue::New<ExtValue_Extension>(std::move(parent), params_args);+}++#ifdef ZEOLITE_PRIVATE_NAMESPACE+}  // namespace ZEOLITE_PRIVATE_NAMESPACE+using namespace ZEOLITE_PRIVATE_NAMESPACE;+#endif  // ZEOLITE_PRIVATE_NAMESPACE

@@ -29,6 +29,12 @@  ZEOLITE=("$@") +if [[ "$PARALLEL" ]]; then+  PARALLEL="-j $PARALLEL"+else+  PARALLEL='-j 1'+fi+ show_message() {   echo -e "[$PROGRAM]" "$@" 1>&2 }@@ -54,7 +60,7 @@   test_bad_path() {-  local output=$(do_zeolite -p "$ZEOLITE_PATH" -r tests/bad-path -f || true)+  local output=$(do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/bad-path -f || true)   if ! echo "$output" | egrep -q 'bad-path/\.zeolite-module .+ /dev/null'; then     show_message 'Expected path error from tests/bad-path:'     echo "$output" 1>&2@@ -64,7 +70,7 @@   test_check_defs() {-  local output=$(do_zeolite -p "$ZEOLITE_PATH" -r tests/check-defs -f || true)+  local output=$(do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/check-defs -f || true)   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@@ -118,7 +124,7 @@   rm -f "$ZEOLITE_PATH/tests/freshness"/{,sub1/,sub2/}{public3.0rp,source3.0rx,test3.0rt}    # Compile and test normally.-  do_zeolite -p "$ZEOLITE_PATH" -R tests/freshness/reverse -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -R tests/freshness/reverse -f   do_zeolite -p "$ZEOLITE_PATH" -t tests/freshness/reverse    # Modify the module's files.@@ -185,7 +191,7 @@ END [[ $? -eq 0 ]] || return 1 -  do_zeolite -p "$ZEOLITE_PATH" -r tests/freshness+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/freshness    local output=$(do_zeolite -p "$ZEOLITE_PATH" -t tests/freshness/reverse || true)   require_patterns "$output" <<END@@ -210,7 +216,7 @@ test_leak_check() {   local binary="$ZEOLITE_PATH/tests/leak-check/LeakTest"   rm -f "$binary"-  do_zeolite -p "$ZEOLITE_PATH" -r tests/leak-check -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/leak-check -f   # race-condition check   # NOTE: If this fails, the valgrind check will be skipped.   local output=$(execute "$binary" 'race' || true)@@ -237,7 +243,7 @@   test_simulate_refs() {-  do_zeolite -p "$ZEOLITE_PATH" -r tests/simulate-refs -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/simulate-refs -f }  @@ -352,13 +358,13 @@   test_module_only4() {-  do_zeolite -p "$ZEOLITE_PATH" -r tests/module-only4 -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/module-only4 -f   do_zeolite -p "$ZEOLITE_PATH" -t tests/module-only4 }   test_warn_public() {-  local output=$(do_zeolite -p "$ZEOLITE_PATH" -R tests/warn-public -f)+  local output=$(do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -R tests/warn-public -f)   if ! echo "$output" | egrep -q '"internal" .+ public'; then     show_message 'Expected "internal" dependency warning from tests/warn-public:'     echo "$output" 1>&2@@ -373,7 +379,7 @@   test_self_offset() {-  do_zeolite -p "$ZEOLITE_PATH" -r tests/self-offset -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/self-offset -f   do_zeolite -p "$ZEOLITE_PATH" -t tests/self-offset } @@ -381,7 +387,7 @@ test_templates() {   execute rm -f $ZEOLITE_PATH/tests/templates/Extension_*.cpp   do_zeolite -p "$ZEOLITE_PATH" --templates tests/templates-  do_zeolite -p "$ZEOLITE_PATH" -r tests/templates+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/templates   do_zeolite -p "$ZEOLITE_PATH" -t tests/templates } @@ -403,7 +409,7 @@   test_fast_static() {-  do_zeolite -p "$ZEOLITE_PATH/tests/fast-static" -I lib/util --fast Program program.0rx+  do_zeolite -p "$ZEOLITE_PATH/tests/fast-static" $PARALLEL -I lib/util --fast Program program.0rx   local output=$(execute "$ZEOLITE_PATH/tests/fast-static/Program")   if ! echo "$output" | fgrep -xq 'Static linking works!'; then     show_message 'Expected "Static linking works!" in program output:'@@ -451,7 +457,7 @@   local binary="$ZEOLITE_PATH/example/hello/HelloDemo"   local name='Cli Tests'   rm -f "$binary"-  do_zeolite -p "$ZEOLITE_PATH/example/hello" -I lib/util --fast HelloDemo hello-demo.0rx+  do_zeolite -p "$ZEOLITE_PATH/example/hello" $PARALLEL -I lib/util --fast HelloDemo hello-demo.0rx   local output=$(echo "$name" | execute_noredir "$binary" 2>&1)   if ! echo "$output" | egrep -q "\"$name\""; then     show_message "Expected \"$name\" in HelloDemo output:"@@ -462,7 +468,7 @@   test_example_parser() {-  do_zeolite -p "$ZEOLITE_PATH" -r example/parser -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r example/parser -f   do_zeolite -p "$ZEOLITE_PATH" -t example/parser } @@ -472,7 +478,7 @@   local expected='2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109,113,127,131,137,139,149,151,157,163,167,173,179,181,191,193,197,199,211,223,227,229,233,239,241,251,257,263,269,271,277,281,283,293,307,311,313,317,331,337,347,349,353,359,367,373,379,383,389,397,401,409,419,421,431,433,439,443,449,457,461,463,467,479,487,491,499,503,509,521,523,541,'   rm -f "$binary"   local temp=$(execute mktemp)-  do_zeolite -p "$ZEOLITE_PATH" -r example/primes -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r example/primes -f   {     echo;     sleep 0.1;@@ -493,7 +499,7 @@   local binary="$ZEOLITE_PATH/example/random/RandomDemo"   rm -f "$binary"   local temp=$(execute mktemp)-  do_zeolite -p "$ZEOLITE_PATH" -r example/random -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r example/random -f   execute_noredir "$binary" 5 > "$temp"   local output=$(cat "$temp")   rm -f "$temp"@@ -506,7 +512,7 @@   test_traces() {-  do_zeolite -p "$ZEOLITE_PATH" -r tests/traces -f+  do_zeolite -p "$ZEOLITE_PATH" $PARALLEL -r tests/traces -f   local source_files=("$ZEOLITE_PATH/tests/traces/traces.0rx")   local expected=$(fgrep -n '// TRACED' "${source_files[@]}" | egrep -o '^[0-9]+' | sort -u)   local actual=$(do_zeolite -p "$ZEOLITE_PATH" --show-traces "tests/traces" | grep 0rx | sed -r 's/^line ([0-9]+).*/\1/' | sort -u)

@@ -0,0 +1,23 @@+/* -----------------------------------------------------------------------------+Copyright 2021 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$++concrete Extension {+  @type execute () -> (String)+}

@@ -0,0 +1,25 @@+/* -----------------------------------------------------------------------------+Copyright 2021 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]++testcase "internal refines/defines work for C++ extension" {+  success+}++unittest test {+  \ Testing.checkEquals(Extension.execute(),"message")+}

@@ -272,64 +272,149 @@ }  -testcase "call from intersect" {+testcase "call from intersect failed merge" {+  error+  require "\[Base<AsBool>&Base<Formatted>\]"+  require "get"+  require "[Mm]ultiple"+}++unittest test {+  [Base<AsBool>&Base<Formatted>] value <- Value1.create()+  \ value.get()+}++@value interface Base<|#x> {+  get () -> (#x)+}++concrete Value1 {+  refines Base<Int>+  @type create () -> (Value1)+}++define Value1 {+  get () {+    return 1+  }++  create () {+    return Value1{ }+  }+}++concrete Value2 {+  refines Base<String>+  @type create () -> (Value2)+}++define Value2 {+  get () {+    return "message"+  }++  create () {+    return Value2{ }+  }+}+++testcase "call from intersect bad function name" {+  error+  require "\[AsBool&Formatted\]"+  require "asFloat"+}++unittest test {+  [AsBool&Formatted] value <- 1+  \ value.asFloat()+}+++testcase "call from intersect automatic merge" {   success }  unittest test {-  [Base1&Base2] value <- Value.create()-  \ value.call()+  [Base<Int>&Base<Formatted>] value <- Value1.create()+  \ Testing.checkEquals(value.get(),1) } -@value interface Base1 {-  call () -> ()+@value interface Base<|#x> {+  get () -> (#x) } -@value interface Base2 {}+concrete Value1 {+  refines Base<Int>+  @type create () -> (Value1)+} -concrete Value {-  refines Base1-  refines Base2+define Value1 {+  get () {+    return 1+  } -  @type create () -> (Value)+  create () {+    return Value1{ }+  } } -define Value {-  call () {}+concrete Value2 {+  refines Base<String>+  @type create () -> (Value2)+} +define Value2 {+  get () {+    return "message"+  }+   create () {-    return Value{}+    return Value2{ }   } }  -testcase "call from intersect with conversion" {+testcase "call from intersect explicit conversion" {   success }  unittest test {-  [Base1&Base2] value <- Value.create()-  \ value?Base1.call()+  [Base<AsBool>&Base<Formatted>] value <- Value1.create()+  \ Testing.checkEquals(value?Base<Formatted>.get().formatted(),"1") } -@value interface Base1 {-  call () -> ()+@value interface Base<|#x> {+  get () -> (#x) } -@value interface Base2 {}+concrete Value1 {+  refines Base<Int>+  @type create () -> (Value1)+} -concrete Value {-  refines Base1-  refines Base2+define Value1 {+  get () {+    return 1+  } -  @type create () -> (Value)+  create () {+    return Value1{ }+  } } -define Value {-  call () {}+concrete Value2 {+  refines Base<String>+  @type create () -> (Value2)+} +define Value2 {+  get () {+    return "message"+  }+   create () {-    return Value{}+    return Value2{ }   } } @@ -387,6 +472,7 @@ concrete Test {}  + testcase "call from param value" {   success }@@ -701,28 +787,6 @@ }  -testcase "multiple mergeable @value functions match from intersection" {-  compiles-}--@value interface Type1 {-  execute (Int) -> ()-}--@value interface Type2 {-  execute (Formatted) -> ()-}--concrete Test {}--define Test {-  @type test ([Type1&Type2]) -> ()-  test (x) {-    \ x.execute("message")-  }-}-- testcase "multiple mergeable @type functions match from filters" {   compiles }@@ -769,30 +833,6 @@     #x requires Type1     #x requires Type2   (#x) -> ()-  test (x) {-    \ x.execute()-  }-}---testcase "multiple unmergeable @value functions match from intersection" {-  error-  require "[Mm]ultiple"-  require "execute"-}--@value interface Type1 {-  execute () -> (Int)-}--@value interface Type2 {-  execute () -> (String)-}--concrete Test {}--define Test {-  @type test ([Type1&Type2]) -> ()   test (x) {     \ x.execute()   }

@@ -1,5 +1,5 @@ /* ------------------------------------------------------------------------------Copyright 2020 Kevin P. Barry+Copyright 2020-2021 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.@@ -212,5 +212,77 @@   @value get () -> (Int)   get () {     return value+  }+}+++testcase "internal inheritance wrong interface type" {+  error+  require "Base"+  require "type interface"+}++@value interface Base {}++concrete Type {}++define Type {+  defines Base+}+++testcase "internal inheritance bad refines variance" {+  error+  require "#x.+invariant"+  exclude "call"+}++@value interface Base<#x> {+  call (#x) -> ()+}++concrete Type<|#x> {}++define Type {+  refines Base<#x>+}+++testcase "internal inheritance bad defines variance" {+  error+  require "#x.+invariant"+  exclude "call"+}++@type interface Base<#x> {+  call (#x) -> ()+}++concrete Type<|#x> {}++define Type {+  defines Base<#x>+}+++testcase "indirect internal inheritance flattened correctly" {+  compiles+}++@value interface Base1<#x> {}++@value interface Base2<#x> {+  refines Base1<#x>+}++concrete Type<#x> {+  @type new () -> (Base1<Type<#x>>)+}++define Type {+  refines Base2<Type<#x>>++  new () {+    return Type<#x>{ }   } }

@@ -79,7 +79,7 @@ }  define LastReference {-  $ReadOnly[copy,barrier]$+  $ReadOnlyExcept[]$    refines Routine 

@@ -426,3 +426,101 @@     return foo   } }+++testcase "ReadOnlyExcept applies to @category members" {+  error+  require "foo.+read-only"+  exclude "bar"+}++concrete Type {}++define Type {+  $ReadOnlyExcept[bar]$++  @category Int foo <- 123+  @category Int bar <- 123++  @category call () -> ()+  call () {+    bar <- 456+    foo <- 456+  }+}+++testcase "ReadOnlyExcept applies to @value members" {+  error+  require "foo.+read-only"+  exclude "bar"+}++concrete Type {}++define Type {+  $ReadOnlyExcept[bar]$++  @value Int foo+  @value Int bar++  @value call () -> ()+  call () {+    bar <- 456+    foo <- 456+  }+}+++testcase "ReadOnlyExcept plus ReadOnly results in read-only" {+  error+  require "foo.+read-only"+}++concrete Type {}++define Type {+  $ReadOnlyExcept[foo]$+  $ReadOnly[foo]$++  @value Int foo++  @value call () -> ()+  call () {+    foo <- 456+  }+}+++testcase "ReadOnlyExcept unions rather than interscts" {+  compiles+  require compiler "ReadOnlyExcept"+}++concrete Type {}++define Type {+  $ReadOnlyExcept[foo]$+  $ReadOnlyExcept[bar]$++  @value Int foo+  @value Int bar++  @value call () -> ()+  call () {+    bar <- 456+    foo <- 456+  }+}+++testcase "Bad name for ReadOnlyExcept @category member" {+  error+  require "foo.+does not exist"+}++concrete Type {}++define Type {+  $ReadOnlyExcept[foo]$+}

@@ -781,3 +781,54 @@ unittest unionToIntersect {   \ Testing.checkFalse(present(reduce<[A|B],[A&B]>(AB.create()))) }+++testcase "parent param contains meta type" {+  success+}++unittest test {+  \ Testing.checkTrue(present(reduce<Type,Build<AsBool>>(Type.new())))+  \ Testing.checkTrue(present(reduce<Type,Build<ReadAt<Char>>>(Type.new())))+  \ Testing.checkFalse(present(reduce<Type,Build<String>>(Type.new())))+}++concrete Type {+  refines Build<[AsBool&ReadAt<Char>]>++  @type new () -> (Type)+}++define Type {+  new () { return Type{ } }+  build () { return "message" }+}+++testcase "parent param contains #self" {+  success+}++unittest test {+  \ Testing.checkTrue(present(reduce<Type,Order<Type>>(Type.new())))+  \ Testing.checkTrue(present(reduce<Type,Order<Order<Type>>>(Type.new())))+  \ Testing.checkFalse(present(reduce<Type,Build<Type>>(Type.new())))+  \ Testing.checkTrue(present(reduce<Type,Build<Order<Type>>>(Type.new())))+  \ Testing.checkTrue(present(reduce<Type,Order<Formatted>>(Type.new())))+}++concrete Type {+  refines Order<#self>+  refines Build<Order<Type>>+  refines Formatted++  @type new () -> (Type)+}++define Type {+  new () { return Type{ } }+  build () { return self }+  get () { return self }+  next () { return self }+  formatted () { return "Type" }+}

@@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com]  define Routines {-  $ReadOnly[dropShared,dropSharedBroken,dropWeak,sharedThenDrop,sharedThenDropBroken,name,state]$+  $ReadOnlyExcept[machine]$    refines StateMachine 

@@ -1,7 +1,7 @@ cabal-version:       2.2  name:                zeolite-lang-version:             0.22.0.0+version:             0.22.1.0 synopsis:            Zeolite is a statically-typed, general-purpose programming language.  description:@@ -33,6 +33,9 @@     .     # Or just choose the 1st match for each.     zeolite-setup 1 1+    .+    # Use -j n before other options to execute n steps at a time in parallel.+    zeolite-setup -j 4     @     .   * (Optional) As a sanity check, compile and run@@ -136,6 +139,7 @@                      tests/*.0rp,                      tests/*.0rt,                      tests/*.0rx,+                     tests/*.cpp,                      tests/*.sh,                      tests/bad-path/README.md,                      tests/bad-path/.zeolite-module,