[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.

diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index 4885b13..aed32b6 100644 (file)
--- 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 789887c..3b61f8a 100644 (file)
--- 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 b24701d..0c4f500 100644 (file)
--- 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 83134d8..706ee3d 100644 (file)
--- 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)