X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreLint.lhs;h=119b2320cb4d990133e0074ba834ceaa6a31ed46;hb=70fb70c59556ef6c1b72ddf60459157d5383c26b;hp=c69a9d2f3d12fe0b0f86bf785d3caa22a60fbdaf;hpb=9ce35503f60f190fbd4a7df80cc22a43e223255d;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index c69a9d2..119b232 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -213,8 +213,7 @@ lintCoreExpr (Var var)
 
 	; checkDeadIdOcc var
 	; var' <- lookupIdInScope var
-        ; return (idType var')
-        }
+        ; return (idType var') }
 
 lintCoreExpr (Lit lit)
   = return (literalType lit)
@@ -230,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
@@ -241,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])
@@ -280,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
@@ -336,7 +348,7 @@ lintAltBinders :: OutType     -- Scrutinee type
 lintAltBinders scrut_ty con_ty [] 
   = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) 
 lintAltBinders scrut_ty con_ty (bndr:bndrs)
-  | isTyVar bndr
+  | isTyCoVar bndr
   = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
        ; lintAltBinders scrut_ty con_ty' bndrs }
   | otherwise
@@ -1082,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:"),