Get rid of non-exhaustive lambda

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

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index c69a9d2..234dcbb 100644 (file)
--- 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])
@@ -260,8 +272,9 @@ lintCoreExpr e@(App fun arg)
 
 lintCoreExpr (Lam var expr)
   = addLoc (LambdaBodyOf var) $
-    lintBinders [var] $ \[var'] -> 
-    do { body_ty <- lintCoreExpr expr
+    lintBinders [var] $ \ vars' ->
+    do { let [var'] = vars'  
+       ; body_ty <- lintCoreExpr expr
        ; if isId var' then 
              return (mkFunTy (idType var') body_ty) 
         else
@@ -280,7 +293,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 +349,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
@@ -369,7 +382,7 @@ lintValApp arg fun_ty arg_ty
 \end{code}
 
 \begin{code}
-checkKinds :: Var -> OutType -> LintM ()
+checkKinds :: OutVar -> OutType -> LintM ()
 -- Both args have had substitution applied
 checkKinds tyvar arg_ty
        -- Arg type might be boxed for a function with an uncommitted
@@ -592,26 +605,29 @@ lintSplitCoVar cv
                                 , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
 
 -------------------
-lintCoercion :: OutType -> LintM (OutType, OutType)
+lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType)
 -- Check the kind of a coercion term, returning the kind
-lintCoercion ty@(TyVarTy tv)
+lintCoercion co 
+  = addLoc (InCoercion co) $ lintCoercion' co
+
+lintCoercion' ty@(TyVarTy tv)
   = do { checkTyVarInScope tv
        ; if isCoVar tv then return (coVarKind tv) 
                        else return (ty, ty) }
 
-lintCoercion ty@(AppTy ty1 ty2) 
+lintCoercion' ty@(AppTy ty1 ty2) 
   = do { (s1,t1) <- lintCoercion ty1
        ; (s2,t2) <- lintCoercion ty2
        ; check_co_app ty (typeKind s1) [s2]
-       ; return (AppTy s1 s2, AppTy t1 t2) }
+       ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
 
-lintCoercion ty@(FunTy ty1 ty2) 
+lintCoercion' ty@(FunTy ty1 ty2)
   = do { (s1,t1) <- lintCoercion ty1
        ; (s2,t2) <- lintCoercion ty2
        ; check_co_app ty (tyConKind funTyCon) [s1, s2]
        ; return (FunTy s1 s2, FunTy t1 t2) }
 
-lintCoercion ty@(TyConApp tc tys) 
+lintCoercion' ty@(TyConApp tc tys) 
   | Just (ar, desc) <- isCoercionTyCon_maybe tc
   = do { unless (tys `lengthAtLeast` ar) (badCo ty)
        ; (s,t) <- lintCoTyConApp ty desc (take ar tys)
@@ -627,19 +643,19 @@ lintCoercion ty@(TyConApp tc tys)
        ; check_co_app ty (tyConKind tc) ss
        ; return (TyConApp tc ss, TyConApp tc ts) }
 
-lintCoercion ty@(PredTy (ClassP cls tys))
+lintCoercion' ty@(PredTy (ClassP cls tys))
   = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
        ; check_co_app ty (tyConKind (classTyCon cls)) ss
        ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) }
 
-lintCoercion (PredTy (IParam n p_ty))
+lintCoercion' (PredTy (IParam n p_ty))
   = do { (s,t) <- lintCoercion p_ty
        ; return (PredTy (IParam n s), PredTy (IParam n t)) }
 
-lintCoercion ty@(PredTy (EqPred {}))
+lintCoercion' ty@(PredTy (EqPred {}))
   = failWithL (badEq ty)
 
-lintCoercion (ForAllTy tv ty)
+lintCoercion' (ForAllTy tv ty)
   | isCoVar tv
   = do { (co1, co2) <- lintSplitCoVar tv
        ; (s1,t1)    <- lintCoercion co1
@@ -836,6 +852,7 @@ data LintLocInfo
   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
   | TopLevelBindings
   | InType Type                -- Inside a type
+  | InCoercion Coercion        -- Inside a type
 \end{code}
 
                  
@@ -991,6 +1008,8 @@ dumpLoc TopLevelBindings
   = (noSrcLoc, empty)
 dumpLoc (InType ty)
   = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
+dumpLoc (InCoercion ty)
+  = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty))
 
 pp_binders :: [Var] -> SDoc
 pp_binders bs = sep (punctuate comma (map pp_binder bs))
@@ -1082,6 +1101,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:"),