zeolite-lang 0.7.0.0 → 0.7.0.1

raw patch · 20 files changed

+452/−177 lines, 20 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +16/−0
• src/Base/CompileError.hs +5/−0
• src/Base/CompileInfo.hs +48/−27
• src/Compilation/CompilerState.hs +4/−0
• src/Compilation/ProcedureContext.hs +8/−8
• src/Compilation/ScopeContext.hs +1/−1
• src/CompilerCxx/Category.hs +24/−29
• src/CompilerCxx/CategoryContext.hs +1/−1
• src/CompilerCxx/Procedure.hs +45/−30
• src/Parser/TypeInstance.hs +1/−1
• src/Test/CompileInfo.hs +20/−1
• src/Test/TypeCategory.hs +1/−1
• src/Test/TypeInstance.hs +1/−1
• src/Types/DefinedCategory.hs +5/−3
• src/Types/Function.hs +10/−11
• src/Types/TypeCategory.hs +60/−30
• src/Types/TypeInstance.hs +61/−31
• tests/inference.0rt +88/−1
• tests/regressions.0rt +52/−0
• zeolite-lang.cabal +1/−1

@@ -1,5 +1,21 @@ # Revision history for zeolite-lang +## 0.7.0.1  -- 2020-05-20++### Language++* **[fix]** Fixes an edge-case where type-inference can be influenced by a+  param filter for a param with the same name in the scope that is calling the+  function. (For example, having `#x requires Foo` in scope while calling a+  function that also happens to have a param named `#x`.)++* **[fix]** Fixes an edge-case where parameter substitution at the type level+  can clash with a type parameter scoped to a function. (Related to the above,+  but actually a separate issue discovered while solving the former.)++* **[behavior]** Shows inferred-type assignments in error messages related to+  expressions containing inferred types.+ ## 0.7.0.0  -- 2020-05-19  ### Language

@@ -49,6 +49,11 @@   reviseErrorM :: m a -> String -> m a   reviseErrorM e _ = e   compileWarningM :: String -> m ()+  compileWarningM _ = return ()+  compileBackgroundM :: String -> m ()+  compileBackgroundM _ = return ()+  resetBackgroundM :: m a -> m a+  resetBackgroundM = id  mapErrorsM :: CompileErrorM m => (a -> m b) -> [a] -> m [b] mapErrorsM f = collectAllOrErrorM . map f

@@ -139,6 +139,7 @@   } |   CompileSuccess {     csWarnings :: [String],+    csBackground :: [String],     csData :: a   } @@ -146,27 +147,30 @@   fmap f x = CompileInfoT $ do     x' <- citState x     case x' of-         CompileFail w e    -> return $ CompileFail w e -- Not the same a.-         CompileSuccess w d -> return $ CompileSuccess w (f d)+         CompileFail w e      -> return $ CompileFail w e -- Not the same a.+         CompileSuccess w b d -> return $ CompileSuccess w b (f d)  instance (Applicative m, Monad m) => Applicative (CompileInfoT m) where-  pure = CompileInfoT .return . CompileSuccess []+  pure = CompileInfoT .return . CompileSuccess [] []   f <*> x = CompileInfoT $ do     f' <- citState f     x' <- citState x     case (f',x') of-         (CompileFail w e,     _)                   -> return $ CompileFail w e -- Not the same a.-         (i,                   CompileFail w e)     -> return $ CompileFail (getWarnings i ++ w) e -- Not the same a.-         (CompileSuccess w1 f2,CompileSuccess w2 d) -> return $ CompileSuccess (w1 ++ w2) (f2 d)+         (CompileFail w e,_) ->+           return $ CompileFail w e -- Not the same a.+         (i,CompileFail w e) ->+           return $ CompileFail (getWarnings i ++ w) (addBackground (getBackground i) e)+         (CompileSuccess w1 b1 f2,CompileSuccess w2 b2 d) ->+           return $ CompileSuccess (w1 ++ w2) (b1 ++ b2) (f2 d)  instance Monad m => Monad (CompileInfoT m) where   x >>= f = CompileInfoT $ do     x' <- citState x     case x' of-         CompileFail w e    -> return $ CompileFail w e -- Not the same a.-         CompileSuccess w d -> do+         CompileFail w e -> return $ CompileFail w e -- Not the same a.+         CompileSuccess w b d -> do            d2 <- citState $ f d-           return $ prependWarning w d2+           return $ includeBackground b $ prependWarning w d2   return = pure  #if MIN_VERSION_base(4,9,0)@@ -175,7 +179,7 @@ #endif  instance MonadTrans CompileInfoT where-  lift = CompileInfoT . fmap (CompileSuccess [])+  lift = CompileInfoT . fmap (CompileSuccess [] [])  instance MonadIO m => MonadIO (CompileInfoT m) where   liftIO = lift . liftIO@@ -185,40 +189,57 @@   collectAllOrErrorM xs = CompileInfoT $ do     xs' <- sequence $ map citState $ foldr (:) [] xs     return $ result $ splitErrorsAndData xs' where-      result ([],xs2,ws) = CompileSuccess ws xs2-      result (es,_,ws)   = CompileFail ws $ CompileMessage "" es+      result ([],xs2,bs,ws) = CompileSuccess ws bs xs2+      result (es,_,bs,ws)   = CompileFail ws $ addBackground bs $ CompileMessage "" es   collectOneOrErrorM xs = CompileInfoT $ do     xs' <- sequence $ map citState $ foldr (:) [] xs     return $ result $ splitErrorsAndData xs' where-      result (_,x:_,ws) = CompileSuccess ws x-      result ([],_,ws)  = CompileFail ws $ CompileMessage "" []-      result (es,_,ws)  = CompileFail ws $ CompileMessage "" es+      result (_,x:_,bs,ws) = CompileSuccess ws bs x+      result ([],_,bs,ws)  = CompileFail ws $ addBackground bs $ CompileMessage "" []+      result (es,_,bs,ws)  = CompileFail ws $ addBackground bs $ CompileMessage "" es   reviseErrorM x e2 = CompileInfoT $ do     x' <- citState x     case x' of          CompileFail w (CompileMessage [] ms) -> return $ CompileFail w $ CompileMessage e2 ms          CompileFail w e                      -> return $ CompileFail w $ CompileMessage e2 [e]          x2                                   -> return x2-  compileWarningM w = CompileInfoT (return $ CompileSuccess [w] ())+  compileWarningM w = CompileInfoT (return $ CompileSuccess [w] [] ())+  compileBackgroundM b = CompileInfoT (return $ CompileSuccess [] [b] ())+  resetBackgroundM x = CompileInfoT $ do+    x' <- citState x+    case x' of+         CompileSuccess w _ d -> return $ CompileSuccess w [] d+         x2                   -> return x2  instance Monad m => MergeableM (CompileInfoT m) where   mergeAnyM xs = CompileInfoT $ do     xs' <- sequence $ map citState $ foldr (:) [] xs     return $ result $ splitErrorsAndData xs' where-      result ([],[],ws) = CompileFail ws $ CompileMessage "" []-      result (es,[],ws) = CompileFail ws $ CompileMessage "" es-      result (_,xs2,ws) = CompileSuccess ws (mergeAny xs2)+      result ([],[],bs,ws) = CompileFail ws $ addBackground bs $ CompileMessage "" []+      result (es,[],bs,ws) = CompileFail ws $ addBackground bs $ CompileMessage "" es+      result (_,xs2,bs,ws) = CompileSuccess ws bs (mergeAny xs2)   mergeAllM = collectAllOrErrorM >=> return . mergeAll  getWarnings :: CompileInfoState a -> [String]-getWarnings (CompileFail w _)    = w-getWarnings (CompileSuccess w _) = w+getWarnings (CompileFail w _)      = w+getWarnings (CompileSuccess w _ _) = w  prependWarning :: [String] -> CompileInfoState a -> CompileInfoState a-prependWarning w (CompileSuccess w2 d) = CompileSuccess (w ++ w2) d-prependWarning w (CompileFail w2 e)    = CompileFail (w ++ w2) e+prependWarning w (CompileSuccess w2 b d) = CompileSuccess (w ++ w2) b d+prependWarning w (CompileFail w2 e)      = CompileFail (w ++ w2) e -splitErrorsAndData :: Foldable f => f (CompileInfoState a) -> ([CompileMessage],[a],[String])-splitErrorsAndData = foldr partition ([],[],[]) where-  partition (CompileFail w e)    (es,ds,ws) = (e:es,ds,w++ws)-  partition (CompileSuccess w d) (es,ds,ws) = (es,d:ds,w++ws)+getBackground :: CompileInfoState a -> [String]+getBackground (CompileSuccess _ b _) = b+getBackground _                      = []++includeBackground :: [String] -> CompileInfoState a -> CompileInfoState a+includeBackground b  (CompileFail w e)       = CompileFail w (addBackground b e)+includeBackground b1 (CompileSuccess w b2 d) = CompileSuccess w (b1 ++ b2) d++addBackground :: [String] -> CompileMessage -> CompileMessage+addBackground b (CompileMessage e es) = CompileMessage e (es ++ map (flip CompileMessage []) b)++splitErrorsAndData :: Foldable f => f (CompileInfoState a) -> ([CompileMessage],[a],[String],[String])+splitErrorsAndData = foldr partition ([],[],[],[]) where+  partition (CompileFail w e)      (es,ds,bs,ws) = (e:es,ds,bs,w++ws)+  partition (CompileSuccess w b d) (es,ds,bs,ws) = (es,d:ds,b++bs,w++ws)

@@ -60,6 +60,7 @@   csUpdateAssigned,   csWrite,   getCleanContext,+  resetBackgroundStateT,   reviseErrorStateT,   runDataCompiler, ) where@@ -150,6 +151,9 @@  reviseErrorStateT :: (CompileErrorM m) => CompilerState a m b -> String -> CompilerState a m b reviseErrorStateT x s = mapStateT (`reviseErrorM` s) x++resetBackgroundStateT :: (CompileErrorM m) => CompilerState a m b -> CompilerState a m b+resetBackgroundStateT x = mapStateT resetBackgroundM x  csCurrentScope :: CompilerContext c m s a => CompilerState a m SymbolScope csCurrentScope = fmap ccCurrentScope get >>= lift

@@ -85,7 +85,7 @@   ccCurrentScope = return . pcScope   ccResolver = return . AnyTypeResolver . CategoryResolver . pcCategories   ccSameType ctx = return . (== same) where-    same = TypeInstance (pcType ctx) (fmap (SingleType . JustParamName . vpParam) $ pcExtParams ctx)+    same = TypeInstance (pcType ctx) (fmap (SingleType . JustParamName False . vpParam) $ pcExtParams ctx)   ccAllFilters = return . pcAllFilters   ccGetParamScope ctx p = do     case p `Map.lookup` pcParamScopes ctx of@@ -144,7 +144,7 @@     getFunction (Just ta@(TypeMerge MergeIntersect ts)) =       collectOneOrErrorM (map getFunction $ map Just ts) `reviseErrorM`         ("Function " ++ show n ++ " not available for type " ++ show ta ++ formatFullContextBrace c)-    getFunction (Just (SingleType (JustParamName p))) = do+    getFunction (Just (SingleType (JustParamName _ p))) = do       fa <- ccAllFilters ctx       fs <- case p `Map.lookup` fa of                 (Just fs) -> return fs@@ -156,23 +156,23 @@     getFunction (Just (SingleType (JustTypeInstance t2)))       -- Same category as the procedure itself.       | tiName t2 == pcType ctx =-        checkFunction (tiName t2) (fmap vpParam $ pcExtParams ctx) (tiParams t2) $ n `Map.lookup` pcFunctions ctx+        subAndCheckFunction (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 t2)         let params = Positional $ map vpParam $ getCategoryParams ca         let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca-        checkFunction (tiName t2) params (tiParams t2) $ n `Map.lookup` fa+        subAndCheckFunction (tiName t2) params (tiParams t2) $ n `Map.lookup` fa     getFunction Nothing = do-      let ps = fmap (SingleType . JustParamName . vpParam) $ pcExtParams ctx+      let ps = fmap (SingleType . JustParamName False . vpParam) $ pcExtParams ctx       getFunction (Just $ SingleType $ JustTypeInstance $ TypeInstance (pcType ctx) ps)     getFunction (Just t2) = compileErrorM $ "Type " ++ show t2 ++ " contains unresolved types"     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 t2) params (diParams t2) $ n `Map.lookup` fa-    checkFunction t2 ps1 ps2 (Just f) = do+      subAndCheckFunction (diName t2) params (diParams t2) $ n `Map.lookup` fa+    subAndCheckFunction t2 ps1 ps2 (Just f) = do       when (pcDisallowInit ctx && t2 == pcType ctx) $         compileErrorM $ "Function " ++ show n ++                        " disallowed during initialization" ++ formatFullContextBrace c@@ -183,7 +183,7 @@         ("In external function call at " ++ formatFullContext c)       let assigned = Map.fromList paired       uncheckedSubFunction assigned f-    checkFunction t2 _ _ _ =+    subAndCheckFunction t2 _ _ _ =       compileErrorM $ "Category " ++ show t2 ++                      " does not have a type or value function named " ++ show n ++                      formatFullContextBrace c

@@ -71,7 +71,7 @@   (_,t) <- getConcreteCategory ta (c,n)   let params = Positional $ getCategoryParams t   let params2 = Positional pi-  let typeInstance = TypeInstance n $ fmap (SingleType . JustParamName . vpParam) params+  let typeInstance = TypeInstance n $ fmap (SingleType . JustParamName False . vpParam) params   let filters = getCategoryFilters t   let filters2 = fi   let r = CategoryResolver ta

@@ -300,24 +300,36 @@   (_,t) <- getConcreteCategory ta (c,n)   let r = CategoryResolver ta   [cp,tp,vp] <- getProcedureScopes ta em dd-  cf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure cp-  tf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure tp-  vf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure vp+  let (cm,tm,vm) = partitionByScope dmScope ms+  let filters = getCategoryFilters t+  let filters2 = fi+  let allFilters = getFilterMap (getCategoryParams t ++ pi) $ filters ++ filters2   -- Functions explicitly declared externally.   let externalFuncs = Set.fromList $ map sfName $ filter ((== n) . sfType) $ getCategoryFunctions t   -- Functions explicitly declared internally.   let overrideFuncs = Map.fromList $ map (\f -> (sfName f,f)) fs   -- Functions only declared internally.   let internalFuncs = Map.filter (not . (`Set.member` externalFuncs) . sfName) overrideFuncs-  let (cm,tm,vm) = partitionByScope dmScope ms+  let fe = Map.elems internalFuncs+  let allFuncs = getCategoryFunctions t ++ fe+  cf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure cp+  ce <- mergeAllM [+      categoryConstructor t cm,+      categoryDispatch allFuncs,+      return $ mergeAll $ map fst cf,+      mergeAllM $ map (createMemberLazy r allFilters) cm+    ]+  tf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure tp   disallowTypeMembers tm+  te <- mergeAllM [+      typeConstructor t tm,+      typeDispatch allFuncs,+      return $ mergeAll $ map fst tf,+      mergeAllM $ map (createMember r allFilters) tm+    ]+  vf <- collectAllOrErrorM $ applyProcedureScope compileExecutableProcedure vp   let internalCount = length pi   let memberCount = length vm-  let fe = Map.elems internalFuncs-  let allFuncs = getCategoryFunctions t ++ fe-  let filters = getCategoryFilters t-  let filters2 = fi-  let allFilters = getFilterMap (getCategoryParams t ++ pi) $ filters ++ filters2   top <- mergeAllM [       return $ onlyCode $ "class " ++ valueName n ++ ";",       declareInternalValue n internalCount memberCount@@ -338,18 +350,6 @@       return $ defineValue,       defineInternalValue n internalCount memberCount     ] ++ map (return . snd) (cf ++ tf ++ vf)-  ce <- mergeAllM [-      categoryConstructor t cm,-      categoryDispatch allFuncs,-      return $ mergeAll $ map fst cf,-      mergeAllM $ map (createMemberLazy r allFilters) cm-    ]-  te <- mergeAllM [-      typeConstructor t tm,-      typeDispatch allFuncs,-      return $ mergeAll $ map fst tf,-      mergeAllM $ map (createMember r allFilters) tm-    ]   commonDefineAll t ns rs top bottom ce te fe   where     disallowTypeMembers :: (Show c, CompileErrorM m, MergeableM m) =>@@ -388,7 +388,7 @@       let initPassed = map (\(i,p) -> paramName p ++ "(*std::get<" ++ show i ++ ">(params))") $ zip ([0..] :: [Int]) ps2       let allInit = intercalate ", " $ initParent:initPassed       ctx <- getContextForInit ta em t dd TypeScope-      initMembers <- runDataCompiler (sequence $ map initMember ms2) ctx+      initMembers <- runDataCompiler (sequence $ map compileRegularInit ms2) ctx       mergeAllM [           return $ onlyCode $ typeName n ++ "(" ++ allArgs ++ ") : " ++ allInit ++ " {",           return $ indentCompiled $ onlyCodes $ getCycleCheck (typeName n),@@ -415,11 +415,6 @@       validateGeneralInstance r filters (vtType $ dmType m) `reviseErrorM`         ("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 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 fs2 =       return $ onlyCodes $ [           "ReturnTuple Dispatch(" ++@@ -637,7 +632,7 @@           "const TypeCategory& category, " ++           "std::vector<const TypeInstance*>& args) const final {"         ] ++ allCats rs2 ++ ["  return false;","}"]-    myType = (getCategoryName t,map (SingleType . JustParamName . fst) params)+    myType = (getCategoryName t,map (SingleType . JustParamName False . fst) params)     refines rs2 = map (\r -> (tiName r,pValues $ tiParams r)) $ map vrType rs2     allCats rs2 = concat $ map singleCat (myType:refines rs2)     singleCat (t2,ps) = [@@ -663,7 +658,7 @@   typeGetter t ++ "(T_get(" ++ intercalate "," (map ("&" ++) ps') ++ "))"   where     ps' = map expandLocalType $ pValues ps-expandLocalType (SingleType (JustParamName p)) = paramName p+expandLocalType (SingleType (JustParamName _ p)) = paramName p expandLocalType _ = undefined  -- The instance is an InferredType.  defineCategoryName :: CategoryName -> CompiledData [String]

@@ -55,7 +55,7 @@   let sa = Map.fromList $ zip (map vpParam $ getCategoryParams t) (repeat TypeScope)   let r = CategoryResolver tm   fa <- setInternalFunctions r t (dcFunctions d)-  let typeInstance = TypeInstance (getCategoryName t) $ fmap (SingleType . JustParamName . vpParam) ps+  let typeInstance = TypeInstance (getCategoryName t) $ fmap (SingleType . JustParamName False . vpParam) ps   let builtin = Map.filter ((== LocalScope) . vvScope) $ builtinVariables typeInstance   members <- mapMembers $ filter ((<= s) . dmScope) (dcMembers d)   return $ ProcedureContext {

@@ -27,9 +27,8 @@   categoriesFromRefine,   compileExecutableProcedure,   compileMainProcedure,-  compileExpression,   compileLazyInit,-  compileStatement,+  compileRegularInit, ) where  import Control.Applicative ((<|>))@@ -138,7 +137,7 @@                      CompilerContext c m [String] a) =>   a -> [c] -> Expression c -> CompilerState a m String compileCondition ctx c e = do-  (e',ctx') <- lift $ runStateT compile ctx+  (e',ctx') <- resetBackgroundStateT $ lift $ runStateT compile ctx   lift (ccGetRequired ctx') >>= csRequiresTypes   noTrace <- csGetNoTrace   if noTrace@@ -160,8 +159,12 @@                      CompilerContext c m [String] a) =>   a -> Procedure c -> CompilerState a m a compileProcedure ctx (Procedure _ ss) = do-  ctx' <- lift $ execStateT (sequence $ map (\s -> warnUnreachable s >> compileStatement s) ss) ctx+  ctx' <- lift $ execStateT (sequence $ map compileOne ss) ctx   return ctx' where+    compileOne s = do+      warnUnreachable s+      s' <- resetBackgroundStateT $ compileStatement s+      return s'     warnUnreachable s = do       unreachable <- csIsUnreachable       lift $ when unreachable $@@ -233,19 +236,18 @@   (_,e') <- compileExpression e   maybeSetTrace c   csWrite ["(void) (" ++ useAsWhatever e' ++ ");"]-compileStatement (Assignment c as e) = do+compileStatement (Assignment c as e) = flip reviseErrorStateT message $ do   (ts,e') <- compileExpression e   r <- csResolver   fa <- csAllFilters   -- Check for a count match first, to avoid the default error message.-  _ <- processPairsT alwaysPair (fmap assignableName as) ts `reviseErrorStateT`-    ("In assignment at " ++ formatFullContext c)-  _ <- processPairsT (createVariable r fa) as ts `reviseErrorStateT`-    ("In assignment at " ++ formatFullContext c)+  _ <- processPairsT alwaysPair (fmap assignableName as) ts+  _ <- processPairsT (createVariable r fa) as ts   maybeSetTrace c   variableTypes <- sequence $ map (uncurry getVariableType) $ zip (pValues as) (pValues ts)   assignAll (zip3 ([0..] :: [Int]) variableTypes (pValues as)) e'   where+    message = "In assignment at " ++ formatFullContext c     assignAll [v] e2 = assignSingle v e2     assignAll vs e2 = do       csWrite ["{","const auto r = " ++ useAsReturns e2 ++ ";"]@@ -256,21 +258,21 @@       (VariableValue _ _ t _) <- csGetVariable c2 n       return t     getVariableType (ExistingVariable (DiscardInput _)) t = return t-    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] `reviseErrorM`-        ("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 c2 n)) t2 = do-      (VariableValue _ _ t1 w) <- csGetVariable c2 n-      when (not w) $ lift $ compileErrorM $ "Cannot assign to read-only variable " ++-                                           show n ++ formatFullContextBrace c2-      -- TODO: Also show original context.-      lift $ (checkValueTypeMatch_ r fa t2 t1) `reviseErrorM`-        ("In assignment to " ++ show n ++ " at " ++ formatFullContext c2)-      csUpdateAssigned n+    createVariable r fa (CreateVariable c2 t1 n) t2 =+      flip reviseErrorStateT ("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+        (VariableValue _ _ t1 w) <- csGetVariable c2 n+        when (not w) $ lift $ compileErrorM $ "Cannot assign to read-only variable " +++                                              show n ++ formatFullContextBrace c2+        -- TODO: Also show original context.+        lift $ (checkValueTypeMatch_ r fa t2 t1)+        csUpdateAssigned n     createVariable _ _ _ _ = return ()     assignSingle (_,t,CreateVariable _ _ n) e2 =       csWrite [variableName n ++ " = " ++ writeStoredVariable t e2 ++ ";"]@@ -290,11 +292,20 @@     assignMulti _ = return () compileStatement (NoValueExpression _ v) = compileVoidExpression v +compileRegularInit :: (Show c, CompileErrorM m, MergeableM m,+                       CompilerContext c m [String] a) =>+  DefinedMember c -> CompilerState a m ()+compileRegularInit (DefinedMember _ _ _ _ Nothing) = return mergeDefault+compileRegularInit (DefinedMember c2 s t n2 (Just e)) = resetBackgroundStateT $ do+  csAddVariable c2 n2 (VariableValue c2 s t True)+  let assign = Assignment c2 (Positional [ExistingVariable (InputValue c2 n2)]) e+  compileStatement assign+ compileLazyInit :: (Show c, CompileErrorM m, MergeableM m,                    CompilerContext c m [String] a) =>   DefinedMember c -> CompilerState a m () compileLazyInit (DefinedMember _ _ _ _ Nothing) = return mergeDefault-compileLazyInit (DefinedMember c _ t1 n (Just e)) = do+compileLazyInit (DefinedMember c _ t1 n (Just e)) = resetBackgroundStateT $ do   (ts,e') <- compileExpression e   when (length (pValues ts) /= 1) $     lift $ compileErrorM $ "Expected single return in initializer" ++ formatFullContextBrace (getExpressionContext e)@@ -804,8 +815,9 @@   es' <- sequence $ map compileExpression $ pValues es   (ts,es'') <- getValues es'   ps2 <- lift $ guessParamsFromArgs r fa f ps (Positional ts)+  lift $ mergeAllM $ map backgroundMessage $ zip3 (map vpParam $ pValues $ sfParams f) (pValues ps) (pValues ps2)   f' <- lift $ parsedToFunctionType f-  f'' <- lift $ assignFunctionParams r fa ps2 f'+  f'' <- lift $ assignFunctionParams r fa Map.empty ps2 f'   -- Called an extra time so arg count mismatches have reasonable errors.   lift $ processPairs_ (\_ _ -> return ()) (ftArgs f'') (Positional ts)   lift $ processPairs_ (checkArg r fa) (ftArgs f'') (Positional $ zip ([0..] :: [Int]) ts)@@ -817,6 +829,10 @@   return $ (ftReturns f'',OpaqueMulti call)   where     errorContext = "In call to " ++ show (sfName f) ++ " at " ++ formatFullContext c+    backgroundMessage (n,(InferredInstance c2),t) =+      compileBackgroundM $ "Parameter " ++ show n ++ " (from " ++ show (sfType f) ++ "." +++        show (sfName f) ++ ") inferred as " ++ show t ++ " at " ++ formatFullContext c2+    backgroundMessage _ = return ()     assemble Nothing _ ValueScope ps2 es2 =       return $ callName (sfName f) ++ "(Var_self, " ++ ps2 ++ ", " ++ es2 ++ ")"     assemble Nothing scoped _ ps2 es2 =@@ -843,11 +859,10 @@   r -> ParamFilters -> ScopedFunction c -> Positional (InstanceOrInferred c) ->   Positional ValueType -> m (Positional GeneralInstance) guessParamsFromArgs r fa f ps ts = do-  let fa2 = fa `Map.union` getFunctionFilterMap f+  let ff = getFunctionFilterMap f   args <- processPairs alwaysPair ts (fmap pvType $ sfArgs f)   pa <- fmap Map.fromList $ processPairs toInstance (fmap vpParam $ sfParams f) ps-  let pa2 = pa `Map.union` (Map.fromList $ zip (Map.keys fa2) (map (SingleType . JustParamName) $ Map.keys fa2))-  pa3 <- inferParamTypes r fa2 pa2 args+  pa3 <- inferParamTypes r fa ff pa args   fmap Positional $ mapErrorsM (subPosition pa3) (pValues $ sfParams f) where     subPosition pa2 p =       case (vpParam p) `Map.lookup` pa2 of@@ -920,7 +935,7 @@ expandGeneralInstance (SingleType (JustTypeInstance (TypeInstance t ps))) = do   ps' <- sequence $ map expandGeneralInstance $ pValues ps   return $ typeGetter t ++ "(T_get(" ++ intercalate "," (map ("&" ++) ps') ++ "))"-expandGeneralInstance (SingleType (JustParamName p)) = do+expandGeneralInstance (SingleType (JustParamName _ p)) = do   s <- csGetParamScope p   scoped <- autoScope s   return $ scoped ++ paramName p

@@ -116,7 +116,7 @@   sourceParser = try param <|> inst where     param = labeled "param" $ do       n <- sourceParser-      return $ JustParamName n+      return $ JustParamName False n     inst = labeled "type" $ do       t <- sourceParser       return $ JustTypeInstance t

@@ -53,7 +53,26 @@      checkSuccess ['a','b']  (sequence [return 'a',return 'b']),     checkSuccess []         (sequence [] :: CompileInfoIO [Char]),-    checkError   "error1\n" (sequence [compileErrorM "error1",return 'b',compileErrorM "error2"])+    checkError   "error1\n" (sequence [compileErrorM "error1",return 'b',compileErrorM "error2"]),++    checkSuccess 'a' (return 'a' `reviseErrorM` "message"),+    checkError "message\n  error\n" (compileErrorM "error" `reviseErrorM` "message" :: CompileInfoIO ()),++    checkSuccess 'a' (compileBackgroundM "background" >> return 'a'),+    checkError "error\n  background\n"+      (compileBackgroundM "background" >> compileErrorM "error" :: CompileInfoIO ()),+    checkError "error\n  background\n"+      (collectAllOrErrorM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO [()]),+    checkError "error\n  background\n"+      (collectOneOrErrorM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO ()),+    checkError "error\n  background\n"+      (mergeAllM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO ()),+    checkError "error\n  background\n"+      (mergeAnyM [compileBackgroundM "background"] >> compileErrorM "error" :: CompileInfoIO ()),++    checkSuccess 'a' ((resetBackgroundM $ compileBackgroundM "background") >> return 'a'),+    checkError "error\n"+      ((resetBackgroundM $ compileBackgroundM "background") >> compileErrorM "error" :: CompileInfoIO ())   ]  checkSuccess :: (Eq a, Show a) => a -> CompileInfoIO a -> IO (CompileInfo ())

@@ -1148,7 +1148,7 @@   weakLookup tm2 n =     case n `Map.lookup` tm2 of          Just t  -> return t-         Nothing -> return $ SingleType $ JustParamName n+         Nothing -> return $ SingleType $ JustParamName True n   filterSub im (k,fs) = do     fs' <- mapErrorsM (uncheckedSubFilter (weakLookup im)) fs     return (k,fs')

@@ -802,7 +802,7 @@   weakLookup tm n =     case n `Map.lookup` tm of          Just t  -> return t-         Nothing -> return $ SingleType $ JustParamName n+         Nothing -> return $ SingleType $ JustParamName True n   filterSub im (k,fs) = do     fs' <- mapErrorsM (uncheckedSubFilter (weakLookup im)) fs     return (k,fs')

@@ -83,7 +83,8 @@   m (Map.Map FunctionName (ScopedFunction c)) setInternalFunctions r t fs = foldr update (return start) fs where   start = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions t-  filters = getCategoryFilterMap t+  fm = getCategoryFilterMap t+  pm = getCategoryParamMap t   update f@(ScopedFunction c n t2 s as rs ps fs2 ms) fa = do     validateCategoryFunction r t f     fa' <- fa@@ -94,7 +95,7 @@                              "\n  ->\n" ++ show f ++ "\n---\n") $ do              f0' <- parsedToFunctionType f0              f' <- parsedToFunctionType f-             checkFunctionConvert r filters f0' 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) =>@@ -170,11 +171,12 @@   let tm' = Map.insert (dcName d) c2 tm   let r = CategoryResolver tm'   let fm = getCategoryFilterMap t+  let pm = getCategoryParamMap t   rs' <- mergeRefines r fm (rs++rs2)   noDuplicateRefines [] n rs'   ds' <- mergeDefines r fm (ds++ds2)   noDuplicateDefines [] n ds'-  fs' <- mergeFunctions r tm' fm rs' ds' fs+  fs' <- mergeFunctions r tm' pm fm rs' ds' fs   let c2' = ValueConcrete c ns n ps rs' ds' vs fs'   let tm0 = (dcName d) `Map.delete` tm   checkCategoryInstances tm0 [c2']

@@ -96,35 +96,34 @@       validateInstanceVariance r allVariances Covariant t  assignFunctionParams :: (MergeableM m, CompileErrorM m, TypeResolver r) =>-  r -> ParamFilters -> Positional GeneralInstance ->+  r -> ParamFilters -> ParamValues -> Positional GeneralInstance ->   FunctionType -> m FunctionType-assignFunctionParams r fm ts (FunctionType as rs ps fa) = do+assignFunctionParams r fm pm 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 $ mapErrorsM (assignFilters allAssigned) (pValues fa)+  let pa = pm `Map.union` assigned+  fa' <- fmap Positional $ mapErrorsM (assignFilters pa) (pValues fa)   processPairs_ (validateAssignment r fm) ts fa'   as' <- fmap Positional $-         mapErrorsM (uncheckedSubValueType $ getValueForParam allAssigned) (pValues as)+         mapErrorsM (uncheckedSubValueType $ getValueForParam pa) (pValues as)   rs' <- fmap Positional $-         mapErrorsM (uncheckedSubValueType $ getValueForParam allAssigned) (pValues rs)+         mapErrorsM (uncheckedSubValueType $ getValueForParam pa) (pValues rs)   return $ FunctionType as' rs' (Positional []) (Positional [])   where     assignFilters fm2 fs = mapErrorsM (uncheckedSubFilter $ getValueForParam fm2) fs  checkFunctionConvert :: (MergeableM m, CompileErrorM m, TypeResolver r) =>-  r -> ParamFilters -> FunctionType -> FunctionType -> m ()-checkFunctionConvert r fm (FunctionType as1 rs1 ps1 fa1) ff2 = do+  r -> ParamFilters -> ParamValues -> FunctionType -> FunctionType -> m ()+checkFunctionConvert r fm pm (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+  let asTypes = Positional $ map (SingleType . JustParamName False) $ pValues ps1   -- Substitute params from ff2 into ff1.-  (FunctionType as2 rs2 _ _) <- assignFunctionParams r fm' asTypes ff2+  (FunctionType as2 rs2 _ _) <- assignFunctionParams r fm' pm 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-  return ()   where     validateArg fm2 a1 a2 = checkValueTypeMatch r fm2 a1 a2     validateReturn fm2 r1 r2 = checkValueTypeMatch r fm2 r2 r1

@@ -48,6 +48,7 @@   getCategoryFunctions,   getCategoryName,   getCategoryNamespace,+  getCategoryParamMap,   getCategoryParams,   getCategoryRefines,   getConcreteCategory,@@ -78,7 +79,7 @@ ) where  import Control.Arrow (second)-import Control.Monad (when)+import Control.Monad ((>=>),when) import Data.List (group,groupBy,intercalate,sort,sortBy) import qualified Data.Map as Map import qualified Data.Set as Set@@ -393,7 +394,7 @@             _ -> return []  subAllParams :: (MergeableM m, CompileErrorM m) =>-  Map.Map ParamName GeneralInstance -> GeneralInstance -> m GeneralInstance+  ParamValues -> GeneralInstance -> m GeneralInstance subAllParams pa = uncheckedSubInstance (getValueForParam pa)  type CategoryMap c = Map.Map CategoryName (AnyCategory c)@@ -470,6 +471,10 @@ getCategoryFilterMap :: AnyCategory c -> ParamFilters getCategoryFilterMap t = getFilterMap (getCategoryParams t) (getCategoryFilters t) +getCategoryParamMap :: AnyCategory c -> ParamValues+getCategoryParamMap t = let ps = map vpParam $ getCategoryParams t in+                          Map.fromList $ zip ps (map (SingleType . JustParamName False) ps)+ -- TODO: Use this where it's needed in this file. getFunctionFilterMap :: ScopedFunction c -> ParamFilters getFunctionFilterMap f = getFilterMap (pValues $ sfParams f) (sfFilters f)@@ -750,16 +755,18 @@       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+      let pm = getCategoryParamMap t       rs' <- fmap concat $ mapErrorsM (getRefines tm) rs       rs'' <- mergeRefines r fm rs'       noDuplicateRefines c n rs''       checkMerged r fm rs rs''       -- Only merge from direct parents.-      fs' <- mergeFunctions r tm fm rs [] fs+      fs' <- mergeFunctions r tm pm fm rs [] fs       return $ ValueInterface c ns n ps rs'' vs fs'     -- TODO: Remove duplication below and/or have separate tests.     updateSingle r tm t@(ValueConcrete c ns n ps rs ds vs fs) = do       let fm = getCategoryFilterMap t+      let pm = getCategoryParamMap t       rs' <- fmap concat $ mapErrorsM (getRefines tm) rs       rs'' <- mergeRefines r fm rs'       noDuplicateRefines c n rs''@@ -767,7 +774,7 @@       ds' <- mergeDefines r fm ds       noDuplicateDefines c n ds'       -- Only merge from direct parents.-      fs' <- mergeFunctions r tm fm rs ds fs+      fs' <- mergeFunctions r tm pm 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 _)) = do@@ -796,29 +803,33 @@     checkConvert _ _ _ _ = return ()  mergeFunctions :: (Show c, MergeableM m, CompileErrorM m, TypeResolver r) =>-  r -> CategoryMap c -> ParamFilters -> [ValueRefine c] ->+  r -> CategoryMap c -> ParamValues -> ParamFilters -> [ValueRefine c] ->   [ValueDefine c] -> [ScopedFunction c] -> m [ScopedFunction c]-mergeFunctions r tm fm rs ds fs = do+mergeFunctions r tm pm fm rs ds fs = do   inheritValue <- fmap concat $ mapErrorsM (getRefinesFuncs tm) rs   inheritType  <- fmap concat $ mapErrorsM (getDefinesFuncs tm) ds   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)   mapErrorsM (mergeByName r fm inheritByName explicitByName) allNames where-    getRefinesFuncs tm2 ra@(ValueRefine c (TypeInstance n ts2)) = flip reviseErrorM (show ra) $ do+    getRefinesFuncs tm2 (ValueRefine c (TypeInstance n ts2)) = 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-      mapErrorsM (uncheckedSubFunction assigned) fs2-    getDefinesFuncs tm2 da@(ValueDefine c (DefinesInstance n ts2)) = flip reviseErrorM (show da) $  do+      mapErrorsM (subFunction 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 (uncheckedSubFunction assigned) fs2+      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     mergeByName r2 fm2 im em n =       tryMerge r2 fm2 n (n `Map.lookup` im) (n `Map.lookup` em)     -- Inherited without an override.@@ -849,7 +860,7 @@                                 "\n  ->\n" ++ show f1 ++ "\n---\n") $ do                 f1' <- parsedToFunctionType f1                 f2' <- parsedToFunctionType f2-                checkFunctionConvert r3 fm3 f2' f1'+                checkFunctionConvert r3 fm3 pm f2' f1'  data FunctionName =   FunctionName {@@ -937,11 +948,11 @@            _ -> []  uncheckedSubFunction :: (Show c, MergeableM m, CompileErrorM m) =>-  Map.Map ParamName GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)+  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-    let fixed = Map.fromList $ map (\n2 -> (n2,SingleType $ JustParamName n2)) $ map vpParam $ pValues ps-    let pa' = Map.union pa fixed+    let unresolved = Map.fromList $ map (\n2 -> (n2,SingleType $ JustParamName False n2)) $ map vpParam $ pValues ps+    let pa' = (fmap fixTypeParams 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@@ -955,16 +966,34 @@         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 -> Map.Map ParamName GeneralInstance ->-  [(ValueType,ValueType)] -> m (Map.Map ParamName GeneralInstance)-inferParamTypes r f ps ts = do+  r -> ParamFilters -> ParamFilters -> ParamValues ->+  [(ValueType,ValueType)] -> m (ParamValues)+inferParamTypes r f ff ps ts = do   ts2 <- mapErrorsM subAll ts-  f2  <- fmap Map.fromList $ mapErrorsM filterSub $ Map.toList f-  gs  <- mergeAllM $ map (uncurry $ checkValueTypeMatch r f2) ts2-  let gs2 = concat $ map (filtersToGuess f2) $ Map.elems ps+  ff2 <- fmap Map.fromList $ mapErrorsM filterSub $ Map.toList ff+  gs  <- mergeAllM $ map (uncurry $ checkValueTypeMatch r f) ts2+  let gs2 = concat $ map (filtersToGuess ff2) $ Map.elems ps   let gs3 = mergeAll $ gs:(map mergeLeaf gs2)-  gs4 <- mergeInferredTypes r f2 gs3+  gs4 <- mergeInferredTypes r f gs3   let ga = Map.fromList $ zip (map itgParam gs4) (map itgGuess gs4)   return $ ga `Map.union` ps where     subAll (t1,t2) = do@@ -978,16 +1007,18 @@            Nothing -> []            Just fs -> concat $ map (filterToGuess p) fs     filtersToGuess _ _ = []-    filterToGuess p (TypeFilter FilterRequires t) =-      [InferredTypeGuess p (SingleType t) Contravariant]-    filterToGuess p (TypeFilter FilterAllows t) =-      [InferredTypeGuess p (SingleType t) Covariant]+    filterToGuess p (TypeFilter FilterRequires t)+      | hasInferredParams (SingleType t) = []+      | otherwise = [InferredTypeGuess p (SingleType t) Contravariant]+    filterToGuess p (TypeFilter FilterAllows t)+      | hasInferredParams (SingleType t) = []+      | otherwise = [InferredTypeGuess p (SingleType t) Covariant]     filterToGuess _ _ = []  mergeInferredTypes :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> MergeTree InferredTypeGuess -> m [InferredTypeGuess] mergeInferredTypes r f = reduceMergeTree anyOp allOp leafOp where-  leafOp i = noInferred (itgGuess i) >> return [i]+  leafOp i = noInferred i >> return [i]   anyOp = mergeCommon anyCheck   allOp = mergeCommon allCheck   mergeCommon check is = do@@ -1000,10 +1031,9 @@          [i2] -> return [i2]          is2  -> compileErrorM $ "Could not reconcile guesses for " ++ show i ++                                  ": " ++ show is2-  noInferred (TypeMerge _ ts) = mergeAllM $ map noInferred ts-  noInferred (SingleType (JustTypeInstance (TypeInstance _ (Positional ts)))) = mergeAllM $ map noInferred ts-  noInferred (SingleType (JustInferredType i)) = compileErrorM $ "Failed to infer " ++ show i-  noInferred _ = return ()+  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

@@ -31,6 +31,7 @@   InstanceParams,   InstanceVariances,   ParamFilters,+  ParamValues,   ParamVariances,   ParamName(..),   StorageType(..),@@ -43,11 +44,9 @@   checkGeneralMatch,   checkValueTypeMatch,   checkValueTypeMatch_,-  uncheckedSubFilter,-  uncheckedSubFilters,-  uncheckedSubInstance,-  uncheckedSubValueType,+  fixTypeParams,   getValueForParam,+  hasInferredParams,   isBuiltinCategory,   isDefinesFilter,   isRequiresFilter,@@ -55,6 +54,11 @@   noInferredTypes,   requiredParam,   requiredSingleton,+  uncheckedSubFilter,+  uncheckedSubFilters,+  uncheckedSubInstance,+  uncheckedSubValueType,+  unfixTypeParams,   validateAssignment,   validateDefinesInstance,   validateDefinesVariance,@@ -110,7 +114,7 @@ requiredSingleton n = ValueType RequiredValue $ SingleType $ JustTypeInstance $ TypeInstance n (Positional [])  requiredParam :: ParamName -> ValueType-requiredParam n = ValueType RequiredValue $ SingleType $ JustParamName n+requiredParam n = ValueType RequiredValue $ SingleType $ JustParamName False n  data CategoryName =   CategoryName {@@ -192,6 +196,7 @@     jtiType :: TypeInstance   } |   JustParamName {+    jpnFixed :: Bool,     jpnName :: ParamName   } |   JustInferredType {@@ -200,9 +205,10 @@   deriving (Eq,Ord)  instance Show TypeInstanceOrParam where-  show (JustTypeInstance t) = show t-  show (JustParamName n)    = show n-  show (JustInferredType i) = show i ++ " /*inferred*/"+  show (JustTypeInstance t)   = show t+  show (JustParamName True n) = show n ++ "/*fixed*/"+  show (JustParamName _ n)    = show n+  show (JustInferredType n)   = show n ++ "/*inferred*/"  data FilterDirection =   FilterRequires |@@ -239,12 +245,21 @@ viewTypeFilter :: ParamName -> TypeFilter -> String viewTypeFilter n f = show n ++ " " ++ show f +hasInferredParams :: GeneralInstance -> Bool+hasInferredParams (TypeMerge _ ts) =+  any hasInferredParams ts+hasInferredParams (SingleType (JustTypeInstance (TypeInstance _ (Positional ts)))) =+  any hasInferredParams ts+hasInferredParams (SingleType (JustInferredType _)) = True+hasInferredParams _                                 = False+ type InstanceParams = Positional GeneralInstance type InstanceVariances = Positional Variance type InstanceFilters = Positional [TypeFilter] -type ParamFilters = Map.Map ParamName [TypeFilter]+type ParamFilters   = Map.Map ParamName [TypeFilter] type ParamVariances = Map.Map ParamName Variance+type ParamValues    = Map.Map ParamName GeneralInstance  class TypeResolver r where   -- Performs parameter substitution for refines.@@ -283,12 +298,26 @@   resolve _        = compileErrorM $ "Param " ++ show n ++ " not found"  getValueForParam :: (CompileErrorM m) =>-  Map.Map ParamName GeneralInstance -> ParamName -> m GeneralInstance+  ParamValues -> ParamName -> m GeneralInstance getValueForParam pa n =   case n `Map.lookup` pa of-        (Just x) -> return x-        _ -> compileErrorM $ "Param " ++ show n ++ " does not exist"+       (Just x) -> return x+       _ -> compileErrorM $ "Param " ++ show n ++ " does not exist" +fixTypeParams :: GeneralInstance -> GeneralInstance+fixTypeParams = setParamsFixed True++unfixTypeParams :: GeneralInstance -> GeneralInstance+unfixTypeParams = setParamsFixed False++setParamsFixed :: Bool -> GeneralInstance -> GeneralInstance+setParamsFixed f (TypeMerge m ts) = TypeMerge m $ map (setParamsFixed f) ts+setParamsFixed f (SingleType (JustTypeInstance (TypeInstance t ts))) =+  SingleType $ JustTypeInstance $ TypeInstance t $ fmap (setParamsFixed f) ts+setParamsFixed f (SingleType (JustParamName _ n2)) =+  SingleType $ JustParamName f n2+setParamsFixed _ t = t+ noInferredTypes :: (MergeableM m, CompileErrorM m) => m (MergeTree InferredTypeGuess) -> m () noInferredTypes = id >=> reduceMergeTree return return message where   message i = compileErrorM $ "Type guess " ++ show i ++ " not allowed here"@@ -308,9 +337,8 @@ checkGeneralMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> Variance ->   GeneralInstance -> GeneralInstance -> m (MergeTree InferredTypeGuess)-checkGeneralMatch r f v (SingleType (JustInferredType p1)) t2 = do-  compileWarningM $ "Treating inferred parameter " ++ show p1 ++ " on the left as a regular parameter"-  checkGeneralMatch r f v (SingleType $ JustParamName p1) t2+checkGeneralMatch _ _ _ (SingleType (JustInferredType p1)) _ =+  compileErrorM $ "Inferred parameter " ++ show p1 ++ " is not allowed on the left" checkGeneralMatch _ _ v t1 (SingleType (JustInferredType p2)) =   return $ mergeLeaf $ InferredTypeGuess p2 t1 v checkGeneralMatch r f Invariant ts1 ts2 =@@ -327,18 +355,17 @@ checkSingleMatch :: (MergeableM m, CompileErrorM m, TypeResolver r) =>   r -> ParamFilters -> Variance ->   TypeInstanceOrParam -> TypeInstanceOrParam -> m (MergeTree InferredTypeGuess)-checkSingleMatch r f v (JustInferredType p1) t2 = do-  compileWarningM $ "Treating inferred parameter " ++ show p1 ++ " on the left as a regular parameter"-  checkSingleMatch r f v (JustParamName p1) t2+checkSingleMatch _ _ _ (JustInferredType p1) _ =+  compileErrorM $ "Inferred parameter " ++ show p1 ++ " is not allowed on the left" checkSingleMatch _ _ v t1 (JustInferredType p2) =   return $ mergeLeaf $ InferredTypeGuess p2 (SingleType t1) v checkSingleMatch r f v (JustTypeInstance t1) (JustTypeInstance t2) =   checkInstanceToInstance r f v t1 t2-checkSingleMatch r f v (JustParamName p1) (JustTypeInstance t2) =+checkSingleMatch r f v (JustParamName _ p1) (JustTypeInstance t2) =   checkParamToInstance r f v p1 t2-checkSingleMatch r f v (JustTypeInstance t1) (JustParamName p2) =+checkSingleMatch r f v (JustTypeInstance t1) (JustParamName _ p2) =   checkInstanceToParam r f v t1 p2-checkSingleMatch r f v (JustParamName p1) (JustParamName p2) =+checkSingleMatch r f v (JustParamName _ p1) (JustParamName _ p2) =   checkParamToParam r f v p1 p2  checkInstanceToInstance :: (MergeableM m, CompileErrorM m, TypeResolver r) =>@@ -451,14 +478,16 @@     mergeAnyM (map (\(c1,c2) -> checkConstraintToConstraint v c1 c2) typeFilters) `reviseErrorM`       ("No filters imply " ++ show n1 ++ " -> " ++ show n2)     where+      selfParam1 = JustParamName False n1+      selfParam2 = JustParamName False n2       self1-        | v == Covariant = TypeFilter FilterRequires (JustParamName n1)-        | otherwise      = TypeFilter FilterAllows   (JustParamName n1)+        | v == Covariant = TypeFilter FilterRequires selfParam1+        | otherwise      = TypeFilter FilterAllows   selfParam1       self2-        | v == Covariant = TypeFilter FilterAllows   (JustParamName n2)-        | otherwise      = TypeFilter FilterRequires (JustParamName n2)+        | v == Covariant = TypeFilter FilterAllows   selfParam2+        | otherwise      = TypeFilter FilterRequires selfParam2       checkConstraintToConstraint Covariant (TypeFilter FilterRequires t1) (TypeFilter FilterAllows t2)-        | t1 == (JustParamName n1) && t2 == (JustParamName n2) =+        | t1 == selfParam1 && t2 == selfParam2 =           compileErrorM $ "Infinite recursion in " ++ show n1 ++ " -> " ++ show n2         -- x -> F1, F2 -> y implies x -> y only if F1 -> F2         | otherwise = checkSingleMatch r f Covariant t1 t2@@ -470,7 +499,7 @@                         viewTypeFilter n2 f2 ++ " do not imply " ++                         show n1 ++ " -> " ++ show n2       checkConstraintToConstraint Contravariant (TypeFilter FilterAllows t1) (TypeFilter FilterRequires t2)-        | t1 == (JustParamName n1) && t2 == (JustParamName n2) =+        | t1 == selfParam1 && t2 == selfParam2 =           compileErrorM $ "Infinite recursion in " ++ show n1 ++ " <- " ++ show n2         -- x <- F1, F2 <- y implies x <- y only if F1 <- F2         | otherwise = checkSingleMatch r f Contravariant t1 t2@@ -490,7 +519,7 @@   | otherwise      = mergeAllM (map (validateGeneralInstance r f) ts) validateGeneralInstance r f (SingleType (JustTypeInstance t)) =   validateTypeInstance r f t-validateGeneralInstance _ f (SingleType (JustParamName n)) =+validateGeneralInstance _ f (SingleType (JustParamName _ n)) =   when (not $ n `Map.member` f) $     compileErrorM $ "Param " ++ show n ++ " does not exist" validateGeneralInstance _ _ t = compileErrorM $ "Type " ++ show t ++ " contains unresolved types"@@ -531,7 +560,7 @@   checkDefinesFilter f2@(DefinesInstance n2 _) (JustTypeInstance t1) = do     ps1' <- trDefines r t1 n2     checkDefinesMatch r f f2 (DefinesInstance n2 ps1')-  checkDefinesFilter f2 (JustParamName n1) = do+  checkDefinesFilter f2 (JustParamName _ n1) = do       fs1 <- fmap (map dfType . filter isDefinesFilter) $ f `filterLookup` n1       mergeAnyM (map (checkDefinesMatch r f f2) fs1) `reviseErrorM`         ("No filters imply " ++ show n1 ++ " defines " ++ show f2)@@ -556,7 +585,7 @@   mergeAllM (map (validateInstanceVariance r vm v) ts) validateInstanceVariance r vm v (TypeMerge MergeIntersect ts) =   mergeAllM (map (validateInstanceVariance r vm v) ts)-validateInstanceVariance _ vm v (SingleType (JustParamName n)) =+validateInstanceVariance _ vm v (SingleType (JustParamName _ n)) =   case n `Map.lookup` vm of       Nothing -> compileErrorM $ "Param " ++ show n ++ " is undefined"       (Just v0) -> when (not $ v0 `paramAllowsVariance` v) $@@ -590,7 +619,8 @@     gs <- mapErrorsM subAll ts     let t2 = SingleType $ JustTypeInstance $ TypeInstance n (Positional gs)     return (t2)-  subInstance (JustParamName n) = replace n+  subInstance p@(JustParamName True _) = return $ SingleType p+  subInstance (JustParamName _ n)      = replace n   subInstance t = compileErrorM $ "Type " ++ show t ++ " contains unresolved types"  uncheckedSubFilter :: (MergeableM m, CompileErrorM m) =>

@@ -194,7 +194,7 @@  testcase "inference from filter" {   error-  require "Formatted"+  require "#x.+get.+Formatted"   require "String"   require "value2"   exclude "value1"@@ -210,6 +210,93 @@     #x allows Formatted   (#x) -> (#x)   get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "inference from filter without param" {+  error+  require "#x.+get.+Formatted"+  require "String"+  require "value2"+  exclude "value1"+}++define Test {+  run () {+    Formatted value1 <- get<Formatted,?>("value")+    String    value2 <- get<Formatted,?>("value")+  }++  @type get<#y,#x>+    #x allows #y+  (#x) -> (#x)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "inference from filter including param" {+  error+  require "#x.+get.+Type<String>"+}++concrete Type<#x> {+  @type create () -> (Type<#x>)+}++define Type {+  create () {+    return Type<#x>{ }+  }+}++define Test {+  run () {+    Type<String> value2 <- get<?>(Type<String>$create())+  }++  @type get<#x>+    #x allows Type<#x>+  (#x) -> (#x)+  get (x) {+    return x+  }+}++concrete Test {+  @type run () -> ()+}+++testcase "clashing param filter in the same scope" {+  success Test$run()+}++define Test {+  run () {+    \ get1<Int>()+  }++  @type get1<#x>+    #x requires Int+  () -> ()+  get1 () {+    String value <- get2<?>("message")+  }++  @type get2<#x> (#x) -> (#x)+  get2 (x) {     return x   } }

@@ -0,0 +1,52 @@+/* -----------------------------------------------------------------------------+Copyright 2020 Kevin P. Barry++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+----------------------------------------------------------------------------- */++// Author: Kevin P. Barry [ta0kira@gmail.com]++testcase "Issue #73 is fixed" {+  success empty+}++concrete Type1<#x> {+  @type call<#y> (#x) -> ()+}++define Type1 {+  call (_) {}+}++concrete Type2<#y> {+  @type call () -> ()+}++define Type2 {+  call () {+    // Value<#y> gets subbed in for #x, so call is re-parameterized with an+    // argument of type Value<#y>. When the compiler processes call<Int>, it+    // looks for #y, which it finds; however, it's a different #y.+    \ Type1<Value<#y>>$call<Int>(Value<#y>$create())+  }+}++concrete Value<#z> {+  @type create () -> (Value<#z>)+}++define Value {+  create () {+    return Value<#z>{ }+  }+}

@@ -1,7 +1,7 @@ cabal-version:       2.2  name:                zeolite-lang-version:             0.7.0.0+version:             0.7.0.1 synopsis:            Zeolite is a statically-typed, general-purpose programming language.  description: