Super-monster patch implementing the new typechecker -- at last

[ghc-hetmet.git] / compiler / coreSyn / CoreLint.lhs

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index c267c96..119b232 100644 (file)
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -229,9 +229,9 @@ lintCoreExpr (Note _ expr)
   = lintCoreExpr expr
 
 lintCoreExpr (Let (NonRec tv (Type ty)) body)
-  =    -- See Note [Type let] in CoreSyn
-    do { checkL (isTyVar tv) (mkKindErrMsg tv ty)      -- Not quite accurate
-       ; ty' <- lintInTy ty
+  | isTyVar tv
+  =    -- See Note [Linting type lets]
+    do { ty' <- addLoc (RhsOf tv) $ lintInTy ty
         ; lintTyBndr tv              $ \ tv' -> 
           addLoc (BodyOfLetRec [tv]) $ 
           extendSubstL tv' ty'       $ do
@@ -240,6 +240,19 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
                -- take advantage of it in the body
         ; lintCoreExpr body } }
 
+  | isCoVar tv
+  = do { co <- applySubst ty
+       ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co
+       ; lintTyBndr tv  $ \ tv' -> 
+         addLoc (BodyOfLetRec [tv]) $ do
+       { let (t1,t2) = coVarKind tv'
+       ; checkTys s1 t1 (mkTyVarLetErr tv ty)
+       ; checkTys s2 t2 (mkTyVarLetErr tv ty)
+       ; lintCoreExpr body } }
+
+  | otherwise
+  = failWithL (mkTyVarLetErr tv ty)    -- Not quite accurate
+
 lintCoreExpr (Let (NonRec bndr rhs) body)
   = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
        ; addLoc (BodyOfLetRec [bndr])
@@ -279,7 +292,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
          Just (tycon, _)
               | debugIsOn &&
                 isAlgTyCon tycon && 
-               not (isOpenTyCon tycon) &&
+               not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
                 null (tyConDataCons tycon) -> 
                   pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
                        -- This can legitimately happen for type families
@@ -1081,6 +1094,14 @@ mkNonFunAppMsg fun_ty arg_ty arg
              hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
              hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 
+mkTyVarLetErr :: TyVar -> Type -> Message
+mkTyVarLetErr tyvar ty
+  = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"),
+         hang (ptext (sLit "Type/coercion variable:"))
+                4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+         hang (ptext (sLit "Arg type/coercion:"))   
+                4 (ppr ty)]
+
 mkKindErrMsg :: TyVar -> Type -> Message
 mkKindErrMsg tyvar arg_ty
   = vcat [ptext (sLit "Kinds don't match in type application:"),