[project @ 2004-11-26 16:19:45 by simonmar]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcGenDeriv.lhs
index e922146..8f8168b 100644 (file)
@@ -32,31 +32,26 @@ import HsSyn
 import RdrName         ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual,
                           mkDerivedRdrName )
 import BasicTypes      ( Fixity(..), maxPrecedence, Boxity(..) )
-import FieldLabel       ( fieldLabelName )
-import DataCon         ( isNullaryDataCon, dataConTag,
+import DataCon         ( isNullarySrcDataCon, dataConTag,
                          dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
-                         DataCon, dataConName,
+                         DataCon, dataConName, dataConIsInfix,
                          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 )
-import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
+import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity,
                          maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
                        )
 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 )
@@ -157,14 +152,14 @@ gen_Eq_binds tycon
 
         (nullary_cons, nonnullary_cons)
            | isNewTyCon tycon = ([], tyConDataCons tycon)
-           | otherwise       = partition isNullaryDataCon (tyConDataCons tycon)
+           | otherwise       = partition isNullarySrcDataCon (tyConDataCons tycon)
 
        rest
          = if (null nullary_cons) then
                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)]
@@ -172,7 +167,7 @@ gen_Eq_binds tycon
     in
     listToBag [
       mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
-      mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag (
+      mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyLHsBinds (
        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
     ]
   where
@@ -319,7 +314,7 @@ gen_Ord_binds tycon
     single_con_type = isSingleton tycon_data_cons
     (nullary_cons, nonnullary_cons)
        | isNewTyCon tycon = ([], tyConDataCons tycon)
-       | otherwise       = partition isNullaryDataCon tycon_data_cons
+       | otherwise       = partition isNullarySrcDataCon tycon_data_cons
 
     cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
     cmp_eq_match
@@ -329,13 +324,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
@@ -422,7 +417,7 @@ gen_Enum_binds tycon
     occ_nm    = getOccString tycon
 
     succ_enum
-      = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $
+      = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $
        untag_Expr tycon [(a_RDR, ah_RDR)] $
        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
                               nlHsVarApps intDataCon_RDR [ah_RDR]])
@@ -432,7 +427,7 @@ gen_Enum_binds tycon
                                        nlHsIntLit 1]))
                    
     pred_enum
-      = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $
+      = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyLHsBinds $
        untag_Expr tycon [(a_RDR, ah_RDR)] $
        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
                               nlHsVarApps intDataCon_RDR [ah_RDR]])
@@ -442,7 +437,7 @@ gen_Enum_binds tycon
                                               nlHsLit (HsInt (-1))]))
 
     to_enum
-      = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $
+      = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyLHsBinds $
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
@@ -450,7 +445,7 @@ gen_Enum_binds tycon
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 
     enum_from
-      = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $
+      = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyLHsBinds $
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          nlHsApps map_RDR 
                [nlHsVar (tag2con_RDR tycon),
@@ -459,7 +454,7 @@ gen_Enum_binds tycon
                            (nlHsVar (maxtag_RDR tycon)))]
 
     enum_from_then
-      = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $
+      = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyLHsBinds $
          untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
            nlHsPar (enum_from_then_to_Expr
@@ -472,7 +467,7 @@ gen_Enum_binds tycon
                           ))
 
     from_enum
-      = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $
+      = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyLHsBinds $
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
 \end{code}
@@ -586,7 +581,7 @@ gen_Ix_binds tycon
 
     enum_range
       = mk_easy_FunBind tycon_loc range_RDR 
-               [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $
+               [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          untag_Expr tycon [(b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
@@ -597,8 +592,8 @@ gen_Ix_binds tycon
     enum_index
       = mk_easy_FunBind tycon_loc index_RDR 
                [noLoc (AsPat (noLoc c_RDR) 
-                          (nlTuplePat [a_Pat, wildPat] Boxed)), 
-                               d_Pat] emptyBag (
+                          (nlTuplePat [a_Pat, nlWildPat] Boxed)), 
+                               d_Pat] emptyLHsBinds (
        nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
           untag_Expr tycon [(a_RDR, ah_RDR)] (
           untag_Expr tycon [(d_RDR, dh_RDR)] (
@@ -615,7 +610,7 @@ gen_Ix_binds tycon
 
     enum_inRange
       = mk_easy_FunBind tycon_loc inRange_RDR 
-         [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag (
+         [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds (
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
@@ -649,7 +644,7 @@ gen_Ix_binds tycon
     --------------------------------------------------------------
     single_con_range
       = mk_easy_FunBind tycon_loc range_RDR 
-         [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $
+         [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $
        nlHsDo ListComp stmts
       where
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
@@ -680,7 +675,7 @@ gen_Ix_binds tycon
 
        range_size
          = mk_easy_FunBind tycon_loc rangeSize_RDR 
-                       [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag (
+                       [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds (
                genOpApp (
                    (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
                                         b_Expr])
@@ -691,7 +686,7 @@ gen_Ix_binds tycon
       = mk_easy_FunBind tycon_loc inRange_RDR 
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, 
                 con_pat cs_needed]
-                          emptyBag (
+                          emptyLHsBinds (
          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
       where
        in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
@@ -756,7 +751,7 @@ gen_Read_binds get_fixity tycon
 
     loc       = getSrcSpan tycon
     data_cons = tyConDataCons tycon
-    (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
     
     read_prec = mkVarBind loc readPrec_RDR
                              (nlHsApp (nlHsVar parens_RDR) read_cons)
@@ -784,7 +779,7 @@ gen_Read_binds get_fixity tycon
              | otherwise         = prefix_stmts
      
                prefix_stmts            -- T a b c
-                 = [bindLex (ident_pat (data_con_str data_con))]
+                 = [bindLex (ident_pat (data_con_str_w_parens data_con))]
                    ++ read_args
                    ++ [result_stmt data_con as_needed]
         
@@ -795,7 +790,7 @@ gen_Read_binds get_fixity tycon
             result_stmt data_con [a1,a2]]
      
                lbl_stmts               -- T { f1 = a, f2 = b }
-                 = [bindLex (ident_pat (data_con_str data_con)),
+                 = [bindLex (ident_pat (data_con_str_w_parens data_con)),
                     read_punc "{"]
                    ++ concat (intersperse [read_punc ","] field_stmts)
                    ++ [read_punc "}", result_stmt data_con as_needed]
@@ -805,7 +800,7 @@ gen_Read_binds get_fixity tycon
                con_arity    = dataConSourceArity data_con
                labels       = dataConFieldLabels data_con
                dc_nm        = getName data_con
-               is_infix     = isDataSymOcc (getOccName dc_nm)
+               is_infix     = dataConIsInfix data_con
                as_needed    = take con_arity as_RDRs
        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
                (read_a1:read_a2:_) = read_args
@@ -824,7 +819,8 @@ gen_Read_binds get_fixity tycon
     ident_pat s  = nlConPat ident_RDR [nlLitPat s]               -- Ident "foo"
     symbol_pat s = nlConPat symbol_RDR [nlLitPat s]              -- Symbol ">>"
     
-    data_con_str con = mkHsString (occNameUserString (getOccName con))
+    data_con_str          con = mkHsString (occNameUserString (getOccName con))
+    data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
     
     read_punc c = bindLex (punc_pat c)
     read_arg a ty 
@@ -847,7 +843,7 @@ gen_Read_binds get_fixity tycon
                    bindLex (symbol_pat lbl_lit),
                    read_punc ")"]
                 where  
-                  lbl_str = occNameUserString (getOccName (fieldLabelName lbl)) 
+                  lbl_str = occNameUserString (getOccName lbl) 
                   lbl_lit = mkHsString lbl_str
                   is_id_start c = isAlpha c || c == '_'
 \end{code}
@@ -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))))
@@ -917,24 +913,22 @@ gen_Show_binds get_fixity tycon
             dc_nm          = getName data_con
             dc_occ_nm      = getOccName data_con
              con_str        = occNameUserString dc_occ_nm
+            op_con_str     = occNameUserString_with_parens dc_occ_nm
 
             show_thingies 
                | is_infix      = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
-               | record_syntax = mk_showString_app (con_str ++ " {") : 
+               | record_syntax = mk_showString_app (op_con_str ++ " {") : 
                                  show_record_args ++ [mk_showString_app "}"]
-               | otherwise     = mk_showString_app (con_str ++ " ") : show_prefix_args
+               | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
                 
-            show_label l = mk_showString_app (the_name ++ " = ")
+            show_label l = mk_showString_app (nm ++ " = ")
                        -- Note the spaces around the "=" sign.  If we don't have them
                        -- then we get Foo { x=-1 } and the "=-" parses as a single
                        -- lexeme.  Only the space after the '=' is necessary, but
                        -- it seems tidier to have them both sides.
                 where
-                  occ_nm   = getOccName (fieldLabelName l)
-                  nm       = occNameUserString occ_nm
-                  is_op    = isSymOcc occ_nm       -- Legal, but rare.
-                  the_name | is_op     = '(':nm ++ ")"
-                           | otherwise = nm
+                  occ_nm   = getOccName l
+                  nm       = occNameUserString_with_parens occ_nm
 
              show_args                      = zipWith show_arg bs_needed arg_tys
             (show_arg1:show_arg2:_) = show_args
@@ -955,11 +949,18 @@ gen_Show_binds get_fixity tycon
                                                         box_if_necy "Show" tycon (nlHsVar b) arg_ty]
 
                -- Fixity stuff
-            is_infix = isDataSymOcc dc_occ_nm
+            is_infix = dataConIsInfix data_con
              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
             arg_prec | record_syntax = 0       -- Record fields don't need parens
                      | otherwise     = con_prec_plus_one
 
+occNameUserString_with_parens :: OccName -> String
+occNameUserString_with_parens occ
+  | isSymOcc occ = '(':nm ++ ")"
+  | otherwise    = nm
+  where
+   nm = occNameUserString occ
+
 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 \end{code}
 
@@ -993,27 +994,30 @@ From the data type
 
 we generate
 
-       instance (Typeable a, Typeable b) => Typeable (T a b) where
-               typeOf _ = mkTypeRep (mkTyConRep "T")
-                                    [typeOf (undefined::a),
-                                     typeOf (undefined::b)]
+       instance Typeable2 T where
+               typeOf2 _ = mkTyConApp (mkTyConRep "T") []
 
-Notice the use of lexically scoped type variables.
+We are passed the Typeable2 class as well as T
 
 \begin{code}
 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
 gen_Typeable_binds tycon
   = unitBag $
-       mk_easy_FunBind tycon_loc typeOf_RDR [wildPat] emptyBag
-               (nlHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
+       mk_easy_FunBind tycon_loc 
+               (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
+               [nlWildPat] emptyLHsBinds
+               (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
   where
     tycon_loc = getSrcSpan tycon
-    tyvars    = tyConTyVars tycon
     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
-    arg_reps  = nlList (map mk tyvars)
-    mk tyvar  = nlHsApp (nlHsVar typeOf_RDR) 
-                     (noLoc (ExprWithTySig (nlHsVar undefined_RDR)
-                                           (nlHsTyVar (getRdrName tyvar))))
+
+mk_typeOf_RDR :: TyCon -> RdrName
+-- Use the arity of the TyCon to make the right typeOfn function
+mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
+               where
+                 arity = tyConArity tycon
+                 suffix | arity == 0 = ""
+                        | otherwise  = show arity
 \end{code}
 
 
@@ -1030,19 +1034,20 @@ From the data type
 
 we generate
 
-  $cT1 = mkConstr 1 "T1" Prefix
-  $cT2 = mkConstr 2 "T2" Prefix
-  $dT  = mkDataType [$con_T1, $con_T2]
+  $cT1 = mkDataCon $dT "T1" Prefix
+  $cT2 = mkDataCon $dT "T2" Prefix
+  $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
+  -- the [] is for field labels.
 
   instance (Data a, Data b) => Data (T a b) where
     gfoldl k z (T1 a b) = z T `k` a `k` b
     gfoldl k z T2          = z T2
     -- ToDo: add gmapT,Q,M, gfoldr
-    
-    fromConstr c = case conIndex c of
-                       I# 1# -> T1 undefined undefined
-                       I# 2# -> T2
-    
+    gunfold k z c = case conIndex c of
+                       I# 1# -> k (k (z T1))
+                       I# 2# -> z T2
+
     toConstr (T1 _ _) = $cT1
     toConstr T2              = $cT2
     
@@ -1054,13 +1059,15 @@ gen_Data_binds :: FixityEnv
               -> (LHsBinds RdrName,    -- The method bindings
                   LHsBinds RdrName)    -- Auxiliary bindings
 gen_Data_binds fix_env tycon
-  = (listToBag [gfoldl_bind, fromCon_bind, toCon_bind, dataTypeOf_bind],
+  = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
                -- 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)
@@ -1072,52 +1079,83 @@ gen_Data_binds fix_env tycon
                     as_needed = take (dataConSourceArity con) as_RDRs
                     mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
 
-       ------------ fromConstr
-    fromCon_bind = mk_FunBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)]
-    from_con_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) 
-                         (map from_con_alt data_cons)
-    from_con_alt dc = mkSimpleHsAlt (nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger (dataConTag dc)))])
-                                   (nlHsVarApps (getRdrName dc)
-                                                (replicate (dataConSourceArity dc) undefined_RDR))
+       ------------ gunfold
+    gunfold_bind = mk_FunBind tycon_loc
+                              gunfold_RDR
+                              [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], 
+                               gunfold_rhs)]
+
+    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_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)
     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
     
        ------------ dataTypeOf
-    dataTypeOf_bind = mk_easy_FunBind tycon_loc dataTypeOf_RDR [wildPat] 
-                                         emptyBag (nlHsVar data_type_name)
+    dataTypeOf_bind = mk_easy_FunBind
+                        tycon_loc
+                        dataTypeOf_RDR
+                       [nlWildPat]
+                        emptyLHsBinds
+                        (nlHsVar data_type_name)
 
        ------------ $dT
+
     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
-    datatype_bind  = mkVarBind tycon_loc data_type_name
-                                  (nlHsVar mkDataType_RDR `nlHsApp` 
-                                   nlList constrs)
+    datatype_bind  = mkVarBind
+                       tycon_loc
+                       data_type_name
+                      (           nlHsVar mkDataType_RDR 
+                         `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
+                         `nlHsApp` nlList constrs
+                       )
     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
 
 
        ------------ $cT1 etc
     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
-    mk_con_bind dc = mkVarBind tycon_loc (mk_constr_name dc) 
-                                            (nlHsApps mkConstr_RDR (constr_args dc))
-    constr_args dc = [nlHsIntLit (toInteger (dataConTag dc)),          -- Tag
-                     nlHsLit (mkHsString (occNameUserString dc_occ)),  -- String name
-                     nlHsVar fixity]                                   -- Fixity
+    mk_con_bind dc = mkVarBind
+                       tycon_loc
+                       (mk_constr_name dc) 
+                      (nlHsApps mkConstr_RDR (constr_args dc))
+    constr_args dc =
+        [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
+          nlHsVar data_type_name,                              -- DataType
+          nlHsLit (mkHsString (occNameUserString dc_occ)),     -- String name
+           nlList  labels,                                     -- Field labels
+          nlHsVar fixity]                                      -- Fixity
        where
+          labels   = map (nlHsLit . mkHsString . getOccString)
+                         (dataConFieldLabels dc)
          dc_occ   = getOccName dc
          is_infix = isDataSymOcc dc_occ
          fixity | is_infix  = infix_RDR
                 | otherwise = prefix_RDR
 
-gfoldl_RDR     = varQual_RDR gENERICS_Name FSLIT("gfoldl")
-fromConstr_RDR = varQual_RDR gENERICS_Name FSLIT("fromConstr")
-toConstr_RDR   = varQual_RDR gENERICS_Name FSLIT("toConstr")
-dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
-mkConstr_RDR   = varQual_RDR gENERICS_Name FSLIT("mkConstr")
-mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
-conIndex_RDR   = varQual_RDR gENERICS_Name FSLIT("conIndex")
-prefix_RDR     = dataQual_RDR gENERICS_Name FSLIT("Prefix")
-infix_RDR      = dataQual_RDR gENERICS_Name FSLIT("Infix")
+gfoldl_RDR     = varQual_RDR gENERICS FSLIT("gfoldl")
+gunfold_RDR    = varQual_RDR gENERICS FSLIT("gunfold")
+toConstr_RDR   = varQual_RDR gENERICS FSLIT("toConstr")
+dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
+mkConstr_RDR   = varQual_RDR gENERICS FSLIT("mkConstr")
+mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
+conIndex_RDR   = varQual_RDR gENERICS FSLIT("constrIndex")
+prefix_RDR     = dataQual_RDR gENERICS FSLIT("Prefix")
+infix_RDR      = dataQual_RDR gENERICS FSLIT("Infix")
 \end{code}
 
 %************************************************************************
@@ -1303,9 +1341,8 @@ eq_Expr tycon ty a b = genOpApp a eq_op b
  where
    eq_op
     | not (isUnLiftedType ty) = eq_RDR
-    | otherwise               =
+    | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
          -- we have to do something special for primitive things...
-       primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
 \end{code}
 
 \begin{code}
@@ -1417,6 +1454,8 @@ a_Pat             = nlVarPat a_RDR
 b_Pat          = nlVarPat b_RDR
 c_Pat          = nlVarPat c_RDR
 d_Pat          = nlVarPat d_RDR
+k_Pat          = nlVarPat k_RDR
+z_Pat          = nlVarPat z_RDR
 
 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon ->  RdrName
 -- Generates Orig s RdrName, for the binding positions