[project @ 2004-05-06 12:30:38 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcGenDeriv.lhs

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 83134d8..05019c3 100644 (file)
--- 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)