zeolite-lang 0.7.0.1 → 0.7.0.2
raw patch · 26 files changed
+268/−525 lines, 26 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Compilation.CompilerState: reviseErrorStateT :: CompileErrorM m => CompilerState a m b -> String -> CompilerState a m b
+ Base.CompileError: (<??) :: CompileErrorM m => m a -> String -> m a
+ Base.CompileError: (??>) :: CompileErrorM m => String -> m a -> m a
+ Base.Mergeable: instance (GHC.Classes.Ord k, Base.Mergeable.Mergeable a) => Base.Mergeable.Mergeable (Data.Map.Internal.Map k a)
+ Base.Mergeable: instance Base.Mergeable.MergeableM Data.Functor.Identity.Identity
+ Compilation.CompilerState: (<???) :: CompileErrorM m => CompilerState a m b -> String -> CompilerState a m b
+ Compilation.CompilerState: (???>) :: CompileErrorM m => String -> CompilerState a m b -> CompilerState a m b
Files
- ChangeLog.md +7/−0
- lib/math/tests.0rt +1/−351
- src/Base/CompileError.hs +8/−0
- src/Base/MergeTree.hs +9/−7
- src/Base/Mergeable.hs +11/−0
- src/Cli/ProcessMetadata.hs +4/−4
- src/Cli/RunCompiler.hs +4/−4
- src/Cli/TestRunner.hs +5/−5
- src/Compilation/CompilerState.hs +7/−3
- src/Compilation/ProcedureContext.hs +8/−8
- src/Compilation/ScopeContext.hs +1/−2
- src/CompilerCxx/Category.hs +12/−12
- src/CompilerCxx/Procedure.hs +18/−18
- src/Test/Common.hs +5/−5
- src/Test/IntegrationTest.hs +1/−1
- src/Test/MergeTree.hs +12/−0
- src/Test/ParseMetadata.hs +2/−2
- src/Test/TypeCategory.hs +43/−4
- src/Test/TypeInstance.hs +5/−5
- src/Test/testfiles/delayed_merging.0rx +18/−0
- src/Types/DefinedCategory.hs +7/−7
- src/Types/Function.hs +6/−6
- src/Types/TypeCategory.hs +54/−64
- src/Types/TypeInstance.hs +9/−9
- src/Types/Variance.hs +4/−2
- zeolite-lang.cabal +7/−6
ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for zeolite-lang +## 0.7.0.2 -- 2020-05-21++### Language++* **[fix]** Improves the likelihood of successful type inference when unions,+ intersections, or filters are combined with inheritance and type nesting.+ ## 0.7.0.1 -- 2020-05-20 ### Language
lib/math/tests.0rt view
@@ -16,389 +16,39 @@ // Author: Kevin P. Barry [ta0kira@gmail.com] -testcase "sanity check cos" {+testcase "sanity check all functions" { success Test$run() } define Test { run () { \ Testing$checkBetween<?>(Math$cos(2.0),-0.42,-0.41)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check sin" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$sin(2.0),0.90,0.91)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check tan" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$tan(2.0),-2.19,-2.18)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check acos" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$acos(0.5),1.04,1.05)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check asin" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$asin(0.5),0.52,0.53)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check atan" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$atan(0.5),0.46,0.47)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check cosh" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$cosh(2.0),3.76,3.77)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check sinh" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$sinh(2.0),3.62,3.63)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check tanh" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$tanh(2.0),0.96,0.97)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check acosh" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$acosh(2.0),1.31,1.32)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check asinh" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$asinh(2.0),1.44,1.45)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check atanh" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$atanh(0.5),0.54,0.55)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check exp" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$exp(1.0),2.71,2.72)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check log" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$log(9.0),2.19,2.20)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check log10" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$log10(100.0),1.99,2.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check log2" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$log2(8.0),2.99,3.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check pow" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$pow(2.0,3.0),7.99,8.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check sqrt" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$sqrt(4.0),1.99,2.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check ceil" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$ceil(2.2),2.99,3.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check floor" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$floor(2.2),1.99,2.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check fmod" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$fmod(7.0,4.0),2.99,3.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check trunc" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$trunc(2.2),1.99,2.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check round" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$round(2.7),2.99,3.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check fabs" {- success Test$run()-}--define Test {- run () { \ Testing$checkBetween<?>(Math$fabs(-10.0),9.99,10.01)- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check isinf" {- success Test$run()-}--define Test {- run () { if (!Math$isinf(Math$log(0.0))) { fail("Failed") }- }-}--concrete Test {- @type run () -> ()-}---testcase "sanity check isnan" {- success Test$run()-}--define Test {- run () { if (!Math$isnan(Math$sqrt(-1.0))) { fail("Failed") }
src/Base/CompileError.hs view
@@ -22,6 +22,8 @@ module Base.CompileError ( CompileErrorM(..),+ (<??),+ (??>), errorFromIO, mapErrorsM, mapErrorsM_,@@ -54,6 +56,12 @@ compileBackgroundM _ = return () resetBackgroundM :: m a -> m a resetBackgroundM = id++(<??) :: CompileErrorM m => m a -> String -> m a+(<??) = reviseErrorM++(??>) :: CompileErrorM m => String -> m a -> m a+(??>) = flip reviseErrorM mapErrorsM :: CompileErrorM m => (a -> m b) -> [a] -> m [b] mapErrorsM f = collectAllOrErrorM . map f
src/Base/MergeTree.hs view
@@ -25,6 +25,8 @@ reduceMergeTree, ) where +import Data.Functor.Identity (runIdentity)+ import Base.Mergeable @@ -62,7 +64,7 @@ fmap f (MergeLeaf x) = MergeLeaf (f x) instance Foldable MergeTree where- foldr f y = foldr f y . maybe [] id . reduceMergeTree return return (return . (:[]))+ foldr f y = foldr f y . runIdentity . reduceMergeTree return return (return . (:[])) instance Traversable MergeTree where traverse f (MergeAny xs) = MergeAny <$> foldr (<*>) (pure []) (map (fmap (:) . traverse f) xs)@@ -70,13 +72,13 @@ traverse f (MergeLeaf x) = fmap MergeLeaf (f x) instance Mergeable (MergeTree a) where- mergeAny = unnest . filter (not . isEmptyAny) . foldr (:) [] where- isEmptyAny (MergeAny []) = True- isEmptyAny _ = False+ mergeAny = unnest . foldr ((++) . flattenAny) [] where+ flattenAny (MergeAny xs) = xs+ flattenAny x = [x] unnest [x] = x unnest xs = MergeAny xs- mergeAll = unnest . filter (not . isEmptyAll) . foldr (:) [] where- isEmptyAll (MergeAll []) = True- isEmptyAll _ = False+ mergeAll = unnest . foldr ((++) . flattenAll) [] where+ flattenAll (MergeAll xs) = xs+ flattenAll x = [x] unnest [x] = x unnest xs = MergeAll xs
src/Base/Mergeable.hs view
@@ -27,6 +27,9 @@ mergeDefaultM, ) where +import Data.Functor.Identity+import Data.Map as Map hiding (foldr)+ #if MIN_VERSION_base(4,11,0) #else import Data.Monoid ((<>))@@ -55,6 +58,14 @@ mergeAny = foldr (++) [] mergeAll = foldr (++) [] +instance (Ord k, Mergeable a) => Mergeable (Map k a) where+ mergeAny = Map.fromListWith (\x y -> mergeAny [x,y]) . foldr ((++) . Map.toList) []+ mergeAll = Map.fromListWith (\x y -> mergeAll [x,y]) . foldr ((++) . Map.toList) []+ instance MergeableM Maybe where mergeAnyM = fmap mergeAny . foldr ((<>) . fmap (:[])) Nothing mergeAllM = fmap mergeAll . sequence . foldr (:) []++instance MergeableM Identity where+ mergeAnyM = Identity . mergeAny . foldr ((:) . runIdentity) []+ mergeAllM = Identity . mergeAll . foldr ((:) . runIdentity) []
src/Cli/ProcessMetadata.hs view
@@ -97,7 +97,7 @@ filePresent <- errorFromIO $ doesFileExist f when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been configured yet" c <- errorFromIO $ readFile f- (autoReadConfig f c) `reviseErrorM`+ (autoReadConfig f c) <?? ("Could not parse metadata from \"" ++ p ++ "\"; please reconfigure") isPathUpToDate :: VersionHash -> ForceMode -> FilePath -> CompileInfoIO Bool@@ -114,7 +114,7 @@ writeMetadata p m = do p' <- errorFromIO $ canonicalizePath p errorFromIO $ hPutStrLn stderr $ "Writing metadata for \"" ++ p' ++ "\"."- m' <- autoWriteConfig m `reviseErrorM` ("In data for " ++ p)+ m' <- autoWriteConfig m <?? ("In data for " ++ p) writeCachedFile p' "" metadataFilename m' writeRecompile :: FilePath -> ModuleConfig -> CompileInfoIO ()@@ -122,7 +122,7 @@ p' <- errorFromIO $ canonicalizePath p let f = p </> moduleFilename errorFromIO $ hPutStrLn stderr $ "Updating config for \"" ++ p' ++ "\"."- m' <- autoWriteConfig m `reviseErrorM` ("In data for " ++ p)+ m' <- autoWriteConfig m <?? ("In data for " ++ p) errorFromIO $ writeFile f m' eraseCachedData :: FilePath -> CompileInfoIO ()@@ -251,7 +251,7 @@ filePresent <- errorFromIO $ doesFileExist f when (not filePresent) $ compileErrorM $ "Module \"" ++ p ++ "\" has not been compiled yet" c <- errorFromIO $ readFile f- (autoReadConfig f c) `reviseErrorM`+ (autoReadConfig f c) <?? ("Could not parse metadata from \"" ++ p ++ "\"; please recompile") fixPath :: FilePath -> FilePath
src/Cli/RunCompiler.hs view
@@ -69,7 +69,7 @@ intercalate ", " (map show fs) ++ "\n" processResults passed failed rs | isCompileError rs =- (fromCompileInfo rs) `reviseErrorM`+ (fromCompileInfo rs) <?? ("\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)") | otherwise = compileWarningM $ "\nPassed: " ++ show passed ++ " test(s), Failed: " ++ show failed ++ " test(s)"@@ -103,7 +103,7 @@ msMode = (CompileBinary c fn (absolute </> show c) []), msForce = f }- compileModule resolver backend spec `reviseErrorM` ("In compilation of \"" ++ f2' ++ "\"")+ compileModule resolver backend spec <?? ("In compilation of \"" ++ f2' ++ "\"") errorFromIO $ removeDirectoryRecursive dir runCompiler resolver backend (CompileOptions h _ _ ds _ _ p CompileRecompileRecursive f) = do@@ -155,7 +155,7 @@ msMode = m, msForce = f }- compileModule resolver backend spec `reviseErrorM` ("In compilation of module \"" ++ d ++ "\"")+ compileModule resolver backend spec <?? ("In compilation of module \"" ++ d ++ "\"") runCompiler resolver backend (CompileOptions _ is is2 ds _ _ p CreateTemplates f) = mapM_ compileSingle ds where compilerHash = getCompilerHash backend@@ -167,7 +167,7 @@ deps1 <- loadPublicDeps compilerHash f Map.empty (base:as) deps2 <- loadPublicDeps compilerHash f (mapMetadata deps1) as2 path <- errorFromIO $ canonicalizePath p- createModuleTemplates path d deps1 deps2 `reviseErrorM` ("In module \"" ++ d' ++ "\"")+ createModuleTemplates path d deps1 deps2 <?? ("In module \"" ++ d' ++ "\"") runCompiler resolver backend (CompileOptions h is is2 ds es ep p m f) = mapM_ compileSingle ds where compileSingle d = do
src/Cli/TestRunner.hs view
@@ -49,7 +49,7 @@ runSingleTest b cm p paths deps (f,s) = do errorFromIO $ hPutStrLn stderr $ "\nExecuting tests from " ++ f allResults <- checkAndRun (parseTestSource (f,s))- return $ second (flip reviseErrorM $ "\nIn test file " ++ f) allResults where+ return $ second (("\nIn test file " ++ f) ??>) allResults where checkAndRun ts | isCompileError ts = do errorFromIO $ hPutStrLn stderr $ "Failed to parse tests in " ++ f@@ -64,7 +64,7 @@ let name = "\"" ++ ithTestName (itHeader t) ++ "\" (from " ++ f ++ ")" let context = formatFullContextBrace (ithContext $ itHeader t) errorFromIO $ hPutStrLn stderr $ "\n*** Executing test " ++ name ++ " ***"- outcome <- fmap (flip reviseErrorM ("\nIn test \"" ++ name ++ "\"" ++ context)) $+ outcome <- fmap (("\nIn test \"" ++ ithTestName (itHeader t) ++ "\"" ++ context) ??>) $ run (ithResult $ itHeader t) (itCategory t) (itDefinition t) if isCompileError outcome then errorFromIO $ hPutStrLn stderr $ "*** Test " ++ name ++ " failed ***"@@ -88,13 +88,13 @@ let ce = checkExcluded es comp err out let compError = if null comp then return ()- else (mergeAllM $ map compileErrorM comp) `reviseErrorM` "\nOutput from compiler:"+ else (mergeAllM $ map compileErrorM comp) <?? "\nOutput from compiler:" let errError = if null err then return ()- else (mergeAllM $ map compileErrorM err) `reviseErrorM` "\nOutput to stderr from test:"+ else (mergeAllM $ map compileErrorM err) <?? "\nOutput to stderr from test:" let outError = if null out then return ()- else (mergeAllM $ map compileErrorM out) `reviseErrorM` "\nOutput to stdout from test:"+ else (mergeAllM $ map compileErrorM out) <?? "\nOutput to stdout from test:" if isCompileError cr || isCompileError ce then mergeAllM [cr,ce,compError,errError,outError] else mergeAllM [cr,ce]
src/Compilation/CompilerState.hs view
@@ -30,6 +30,8 @@ LoopSetup(..), MemberValue(..), ReturnVariable(..),+ (<???),+ (???>), csAddVariable, csAllFilters, csCheckValueInit,@@ -61,7 +63,6 @@ csWrite, getCleanContext, resetBackgroundStateT,- reviseErrorStateT, runDataCompiler, ) where @@ -149,8 +150,11 @@ instance Show c => Show (VariableValue c) where show (VariableValue c _ t _) = show t ++ formatFullContextBrace c -reviseErrorStateT :: (CompileErrorM m) => CompilerState a m b -> String -> CompilerState a m b-reviseErrorStateT x s = mapStateT (`reviseErrorM` s) x+(<???) :: (CompileErrorM m) => CompilerState a m b -> String -> CompilerState a m b+(<???) x s = mapStateT (<?? s) x++(???>) :: (CompileErrorM m) => String -> CompilerState a m b -> CompilerState a m b+(???>) s x = mapStateT (s ??>) x resetBackgroundStateT :: (CompileErrorM m) => CompilerState a m b -> CompilerState a m b resetBackgroundStateT x = mapStateT resetBackgroundM x
src/Compilation/ProcedureContext.hs view
@@ -142,7 +142,7 @@ compileErrorM $ "Use explicit type conversion to call " ++ show n ++ " for union type " ++ show t2 ++ formatFullContextBrace c getFunction (Just ta@(TypeMerge MergeIntersect ts)) =- collectOneOrErrorM (map getFunction $ map Just ts) `reviseErrorM`+ collectOneOrErrorM (map getFunction $ map Just ts) <?? ("Function " ++ show n ++ " not available for type " ++ show ta ++ formatFullContextBrace c) getFunction (Just (SingleType (JustParamName _ p))) = do fa <- ccAllFilters ctx@@ -151,7 +151,7 @@ _ -> compileErrorM $ "Param " ++ show p ++ " does not exist" let ts = map tfType $ filter isRequiresFilter fs let ds = map dfType $ filter isDefinesFilter fs- collectOneOrErrorM (map (getFunction . Just . SingleType) ts ++ map checkDefine ds) `reviseErrorM`+ collectOneOrErrorM (map (getFunction . Just . SingleType) ts ++ map checkDefine ds) <?? ("Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c) getFunction (Just (SingleType (JustTypeInstance t2))) -- Same category as the procedure itself.@@ -179,7 +179,7 @@ when (sfScope f == CategoryScope) $ compileErrorM $ "Function " ++ show n ++ " in " ++ show t2 ++ " is a category function" ++ formatFullContextBrace c- paired <- processPairs alwaysPair ps1 ps2 `reviseErrorM`+ paired <- processPairs alwaysPair ps1 ps2 <?? ("In external function call at " ++ formatFullContext c) let assigned = Map.fromList paired uncheckedSubFunction assigned f@@ -191,7 +191,7 @@ | t /= pcType ctx = compileErrorM $ "Category " ++ show (pcType ctx) ++ " cannot initialize values from " ++ show t ++ formatFullContextBrace c- | otherwise = flip reviseErrorM ("In initialization at " ++ formatFullContext c) $ do+ | otherwise = ("In initialization at " ++ formatFullContext c) ??> do let t' = TypeInstance (pcType ctx) as r <- ccResolver ctx allFilters <- ccAllFilters ctx@@ -217,7 +217,7 @@ assignFilters fm fs = do mapErrorsM (uncheckedSubFilter $ getValueForParam fm) fs checkInit r fa (MemberValue c2 n t0) (i,t1) = do- checkValueTypeMatch r fa t1 t0 `reviseErrorM`+ checkValueTypeMatch r fa t1 t0 <?? ("In initializer " ++ show i ++ " for " ++ show n ++ formatFullContextBrace c2) subSingle pa (DefinedMember c2 _ t2 n _) = do t2' <- uncheckedSubValueType (getValueForParam pa) t2@@ -400,16 +400,16 @@ Nothing -> Positional [] Just vs2 -> vs2 -- Check for a count match first, to avoid the default error message.- processPairs_ alwaysPair (fmap pvType rs) vs' `reviseErrorM`+ processPairs_ alwaysPair (fmap pvType rs) vs' <?? ("In procedure return at " ++ formatFullContext c)- processPairs_ checkReturnType rs (Positional $ zip ([0..] :: [Int]) $ pValues vs') `reviseErrorM`+ processPairs_ checkReturnType rs (Positional $ zip ([0..] :: [Int]) $ pValues vs') <?? ("In procedure return at " ++ formatFullContext c) return () where checkReturnType ta0@(PassedValue _ t0) (n,t) = do r <- ccResolver ctx pa <- ccAllFilters ctx- checkValueTypeMatch r pa t t0 `reviseErrorM`+ checkValueTypeMatch r pa t t0 <?? ("Cannot convert " ++ show t ++ " to " ++ show ta0 ++ " in return " ++ show n ++ " at " ++ formatFullContext c) check (ValidateNames ts ra) =
src/Compilation/ScopeContext.hs view
@@ -102,8 +102,7 @@ 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 `reviseErrorM`- (show n2 ++ " " ++ show f ++ formatFullContextBrace c2)+ validateTypeFilter r fa f <?? (show n2 ++ " " ++ show f ++ formatFullContextBrace c2) checkFunction pm f = when (sfScope f == ValueScope) $ mergeAllM $ map (checkParam pm) $ pValues $ sfParams f
src/CompilerCxx/Category.hs view
@@ -140,7 +140,7 @@ -- Ensures that there isn't an inavertent collision when resolving -- dependencies for the module later on. tmTesting' <- tmTesting- _ <- includeNewTypes tmTesting' cs2 `reviseErrorM` "In a module source that is conditionally public"+ _ <- (includeNewTypes tmTesting' cs2) <?? "In a module source that is conditionally public" hxx <- mapErrorsM (compileCategoryDeclaration tm' ns4) cs2 let interfaces = filter (not . isValueConcrete) cs2 cxx1 <- mapErrorsM compileInterfaceDefinition interfaces@@ -175,10 +175,10 @@ formatFullContextBrace (getCategoryContext t) ++ " has not been defined or declared external") (_,Just ds) ->- flip reviseErrorM ("Category " ++ show (getCategoryName t) ++- formatFullContextBrace (getCategoryContext t) ++- " is defined " ++ show (length ds) ++ " times") $- mergeAllM $ map (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds+ ("Category " ++ show (getCategoryName t) +++ formatFullContextBrace (getCategoryContext t) +++ " is defined " ++ show (length ds) ++ " times") ??>+ (mergeAllM $ map (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds) checkSupefluous es2 | null es2 = return () | otherwise = compileErrorM $ "External categories either not concrete or not present: " ++@@ -206,8 +206,8 @@ reconcile [_] = return () reconcile [] = compileErrorM $ "No matches for main category " ++ show n ++ " ($TestsOnly$ sources excluded)" reconcile ds =- flip reviseErrorM ("Multiple matches for main category " ++ show n) $- mergeAllM $ map (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds+ ("Multiple matches for main category " ++ show n) ??>+ (mergeAllM $ map (\d -> compileErrorM $ "Defined at " ++ formatFullContext (dcContext d)) ds) compileCategoryDeclaration :: (Show c, CompileErrorM m, MergeableM m) => CategoryMap c -> [Namespace] -> AnyCategory c -> m CxxOutput@@ -265,7 +265,7 @@ CategoryMap c -> CategoryName -> m CxxOutput compileConcreteTemplate ta n = do (_,t) <- getConcreteCategory ta ([],n)- compileConcreteDefinition ta Map.empty [] Nothing (defined t) `reviseErrorM` ("In generated template for " ++ show n) where+ compileConcreteDefinition ta Map.empty [] Nothing (defined t) <?? ("In generated template for " ++ show n) where defined t = DefinedCategory { dcContext = [], dcName = getCategoryName t,@@ -408,11 +408,11 @@ return $ onlyCode $ valueName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {}" unwrappedArg i m = writeStoredVariable (dmType m) (UnwrappedSingle $ "args.At(" ++ show i ++ ")") createMember r filters m = do- validateGeneralInstance r filters (vtType $ dmType m) `reviseErrorM`+ validateGeneralInstance r filters (vtType $ dmType m) <?? ("In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)) return $ onlyCode $ variableStoredType (dmType m) ++ " " ++ variableName (dmName m) ++ ";" createMemberLazy r filters m = do- validateGeneralInstance r filters (vtType $ dmType m) `reviseErrorM`+ validateGeneralInstance r filters (vtType $ dmType m) <?? ("In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)) return $ onlyCode $ variableLazyType (dmType m) ++ " " ++ variableName (dmName m) ++ ";" categoryDispatch fs2 =@@ -767,7 +767,7 @@ createMainFile :: (Show c, CompileErrorM m, MergeableM m) => CategoryMap c -> ExprMap c -> CategoryName -> FunctionName -> m (Namespace,[String])-createMainFile tm em n f = flip reviseErrorM ("In the creation of the main binary procedure") $ do+createMainFile tm em n f = ("In the creation of the main binary procedure") ??> do ca <- fmap indentCompiled (compileMainProcedure tm em expr) let file = createMainCommon "main" ca (_,t) <- getConcreteCategory tm ([],n)@@ -778,7 +778,7 @@ createTestFile :: (Show c, CompileErrorM m, MergeableM m) => CategoryMap c -> ExprMap c -> Expression c -> m ([CategoryName],[String])-createTestFile tm em e = flip reviseErrorM ("In the creation of the test binary procedure") $ do+createTestFile tm em e = ("In the creation of the test binary procedure") ??> do ca@(CompiledData req _) <- fmap indentCompiled (compileMainProcedure tm em e) let file = createMainCommon "test" ca return (Set.toList req,file)
src/CompilerCxx/Procedure.hs view
@@ -75,7 +75,7 @@ compileProcedure ctx0 p >>= put unreachable <- csIsUnreachable when (not unreachable) $- doImplicitReturn [] `reviseErrorStateT`+ doImplicitReturn [] <??? ("In implicit return from " ++ show n ++ formatFullContextBrace c) wrapProcedure output pt ct = mergeAll $ [@@ -144,7 +144,7 @@ then return e' else return $ predTraceContext c ++ e' where- compile = flip reviseErrorStateT ("In condition at " ++ formatFullContext c) $ do+ compile = ("In condition at " ++ formatFullContext c) ???> do (ts,e') <- compileExpression e lift $ checkCondition ts return $ useAsUnboxed PrimBool e'@@ -196,7 +196,7 @@ autoPositionalCleanup e -- Multi-expression => must all be singles. getReturn rs = do- lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) `reviseErrorM`+ lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map (fst . snd) rs) <?? ("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) ++ ")"@@ -227,7 +227,7 @@ let (Positional [t0],e0) = e' r <- csResolver fa <- csAllFilters- lift $ (checkValueTypeMatch_ r fa t0 formattedRequiredValue) `reviseErrorM`+ lift $ (checkValueTypeMatch_ r fa t0 formattedRequiredValue) <?? ("In fail call at " ++ formatFullContext c) csSetNoReturn maybeSetTrace c@@ -236,7 +236,7 @@ (_,e') <- compileExpression e maybeSetTrace c csWrite ["(void) (" ++ useAsWhatever e' ++ ");"]-compileStatement (Assignment c as e) = flip reviseErrorStateT message $ do+compileStatement (Assignment c as e) = message ???> do (ts,e') <- compileExpression e r <- csResolver fa <- csAllFilters@@ -259,14 +259,14 @@ return t getVariableType (ExistingVariable (DiscardInput _)) t = return t createVariable r fa (CreateVariable c2 t1 n) t2 =- flip reviseErrorStateT ("In creation of " ++ show n ++ " at " ++ formatFullContext c2) $ do+ ("In creation of " ++ show n ++ " at " ++ formatFullContext c2) ???> do -- TODO: Call csRequiresTypes for t1. (Maybe needs a helper function.) lift $ mergeAllM [validateGeneralInstance r fa (vtType t1), checkValueTypeMatch_ r fa t2 t1] csAddVariable c2 n (VariableValue c2 LocalScope t1 True) csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"] createVariable r fa (ExistingVariable (InputValue c2 n)) t2 =- flip reviseErrorStateT ("In assignment to " ++ show n ++ " at " ++ formatFullContext c2) $ do+ ("In assignment to " ++ show n ++ " at " ++ formatFullContext c2) ???> do (VariableValue _ _ t1 w) <- csGetVariable c2 n when (not w) $ lift $ compileErrorM $ "Cannot assign to read-only variable " ++ show n ++ formatFullContextBrace c2@@ -312,7 +312,7 @@ r <- csResolver fa <- csAllFilters let Positional [t2] = ts- lift $ (checkValueTypeMatch_ r fa t2 t1) `reviseErrorM`+ lift $ (checkValueTypeMatch_ r fa t2 t1) <?? ("In initialization of " ++ show n ++ " at " ++ formatFullContext c) csWrite [variableName n ++ "([this]() { return " ++ writeStoredVariable t1 e' ++ "; })"] @@ -430,7 +430,7 @@ csInheritReturns [ctxCl] where createVariable r fa (c,t,n) = do- lift $ validateGeneralInstance r fa (vtType t) `reviseErrorM`+ lift $ validateGeneralInstance r fa (vtType t) <?? ("In creation of " ++ show n ++ " at " ++ formatFullContext c) csWrite [variableStoredType t ++ " " ++ variableName n ++ ";"] showVariable (c,t,n) = do@@ -554,7 +554,7 @@ getValues [(Positional ts,e)] = return (ts,useAsArgs e) -- Multi-expression => must all be singles. getValues rs = do- lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) `reviseErrorM`+ lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) <?? ("In return at " ++ formatFullContext c) return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")")@@ -636,7 +636,7 @@ r <- csResolver fa <- csAllFilters let vt = ValueType RequiredValue $ SingleType $ JustTypeInstance t- lift $ (checkValueTypeMatch_ r fa t' vt) `reviseErrorM`+ lift $ (checkValueTypeMatch_ r fa t' vt) <?? ("In converted call at " ++ formatFullContext c) f' <- lookupValueFunction vt f compileFunctionCall (Just $ useAsUnwrapped e') f' f@@ -673,7 +673,7 @@ return (Positional [t],readStoredVariable lazy t (scoped ++ variableName n)) compileExpressionStart (NamedMacro c n) = do e <- csExprLookup c n- compileExpression e `reviseErrorStateT` ("In env lookup at " ++ formatFullContext c)+ compileExpression e <??? ("In env lookup at " ++ formatFullContext c) compileExpressionStart (CategoryCall c t f@(FunctionCall _ n _ _)) = do f' <- csGetCategoryFunction c (Just t) n csRequiresTypes $ Set.fromList [t,sfType f']@@ -682,7 +682,7 @@ compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do r <- csResolver fa <- csAllFilters- lift $ validateGeneralInstance r fa (SingleType t) `reviseErrorM` ("In function call at " ++ formatFullContext c)+ lift $ validateGeneralInstance r fa (SingleType t) <?? ("In function call at " ++ formatFullContext c) f' <- csGetTypeFunction c (Just $ SingleType t) n when (sfScope f' /= TypeScope) $ lift $ compileErrorM $ "Function " ++ show n ++ " cannot be used as a type function" ++@@ -733,7 +733,7 @@ fa <- csAllFilters lift $ validateGeneralInstance r fa t1 lift $ validateGeneralInstance r fa t2- lift $ (checkValueTypeMatch_ r fa t0 (ValueType OptionalValue t1)) `reviseErrorM`+ lift $ (checkValueTypeMatch_ r fa t0 (ValueType OptionalValue t1)) <?? ("In argument to reduce call at " ++ formatFullContext c) -- TODO: If t1 -> t2 then just return e without a Reduce call. t1' <- expandGeneralInstance t1@@ -791,7 +791,7 @@ (Positional [t],e') <- compileExpression e -- TODO: Get rid of the Positional matching here. r <- csResolver fa <- csAllFilters- lift $ (checkValueTypeMatch_ r fa t t0) `reviseErrorM`+ lift $ (checkValueTypeMatch_ r fa t t0) <?? ("In assignment at " ++ formatFullContext c) csUpdateAssigned n scoped <- autoScope s@@ -809,7 +809,7 @@ CompilerContext c m [String] a) => Maybe String -> ScopedFunction c -> FunctionCall c -> CompilerState a m (ExpressionType,ExprValue)-compileFunctionCall e f (FunctionCall c _ ps es) = flip reviseErrorStateT errorContext $ do+compileFunctionCall e f (FunctionCall c _ ps es) = errorContext ???> do r <- csResolver fa <- csAllFilters es' <- sequence $ map compileExpression $ pValues es@@ -846,14 +846,14 @@ getValues [(Positional ts,e2)] = return (ts,useAsArgs e2) -- Multi-expression => must all be singles. getValues rs = do- lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) `reviseErrorM`+ lift $ mergeAllM (map checkArity $ zip ([0..] :: [Int]) $ map fst rs) <?? ("In return at " ++ formatFullContext c) return (map (head . pValues . fst) rs, "ArgTuple(" ++ intercalate ", " (map (useAsUnwrapped . snd) rs) ++ ")") checkArity (_,Positional [_]) = return () checkArity (i,Positional ts) = compileErrorM $ "Return position " ++ show i ++ " has " ++ show (length ts) ++ " values but should have 1" checkArg r fa t0 (i,t1) = do- checkValueTypeMatch r fa t1 t0 `reviseErrorM` ("In argument " ++ show i ++ " to " ++ show (sfName f))+ checkValueTypeMatch r fa t1 t0 <?? ("In argument " ++ show i ++ " to " ++ show (sfName f)) guessParamsFromArgs :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->
src/Test/Common.hs view
@@ -119,7 +119,7 @@ check $ validateGeneralInstance r pa2 t where prefix = x ++ " " ++ showParams pa- check = flip reviseErrorM (prefix ++ ":")+ check x2 = x2 <?? (prefix ++ ":") checkTypeFail :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo () checkTypeFail r pa x = do@@ -138,7 +138,7 @@ check $ validateDefinesInstance r pa2 t where prefix = x ++ " " ++ showParams pa- check = flip reviseErrorM (prefix ++ ":")+ check x2 = x2 <?? (prefix ++ ":") checkDefinesFail :: TypeResolver r => r -> [(String,[String])] -> String -> CompileInfo () checkDefinesFail r pa x = do@@ -159,7 +159,7 @@ containsNoDuplicates :: (Ord a, Show a) => [a] -> CompileInfo () containsNoDuplicates expected =- (mergeAllM $ map checkSingle $ group $ sort expected) `reviseErrorM` (show expected)+ (mergeAllM $ map checkSingle $ group $ sort expected) <?? (show expected) where checkSingle xa@(x:_:_) = compileErrorM $ "Item " ++ show x ++ " occurs " ++ show (length xa) ++ " times"@@ -167,7 +167,7 @@ containsAtLeast :: (Ord a, Show a) => [a] -> [a] -> CompileInfo () containsAtLeast actual expected =- (mergeAllM $ map (checkInActual $ Set.fromList actual) expected) `reviseErrorM`+ (mergeAllM $ map (checkInActual $ Set.fromList actual) expected) <?? (show actual ++ " (actual) vs. " ++ show expected ++ " (expected)") where checkInActual va v =@@ -177,7 +177,7 @@ containsAtMost :: (Ord a, Show a) => [a] -> [a] -> CompileInfo () containsAtMost actual expected =- (mergeAllM $ map (checkInExpected $ Set.fromList expected) actual) `reviseErrorM`+ (mergeAllM $ map (checkInExpected $ Set.fromList expected) actual) <?? (show actual ++ " (actual) vs. " ++ show expected ++ " (expected)") where checkInExpected va v =
src/Test/IntegrationTest.hs view
@@ -115,7 +115,7 @@ unwrap $ parse (between optionalSpace endOfDoc sourceParser) f s where unwrap (Left e) = return $ compileErrorM (show e)- unwrap (Right t) = fmap (flip reviseErrorM ("Check " ++ f ++ ":")) $ o t+ unwrap (Right t) = fmap (("Check " ++ f ++ ":") ??>) $ o t extractCategoryNames :: IntegrationTest c -> [String] extractCategoryNames = map (show . getCategoryName) . itCategory
src/Test/MergeTree.hs view
@@ -38,6 +38,13 @@ checkMatch (mergeLeaf 1) id (mergeAny [mergeLeaf 1,mergeAny []] :: MergeTree Int), checkMatch (mergeLeaf 1) id (mergeAll [mergeLeaf 1,mergeAll []] :: MergeTree Int), + checkMatch2 (mergeAny [mergeLeaf 1,mergeLeaf 2,mergeAll [mergeLeaf 3,mergeLeaf 4]])+ (mergeAny [mergeLeaf 1,mergeLeaf 2,mergeLeaf 3,mergeLeaf 4])+ (mergeAny [mergeAny [mergeLeaf 1],mergeLeaf 2,mergeAll [mergeLeaf 3,mergeLeaf 4]] :: MergeTree Int),+ checkMatch2 (mergeAll [mergeLeaf 1,mergeLeaf 2,mergeAny [mergeLeaf 3,mergeLeaf 4]])+ (mergeAll [mergeLeaf 1,mergeLeaf 2,mergeLeaf 3,mergeLeaf 4])+ (mergeAll [mergeAll [mergeLeaf 1],mergeLeaf 2,mergeAny [mergeLeaf 3,mergeLeaf 4]] :: MergeTree Int),+ checkMatch ([1,2]) (foldr (:) []) (mergeAny [mergeLeaf 1,mergeAll [mergeLeaf 2]] :: MergeTree Int), checkMatch ([1,2]) (foldr (:) [])@@ -87,6 +94,11 @@ return $ if x /= y' then compileErrorM $ "Expected " ++ show x ++ " but got " ++ show y' else return ()++checkMatch2 :: (Eq a, Show a) => a -> a -> a -> IO (CompileInfo ())+checkMatch2 x y z = return $ do+ when (x /= z) $ compileErrorM $ "Expected " ++ show x ++ " but got " ++ show z+ when (y == z) $ compileErrorM $ "Expected something besides " ++ show y checkSuccess :: (Eq b, Show b) => b -> (a -> CompileInfo b) -> a -> IO (CompileInfo ()) checkSuccess x f y = let y' = f y in
src/Test/ParseMetadata.hs view
@@ -335,7 +335,7 @@ checkWriteThenRead :: (Eq a, Show a, ConfigFormat a) => a -> IO (CompileInfo ()) checkWriteThenRead m = return $ do text <- fmap spamComments $ autoWriteConfig m- m' <- autoReadConfig "(string)" text `reviseErrorM` ("Serialized >>>\n\n" ++ text ++ "\n<<< Serialized\n\n")+ m' <- autoReadConfig "(string)" text <?? ("Serialized >>>\n\n" ++ text ++ "\n<<< Serialized\n\n") when (m' /= m) $ compileErrorM $ "Failed to match after write/read\n" ++ "Before:\n" ++ show m ++ "\n" ++@@ -363,7 +363,7 @@ return $ check parsed contents where check x contents = do- x' <- x `reviseErrorM` ("While parsing " ++ f)+ x' <- x <?? ("While parsing " ++ f) when (not $ m x') $ compileErrorM $ "Failed to match after write/read\n" ++ "Unparsed:\n" ++ contents ++ "\n" ++
src/Test/TypeCategory.hs view
@@ -961,7 +961,46 @@ [("#x",[])] ["#x"] -- Guesses are both Type0 and Type1, and Type0 is more general. [("Interface3<Type0>","[Interface1<#x>&Interface3<#x>]")]- [("#x","Type0",Invariant)])+ [("#x","Type0",Invariant)]),++ checkOperationSuccess+ ("testfiles" </> "inference.0rx")+ (\ts -> do+ tm <- includeNewTypes defaultCategories ts+ checkInferenceSuccess tm+ [("#x",[])] ["#x"]+ -- An unrelated union shouldn't cause problems.+ [("Type1","#x"),("Type2","[Type2|Type0]")]+ [("#x","Type1",Covariant)]),++ checkOperationSuccess+ ("testfiles" </> "inference.0rx")+ (\ts -> do+ tm <- includeNewTypes defaultCategories ts+ checkInferenceSuccess tm+ [("#x",[]),("#y",[])] ["#x","#y"]+ [("Interface3<Type0>","[Interface1<#x>&Interface3<#x>]"),+ ("Interface3<Type0>","[Interface1<#y>|Interface3<#y>]")]+ [("#x","Type0",Invariant),("#y","Type1",Covariant)]),++ checkOperationSuccess+ ("testfiles" </> "delayed_merging.0rx")+ (\ts -> do+ tm <- includeNewTypes defaultCategories ts+ checkInferenceFail tm+ [("#x",[])] ["#x"]+ -- Guesses are either Type1 or Type2.+ [("Type","[Interface1<#x>|Interface2<#x>]")]),+ checkOperationSuccess+ ("testfiles" </> "delayed_merging.0rx")+ (\ts -> do+ tm <- includeNewTypes defaultCategories ts+ checkInferenceSuccess tm+ [("#x",[])] ["#x"]+ -- Failure to merge Type1 and Type2 is resolved by Base.+ [("Base","#x"),+ ("Type","[Interface1<#x>|Interface2<#x>]")]+ [("#x","Base",Covariant)]) ] getRefines :: Map.Map CategoryName (AnyCategory c) -> String -> CompileInfo [String]@@ -1032,7 +1071,7 @@ compileErrorM $ "Different item counts: " ++ show actual ++ " (actual) vs. " ++ show expected ++ " (expected)" | otherwise = mergeAllM $ map check (zip3 actual expected ([1..] :: [Int])) where- check (a,e,n) = f a e `reviseErrorM` ("Item " ++ show n ++ " mismatch")+ check (a,e,n) = f a e <?? ("Item " ++ show n ++ " mismatch") containsPaired :: (Eq a, Show a) => [a] -> [a] -> CompileInfo () containsPaired = checkPaired checkSingle where@@ -1046,7 +1085,7 @@ let parsed = readMulti f contents :: CompileInfo [AnyCategory SourcePos] return $ check (parsed >>= o >> return ()) where- check = flip reviseErrorM ("Check " ++ f ++ ":")+ check x = x <?? ("Check " ++ f ++ ":") checkOperationFail :: String -> ([AnyCategory SourcePos] -> CompileInfo a) -> IO (CompileInfo ()) checkOperationFail f o = do@@ -1118,7 +1157,7 @@ checkInferenceCommon :: ([InferredTypeGuess] -> CompileInfo [InferredTypeGuess] -> CompileInfo ()) -> CategoryMap SourcePos -> [(String, [String])] -> [String] -> [(String,String)] -> [(String,String,Variance)] -> CompileInfo ()-checkInferenceCommon check tm pa is ts gs = checked `reviseErrorM` context where+checkInferenceCommon check tm pa is ts gs = checked <?? context where context = "With params = " ++ show pa ++ ", pairs = " ++ show ts checked = do let r = CategoryResolver tm
src/Test/TypeInstance.hs view
@@ -781,7 +781,7 @@ (MergeTree InferredTypeGuess -> CompileInfo (MergeTree InferredTypeGuess) -> CompileInfo ()) -> [(String, [String])] -> [String] -> String -> String -> MergeTree (String,String,Variance) -> IO (CompileInfo ())-checkInferenceCommon check pa is x y gs = return $ checked `reviseErrorM` context where+checkInferenceCommon check pa is x y gs = return $ checked <?? context where context = "With params = " ++ show pa ++ ", pair = (" ++ show x ++ "," ++ show y ++ ")" checked = do ([t1,t2],pa2) <- parseTheTest pa [x,y]@@ -833,17 +833,17 @@ Map.Map CategoryName (Map.Map CategoryName (InstanceParams -> InstanceParams)) -> TypeInstance -> CategoryName -> m InstanceParams getParams ma (TypeInstance n1 ps1) n2 = do- ra <- mapLookup ma n1 `reviseErrorM` ("In lookup of category " ++ show n1)- f <- mapLookup ra n2 `reviseErrorM` ("In lookup of parent " ++ show n2 ++ " of " ++ show n1)+ ra <- mapLookup ma n1 <?? ("In lookup of category " ++ show n1)+ f <- mapLookup ra n2 <?? ("In lookup of parent " ++ show n2 ++ " of " ++ show n1) return $ f ps1 getTypeFilters :: CompileErrorM m => TypeInstance -> m InstanceFilters-getTypeFilters (TypeInstance n ps) = flip reviseErrorM "In type filters lookup" $ do+getTypeFilters (TypeInstance n ps) = "In type filters lookup" ??> do f <- mapLookup typeFilters n return $ f ps getDefinesFilters :: CompileErrorM m => DefinesInstance -> m InstanceFilters-getDefinesFilters (DefinesInstance n ps) = flip reviseErrorM "In defines filters lookup" $ do+getDefinesFilters (DefinesInstance n ps) = "In defines filters lookup" ??> do f <- mapLookup definesFilters n return $ f ps
+ src/Test/testfiles/delayed_merging.0rx view
@@ -0,0 +1,18 @@+@value interface Base {}++concrete Type1 {+ refines Base+}++concrete Type2 {+ refines Base+}++@value interface Interface1<|#x> {}++@value interface Interface2<|#x> {}++concrete Type {+ refines Interface1<Type1>+ refines Interface2<Type2>+}
src/Types/DefinedCategory.hs view
@@ -91,11 +91,11 @@ case n `Map.lookup` fa' of Nothing -> return $ Map.insert n f fa' (Just f0@(ScopedFunction c2 _ _ _ _ _ _ _ ms2)) -> do- flip reviseErrorM ("In function merge:\n---\n" ++ show f0 ++- "\n ->\n" ++ show f ++ "\n---\n") $ do- f0' <- parsedToFunctionType f0- f' <- parsedToFunctionType f- checkFunctionConvert r fm pm f0' f'+ ("In function merge:\n---\n" ++ show f0 +++ "\n ->\n" ++ show f ++ "\n---\n") ??> do+ f0' <- parsedToFunctionType f0+ f' <- parsedToFunctionType f+ checkFunctionConvert r fm pm f0' f' 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) =>@@ -129,7 +129,7 @@ formatFullContextBrace (epContext p) ++ " does not correspond to a function" getPair (Just f) (Just p) = do- processPairs_ alwaysPair (sfArgs f) (avNames $ epArgs p) `reviseErrorM`+ processPairs_ alwaysPair (sfArgs f) (avNames $ epArgs p) <?? ("Procedure for " ++ show (sfName f) ++ formatFullContextBrace (avContext $ epArgs p) ++ " has the wrong number of arguments" ++@@ -137,7 +137,7 @@ if isUnnamedReturns (epReturns p) then return () else do- processPairs_ alwaysPair (sfReturns f) (nrNames $ epReturns p) `reviseErrorM`+ processPairs_ alwaysPair (sfReturns f) (nrNames $ epReturns p) <?? ("Procedure for " ++ show (sfName f) ++ formatFullContextBrace (nrContext $ epReturns p) ++ " has the wrong number of returns" ++
src/Types/Function.hs view
@@ -76,21 +76,21 @@ when (n `Map.member` fm) $ compileErrorM $ "Param " ++ show n ++ " hides another param in a higher scope" checkFilterType fa2 (n,f) =- validateTypeFilter r fa2 f `reviseErrorM` ("In filter " ++ show n ++ " " ++ show f)+ validateTypeFilter r fa2 f <?? ("In filter " ++ show n ++ " " ++ show f) checkFilterVariance (n,f@(TypeFilter FilterRequires t)) =- validateInstanceVariance r allVariances Contravariant (SingleType t) `reviseErrorM`+ validateInstanceVariance r allVariances Contravariant (SingleType t) <?? ("In filter " ++ show n ++ " " ++ show f) checkFilterVariance (n,f@(TypeFilter FilterAllows t)) =- validateInstanceVariance r allVariances Covariant (SingleType t) `reviseErrorM`+ validateInstanceVariance r allVariances Covariant (SingleType t) <?? ("In filter " ++ show n ++ " " ++ show f) checkFilterVariance (n,f@(DefinesFilter t)) =- validateDefinesVariance r allVariances Contravariant t `reviseErrorM`+ validateDefinesVariance r allVariances Contravariant t <?? ("In filter " ++ show n ++ " " ++ show f)- checkArg fa2 ta@(ValueType _ t) = flip reviseErrorM ("In argument " ++ show ta) $ do+ checkArg fa2 ta@(ValueType _ t) = ("In argument " ++ show ta) ??> do when (isWeakValue ta) $ compileErrorM "Weak values not allowed as argument types" validateGeneralInstance r fa2 t validateInstanceVariance r allVariances Contravariant t- checkReturn fa2 ta@(ValueType _ t) = flip reviseErrorM ("In return " ++ show ta) $ do+ checkReturn fa2 ta@(ValueType _ t) = ("In return " ++ show ta) ??> do when (isWeakValue ta) $ compileErrorM "Weak values not allowed as return types" validateGeneralInstance r fa2 t validateInstanceVariance r allVariances Covariant t
src/Types/TypeCategory.hs view
@@ -79,7 +79,8 @@ ) where import Control.Arrow (second)-import Control.Monad ((>=>),when)+import Control.Monad (when)+import Data.Functor.Identity (runIdentity) import Data.List (group,groupBy,intercalate,sort,sortBy) import qualified Data.Map as Map import qualified Data.Set as Set@@ -588,13 +589,13 @@ " times in " ++ show n ++ formatFullContextBrace c checkCount _ = return () checkRefine r vm (ValueRefine c t) =- validateInstanceVariance r vm Covariant (SingleType $ JustTypeInstance t) `reviseErrorM`+ validateInstanceVariance r vm Covariant (SingleType $ JustTypeInstance t) <?? (show t ++ formatFullContextBrace c) checkDefine r vm (ValueDefine c t) =- validateDefinesVariance r vm Covariant t `reviseErrorM`+ validateDefinesVariance r vm Covariant t <?? (show t ++ formatFullContextBrace c) checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterRequires t)) =- flip reviseErrorM ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do+ ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) ??> do case n `Map.lookup` vs of Just Contravariant -> compileErrorM $ "Contravariant param " ++ show n ++ " cannot have a requires filter"@@ -602,7 +603,7 @@ _ -> return () validateInstanceVariance r vs Contravariant (SingleType t) checkFilterVariance r vs (ParamFilter c n f@(TypeFilter FilterAllows t)) =- flip reviseErrorM ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do+ ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) ??> do case n `Map.lookup` vs of Just Covariant -> compileErrorM $ "Covariant param " ++ show n ++ " cannot have an allows filter"@@ -610,7 +611,7 @@ _ -> return () validateInstanceVariance r vs Covariant (SingleType t) checkFilterVariance r vs (ParamFilter c n f@(DefinesFilter t)) =- flip reviseErrorM ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) $ do+ ("In filter " ++ show n ++ " " ++ show f ++ formatFullContextBrace c) ??> do case n `Map.lookup` vs of Just Contravariant -> compileErrorM $ "Contravariant param " ++ show n ++ " cannot have a defines filter"@@ -637,13 +638,13 @@ when (not $ n `Set.member` pa) $ compileErrorM $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist" checkRefine r fm (ValueRefine c t) =- validateTypeInstance r fm t `reviseErrorM`+ validateTypeInstance r fm t <?? (show t ++ formatFullContextBrace c) checkDefine r fm (ValueDefine c t) =- validateDefinesInstance r fm t `reviseErrorM`+ validateDefinesInstance r fm t <?? (show t ++ formatFullContextBrace c) checkFilter r fm (ParamFilter c n f) =- validateTypeFilter r fm f `reviseErrorM`+ validateTypeFilter r fm f <?? (show n ++ " " ++ show f ++ formatFullContextBrace c) validateCategoryFunction :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -651,7 +652,7 @@ validateCategoryFunction r t f = do let fm = getCategoryFilterMap t let vm = Map.fromList $ map (\p -> (vpParam p,vpVariance p)) $ getCategoryParams t- flip reviseErrorM ("In function:\n---\n" ++ show f ++ "\n---\n") $ do+ ("In function:\n---\n" ++ show f ++ "\n---\n") ??> do funcType <- parsedToFunctionType f case sfScope f of CategoryScope -> validatateFunctionType r Map.empty Map.empty funcType@@ -749,7 +750,7 @@ preMergeSingle _ t = return t update r t u = do (ts2,tm) <- u- t' <- updateSingle r tm t `reviseErrorM`+ t' <- updateSingle r tm t <?? ("In category " ++ show (getCategoryName t) ++ formatFullContextBrace (getCategoryContext t)) return (ts2 ++ [t'],Map.insert (getCategoryName t') t' tm)@@ -797,7 +798,7 @@ checkConvert r fm (Just ta1@(ValueRefine _ t1)) ta2@(ValueRefine _ t2) = do noInferredTypes $ checkGeneralMatch r fm Covariant (SingleType $ JustTypeInstance t1)- (SingleType $ JustTypeInstance t2) `reviseErrorM`+ (SingleType $ JustTypeInstance t2) <?? ("Cannot refine " ++ show ta1 ++ " from inherited " ++ show ta2) return () checkConvert _ _ _ _ = return ()@@ -818,18 +819,14 @@ let fs2 = getCategoryFunctions t paired <- processPairs alwaysPair (Positional ps) ts2 let assigned = Map.fromList paired- mapErrorsM (subFunction assigned) fs2+ mapErrorsM (unfixedSubFunction assigned) fs2 getDefinesFuncs tm2 (ValueDefine c (DefinesInstance n ts2)) = 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- mapErrorsM (subFunction assigned) fs2- -- uncheckedSubFunction fixes params so that subsequent substitutions of the- -- function's own params can't cause a name clash. unfixFunctionParams- -- un-fixes them so that actual substitution later will succeed.- subFunction as = uncheckedSubFunction as >=> return . unfixFunctionParams+ mapErrorsM (unfixedSubFunction assigned) fs2 mergeByName r2 fm2 im em n = tryMerge r2 fm2 n (n `Map.lookup` im) (n `Map.lookup` em) -- Inherited without an override.@@ -856,8 +853,8 @@ show (sfScope f1) ++ " in function merge:\n---\n" ++ show f2 ++ "\n ->\n" ++ show f1 | otherwise =- flip reviseErrorM ("In function merge:\n---\n" ++ show f2 ++- "\n ->\n" ++ show f1 ++ "\n---\n") $ do+ ("In function merge:\n---\n" ++ show f2 +++ "\n ->\n" ++ show f1 ++ "\n---\n") ??> do f1' <- parsedToFunctionType f1 f2' <- parsedToFunctionType f2 checkFunctionConvert r3 fm3 pm f2' f1'@@ -947,12 +944,17 @@ (Just fs) -> fs _ -> [] + uncheckedSubFunction :: (Show c, MergeableM m, CompileErrorM m) => ParamValues -> ScopedFunction c -> m (ScopedFunction c)-uncheckedSubFunction pa ff@(ScopedFunction c n t s as rs ps fa ms) =- flip reviseErrorM ("In function:\n---\n" ++ show ff ++ "\n---\n") $ do+uncheckedSubFunction = unfixedSubFunction . fmap fixTypeParams++unfixedSubFunction :: (Show c, MergeableM m, CompileErrorM m) =>+ ParamValues -> ScopedFunction c -> m (ScopedFunction c)+unfixedSubFunction pa ff@(ScopedFunction c n t s as rs ps fa ms) =+ ("In function:\n---\n" ++ show ff ++ "\n---\n") ??> do let unresolved = Map.fromList $ map (\n2 -> (n2,SingleType $ JustParamName False n2)) $ map vpParam $ pValues ps- let pa' = (fmap fixTypeParams pa) `Map.union` unresolved+ let pa' = pa `Map.union` unresolved as' <- fmap Positional $ mapErrorsM (subPassed pa') $ pValues as rs' <- fmap Positional $ mapErrorsM (subPassed pa') $ pValues rs fa' <- mapErrorsM (subFilter pa') fa@@ -966,24 +968,6 @@ f' <- uncheckedSubFilter (getValueForParam pa2) f return $ ParamFilter c2 n2 f' -unfixFunctionParams :: ScopedFunction c -> ScopedFunction c-unfixFunctionParams (ScopedFunction c n t s as rs ps fa ms) = updated where- updated = ScopedFunction c n t s as2 rs2 ps fa2 ms2- as2 = fmap unfixPassed as- rs2 = fmap unfixPassed rs- fa2 = map unfixFilter fa- ms2 = map unfixFunctionParams ms- unfixPassed (PassedValue c2 (ValueType r t2)) = PassedValue c2 (ValueType r (unfixTypeParams t2))- unfixFilter (ParamFilter c2 n2 (TypeFilter d (JustTypeInstance t2))) =- ParamFilter c2 n2 (TypeFilter d (JustTypeInstance (unfixInstance t2)))- unfixFilter (ParamFilter c2 n2 (TypeFilter d (JustParamName _ n3))) =- ParamFilter c2 n2 (TypeFilter d (JustParamName False n3))- unfixFilter (ParamFilter c2 n2 (DefinesFilter t2)) =- ParamFilter c2 n2 (DefinesFilter (unfixDefines t2))- unfixFilter f = f- unfixInstance (TypeInstance t2 ps2) = TypeInstance t2 (fmap unfixTypeParams ps2)- unfixDefines (DefinesInstance t2 ps2) = DefinesInstance t2 (fmap unfixTypeParams ps2)- inferParamTypes :: (MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> ParamFilters -> ParamValues -> [(ValueType,ValueType)] -> m (ParamValues)@@ -1015,28 +999,34 @@ | otherwise = [InferredTypeGuess p (SingleType t) Covariant] filterToGuess _ _ = [] +separateParamGuesses :: MergeableM m => MergeTree InferredTypeGuess ->+ m (Map.Map ParamName (MergeTree InferredTypeGuess))+separateParamGuesses = reduceMergeTree return return (return . toMap) where+ toMap i = Map.fromList [(itgParam i,mergeLeaf i)]+ mergeInferredTypes :: (MergeableM m, CompileErrorM m, TypeResolver r) => r -> ParamFilters -> MergeTree InferredTypeGuess -> m [InferredTypeGuess]-mergeInferredTypes r f = reduceMergeTree anyOp allOp leafOp where- leafOp i = noInferred i >> return [i]- anyOp = mergeCommon anyCheck- allOp = mergeCommon allCheck- mergeCommon check is = do- let ia = Map.fromListWith (++) $ zip (map itgParam is) (map (:[]) is)- mergeAllM $ map (tryMerge check) $ Map.toList ia- tryMerge check (i,is) = do- is' <- mergeObjects check is- case is' of- [] -> undefined -- Shouldn't happen.- [i2] -> return [i2]- is2 -> compileErrorM $ "Could not reconcile guesses for " ++ show i ++- ": " ++ show is2- noInferred (InferredTypeGuess n t _) =- when (hasInferredParams t) $- compileErrorM $ "Guess " ++ show t ++ " for parameter " ++ show n ++ " contains inferred types"- anyCheck (InferredTypeGuess _ g1 v1) (InferredTypeGuess _ g2 _) =- -- Find the least-general guess: If g1 can be replaced with g2, prefer g1.- noInferredTypes $ checkGeneralMatch r f v1 g1 g2- allCheck (InferredTypeGuess _ g1 _) (InferredTypeGuess _ g2 v2) =- -- Find the most-general guess: If g2 can be replaced with g1, prefer g1.- noInferredTypes $ checkGeneralMatch r f v2 g2 g1+mergeInferredTypes r f gs = do+ let gs' = runIdentity $ separateParamGuesses gs+ mapErrorsM reduce $ Map.toList gs' where+ reduce (i,is) = do+ is' <- reduceMergeTree anyOp allOp leafOp is+ let is2 = foldr (:) [] is'+ case is2 of+ [] -> undefined -- Shouldn't happen.+ [i2] -> return i2+ is3 -> compileErrorM $ "Could not reconcile guesses for " ++ show i ++ ": " ++ show is3+ leafOp i = noInferred i >> return [i]+ anyOp = mergeObjects anyCheck . sortBy lessGeneral+ allOp = mergeObjects allCheck . sortBy moreGeneral+ noInferred (InferredTypeGuess n t _) =+ when (hasInferredParams t) $+ compileErrorM $ "Guess " ++ show t ++ " for parameter " ++ show n ++ " contains inferred types"+ lessGeneral x y = itgVariance y `compare` itgVariance x+ moreGeneral x y = itgVariance x `compare` itgVariance y+ anyCheck (InferredTypeGuess _ g1 v1) (InferredTypeGuess _ g2 _) =+ -- Find the least-general guess: If g1 can be replaced with g2, prefer g1.+ noInferredTypes $ checkGeneralMatch r f v1 g1 g2+ allCheck (InferredTypeGuess _ g1 _) (InferredTypeGuess _ g2 v2) =+ -- Find the most-general guess: If g2 can be replaced with g1, prefer g1.+ noInferredTypes $ checkGeneralMatch r f v2 g2 g1
src/Types/TypeInstance.hs view
@@ -331,7 +331,7 @@ checkValueTypeMatch r f ts1@(ValueType r1 t1) ts2@(ValueType r2 t2) | r1 < r2 = compileErrorM $ "Cannot convert " ++ show ts1 ++ " to " ++ show ts2- | otherwise = checkGeneralMatch r f Covariant t1 t2 `reviseErrorM`+ | otherwise = checkGeneralMatch r f Covariant t1 t2 <?? ("Cannot convert " ++ show ts1 ++ " to " ++ show ts2) checkGeneralMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -403,7 +403,7 @@ checkParamToInstance r f Contravariant n1 t2] checkParamToInstance r f v@Contravariant n1 t2@(TypeInstance _ _) = do cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n1- mergeAnyM (map checkConstraintToInstance cs2) `reviseErrorM`+ mergeAnyM (map checkConstraintToInstance cs2) <?? ("No filters imply " ++ show t2 ++ " <- " ++ show n1 ++ " in " ++ show v ++ " contexts") where checkConstraintToInstance (TypeFilter FilterAllows t) =@@ -415,7 +415,7 @@ " does not imply " ++ show t2 ++ " <- " ++ show n1 checkParamToInstance r f v@Covariant n1 t2@(TypeInstance _ _) = do cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n1- mergeAnyM (map checkConstraintToInstance cs1) `reviseErrorM`+ mergeAnyM (map checkConstraintToInstance cs1) <?? ("No filters imply " ++ show n1 ++ " -> " ++ show t2 ++ " in " ++ show v ++ " contexts") where checkConstraintToInstance (TypeFilter FilterRequires t) =@@ -435,7 +435,7 @@ checkInstanceToParam r f Contravariant t1 n2] checkInstanceToParam r f v@Contravariant t1@(TypeInstance _ _) n2 = do cs1 <- fmap (filter isTypeFilter) $ f `filterLookup` n2- mergeAnyM (map checkInstanceToConstraint cs1) `reviseErrorM`+ mergeAnyM (map checkInstanceToConstraint cs1) <?? ("No filters imply " ++ show n2 ++ " <- " ++ show t1 ++ " in " ++ show v ++ " contexts") where checkInstanceToConstraint (TypeFilter FilterRequires t) =@@ -448,7 +448,7 @@ " does not imply " ++ show n2 ++ " <- " ++ show t1 checkInstanceToParam r f v@Covariant t1@(TypeInstance _ _) n2 = do cs2 <- fmap (filter isTypeFilter) $ f `filterLookup` n2- mergeAnyM (map checkInstanceToConstraint cs2) `reviseErrorM`+ mergeAnyM (map checkInstanceToConstraint cs2) <?? ("No filters imply " ++ show t1 ++ " -> " ++ show n2 ++ " in " ++ show v ++ " contexts") where checkInstanceToConstraint (TypeFilter FilterAllows t) =@@ -475,7 +475,7 @@ let typeFilters = [(c1,c2) | c1 <- cs1, c2 <- cs2] ++ [(self1,c2) | c2 <- cs2] ++ [(c1,self2) | c1 <- cs1]- mergeAnyM (map (\(c1,c2) -> checkConstraintToConstraint v c1 c2) typeFilters) `reviseErrorM`+ mergeAnyM (map (\(c1,c2) -> checkConstraintToConstraint v c1 c2) typeFilters) <?? ("No filters imply " ++ show n1 ++ " -> " ++ show n2) where selfParam1 = JustParamName False n1@@ -529,7 +529,7 @@ validateTypeInstance r f t@(TypeInstance _ ps) = do fa <- trTypeFilters r t processPairs_ (validateAssignment r f) ps fa- mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseErrorM`+ mergeAllM (map (validateGeneralInstance r f) (pValues ps)) <?? ("Recursive error in " ++ show t) validateDefinesInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -537,7 +537,7 @@ validateDefinesInstance r f t@(DefinesInstance _ ps) = do fa <- trDefinesFilters r t processPairs_ (validateAssignment r f) ps fa- mergeAllM (map (validateGeneralInstance r f) (pValues ps)) `reviseErrorM`+ mergeAllM (map (validateGeneralInstance r f) (pValues ps)) <?? ("Recursive error in " ++ show t) validateTypeFilter :: (MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -562,7 +562,7 @@ checkDefinesMatch r f f2 (DefinesInstance n2 ps1') checkDefinesFilter f2 (JustParamName _ n1) = do fs1 <- fmap (map dfType . filter isDefinesFilter) $ f `filterLookup` n1- mergeAnyM (map (checkDefinesMatch r f f2) fs1) `reviseErrorM`+ mergeAnyM (map (checkDefinesMatch r f f2) fs1) <?? ("No filters imply " ++ show n1 ++ " defines " ++ show f2) checkDefinesFilter _ t2 = compileErrorM $ "Type " ++ show t2 ++ " contains unresolved types"
src/Types/Variance.hs view
@@ -25,10 +25,12 @@ ) where +-- NOTE: The ordering here is used when prioritizing multiple constraints on an+-- inferred type. data Variance = Contravariant |- Invariant |- Covariant+ Covariant |+ Invariant deriving (Eq,Ord) instance Show Variance where
zeolite-lang.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: zeolite-lang-version: 0.7.0.1+version: 0.7.0.2 synopsis: Zeolite is a statically-typed, general-purpose programming language. description:@@ -28,20 +28,21 @@ zeolite-setup @ .- * (Optional) Once the setup above is completed, you should run the- integration tests to ensure that code can be compiled and run. These can- take quite a while to complete. Please create an+ * (Optional) As a sanity check, compile and run+ @<https://github.com/ta0kira/zeolite/tree/master/example/hello example/hello>@.+ Please create an <https://github.com/ta0kira/zeolite/issues issue on GitHub> if you encounter any errors. . @ ZEOLITE_PATH=$(zeolite --get-path)- zeolite -p "$ZEOLITE_PATH" -t tests lib\/file lib\/math lib\/util+ zeolite -p "$ZEOLITE_PATH" -f -i lib\/util -m HelloDemo example\/hello+ $ZEOLITE_PATH\/example\/hello\/HelloDemo @ . The <https://github.com/ta0kira/zeolite/tree/master/example code examples> are located in @$ZEOLITE_PATH/example@. You should not normally need to use- @$ZEOLITE_PATH@ outside of running included tests and examples.+ @$ZEOLITE_PATH@ outside of running the included tests and examples. homepage: https://github.com/ta0kira/zeolite license: Apache-2.0