From c7c01b0d35e816c4e85177d22d82be22261684a1 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 5 Apr 2004 10:51:23 +0000
Subject: [PATCH] [project @ 2004-04-05 10:51:23 by simonpj] Remove redundant
 case-analysis for single-constructor case of gunfold

---
 ghc/compiler/typecheck/TcGenDeriv.lhs |   26 +++++++++++++++-----------
 1 file changed, 15 insertions(+), 11 deletions(-)

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 706ee3d..67cb7ee 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -1062,10 +1062,11 @@ gen_Data_binds fix_env tycon
 		-- Auxiliary definitions: the data type and constructors
      datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
   where
-    tycon_loc = getSrcSpan tycon
+    tycon_loc  = getSrcSpan tycon
     tycon_name = tyConName tycon
-    data_cons = tyConDataCons tycon
-    n_cons    = length data_cons
+    data_cons  = tyConDataCons tycon
+    n_cons     = length data_cons
+    one_constr = n_cons == 1
 
 	------------ gfoldl
     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
@@ -1080,17 +1081,20 @@ gen_Data_binds fix_env tycon
 	------------ gunfold
     gunfold_bind = mk_FunBind tycon_loc
                               gunfold_RDR
-                              [([k_Pat,z_Pat,c_Pat], gunfold_rhs)]
+                              [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], 
+				gunfold_rhs)]
 
-    gunfold_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) 
-			   (map gunfold_alt data_cons)
+    gunfold_rhs 
+	| one_constr = mk_unfold_rhs (head data_cons)	-- No need for case
+	| otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) 
+			        (map gunfold_alt data_cons)
 
-    gunfold_alt dc
-      = mkSimpleHsAlt (mk_tag_pat dc)
-	              (foldr nlHsApp
+    gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
+    mk_unfold_rhs dc = foldr nlHsApp
                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
-                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR)))
-    mk_tag_pat dc	-- Last one is a wild-pat, to avoid 
+                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
+
+    mk_unfold_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))]
-- 
1.7.10.4