[add new grin lint-checker that is more robust, check for unknown free variables within it.
John Meacham <john@repetae.net>**20070516045530] hunk ./Grin/Lint.hs 8
-import Options
hunk ./Grin/Lint.hs 9
-import Grin.Grin
-import Grin.Show
-import Util.Gen
hunk ./Grin/Lint.hs 10
+import Control.Monad.Reader
+import Data.Monoid
hunk ./Grin/Lint.hs 13
+import qualified Data.Set as Set
+
+import Doc.DocLike
+import Grin.Grin
+import Grin.Noodle
+import Grin.Show
+import Options
hunk ./Grin/Lint.hs 21
-import qualified FlagDump as FD
+import Support.FreeVars
hunk ./Grin/Lint.hs 23
+import Util.Gen
+import Util.SetLike
+import qualified FlagDump as FD
hunk ./Grin/Lint.hs 40
-    let errs = [  (err ++ "\n" ++ render (prettyFun a) ) | (a,Left err) <-  [ (a,typecheck (grinTypeEnv grin) c:: Either String Ty)   | a@(_,(_ :-> c)) <-  grinFuncs grin ]]
+    let env = TcEnv { envTyEnv = grinTypeEnv grin, envInScope = fromList (fsts $ grinCafs grin) }
+    let errs = [  (err ++ "\n" ++ render (prettyFun a) ) | (a,Left err) <-  [ (a,runTc env (tcLam Nothing c))  | a@(_,c) <-  grinFuncs grin ]]
hunk ./Grin/Lint.hs 107
+
+data TcEnv = TcEnv {
+    envTyEnv :: TyEnv,
+    envInScope :: Set.Set Var
+}
+
+
+
+newtype Tc a = Tc (ReaderT TcEnv (Either String) a)
+    deriving(Monad,MonadReader TcEnv)
+
+
+runTc :: TcEnv -> Tc a -> Either String a
+runTc env (Tc r) = runReaderT r env
+
+same _ t1 t2 | t1 == t2 = return t1
+same msg t1 t2 = fail $ "Types not the same:" <+> parens msg <+> parens (tshow t1) <+> parens (tshow t2)
+
+tcLam :: Maybe Ty -> Lam -> Tc Ty
+tcLam mty (v :-> e) = f mty where
+    f Nothing = ans (tcVal v)
+    f (Just ty) = ans $ do
+        t <- tcVal v
+        same (":->" <+> show mty <+> show (v :-> e)) ty t
+    ans r = local (\e -> e { envInScope = freeVars v `mappend` envInScope e }) $ r >> tcExp e
+
+tcExp :: Exp -> Tc Ty
+tcExp e = f e where
+    f (e :>>= lam) = do
+        t1 <- f e
+        tcLam (Just t1) lam
+    f n@(Prim p as) = do
+        let (as',t') = primType p
+        as'' <- mapM tcVal as
+        if as'' == as' then return t' else
+            fail $ "Prim: arguments do not match " ++ show n
+    f ap@(App fn [v,a] t) | fn == funcApply = do
+        [v',a'] <- mapM tcVal [v,a]
+        if v' == TyNode then return t
+         else fail $ "App apply arg doesn't match: " ++ show ap
+    f ap@(App fn [v] t) | fn == funcApply = do
+        v' <- tcVal v
+        if v' == TyNode then return t
+         else fail $ "App apply arg doesn't match: " ++ show ap
+    f ap@(App fn [v] t) | fn == funcEval = do
+        v' <- tcVal v
+        if v' == tyINode then return t
+         else fail $ "App eval arg doesn't match: " ++ show ap
+    f a@(App fn as t) = do
+        te <- asks envTyEnv
+        (as',t') <- findArgsType te fn
+        as'' <- mapM tcVal as
+        if t' == t then
+            if as'' == as' then return t' else
+                fail $ "App: arguments do not match: " ++ show (a,as',t')
+         else fail $ "App: results do not match: " ++ show (a,t,(as',t'))
+    f (Store v) = do
+        t <- tcVal v
+        return (TyPtr t)
+    f Alloc { expValue = v } = do
+        t <- tcVal v
+        return (TyPtr t)
+    f (Return v) = tcVal v
+    f (Fetch v) = do
+        (TyPtr t) <- tcVal v
+        return t
+    f (Error _ t) = return t
+    f e@(Update w v) = do
+        (TyPtr t) <- tcVal w
+        t' <- tcVal v
+        same (show e) t t'
+        return tyUnit
+    f (Case _ []) = fail "empty case"
+    f (Case v as) = do
+        tv <- tcVal v
+        es <- mapM (tcLam (Just tv)) as
+        foldl1M (same $ "case exp: " ++ show (map head $ sortGroupUnder fst (zip es as)) ) es
+    f (Let { expDefs = defs, expBody = body }) = do
+        te <- asks envTyEnv
+        let nte = extendTyEnv defs te
+        local (\e -> e { envTyEnv = extendTyEnv defs (envTyEnv e) }) $ do
+            mapM_ (tcLam Nothing) [ b | FuncDef { funcDefBody = b } <- defs ]
+            f body
+
+tcVal :: Val -> Tc Ty
+tcVal v = f v where
+    f (Tag _) = return TyTag
+    f e@(Var v t) = do
+        s <- asks envInScope
+        case v `member` s of
+            True -> return t
+            False -> fail $ "variable not in scope: " ++ show e
+    f (Lit _ t) = return t
+    f (NodeV _v as) = do
+        mapM_ f as
+        return TyNode
+    f (Tup xs) = do
+        xs <- mapM f xs
+        return $ TyTup xs
+    f (Const t) = do
+        v <- f t
+        return (TyPtr v)
+    f (Index v offset) = do
+        t <- f v
+        Ty _ <- f offset
+        return t
+    f (ValUnknown ty) = return ty
+    f (Addr _) = return $ TyPtr (error "typecheck: Addr")
+    f (ValPrim _ vs ty) = do mapM_ f vs >> return ty
+    f n@(NodeC tg as) = do
+        te <- asks envTyEnv
+        (as',_) <- findArgsType te tg
+        as'' <- mapM f as
+        if as'' == as' then return TyNode else
+            fail $ "NodeC: arguments do not match " ++ show n ++ show (as'',as')
+
+
+