diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/base/src/boxed.cpp b/base/src/boxed.cpp --- a/base/src/boxed.cpp +++ b/base/src/boxed.cpp @@ -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 diff --git a/bin/zeolite-setup.hs b/bin/zeolite-setup.hs --- a/bin/zeolite-setup.hs +++ b/bin/zeolite-setup.hs @@ -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 diff --git a/bin/zeolite.hs b/bin/zeolite.hs --- a/bin/zeolite.hs +++ b/bin/zeolite.hs @@ -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' diff --git a/example/parser/test-data.0rx b/example/parser/test-data.0rx --- a/example/parser/test-data.0rx +++ b/example/parser/test-data.0rx @@ -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, diff --git a/lib/container/interfaces.0rp b/lib/container/interfaces.0rp --- a/lib/container/interfaces.0rp +++ b/lib/container/interfaces.0rp @@ -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: diff --git a/lib/container/queue.0rp b/lib/container/queue.0rp new file mode 100644 --- /dev/null +++ b/lib/container/queue.0rp @@ -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) +} diff --git a/lib/container/src/auto-tree.0rx b/lib/container/src/auto-tree.0rx --- a/lib/container/src/auto-tree.0rx +++ b/lib/container/src/auto-tree.0rx @@ -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 diff --git a/lib/container/src/queue.0rx b/lib/container/src/queue.0rx new file mode 100644 --- /dev/null +++ b/lib/container/src/queue.0rx @@ -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 + } +} diff --git a/lib/container/src/sorting.0rx b/lib/container/src/sorting.0rx --- a/lib/container/src/sorting.0rx +++ b/lib/container/src/sorting.0rx @@ -84,7 +84,7 @@ } define HeapSort { - $ReadOnly[seq,compare]$ + $ReadOnlyExcept[]$ @value [ReadAt<#x>&WriteAt<#x>] seq @value LessThan2<#x> compare diff --git a/lib/container/src/type-map.0rx b/lib/container/src/type-map.0rx --- a/lib/container/src/type-map.0rx +++ b/lib/container/src/type-map.0rx @@ -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 diff --git a/lib/container/src/wrappers.0rx b/lib/container/src/wrappers.0rx --- a/lib/container/src/wrappers.0rx +++ b/lib/container/src/wrappers.0rx @@ -17,7 +17,7 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] define SimpleKeyValue { - $ReadOnly[key,value]$ + $ReadOnlyExcept[]$ refines KeyValue<#k,#v> diff --git a/lib/container/test/queue.0rt b/lib/container/test/queue.0rt new file mode 100644 --- /dev/null +++ b/lib/container/test/queue.0rt @@ -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 queue <- SimpleQueue.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 queue <- `Counter.zeroIndexed` max `OrderH:copyTo` SimpleQueue.new() + SimpleQueue 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) +} diff --git a/lib/math/src/random.0rx b/lib/math/src/random.0rx --- a/lib/math/src/random.0rx +++ b/lib/math/src/random.0rx @@ -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 random diff --git a/lib/math/src/token.0rx b/lib/math/src/token.0rx --- a/lib/math/src/token.0rx +++ b/lib/math/src/token.0rx @@ -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 toToken <- HashedMap.new() diff --git a/lib/util/extra.0rp b/lib/util/extra.0rp --- a/lib/util/extra.0rp +++ b/lib/util/extra.0rp @@ -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 + refines Duplicate + refines ReadAt + refines WriteAt +} + // Contains either a value or an error message. // // Params: diff --git a/lib/util/src/counters.0rx b/lib/util/src/counters.0rx --- a/lib/util/src/counters.0rx +++ b/lib/util/src/counters.0rx @@ -119,7 +119,7 @@ } define Repeat { - $ReadOnly[limit,value]$ + $ReadOnlyExcept[current]$ refines Order<#x> diff --git a/lib/util/src/extra.0rx b/lib/util/src/extra.0rx --- a/lib/util/src/extra.0rx +++ b/lib/util/src/extra.0rx @@ -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 error <- reduce<#self,ErrorOr>(self) + } in if (present(error)) { + return require(error) } else { - return ErrorOr{ empty, maybeError } + fail("no error present to convert") } } } diff --git a/lib/util/test/extra.0rt b/lib/util/test/extra.0rt --- a/lib/util/test/extra.0rt +++ b/lib/util/test/extra.0rt @@ -136,3 +136,47 @@ unittest hashed { \ Testing.checkEquals(Void.default().duplicate().hashed(),Void.default().hashed()) } + + +testcase "AlwaysEmpty tests" { + success +} + +unittest conversions { + ReadAt read <- AlwaysEmpty.default() + WriteAt 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) +} diff --git a/src/Cli/CompileOptions.hs b/src/Cli/CompileOptions.hs --- a/src/Cli/CompileOptions.hs +++ b/src/Cli/CompileOptions.hs @@ -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) diff --git a/src/Cli/Compiler.hs b/src/Cli/Compiler.hs --- a/src/Cli/Compiler.hs +++ b/src/Cli/Compiler.hs @@ -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' diff --git a/src/Cli/ParseCompileOptions.hs b/src/Cli/ParseCompileOptions.hs --- a/src/Cli/ParseCompileOptions.hs +++ b/src/Cli/ParseCompileOptions.hs @@ -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 diff --git a/src/Cli/Programs.hs b/src/Cli/Programs.hs --- a/src/Cli/Programs.hs +++ b/src/Cli/Programs.hs @@ -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 diff --git a/src/Cli/RunCompiler.hs b/src/Cli/RunCompiler.hs --- a/src/Cli/RunCompiler.hs +++ b/src/Cli/RunCompiler.hs @@ -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 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 ) 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 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) (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 >= 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 ++ diff --git a/src/Compilation/ScopeContext.hs b/src/Compilation/ScopeContext.hs --- a/src/Compilation/ScopeContext.hs +++ b/src/Compilation/ScopeContext.hs @@ -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 diff --git a/src/CompilerCxx/Code.hs b/src/CompilerCxx/Code.hs --- a/src/CompilerCxx/Code.hs +++ b/src/CompilerCxx/Code.hs @@ -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 diff --git a/src/CompilerCxx/CxxFiles.hs b/src/CompilerCxx/CxxFiles.hs --- a/src/CompilerCxx/CxxFiles.hs +++ b/src/CompilerCxx/CxxFiles.hs @@ -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>& 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& 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>& 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& 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>{" ++ intercalate ", " (map expandLocalType ps) ++ "};", - " return true;" - ] + singleCase (n2,ps) = do + ps' <- mapCompilerM (reverseSelfInstance self) ps + return [ + " case " ++ categoryIdName n2 ++ ":", + " args = std::vector>{" ++ 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>(" ++ intercalate "," ps ++ "))" defineCategoryName :: SymbolScope -> CategoryName -> CompiledData [String] defineCategoryName TypeScope _ = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }" diff --git a/src/CompilerCxx/LanguageModule.hs b/src/CompilerCxx/LanguageModule.hs --- a/src/CompilerCxx/LanguageModule.hs +++ b/src/CompilerCxx/LanguageModule.hs @@ -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) diff --git a/src/Config/LocalConfig.hs b/src/Config/LocalConfig.hs --- a/src/Config/LocalConfig.hs +++ b/src/Config/LocalConfig.hs @@ -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 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]) (takeFileName $ dropExtension s ++ ".a") - executeProcess ab ["-q",arName,objName] 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 diff --git a/src/Module/CompileMetadata.hs b/src/Module/CompileMetadata.hs --- a/src/Module/CompileMetadata.hs +++ b/src/Module/CompileMetadata.hs @@ -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 ] diff --git a/src/Module/ParseMetadata.hs b/src/Module/ParseMetadata.hs --- a/src/Module/ParseMetadata.hs +++ b/src/Module/ParseMetadata.hs @@ -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 diff --git a/src/Module/ProcessMetadata.hs b/src/Module/ProcessMetadata.hs --- a/src/Module/ProcessMetadata.hs +++ b/src/Module/ProcessMetadata.hs @@ -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 diff --git a/src/Parser/DefinedCategory.hs b/src/Parser/DefinedCategory.hs --- a/src/Parser/DefinedCategory.hs +++ b/src/Parser/DefinedCategory.hs @@ -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 ",") diff --git a/src/Test/ParseMetadata.hs b/src/Test/ParseMetadata.hs --- a/src/Test/ParseMetadata.hs +++ b/src/Test/ParseMetadata.hs @@ -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 = [] diff --git a/src/Test/testfiles/module-config.txt b/src/Test/testfiles/module-config.txt --- a/src/Test/testfiles/module-config.txt +++ b/src/Test/testfiles/module-config.txt @@ -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 { diff --git a/src/Types/DefinedCategory.hs b/src/Types/DefinedCategory.hs --- a/src/Types/DefinedCategory.hs +++ b/src/Types/DefinedCategory.hs @@ -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) GeneralInstance -> DefinedMember c -> m (DefinedMember c) diff --git a/src/Types/TypeCategory.hs b/src/Types/TypeCategory.hs --- a/src/Types/TypeCategory.hs +++ b/src/Types/TypeCategory.hs @@ -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] diff --git a/tests/.zeolite-module b/tests/.zeolite-module --- a/tests/.zeolite-module +++ b/tests/.zeolite-module @@ -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 {} diff --git a/tests/Extension_Extension.cpp b/tests/Extension_Extension.cpp new file mode 100644 --- /dev/null +++ b/tests/Extension_Extension.cpp @@ -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 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 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 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 parent, const ParamsArgs& params_args) { + return BoxedValue::New(std::move(parent), params_args); +} + +#ifdef ZEOLITE_PRIVATE_NAMESPACE +} // namespace ZEOLITE_PRIVATE_NAMESPACE +using namespace ZEOLITE_PRIVATE_NAMESPACE; +#endif // ZEOLITE_PRIVATE_NAMESPACE diff --git a/tests/cli-tests.sh b/tests/cli-tests.sh --- a/tests/cli-tests.sh +++ b/tests/cli-tests.sh @@ -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" <&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) diff --git a/tests/extension.0rp b/tests/extension.0rp new file mode 100644 --- /dev/null +++ b/tests/extension.0rp @@ -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) +} diff --git a/tests/extension.0rt b/tests/extension.0rt new file mode 100644 --- /dev/null +++ b/tests/extension.0rt @@ -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") +} diff --git a/tests/function-calls.0rt b/tests/function-calls.0rt --- a/tests/function-calls.0rt +++ b/tests/function-calls.0rt @@ -272,64 +272,149 @@ } -testcase "call from intersect" { +testcase "call from intersect failed merge" { + error + require "\[Base&Base\]" + require "get" + require "[Mm]ultiple" +} + +unittest test { + [Base&Base] value <- Value1.create() + \ value.get() +} + +@value interface Base<|#x> { + get () -> (#x) +} + +concrete Value1 { + refines Base + @type create () -> (Value1) +} + +define Value1 { + get () { + return 1 + } + + create () { + return Value1{ } + } +} + +concrete Value2 { + refines Base + @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&Base] 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 + @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 + @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&Base] value <- Value1.create() + \ Testing.checkEquals(value?Base.get().formatted(),"1") } -@value interface Base1 { - call () -> () +@value interface Base<|#x> { + get () -> (#x) } -@value interface Base2 {} +concrete Value1 { + refines Base + @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 + @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() } diff --git a/tests/internal-inheritance.0rt b/tests/internal-inheritance.0rt --- a/tests/internal-inheritance.0rt +++ b/tests/internal-inheritance.0rt @@ -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>) +} + +define Type { + refines Base2> + + new () { + return Type<#x>{ } } } diff --git a/tests/leak-check/leak-check.0rx b/tests/leak-check/leak-check.0rx --- a/tests/leak-check/leak-check.0rx +++ b/tests/leak-check/leak-check.0rx @@ -79,7 +79,7 @@ } define LastReference { - $ReadOnly[copy,barrier]$ + $ReadOnlyExcept[]$ refines Routine diff --git a/tests/local-rules.0rt b/tests/local-rules.0rt --- a/tests/local-rules.0rt +++ b/tests/local-rules.0rt @@ -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]$ +} diff --git a/tests/reduce.0rt b/tests/reduce.0rt --- a/tests/reduce.0rt +++ b/tests/reduce.0rt @@ -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.new()))) + \ Testing.checkTrue(present(reduce>>(Type.new()))) + \ Testing.checkFalse(present(reduce>(Type.new()))) +} + +concrete Type { + refines Build<[AsBool&ReadAt]> + + @type new () -> (Type) +} + +define Type { + new () { return Type{ } } + build () { return "message" } +} + + +testcase "parent param contains #self" { + success +} + +unittest test { + \ Testing.checkTrue(present(reduce>(Type.new()))) + \ Testing.checkTrue(present(reduce>>(Type.new()))) + \ Testing.checkFalse(present(reduce>(Type.new()))) + \ Testing.checkTrue(present(reduce>>(Type.new()))) + \ Testing.checkTrue(present(reduce>(Type.new()))) +} + +concrete Type { + refines Order<#self> + refines Build> + refines Formatted + + @type new () -> (Type) +} + +define Type { + new () { return Type{ } } + build () { return self } + get () { return self } + next () { return self } + formatted () { return "Type" } +} diff --git a/tests/simulate-refs/routines.0rx b/tests/simulate-refs/routines.0rx --- a/tests/simulate-refs/routines.0rx +++ b/tests/simulate-refs/routines.0rx @@ -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 diff --git a/zeolite-lang.cabal b/zeolite-lang.cabal --- a/zeolite-lang.cabal +++ b/zeolite-lang.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: zeolite-lang -version: 0.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,