X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=05019c3adb1620937caf583d346a420d779606ce;hb=bde1dd37ac3a36371be618cc7301f1b7853952fd;hp=83134d824c2787ad2ac36d5f25ac040e44a35a2a;hpb=fc63e16fda616d34ffc93a19d1f47271d416e65a;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 83134d8..05019c3 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -37,16 +37,11 @@ import DataCon		( isNullaryDataCon, dataConTag,
 			  dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
 			  DataCon, dataConName,
 			  dataConFieldLabels )
-import Name		( getOccString, getOccName, getSrcLoc, occNameString, 
-			  occNameUserString, 
-			  Name, NamedThing(..), 
-			  isDataSymOcc, isSymOcc
-			)
+import Name		( getOccString, getSrcLoc, Name, NamedThing(..)	)
 
 import HscTypes		( FixityEnv, lookupFixity )
 import PrelInfo
 import PrelNames
-import TysWiredIn
 import MkId		( eRROR_ID )
 import PrimOp		( PrimOp(..) )
 import SrcLoc		( Located(..), noLoc, srcLocSpan )
@@ -56,7 +51,8 @@ import TyCon		( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity
 import TcType		( isUnLiftedType, tcEqType, Type )
 import TysPrim		( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
 			  intPrimTyCon )
-import TysWiredIn	( charDataCon, intDataCon, floatDataCon, doubleDataCon )
+import TysWiredIn	( charDataCon, intDataCon, floatDataCon, doubleDataCon,
+			  intDataCon_RDR, true_RDR, false_RDR )
 import Util		( zipWithEqual, isSingleton,
 			  zipWith3Equal, nOfThem, zipEqual )
 import Char		( isAlpha )
@@ -164,7 +160,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 +325,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 +593,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 +894,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 +1000,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
@@ -1062,9 +1058,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
+    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)
@@ -1079,19 +1077,25 @@ 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 (nlConPat intDataCon_RDR
-                            [nlLitPat (HsIntPrim (toInteger (dataConTag 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_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))]
+      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)