From d16986ac581b30084b3ba44cd918270da65d4cef Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Wed, 6 Sep 2006 22:04:17 +0000
Subject: [PATCH] Pattern-match warning police

---
 compiler/typecheck/TcType.lhs  |   17 +++++++++++------
 compiler/typecheck/TcUnify.lhs |    5 +++++
 2 files changed, 16 insertions(+), 6 deletions(-)

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index ed29d65..10300db 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -700,9 +700,9 @@ tcSplitFunTysN ty n_args
   | otherwise
   = ([], ty)
 
-tcFunArgTy    ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
-tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
-
+tcSplitFunTy  ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
+tcFunArgTy    ty = fst (tcSplitFunTy ty)
+tcFunResultTy ty = snd (tcSplitFunTy ty)
 
 -----------------------
 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
@@ -750,6 +750,7 @@ tcSplitDFunHead :: Type -> (Class, [Type])
 tcSplitDFunHead tau  
   = case tcSplitPredTy_maybe tau of 
 	Just (ClassP clas tys) -> (clas, tys)
+	other -> panic "tcSplitDFunHead"
 
 tcValidInstHeadTy :: Type -> Bool
 -- Used in Haskell-98 mode, for the argument types of an instance head
@@ -816,6 +817,7 @@ getClassPredTys_maybe _		        = Nothing
 
 getClassPredTys :: PredType -> (Class, [Type])
 getClassPredTys (ClassP clas tys) = (clas, tys)
+getClassPredTys other = panic "getClassPredTys"
 
 mkDictTy :: Class -> [Type] -> Type
 mkDictTy clas tys = mkPredTy (ClassP clas tys)
@@ -869,6 +871,7 @@ dataConsStupidTheta (con1:cons)
 		    | con <- cons
 		    , let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con)
 		    , pred <- dataConStupidTheta con ]
+dataConsStupidTheta [] = panic "dataConsStupidTheta"
 \end{code}
 
 
@@ -1117,12 +1120,14 @@ toDNType :: Type -> DNType
 toDNType ty
   | isStringTy ty = DNString
   | isFFIDotnetObjTy ty = DNObject
-  | Just (tc,argTys) <- tcSplitTyConApp_maybe ty = 
-     case lookup (getUnique tc) dn_assoc of
+  | Just (tc,argTys) <- tcSplitTyConApp_maybe ty 
+  =  case lookup (getUnique tc) dn_assoc of
        Just x  -> x
        Nothing 
          | tc `hasKey` ioTyConKey -> toDNType (head argTys)
-	 | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
+	 | otherwise -> pprPanic ("toDNType: unsupported .NET type") 
+			  (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
+  | otherwise = panic "toDNType"	-- Is this right?
     where
       dn_assoc :: [ (Unique, DNType) ]
       dn_assoc = [ (unitTyConKey,   DNUnit)
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 649408c..bb97f8d 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -180,6 +180,7 @@ subFunTys error_herald n_pats res_ty thing_inside
 			     ; return (idCoercion, res) } }
 	where
 	  mk_res_ty (res_ty' : arg_tys') = mkFunTys arg_tys' res_ty'
+	  mk_res_ty [] = panic "TcUnify.mk_res_ty1"
 	  kinds = openTypeKind : take n (repeat argTypeKind)
 		-- Note argTypeKind: the args can have an unboxed type,
 		-- but not an unboxed tuple.
@@ -268,6 +269,7 @@ boxySplitAppTy orig_ty
 				 ; return (fun_ty, arg_ty) } }
       where
         mk_res_ty [fun_ty', arg_ty'] = mkAppTy fun_ty' arg_ty'
+	mk_res_ty other = panic "TcUnify.mk_res_ty2"
 	tv_kind = tyVarKind tv
 	kinds = [mkArrowKind liftedTypeKind (defaultKind tv_kind),
 					 	-- m :: * -> k
@@ -460,6 +462,8 @@ boxy_match_s tmpl_tvs [] boxy_tvs [] subst
 boxy_match_s tmpl_tvs (t_ty:t_tys) boxy_tvs (b_ty:b_tys) subst
   = boxy_match tmpl_tvs t_ty boxy_tvs b_ty $
     boxy_match_s tmpl_tvs t_tys boxy_tvs b_tys subst
+boxy_match_s tmpl_tvs _ boxy_tvs _ subst
+  = panic "boxy_match_s"	-- Lengths do not match
     
 
 ------------
@@ -689,6 +693,7 @@ tc_sub outer act_sty act_ty@(FunTy act_arg act_res) exp_sty (TyVarTy exp_tv)
  			      ; tc_sub_funs act_arg act_res arg_ty res_ty } }
  where
     mk_res_ty [arg_ty', res_ty'] = mkFunTy arg_ty' res_ty'
+    mk_res_ty other = panic "TcUnify.mk_res_ty3"
     fun_kinds = [argTypeKind, openTypeKind]
 
 -- Everything else: defer to boxy matching
-- 
1.7.10.4