zeolite-lang 0.1.2.9 → 0.1.3.0
raw patch · 45 files changed
+1044/−869 lines, 45 filesdep ~basedep ~directoryPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base, directory
API changes (from Hackage documentation)
+ Parser.Common: char_ :: Char -> Parser ()
+ Parser.Common: sepAfter_ :: Parser a -> Parser ()
+ Parser.Common: string_ :: String -> Parser ()
+ Types.Positional: processPairs_ :: (Show a, Show b, CompileErrorM m) => (a -> b -> m c) -> Positional a -> Positional b -> m ()
- Cli.CompileMetadata: allowedExtraTypes :: [[Char]]
+ Cli.CompileMetadata: allowedExtraTypes :: [String]
- Compilation.CompileInfo: getCompileError :: () => CompileInfo a -> CompileMessage
+ Compilation.CompileInfo: getCompileError :: CompileInfo a -> CompileMessage
- Compilation.CompileInfo: getCompileSuccess :: () => CompileInfo a -> a
+ Compilation.CompileInfo: getCompileSuccess :: CompileInfo a -> a
- Compilation.CompileInfo: getCompileWarnings :: () => CompileInfo a -> [String]
+ Compilation.CompileInfo: getCompileWarnings :: CompileInfo a -> [String]
- Compilation.ScopeContext: getProcedureScopes :: (Show c, CompileErrorM m, MergeableM m) => CategoryMap c -> [Namespace] -> DefinedCategory c -> m [ProcedureScope c]
+ Compilation.ScopeContext: getProcedureScopes :: (Show c, CompileErrorM m, MergeableM m) => CategoryMap c -> DefinedCategory c -> m [ProcedureScope c]
- Parser.Common: assignOperator :: Parser String
+ Parser.Common: assignOperator :: Parser ()
- Parser.Common: labeled :: () => String -> ParsecT s u m a -> ParsecT s u m a
+ Parser.Common: labeled :: String -> Parser a -> Parser a
- Types.IntegrationTest: getExcludePattern :: () => ExpectedResult c -> [OutputPattern]
+ Types.IntegrationTest: getExcludePattern :: ExpectedResult c -> [OutputPattern]
- Types.IntegrationTest: getRequirePattern :: () => ExpectedResult c -> [OutputPattern]
+ Types.IntegrationTest: getRequirePattern :: ExpectedResult c -> [OutputPattern]
- Types.IntegrationTest: isExpectCompileError :: () => ExpectedResult c -> Bool
+ Types.IntegrationTest: isExpectCompileError :: ExpectedResult c -> Bool
- Types.IntegrationTest: isExpectRuntimeError :: () => ExpectedResult c -> Bool
+ Types.IntegrationTest: isExpectRuntimeError :: ExpectedResult c -> Bool
- Types.IntegrationTest: isExpectRuntimeSuccess :: () => ExpectedResult c -> Bool
+ Types.IntegrationTest: isExpectRuntimeSuccess :: ExpectedResult c -> Bool
Files
- ChangeLog.md +4/−0
- bin/unit-tests.hs +3/−1
- bin/zeolite-setup.hs +9/−4
- bin/zeolite.hs +1/−1
- src/Base/CompileError.hs +6/−3
- src/Base/Mergeable.hs +3/−2
- src/Cli/CompileMetadata.hs +27/−15
- src/Cli/CompileOptions.hs +7/−0
- src/Cli/Compiler.hs +36/−43
- src/Cli/ParseCompileOptions.hs +41/−38
- src/Cli/TestRunner.hs +12/−15
- src/Compilation/CompileInfo.hs +19/−5
- src/Compilation/CompilerState.hs +2/−3
- src/Compilation/ProcedureContext.hs +23/−24
- src/Compilation/ScopeContext.hs +14/−15
- src/CompilerCxx/Category.hs +67/−68
- src/CompilerCxx/CategoryContext.hs +5/−3
- src/CompilerCxx/Code.hs +24/−26
- src/CompilerCxx/Naming.hs +0/−1
- src/CompilerCxx/Procedure.hs +107/−110
- src/Config/LoadConfig.hs +3/−2
- src/Config/Paths.hs +0/−2
- src/Parser/Common.hs +123/−16
- src/Parser/DefinedCategory.hs +13/−12
- src/Parser/IntegrationTest.hs +10/−11
- src/Parser/Procedure.hs +60/−58
- src/Parser/SourceFile.hs +2/−4
- src/Parser/TypeCategory.hs +31/−25
- src/Parser/TypeInstance.hs +4/−6
- src/Test/Common.hs +3/−2
- src/Test/DefinedCategory.hs +3/−2
- src/Test/IntegrationTest.hs +1/−1
- src/Test/Parser.hs +3/−2
- src/Test/Procedure.hs +6/−2
- src/Test/TypeCategory.hs +155/−165
- src/Test/TypeInstance.hs +26/−7
- src/Types/DefinedCategory.hs +9/−8
- src/Types/Function.hs +15/−15
- src/Types/GeneralType.hs +1/−2
- src/Types/IntegrationTest.hs +5/−0
- src/Types/Positional.hs +5/−2
- src/Types/Procedure.hs +0/−1
- src/Types/TypeCategory.hs +109/−108
- src/Types/TypeInstance.hs +21/−27
- zeolite-lang.cabal +26/−12
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for zeolite-lang +## 0.1.3.0 -- 2020-05-01++* **[new]** Adds support for more versions of GHC.+ ## 0.1.2.0 -- 2020-04-28 * **[fix]** Fixes a parser issue with empty `{}` blocks following `scoped`.
bin/unit-tests.hs view
@@ -28,6 +28,7 @@ import qualified Test.TypeInstance as TypeInstanceTest +main :: IO () main = runAllTests $ concat [ labelWith "DefinedCategoryTest" DefinedCategoryTest.tests, labelWith "TypeInstanceTest" TypeInstanceTest.tests,@@ -37,4 +38,5 @@ labelWith "IntegrationTestTest" IntegrationTestTest.tests ] -labelWith s ts = map (\(n,t) -> fmap (`reviseError` ("In " ++ s ++ " (#" ++ show n ++ "):")) t) (zip [1..] ts)+labelWith :: CompileErrorM m => String -> [IO (m ())] -> [IO (m ())]+labelWith s ts = map (\(n,t) -> fmap (`reviseError` ("In " ++ s ++ " (#" ++ show n ++ "):")) t) (zip ([1..] :: [Int]) ts)
bin/zeolite-setup.hs view
@@ -25,25 +25,30 @@ import Cli.CompileOptions import Cli.Compiler import Config.LoadConfig-import Config.Paths-import Config.Programs +main :: IO () main = do f <- localConfigPath isFile <- doesFileExist f when isFile $ do hPutStrLn stderr $ "*** WARNING: Local config " ++ f ++ " will be overwritten. ***" config <- createConfig- f <- localConfigPath hPutStrLn stderr $ "Writing local config to " ++ f ++ "." writeFile f (show config ++ "\n") initLibraries hPutStrLn stderr "Setup is now complete!" +clangBinary :: String clangBinary = "clang++"++gccBinary :: String gccBinary = "g++"++arBinary :: String arBinary = "ar"++libraries :: [String] libraries = [ "base", "lib/util",@@ -83,7 +88,7 @@ where getChoice = do hPutStrLn stderr p- let cs' = zipWith (\n c -> show n ++ ") " ++ c) [1..] $ cs ++ ["other"]+ let cs' = zipWith (\n c -> show n ++ ") " ++ c) ([1..] :: [Int]) $ cs ++ ["other"] let cs'' = (head cs' ++ " [default]"):(tail cs') mapM_ (hPutStrLn stderr) cs'' hPutStr stderr "? "
bin/zeolite.hs view
@@ -19,7 +19,6 @@ import Control.Monad (when) import System.Environment import System.Exit-import System.FilePath import System.IO import Base.CompileError@@ -29,6 +28,7 @@ import Compilation.CompileInfo +main :: IO () main = do args <- getArgs let options = parseCompileOptions args >>= validateCompileOptions
src/Base/CompileError.hs view
@@ -25,11 +25,14 @@ CompileErrorM(..), ) where -import Control.Monad (Monad(..))+#if MIN_VERSION_base(4,8,0)+#else import Data.Foldable-import Data.Functor+#endif -#if MIN_VERSION_base(4,9,0)+#if MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ()+#elif MIN_VERSION_base(4,9,0) import Control.Monad.Fail #endif
src/Base/Mergeable.hs view
@@ -25,9 +25,10 @@ MergeableM(..), ) where -import Control.Monad (Monad(..))+#if MIN_VERSION_base(4,8,0)+#else import Data.Foldable-import Data.Functor+#endif class Mergeable a where
src/Cli/CompileMetadata.hs view
@@ -58,7 +58,6 @@ import Data.List (nub,isSuffixOf) import Data.Maybe (isJust) import System.Directory-import System.Environment import System.Exit (exitFailure) import System.FilePath import System.IO@@ -134,9 +133,16 @@ } deriving (Show,Read) +cachedDataPath :: String cachedDataPath = ".zeolite-cache"++recompileFilename :: String recompileFilename = ".zeolite-module"++metadataFilename :: String metadataFilename = "metadata.txt"++allowedExtraTypes :: [String] allowedExtraTypes = [".hpp",".cpp",".h",".cc",".a",".o"] loadMetadata :: String -> IO CompileMetadata@@ -186,8 +192,8 @@ m <- tryLoadMetadata p case m of Nothing -> return False- Just m'-> do- (fr,_) <- loadDepsCommon True (\m -> cmPublicDeps m ++ cmPrivateDeps m) [p]+ Just _ -> do+ (fr,_) <- loadDepsCommon True (\m2 -> cmPublicDeps m2 ++ cmPrivateDeps m2) [p] return fr isPathConfigured :: String -> IO Bool@@ -283,15 +289,15 @@ loadDepsCommon :: Bool -> (CompileMetadata -> [String]) -> [String] -> IO (Bool,[CompileMetadata]) loadDepsCommon s f ps = fmap snd $ fixedPaths >>= collect (Set.empty,(True,[])) where fixedPaths = sequence $ map canonicalizePath ps- collect xa@(pa,(fr,xs)) (p:ps)- | p `Set.member` pa = collect xa ps+ collect xa@(pa,(fr,xs)) (p:ps2)+ | p `Set.member` pa = collect xa ps2 | otherwise = do when (not s) $ hPutStrLn stderr $ "Loading metadata for dependency \"" ++ p ++ "\"." m <- loadMetadata p fresh <- checkModuleFreshness p m when (not s && not fresh) $ hPutStrLn stderr $ "Module \"" ++ p ++ "\" is out of date and should be recompiled."- collect (p `Set.insert` pa,(fresh && fr,xs ++ [m])) (ps ++ f m)+ collect (p `Set.insert` pa,(fresh && fr,xs ++ [m])) (ps2 ++ f m) collect xa _ = return xa fixPath :: String -> String@@ -326,31 +332,36 @@ let e2 = checkMissing xs xs2 let e3 = checkMissing ts ts2 rm <- check time (p </> recompileFilename)- f1 <- sequence $ map (\p2 -> check time $ getCachedPath p2 "" metadataFilename) $ is ++ is2+ f1 <- sequence $ map (\p3 -> check time $ getCachedPath p3 "" metadataFilename) $ is ++ is2 f2 <- sequence $ map (check time . (p2 </>)) $ ps ++ xs f3 <- sequence $ map (check time . getCachedPath p2 "") $ hxx ++ cxx let fresh = not $ any id $ [rm,e1,e2,e3] ++ f1 ++ f2 ++ f3 return fresh where check time f = do- exists <- doesPathExist f+ exists <- doesFileOrDirExist f if not exists then return True else do time2 <- getModificationTime f return (time2 > time) checkMissing s0 s1 = not $ null $ (Set.fromList s1) `Set.difference` (Set.fromList s0)+ doesFileOrDirExist f2 = do+ existF <- doesFileExist f2+ if existF+ then return True+ else doesDirectoryExist f2 getObjectFileResolver :: [CategoryIdentifier] -> [ObjectFile] -> [Namespace] -> [CategoryName] -> [String] getObjectFileResolver ce os ns ds = resolved ++ nonCategories where categories = filter isCategoryObjectFile os nonCategories = map oofFile $ filter (not . isCategoryObjectFile) os- categoryMap = Map.fromList $ map keyByCategory categories- keyByCategory o = ((ciCategory $ cofCategory o,ciNamespace $ cofCategory o),o)+ categoryMap = Map.fromList $ map keyByCategory2 categories+ keyByCategory2 o = ((ciCategory $ cofCategory o,ciNamespace $ cofCategory o),o) objectMap = Map.fromList $ map keyBySpec categories keyBySpec o = (cofCategory o,o)- directDeps = concat $ map (resolveDep . show) ds+ directDeps = concat $ map (resolveDep2 . show) ds directResolved = map cofCategory directDeps ++ ce- resolveDep d = unwrap $ foldl (<|>) Nothing allChecks <|> Just [] where+ resolveDep2 d = unwrap $ foldl (<|>) Nothing allChecks <|> Just [] where allChecks = map (\n -> (d,n) `Map.lookup` categoryMap >>= return . (:[])) (map show ns ++ [""]) unwrap (Just xs) = xs unwrap _ = []@@ -360,11 +371,11 @@ | c `Set.member` ca = collectAll ca fa cs | otherwise = case c `Map.lookup` objectMap of- Nothing -> collectAll ca fa cs- Just (CategoryObjectFile _ ds fs) -> (ca',fa'',fs') where- (ca',fa',fs0) = collectAll (c `Set.insert` ca) fa (ds ++ cs)+ Just (CategoryObjectFile _ ds2 fs) -> (ca',fa'',fs') where+ (ca',fa',fs0) = collectAll (c `Set.insert` ca) fa (ds2 ++ cs) fa'' = fa' `Set.union` (Set.fromList fs) fs' = (filter (not . flip elem fa') fs) ++ fs0+ _ -> collectAll ca fa cs resolveObjectDeps :: String -> [([String],CxxOutput)] -> [CompileMetadata] -> [ObjectFile] resolveObjectDeps p os deps = resolvedCategories ++ nonCategories where@@ -377,6 +388,7 @@ depCategories = map keyByCategory $ concat $ map categoriesToIds deps categoriesToIds dep = map (\c -> CategoryIdentifier (cmPath dep) c (cmNamespace dep)) (cmCategories dep) cxxToId (CxxOutput (Just c) _ ns _ _ _) = CategoryIdentifier p (show c) (show ns)+ cxxToId _ = undefined resolveCategory (fs,ca@(CxxOutput _ _ _ ns2 ds _)) = (cxxToId ca,CategoryObjectFile (cxxToId ca) rs fs) where rs = concat $ map (resolveDep categoryMap (map show ns2 ++ publicNamespaces) . show) ds
src/Cli/CompileOptions.hs view
@@ -84,23 +84,30 @@ CompileUnspecified deriving (Eq,Read,Show) +isOnlyShowPath :: CompileMode -> Bool isOnlyShowPath OnlyShowPath = True isOnlyShowPath _ = False +isCompileBinary :: CompileMode -> Bool isCompileBinary (CompileBinary _ _) = True isCompileBinary _ = False +isCompileIncremental :: CompileMode -> Bool isCompileIncremental CompileIncremental = True isCompileIncremental _ = False +isCompileRecompile :: CompileMode -> Bool isCompileRecompile CompileRecompile = True isCompileRecompile _ = False +isExecuteTests :: CompileMode -> Bool isExecuteTests (ExecuteTests _) = True isExecuteTests _ = False +isCreateTemplates :: CompileMode -> Bool isCreateTemplates CreateTemplates = True isCreateTemplates _ = False +maybeDisableHelp :: HelpMode -> HelpMode maybeDisableHelp HelpUnspecified = HelpNotNeeded maybeDisableHelp h = h
src/Cli/Compiler.hs view
@@ -21,25 +21,20 @@ runCompiler, ) where -import Control.Applicative ((<|>)) import Control.Monad (when) import Data.List (intercalate,isSuffixOf,nub,sort)-import Data.Maybe (isJust) import System.Directory-import System.Environment import System.Exit import System.FilePath import System.Posix.Temp (mkstemps) import System.IO-import qualified Data.Map as Map import qualified Data.Set as Set import Base.CompileError import Base.Mergeable import Cli.CompileMetadata import Cli.CompileOptions-import Cli.ParseCompileOptions -- Not safe, due to Text.Regex.TDFA.-import Cli.TestRunner+import Cli.TestRunner -- Not safe, due to Text.Regex.TDFA. import Compilation.CompileInfo import CompilerCxx.Category import CompilerCxx.Naming@@ -62,7 +57,7 @@ runCompiler (CompileOptions _ _ _ _ _ _ _ _ OnlyShowPath _ _) = do p <- rootPath >>= canonicalizePath hPutStrLn stdout p-runCompiler co@(CompileOptions _ _ _ ds _ _ _ p (ExecuteTests tp) _ f) = do+runCompiler (CompileOptions _ _ _ ds _ _ _ p (ExecuteTests tp) _ f) = do (backend,resolver) <- loadConfig ds' <- sequence $ map (preloadModule resolver) ds let possibleTests = Set.fromList $ concat $ map getTestsFromPreload ds'@@ -111,7 +106,7 @@ | otherwise = do hPutStrLn stderr $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)" hPutStrLn stderr $ "Zeolite tests passed."-runCompiler co@(CompileOptions h _ _ ds _ _ _ p CompileRecompile _ f) = do+runCompiler (CompileOptions h _ _ ds _ _ _ p CompileRecompile _ f) = do fmap mergeAll $ sequence $ map recompileSingle ds where recompileSingle d0 = do let d = p </> d0@@ -124,11 +119,11 @@ maybeCompile (Just rm') upToDate | f < ForceAll && upToDate = hPutStrLn stderr $ "Path " ++ d0 ++ " is up to date." | otherwise = do- let (RecompileMetadata p d is is2 es ep ec m o) = rm'+ let (RecompileMetadata p2 d is is2 es ep ec m o) = rm' -- In case the module is manually configured with a p such as "..", -- since the absolute path might not be known ahead of time. absolute <- canonicalizePath d0- let fixed = fixPath (absolute </> p)+ let fixed = fixPath (absolute </> p2) let recompile = CompileOptions { coHelp = h, coPublicDeps = map ((fixed </> d) </>) is,@@ -143,7 +138,7 @@ coForce = if f == ForceAll then ForceRecompile else AllowRecompile } runCompiler recompile-runCompiler co@(CompileOptions h is is2 ds es ep ec p m o f) = do+runCompiler (CompileOptions _ is is2 ds es ep ec p m o f) = do (backend,resolver) <- loadConfig as <- fmap fixPaths $ sequence $ map (resolveModule resolver p) is as2 <- fmap fixPaths $ sequence $ map (resolveModule resolver p) is2@@ -216,7 +211,6 @@ let hxx = filter (isSuffixOf ".hpp" . coFilename) fs' let other = filter (not . isSuffixOf ".hpp" . coFilename) fs' os1 <- sequence $ map (writeOutputFile b (show ns0) paths' d) $ hxx ++ other- base <- resolveBaseModule r actual <- resolveModule r p d isBase <- isBaseModule r actual -- Base files should be compiled to .o and not .a.@@ -224,7 +218,7 @@ then compileBuiltinFile else compileExtraFile os2 <- fmap concat $ sequence $ map (extraComp b (show ns0) paths' d) es'- let (hxx,cxx,os') = sortCompiledFiles $ map (\f -> show (coNamespace f) </> coFilename f) fs' ++ es'+ let (hxx',cxx,os') = sortCompiledFiles $ map (\f2 -> show (coNamespace f2) </> coFilename f2) fs' ++ es' path <- canonicalizePath $ p </> d let os1' = resolveObjectDeps path os1 deps let cm0 = CompileMetadata {@@ -238,7 +232,7 @@ cmPublicFiles = sort ps, cmPrivateFiles = sort xs, cmTestFiles = sort ts,- cmHxxFiles = sort hxx,+ cmHxxFiles = sort hxx', cmCxxFiles = sort cxx, cmObjectFiles = os1' ++ os2 ++ map OtherObjectFile os' }@@ -263,29 +257,29 @@ formatWarnings c | null $ getCompileWarnings c = return () | otherwise = hPutStr stderr $ "Compiler warnings:\n" ++ (concat $ map (++ "\n") (getCompileWarnings c))- writeOutputFile b ns0 paths d ca@(CxxOutput c f ns ns2 req content) = do- hPutStrLn stderr $ "Writing file " ++ f- writeCachedFile (p </> d) (show ns) f $ concat $ map (++ "\n") content- if isSuffixOf ".cpp" f || isSuffixOf ".cc" f+ writeOutputFile b ns0 paths d ca@(CxxOutput _ f2 ns _ _ content) = do+ hPutStrLn stderr $ "Writing file " ++ f2+ writeCachedFile (p </> d) (show ns) f2 $ concat $ map (++ "\n") content+ if isSuffixOf ".cpp" f2 || isSuffixOf ".cc" f2 then do- let f' = getCachedPath (p </> d) (show ns) f+ let f2' = getCachedPath (p </> d) (show ns) f2 let p0 = getCachedPath (p </> d) "" "" let p1 = getCachedPath (p </> d) (show ns) "" createCachePath (p </> d) let ns' = if isStaticNamespace ns then show ns else show ns0- let command = CompileToObject f' (getCachedPath (p </> d) ns' "") dynamicNamespaceName "" (p0:p1:paths) False- o <- runCxxCommand b command- return $ ([o],ca)+ let command = CompileToObject f2' (getCachedPath (p </> d) ns' "") dynamicNamespaceName "" (p0:p1:paths) False+ o2 <- runCxxCommand b command+ return $ ([o2],ca) else return ([],ca) compileExtraFile = compileExtraCommon True compileBuiltinFile = compileExtraCommon False- compileExtraCommon e b ns0 paths d f- | isSuffixOf ".cpp" f || isSuffixOf ".cc" f = do- let f' = p </> d </> f+ compileExtraCommon e b ns0 paths d f2+ | isSuffixOf ".cpp" f2 || isSuffixOf ".cc" f2 = do+ let f2' = p </> d </> f2 createCachePath (p </> d)- let command = CompileToObject f' (getCachedPath (p </> d) "" "") dynamicNamespaceName ns0 paths e- o <- runCxxCommand b command- return [OtherObjectFile o]+ let command = CompileToObject f2' (getCachedPath (p </> d) "" "") dynamicNamespaceName ns0 paths e+ o2 <- runCxxCommand b command+ return [OtherObjectFile o2] | otherwise = return [] processTemplates deps d = do (ps,xs,_) <- findSourceFiles p d@@ -303,31 +297,31 @@ else do formatWarnings ts sequence $ map (writeTemplate d) $ getCompileSuccess ts- createTemplates is cs ds = do- tm1 <- addIncludes defaultCategories is+ createTemplates is3 cs ds2 = do+ tm1 <- addIncludes defaultCategories is3 cs' <- fmap concat $ collectAllOrErrorM $ map parsePublicSource cs let cs'' = map (setCategoryNamespace DynamicNamespace) cs' tm2 <- includeNewTypes tm1 cs''- da <- collectAllOrErrorM $ map parseInternalSource ds- let ds' = concat $ map snd da+ da <- collectAllOrErrorM $ map parseInternalSource ds2+ let ds2' = concat $ map snd da let cs2 = concat $ map fst da tm3 <- includeNewTypes tm2 cs2 let ca = Set.fromList $ map getCategoryName $ filter isValueConcrete cs'- let ca' = foldr Set.delete ca $ map dcName ds'+ let ca' = foldr Set.delete ca $ map dcName ds2' collectAllOrErrorM $ map (compileConcreteTemplate tm3) $ Set.toList ca' writeTemplate d (CxxOutput _ n _ _ _ content) = do let n' = p </> d </> n- exists <- doesPathExist n'+ exists <- doesFileExist n' if exists && f /= ForceAll then hPutStrLn stderr $ "Skipping existing file " ++ n else do hPutStrLn stderr $ "Writing file " ++ n writeFile n' $ concat $ map (++ "\n") content- compileAll ns0 ns2 is cs ds = do- tm1 <- addIncludes defaultCategories is+ compileAll ns0 ns2 is3 cs ds2 = do+ tm1 <- addIncludes defaultCategories is3 cs' <- fmap concat $ collectAllOrErrorM $ map parsePublicSource cs let cs'' = map (setCategoryNamespace ns0) cs'- xa <- collectAllOrErrorM $ map parsePrivate ds+ xa <- collectAllOrErrorM $ map parsePrivate ds2 let cm = CategoryModule { cnBase = tm1, cnNamespaces = ns0:ns2,@@ -340,13 +334,12 @@ return (pc,ms,xx) parsePrivate d = do let ns1 = StaticNamespace $ privateNamespace (p </> fst d)- (cs,ds) <- parseInternalSource d+ (cs,ds2) <- parseInternalSource d let cs' = map (setCategoryNamespace ns1) cs- return $ PrivateSource ns1 cs' ds+ return $ PrivateSource ns1 cs' ds2 addIncludes tm fs = do cs <- fmap concat $ collectAllOrErrorM $ map parsePublicSource fs includeNewTypes tm cs- mergeInternal ds = (concat $ map fst ds,concat $ map snd ds) getBinaryName (CompileBinary n _) | null o = canonicalizePath $ p </> head ds </> n | otherwise = canonicalizePath $ p </> head ds </> o@@ -375,11 +368,11 @@ let os' = ofr ns2 req let command = CompileToBinary o' os' f0 paths hPutStrLn stderr $ "Creating binary " ++ f0- runCxxCommand b command+ _ <- runCxxCommand b command removeFile o' createBinary _ _ _ _ _ = return ()- maybeCreateMain cm (CompileBinary n f) =- fmap (:[]) $ compileModuleMain cm (CategoryName n) (FunctionName f)+ maybeCreateMain cm (CompileBinary n f2) =+ fmap (:[]) $ compileModuleMain cm (CategoryName n) (FunctionName f2) maybeCreateMain _ _ = return [] checkAllowedStale :: Bool -> ForceMode -> IO ()
src/Cli/ParseCompileOptions.hs view
@@ -28,7 +28,7 @@ import Text.Regex.TDFA -- Not safe! import Base.CompileError-import Cli.CompileMetadata (allowedExtraTypes,getCacheRelativePath)+import Cli.CompileMetadata (allowedExtraTypes) import Cli.CompileOptions @@ -68,7 +68,7 @@ defaultMainFunc = "run" parseCompileOptions :: CompileErrorM m => [String] -> m CompileOptions-parseCompileOptions = parseAll emptyCompileOptions . zip [1..] where+parseCompileOptions = parseAll emptyCompileOptions . zip ([1..] :: [Int]) where parseAll co [] = return co parseAll co os = do (os',co') <- parseSingle co os@@ -87,10 +87,12 @@ | null d = argError n d "Invalid function name." | otherwise = argError n d $ "Invalid function name for " ++ o ++ "." - parseSingle (CompileOptions _ is is2 ds es ep ec p m o f) ((n,"-h"):os) =+ parseSingle _ [] = undefined++ parseSingle (CompileOptions _ is is2 ds es ep ec p m o f) ((_,"-h"):os) = return (os,CompileOptions HelpNeeded is is2 ds es ep ec p m o f) - parseSingle (CompileOptions h is is2 ds es ep ec p m o _) ((n,"-f"):os) =+ parseSingle (CompileOptions h is is2 ds es ep ec p m o _) ((_,"-f"):os) = return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p m o ForceAll) parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-c"):os)@@ -116,64 +118,65 @@ parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-m"):os) | m /= CompileUnspecified = argError n "-m" "Compiler mode already set." | otherwise = update os where- update ((n,c):os) = do- let (t,fn) = check $ break (== '.') c- checkCategoryName n t "-m"- checkFunctionName n fn "-m"- return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p (CompileBinary t fn) o f) where- check (t,"") = (t,defaultMainFunc)- check (t,'.':fn) = (t,fn)+ update ((n2,c):os2) = do+ (t,fn) <- check $ break (== '.') c+ checkCategoryName n2 t "-m"+ checkFunctionName n2 fn "-m"+ return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p (CompileBinary t fn) o f) where+ check (t,"") = return (t,defaultMainFunc)+ check (t,'.':fn) = return (t,fn)+ check _ = argError n2 "-m" $ "Invalid entry point \"" ++ c ++ "\"." update _ = argError n "-m" "Requires a category name." parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-o"):os) | not $ null o = argError n "-o" "Output name already set." | otherwise = update os where- update ((n,o):os) = do- checkPathName n o "-o"- return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p m o f)+ update ((n2,o2):os2) = do+ checkPathName n2 o2 "-o"+ return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p m o2 f) update _ = argError n "-o" "Requires an output name." parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-i"):os) = update os where- update ((n,d):os)- | isSuffixOf ".0rp" d = argError n d "Cannot directly include .0rp source files."- | isSuffixOf ".0rx" d = argError n d "Cannot directly include .0rx source files."- | isSuffixOf ".0rt" d = argError n d "Cannot directly include .0rt test files."+ update ((n2,d):os2)+ | isSuffixOf ".0rp" d = argError n2 d "Cannot directly include .0rp source files."+ | isSuffixOf ".0rx" d = argError n2 d "Cannot directly include .0rx source files."+ | isSuffixOf ".0rt" d = argError n2 d "Cannot directly include .0rt test files." | otherwise = do- checkPathName n d "-i"- return (os,CompileOptions (maybeDisableHelp h) (is ++ [d]) is2 ds es ep ec p m o f)+ checkPathName n2 d "-i"+ return (os2,CompileOptions (maybeDisableHelp h) (is ++ [d]) is2 ds es ep ec p m o f) update _ = argError n "-i" "Requires a source path." parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-I"):os) = update os where- update ((n,d):os)- | isSuffixOf ".0rp" d = argError n d "Cannot directly include .0rp source files."- | isSuffixOf ".0rx" d = argError n d "Cannot directly include .0rx source files."- | isSuffixOf ".0rt" d = argError n d "Cannot directly include .0rt test files."+ update ((n2,d):os2)+ | isSuffixOf ".0rp" d = argError n2 d "Cannot directly include .0rp source files."+ | isSuffixOf ".0rx" d = argError n2 d "Cannot directly include .0rx source files."+ | isSuffixOf ".0rt" d = argError n2 d "Cannot directly include .0rt test files." | otherwise = do- checkPathName n d "-i"- return (os,CompileOptions (maybeDisableHelp h) is (is2 ++ [d]) ds es ep ec p m o f)+ checkPathName n2 d "-i"+ return (os2,CompileOptions (maybeDisableHelp h) is (is2 ++ [d]) ds es ep ec p m o f) update _ = argError n "-I" "Requires a source path." parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-e"):os) = update os where- update ((n,e):os)+ update ((n2,e):os2) | any (flip isSuffixOf e) allowedExtraTypes = do- checkPathName n e "-e"- return (os,CompileOptions (maybeDisableHelp h) is is2 ds (es ++ [e]) ep ec p m o f)+ checkPathName n2 e "-e"+ return (os2,CompileOptions (maybeDisableHelp h) is is2 ds (es ++ [e]) ep ec p m o f) | takeExtension e == "" || e == "." = do- checkPathName n e "-e"- return (os,CompileOptions (maybeDisableHelp h) is is2 ds es (ep ++ [e]) ec p m o f)- | otherwise = argError n "-e" $ "Only " ++ intercalate ", " allowedExtraTypes ++- " and directory sources are allowed."+ checkPathName n2 e "-e"+ return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es (ep ++ [e]) ec p m o f)+ | otherwise = argError n2 "-e" $ "Only " ++ intercalate ", " allowedExtraTypes +++ " and directory sources are allowed." update _ = argError n "-e" "Requires a source filename." parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,"-p"):os) | not $ null p = argError n "-p" "Path prefix already set." | otherwise = update os where- update ((n,p):os) = do- checkPathName n p "-p"- return (os,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p m o f)+ update ((n2,p2):os2) = do+ checkPathName n2 p2 "-p"+ return (os2,CompileOptions (maybeDisableHelp h) is is2 ds es ep ec p2 m o f) update _ = argError n "-p" "Requires a path prefix." - parseSingle _ ((n,o@('-':_)):os) = argError n o "Unknown option."+ parseSingle _ ((n,o@('-':_)):_) = argError n o "Unknown option." parseSingle (CompileOptions h is is2 ds es ep ec p m o f) ((n,d):os) | isSuffixOf ".0rp" d = argError n d "Cannot directly include .0rp source files."@@ -189,7 +192,7 @@ return (os,CompileOptions (maybeDisableHelp h) is is2 (ds ++ [d]) es ep ec p m o f) validateCompileOptions :: CompileErrorM m => CompileOptions -> m CompileOptions-validateCompileOptions co@(CompileOptions h is is2 ds es ep ec p m o _)+validateCompileOptions co@(CompileOptions h is is2 ds es ep _ p m o _) | h /= HelpNotNeeded = return co | (not $ null o) && (isCompileIncremental m) =
src/Cli/TestRunner.hs view
@@ -23,7 +23,6 @@ import Control.Arrow (second) import Control.Monad (when) import Data.List (isSuffixOf,nub)-import System.Directory (setCurrentDirectory) import System.IO import System.Posix.Temp (mkdtemp) import System.FilePath@@ -38,7 +37,6 @@ import CompilerCxx.Naming import Config.Programs import Parser.SourceFile-import Types.Builtin import Types.IntegrationTest import Types.TypeCategory import Types.TypeInstance@@ -65,13 +63,13 @@ let context = formatFullContextBrace (ithContext $ itHeader t) hPutStrLn stderr $ "\n*** Executing test \"" ++ name ++ "\" ***" outcome <- fmap (flip reviseError ("\nIn test \"" ++ name ++ "\"" ++ context)) $- run name (ithResult $ itHeader t) (itCategory t) (itDefinition t)+ run (ithResult $ itHeader t) (itCategory t) (itDefinition t) if isCompileError outcome then hPutStrLn stderr $ "*** Test \"" ++ name ++ "\" failed ***" else hPutStrLn stderr $ "*** Test \"" ++ name ++ "\" passed ***" return outcome - run n (ExpectCompileError _ rs es) cs ds = do+ run (ExpectCompileError _ rs es) cs ds = do let result = compileAll Nothing cs ds :: CompileInfo ([CategoryName],[String],Namespace,[CxxOutput]) if not $ isCompileError result then return $ compileError "Expected compiler error"@@ -80,8 +78,8 @@ let errors = show $ getCompileError result checkContent rs es (warnings ++ lines errors) [] [] - run n (ExpectRuntimeError _ e rs es) cs ds = execute False n e rs es cs ds- run n (ExpectRuntimeSuccess _ e rs es) cs ds = execute True n e rs es cs ds+ run (ExpectRuntimeError _ e rs es) cs ds = execute False e rs es cs ds+ run (ExpectRuntimeSuccess _ e rs es) cs ds = execute True e rs es cs ds checkContent rs es comp err out = do let cr = checkRequired rs comp err out@@ -99,7 +97,7 @@ then mergeAllM [cr,ce,compError,errError,outError] else mergeAllM [cr,ce] - execute s n e rs es cs ds = do+ execute s2 e rs es cs ds = do let result = compileAll (Just e) cs ds :: CompileInfo ([CategoryName],[String],Namespace,[CxxOutput]) if isCompileError result then return $ result >> return ()@@ -108,8 +106,8 @@ let (req,main,ns,fs) = getCompileSuccess result binaryName <- createBinary main req [ns] fs let command = TestCommand binaryName (takeDirectory binaryName)- (TestCommandResult s' out err) <- runTestCommand b command- case (s,s') of+ (TestCommandResult s2' out err) <- runTestCommand b command+ case (s2,s2') of (True,False) -> return $ mergeAllM $ map compileError $ warnings ++ err ++ out (False,True) -> return $ compileError "Expected runtime failure" _ -> return $ checkContent rs es warnings err out@@ -131,7 +129,7 @@ xx <- compileCategoryModule cm tm' <- includeNewTypes tm cs' (req,main) <- case e of- Just e -> createTestFile tm' e+ Just e2 -> createTestFile tm' e2 Nothing -> return ([],[]) return (req,main,ns1,xx) @@ -164,9 +162,8 @@ let os' = ofr ns req let command = CompileToBinary main os' binary paths' runCxxCommand b command- return binary- writeSingleFile d ca@(CxxOutput _ f _ _ _ content) = do- writeFile (d </> f) $ concat $ map (++ "\n") content- if isSuffixOf ".cpp" f- then return ([d </> f],ca)+ writeSingleFile d ca@(CxxOutput _ f2 _ _ _ content) = do+ writeFile (d </> f2) $ concat $ map (++ "\n") content+ if isSuffixOf ".cpp" f2+ then return ([d </> f2],ca) else return ([],ca)
src/Compilation/CompileInfo.hs view
@@ -34,7 +34,14 @@ import Data.Functor import Prelude hiding (concat,foldr) -#if MIN_VERSION_base(4,9,0)+#if MIN_VERSION_base(4,8,0)+#else+import Data.Foldable+#endif++#if MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ()+#elif MIN_VERSION_base(4,9,0) import Control.Monad.Fail #endif @@ -66,14 +73,19 @@ csData :: a } +getCompileError :: CompileInfo a -> CompileMessage getCompileError = cfErrors++getCompileSuccess :: CompileInfo a -> a getCompileSuccess = csData++getCompileWarnings :: CompileInfo a -> [String] getCompileWarnings (CompileFail w _) = w getCompileWarnings (CompileSuccess w _) = w instance Functor CompileInfo where- fmap f (CompileFail w e) = CompileFail w e -- Not the same a.+ fmap _ (CompileFail w e) = CompileFail w e -- Not the same a. fmap f (CompileSuccess w d) = CompileSuccess w (f d) instance Applicative CompileInfo where@@ -87,6 +99,7 @@ (CompileSuccess w d) >>= f = prependWarning w $ f d return = CompileSuccess [] +prependWarning :: [String] -> CompileInfo a -> CompileInfo a prependWarning w (CompileSuccess w2 d) = CompileSuccess (w ++ w2) d prependWarning w (CompileFail w2 e) = CompileFail (w ++ w2) e @@ -102,13 +115,13 @@ result ([],_,ws) = CompileFail ws $ CompileMessage "No choices found" [] result (es,_,ws) = CompileFail ws $ CompileMessage "" es reviseErrorM x@(CompileSuccess _ _) _ = x- reviseErrorM x@(CompileFail w (CompileMessage [] ms)) s = CompileFail w $ CompileMessage s ms- reviseErrorM x@(CompileFail w e) s = CompileFail w $ CompileMessage s [e]+ reviseErrorM (CompileFail w (CompileMessage [] ms)) s = CompileFail w $ CompileMessage s ms+ reviseErrorM (CompileFail w e) s = CompileFail w $ CompileMessage s [e] compileWarningM w = CompileSuccess [w] () instance MergeableM CompileInfo where mergeAnyM = result . splitErrorsAndData where- result (_,xs@(x:_),ws) = CompileSuccess ws $ mergeAny xs+ result (_,xs@(_:_),ws) = CompileSuccess ws $ mergeAny xs result ([],_,ws) = CompileFail ws $ CompileMessage "No choices found" [] result (es,_,ws) = CompileFail ws $ CompileMessage "" es mergeAllM = result . splitErrorsAndData where@@ -124,6 +137,7 @@ fail = compileErrorM #endif +nestMessages :: CompileMessage -> CompileMessage -> CompileMessage nestMessages (CompileMessage m1 ms1) (CompileMessage [] ms2) = CompileMessage m1 (ms1 ++ ms2) nestMessages (CompileMessage [] ms1) (CompileMessage m2 ms2) =
src/Compilation/CompilerState.hs view
@@ -25,8 +25,8 @@ CleanupSetup(..), CompilerContext(..), CompiledData(..),- CompilerState(..),- ExpressionType(..),+ CompilerState,+ ExpressionType, LoopSetup(..), MemberValue(..), ReturnVariable(..),@@ -72,7 +72,6 @@ import Base.CompileError import Base.Mergeable import Types.DefinedCategory-import Types.Function import Types.Positional import Types.Procedure import Types.TypeCategory
src/Compilation/ProcedureContext.hs view
@@ -35,7 +35,6 @@ import Base.Mergeable import Compilation.CompilerState import Types.DefinedCategory-import Types.Function import Types.GeneralType import Types.Positional import Types.Procedure@@ -118,7 +117,6 @@ -- A different category than the procedure. | otherwise = do (_,ca) <- getCategory (pcCategories ctx) (c,t)- let params = Positional $ map vpParam $ getCategoryParams ca let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca checkFunction $ n `Map.lookup` fa checkFunction (Just f) = do@@ -133,10 +131,10 @@ " does not have a category function named " ++ show n ++ formatFullContextBrace c ccGetTypeFunction ctx c t n = getFunction t where- getFunction (Just t@(TypeMerge MergeUnion _)) =+ getFunction (Just t2@(TypeMerge MergeUnion _)) = compileError $ "Use explicit type conversion to call " ++ show n ++ " for union type " ++- show t ++ formatFullContextBrace c- getFunction (Just t@(TypeMerge MergeIntersect ts)) =+ show t2 ++ formatFullContextBrace c+ getFunction (Just (TypeMerge MergeIntersect ts)) = collectOneOrErrorM $ map getFunction $ map Just ts getFunction (Just (SingleType (JustParamName p))) = do fa <- ccAllFilters ctx@@ -149,24 +147,24 @@ [compileError $ "Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c] ++ (map getFunction $ map (Just . SingleType) ts) ++ (map checkDefine ds)- getFunction (Just (SingleType (JustTypeInstance t)))+ getFunction (Just (SingleType (JustTypeInstance t2))) -- Same category as the procedure itself.- | tiName t == pcType ctx =- checkFunction (tiName t) (fmap vpParam $ pcExtParams ctx) (tiParams t) $ n `Map.lookup` pcFunctions ctx+ | tiName t2 == pcType ctx =+ checkFunction (tiName t2) (fmap vpParam $ pcExtParams ctx) (tiParams t2) $ n `Map.lookup` pcFunctions ctx -- A different category than the procedure. | otherwise = do- (_,ca) <- getCategory (pcCategories ctx) (c,tiName t)+ (_,ca) <- getCategory (pcCategories ctx) (c,tiName t2) let params = Positional $ map vpParam $ getCategoryParams ca let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca- checkFunction (tiName t) params (tiParams t) $ n `Map.lookup` fa+ checkFunction (tiName t2) params (tiParams t2) $ n `Map.lookup` fa getFunction Nothing = do let ps = fmap (SingleType . JustParamName . vpParam) $ pcExtParams ctx getFunction (Just $ SingleType $ JustTypeInstance $ TypeInstance (pcType ctx) ps)- checkDefine t = do- (_,ca) <- getCategory (pcCategories ctx) (c,diName t)+ checkDefine t2 = do+ (_,ca) <- getCategory (pcCategories ctx) (c,diName t2) let params = Positional $ map vpParam $ getCategoryParams ca let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca- checkFunction (diName t) params (diParams t) $ n `Map.lookup` fa+ checkFunction (diName t2) params (diParams t2) $ n `Map.lookup` fa checkFunction t2 ps1 ps2 (Just f) = do when (pcDisallowInit ctx && t2 == pcType ctx) $ compileError $ "Function " ++ show n ++@@ -199,10 +197,10 @@ let positional = map (getFilters mapped) (map vpParam $ pValues $ pcIntParams ctx) assigned <- fmap Map.fromList $ processPairs alwaysPair (fmap vpParam $ pcIntParams ctx) ps subbed <- fmap Positional $ collectAllOrErrorM $ map (assignFilters assigned) positional- processPairs (validateAssignment r allFilters) ps subbed+ processPairs_ (validateAssignment r allFilters) ps subbed -- Check initializer types. ms <- fmap Positional $ collectAllOrErrorM $ map (subSingle pa') (pcMembers ctx)- processPairs (checkInit r allFilters) ms (Positional $ zip [1..] $ pValues ts)+ processPairs_ (checkInit r allFilters) ms (Positional $ zip ([1..] :: [Int]) $ pValues ts) return () where getFilters fm n =@@ -211,12 +209,12 @@ _ -> [] assignFilters fm fs = do collectAllOrErrorM $ map (uncheckedSubFilter $ getValueForParam fm) fs- checkInit r fa (MemberValue c n t0) (i,t1) = do+ checkInit r fa (MemberValue c2 n t0) (i,t1) = do checkValueTypeMatch r fa t1 t0 `reviseError`- ("In initializer " ++ show i ++ " for " ++ show n ++ formatFullContextBrace c)- subSingle pa (DefinedMember c _ t n _) = do- t' <- uncheckedSubValueType (getValueForParam pa) t- return $ MemberValue c n t'+ ("In initializer " ++ show i ++ " for " ++ show n ++ formatFullContextBrace c2)+ subSingle pa (DefinedMember c2 _ t2 n _) = do+ t2' <- uncheckedSubValueType (getValueForParam pa) t2+ return $ MemberValue c2 n t2' ccGetVariable ctx c n = case n `Map.lookup` pcVariables ctx of (Just v) -> return v@@ -353,6 +351,7 @@ combineParallel r UnreachableCode = r combineParallel (ValidateNames ts ra1) (ValidateNames _ ra2) = ValidateNames ts $ Map.union ra1 ra2 combineParallel r@(ValidatePositions _) _ = r+ combineParallel _ r@(ValidatePositions _) = r ccRegisterReturn ctx c vs = do check (pcReturns ctx) return $ ProcedureContext {@@ -380,12 +379,12 @@ check (ValidatePositions rs) = do let vs' = case vs of Nothing -> Positional []- Just vs -> vs- processPairs checkReturnType rs (Positional $ zip [1..] $ pValues vs') `reviseError`+ Just vs2 -> vs2+ processPairs_ checkReturnType rs (Positional $ zip ([0..] :: [Int]) $ pValues vs') `reviseError` ("In procedure return at " ++ formatFullContext c) return () where- checkReturnType ta0@(PassedValue c0 t0) (n,t) = do+ checkReturnType ta0@(PassedValue _ t0) (n,t) = do r <- ccResolver ctx pa <- ccAllFilters ctx checkValueTypeMatch r pa t t0 `reviseError`@@ -393,7 +392,7 @@ show n ++ " at " ++ formatFullContext c) check (ValidateNames ts ra) = case vs of- Just vs -> check (ValidatePositions ts)+ Just _ -> check (ValidatePositions ts) Nothing -> mergeAllM $ map alwaysError $ Map.toList ra where alwaysError (n,t) = compileError $ "Named return " ++ show n ++ " (" ++ show t ++ ") might not have been set before return at " ++
src/Compilation/ScopeContext.hs view
@@ -27,13 +27,12 @@ ) where import Control.Monad (when)+import Prelude hiding (pi) import qualified Data.Map as Map-import qualified Data.Set as Set import Base.CompileError import Base.Mergeable import Types.DefinedCategory-import Types.Function import Types.GeneralType import Types.Positional import Types.Procedure@@ -65,8 +64,8 @@ applyProcedureScope f (ProcedureScope ctx fs) = map (uncurry (f ctx)) fs getProcedureScopes :: (Show c, CompileErrorM m, MergeableM m) =>- CategoryMap c -> [Namespace] -> DefinedCategory c -> m [ProcedureScope c]-getProcedureScopes ta ns dd@(DefinedCategory c n pi _ _ fi ms ps fs) = do+ CategoryMap c -> DefinedCategory c -> m [ProcedureScope c]+getProcedureScopes ta (DefinedCategory c n pi _ _ fi ms ps fs) = do (_,t) <- getConcreteCategory ta (c,n) let params = Positional $ getCategoryParams t let params2 = Positional pi@@ -94,25 +93,25 @@ return [ProcedureScope ctxC cp,ProcedureScope ctxT tp,ProcedureScope ctxV vp] where builtins t s0 = Map.filter ((<= s0) . vvScope) $ builtinVariables t- checkInternalParams pi fi pe fs r fa = do- let pm = Map.fromList $ map (\p -> (vpParam p,vpContext p)) pi- mergeAllM $ map (checkFunction pm) fs+ checkInternalParams pi2 fi2 pe fs2 r fa = do+ let pm = Map.fromList $ map (\p -> (vpParam p,vpContext p)) pi2+ mergeAllM $ map (checkFunction pm) fs2 mergeAllM $ map (checkParam pm) pe- let fa' = Map.union fa $ getFilterMap pi fi- mergeAllM $ map (checkFilter r fa') fi- checkFilter r fa (ParamFilter c n f) =+ let fa' = Map.union fa $ getFilterMap pi2 fi2+ mergeAllM $ map (checkFilter r fa') fi2+ checkFilter r fa (ParamFilter c2 n2 f) = validateTypeFilter r fa f `reviseError`- (show n ++ " " ++ show f ++ formatFullContextBrace c)+ (show n2 ++ " " ++ show f ++ formatFullContextBrace c2) checkFunction pm f = when (sfScope f == ValueScope) $ mergeAllM $ map (checkParam pm) $ pValues $ sfParams f checkParam pm p = case vpParam p `Map.lookup` pm of Nothing -> return ()- (Just c) -> compileError $ "Internal param " ++ show (vpParam p) ++- formatFullContextBrace c ++- " is already defined at " ++- formatFullContext (vpContext p)+ (Just c2) -> compileError $ "Internal param " ++ show (vpParam p) +++ formatFullContextBrace (vpContext p) +++ " is already defined at " +++ formatFullContext c2 -- TODO: This is probably in the wrong module. builtinVariables :: TypeInstance -> Map.Map VariableName (VariableValue c)
src/CompilerCxx/Category.hs view
@@ -33,7 +33,8 @@ compileModuleMain, ) where -import Data.List (intercalate,nub,sortOn)+import Data.List (intercalate,sortBy)+import Prelude hiding (pi) import qualified Data.Map as Map import qualified Data.Set as Set @@ -45,9 +46,7 @@ import CompilerCxx.Code import CompilerCxx.Naming import CompilerCxx.Procedure-import Types.Builtin import Types.DefinedCategory-import Types.Function import Types.GeneralType import Types.Positional import Types.Procedure@@ -88,9 +87,9 @@ hxx <- collectAllOrErrorM $ map (compileCategoryDeclaration tm') cs let interfaces = filter (not . isValueConcrete) cs cxx <- collectAllOrErrorM $ map compileInterfaceDefinition interfaces- xa <- collectAllOrErrorM $ map compileInternal xa- let xx = concat $ map snd xa- let dm = Map.fromListWith (++) $ map (\d -> (dcName d,[d])) $ concat $ map fst xa+ xa2 <- collectAllOrErrorM $ map compileInternal xa+ let xx = concat $ map snd xa2+ let dm = Map.fromListWith (++) $ map (\d -> (dcName d,[d])) $ concat $ map fst xa2 checkDuplicates dm cs return $ hxx ++ cxx ++ xx where compileInternal (PrivateSource ns1 cs2 ds) = do@@ -101,9 +100,9 @@ cxx1 <- collectAllOrErrorM $ map compileInterfaceDefinition interfaces cxx2 <- collectAllOrErrorM $ map (compileDefinition tm' (ns1:ns)) ds return (ds,hxx ++ cxx1 ++ cxx2)- compileDefinition tm ns d = do- tm' <- mergeInternalInheritance tm d- compileConcreteDefinition tm' ns d+ compileDefinition tm2 ns2 d = do+ tm2' <- mergeInternalInheritance tm2 d+ compileConcreteDefinition tm2' ns2 d checkDuplicates dm = mergeAllM . map (check dm) check dm t = case getCategoryName t `Map.lookup` dm of@@ -117,8 +116,7 @@ compileModuleMain :: (Show c, CompileErrorM m, MergeableM m) => CategoryModule c -> CategoryName -> FunctionName -> m CxxOutput-compileModuleMain (CategoryModule tm ns cs xa) n f = do- tm' <- includeNewTypes tm cs+compileModuleMain (CategoryModule tm _ cs xa) n f = do xx <- fmap concat $ collectAllOrErrorM $ filter (not . isCompileError) $ map maybeCompileMain xa reconcile xx where maybeCompileMain (PrivateSource _ cs2 ds) = do@@ -127,8 +125,8 @@ let dm = Set.fromList $ map dcName ds if n `Set.member` dm then do- (ns,main) <- createMainFile tm' n f- return [CxxOutput Nothing mainFilename NoNamespace [ns] [n] main]+ (ns2,main) <- createMainFile tm' n f+ return [CxxOutput Nothing mainFilename NoNamespace [ns2] [n] main] else return [] reconcile [x] = return x reconcile [] = compileErrorM $ "No matches for main category " ++ show n@@ -151,7 +149,7 @@ onlyCodes guardBottom ] depends = getCategoryDeps t- content = onlyCodes $ collection ++ labels ++ getCategory ++ getType+ content = onlyCodes $ collection ++ labels ++ getCategory2 ++ getType name = getCategoryName t guardTop = ["#ifndef " ++ guardName,"#define " ++ guardName] guardBottom = ["#endif // " ++ guardName]@@ -164,7 +162,7 @@ collection | isValueConcrete t = [] | otherwise = ["extern const void* const " ++ collectionName name ++ ";"]- getCategory+ getCategory2 | isInstanceInterface t = [] | otherwise = declareGetCategory t getType@@ -173,9 +171,6 @@ compileInterfaceDefinition :: MergeableM m => AnyCategory c -> m CxxOutput compileInterfaceDefinition t = do- top <- return emptyCode- bottom <- return emptyCode- ce <- return emptyCode te <- typeConstructor commonDefineAll t [] emptyCode emptyCode emptyCode te [] where@@ -185,7 +180,7 @@ let argsPassed = "Params<" ++ show (length ps) ++ ">::Type params" let allArgs = intercalate ", " [argParent,argsPassed] let initParent = "parent(p)"- let initPassed = map (\(i,p) -> paramName p ++ "(*std::get<" ++ show i ++ ">(params))") $ zip [0..] ps+ let initPassed = map (\(i,p) -> paramName p ++ "(*std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) ps let allInit = intercalate ", " $ initParent:initPassed return $ onlyCode $ typeName (getCategoryName t) ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" @@ -222,10 +217,10 @@ compileConcreteDefinition :: (Show c, CompileErrorM m, MergeableM m) => CategoryMap c -> [Namespace] -> DefinedCategory c -> m CxxOutput-compileConcreteDefinition ta ns dd@(DefinedCategory c n pi _ _ fi ms ps fs) = do+compileConcreteDefinition ta ns dd@(DefinedCategory c n pi _ _ fi ms _ fs) = do (_,t) <- getConcreteCategory ta (c,n) let r = CategoryResolver ta- [cp,tp,vp] <- getProcedureScopes ta ns dd+ [cp,tp,vp] <- getProcedureScopes ta dd cf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure cp tf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure tp vf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure vp@@ -250,7 +245,7 @@ ] defineValue <- mergeAllM [ return $ onlyCode $ "struct " ++ valueName n ++ " : public " ++ valueBase ++ " {",- fmap indentCompiled $ valueConstructor ta t vm,+ fmap indentCompiled $ valueConstructor vm, fmap indentCompiled $ valueDispatch allFuncs, return $ indentCompiled $ defineCategoryName2 n, return $ indentCompiled $ mergeAll $ map fst vf,@@ -264,13 +259,13 @@ defineInternalValue n internalCount memberCount ] ++ map (return . snd) (cf ++ tf ++ vf) ce <- mergeAllM [- categoryConstructor ta t cm,+ categoryConstructor t cm, categoryDispatch allFuncs, return $ mergeAll $ map fst cf, mergeAllM $ map (createMemberLazy r allFilters) cm ] te <- mergeAllM [- typeConstructor ta t tm,+ typeConstructor t tm, typeDispatch allFuncs, return $ mergeAll $ map fst tf, mergeAllM $ map (createMember r allFilters) tm@@ -288,13 +283,13 @@ createParam p = return $ onlyCode $ paramType ++ " " ++ paramName (vpParam p) ++ ";" -- TODO: Can probably remove this if @type members are disallowed. Or, just -- skip it if there are no @type members.- getCycleCheck n = [- "CycleCheck<" ++ n ++ ">::Check();",- "CycleCheck<" ++ n ++ "> marker(*this);"+ getCycleCheck n2 = [+ "CycleCheck<" ++ n2 ++ ">::Check();",+ "CycleCheck<" ++ n2 ++ "> marker(*this);" ]- categoryConstructor tm t ms = do- ctx <- getContextForInit tm t dd CategoryScope- initMembers <- runDataCompiler (sequence $ map compileLazyInit ms) ctx+ categoryConstructor t ms2 = do+ ctx <- getContextForInit ta t dd CategoryScope+ initMembers <- runDataCompiler (sequence $ map compileLazyInit ms2) ctx let initMembersStr = intercalate ", " $ cdOutput initMembers let initColon = if null initMembersStr then "" else " : " mergeAllM [@@ -304,16 +299,16 @@ return $ onlyCode "}", return $ clearCompiled initMembers -- Inherit required types. ]- typeConstructor tm t ms = do- let ps = map vpParam $ getCategoryParams t+ typeConstructor t ms2 = do+ let ps2 = map vpParam $ getCategoryParams t let argParent = categoryName n ++ "& p"- let paramsPassed = "Params<" ++ show (length ps) ++ ">::Type params"+ let paramsPassed = "Params<" ++ show (length ps2) ++ ">::Type params" let allArgs = intercalate ", " [argParent,paramsPassed] let initParent = "parent(p)"- let initPassed = map (\(i,p) -> paramName p ++ "(*std::get<" ++ show i ++ ">(params))") $ zip [0..] ps+ let initPassed = map (\(i,p) -> paramName p ++ "(*std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) ps2 let allInit = intercalate ", " $ initParent:initPassed- ctx <- getContextForInit tm t dd TypeScope- initMembers <- runDataCompiler (sequence $ map initMember ms) ctx+ ctx <- getContextForInit ta t dd TypeScope+ initMembers <- runDataCompiler (sequence $ map initMember ms2) ctx mergeAllM [ return $ onlyCode $ typeName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {", return $ indentCompiled $ onlyCodes $ getCycleCheck (typeName n),@@ -321,14 +316,14 @@ return $ indentCompiled $ initMembers, return $ onlyCode "}" ]- valueConstructor tm t ms = do+ valueConstructor ms2 = do let argParent = typeName n ++ "& p" let paramsPassed = "const ParamTuple& params" let argsPassed = "const ValueTuple& args" let allArgs = intercalate ", " [argParent,paramsPassed,argsPassed] let initParent = "parent(p)"- let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(*params.At(" ++ show i ++ "))") $ zip [0..] pi- let initArgs = map (\(i,m) -> variableName (dmName m) ++ "(" ++ unwrappedArg i m ++ ")") $ zip [0..] ms+ let initParams = map (\(i,p) -> paramName (vpParam p) ++ "(*params.At(" ++ show i ++ "))") $ zip ([0..] :: [Int]) pi+ let initArgs = map (\(i,m) -> variableName (dmName m) ++ "(" ++ unwrappedArg i m ++ ")") $ zip ([0..] :: [Int]) ms2 let allInit = intercalate ", " $ initParent:(initParams ++ initArgs) return $ onlyCode $ valueName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" unwrappedArg i m = writeStoredVariable (dmType m) (UnwrappedSingle $ "args.At(" ++ show i ++ ")")@@ -341,32 +336,32 @@ ("In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)) return $ onlyCode $ variableLazyType (dmType m) ++ " " ++ variableName (dmName m) ++ ";" initMember (DefinedMember _ _ _ _ Nothing) = return mergeDefault- initMember (DefinedMember c s t n (Just e)) = do- csAddVariable c n (VariableValue c s t True)- let assign = Assignment c (Positional [ExistingVariable (InputValue c n)]) e+ initMember (DefinedMember c2 s t n2 (Just e)) = do+ csAddVariable c2 n2 (VariableValue c2 s t True)+ let assign = Assignment c2 (Positional [ExistingVariable (InputValue c2 n2)]) e compileStatement assign- categoryDispatch fs =+ categoryDispatch fs2 = return $ onlyCodes $ [ "ReturnTuple Dispatch(" ++ "const CategoryFunction& label, " ++ "const ParamTuple& params, " ++ "const ValueTuple& args) final {"- ] ++ createFunctionDispatch n CategoryScope fs ++ ["}"]- typeDispatch fs =+ ] ++ createFunctionDispatch n CategoryScope fs2 ++ ["}"]+ typeDispatch fs2 = return $ onlyCodes $ [ "ReturnTuple Dispatch(" ++ "const TypeFunction& label, " ++ "const ParamTuple& params, " ++ "const ValueTuple& args) final {"- ] ++ createFunctionDispatch n TypeScope fs ++ ["}"]- valueDispatch fs =+ ] ++ createFunctionDispatch n TypeScope fs2 ++ ["}"]+ valueDispatch fs2 = return $ onlyCodes $ [ "ReturnTuple Dispatch(" ++ "const S<TypeValue>& self, " ++ "const ValueFunction& label, " ++ "const ParamTuple& params," ++ "const ValueTuple& args) final {"- ] ++ createFunctionDispatch n ValueScope fs ++ ["}"]+ ] ++ createFunctionDispatch n ValueScope fs2 ++ ["}"] commonDefineAll :: MergeableM m => AnyCategory c -> [Namespace] -> CompiledData [String] -> CompiledData [String] ->@@ -402,7 +397,7 @@ defineInternalType name paramCount, return bottom, return $ onlyCode $ "} // namespace",- return $ onlyCodes $ getCategory ++ getType+ return $ onlyCodes $ getCategory2 ++ getType ] declareTypes = return $ onlyCodes $ map (\f -> "class " ++ f name ++ ";") [categoryName,typeName]@@ -417,10 +412,11 @@ collectionValName = "collection_" ++ show name (fc,ft,fv) = partitionByScope sfScope $ getCategoryFunctions t ++ fe createAllLabels = onlyCodes $ concat $ map createLabels [fc,ft,fv]- createLabels = map (uncurry createLabelForFunction) . zip [0..] . sortOn sfName . filter ((== name) . sfType)+ createLabels = map (uncurry createLabelForFunction) . zip [0..] . sortBy compareName . filter ((== name) . sfType) getInternal = defineInternalCategory t- getCategory = defineGetCatetory t+ getCategory2 = defineGetCatetory t getType = defineGetType t+ compareName x y = sfName x `compare` sfName y addNamespace :: AnyCategory c -> CompiledData [String] -> CompiledData [String] addNamespace t cs@@ -460,17 +456,19 @@ "::*)(const ParamTuple&, const ValueTuple&);" | s == ValueScope = " using CallType = ReturnTuple(" ++ valueName n ++ "::*)(const S<TypeValue>&, const ParamTuple&, const ValueTuple&);"+ | otherwise = undefined name f | s == CategoryScope = categoryName n ++ "::" ++ callName f | s == TypeScope = typeName n ++ "::" ++ callName f | s == ValueScope = valueName n ++ "::" ++ callName f- table (n2,fs) =+ | otherwise = undefined+ table (n2,fs2) = [" static const CallType " ++ tableName n2 ++ "[] = {"] ++- map (\f -> " &" ++ name f ++ ",") (Set.toList $ Set.fromList $ map sfName fs) +++ map (\f -> " &" ++ name f ++ ",") (Set.toList $ Set.fromList $ map sfName fs2) ++ [" };"]- dispatch (n2,fs) = [+ dispatch (n2,fs2) = [ " if (label.collection == " ++ collectionName n2 ++ ") {",- " if (label.function_num < 0 || label.function_num >= " ++ show (length fs) ++ ") {",+ " if (label.function_num < 0 || label.function_num >= " ++ show (length fs2) ++ ") {", " FAIL() << \"Bad function call \" << label;", " }", " return (this->*" ++ tableName n2 ++ "[label.function_num])(" ++ args ++ ");",@@ -480,10 +478,12 @@ | s == CategoryScope = "params, args" | s == TypeScope = "params, args" | s == ValueScope = "self, params, args"+ | otherwise = undefined fallback | s == CategoryScope = " return TypeCategory::Dispatch(label, params, args);" | s == TypeScope = " return TypeInstance::Dispatch(label, params, args);" | s == ValueScope = " return TypeValue::Dispatch(self, label, params, args);"+ | otherwise = undefined commonDefineCategory :: MergeableM m => AnyCategory c -> CompiledData [String] -> m (CompiledData [String])@@ -530,7 +530,7 @@ " }" ] ++ checks ++ [" return true;","}"] params = map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t- checks = concat $ map singleCheck $ zip [0..] params+ checks = concat $ map singleCheck $ zip ([0..] :: [Int]) params singleCheck (i,(p,Covariant)) = [ " if (!TypeInstance::CanConvert(*args[" ++ show i ++ "], " ++ paramName p ++ ")) return false;" ]@@ -551,8 +551,8 @@ myType = (getCategoryName t,map (SingleType . JustParamName . fst) params) refines = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType $ getCategoryRefines t allCats = concat $ map singleCat (myType:refines)- singleCat (t,ps) = [- " if (&category == &" ++ categoryGetter t ++ "()) {",+ singleCat (t2,ps) = [+ " if (&category == &" ++ categoryGetter t2 ++ "()) {", " args = std::vector<const TypeInstance*>{" ++ expanded ++ "};", " return true;", " }"@@ -565,12 +565,11 @@ expandLocalType (TypeMerge MergeUnion []) = allGetter ++ "()" expandLocalType (TypeMerge MergeIntersect []) = anyGetter ++ "()" expandLocalType (TypeMerge m ps) =- getter ++ "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps') ++ "))"+ getter m ++ "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps') ++ "))" where ps' = map expandLocalType ps- getter- | m == MergeUnion = unionGetter- | m == MergeIntersect = intersectGetter+ getter MergeUnion = unionGetter+ getter MergeIntersect = intersectGetter expandLocalType (SingleType (JustTypeInstance (TypeInstance t ps))) = typeGetter t ++ "(T_get(" ++ intercalate "," (map ("&" ++) ps') ++ "))" where@@ -581,10 +580,10 @@ defineCategoryName t = onlyCode $ "std::string CategoryName() const final { return \"" ++ show t ++ "\"; }" defineCategoryName2 :: CategoryName -> CompiledData [String]-defineCategoryName2 t = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }"+defineCategoryName2 _ = onlyCode $ "std::string CategoryName() const final { return parent.CategoryName(); }" defineTypeName :: CategoryName -> [ParamName] -> CompiledData [String]-defineTypeName t ps =+defineTypeName _ ps = onlyCodes [ "void BuildTypeName(std::ostream& output) const final {", " return TypeInstance::TypeNameFrom(output, parent" ++ concat (map ((", " ++) . paramName) ps) ++ ");",@@ -642,7 +641,7 @@ declareInternalValue :: Monad m => CategoryName -> Int -> Int -> m (CompiledData [String])-declareInternalValue t p n =+declareInternalValue t _ _ = return $ onlyCodes [ "S<TypeValue> " ++ valueCreator t ++ "(" ++ typeName t ++ "& parent, " ++@@ -651,7 +650,7 @@ defineInternalValue :: Monad m => CategoryName -> Int -> Int -> m (CompiledData [String])-defineInternalValue t p n =+defineInternalValue t _ _ = return $ onlyCodes [ "S<TypeValue> " ++ valueCreator t ++ "(" ++ typeName t ++ "& parent, " ++ "const ParamTuple& params, const ValueTuple& args) {",@@ -667,8 +666,8 @@ " ProgramArgv program_argv(argc, argv);", " " ++ startFunctionTracing n ] ++ out ++ ["}"] where- depIncludes req = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $- filter (not . isBuiltinCategory) $ Set.toList req+ depIncludes req2 = map (\i -> "#include \"" ++ headerFilename i ++ "\"") $+ filter (not . isBuiltinCategory) $ Set.toList req2 createMainFile :: (Show c, CompileErrorM m, MergeableM m) => CategoryMap c -> CategoryName -> FunctionName -> m (Namespace,[String])
src/CompilerCxx/CategoryContext.hs view
@@ -25,6 +25,7 @@ getProcedureContext, ) where +import Prelude hiding (pi) import qualified Data.Map as Map import qualified Data.Set as Set @@ -35,7 +36,6 @@ import Compilation.ScopeContext import CompilerCxx.Code import Types.DefinedCategory-import Types.Function import Types.GeneralType import Types.Positional import Types.Procedure@@ -86,7 +86,7 @@ ScopeContext c -> ScopedFunction c -> ExecutableProcedure c -> m (ProcedureContext c) getProcedureContext (ScopeContext tm t ps pi ms pa fi fa va) ff@(ScopedFunction _ _ _ s as1 rs1 ps1 fs _)- (ExecutableProcedure _ _ n as2 rs2 _) = do+ (ExecutableProcedure _ _ _ as2 rs2 _) = do rs' <- if isUnnamedReturns rs2 then return $ ValidatePositions rs1 else fmap (ValidateNames rs1 . Map.fromList) $ processPairs pairOutput rs1 (nrNames rs2)@@ -102,6 +102,7 @@ CategoryScope -> localScopes TypeScope -> Map.union typeScopes localScopes ValueScope -> Map.unions [localScopes,typeScopes,valueScopes]+ _ -> undefined let localFilters = getFunctionFilterMap ff let typeFilters = getFilterMap (pValues ps) pa let valueFilters = getFilterMap (pValues pi) fi@@ -109,6 +110,7 @@ CategoryScope -> localFilters TypeScope -> Map.union localFilters typeFilters ValueScope -> Map.unions [localFilters,typeFilters,valueFilters]+ _ -> undefined let ns0 = if isUnnamedReturns rs2 then [] else zipWith3 ReturnVariable [0..] (map ovName $ pValues $ nrNames rs2) (map pvType $ pValues rs1)@@ -136,7 +138,7 @@ pcCleanupSetup = CleanupSetup [] [] } where- pairOutput (PassedValue c1 t) (OutputValue c2 n) = return $ (n,PassedValue (c2++c1) t)+ pairOutput (PassedValue c1 t2) (OutputValue c2 n2) = return $ (n2,PassedValue (c2++c1) t2) getMainContext :: CompileErrorM m => CategoryMap c -> m (ProcedureContext c) getMainContext tm = return $ ProcedureContext {
src/CompilerCxx/Code.hs view
@@ -60,7 +60,6 @@ import Compilation.CompilerState import CompilerCxx.Naming import Types.Builtin-import Types.DefinedCategory import Types.Positional import Types.TypeCategory import Types.TypeInstance@@ -122,6 +121,7 @@ LazySingle ExprValue deriving (Show) +getFromLazy :: ExprValue -> ExprValue getFromLazy (OpaqueMulti e) = OpaqueMulti $ e ++ ".Get()" getFromLazy (WrappedSingle e) = WrappedSingle $ e ++ ".Get()" getFromLazy (UnwrappedSingle e) = UnwrappedSingle $ e ++ ".Get()"@@ -186,24 +186,21 @@ useAsUnwrapped (LazySingle e) = useAsUnwrapped $ getFromLazy e useAsUnboxed :: PrimitiveType -> ExprValue -> String-useAsUnboxed t (OpaqueMulti e)- | t == PrimBool = "(" ++ e ++ ").Only()->AsBool()"- | t == PrimString = "(" ++ e ++ ").Only()->AsString()"- | t == PrimChar = "(" ++ e ++ ").Only()->AsChar()"- | t == PrimInt = "(" ++ e ++ ").Only()->AsInt()"- | t == PrimFloat = "(" ++ e ++ ").Only()->AsFloat()"-useAsUnboxed t (WrappedSingle e)- | t == PrimBool = "(" ++ e ++ ")->AsBool()"- | t == PrimString = "(" ++ e ++ ")->AsString()"- | t == PrimChar = "(" ++ e ++ ")->AsChar()"- | t == PrimInt = "(" ++ e ++ ")->AsInt()"- | t == PrimFloat = "(" ++ e ++ ")->AsFloat()"-useAsUnboxed t (UnwrappedSingle e)- | t == PrimBool = "(" ++ e ++ ")->AsBool()"- | t == PrimString = "(" ++ e ++ ")->AsString()"- | t == PrimChar = "(" ++ e ++ ")->AsChar()"- | t == PrimInt = "(" ++ e ++ ")->AsInt()"- | t == PrimFloat = "(" ++ e ++ ")->AsFloat()"+useAsUnboxed PrimBool (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsBool()"+useAsUnboxed PrimString (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsString()"+useAsUnboxed PrimChar (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsChar()"+useAsUnboxed PrimInt (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsInt()"+useAsUnboxed PrimFloat (OpaqueMulti e) = "(" ++ e ++ ").Only()->AsFloat()"+useAsUnboxed PrimBool (WrappedSingle e) = "(" ++ e ++ ")->AsBool()"+useAsUnboxed PrimString (WrappedSingle e) = "(" ++ e ++ ")->AsString()"+useAsUnboxed PrimChar (WrappedSingle e) = "(" ++ e ++ ")->AsChar()"+useAsUnboxed PrimInt (WrappedSingle e) = "(" ++ e ++ ")->AsInt()"+useAsUnboxed PrimFloat (WrappedSingle e) = "(" ++ e ++ ")->AsFloat()"+useAsUnboxed PrimBool (UnwrappedSingle e) = "(" ++ e ++ ")->AsBool()"+useAsUnboxed PrimString (UnwrappedSingle e) = "(" ++ e ++ ")->AsString()"+useAsUnboxed PrimChar (UnwrappedSingle e) = "(" ++ e ++ ")->AsChar()"+useAsUnboxed PrimInt (UnwrappedSingle e) = "(" ++ e ++ ")->AsInt()"+useAsUnboxed PrimFloat (UnwrappedSingle e) = "(" ++ e ++ ")->AsFloat()" useAsUnboxed _ (BoxedPrimitive _ e) = "(" ++ e ++ ")" useAsUnboxed _ (UnboxedPrimitive _ e) = "(" ++ e ++ ")" useAsUnboxed t (LazySingle e) = useAsUnboxed t $ getFromLazy e@@ -273,6 +270,7 @@ getType CategoryScope = "const CategoryFunction&" getType TypeScope = "const TypeFunction&" getType ValueScope = "const ValueFunction&"+ getType _ = undefined newFunctionLabel :: Int -> ScopedFunction c -> String newFunctionLabel i f = "(*new " ++ (getType $ sfScope f) ++ "{ " ++ intercalate ", " args ++ " })" where@@ -295,7 +293,7 @@ getType CategoryScope = "CategoryFunction" getType TypeScope = "TypeFunction" getType ValueScope = "ValueFunction"-+ getType _ = undefined categoryBase :: String categoryBase = "TypeCategory"@@ -327,12 +325,12 @@ | null cs = "\"\"" | otherwise = escapeAll False "" cs where -- Creates alternating substrings of (un)escaped characters.- escapeAll False ss (c:cs)- | c `Set.member` unescapedChars = escapeAll False (ss ++ [c]) cs- | otherwise = maybeQuote ss ++ escapeAll True "" (c:cs)- escapeAll True ss (c:cs)- | c `Set.member` unescapedChars = maybeQuote ss ++ escapeAll False "" (c:cs)- | otherwise = escapeAll True (ss ++ escapeChar c) cs+ escapeAll False ss (c:cs2)+ | c `Set.member` unescapedChars = escapeAll False (ss ++ [c]) cs2+ | otherwise = maybeQuote ss ++ escapeAll True "" (c:cs2)+ escapeAll True ss (c:cs2)+ | c `Set.member` unescapedChars = maybeQuote ss ++ escapeAll False "" (c:cs2)+ | otherwise = escapeAll True (ss ++ escapeChar c) cs2 escapeAll _ ss "" = maybeQuote ss maybeQuote ss | null ss = ""
src/CompilerCxx/Naming.hs view
@@ -53,7 +53,6 @@ import Data.Hashable (Hashable,hash) import Numeric (showHex) -import Types.Function import Types.Procedure import Types.TypeCategory import Types.TypeInstance
src/CompilerCxx/Procedure.hs view
@@ -34,7 +34,6 @@ import Control.Monad.Trans.State (execStateT,get,put,runStateT) import Control.Monad.Trans (lift) import Data.List (intercalate)-import qualified Data.Map as Map import qualified Data.Set as Set import Base.CompileError@@ -97,24 +96,25 @@ | s == ValueScope = returnType ++ " " ++ valueName t ++ "::" ++ name ++ "(const S<TypeValue>& Var_self, const ParamTuple& params, const ValueTuple& args) {"+ | otherwise = undefined returnType = "ReturnTuple" setProcedureTrace = startFunctionTracing $ show t ++ "." ++ show n defineReturns | isUnnamedReturns rs2 = [] | otherwise = [returnType ++ " returns(" ++ show (length $ pValues rs1) ++ ");"]- nameParams = flip map (zip [0..] $ pValues ps1) $- (\(i,p) -> paramType ++ " " ++ paramName (vpParam p) ++ " = *params.At(" ++ show i ++ ");")- nameArgs = flip map (zip [0..] $ filter (not . isDiscardedInput . snd) $ zip (pValues as1) (pValues $ avNames as2)) $- (\(i,(t,n)) -> "const " ++ variableProxyType (pvType t) ++ " " ++ variableName (ivName n) ++- " = " ++ writeStoredVariable (pvType t) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") ++ ";")+ nameParams = flip map (zip ([0..] :: [Int]) $ pValues ps1) $+ (\(i,p2) -> paramType ++ " " ++ paramName (vpParam p2) ++ " = *params.At(" ++ show i ++ ");")+ nameArgs = flip map (zip ([0..] :: [Int]) $ filter (not . isDiscardedInput . snd) $ zip (pValues as1) (pValues $ avNames as2)) $+ (\(i,(t2,n2)) -> "const " ++ variableProxyType (pvType t2) ++ " " ++ variableName (ivName n2) +++ " = " ++ writeStoredVariable (pvType t2) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") ++ ";") nameReturns | isUnnamedReturns rs2 = []- | otherwise = map (\(i,(t,n)) -> nameReturn i (pvType t) n) (zip [0..] $ zip (pValues rs1) (pValues $ nrNames rs2))- nameReturn i t n- | isPrimType t = variableProxyType t ++ " " ++ variableName (ovName n) ++ ";"+ | otherwise = map (\(i,(t2,n2)) -> nameReturn i (pvType t2) n2) (zip ([0..] :: [Int]) $ zip (pValues rs1) (pValues $ nrNames rs2))+ nameReturn i t2 n2+ | isPrimType t2 = variableProxyType t2 ++ " " ++ variableName (ovName n2) ++ ";" | otherwise =- variableProxyType t ++ " " ++ variableName (ovName n) ++- " = " ++ writeStoredVariable t (UnwrappedSingle $ "returns.At(" ++ show i ++ ")") ++ ";"+ variableProxyType t2 ++ " " ++ variableName (ovName n2) +++ " = " ++ writeStoredVariable t2 (UnwrappedSingle $ "returns.At(" ++ show i ++ ")") ++ ";" compileCondition :: (Show c, CompileErrorM m, MergeableM m, CompilerContext c m [String] a) =>@@ -138,7 +138,7 @@ compileProcedure :: (Show c, CompileErrorM m, MergeableM m, CompilerContext c m [String] a) => a -> Procedure c -> CompilerState a m a-compileProcedure ctx (Procedure c ss) = do+compileProcedure ctx (Procedure _ ss) = do ctx' <- lift $ execStateT (sequence $ map (\s -> warnUnreachable s >> compileStatement s) ss) ctx return ctx' where warnUnreachable s = do@@ -165,7 +165,7 @@ autoPositionalCleanup e -- Multi-expression => must all be singles. getReturn rs = do- lift $ mergeAllM (map checkArity $ zip [1..] $ map (fst . snd) rs) `reviseError`+ lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) `reviseError` ("In return at " ++ formatFullContext c) csRegisterReturn c $ Just $ Positional $ map (head . pValues . fst . snd) rs let e = OpaqueMulti $ "ReturnTuple(" ++ intercalate "," (map (useAsUnwrapped . snd . snd) rs) ++ ")"@@ -192,14 +192,14 @@ e' <- compileExpression e when (length (pValues $ fst e') /= 1) $ lift $ compileError $ "Expected single return in argument" ++ formatFullContextBrace c- let (Positional [t0],e) = e'+ let (Positional [t0],e0) = e' r <- csResolver fa <- csAllFilters lift $ (checkValueTypeMatch r fa t0 formattedRequiredValue) `reviseError` ("In fail call at " ++ formatFullContext c) csSetNoReturn csWrite $ setTraceContext c- csWrite ["BuiltinFail(" ++ useAsUnwrapped e ++ ");"]+ csWrite ["BuiltinFail(" ++ useAsUnwrapped e0 ++ ");"] compileStatement (IgnoreValues c e) = do (_,e') <- compileExpression e csWrite $ setTraceContext c@@ -208,44 +208,44 @@ (ts,e') <- compileExpression e r <- csResolver fa <- csAllFilters- processPairsT (createVariable r fa) as ts `reviseErrorStateT`+ _ <- processPairsT (createVariable r fa) as ts `reviseErrorStateT` ("In assignment at " ++ formatFullContext c) csWrite $ setTraceContext c variableTypes <- sequence $ map (uncurry getVariableType) $ zip (pValues as) (pValues ts)- assignAll (zip3 [0..] variableTypes (pValues as)) e'+ assignAll (zip3 ([0..] :: [Int]) variableTypes (pValues as)) e' where- assignAll [v] e = assignSingle v e- assignAll vs e = do- csWrite ["{","const auto r = " ++ useAsReturns e ++ ";"]- sequence $ map assignMulti vs+ assignAll [v] e2 = assignSingle v e2+ assignAll vs e2 = do+ csWrite ["{","const auto r = " ++ useAsReturns e2 ++ ";"]+ sequence_ $ map assignMulti vs csWrite ["}"] getVariableType (CreateVariable _ t _) _ = return t- getVariableType (ExistingVariable (InputValue c n)) _ = do- (VariableValue _ _ t _) <- csGetVariable c n+ getVariableType (ExistingVariable (InputValue c2 n)) _ = do+ (VariableValue _ _ t _) <- csGetVariable c2 n return t getVariableType (ExistingVariable (DiscardInput _)) t = return t- createVariable r fa (CreateVariable c t1 n) t2 = do+ createVariable r fa (CreateVariable c2 t1 n) t2 = do -- TODO: Call csRequiresTypes for t1. (Maybe needs a helper function.) lift $ mergeAllM [validateGeneralInstance r fa (vtType t1), checkValueTypeMatch r fa t2 t1] `reviseError`- ("In creation of " ++ show n ++ " at " ++ formatFullContext c)- csAddVariable c n (VariableValue c LocalScope t1 True)+ ("In creation of " ++ show n ++ " at " ++ formatFullContext c2)+ csAddVariable c2 n (VariableValue c2 LocalScope t1 True) csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"]- createVariable r fa (ExistingVariable (InputValue c n)) t2 = do- (VariableValue _ s1 t1 w) <- csGetVariable c n+ createVariable r fa (ExistingVariable (InputValue c2 n)) t2 = do+ (VariableValue _ _ t1 w) <- csGetVariable c2 n when (not w) $ lift $ compileError $ "Cannot assign to read-only variable " ++- show n ++ formatFullContextBrace c+ show n ++ formatFullContextBrace c2 -- TODO: Also show original context. lift $ (checkValueTypeMatch r fa t2 t1) `reviseError`- ("In assignment to " ++ show n ++ " at " ++ formatFullContext c)+ ("In assignment to " ++ show n ++ " at " ++ formatFullContext c2) csUpdateAssigned n createVariable _ _ _ _ = return ()- assignSingle (i,t,CreateVariable _ _ n) e =- csWrite [variableName n ++ " = " ++ writeStoredVariable t e ++ ";"]- assignSingle (i,t,ExistingVariable (InputValue _ n)) e = do- (VariableValue _ s _ _) <- csGetVariable c n+ assignSingle (_,t,CreateVariable _ _ n) e2 =+ csWrite [variableName n ++ " = " ++ writeStoredVariable t e2 ++ ";"]+ assignSingle (_,t,ExistingVariable (InputValue c2 n)) e2 = do+ (VariableValue _ s _ _) <- csGetVariable c2 n scoped <- autoScope s- csWrite [scoped ++ variableName n ++ " = " ++ writeStoredVariable t e ++ ";"]+ csWrite [scoped ++ variableName n ++ " = " ++ writeStoredVariable t e2 ++ ";"] assignSingle _ _ = return () assignMulti (i,t,CreateVariable _ _ n) = csWrite [variableName n ++ " = " ++@@ -303,25 +303,26 @@ cs <- unwind es csInheritReturns (ctx:cs) where- unwind (IfStatement c e p es) = do+ unwind (IfStatement c2 e2 p2 es2) = do ctx0 <- getCleanContext- e' <- compileCondition ctx0 c e- ctx <- compileProcedure ctx0 p+ e2' <- compileCondition ctx0 c2 e2+ ctx <- compileProcedure ctx0 p2 (lift $ ccGetRequired ctx) >>= csRequiresTypes- csWrite ["else if (" ++ e' ++ ") {"]+ csWrite ["else if (" ++ e2' ++ ") {"] (lift $ ccGetOutput ctx) >>= csWrite csWrite ["}"]- cs <- unwind es+ cs <- unwind es2 return $ ctx:cs- unwind (ElseStatement c p) = do+ unwind (ElseStatement _ p2) = do ctx0 <- getCleanContext- ctx <- compileProcedure ctx0 p+ ctx <- compileProcedure ctx0 p2 (lift $ ccGetRequired ctx) >>= csRequiresTypes csWrite ["else {"] (lift $ ccGetOutput ctx) >>= csWrite csWrite ["}"] return [ctx] unwind TerminateConditional = fmap (:[]) get+compileIfElifElse _ = undefined compileWhileLoop :: (Show c, CompileErrorM m, MergeableM m, CompilerContext c m [String] a) =>@@ -354,10 +355,7 @@ ctx0 <- getCleanContext r <- csResolver fa <- csAllFilters- let cc = case cl of- Just (Procedure _ ss2) -> ss2- _ -> []- sequence $ map (createVariable r fa) vs+ sequence_ $ map (createVariable r fa) vs ctxP <- compileProcedure ctx0 p (ctxP',cl',ctxCl) <- case cl of@@ -379,7 +377,7 @@ (lift $ ccGetOutput ctxS) >>= csWrite csWrite cl' csWrite ["}"]- sequence $ map showVariable vs+ sequence_ $ map showVariable vs (lift $ ccGetRequired ctxS) >>= csRequiresTypes (lift $ ccGetRequired ctxCl) >>= csRequiresTypes csInheritReturns [ctxS]@@ -394,54 +392,54 @@ csAddVariable c n (VariableValue c LocalScope t True) -- Don't merge if the second scope has cleanup, so that the latter can't -- refer to variables defined in the first scope.- rewriteScoped (ScopedBlock c p cl@(Just _)- s@(NoValueExpression _ (WithScope- (ScopedBlock _ _ (Just _) _)))) =- ([],p,cl,s)+ rewriteScoped (ScopedBlock _ p cl@(Just _)+ s2@(NoValueExpression _ (WithScope+ (ScopedBlock _ _ (Just _) _)))) =+ ([],p,cl,s2) -- Merge chained scoped sections into a single section. rewriteScoped (ScopedBlock c (Procedure c2 ss1) cl1 (NoValueExpression _ (WithScope- (ScopedBlock _ (Procedure _ ss2) cl2 s)))) =- rewriteScoped $ ScopedBlock c (Procedure c2 $ ss1 ++ ss2) (cl1 <|> cl2) s+ (ScopedBlock _ (Procedure _ ss2) cl2 s2)))) =+ rewriteScoped $ ScopedBlock c (Procedure c2 $ ss1 ++ ss2) (cl1 <|> cl2) s2 -- Gather to-be-created variables. rewriteScoped (ScopedBlock _ p cl (Assignment c2 vs e)) = (created,p,cl,Assignment c2 (Positional existing) e) where (created,existing) = foldr update ([],[]) (pValues vs) update (CreateVariable c t n) (cs,es) = ((c,t,n):cs,(ExistingVariable $ InputValue c n):es)- update e (cs,es) = (cs,e:es)+ update e2 (cs,es) = (cs,e2:es) -- Merge the statement into the scoped block.- rewriteScoped (ScopedBlock _ p cl s) =- ([],p,cl,s)+ rewriteScoped (ScopedBlock _ p cl s2) =+ ([],p,cl,s2) compileExpression :: (Show c, CompileErrorM m, MergeableM m, CompilerContext c m [String] a) => Expression c -> CompilerState a m (ExpressionType,ExprValue) compileExpression = compile where- compile (Literal (StringLiteral c l)) = do+ compile (Literal (StringLiteral _ l)) = do return (Positional [stringRequiredValue],UnboxedPrimitive PrimString $ "PrimString_FromLiteral(" ++ escapeChars l ++ ")")- compile (Literal (CharLiteral c l)) = do+ compile (Literal (CharLiteral _ l)) = do return (Positional [charRequiredValue],UnboxedPrimitive PrimChar $ "PrimChar('" ++ escapeChar l ++ "')") compile (Literal (IntegerLiteral c True l)) = do- when (l > 2^64 - 1) $ lift $ compileError $+ when (l > 2^(64 :: Integer) - 1) $ lift $ compileError $ "Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit unsigned"- let l' = if l > 2^63 - 1 then l - 2^64 else l+ let l' = if l > 2^(63 :: Integer) - 1 then l - 2^(64 :: Integer) else l return (Positional [intRequiredValue],UnboxedPrimitive PrimInt $ "PrimInt(" ++ show l' ++ ")") compile (Literal (IntegerLiteral c False l)) = do- when (l > 2^63 - 1) $ lift $ compileError $+ when (l > 2^(63 :: Integer) - 1) $ lift $ compileError $ "Literal " ++ show l ++ formatFullContextBrace c ++ " is greater than the max value for 64-bit signed"- when ((-l) > 2^63 - 2) $ lift $ compileError $+ when ((-l) > (2^(63 :: Integer) - 2)) $ lift $ compileError $ "Literal " ++ show l ++ formatFullContextBrace c ++ " is less than the min value for 64-bit signed" return (Positional [intRequiredValue],UnboxedPrimitive PrimInt $ "PrimInt(" ++ show l ++ ")")- compile (Literal (DecimalLiteral c l e)) = do+ compile (Literal (DecimalLiteral _ l e)) = do -- TODO: Check bounds. return (Positional [floatRequiredValue],UnboxedPrimitive PrimFloat $ "PrimFloat(" ++ show l ++ "E" ++ show e ++ ")")- compile (Literal (BoolLiteral c True)) = do+ compile (Literal (BoolLiteral _ True)) = do return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "true")- compile (Literal (BoolLiteral c False)) = do+ compile (Literal (BoolLiteral _ False)) = do return (Positional [boolRequiredValue],UnboxedPrimitive PrimBool "false")- compile (Literal (EmptyLiteral c)) = do+ compile (Literal (EmptyLiteral _)) = do return (Positional [emptyValue],UnwrappedSingle "Var_empty")- compile (Expression c s os) = do+ compile (Expression _ s os) = do foldl transform (compileExpressionStart s) os compile (UnaryExpression c (FunctionOperator _ (FunctionSpec _ (CategoryFunction c2 cn) fn ps)) e) = compile (Expression c (CategoryCall c2 cn (FunctionCall c fn ps (Positional [e]))) [])@@ -460,21 +458,21 @@ t' <- requireSingle c ts doUnary t' e' where- doUnary t e- | o == "!" = doNot t e- | o == "-" = doNeg t e+ doUnary t e2+ | o == "!" = doNot t e2+ | o == "-" = doNeg t e2 | otherwise = lift $ compileError $ "Unknown unary operator \"" ++ o ++ "\" " ++ formatFullContextBrace c- doNot t e = do+ doNot t e2 = do when (t /= boolRequiredValue) $ lift $ compileError $ "Cannot use " ++ show t ++ " with unary ! operator" ++ formatFullContextBrace c- return $ (Positional [boolRequiredValue],UnboxedPrimitive PrimBool $ "!" ++ useAsUnboxed PrimBool e)- doNeg t e+ return $ (Positional [boolRequiredValue],UnboxedPrimitive PrimBool $ "!" ++ useAsUnboxed PrimBool e2)+ doNeg t e2 | t == intRequiredValue = return $ (Positional [intRequiredValue],- UnboxedPrimitive PrimInt $ "-" ++ useAsUnboxed PrimInt e)+ UnboxedPrimitive PrimInt $ "-" ++ useAsUnboxed PrimInt e2) | t == floatRequiredValue = return $ (Positional [floatRequiredValue],- UnboxedPrimitive PrimFloat $ "-" ++ useAsUnboxed PrimFloat e)+ UnboxedPrimitive PrimFloat $ "-" ++ useAsUnboxed PrimFloat e2) | otherwise = lift $ compileError $ "Cannot use " ++ show t ++ " with unary - operator" ++ formatFullContextBrace c compile (InitializeValue c t ps es) = do@@ -497,7 +495,7 @@ getValues [(Positional ts,e)] = return (ts,useAsArgs e) -- Multi-expression => must all be singles. getValues rs = do- lift $ mergeAllM (map checkArity $ zip [1..] $ map fst rs) `reviseError`+ lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) `reviseError` ("In return at " ++ formatFullContext c) return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")@@ -526,7 +524,6 @@ arithmetic1 = Set.fromList ["*","/"] arithmetic2 = Set.fromList ["%"] arithmetic3 = Set.fromList ["+","-"]- arithmetic = Set.union arithmetic1 arithmetic2 equals = Set.fromList ["==","!="] comparison = Set.fromList ["==","!=","<","<=",">",">="] logical = Set.fromList ["&&","||"]@@ -569,8 +566,8 @@ | otherwise = lift $ compileError $ "Cannot " ++ show o ++ " " ++ show t1 ++ " and " ++ show t2 ++ formatFullContextBrace c- glueInfix t1 t2 e1 o e2 =- UnboxedPrimitive t2 $ useAsUnboxed t1 e1 ++ o ++ useAsUnboxed t1 e2+ glueInfix t1 t2 e3 o2 e4 =+ UnboxedPrimitive t2 $ useAsUnboxed t1 e3 ++ o2 ++ useAsUnboxed t1 e4 transform e (ConvertedCall c t f) = do (Positional ts,e') <- e t' <- requireSingle c ts@@ -586,10 +583,10 @@ t' <- requireSingle c ts f' <- lookupValueFunction t' f compileFunctionCall (Just $ useAsUnwrapped e') f' f- requireSingle c [t] = return t- requireSingle c ts =+ requireSingle _ [t] = return t+ requireSingle c2 ts = lift $ compileError $ "Function call requires 1 return but found but found {" ++- intercalate "," (map show ts) ++ "}" ++ formatFullContextBrace c+ intercalate "," (map show ts) ++ "}" ++ formatFullContextBrace c2 lookupValueFunction :: (Show c, CompileErrorM m, MergeableM m, CompilerContext c m [String] a) =>@@ -642,7 +639,8 @@ when (sfScope f' > s) $ compileError $ "Function " ++ show n ++ " is not in scope here" ++ formatFullContextBrace c return f'-compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinPresent ps es)) = do+-- TODO: Compile BuiltinCall like regular functions, for consistent validation.+compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinPresent ps es)) = do when (length (pValues ps) /= 0) $ lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c when (length (pValues es) /= 1) $@@ -655,7 +653,7 @@ lift $ compileError $ "Weak values not allowed here" ++ formatFullContextBrace c return $ (Positional [boolRequiredValue], UnboxedPrimitive PrimBool $ valueBase ++ "::Present(" ++ useAsUnwrapped e ++ ")")-compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinReduce ps es)) = do+compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinReduce ps es)) = do when (length (pValues ps) /= 2) $ lift $ compileError $ "Expected 2 type parameters" ++ formatFullContextBrace c when (length (pValues es) /= 1) $@@ -678,8 +676,7 @@ csRequiresTypes $ categoriesFromTypes t2 return $ (Positional [ValueType OptionalValue t2], UnwrappedSingle $ typeBase ++ "::Reduce(" ++ t1' ++ ", " ++ t2' ++ ", " ++ useAsUnwrapped e ++ ")")--- TODO: Compile BuiltinCall like regular functions, for consistent validation.-compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinRequire ps es)) = do+compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinRequire ps es)) = do when (length (pValues ps) /= 0) $ lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c when (length (pValues es) /= 1) $@@ -692,7 +689,7 @@ lift $ compileError $ "Weak values not allowed here" ++ formatFullContextBrace c return $ (Positional [ValueType RequiredValue (vtType t0)], UnwrappedSingle $ valueBase ++ "::Require(" ++ useAsUnwrapped e ++ ")")-compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinStrong ps es)) = do+compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinStrong ps es)) = do when (length (pValues ps) /= 0) $ lift $ compileError $ "Expected 0 type parameters" ++ formatFullContextBrace c when (length (pValues es) /= 1) $@@ -706,7 +703,7 @@ -- Weak values are already unboxed. then return (t1,UnwrappedSingle $ valueBase ++ "::Strong(" ++ useAsUnwrapped e ++ ")") else return (t1,e)-compileExpressionStart (BuiltinCall c f@(FunctionCall _ BuiltinTypename ps es)) = do+compileExpressionStart (BuiltinCall c (FunctionCall _ BuiltinTypename ps es)) = do when (length (pValues ps) /= 1) $ lift $ compileError $ "Expected 1 type parameter" ++ formatFullContextBrace c when (length (pValues es) /= 0) $@@ -719,9 +716,10 @@ csRequiresTypes $ Set.unions $ map categoriesFromTypes $ pValues ps return $ (Positional [formattedRequiredValue], valueAsWrapped $ UnboxedPrimitive PrimString $ typeBase ++ "::TypeName(" ++ t' ++ ")")-compileExpressionStart (ParensExpression c e) = compileExpression e+compileExpressionStart (BuiltinCall _ _) = undefined+compileExpressionStart (ParensExpression _ e) = compileExpression e compileExpressionStart (InlineAssignment c n e) = do- (VariableValue c2 s t0 w) <- csGetVariable c n+ (VariableValue _ s t0 w) <- csGetVariable c n when (not w) $ lift $ compileError $ "Cannot assign to read-only variable " ++ show n ++ formatFullContextBrace c (Positional [t],e') <- compileExpression e -- TODO: Get rid of the Positional matching here.@@ -749,31 +747,31 @@ es' <- sequence $ map compileExpression $ pValues es (ts,es'') <- getValues es' -- Called an extra time so arg count mismatches have reasonable errors.- lift $ processPairs (\_ _ -> return ()) (ftArgs f'') (Positional ts) `reviseError`+ lift $ processPairs_ (\_ _ -> return ()) (ftArgs f'') (Positional ts) `reviseError` ("In function call at " ++ formatFullContext c)- lift $ processPairs (checkArg r fa) (ftArgs f'') (Positional $ zip [1..] ts) `reviseError`+ lift $ processPairs_ (checkArg r fa) (ftArgs f'') (Positional $ zip ([0..] :: [Int]) ts) `reviseError` ("In function call at " ++ formatFullContext c) csRequiresTypes $ Set.unions $ map categoriesFromTypes $ pValues ps csRequiresTypes (Set.fromList [sfType f]) params <- expandParams2 ps scoped <- autoScope (sfScope f)- call <- assemble e scoped (sfScope f) (functionName f) params es''+ call <- assemble e scoped (sfScope f) params es'' return $ (ftReturns f'',OpaqueMulti call) where- assemble Nothing _ ValueScope n ps es =- return $ callName (sfName f) ++ "(Var_self, " ++ ps ++ ", " ++ es ++ ")"- assemble Nothing scoped _ n ps es =- return $ scoped ++ callName (sfName f) ++ "(" ++ ps ++ ", " ++ es ++ ")"- assemble (Just e) _ ValueScope n ps es =- return $ valueBase ++ "::Call(" ++ e ++ ", " ++ functionName f ++ ", " ++ ps ++ ", " ++ es ++ ")"- assemble (Just e) _ _ n ps es =- return $ e ++ ".Call(" ++ functionName f ++ ", " ++ ps ++ ", " ++ es ++ ")"+ assemble Nothing _ ValueScope ps2 es2 =+ return $ callName (sfName f) ++ "(Var_self, " ++ ps2 ++ ", " ++ es2 ++ ")"+ assemble Nothing scoped _ ps2 es2 =+ return $ scoped ++ callName (sfName f) ++ "(" ++ ps2 ++ ", " ++ es2 ++ ")"+ assemble (Just e2) _ ValueScope ps2 es2 =+ return $ valueBase ++ "::Call(" ++ e2 ++ ", " ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")"+ assemble (Just e2) _ _ ps2 es2 =+ return $ e2 ++ ".Call(" ++ functionName f ++ ", " ++ ps2 ++ ", " ++ es2 ++ ")" -- TODO: Lots of duplication with assignments and initialization. -- Single expression, but possibly multi-return.- getValues [(Positional ts,e)] = return (ts,useAsArgs e)+ getValues [(Positional ts,e2)] = return (ts,useAsArgs e2) -- Multi-expression => must all be singles. getValues rs = do- lift $ mergeAllM (map checkArity $ zip [1..] $ map fst rs) `reviseError`+ lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) `reviseError` ("In return at " ++ formatFullContext c) return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")") checkArity (_,Positional [_]) = return ()@@ -832,11 +830,10 @@ expandGeneralInstance (TypeMerge MergeIntersect []) = return $ anyGetter ++ "()" expandGeneralInstance (TypeMerge m ps) = do ps' <- sequence $ map expandGeneralInstance ps- return $ getter ++ "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps') ++ "))"+ return $ getter m ++ "(L_get<" ++ typeBase ++ "*>(" ++ intercalate "," (map ("&" ++) ps') ++ "))" where- getter- | m == MergeUnion = unionGetter- | m == MergeIntersect = intersectGetter+ getter MergeUnion = unionGetter+ getter MergeIntersect = intersectGetter expandGeneralInstance (SingleType (JustTypeInstance (TypeInstance t ps))) = do ps' <- sequence $ map expandGeneralInstance $ pValues ps return $ typeGetter t ++ "(T_get(" ++ intercalate "," (map ("&" ++) ps') ++ "))"@@ -850,14 +847,14 @@ named <- csIsNamedReturns (CleanupSetup cs ss) <- csGetCleanup when (not $ null ss) $ do- sequence $ map (csInheritReturns . (:[])) cs+ sequence_ $ map (csInheritReturns . (:[])) cs csWrite ss csRegisterReturn c Nothing if not named then csWrite ["return ReturnTuple(0);"] else do vars <- csPrimNamedReturns- sequence $ map (csWrite . (:[]) . assign) vars+ sequence_ $ map (csWrite . (:[]) . assign) vars csWrite ["return returns;"] where assign (ReturnVariable i n t) =@@ -870,6 +867,6 @@ then csWrite ["return " ++ useAsReturns e ++ ";"] else do csWrite ["{","ReturnTuple returns = " ++ useAsReturns e ++ ";"]- sequence $ map (csInheritReturns . (:[])) cs+ sequence_ $ map (csInheritReturns . (:[])) cs csWrite ss csWrite ["return returns;","}"]
src/Config/LoadConfig.hs view
@@ -75,6 +75,7 @@ } deriving (Read,Show) +localConfigFilename :: String localConfigFilename = "local-config.txt" localConfigPath :: IO FilePath@@ -96,7 +97,7 @@ nsFlag | null ns = [] | otherwise = ["-D" ++ nm ++ "=" ++ ns]- runCxxCommand (UnixBackend cb co ab) (CompileToBinary m ss o ps) = do+ runCxxCommand (UnixBackend cb co _) (CompileToBinary m ss o ps) = do let arFiles = filter (isSuffixOf ".a") ss let otherFiles = filter (not . isSuffixOf ".a") ss executeProcess cb $ co ++ otherOptions ++ m:otherFiles ++ arFiles ++ ["-o", o]@@ -134,7 +135,7 @@ resolveModule SimpleResolver p m = do m' <- getDataFileName m firstExisting m [p</>m,m']- resolveBaseModule r = do+ resolveBaseModule _ = do let m = "base" m' <- getDataFileName m firstExisting m [m']
src/Config/Paths.hs view
@@ -22,8 +22,6 @@ PathResolver(..), ) where -import System.FilePath- class PathResolver r where resolveModule :: r -> FilePath -> FilePath -> IO FilePath
src/Parser/Common.hs view
@@ -25,6 +25,7 @@ blockComment, builtinValues, categorySymbolGet,+ char_, endOfDoc, escapeStart, infixFuncEnd,@@ -90,7 +91,9 @@ regexChar, requiredSpace, sepAfter,+ sepAfter_, sepAfter1,+ string_, stringChar, statementEnd, statementStart,@@ -112,63 +115,157 @@ -- Should never prune whitespace/comments from front, but always from back. sourceParser :: Parser a +labeled :: String -> Parser a -> Parser a labeled = flip label -escapeStart = sepAfter (string "\\" >> return ())-statementStart = sepAfter (string "~" >> return ())-statementEnd = sepAfter (string "" >> return ())-valueSymbolGet = sepAfter (string "." >> return ())-categorySymbolGet = sepAfter (string "$$" >> return ())-typeSymbolGet = sepAfter (string "$" >> notFollowedBy (string "$"))-assignOperator = operator "<-"-infixFuncStart = sepAfter (string "`" >> return ())-infixFuncEnd = sepAfter (string "`" >> return ())+escapeStart :: Parser ()+escapeStart = sepAfter (string_ "\\") +statementStart :: Parser ()+statementStart = sepAfter (string_ "~")++statementEnd :: Parser ()+statementEnd = sepAfter (string_ "")++valueSymbolGet :: Parser ()+valueSymbolGet = sepAfter (string_ ".")++categorySymbolGet :: Parser ()+categorySymbolGet = sepAfter (string_ "$$")++typeSymbolGet :: Parser ()+typeSymbolGet = sepAfter (string_ "$" >> notFollowedBy (string_ "$"))++assignOperator :: Parser ()+assignOperator = operator "<-" >> return ()++infixFuncStart :: Parser ()+infixFuncStart = sepAfter (string_ "`")++infixFuncEnd :: Parser ()+infixFuncEnd = sepAfter (string_ "`")+ -- TODO: Maybe this should not use strings. builtinValues :: Parser String builtinValues = foldr (<|>) (fail "empty") $ map try [ kwSelf >> return "self" ] +kwAll :: Parser () kwAll = keyword "all"++kwAllows :: Parser () kwAllows = keyword "allows"++kwAny :: Parser () kwAny = keyword "any"++kwBreak :: Parser () kwBreak = keyword "break"++kwCategory :: Parser () kwCategory = keyword "@category"++kwCleanup :: Parser () kwCleanup = keyword "cleanup"++kwConcrete :: Parser () kwConcrete = keyword "concrete"++kwContinue :: Parser () kwContinue = keyword "continue"++kwDefine :: Parser () kwDefine = keyword "define"++kwDefines :: Parser () kwDefines = keyword "defines"++kwElif :: Parser () kwElif = keyword "elif"++kwElse :: Parser () kwElse = keyword "else"++kwEmpty :: Parser () kwEmpty = keyword "empty"++kwFail :: Parser () kwFail = keyword "fail"++kwFalse :: Parser () kwFalse = keyword "false"++kwIf :: Parser () kwIf = keyword "if"++kwIn :: Parser () kwIn = keyword "in"++kwIgnore :: Parser () kwIgnore = keyword "_"++kwInterface :: Parser () kwInterface = keyword "interface"++kwOptional :: Parser () kwOptional = keyword "optional"++kwPresent :: Parser () kwPresent = keyword "present"++kwReduce :: Parser () kwReduce = keyword "reduce"++kwRefines :: Parser () kwRefines = keyword "refines"++kwRequire :: Parser () kwRequire = keyword "require"++kwRequires :: Parser () kwRequires = keyword "requires"++kwReturn :: Parser () kwReturn = keyword "return"++kwSelf :: Parser () kwSelf = keyword "self"++kwScoped :: Parser () kwScoped = keyword "scoped"++kwStrong :: Parser () kwStrong = keyword "strong"++kwTestcase :: Parser () kwTestcase = keyword "testcase"++kwTrue :: Parser () kwTrue = keyword "true"++kwType :: Parser () kwType = keyword "@type"++kwTypename :: Parser () kwTypename = keyword "typename"++kwTypes :: Parser () kwTypes = keyword "types"++kwUpdate :: Parser () kwUpdate = keyword "update"++kwValue :: Parser () kwValue = keyword "@value"++kwWeak :: Parser () kwWeak = keyword "weak"++kwWhile :: Parser () kwWhile = keyword "while" +operatorSymbol :: Parser Char operatorSymbol = labeled "operator symbol" $ satisfy (`Set.member` Set.fromList "+-*/%=!<>&|") isKeyword :: Parser ()@@ -216,15 +313,21 @@ nullParse :: Parser () nullParse = return () +char_ :: Char -> Parser ()+char_ = (>> return ()) . char++string_ :: String -> Parser ()+string_ = (>> return ()) . string+ lineComment :: Parser String-lineComment = between (string "//")+lineComment = between (string_ "//") endOfLine (many $ satisfy (/= '\n')) blockComment :: Parser String-blockComment = between (string "/*")- (string "*/")- (many $ notFollowedBy (string "*/") >> anyChar)+blockComment = between (string_ "/*")+ (string_ "*/")+ (many $ notFollowedBy (string_ "*/") >> anyChar) anyComment :: Parser String anyComment = try blockComment <|> try lineComment@@ -238,6 +341,9 @@ sepAfter :: Parser a -> Parser a sepAfter = between nullParse optionalSpace +sepAfter_ :: Parser a -> Parser ()+sepAfter_ = (>> return ()) . between nullParse optionalSpace+ sepAfter1 :: Parser a -> Parser a sepAfter1 = between nullParse requiredSpace @@ -256,7 +362,7 @@ operator :: String -> Parser String operator o = labeled o $ do- string o+ string_ o notFollowedBy operatorSymbol optionalSpace return o@@ -264,7 +370,7 @@ stringChar :: Parser Char stringChar = escaped <|> notEscaped where escaped = labeled "escaped char sequence" $ do- char '\\'+ char_ '\\' octChar <|> otherEscape where otherEscape = do v <- anyChar@@ -298,6 +404,7 @@ | c >= '0' && c <= '9' = ord(c) - ord('0') | c >= 'A' && c <= 'F' = 10 + ord(c) - ord('A') | c >= 'a' && c <= 'f' = 10 + ord(c) - ord('a')+ | otherwise = undefined parseDec :: Parser Integer parseDec = fmap snd $ parseIntCommon 10 digit@@ -322,7 +429,7 @@ regexChar :: Parser String regexChar = escaped <|> notEscaped where escaped = do- char '\\'+ char_ '\\' v <- anyChar case v of '"' -> return "\""
src/Parser/DefinedCategory.hs view
@@ -24,13 +24,14 @@ ) where import Control.Monad (when)+import Prelude hiding (pi) import Text.Parsec import Text.Parsec.String import Parser.Common-import Parser.Procedure+import Parser.Procedure () import Parser.TypeCategory-import Parser.TypeInstance+import Parser.TypeInstance () import Types.DefinedCategory import Types.Procedure import Types.TypeCategory@@ -43,26 +44,26 @@ c <- getPosition kwDefine n <- sourceParser- sepAfter (string "{")+ sepAfter (string_ "{") (ds,rs) <- parseRefinesDefines (pi,fi) <- parseInternalParams <|> return ([],[]) (ms,ps,fs) <- parseMemberProcedureFunction n- sepAfter (string "}")+ sepAfter (string_ "}") return $ DefinedCategory [c] n pi ds rs fi ms ps fs where parseRefinesDefines = fmap merge2 $ sepBy refineOrDefine optionalSpace refineOrDefine = labeled "refine or define" $ put12 singleRefine <|> put22 singleDefine parseInternalParams = labeled "internal params" $ do try kwTypes- pi <- between (sepAfter $ string "<")- (sepAfter $ string ">")- (sepBy singleParam (sepAfter $ string ","))+ pi <- between (sepAfter $ string_ "<")+ (sepAfter $ string_ ">")+ (sepBy singleParam (sepAfter $ string_ ",")) fi <- parseInternalFilters return (pi,fi) parseInternalFilters = do- try $ sepAfter (string "{")+ try $ sepAfter (string_ "{") fi <- parseFilters- sepAfter (string "}")+ sepAfter (string_ "}") return fi singleParam = labeled "param declaration" $ do c <- getPosition@@ -110,7 +111,7 @@ " but got definition of " ++ show (epName p) return ([],[p],[f]) catchUnscopedType = do- t <- try sourceParser :: Parser ValueType+ _ <- try sourceParser :: Parser ValueType fail $ "members must have an explicit @value or @category scope" parseAnySource :: Parser ([AnyCategory SourcePos],[DefinedCategory SourcePos])@@ -118,10 +119,10 @@ empty = ([],[]) merge (cs1,ds1) (cs2,ds2) = (cs1++cs2,ds1++ds2) parsed = sepBy anyType optionalSpace- anyType = singleCategory <|> singleDefine+ anyType = singleCategory <|> singleDefine2 singleCategory = do c <- sourceParser return ([c],[])- singleDefine = do+ singleDefine2 = do d <- sourceParser return ([],[d])
src/Parser/IntegrationTest.hs view
@@ -23,12 +23,11 @@ ) where import Text.Parsec-import Text.Parsec.String import Parser.Common import Parser.DefinedCategory-import Parser.Procedure-import Parser.TypeCategory+import Parser.Procedure ()+import Parser.TypeCategory () import Types.IntegrationTest @@ -36,12 +35,12 @@ sourceParser = labeled "testcase" $ do c <- getPosition sepAfter kwTestcase- string "\""- name <- manyTill stringChar (string "\"")+ string_ "\""+ name <- manyTill stringChar (string_ "\"") optionalSpace- sepAfter $ string "{"+ sepAfter (string_ "{") result <- resultError <|> resultCrash <|> resultSuccess- sepAfter $ string "}"+ sepAfter (string_ "}") return $ IntegrationTestHeader [c] name result where resultError = labeled "error expectation" $ do c <- getPosition@@ -68,15 +67,15 @@ require = do sepAfter (keyword "require") s <- outputScope- string "\""- r <- fmap concat $ manyTill regexChar (string "\"")+ string_ "\""+ r <- fmap concat $ manyTill regexChar (string_ "\"") optionalSpace return ([OutputPattern s r],[]) exclude = do sepAfter (keyword "exclude") s <- outputScope- string "\""- e <- fmap concat $ manyTill regexChar (string "\"")+ string_ "\""+ e <- fmap concat $ manyTill regexChar (string_ "\"") optionalSpace return ([],[OutputPattern s e]) outputScope = try anyScope <|>
src/Parser/Procedure.hs view
@@ -28,8 +28,8 @@ import qualified Data.Set as Set import Parser.Common-import Parser.TypeCategory-import Parser.TypeInstance+import Parser.TypeCategory ()+import Parser.TypeInstance () import Types.Positional import Types.Procedure import Types.TypeCategory@@ -42,31 +42,31 @@ n <- try sourceParser as <- sourceParser rs <- sourceParser- sepAfter (string "{")+ sepAfter (string_ "{") pp <- sourceParser c2 <- getPosition- sepAfter (string "}")+ sepAfter (string_ "}") return $ ExecutableProcedure [c] [c2] n as rs pp instance ParseFromSource (ArgValues SourcePos) where sourceParser = labeled "procedure arguments" $ do c <- getPosition- as <- between (sepAfter $ string "(")- (sepAfter $ string ")")- (sepBy sourceParser (sepAfter $ string ","))+ as <- between (sepAfter $ string_ "(")+ (sepAfter $ string_ ")")+ (sepBy sourceParser (sepAfter $ string_ ",")) return $ ArgValues [c] (Positional as) instance ParseFromSource (ReturnValues SourcePos) where sourceParser = labeled "procedure returns" $ namedReturns <|> unnamedReturns where namedReturns = do c <- getPosition- rs <- between (sepAfter $ string "(")- (sepAfter $ string ")")- (sepBy sourceParser (sepAfter $ string ","))+ rs <- between (sepAfter $ string_ "(")+ (sepAfter $ string_ ")")+ (sepBy sourceParser (sepAfter $ string_ ",")) return $ NamedReturns [c] (Positional rs) unnamedReturns = do c <- getPosition- notFollowedBy (string "(")+ notFollowedBy (string_ "(") return $ UnnamedReturns [c] instance ParseFromSource VariableName where@@ -84,7 +84,7 @@ return $ InputValue [c] v discard = do c <- getPosition- sepAfter $ string "_"+ sepAfter (string_ "_") return $ DiscardInput [c] instance ParseFromSource (OutputValue SourcePos) where@@ -124,12 +124,12 @@ parseFailCall = do c <- getPosition try kwFail- e <- between (sepAfter $ string "(") (sepAfter $ string ")") sourceParser+ e <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser return $ FailCall [c] e multiDest = do- as <- try $ between (sepAfter $ string "{")- (sepAfter $ string "}")- (sepBy sourceParser (sepAfter $ string ","))+ as <- try $ between (sepAfter $ string_ "{")+ (sepAfter $ string_ "}")+ (sepBy sourceParser (sepAfter $ string_ ",")) assignOperator return as singleDest = do@@ -148,9 +148,9 @@ multiReturn c <|> singleReturn c <|> emptyReturn c multiReturn :: SourcePos -> Parser (Statement SourcePos) multiReturn c = do- rs <- between (sepAfter $ string "{")- (sepAfter $ string "}")- (sepBy sourceParser (sepAfter $ string ","))+ rs <- between (sepAfter $ string_ "{")+ (sepAfter $ string_ "}")+ (sepBy sourceParser (sepAfter $ string_ ",")) statementEnd return $ ExplicitReturn [c] (Positional rs) singleReturn :: SourcePos -> Parser (Statement SourcePos)@@ -202,8 +202,8 @@ try kwIf >> parseIf c where parseIf c = do- i <- between (sepAfter $ string "(") (sepAfter $ string ")") sourceParser- p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser+ i <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser+ p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser next <- parseElif <|> parseElse <|> return TerminateConditional return $ IfStatement [c] i p next parseElif = do@@ -212,28 +212,28 @@ parseElse = do c <- getPosition try kwElse- p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser+ p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser return $ ElseStatement [c] p instance ParseFromSource (WhileLoop SourcePos) where sourceParser = labeled "while" $ do c <- getPosition try kwWhile- i <- between (sepAfter $ string "(") (sepAfter $ string ")") sourceParser- p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser+ i <- between (sepAfter $ string_ "(") (sepAfter $ string_ ")") sourceParser+ p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser u <- fmap Just parseUpdate <|> return Nothing return $ WhileLoop [c] i p u where parseUpdate = do try kwUpdate- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser+ between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser instance ParseFromSource (ScopedBlock SourcePos) where sourceParser = scoped <|> justCleanup where scoped = labeled "scoped" $ do c <- getPosition try kwScoped- p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser+ p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser cl <- fmap Just parseCleanup <|> return Nothing kwIn -- TODO: If there's a parse error in an otherwise-valid {} then the actual@@ -248,10 +248,10 @@ return $ ScopedBlock [c] (Procedure [] []) (Just cl) s parseCleanup = do try kwCleanup- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser+ between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser unconditional = do c <- getPosition- p <- between (sepAfter $ string "{") (sepAfter $ string "}") sourceParser+ p <- between (sepAfter $ string_ "{") (sepAfter $ string_ "}") sourceParser return $ NoValueExpression [c] (Unconditional p) unaryOperator :: Parser (Operator c)@@ -267,7 +267,7 @@ ] infixBefore :: Operator c -> Operator c -> Bool-infixBefore o1 o2 = (infixOrder o1) <= (infixOrder o2) where+infixBefore o1 o2 = (infixOrder o1 :: Int) <= (infixOrder o2 :: Int) where infixOrder (NamedOperator o) -- TODO: Don't hard-code this. | o `Set.member` Set.fromList ["*","/","%"] = 1@@ -305,6 +305,7 @@ | o1 `infixBefore` o2 = let e1' = InfixExpression c1 e1 o1 e2 in infixToTree ss (e1':es) ((c2,o2):os) | otherwise = infixToTree ((e2,c2,o2):(e1,c1,o1):ss) es os+ infixToTree _ _ _ = undefined literal = do l <- sourceParser return $ Literal l@@ -321,19 +322,19 @@ initalize = do c <- getPosition t <- try sourceParser :: Parser TypeInstance- sepAfter (string "{")+ sepAfter (string_ "{") withParams c t <|> withoutParams c t withParams c t = do try kwTypes- ps <- between (sepAfter $ string "<")- (sepAfter $ string ">")- (sepBy sourceParser (sepAfter $ string ","))- as <- (sepAfter (string ",") >> sepBy sourceParser (sepAfter $ string ",")) <|> return []- sepAfter (string "}")+ ps <- between (sepAfter $ string_ "<")+ (sepAfter $ string_ ">")+ (sepBy sourceParser (sepAfter $ string_ ","))+ as <- (sepAfter (string_ ",") >> sepBy sourceParser (sepAfter $ string_ ",")) <|> return []+ sepAfter (string_ "}") return $ InitializeValue [c] t (Positional ps) (Positional as) withoutParams c t = do- as <- sepBy sourceParser (sepAfter $ string ",")- sepAfter (string "}")+ as <- sepBy sourceParser (sepAfter $ string_ ",")+ sepAfter (string_ "}") return $ InitializeValue [c] t (Positional []) (Positional as) instance ParseFromSource (FunctionQualifier SourcePos) where@@ -361,28 +362,28 @@ c <- getPosition q <- sourceParser n <- sourceParser- ps <- try $ between (sepAfter $ string "<")- (sepAfter $ string ">")- (sepBy sourceParser (sepAfter $ string ",")) <|> return []+ ps <- try $ between (sepAfter $ string_ "<")+ (sepAfter $ string_ ">")+ (sepBy sourceParser (sepAfter $ string_ ",")) <|> return [] return $ FunctionSpec [c] q n (Positional ps) unqualified = do c <- getPosition n <- sourceParser- ps <- try $ between (sepAfter $ string "<")- (sepAfter $ string ">")- (sepBy sourceParser (sepAfter $ string ",")) <|> return []+ ps <- try $ between (sepAfter $ string_ "<")+ (sepAfter $ string_ ">")+ (sepBy sourceParser (sepAfter $ string_ ",")) <|> return [] return $ FunctionSpec [c] UnqualifiedFunction n (Positional ps) parseFunctionCall :: SourcePos -> FunctionName -> Parser (FunctionCall SourcePos) parseFunctionCall c n = do -- NOTE: try is needed here so that < operators work when the left side is -- just a variable name, e.g., x < y.- ps <- try $ between (sepAfter $ string "<")- (sepAfter $ string ">")- (sepBy sourceParser (sepAfter $ string ",")) <|> return []- es <- between (sepAfter $ string "(")- (sepAfter $ string ")")- (sepBy sourceParser (sepAfter $ string ","))+ ps <- try $ between (sepAfter $ string_ "<")+ (sepAfter $ string_ ">")+ (sepBy sourceParser (sepAfter $ string_ ",")) <|> return []+ es <- between (sepAfter $ string_ "(")+ (sepAfter $ string_ ")")+ (sepBy sourceParser (sepAfter $ string_ ",")) return $ FunctionCall [c] n (Positional ps) (Positional es) builtinFunction :: Parser FunctionName@@ -404,9 +405,9 @@ typeCall where parens = do c <- getPosition- sepAfter (string "(")+ sepAfter (string_ "(") e <- try (assign c) <|> expr c- sepAfter (string ")")+ sepAfter (string_ ")") return e assign :: SourcePos -> Parser (ExpressionStart SourcePos) assign c = do@@ -468,15 +469,15 @@ emptyLiteral where stringLiteral = do c <- getPosition- string "\""- ss <- manyTill stringChar (string "\"")+ string_ "\""+ ss <- manyTill stringChar (string_ "\"") optionalSpace return $ StringLiteral [c] ss charLiteral = do c <- getPosition- string "'"+ string_ "'" ch <- stringChar- string "'"+ string_ "'" optionalSpace return $ CharLiteral [c] ch escapedInteger = do@@ -492,6 +493,7 @@ 'D' -> parseDec 'x' -> parseHex 'X' -> parseHex+ _ -> undefined optionalSpace return $ IntegerLiteral [c] True d integerOrDecimal = do@@ -499,14 +501,14 @@ d <- parseDec decimal c d <|> integer c d decimal c d = do- char '.'+ char_ '.' (n,d2) <- parseSubOne e <- decExponent <|> return 0 optionalSpace return $ DecimalLiteral [c] (d*10^n + d2) (e - n) decExponent = do- string "e" <|> string "E"- s <- (string "+" >> return 1) <|> (string "-" >> return (-1)) <|> return 1+ string_ "e" <|> string_ "E"+ s <- (string_ "+" >> return 1) <|> (string_ "-" >> return (-1)) <|> return 1 e <- parseDec return (s*e) integer c d = do
src/Parser/SourceFile.hs view
@@ -25,16 +25,14 @@ ) where import Text.Parsec-import Text.Parsec.String import Base.CompileError import Parser.Common import Parser.DefinedCategory-import Parser.IntegrationTest-import Parser.TypeCategory+import Parser.IntegrationTest ()+import Parser.TypeCategory () import Types.DefinedCategory import Types.IntegrationTest-import Types.Positional import Types.TypeCategory
src/Parser/TypeCategory.hs view
@@ -32,7 +32,7 @@ import Text.Parsec.String import Parser.Common-import Parser.TypeInstance+import Parser.TypeInstance () import Types.Positional import Types.TypeCategory import Types.TypeInstance@@ -41,8 +41,8 @@ instance ParseFromSource (AnyCategory SourcePos) where sourceParser = parseValue <|> parseInstance <|> parseConcrete where- open = sepAfter $ string "{"- close = sepAfter $ string "}"+ open = sepAfter (string_ "{")+ close = sepAfter (string_ "}") parseValue = labeled "value interface" $ do c <- getPosition try $ kwValue >> kwInterface@@ -85,28 +85,28 @@ notFollowedBy (string "<") return ([],[],[]) fixedOnly = do -- T<a,b,c>- inv <- between (sepAfter $ string "<")- (sepAfter $ string ">")- (sepBy singleParam (sepAfter $ string ","))+ inv <- between (sepAfter $ string_ "<")+ (sepAfter $ string_ ">")+ (sepBy singleParam (sepAfter $ string_ ",")) return ([],inv,[]) noFixed = do -- T<a,b|c,d>- con <- between (sepAfter $ string "<")- (sepAfter $ string "|")- (sepBy singleParam (sepAfter $ string ","))+ con <- between (sepAfter $ string_ "<")+ (sepAfter $ string_ "|")+ (sepBy singleParam (sepAfter $ string_ ",")) cov <- between nullParse- (sepAfter $ string ">")- (sepBy singleParam (sepAfter $ string ","))+ (sepAfter $ string_ ">")+ (sepBy singleParam (sepAfter $ string_ ",")) return (con,[],cov) explicitFixed = do -- T<a,b|c,d|e,f>- con <- between (sepAfter $ string "<")- (sepAfter $ string "|")- (sepBy singleParam (sepAfter $ string ","))+ con <- between (sepAfter $ string_ "<")+ (sepAfter $ string_ "|")+ (sepBy singleParam (sepAfter $ string_ ",")) inv <- between nullParse- (sepAfter $ string "|")- (sepBy singleParam (sepAfter $ string ","))+ (sepAfter $ string_ "|")+ (sepBy singleParam (sepAfter $ string_ ",")) cov <- between nullParse- (sepAfter $ string ">")- (sepBy singleParam (sepAfter $ string ","))+ (sepAfter $ string_ ">")+ (sepBy singleParam (sepAfter $ string_ ",")) return (con,inv,cov) singleParam = labeled "param declaration" $ do c <- getPosition@@ -171,20 +171,20 @@ ps <- fmap Positional $ noParams <|> someParams fa <- parseFilters as <- fmap Positional $ typeList "argument type"- sepAfter $ string "->"+ sepAfter_ (string "->") rs <- fmap Positional $ typeList "return type" return $ ScopedFunction [c] n t s as rs ps fa [] where noParams = notFollowedBy (string "<") >> return []- someParams = between (sepAfter $ string "<")- (sepAfter $ string ">")+ someParams = between (sepAfter $ string_ "<")+ (sepAfter $ string_ ">") (sepBy singleParam (sepAfter $ string ",")) singleParam = labeled "param declaration" $ do c <- getPosition n <- sourceParser return $ ValueParam [c] n Invariant- typeList l = between (sepAfter $ string "(")- (sepAfter $ string ")")+ typeList l = between (sepAfter $ string_ "(")+ (sepAfter $ string_ ")") (sepBy (labeled l $ singleType) (sepAfter $ string ",")) singleType = do c <- getPosition@@ -193,6 +193,12 @@ parseScope :: Parser SymbolScope parseScope = try categoryScope <|> try typeScope <|> valueScope++categoryScope :: Parser SymbolScope categoryScope = kwCategory >> return CategoryScope-typeScope = kwType >> return TypeScope-valueScope = kwValue >> return ValueScope++typeScope :: Parser SymbolScope+typeScope = kwType >> return TypeScope++valueScope :: Parser SymbolScope+valueScope = kwValue >> return ValueScope
src/Parser/TypeInstance.hs view
@@ -23,9 +23,7 @@ ) where import Control.Applicative ((<|>))-import Control.Monad (when) import Text.Parsec hiding ((<|>))-import Text.Parsec.String import Parser.Common import Types.GeneralType@@ -34,11 +32,11 @@ instance ParseFromSource GeneralInstance where- sourceParser = try all <|> try any <|> intersectOrUnion <|> single where- all = labeled "all" $ do+ sourceParser = try allT <|> try anyT <|> intersectOrUnion <|> single where+ allT = labeled "all" $ do kwAll return $ TypeMerge MergeUnion []- any = labeled "any" $ do+ anyT = labeled "any" $ do kwAny return $ TypeMerge MergeIntersect [] intersectOrUnion = try intersect <|> union@@ -89,7 +87,7 @@ instance ParseFromSource ParamName where sourceParser = labeled "param name" $ do noKeywords- char '#'+ char_ '#' b <- lower e <- sepAfter $ many alphaNum return $ ParamName ('#':b:e)
src/Test/Common.hs view
@@ -54,14 +54,14 @@ import Base.Mergeable import Compilation.CompileInfo import Parser.Common-import Parser.TypeInstance+import Parser.TypeInstance () import Types.TypeInstance runAllTests :: [IO (CompileInfo ())] -> IO () runAllTests ts = do results <- sequence ts- let (es,ps) = partitionEithers $ zipWith numberError [1..] results+ let (es,ps) = partitionEithers $ zipWith numberError ([1..] :: [Int]) results mapM_ (\(n,e) -> hPutStr stderr ("Test " ++ show n ++ ": " ++ show e ++ "\n")) es hPutStr stderr $ show (length ps) ++ " tests passed + " ++ show (length es) ++ " tests failed\n"@@ -75,6 +75,7 @@ forceParse :: ParseFromSource a => String -> a forceParse s = force $ parse sourceParser "(string)" s where force (Right x) = x+ force _ = undefined readSingle :: (ParseFromSource a, CompileErrorM m) => String -> String -> m a readSingle = readSingleWith (optionalSpace >> sourceParser)
src/Test/DefinedCategory.hs view
@@ -22,11 +22,10 @@ import System.FilePath import Text.Parsec-import Text.Parsec.String import Base.CompileError import Compilation.CompileInfo-import Parser.DefinedCategory+import Parser.DefinedCategory () import Test.Common import Types.DefinedCategory @@ -39,6 +38,7 @@ checkParseSuccess ("testfiles" </> "internal_filters.0rx") ] +checkParseSuccess :: String -> IO (CompileInfo ()) checkParseSuccess f = do contents <- loadFile f let parsed = readMulti f contents :: CompileInfo [DefinedCategory SourcePos]@@ -48,6 +48,7 @@ | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) | otherwise = return () +checkParseFail :: String -> IO (CompileInfo ()) checkParseFail f = do contents <- loadFile f let parsed = readMulti f contents :: CompileInfo [DefinedCategory SourcePos]
src/Test/IntegrationTest.hs view
@@ -27,7 +27,7 @@ import Base.CompileError import Compilation.CompileInfo import Parser.Common-import Parser.IntegrationTest+import Parser.IntegrationTest () import Test.Common import Types.DefinedCategory import Types.IntegrationTest
src/Test/Parser.hs view
@@ -21,13 +21,12 @@ module Test.Parser (tests) where import Control.Monad (when)-import Text.Parsec-import Text.Parsec.String import Base.CompileError import Compilation.CompileInfo import Parser.Common import Test.Common+import Text.Parsec.String tests :: [IO (CompileInfo ())]@@ -58,6 +57,7 @@ checkParseFail regexChar "\"" ] +checkParsesAs :: (Eq a, Show a) => Parser a -> [Char] -> a -> IO (CompileInfo ()) checkParsesAs p s m = return $ do let parsed = readSingleWith p "(string)" s check parsed@@ -69,6 +69,7 @@ | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) | otherwise = return () +checkParseFail :: Show a => Parser a -> [Char] -> IO (CompileInfo ()) checkParseFail p s = do let parsed = readSingleWith p "(string)" s return $ check parsed
src/Test/Procedure.hs view
@@ -23,11 +23,10 @@ import Control.Monad import System.FilePath import Text.Parsec-import Text.Parsec.String import Base.CompileError import Compilation.CompileInfo-import Parser.Procedure+import Parser.Procedure () import Test.Common import Types.Positional import Types.Procedure@@ -395,6 +394,7 @@ _ -> False) ] +checkParseSuccess :: String -> IO (CompileInfo ()) checkParseSuccess f = do contents <- loadFile f let parsed = readMulti f contents :: CompileInfo [ExecutableProcedure SourcePos]@@ -404,6 +404,7 @@ | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) | otherwise = return () +checkParseFail :: String -> IO (CompileInfo ()) checkParseFail f = do contents <- loadFile f let parsed = readMulti f contents :: CompileInfo [ExecutableProcedure SourcePos]@@ -414,6 +415,7 @@ | otherwise = compileError $ "Parse " ++ f ++ ": Expected failure but got\n" ++ show (getCompileSuccess c) ++ "\n" +checkShortParseSuccess :: String -> IO (CompileInfo ()) checkShortParseSuccess s = do let parsed = readSingle "(string)" s :: CompileInfo (Statement SourcePos) return $ check parsed@@ -422,6 +424,7 @@ | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) | otherwise = return () +checkShortParseFail :: String -> IO (CompileInfo ()) checkShortParseFail s = do let parsed = readSingle "(string)" s :: CompileInfo (Statement SourcePos) return $ check parsed@@ -431,6 +434,7 @@ | otherwise = compileError $ "Parse '" ++ s ++ "': Expected failure but got\n" ++ show (getCompileSuccess c) ++ "\n" +checkParsesAs :: [Char] -> (Expression SourcePos -> Bool) -> IO (CompileInfo ()) checkParsesAs s m = return $ do let parsed = readSingle "(string)" s :: CompileInfo (Expression SourcePos) check parsed
src/Test/TypeCategory.hs view
@@ -21,20 +21,14 @@ module Test.TypeCategory (tests) where import Control.Arrow-import Control.Monad-import Data.List import System.FilePath-import System.IO import Text.Parsec-import Text.Parsec.String import qualified Data.Map as Map-import qualified Data.Set as Set import Base.CompileError import Base.Mergeable import Compilation.CompileInfo-import Parser.Common-import Parser.TypeCategory+import Parser.TypeCategory () import Test.Common import Types.Builtin import Types.Positional@@ -124,22 +118,22 @@ checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- map (show . getCategoryName) ts `containsPaired` [+ ts2 <- topoSortCategories defaultCategories ts+ map (show . getCategoryName) ts2 `containsPaired` [ "Type","Object2","Object3","Object1","Parent","Child" ]), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- scrapeAllRefines ts `containsExactly` [+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ scrapeAllRefines ts3 `containsExactly` [ ("Object1","Object3<#y>"), ("Object1","Object2"), ("Object3","Object2"),@@ -151,7 +145,7 @@ ("Child","Object3<Object3<Object2>>"), ("Child","Object2") ]- scrapeAllDefines ts `containsExactly` [+ scrapeAllDefines ts3 `containsExactly` [ ("Child","Type<Child>") ]), @@ -161,8 +155,8 @@ existing <- return $ Map.fromList [ (CategoryName "Parent2",InstanceInterface [] NoNamespace (CategoryName "Parent2") [] [] []) ]- ts <- topoSortCategories existing ts- flattenAllConnections existing ts),+ ts2 <- topoSortCategories existing ts+ flattenAllConnections existing ts2), checkOperationFail ("testfiles" </> "flatten.0rx") (\ts -> do@@ -184,9 +178,9 @@ (CategoryName "Object2", ValueInterface [] NoNamespace (CategoryName "Object2") [] [] [] []) ]- ts <- topoSortCategories existing ts- ts <- flattenAllConnections existing ts- scrapeAllRefines ts `containsExactly` [+ ts2 <- topoSortCategories existing ts+ ts3 <- flattenAllConnections existing ts2+ scrapeAllRefines ts3 `containsExactly` [ ("Child","Parent"), ("Child","Object1"), ("Child","Object2")@@ -250,56 +244,56 @@ checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- rs <- getTypeRefines ts "Object1<#a,#b>" "Object1"+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ rs <- getTypeRefines ts3 "Object1<#a,#b>" "Object1" rs `containsPaired` ["#a","#b"]), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- rs <- getTypeRefines ts "Object1<#a,#b>" "Object3"+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ rs <- getTypeRefines ts3 "Object1<#a,#b>" "Object3" rs `containsPaired` ["#b"]), checkOperationFail ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- rs <- getTypeRefines ts "Undefined<#a,#b>" "Undefined"+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ rs <- getTypeRefines ts3 "Undefined<#a,#b>" "Undefined" rs `containsPaired` ["#a","#b"]), checkOperationFail ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- rs <- getTypeRefines ts "Object1<#a>" "Object1"+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ rs <- getTypeRefines ts3 "Object1<#a>" "Object1" rs `containsPaired` ["#a"]), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- rs <- getTypeRefines ts "Parent<#t>" "Object1"+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ rs <- getTypeRefines ts3 "Parent<#t>" "Object1" rs `containsPaired` ["#t","Object3<Object2>"]), checkOperationFail ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- getTypeRefines ts "Parent<#t>" "Child"),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ getTypeRefines ts3 "Parent<#t>" "Child"), checkOperationFail ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- getTypeRefines ts "Child" "Type"),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ getTypeRefines ts3 "Child" "Type"), checkOperationFail ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- getTypeRefines ts "Child" "Missing"),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ getTypeRefines ts3 "Child" "Missing"), checkOperationSuccess ("testfiles" </> "flatten.0rx")@@ -406,64 +400,64 @@ checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeSuccess r [] "Child"), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeSuccess r [] "[Child|Child]"), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeSuccess r [] "[Child&Child]"), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeSuccess r [] "Object2"), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeSuccess r [] "[Object2|Object2]"), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeSuccess r [] "[Object2&Object2]"), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeFail r [] "Type<Child>"), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeFail r [] "[Type<Child>|Type<Child>]"), checkOperationSuccess ("testfiles" </> "flatten.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ta <- flattenAllConnections defaultCategories ts >>= declareAllTypes defaultCategories+ ts2 <- topoSortCategories defaultCategories ts+ ta <- flattenAllConnections defaultCategories ts2 >>= declareAllTypes defaultCategories let r = CategoryResolver ta checkTypeFail r [] "[Type<Child>&Type<Child>]"), @@ -471,29 +465,29 @@ checkOperationSuccess ("testfiles" </> "filters.0rx") (\ts -> do- ts <- topoSortCategories Map.empty ts- ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty+ ts2 <- topoSortCategories Map.empty ts+ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [] "Value0<Value1,Value2>"), checkOperationFail ("testfiles" </> "filters.0rx") (\ts -> do- ts <- topoSortCategories Map.empty ts- ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty+ ts2 <- topoSortCategories Map.empty ts+ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [] "Value0<Value1,Value1>"), checkOperationSuccess ("testfiles" </> "filters.0rx") (\ts -> do- ts <- topoSortCategories Map.empty ts- ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty+ ts2 <- topoSortCategories Map.empty ts+ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [] "Value0<Value3,Value2>"), checkOperationFail ("testfiles" </> "filters.0rx") (\ts -> do- ts <- topoSortCategories Map.empty ts- ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty+ ts2 <- topoSortCategories Map.empty ts+ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [("#x",[]),("#y",[])]@@ -501,8 +495,8 @@ checkOperationSuccess ("testfiles" </> "filters.0rx") (\ts -> do- ts <- topoSortCategories Map.empty ts- ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty+ ts2 <- topoSortCategories Map.empty ts+ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [("#x",["allows #y","requires Function<#x,#y>"]),@@ -511,8 +505,8 @@ checkOperationSuccess ("testfiles" </> "filters.0rx") (\ts -> do- ts <- topoSortCategories Map.empty ts- ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty+ ts2 <- topoSortCategories Map.empty ts+ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [("#x",["allows Value2","requires Function<#x,Value2>"])]@@ -520,8 +514,8 @@ checkOperationFail ("testfiles" </> "filters.0rx") (\ts -> do- ts <- topoSortCategories Map.empty ts- ta <- flattenAllConnections Map.empty ts >>= declareAllTypes Map.empty+ ts2 <- topoSortCategories Map.empty ts+ ta <- flattenAllConnections Map.empty ts2 >>= declareAllTypes Map.empty let r = CategoryResolver ta checkTypeSuccess r [("#x",["allows Value2","requires Function<#x,Value2>"]),@@ -531,71 +525,71 @@ checkOperationSuccess ("testfiles" </> "concrete_instances.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationFail ("testfiles" </> "concrete_missing_define.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationFail ("testfiles" </> "concrete_missing_refine.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationSuccess ("testfiles" </> "value_instances.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationFail ("testfiles" </> "value_missing_define.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationFail ("testfiles" </> "value_missing_refine.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationSuccess ("testfiles" </> "type_instances.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationFail ("testfiles" </> "type_missing_define.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationFail ("testfiles" </> "type_missing_refine.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), checkOperationSuccess ("testfiles" </> "requires_concrete.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- checkCategoryInstances defaultCategories ts),+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ checkCategoryInstances defaultCategories ts3), -- TODO: Clean these tests up. checkOperationSuccess ("testfiles" </> "merged.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- ts <- flattenAllConnections defaultCategories ts- tm <- declareAllTypes defaultCategories ts+ ts2 <- topoSortCategories defaultCategories ts+ ts3 <- flattenAllConnections defaultCategories ts2+ tm <- declareAllTypes defaultCategories ts3 rs <- getRefines tm "Test" rs `containsExactly` ["Value0","Value1","Value2","Value3", "Value4<Value1,Value1>","Inherit1","Inherit2"]),@@ -603,39 +597,33 @@ checkOperationSuccess ("testfiles" </> "merged.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "duplicate_refine.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "duplicate_define.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationFail ("testfiles" </> "refine_wrong_direction.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationFail ("testfiles" </> "inherit_incompatible.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "merge_incompatible.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "flatten.0rx")@@ -746,89 +734,79 @@ checkOperationFail ("testfiles" </> "conflicting_declaration.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationFail ("testfiles" </> "conflicting_inherited.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "successful_merge.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "merge_with_refine.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationFail ("testfiles" </> "failed_merge.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationFail ("testfiles" </> "ambiguous_merge_inherit.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationFail ("testfiles" </> "merge_different_scopes.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "successful_merge_params.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationFail ("testfiles" </> "failed_merge_params.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "preserve_merged.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationFail ("testfiles" </> "conflict_in_preserved.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ()),+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()), checkOperationSuccess ("testfiles" </> "resolved_in_preserved.0rx") (\ts -> do- ts <- topoSortCategories defaultCategories ts- flattenAllConnections defaultCategories ts- return ())+ ts2 <- topoSortCategories defaultCategories ts+ flattenAllConnections defaultCategories ts2 >> return ()) ] -+getRefines :: Map.Map CategoryName (AnyCategory c) -> String -> CompileInfo [String] getRefines tm n = case (CategoryName n) `Map.lookup` tm of (Just t) -> return $ map (show . vrType) (getCategoryRefines t) _ -> compileError $ "Type " ++ n ++ " not found" +getDefines :: Map.Map CategoryName (AnyCategory c) -> String -> CompileInfo [String] getDefines tm n = case (CategoryName n) `Map.lookup` tm of (Just t) -> return $ map (show . vdType) (getCategoryDefines t) _ -> compileError $ "Type " ++ n ++ " not found" +getTypeRefines :: Show c => [AnyCategory c] -> String -> String -> CompileInfo [String] getTypeRefines ts s n = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta@@ -836,6 +814,7 @@ Positional rs <- trRefines r t (CategoryName n) return $ map show rs +getTypeDefines :: Show c => [AnyCategory c] -> String -> String -> CompileInfo [String] getTypeDefines ts s n = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta@@ -843,12 +822,14 @@ Positional ds <- trDefines r t (CategoryName n) return $ map show ds +getTypeVariance :: Show c => [AnyCategory c] -> String -> CompileInfo [Variance] getTypeVariance ts n = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta (Positional vs) <- trVariance r (CategoryName n) return vs +getTypeFilters :: Show c => [AnyCategory c] -> String -> CompileInfo [[String]] getTypeFilters ts s = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta@@ -856,6 +837,7 @@ Positional vs <- trTypeFilters r t return $ map (map show) vs +getTypeDefinesFilters :: Show c => [AnyCategory c] -> String -> CompileInfo [[String]] getTypeDefinesFilters ts s = do ta <- declareAllTypes defaultCategories ts let r = CategoryResolver ta@@ -863,11 +845,13 @@ Positional vs <- trDefinesFilters r t return $ map (map show) vs +scrapeAllRefines :: [AnyCategory c] -> [(String, String)] scrapeAllRefines = map (show *** show) . concat . map scrapeSingle where scrapeSingle (ValueInterface _ _ n _ rs _ _) = map ((,) n . vrType) rs scrapeSingle (ValueConcrete _ _ n _ rs _ _ _) = map ((,) n . vrType) rs scrapeSingle _ = [] +scrapeAllDefines :: [AnyCategory c] -> [(String, String)] scrapeAllDefines = map (show *** show) . concat . map scrapeSingle where scrapeSingle (ValueConcrete _ _ n _ _ ds _ _) = map ((,) n . vdType) ds scrapeSingle _ = []@@ -878,7 +862,7 @@ | length actual /= length expected = compileError $ "Different item counts: " ++ show actual ++ " (actual) vs. " ++ show expected ++ " (expected)"- | otherwise = mergeAllM $ map check (zip3 actual expected [1..]) where+ | otherwise = mergeAllM $ map check (zip3 actual expected ([1..] :: [Int])) where check (a,e,n) = f a e `reviseError` ("Item " ++ show n ++ " mismatch") containsPaired :: (Eq a, Show a, CompileErrorM m, MergeableM m) =>@@ -888,6 +872,7 @@ | a == e = return () | otherwise = compileError $ show a ++ " (actual) vs. " ++ show e ++ " (expected)" +checkOperationSuccess :: String -> ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) checkOperationSuccess f o = do contents <- loadFile f let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos]@@ -895,6 +880,7 @@ where check = flip reviseError ("Check " ++ f ++ ":") +checkOperationFail :: String -> ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) checkOperationFail f o = do contents <- loadFile f let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos]@@ -905,6 +891,7 @@ | otherwise = compileError $ "Check " ++ f ++ ": Expected failure but got\n" ++ show (getCompileSuccess c) ++ "\n" +checkSingleParseSuccess :: String -> IO (CompileInfo ()) checkSingleParseSuccess f = do contents <- loadFile f let parsed = readSingle f contents :: CompileInfo (AnyCategory SourcePos)@@ -914,6 +901,7 @@ | isCompileError c = compileError $ "Parse " ++ f ++ ":\n" ++ show (getCompileError c) | otherwise = return () +checkSingleParseFail :: String -> IO (CompileInfo ()) checkSingleParseFail f = do contents <- loadFile f let parsed = readSingle f contents :: CompileInfo (AnyCategory SourcePos)@@ -924,6 +912,7 @@ | otherwise = compileError $ "Parse " ++ f ++ ": Expected failure but got\n" ++ show (getCompileSuccess c) ++ "\n" +checkShortParseSuccess :: String -> IO (CompileInfo ()) checkShortParseSuccess s = do let parsed = readSingle "(string)" s :: CompileInfo (AnyCategory SourcePos) return $ check parsed@@ -932,6 +921,7 @@ | isCompileError c = compileError $ "Parse '" ++ s ++ "':\n" ++ show (getCompileError c) | otherwise = return () +checkShortParseFail :: String -> IO (CompileInfo ()) checkShortParseFail s = do let parsed = readSingle "(string)" s :: CompileInfo (AnyCategory SourcePos) return $ check parsed
src/Test/TypeInstance.hs view
@@ -1,5 +1,5 @@ {- ------------------------------------------------------------------------------Copyright 2019 Kevin P. Barry+Copyright 2019-2020 Kevin P. Barry Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -20,14 +20,11 @@ module Test.TypeInstance (tests) where -import Data.List-import Text.Parsec import qualified Data.Map as Map import Base.CompileError import Compilation.CompileInfo-import Parser.Common-import Parser.TypeInstance+import Parser.TypeInstance () import Test.Common import Types.Positional import Types.TypeInstance@@ -566,13 +563,28 @@ ] +type0 :: CategoryName type0 = CategoryName "Type0"++type1 :: CategoryName type1 = CategoryName "Type1"++type2 :: CategoryName type2 = CategoryName "Type2"++type3 :: CategoryName type3 = CategoryName "Type3"++type4 :: CategoryName type4 = CategoryName "Type4"++type5 :: CategoryName type5 = CategoryName "Type5"++instance0 :: CategoryName instance0 = CategoryName "Instance0"++instance1 :: CategoryName instance1 = CategoryName "Instance1" variances :: Map.Map CategoryName InstanceVariances@@ -667,11 +679,13 @@ ]) ] -+checkSimpleConvertSuccess :: [Char] -> [Char] -> IO (CompileInfo ()) checkSimpleConvertSuccess = checkConvertSuccess [] +checkSimpleConvertFail :: [Char] -> [Char] -> IO (CompileInfo ()) checkSimpleConvertFail = checkConvertFail [] +checkConvertSuccess :: [(String, [String])] -> [Char] -> [Char] -> IO (CompileInfo ()) checkConvertSuccess pa x y = return checked where prefix = x ++ " -> " ++ y ++ " " ++ showParams pa checked = do@@ -681,6 +695,7 @@ | isCompileError c = compileError $ prefix ++ ":\n" ++ show (getCompileError c) | otherwise = return () +checkConvertFail :: [(String, [String])] -> [Char] -> [Char] -> IO (CompileInfo ()) checkConvertFail pa x y = return checked where prefix = x ++ " /> " ++ y ++ " " ++ showParams pa checked = do@@ -702,19 +717,23 @@ -- Type5 is concrete, somewhat arbitrarily. trConcrete _ = \t -> return (t == type5) +getParams :: CompileErrorM m =>+ Map.Map CategoryName (Map.Map CategoryName (InstanceParams -> InstanceParams))+ -> TypeInstance -> CategoryName -> m InstanceParams getParams ma (TypeInstance n1 ps1) n2 = do ra <- mapLookup ma n1 f <- mapLookup ra n2 return $ f ps1 +getTypeFilters :: CompileErrorM m => TypeInstance -> m InstanceFilters getTypeFilters (TypeInstance n ps) = do f <- mapLookup typeFilters n return $ f ps +getDefinesFilters :: CompileErrorM m => DefinesInstance -> m InstanceFilters getDefinesFilters (DefinesInstance n ps) = do f <- mapLookup definesFilters n return $ f ps- mapLookup :: (Ord n, Show n, CompileErrorM m) => Map.Map n a -> n -> m a mapLookup ma n = resolve $ n `Map.lookup` ma where
src/Types/DefinedCategory.hs view
@@ -84,7 +84,7 @@ setInternalFunctions r t fs = foldr update (return start) fs where start = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions t filters = getCategoryFilterMap t- update f@(ScopedFunction c n t2 s as rs ps fs ms) fa = do+ update f@(ScopedFunction c n t2 s as rs ps fs2 ms) fa = do validateCategoryFunction r t f fa' <- fa case n `Map.lookup` fa' of@@ -95,7 +95,7 @@ f0' <- parsedToFunctionType f0 f' <- parsedToFunctionType f checkFunctionConvert r filters f0' f'- return $ Map.insert n (ScopedFunction (c++c2) n t2 s as rs ps fs ([f0]++ms++ms2)) fa'+ return $ Map.insert n (ScopedFunction (c++c2) n t2 s as rs ps fs2 ([f0]++ms++ms2)) fa' pairProceduresToFunctions :: (Show c, CompileErrorM m, MergeableM m) => Map.Map FunctionName (ScopedFunction c) -> [ExecutableProcedure c] ->@@ -115,10 +115,10 @@ " is already defined" ++ formatFullContextBrace (epContext p0) return $ Map.insert (epName p) p pa'- updatePairs fa pa n ps = do- ps' <- ps- p <- getPair (n `Map.lookup` fa) (n `Map.lookup` pa)- return (p:ps')+ updatePairs fa2 pa n ps2 = do+ ps2' <- ps2+ p <- getPair (n `Map.lookup` fa2) (n `Map.lookup` pa)+ return (p:ps2') getPair (Just f) Nothing = compileError $ "Function " ++ show (sfName f) ++ formatFullContextBrace (sfContext f) ++@@ -128,7 +128,7 @@ formatFullContextBrace (epContext p) ++ " does not correspond to a function" getPair (Just f) (Just p) = do- processPairs alwaysPair (sfArgs f) (avNames $ epArgs p) `reviseError`+ processPairs_ alwaysPair (sfArgs f) (avNames $ epArgs p) `reviseError` ("Procedure for " ++ show (sfName f) ++ formatFullContextBrace (avContext $ epArgs p) ++ " has the wrong number of arguments" ++@@ -136,13 +136,14 @@ if isUnnamedReturns (epReturns p) then return () else do- processPairs alwaysPair (sfReturns f) (nrNames $ epReturns p) `reviseError`+ processPairs_ alwaysPair (sfReturns f) (nrNames $ epReturns p) `reviseError` ("Procedure for " ++ show (sfName f) ++ formatFullContextBrace (nrContext $ epReturns p) ++ " has the wrong number of returns" ++ formatFullContextBrace (sfContext f)) return () return (f,p)+ getPair _ _ = undefined mapMembers :: (Show c, CompileErrorM m, MergeableM m) => [DefinedMember c] -> m (Map.Map VariableName (VariableValue c))
src/Types/Function.hs view
@@ -75,8 +75,8 @@ checkHides n = when (n `Map.member` fm) $ compileError $ "Param " ++ show n ++ " hides another param in a higher scope"- checkFilterType fa (n,f) =- validateTypeFilter r fa f `reviseError` ("In filter " ++ show n ++ " " ++ show f)+ checkFilterType fa2 (n,f) =+ validateTypeFilter r fa2 f `reviseError` ("In filter " ++ show n ++ " " ++ show f) checkFilterVariance (n,f@(TypeFilter FilterRequires t)) = validateInstanceVariance r allVariances Contravariant (SingleType t) `reviseError` ("In filter " ++ show n ++ " " ++ show f)@@ -86,45 +86,45 @@ checkFilterVariance (n,f@(DefinesFilter t)) = validateDefinesVariance r allVariances Contravariant t `reviseError` ("In filter " ++ show n ++ " " ++ show f)- checkArg fa ta@(ValueType _ t) = flip reviseError ("In argument " ++ show ta) $ do+ checkArg fa2 ta@(ValueType _ t) = flip reviseError ("In argument " ++ show ta) $ do when (isWeakValue ta) $ compileError "Weak values not allowed as argument types"- validateGeneralInstance r fa t+ validateGeneralInstance r fa2 t validateInstanceVariance r allVariances Contravariant t- checkReturn fa ta@(ValueType _ t) = flip reviseError ("In return " ++ show ta) $ do+ checkReturn fa2 ta@(ValueType _ t) = flip reviseError ("In return " ++ show ta) $ do when (isWeakValue ta) $ compileError "Weak values not allowed as return types"- validateGeneralInstance r fa t+ validateGeneralInstance r fa2 t validateInstanceVariance r allVariances Covariant t assignFunctionParams :: (MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> Positional GeneralInstance -> FunctionType -> m FunctionType-assignFunctionParams r fm ts ff@(FunctionType as rs ps fa) = do+assignFunctionParams r fm ts (FunctionType as rs ps fa) = do mergeAllM $ map (validateGeneralInstance r fm) $ pValues ts assigned <- fmap Map.fromList $ processPairs alwaysPair ps ts let allAssigned = Map.union assigned (Map.fromList $ map (\n -> (n,SingleType $ JustParamName n)) $ Map.keys fm) fa' <- fmap Positional $ collectAllOrErrorM $ map (assignFilters allAssigned) (pValues fa)- processPairs (validateAssignment r fm) ts fa'+ processPairs_ (validateAssignment r fm) ts fa' as' <- fmap Positional $ collectAllOrErrorM $ map (uncheckedSubValueType $ getValueForParam allAssigned) (pValues as) rs' <- fmap Positional $ collectAllOrErrorM $ map (uncheckedSubValueType $ getValueForParam allAssigned) (pValues rs) return $ FunctionType as' rs' (Positional []) (Positional []) where- assignFilters fm fs = collectAllOrErrorM $ map (uncheckedSubFilter $ getValueForParam fm) fs+ assignFilters fm2 fs = collectAllOrErrorM $ map (uncheckedSubFilter $ getValueForParam fm2) fs checkFunctionConvert :: (MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> FunctionType -> FunctionType -> m ()-checkFunctionConvert r fm ff1@(FunctionType as1 rs1 ps1 fa1) ff2 = do+checkFunctionConvert r fm (FunctionType as1 rs1 ps1 fa1) ff2 = do mapped <- fmap Map.fromList $ processPairs alwaysPair ps1 fa1 let fm' = Map.union fm mapped let asTypes = Positional $ map (SingleType . JustParamName) $ pValues ps1 -- Substitute params from ff2 into ff1. (FunctionType as2 rs2 _ _) <- assignFunctionParams r fm' asTypes ff2 fixed <- processPairs alwaysPair ps1 fa1- let fm' = Map.union fm (Map.fromList fixed)- processPairs (validateArg fm') as1 as2- processPairs (validateReturn fm') rs1 rs2+ let fm'' = Map.union fm (Map.fromList fixed)+ processPairs_ (validateArg fm'') as1 as2+ processPairs_ (validateReturn fm'') rs1 rs2 return () where- validateArg fm a1 a2 = checkValueTypeMatch r fm a1 a2- validateReturn fm r1 r2 = checkValueTypeMatch r fm r2 r1+ validateArg fm2 a1 a2 = checkValueTypeMatch r fm2 a1 a2+ validateReturn fm2 r1 r2 = checkValueTypeMatch r fm2 r2 r1
src/Types/GeneralType.hs view
@@ -24,7 +24,6 @@ checkGeneralType, ) where -import Base.CompileError import Base.Mergeable @@ -44,7 +43,7 @@ deriving (Eq,Ord) checkGeneralType :: (MergeableM m, Mergeable c) => (a -> b -> m c) -> GeneralType a -> GeneralType b -> m c-checkGeneralType f ti1 ti2 = singleCheck ti1 ti2 where+checkGeneralType f = singleCheck where singleCheck (SingleType t1) (SingleType t2) = t1 `f` t2 -- NOTE: The merge-alls must be expanded strictly before the merge-anys. singleCheck ti1 (TypeMerge MergeIntersect t2) = mergeAllM $ map (ti1 `singleCheck`) t2
src/Types/IntegrationTest.hs view
@@ -78,19 +78,24 @@ data OutputScope = OutputAny | OutputCompiler | OutputStderr | OutputStdout deriving (Eq,Ord,Show) +isExpectCompileError :: ExpectedResult c -> Bool isExpectCompileError (ExpectCompileError _ _ _) = True isExpectCompileError _ = False +isExpectRuntimeError :: ExpectedResult c -> Bool isExpectRuntimeError (ExpectRuntimeError _ _ _ _) = True isExpectRuntimeError _ = False +isExpectRuntimeSuccess :: ExpectedResult c -> Bool isExpectRuntimeSuccess (ExpectRuntimeSuccess _ _ _ _) = True isExpectRuntimeSuccess _ = False +getRequirePattern :: ExpectedResult c -> [OutputPattern] getRequirePattern (ExpectCompileError _ rs _) = rs getRequirePattern (ExpectRuntimeError _ _ rs _) = rs getRequirePattern (ExpectRuntimeSuccess _ _ rs _) = rs +getExcludePattern :: ExpectedResult c -> [OutputPattern] getExcludePattern (ExpectCompileError _ _ es) = es getExcludePattern (ExpectRuntimeError _ _ _ es) = es getExcludePattern (ExpectRuntimeSuccess _ _ _ es) = es
src/Types/Positional.hs view
@@ -20,12 +20,11 @@ Positional(..), alwaysPair, processPairs,+ processPairs_, processPairsT, ) where -import Control.Monad (Monad(..)) import Control.Monad.Trans (MonadTrans(..))-import Data.Functor import Base.CompileError @@ -49,6 +48,10 @@ collectAllOrErrorM $ map (uncurry f) (zip ps1 ps2) | otherwise = compileError $ "Parameter count mismatch: " ++ show ps1 ++ " vs. " ++ show ps2++processPairs_ :: (Show a, Show b, CompileErrorM m) =>+ (a -> b -> m c) -> Positional a -> Positional b -> m ()+processPairs_ f xs ys = processPairs f xs ys >> return () processPairsT :: (MonadTrans t, Monad (t m), Show a, Show b, CompileErrorM m) => (a -> b -> t m c) -> Positional a -> Positional b -> t m [c]
src/Types/Procedure.hs view
@@ -48,7 +48,6 @@ import Data.List (intercalate) -import Types.Function import Types.Positional import Types.TypeCategory import Types.TypeInstance
src/Types/TypeCategory.hs view
@@ -20,7 +20,7 @@ module Types.TypeCategory ( AnyCategory(..),- CategoryMap(..),+ CategoryMap, CategoryResolver(..), FunctionName(..), Namespace(..),@@ -147,7 +147,7 @@ map (\r -> " " ++ formatRefine r) rs ++ map (\d -> " " ++ formatDefine d) ds ++ map (\v -> " " ++ formatValue v) vs ++- map (\f -> formatInterfaceFunc f) fs) +++ map (\f -> formatConcreteFunc f) fs) ++ "\n}\n" namespace ns | isStaticNamespace ns = " /*" ++ show ns ++ "*/"@@ -157,12 +157,9 @@ "<" ++ intercalate "," con ++ "|" ++ intercalate "," inv ++ "|" ++ intercalate "," cov ++ ">"- -- NOTE: This assumes that the params are ordered by contravariant,- -- invariant, and covariant.- partitionParam p (con,inv,cov)- | vpVariance p == Contravariant = ((show $ vpParam p):con,inv,cov)- | vpVariance p == Invariant = (con,(show $ vpParam p):inv,cov)- | vpVariance p == Covariant = (con,inv,(show $ vpParam p):cov)+ partitionParam (ValueParam _ p Contravariant) (con,inv,cov) = ((show p):con,inv,cov)+ partitionParam (ValueParam _ p Invariant) (con,inv,cov) = (con,(show p):inv,cov)+ partitionParam (ValueParam _ p Covariant) (con,inv,cov) = (con,inv,(show p):cov) formatRefine r = "refines " ++ show (vrType r) ++ " " ++ formatContext (vrContext r) formatDefine d = "defines " ++ show (vdType d) ++ " " ++ formatContext (vdContext d) formatValue v = show (pfParam v) ++ " " ++ show (pfFilter v) ++@@ -227,17 +224,18 @@ defines = concat $ map (fromDefine . vdType) $ getCategoryDefines t filters = concat $ map (fromFilter . pfFilter) $ getCategoryFilters t functions = concat $ map fromFunction $ getCategoryFunctions t- fromInstance (TypeMerge _ ps) = concat $ map fromInstance ps+ fromInstance (TypeMerge _ ps) = concat $ map fromInstance ps fromInstance (SingleType (JustTypeInstance (TypeInstance n ps))) = n:(concat $ map fromInstance $ pValues ps)- fromInstance _ = []+ fromInstance _ = [] fromDefine (DefinesInstance n ps) = n:(concat $ map fromInstance $ pValues ps) fromFilter (TypeFilter _ t2@(JustTypeInstance _)) = fromInstance (SingleType t2)- fromFilter (DefinesFilter t2) = fromDefine t2+ fromFilter (DefinesFilter t2) = fromDefine t2+ fromFilter _ = [] fromType (ValueType _ t2) = fromInstance t2- fromFunction f = args ++ returns ++ filters where+ fromFunction f = args ++ returns ++ filters2 where args = concat $ map (fromType . pvType) $ pValues $ sfArgs f returns = concat $ map (fromType . pvType) $ pValues $ sfReturns f- filters = concat $ map (fromFilter . pfFilter) $ sfFilters f+ filters2 = concat $ map (fromFilter . pfFilter) $ sfFilters f isValueInterface :: AnyCategory c -> Bool isValueInterface (ValueInterface _ _ _ _ _ _ _) = True@@ -263,12 +261,15 @@ show (StaticNamespace n) = n show _ = "" +isStaticNamespace :: Namespace -> Bool isStaticNamespace (StaticNamespace _) = True isStaticNamespace _ = False +isNoNamespace :: Namespace -> Bool isNoNamespace NoNamespace = True isNoNamespace _ = False +isDynamicNamespace :: Namespace -> Bool isDynamicNamespace DynamicNamespace = True isDynamicNamespace _ = False @@ -319,7 +320,7 @@ trRefines (CategoryResolver tm) (TypeInstance n1 ps1) n2 | n1 == n2 = do (_,t) <- getValueCategory tm ([],n1)- processPairs alwaysPair (Positional $ map vpParam $ getCategoryParams t) ps1+ processPairs_ alwaysPair (Positional $ map vpParam $ getCategoryParams t) ps1 return ps1 | otherwise = do (_,t) <- getValueCategory tm ([],n1)@@ -377,12 +378,12 @@ (getCategoryFilters t) let fa = Map.fromListWith (++) $ map (second (:[])) fs fmap Positional $ collectAllOrErrorM $ map (assignFilter fa) params where- subSingleFilter pa (n,(TypeFilter v t)) = do- (SingleType t2) <- uncheckedSubInstance (getValueForParam pa) (SingleType t)- return (n,(TypeFilter v t2))- subSingleFilter pa (n,(DefinesFilter (DefinesInstance n2 ps))) = do- ps2 <- collectAllOrErrorM $ map (uncheckedSubInstance $ getValueForParam pa) (pValues ps)- return (n,(DefinesFilter (DefinesInstance n2 (Positional ps2))))+ subSingleFilter pa (n,(TypeFilter v t2)) = do+ (SingleType t3) <- uncheckedSubInstance (getValueForParam pa) (SingleType t2)+ return (n,(TypeFilter v t3))+ subSingleFilter pa (n,(DefinesFilter (DefinesInstance n2 ps2))) = do+ ps3 <- collectAllOrErrorM $ map (uncheckedSubInstance $ getValueForParam pa) (pValues ps2)+ return (n,(DefinesFilter (DefinesInstance n2 (Positional ps3)))) assignFilter fa n = case n `Map.lookup` fa of (Just x) -> return x@@ -441,10 +442,10 @@ checkConnectionCycles tm0 ts checkConnectedTypes tm0 ts checkParamVariances tm0 ts- ts <- topoSortCategories tm0 ts- ts <- flattenAllConnections tm0 ts- checkCategoryInstances tm0 ts- declareAllTypes tm0 ts+ ts2 <- topoSortCategories tm0 ts+ ts3 <- flattenAllConnections tm0 ts2+ checkCategoryInstances tm0 ts3+ declareAllTypes tm0 ts3 declareAllTypes :: (Show c, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)@@ -480,15 +481,15 @@ mergeAllM (map (checkSingle tm) ts) where checkSingle tm (ValueInterface c _ n _ rs _ _) = do- let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs- is <- collectAllOrErrorM $ map (getCategory tm) ts+ let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs+ is <- collectAllOrErrorM $ map (getCategory tm) ts2 mergeAllM (map (valueRefinesInstanceError c n) is) mergeAllM (map (valueRefinesConcreteError c n) is) checkSingle tm (ValueConcrete c _ n _ rs ds _ _) = do- let ts1 = map (\r -> (vrContext r,tiName $ vrType r)) rs- let ts2 = map (\d -> (vdContext d,diName $ vdType d)) ds- is1 <- collectAllOrErrorM $ map (getCategory tm) ts1- is2 <- collectAllOrErrorM $ map (getCategory tm) ts2+ let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs+ let ts3 = map (\d -> (vdContext d,diName $ vdType d)) ds+ is1 <- collectAllOrErrorM $ map (getCategory tm) ts2+ is2 <- collectAllOrErrorM $ map (getCategory tm) ts3 mergeAllM (map (concreteRefinesInstanceError c n) is1) mergeAllM (map (concreteDefinesValueError c n) is2) mergeAllM (map (concreteRefinesConcreteError c n) is1)@@ -539,13 +540,13 @@ tm = Map.union tm0 $ Map.fromList $ zip (map getCategoryName ts) ts checker us (ValueInterface c _ n _ rs _ _) = do failIfCycle n c us- let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs- is <- collectAllOrErrorM $ map (getValueCategory tm) ts+ let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs+ is <- collectAllOrErrorM $ map (getValueCategory tm) ts2 mergeAllM (map (checker (us ++ [n]) . snd) is) checker us (ValueConcrete c _ n _ rs _ _ _) = do failIfCycle n c us- let ts = map (\r -> (vrContext r,tiName $ vrType r)) rs- is <- collectAllOrErrorM $ map (getValueCategory tm) ts+ let ts2 = map (\r -> (vrContext r,tiName $ vrType r)) rs+ is <- collectAllOrErrorM $ map (getValueCategory tm) ts2 mergeAllM (map (checker (us ++ [n]) . snd) is) checker _ _ = return () failIfCycle n c us =@@ -622,7 +623,6 @@ checkSingle r t = do let pa = Set.fromList $ map vpParam $ getCategoryParams t let fm = getCategoryFilterMap t- let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t mergeAllM $ map (checkFilterParam pa) (getCategoryFilters t) mergeAllM $ map (checkRefine r fm) (getCategoryRefines t) mergeAllM $ map (checkDefine r fm) (getCategoryDefines t)@@ -652,6 +652,7 @@ CategoryScope -> validatateFunctionType r Map.empty Map.empty funcType TypeScope -> validatateFunctionType r fm vm funcType ValueScope -> validatateFunctionType r fm vm funcType+ _ -> return () topoSortCategories :: (Show c, MergeableM m, CompileErrorM m) => CategoryMap c -> [AnyCategory c] -> m [AnyCategory c]@@ -661,9 +662,9 @@ return ts' where update tm t u = do- (ts,ta) <- u+ (_,ta) <- u if getCategoryName t `Set.member` ta- then return (ts,ta)+ then u else do refines <- collectAllOrErrorM $ map (\r -> getCategory tm (vrContext r,tiName $ vrType r)) $ getCategoryRefines t@@ -708,17 +709,17 @@ [c] -> CategoryName -> [ValueRefine c] -> m () noDuplicateRefines c n rs = do let names = map (\r -> (tiName $ vrType r,r)) rs- noDuplicates c n names+ noDuplicateCategories c n names noDuplicateDefines :: (Show c, MergeableM m, CompileErrorM m) => [c] -> CategoryName -> [ValueDefine c] -> m () noDuplicateDefines c n ds = do let names = map (\d -> (diName $ vdType d,d)) ds- noDuplicates c n names+ noDuplicateCategories c n names -noDuplicates :: (Show c, Show a, MergeableM m, CompileErrorM m) =>+noDuplicateCategories :: (Show c, Show a, MergeableM m, CompileErrorM m) => [c] -> CategoryName -> [(CategoryName,a)] -> m ()-noDuplicates c n ns =+noDuplicateCategories c n ns = mergeAllM $ map checkCount $ groupBy (\x y -> fst x == fst y) $ sortBy (\x y -> fst x `compare` fst y) ns where checkCount xa@(x:_:_) =@@ -740,19 +741,19 @@ tm <- u t' <- preMergeSingle tm t return $ Map.insert (getCategoryName t') t' tm- preMergeSingle tm t@(ValueInterface c ns n ps rs vs fs) = do+ preMergeSingle tm (ValueInterface c ns n ps rs vs fs) = do rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs return $ ValueInterface c ns n ps rs' vs fs- preMergeSingle tm t@(ValueConcrete c ns n ps rs ds vs fs) = do+ preMergeSingle tm (ValueConcrete c ns n ps rs ds vs fs) = do rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs return $ ValueConcrete c ns n ps rs' ds vs fs preMergeSingle _ t = return t update r t u = do- (ts,tm) <- u+ (ts2,tm) <- u t' <- updateSingle r tm t `reviseError` ("In category " ++ show (getCategoryName t) ++ formatFullContextBrace (getCategoryContext t))- return (ts ++ [t'],Map.insert (getCategoryName t') t' tm)+ return (ts2 ++ [t'],Map.insert (getCategoryName t') t' tm) updateSingle r tm t@(ValueInterface c ns n ps rs vs fs) = do let fm = getCategoryFilterMap t rs' <- fmap concat $ collectAllOrErrorM $ map (getRefines tm) rs@@ -775,7 +776,7 @@ fs' <- mergeFunctions r tm fm rs ds fs return $ ValueConcrete c ns n ps rs'' ds' vs fs' updateSingle _ _ t = return t- getRefines tm ra@(ValueRefine c t@(TypeInstance n ps)) = do+ getRefines tm ra@(ValueRefine c t@(TypeInstance n _)) = do (_,v) <- getValueCategory tm (c,n) let refines = getCategoryRefines v pa <- assignParams tm c t@@ -808,52 +809,52 @@ let inheritByName = Map.fromListWith (++) $ map (\f -> (sfName f,[f])) $ inheritValue ++ inheritType let explicitByName = Map.fromListWith (++) $ map (\f -> (sfName f,[f])) fs let allNames = Set.toList $ Set.union (Map.keysSet inheritByName) (Map.keysSet explicitByName)- collectAllOrErrorM $ map (mergeByName r fm inheritByName explicitByName) allNames-getRefinesFuncs tm ra@(ValueRefine c (TypeInstance n ts)) = flip reviseError (show ra) $ do- (_,t) <- getValueCategory tm (c,n)- let ps = map vpParam $ getCategoryParams t- let fs = getCategoryFunctions t- paired <- processPairs alwaysPair (Positional ps) ts- let assigned = Map.fromList paired- collectAllOrErrorM (map (uncheckedSubFunction assigned) fs)-getDefinesFuncs tm da@(ValueDefine c (DefinesInstance n ts)) = flip reviseError (show da) $ do- (_,t) <- getInstanceCategory tm (c,n)- let ps = map vpParam $ getCategoryParams t- let fs = getCategoryFunctions t- paired <- processPairs alwaysPair (Positional ps) ts- let assigned = Map.fromList paired- collectAllOrErrorM (map (uncheckedSubFunction assigned) fs)-mergeByName r fm im em n =- tryMerge r fm n (n `Map.lookup` im) (n `Map.lookup` em)--- Inherited without an override.-tryMerge _ _ n (Just is) Nothing- | length is == 1 = return $ head is- | otherwise = compileError $ "Function " ++ show n ++ " is inherited " ++- show (length is) ++ " times:\n---\n" ++- intercalate "\n---\n" (map show is)--- Not inherited.-tryMerge r fm n Nothing es = tryMerge r fm n (Just []) es--- Explicit override, possibly inherited.-tryMerge r fm n (Just is) (Just es)- | length es /= 1 = compileError $ "Function " ++ show n ++ " is declared " ++- show (length es) ++ " times:\n---\n" ++- intercalate "\n---\n" (map show es)- | otherwise = do- let ff@(ScopedFunction c n t s as rs ps fa ms) = head es- mergeAllM $ map (checkMerge r fm ff) is- return $ ScopedFunction c n t s as rs ps fa (ms ++ is)- where- checkMerge r fm f1 f2- | sfScope f1 /= sfScope f2 =- compileError $ "Cannot merge " ++ showScope (sfScope f2) ++ " with " ++- showScope (sfScope f1) ++ " in function merge:\n---\n" ++- show f2 ++ "\n ->\n" ++ show f1- | otherwise =- flip reviseError ("In function merge:\n---\n" ++ show f2 ++- "\n ->\n" ++ show f1 ++ "\n---\n") $ do- f1' <- parsedToFunctionType f1- f2' <- parsedToFunctionType f2- checkFunctionConvert r fm f2' f1'+ collectAllOrErrorM $ map (mergeByName r fm inheritByName explicitByName) allNames where+ getRefinesFuncs tm2 ra@(ValueRefine c (TypeInstance n ts2)) = flip reviseError (show ra) $ do+ (_,t) <- getValueCategory tm2 (c,n)+ let ps = map vpParam $ getCategoryParams t+ let fs2 = getCategoryFunctions t+ paired <- processPairs alwaysPair (Positional ps) ts2+ let assigned = Map.fromList paired+ collectAllOrErrorM (map (uncheckedSubFunction assigned) fs2)+ getDefinesFuncs tm2 da@(ValueDefine c (DefinesInstance n ts2)) = flip reviseError (show da) $ do+ (_,t) <- getInstanceCategory tm2 (c,n)+ let ps = map vpParam $ getCategoryParams t+ let fs2 = getCategoryFunctions t+ paired <- processPairs alwaysPair (Positional ps) ts2+ let assigned = Map.fromList paired+ collectAllOrErrorM (map (uncheckedSubFunction assigned) fs2)+ mergeByName r2 fm2 im em n =+ tryMerge r2 fm2 n (n `Map.lookup` im) (n `Map.lookup` em)+ -- Inherited without an override.+ tryMerge _ _ n (Just is) Nothing+ | length is == 1 = return $ head is+ | otherwise = compileError $ "Function " ++ show n ++ " is inherited " +++ show (length is) ++ " times:\n---\n" +++ intercalate "\n---\n" (map show is)+ -- Not inherited.+ tryMerge r2 fm2 n Nothing es = tryMerge r2 fm2 n (Just []) es+ -- Explicit override, possibly inherited.+ tryMerge r2 fm2 n (Just is) (Just es)+ | length es /= 1 = compileError $ "Function " ++ show n ++ " is declared " +++ show (length es) ++ " times:\n---\n" +++ intercalate "\n---\n" (map show es)+ | otherwise = do+ let ff@(ScopedFunction c n2 t s as rs2 ps fa ms) = head es+ mergeAllM $ map (checkMerge r2 fm2 ff) is+ return $ ScopedFunction c n2 t s as rs2 ps fa (ms ++ is)+ where+ checkMerge r3 fm3 f1 f2+ | sfScope f1 /= sfScope f2 =+ compileError $ "Cannot merge " ++ showScope (sfScope f2) ++ " with " +++ showScope (sfScope f1) ++ " in function merge:\n---\n" +++ show f2 ++ "\n ->\n" ++ show f1+ | otherwise =+ flip reviseError ("In function merge:\n---\n" ++ show f2 +++ "\n ->\n" ++ show f1 ++ "\n---\n") $ do+ f1' <- parsedToFunctionType f1+ f2' <- parsedToFunctionType f2+ checkFunctionConvert r3 fm3 f2' f1' data FunctionName = FunctionName {@@ -899,15 +900,15 @@ "(" ++ intercalate "," (map (show . pvType) $ pValues rs) ++ ")" ++ showMerges (flatten ms) where showParams [] = ""- showParams ps = "<" ++ intercalate "," (map (show . vpParam) ps) ++ ">"- formatContext cs = "/*" ++ formatFullContext cs ++ "*/"+ showParams ps2 = "<" ++ intercalate "," (map (show . vpParam) ps2) ++ ">"+ formatContext cs2 = "/*" ++ formatFullContext cs2 ++ "*/" formatValue v = " " ++ show (pfParam v) ++ " " ++ show (pfFilter v) ++ " " ++ formatContext (pfContext v) flatten [] = Set.empty- flatten ms = Set.unions $ (Set.fromList $ map sfType ms):(map (flatten . sfMerges) ms)- showMerges ms- | null (Set.toList ms) = " /*not merged*/"- | otherwise = " /*merged from: " ++ intercalate ", " (map show $ Set.toList ms) ++ "*/"+ flatten ms2 = Set.unions $ (Set.fromList $ map sfType ms2):(map (flatten . sfMerges) ms2)+ showMerges ms2+ | null (Set.toList ms2) = " /*not merged*/"+ | otherwise = " /*merged from: " ++ intercalate ", " (map show $ Set.toList ms2) ++ "*/" data PassedValue c = PassedValue {@@ -920,7 +921,7 @@ parsedToFunctionType :: (Show c, MergeableM m, CompileErrorM m) => ScopedFunction c -> m FunctionType-parsedToFunctionType (ScopedFunction c n t _ as rs ps fa _) = do+parsedToFunctionType (ScopedFunction c n _ _ as rs ps fa _) = do let as' = Positional $ map pvType $ pValues as let rs' = Positional $ map pvType $ pValues rs let ps' = Positional $ map vpParam $ pValues ps@@ -935,8 +936,8 @@ compileError $ "Filtered param " ++ show (pfParam f) ++ " is not defined for function " ++ show n ++ formatFullContextBrace c- getFilters fm n =- case n `Map.lookup` fm of+ getFilters fm2 n2 =+ case n2 `Map.lookup` fm2 of (Just fs) -> fs _ -> [] @@ -944,7 +945,7 @@ Map.Map ParamName GeneralInstance -> ScopedFunction c -> m (ScopedFunction c) uncheckedSubFunction pa ff@(ScopedFunction c n t s as rs ps fa ms) = flip reviseError ("In function:\n---\n" ++ show ff ++ "\n---\n") $ do- let fixed = Map.fromList $ map (\n -> (n,SingleType $ JustParamName n)) $ map vpParam $ pValues ps+ let fixed = Map.fromList $ map (\n2 -> (n2,SingleType $ JustParamName n2)) $ map vpParam $ pValues ps let pa' = Map.union pa fixed as' <- fmap Positional $ collectAllOrErrorM $ map (subPassed pa') $ pValues as rs' <- fmap Positional $ collectAllOrErrorM $ map (subPassed pa') $ pValues rs@@ -952,9 +953,9 @@ ms' <- collectAllOrErrorM $ map (uncheckedSubFunction pa) ms return $ (ScopedFunction c n t s as' rs' ps fa' ms') where- subPassed pa (PassedValue c t) = do- t' <- uncheckedSubValueType (getValueForParam pa) t- return $ PassedValue c t'- subFilter pa (ParamFilter c n f) = do- f' <- uncheckedSubFilter (getValueForParam pa) f- return $ ParamFilter c n f'+ subPassed pa2 (PassedValue c2 t2) = do+ t' <- uncheckedSubValueType (getValueForParam pa2) t2+ return $ PassedValue c2 t'+ subFilter pa2 (ParamFilter c2 n2 f) = do+ f' <- uncheckedSubFilter (getValueForParam pa2) f+ return $ ParamFilter c2 n2 f'
src/Types/TypeInstance.hs view
@@ -210,8 +210,8 @@ isTypeFilter _ = False isRequiresFilter :: TypeFilter -> Bool-isRequiresFilter (TypeFilter isRequiresFilter _) = True-isRequiresFilter _ = False+isRequiresFilter (TypeFilter FilterRequires _) = True+isRequiresFilter _ = False isDefinesFilter :: TypeFilter -> Bool isDefinesFilter (DefinesFilter _) = True@@ -317,7 +317,7 @@ let zipped = Positional paired variance <- trVariance r n1 -- NOTE: Covariant is identity, so v2 has technically been composed with it.- processPairs (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance zipped >> mergeDefaultM+ processPairs_ (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance zipped >> mergeDefaultM | otherwise = do ps1' <- trRefines r t1 n2 checkInstanceToInstance r f Covariant (TypeInstance n2 ps1') t2@@ -330,7 +330,7 @@ checkParamToInstance r f Contravariant n1 t2] checkParamToInstance r f Contravariant p1 t2 = checkInstanceToParam r f Covariant t2 p1-checkParamToInstance r f Covariant n1 t2@(TypeInstance n2 ps2) = do+checkParamToInstance r f Covariant n1 t2@(TypeInstance _ _) = do cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n1 mergeAnyM (map checkConstraintToInstance cs1) `reviseError` ("No filters imply " ++ show n1 ++ " -> " ++ show t2)@@ -338,10 +338,10 @@ checkConstraintToInstance (TypeFilter FilterRequires t) = -- x -> F implies x -> T only if F -> T checkSingleMatch r f Covariant t (JustTypeInstance t2)- checkConstraintToInstance f =+ checkConstraintToInstance f2 = -- F -> x cannot imply x -> T -- DefinesInstance cannot be converted to TypeInstance- compileError $ "Constraint " ++ viewTypeFilter n1 f +++ compileError $ "Constraint " ++ viewTypeFilter n1 f2 ++ " does not imply " ++ show n1 ++ " -> " ++ show t2 checkInstanceToParam :: (MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -352,7 +352,7 @@ checkInstanceToParam r f Contravariant t1 n2] checkInstanceToParam r f Contravariant t1 p2 = checkParamToInstance r f Covariant p2 t1-checkInstanceToParam r f Covariant t1@(TypeInstance n1 ps1) n2 = do+checkInstanceToParam r f Covariant t1@(TypeInstance _ _) n2 = do cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n2 mergeAnyM (map checkInstanceToConstraint cs2) `reviseError` ("No filters imply " ++ show t1 ++ " -> " ++ show n2)@@ -360,9 +360,9 @@ checkInstanceToConstraint (TypeFilter FilterAllows t) = -- F -> x implies T -> x only if T -> F checkSingleMatch r f Covariant (JustTypeInstance t1) t- checkInstanceToConstraint f =+ checkInstanceToConstraint f2 = -- x -> F cannot imply T -> x- compileError $ "Constraint " ++ viewTypeFilter n2 f +++ compileError $ "Constraint " ++ viewTypeFilter n2 f2 ++ " does not imply " ++ show t1 ++ " -> " ++ show n2 checkParamToParam :: (MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -403,11 +403,11 @@ validateGeneralInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> GeneralInstance -> m ()-validateGeneralInstance r f ta@(TypeMerge _ ts)+validateGeneralInstance _ _ (TypeMerge _ ts) | length ts == 1 = compileError $ "Unions and intersections must have at least 2 types to avoid ambiguity"-validateGeneralInstance r f ta@(TypeMerge MergeIntersect ts) =+validateGeneralInstance r f (TypeMerge MergeIntersect ts) = mergeAllM (map (validateGeneralInstance r f) ts)-validateGeneralInstance r f ta@(TypeMerge _ ts) =+validateGeneralInstance r f (TypeMerge _ ts) = mergeAllM (map (validateGeneralInstance r f) ts) validateGeneralInstance r f (SingleType (JustTypeInstance t)) = validateTypeInstance r f t@@ -417,17 +417,17 @@ validateTypeInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> TypeInstance -> m ()-validateTypeInstance r f t@(TypeInstance n ps) = do+validateTypeInstance r f t@(TypeInstance _ ps) = do fa <- trTypeFilters r t- processPairs (validateAssignment r f) ps fa+ processPairs_ (validateAssignment r f) ps fa mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseError` ("Recursive error in " ++ show t) validateDefinesInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> DefinesInstance -> m ()-validateDefinesInstance r f t@(DefinesInstance n ps) = do+validateDefinesInstance r f t@(DefinesInstance _ ps) = do fa <- trDefinesFilters r t- processPairs (validateAssignment r f) ps fa+ processPairs_ (validateAssignment r f) ps fa mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseError` ("Recursive error in " ++ show t) @@ -445,15 +445,9 @@ checkGeneralMatch r f Covariant t1 (SingleType t2) checkFilter t1 (TypeFilter FilterAllows t2) = do checkGeneralMatch r f Contravariant t1 (SingleType t2)- checkFilter t1@(TypeMerge _ _) (DefinesFilter t) =- compileError $ "Merged type " ++ show t1 ++ " cannot satisfy defines constraint " ++ show t- checkFilter t1@(SingleType t) (DefinesFilter f) = checkDefinesFilter f t- requireExactlyOne t [_] = mergeDefaultM- requireExactlyOne t [] =- compileError $ "No types in intersection define " ++ show t- requireExactlyOne t ts =- (compileError $ "Multiple types in intersection define " ++ show t) `mergeNestedM`- (mergeAllM $ map (compileError . show) ts)+ checkFilter t1@(TypeMerge _ _) (DefinesFilter t2) =+ compileError $ "Merged type " ++ show t1 ++ " cannot satisfy defines constraint " ++ show t2+ checkFilter (SingleType t1) (DefinesFilter f2) = checkDefinesFilter f2 t1 checkDefinesFilter f2@(DefinesInstance n2 _) (JustTypeInstance t1) = do ps1' <- trDefines r t1 n2 checkDefinesMatch r f f2 (DefinesInstance n2 ps1')@@ -468,7 +462,7 @@ | n1 == n2 = do paired <- processPairs alwaysPair ps1 ps2 variance <- trVariance r n2- processPairs (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance (Positional paired)+ processPairs_ (\v2 (p1,p2) -> checkGeneralMatch r f v2 p1 p2) variance (Positional paired) mergeDefaultM | otherwise = compileError $ "Constraint " ++ show f1 ++ " does not imply " ++ show f2 @@ -482,7 +476,7 @@ mergeAllM (map (validateInstanceVariance r vm v) ts) validateInstanceVariance r vm v (TypeMerge MergeIntersect ts) = mergeAllM (map (validateInstanceVariance r vm v) ts)-validateInstanceVariance r vm v (SingleType (JustParamName n)) =+validateInstanceVariance _ vm v (SingleType (JustParamName n)) = case n `Map.lookup` vm of Nothing -> compileError $ "Param " ++ show n ++ " is undefined" (Just v0) -> when (not $ v0 `paramAllowsVariance` v) $
zeolite-lang.cabal view
@@ -1,5 +1,7 @@+cabal-version: 2.2+ name: zeolite-lang-version: 0.1.2.9+version: 0.1.3.0 synopsis: Zeolite is a statically-typed, general-purpose programming language. description:@@ -50,8 +52,12 @@ category: Compiler build-type: Simple -cabal-version: 2.0-tested-with: GHC == 8.8.3+tested-with: GHC == 8.10.1,+ GHC == 8.8.3,+ GHC == 8.6.5,+ GHC == 8.4.4,+ GHC == 8.2.2,+ GHC == 8.0.2 extra-source-files: ChangeLog.md extra-source-files: src/Test/testfiles/*.0rt,@@ -105,7 +111,16 @@ tests/visibility2/internal/*.0rx +common defaults+ default-language: Haskell2010+ ghc-options: -Wall+ if impl(ghc >= 8)+ ghc-options: -Wno-orphans -Wno-unused-top-binds++ library zeolite-internal+ import: defaults+ exposed-modules: Base.CompileError, Base.Mergeable, Cli.CompileMetadata,@@ -163,9 +178,9 @@ Safe, ScopedTypeVariables - build-depends: base >= 4.8 && < 4.14,+ build-depends: base >= 4.8 && < 4.15, containers >= 0.3 && < 0.7,- directory >= 1.2.7 && < 1.4,+ directory >= 1.2.3 && < 1.4, filepath >= 1.0 && < 1.5, hashable >= 1.0 && < 1.4, mtl >= 1.0 && < 2.3,@@ -175,10 +190,11 @@ unix >= 2.6 && <= 2.8 hs-source-dirs: src- default-language: Haskell2010 executable zeolite+ import: defaults+ main-is: bin/zeolite.hs build-depends: base,@@ -188,10 +204,10 @@ unix, zeolite-internal - default-language: Haskell2010 - executable zeolite-setup+ import: defaults+ main-is: bin/zeolite-setup.hs build-depends: base,@@ -199,10 +215,10 @@ filepath, zeolite-internal - default-language: Haskell2010 - test-suite zeolite-test+ import: defaults+ type: exitcode-stdio-1.0 main-is: bin/unit-tests.hs@@ -211,5 +227,3 @@ directory, filepath, zeolite-internal-- default-language: Haskell2010