[project @ 2004-04-05 10:35:11 by simonpj]

In the derived code for gunfold, use a wild-card for the 
final case, to avoid a redundant test, and to eliminate the
annoying warning about un-matched cases.

While I'm at it, rename HsUtils.wildPat to nlWildPat, for
consistency.

4 files changed, 30 insertions, 26 deletions

diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index 4885b13b79..aed32b6bf6 100644
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -188,7 +188,7 @@ check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 check' []                                              = ([([],[])],emptyUniqSet)
 
 check' [EqnInfo n ctx ps (MatchResult CanFail _)] 
-   | all_vars ps  = ([(takeList ps (repeat wildPat),[])],  unitUniqSet n)
+   | all_vars ps  = ([(takeList ps (repeat nlWildPat),[])],  unitUniqSet n)
 
 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
    | all_vars ps  = (pats,  addOneToUniqSet indexs n)
@@ -253,7 +253,7 @@ process_literals used_lits qs
        default_eqns    = ASSERT2( okGroup qs, pprGroup qs ) 
 			 map remove_var (filter (is_var . firstPat) qs)
        (pats',indexs') = check' default_eqns 
-       pats_default    = [(wildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats 
+       pats_default    = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats 
        indexs_default  = unionUniqSets indexs' indexs
 \end{code}
 
@@ -301,7 +301,7 @@ nothing to do.
 
 \begin{code}
 first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
-first_column_only_vars qs = (map (\ (xs,ys) -> (wildPat:xs,ys)) pats,indexs)
+first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs)
                           where
                             (pats,indexs) = check' (map remove_var qs)
        
@@ -374,7 +374,7 @@ remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs
 
 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
 make_row_vars used_lits (EqnInfo _ _ pats _ ) = 
-   (nlVarPat new_var:takeList (tail pats) (repeat wildPat),[(new_var,used_lits)])
+   (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)])
   where new_var = hash_x
 
 hash_x = mkInternalName unboundKey {- doesn't matter much -}
@@ -382,7 +382,7 @@ hash_x = mkInternalName unboundKey {- doesn't matter much -}
 		     noSrcLoc
 
 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
-make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat wildPat)
+make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat nlWildPat)
 
 compare_cons :: Pat Id -> Pat Id -> Bool
 compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2  
@@ -562,11 +562,11 @@ make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints)
 --   representation 
 
 make_whole_con :: DataCon -> WarningPat
-make_whole_con con | isInfixCon con = nlInfixConPat name wildPat wildPat
+make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat
                    | otherwise      = nlConPat name pats
                 where 
                   name   = getName con
-                  pats   = [wildPat | t <- dataConOrigArgTys con]
+                  pats   = [nlWildPat | t <- dataConOrigArgTys con]
 \end{code}
 
 This equation makes the same thing as @tidy@ in @Match.lhs@, the
@@ -650,12 +650,12 @@ simplify_pat (DictPat dicts methods)
 simplify_con con (PrefixCon ps)   = PrefixCon (map simplify_lpat ps)
 simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2]
 simplify_con con (RecCon fs)      
-  | null fs   = PrefixCon [wildPat | t <- dataConOrigArgTys con]
+  | null fs   = PrefixCon [nlWildPat | t <- dataConOrigArgTys con]
 		-- Special case for null patterns; maybe not a record at all
   | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats)
   where
      -- pad out all the missing fields with WildPats.
-    field_pats = map (\ f -> (getName f, wildPat))
+    field_pats = map (\ f -> (getName f, nlWildPat))
 		     (dataConFieldLabels con)
     all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc)
 		     field_pats fs
diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs
index 789887c49b..3b61f8a26a 100644
--- a/ghc/compiler/hsSyn/HsUtils.lhs
+++ b/ghc/compiler/hsSyn/HsUtils.lhs
@@ -173,10 +173,10 @@ nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
 
 nlWildConPat :: DataCon -> LPat RdrName
 nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
-				   (PrefixCon (nOfThem (dataConSourceArity con) wildPat)))
+				   (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
 
 nlTuplePat pats box = noLoc (TuplePat pats box)
-wildPat  = noLoc (WildPat placeHolderType)	-- Pre-typechecking
+nlWildPat  = noLoc (WildPat placeHolderType)	-- Pre-typechecking
 
 nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
 nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index b24701dacb..0c4f500d67 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -529,7 +529,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
 	-- Need two splits because the  selector can have a type like
 	-- 	forall a. Foo a => forall b. Eq b => ...
     (arg_tys, _) = tcSplitFunTys tau2
-    wild_pats	 = [wildPat | ty <- arg_tys]
+    wild_pats	 = [nlWildPat | ty <- arg_tys]
 
 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth 
   = 	-- A generic default method
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 83134d824c..706ee3da95 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -164,7 +164,7 @@ gen_Eq_binds tycon
 		case maybeTyConSingleCon tycon of
 		  Just _ -> []
 		  Nothing -> -- if cons don't match, then False
-		     [([wildPat, wildPat], false_Expr)]
+		     [([nlWildPat, nlWildPat], false_Expr)]
 	    else -- calc. and compare the tags
 		 [([a_Pat, b_Pat],
 		    untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
@@ -329,13 +329,13 @@ gen_Ord_binds tycon
 			   -- Catch this specially to avoid warnings
 			   -- about overlapping patterns from the desugarer,
 			   -- and to avoid unnecessary pattern-matching
-      = [([wildPat,wildPat], eqTag_Expr)]
+      = [([nlWildPat,nlWildPat], eqTag_Expr)]
       | otherwise
       = map pats_etc nonnullary_cons ++
 	(if single_con_type then	-- Omit wildcards when there's just one 
 	      []			-- constructor, to silence desugarer
 	else
-              [([wildPat, wildPat], default_rhs)])
+              [([nlWildPat, nlWildPat], default_rhs)])
 
       where
 	pats_etc data_con
@@ -597,7 +597,7 @@ gen_Ix_binds tycon
     enum_index
       = mk_easy_FunBind tycon_loc index_RDR 
 		[noLoc (AsPat (noLoc c_RDR) 
-			   (nlTuplePat [a_Pat, wildPat] Boxed)), 
+			   (nlTuplePat [a_Pat, nlWildPat] Boxed)), 
 				d_Pat] emptyBag (
 	nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
 	   untag_Expr tycon [(a_RDR, ah_RDR)] (
@@ -898,7 +898,7 @@ gen_Show_binds get_fixity tycon
 	pats_etc data_con
 	  | nullary_con =  -- skip the showParen junk...
 	     ASSERT(null bs_needed)
-	     ([wildPat, con_pat], mk_showString_app con_str)
+	     ([nlWildPat, con_pat], mk_showString_app con_str)
 	  | otherwise   =
 	     ([a_Pat, con_pat],
 		  showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
@@ -1004,7 +1004,7 @@ gen_Typeable_binds tycon
   = unitBag $
 	mk_easy_FunBind tycon_loc 
 		(mk_typeOf_RDR tycon) 	-- Name of appropriate type0f function
-		[wildPat] emptyBag
+		[nlWildPat] emptyBag
 		(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
   where
     tycon_loc = getSrcSpan tycon
@@ -1065,6 +1065,7 @@ gen_Data_binds fix_env tycon
     tycon_loc = getSrcSpan tycon
     tycon_name = tyConName tycon
     data_cons = tyConDataCons tycon
+    n_cons    = length data_cons
 
 	------------ gfoldl
     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
@@ -1084,14 +1085,17 @@ gen_Data_binds fix_env tycon
     gunfold_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) 
 			   (map gunfold_alt data_cons)
 
-    gunfold_alt dc =
-      mkSimpleHsAlt (nlConPat intDataCon_RDR
-                            [nlLitPat (HsIntPrim (toInteger (dataConTag dc)))])
-	            (foldr nlHsApp
+    gunfold_alt dc
+      = mkSimpleHsAlt (mk_tag_pat dc)
+	              (foldr nlHsApp
                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
-                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
-                    )
-
+                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR)))
+    mk_tag_pat dc	-- Last one is a wild-pat, to avoid 
+			-- redundant test, and annoying warning
+      | tag-fIRST_TAG == n_cons-1 = nlWildPat	-- Last constructor
+      | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
+      where 
+	tag = dataConTag dc
 			  
 	------------ toConstr
     toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
@@ -1101,7 +1105,7 @@ gen_Data_binds fix_env tycon
     dataTypeOf_bind = mk_easy_FunBind
                         tycon_loc
                         dataTypeOf_RDR
-			[wildPat]
+			[nlWildPat]
                         emptyBag
                         (nlHsVar data_type_name)