[project @ 2003-07-24 15:27:27 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcGenDeriv.lhs
index 2ddc307..210710e 100644 (file)
@@ -17,6 +17,8 @@ module TcGenDeriv (
        gen_Ord_binds,
        gen_Read_binds,
        gen_Show_binds,
+       gen_Data_binds,
+       gen_Typeable_binds,
        gen_tag_n_con_monobind,
 
        con2tag_RDR, tag2con_RDR, maxtag_RDR,
@@ -26,15 +28,15 @@ module TcGenDeriv (
 
 #include "HsVersions.h"
 
-import HsSyn           ( InPat(..), HsExpr(..), MonoBinds(..),
+import HsSyn           ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..),
                          Match(..), GRHSs(..), Stmt(..), HsLit(..),
-                         HsBinds(..), HsType(..), HsDoContext(..),
-                         unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList
+                         HsBinds(..), HsType(..), HsStmtContext(..),
+                         unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
                        )
-import RdrHsSyn                ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
-import RdrName         ( RdrName, mkUnqual )
+import RdrName         ( RdrName, mkUnqual, mkRdrUnqual, nameRdrName, getRdrName )
+import RdrHsSyn                ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
 import BasicTypes      ( RecFlag(..), Fixity(..), FixityDirection(..)
-                       , maxPrecedence, defaultFixity
+                       , maxPrecedence
                        , Boxity(..)
                        )
 import FieldLabel       ( fieldLabelName )
@@ -43,30 +45,30 @@ import DataCon              ( isNullaryDataCon, dataConTag,
                          DataCon, 
                          dataConFieldLabels )
 import Name            ( getOccString, getOccName, getSrcLoc, occNameString, 
-                         occNameUserString, nameRdrName, varName,
+                         occNameUserString, varName,
                          Name, NamedThing(..), 
                          isDataSymOcc, isSymOcc
                        )
 
-import PrelInfo                -- Lots of RdrNames
+import HscTypes                ( FixityEnv, lookupFixity )
+import PrelNames       -- Lots of Names
+import PrimOp          -- Lots of Names
 import SrcLoc          ( generatedSrcLoc, SrcLoc )
 import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
-                         maybeTyConSingleCon, tyConFamilySize
+                         maybeTyConSingleCon, tyConFamilySize, tyConTyVars
                        )
 import TcType          ( isUnLiftedType, tcEqType, Type )
-import TysPrim         ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
-                         floatPrimTy, doublePrimTy
-                       )
-import Util            ( mapAccumL, zipEqual, zipWithEqual,
-                         zipWith3Equal, nOfThem )
+import TysPrim         ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy )
+import TysWiredIn      ( charDataCon, intDataCon, floatDataCon, doubleDataCon, wordDataCon )
+import Util            ( zipWithEqual, isSingleton,
+                         zipWith3Equal, nOfThem, zipEqual )
 import Panic           ( panic, assertPanic )
-import Maybes          ( maybeToBool, orElse )
+import Char            ( ord, isAlpha )
 import Constants
 import List            ( partition, intersperse )
-
-#if __GLASGOW_HASKELL__ >= 404
-import GlaExts         ( fromInt )
-#endif
+import Outputable
+import FastString
+import OccName
 \end{code}
 
 %************************************************************************
@@ -149,22 +151,6 @@ instance ... Eq (Foo ...) where
 \end{itemize}
 
 
-deriveEq :: RdrName                            -- Class
-        -> RdrName                             -- Type constructor
-        -> [ (RdrName, [RdrType]) ]    -- Constructors
-        -> (RdrContext,                -- Context for the inst decl
-            [RdrBind],                 -- Binds in the inst decl
-            [RdrBind])                 -- Extra value bindings outside
-
-deriveEq clas tycon constrs 
-  = (context, [eq_bind, ne_bind], [])
-  where
-    context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
-
-    ne_bind = mkBind 
-    (nullary_cons, non_nullary_cons) = partition is_nullary constrs
-    is_nullary (_, args) = null args
-
 \begin{code}
 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
 
@@ -184,20 +170,20 @@ gen_Eq_binds tycon
            else -- calc. and compare the tags
                 [([a_Pat, b_Pat],
                    untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
-                     (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
+                              (genOpApp (HsVar ah_RDR) eqInt_RDR (HsVar bh_RDR)))]
     in
     mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
            `AndMonoBinds`
     mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
-       HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
+       HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
   where
     ------------------------------------------------------------------
     pats_etc data_con
       = let
-           con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
-           con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
+           con1_pat = mkConPat data_con_RDR as_needed
+           con2_pat = mkConPat data_con_RDR bs_needed
 
-           data_con_RDR = qual_orig_name data_con
+           data_con_RDR = getRdrName data_con
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs
@@ -209,7 +195,7 @@ gen_Eq_binds tycon
        nested_eq_expr tys as bs
          = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
          where
-           nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
+           nested_eq ty a b = HsPar (eq_Expr tycon ty (HsVar a) (HsVar b))
 \end{code}
 
 %************************************************************************
@@ -318,100 +304,64 @@ gen_Ord_binds tycon
     tycon_loc = getSrcLoc tycon
     --------------------------------------------------------------------
     compare = mk_easy_FunMonoBind tycon_loc compare_RDR
-               [a_Pat, b_Pat]
-               [cmp_eq]
-           (if maybeToBool (maybeTyConSingleCon tycon) then
-
---             cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
--- Weird.  Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
-
-               cmp_eq_Expr a_Expr b_Expr
-            else
-               untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
-                 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
-                       -- True case; they are equal
-                       -- If an enumeration type we are done; else
-                       -- recursively compare their components
-                   (if isEnumerationTyCon tycon then
-                       eqTag_Expr
-                    else
---                     cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
--- Ditto
-                       cmp_eq_Expr a_Expr b_Expr
-                   )
+                                 [a_Pat, b_Pat] [cmp_eq] compare_rhs
+    compare_rhs
+       | single_con_type = cmp_eq_Expr a_Expr b_Expr
+       | otherwise
+       = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
+                 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
+                       (cmp_eq_Expr a_Expr b_Expr)     -- True case
                        -- False case; they aren't equal
                        -- So we need to do a less-than comparison on the tags
-                   (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
+                       (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
 
     tycon_data_cons = tyConDataCons tycon
+    single_con_type = isSingleton tycon_data_cons
     (nullary_cons, nonnullary_cons)
        | isNewTyCon tycon = ([], tyConDataCons tycon)
        | otherwise       = partition isNullaryDataCon tycon_data_cons
 
-    cmp_eq =
-       mk_FunMonoBind tycon_loc 
-                      cmp_eq_RDR 
-                      (if null nonnullary_cons && (length nullary_cons == 1) then
-                          -- catch this specially to avoid warnings
-                          -- about overlapping patterns from the desugarer.
-                         let 
-                          data_con     = head nullary_cons
-                          data_con_RDR = qual_orig_name data_con
-                           pat          = ConPatIn data_con_RDR []
-                          in
-                         [([pat,pat], eqTag_Expr)]
-                      else
-                         map pats_etc nonnullary_cons ++
-                         -- leave out wildcards to silence desugarer.
-                         (if length tycon_data_cons == 1 then
-                             []
-                          else
-                              [([WildPatIn, WildPatIn], default_rhs)]))
+    cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR cmp_eq_match
+    cmp_eq_match
+      | isEnumerationTyCon tycon
+                          -- We know the tags are equal, so if it's an enumeration TyCon,
+                          -- then there is nothing left to do
+                          -- Catch this specially to avoid warnings
+                          -- about overlapping patterns from the desugarer,
+                          -- and to avoid unnecessary pattern-matching
+      = [([wildPat,wildPat], 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)])
+
       where
        pats_etc data_con
          = ([con1_pat, con2_pat],
             nested_compare_expr tys_needed as_needed bs_needed)
          where
-           con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
-           con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
+           con1_pat = mkConPat data_con_RDR as_needed
+           con2_pat = mkConPat data_con_RDR bs_needed
 
-           data_con_RDR = qual_orig_name data_con
+           data_con_RDR = getRdrName data_con
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs
            tys_needed  = dataConOrigArgTys data_con
 
            nested_compare_expr [ty] [a] [b]
-             = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
+             = careful_compare_Case tycon ty eqTag_Expr (HsVar a) (HsVar b)
 
            nested_compare_expr (ty:tys) (a:as) (b:bs)
              = let eq_expr = nested_compare_expr tys as bs
-               in  careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
+               in  careful_compare_Case tycon ty eq_expr (HsVar a) (HsVar b)
 
        default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
                                                                -- inexhaustive patterns
                    | otherwise         = eqTag_Expr            -- Some nullary constructors;
                                                                -- Tags are equal, no args => return EQ
-    --------------------------------------------------------------------
-
-{- Not necessary: the default decls in PrelBase handle these 
-
-defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
-
-lt = mk_easy_FunMonoBind generatedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
-           compare_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
-le = mk_easy_FunMonoBind generatedSrcLoc le_RDR [a_Pat, b_Pat] [] (
-           compare_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
-ge = mk_easy_FunMonoBind generatedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
-           compare_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
-gt = mk_easy_FunMonoBind generatedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
-           compare_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
-
-max_ = mk_easy_FunMonoBind generatedSrcLoc max_RDR [a_Pat, b_Pat] [] (
-           compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
-min_ = mk_easy_FunMonoBind generatedSrcLoc min_RDR [a_Pat, b_Pat] [] (
-           compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
--}
 \end{code}
 
 %************************************************************************
@@ -472,68 +422,60 @@ gen_Enum_binds tycon
     succ_enum
       = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
        untag_Expr tycon [(a_RDR, ah_RDR)] $
-       HsIf (HsApp (HsApp (HsVar eq_RDR) 
-                          (HsVar (maxtag_RDR tycon)))
-                          (mk_easy_App mkInt_RDR [ah_RDR]))
+       HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
+                              mkHsVarApps mkInt_RDR [ah_RDR]])
             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
             (HsApp (HsVar (tag2con_RDR tycon))
-                   (HsApp (HsApp (HsVar plus_RDR)
-                                 (mk_easy_App mkInt_RDR [ah_RDR]))
-                          (HsLit (HsInt 1))))
+                   (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
+                                       mkHsIntLit 1]))
             tycon_loc
                    
     pred_enum
       = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
        untag_Expr tycon [(a_RDR, ah_RDR)] $
-       HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
-                   (mk_easy_App mkInt_RDR [ah_RDR]))
+       HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
+                              mkHsVarApps mkInt_RDR [ah_RDR]])
             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
             (HsApp (HsVar (tag2con_RDR tycon))
-                          (HsApp (HsApp (HsVar plus_RDR)
-                                        (mk_easy_App mkInt_RDR [ah_RDR]))
-                                 (HsLit (HsInt (-1)))))
+                          (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
+                                              HsLit (HsInt (-1))]))
             tycon_loc
 
     to_enum
       = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
-       HsIf (HsApp (HsApp 
-                   (HsVar and_RDR)
-                   (HsApp (HsApp (HsVar ge_RDR)
-                                 (HsVar a_RDR))
-                                 (HsLit (HsInt 0))))
-                    (HsApp (HsApp (HsVar le_RDR)
-                                 (HsVar a_RDR))
-                                 (HsVar (maxtag_RDR tycon))))
-             (mk_easy_App (tag2con_RDR tycon) [a_RDR])
+       HsIf (mkHsApps and_RDR
+               [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
+                 mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
+             (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
             tycon_loc
 
     enum_from
       = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
          untag_Expr tycon [(a_RDR, ah_RDR)] $
-         HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
-           HsPar (enum_from_to_Expr
-                   (mk_easy_App mkInt_RDR [ah_RDR])
-                   (HsVar (maxtag_RDR tycon)))
+         mkHsApps map_RDR 
+               [HsVar (tag2con_RDR tycon),
+                HsPar (enum_from_to_Expr
+                           (mkHsVarApps mkInt_RDR [ah_RDR])
+                           (HsVar (maxtag_RDR tycon)))]
 
     enum_from_then
       = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
          untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
-         HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
+         HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
            HsPar (enum_from_then_to_Expr
-                   (mk_easy_App mkInt_RDR [ah_RDR])
-                   (mk_easy_App mkInt_RDR [bh_RDR])
-                   (HsIf  (HsApp (HsApp (HsVar gt_RDR)
-                                        (mk_easy_App mkInt_RDR [ah_RDR]))
-                                        (mk_easy_App mkInt_RDR [bh_RDR]))
-                          (HsLit (HsInt 0))
+                   (mkHsVarApps mkInt_RDR [ah_RDR])
+                   (mkHsVarApps mkInt_RDR [bh_RDR])
+                   (HsIf  (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
+                                            mkHsVarApps mkInt_RDR [bh_RDR]])
+                          (mkHsIntLit 0)
                           (HsVar (maxtag_RDR tycon))
                           tycon_loc))
 
     from_enum
       = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
          untag_Expr tycon [(a_RDR, ah_RDR)] $
-         (mk_easy_App mkInt_RDR [ah_RDR])
+         (mkHsVarApps mkInt_RDR [ah_RDR])
 \end{code}
 
 %************************************************************************
@@ -547,28 +489,28 @@ gen_Bounded_binds tycon
   = if isEnumerationTyCon tycon then
        min_bound_enum `AndMonoBinds` max_bound_enum
     else
-       ASSERT(length data_cons == 1)
+       ASSERT(isSingleton data_cons)
        min_bound_1con `AndMonoBinds` max_bound_1con
   where
     data_cons = tyConDataCons tycon
     tycon_loc = getSrcLoc tycon
 
     ----- enum-flavored: ---------------------------
-    min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
-    max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
+    min_bound_enum = mkVarMonoBind tycon_loc minBound_RDR (HsVar data_con_1_RDR)
+    max_bound_enum = mkVarMonoBind tycon_loc maxBound_RDR (HsVar data_con_N_RDR)
 
     data_con_1   = head data_cons
     data_con_N   = last data_cons
-    data_con_1_RDR = qual_orig_name data_con_1
-    data_con_N_RDR = qual_orig_name data_con_N
+    data_con_1_RDR = getRdrName data_con_1
+    data_con_N_RDR = getRdrName data_con_N
 
     ----- single-constructor-flavored: -------------
     arity         = dataConSourceArity data_con_1
 
-    min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
-                    mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
-    max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
-                    mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
+    min_bound_1con = mkVarMonoBind tycon_loc minBound_RDR $
+                    mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
+    max_bound_1con = mkVarMonoBind tycon_loc maxBound_RDR $
+                    mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 \end{code}
 
 %************************************************************************
@@ -646,42 +588,42 @@ gen_Ix_binds tycon
 
     enum_range
       = mk_easy_FunMonoBind tycon_loc range_RDR 
-               [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
+               [TuplePat [a_Pat, b_Pat] Boxed] [] $
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          untag_Expr tycon [(b_RDR, bh_RDR)] $
-         HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
+         HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
              HsPar (enum_from_to_Expr
-                       (mk_easy_App mkInt_RDR [ah_RDR])
-                       (mk_easy_App mkInt_RDR [bh_RDR]))
+                       (mkHsVarApps mkInt_RDR [ah_RDR])
+                       (mkHsVarApps mkInt_RDR [bh_RDR]))
 
     enum_index
       = mk_easy_FunMonoBind tycon_loc index_RDR 
-               [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed), 
+               [AsPat c_RDR (TuplePat [a_Pat, wildPat] Boxed), 
                                d_Pat] [] (
-       HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
+       HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
           untag_Expr tycon [(a_RDR, ah_RDR)] (
           untag_Expr tycon [(d_RDR, dh_RDR)] (
           let
-               rhs = mk_easy_App mkInt_RDR [c_RDR]
+               rhs = mkHsVarApps mkInt_RDR [c_RDR]
           in
           HsCase
-            (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
-            [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc]
+            (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR))
+            [mk_triv_Match (VarPat c_RDR) rhs]
             tycon_loc
           ))
        ) {-else-} (
-          HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
+          HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
        )
        tycon_loc)
 
     enum_inRange
       = mk_easy_FunMonoBind tycon_loc inRange_RDR 
-         [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
+         [TuplePat [a_Pat, b_Pat] Boxed, c_Pat] [] (
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
-         HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
-            (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
+         HsIf (genOpApp (HsVar ch_RDR) geInt_RDR (HsVar ah_RDR)) (
+            (genOpApp (HsVar ch_RDR) leInt_RDR (HsVar bh_RDR))
          ) {-else-} (
             false_Expr
          ) tycon_loc))))
@@ -695,32 +637,31 @@ gen_Ix_binds tycon
     data_con
       =        case maybeTyConSingleCon tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
-         Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
-                        error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
-                    else
-                        dc
+         Just dc | any isUnLiftedType (dataConOrigArgTys dc)
+                 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
+                 | otherwise -> dc
 
     con_arity    = dataConSourceArity data_con
-    data_con_RDR = qual_orig_name data_con
+    data_con_RDR = getRdrName data_con
 
     as_needed = take con_arity as_RDRs
     bs_needed = take con_arity bs_RDRs
     cs_needed = take con_arity cs_RDRs
 
-    con_pat  xs  = ConPatIn data_con_RDR (map VarPatIn xs)
-    con_expr     = mk_easy_App data_con_RDR cs_needed
+    con_pat  xs  = mkConPat data_con_RDR xs
+    con_expr     = mkHsVarApps data_con_RDR cs_needed
 
     --------------------------------------------------------------
     single_con_range
       = mk_easy_FunMonoBind tycon_loc range_RDR 
-         [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
-       HsDo ListComp stmts tycon_loc
+         [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $
+       mkHsDo ListComp stmts tycon_loc
       where
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
                ++
                [ResultStmt con_expr tycon_loc]
 
-       mk_qual a b c = BindStmt (VarPatIn c)
+       mk_qual a b c = BindStmt (VarPat c)
                                 (HsApp (HsVar range_RDR) 
                                        (ExplicitTuple [HsVar a, HsVar b] Boxed))
                                 tycon_loc
@@ -728,14 +669,14 @@ gen_Ix_binds tycon
     ----------------
     single_con_index
       = mk_easy_FunMonoBind tycon_loc index_RDR 
-               [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, 
+               [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed, 
                 con_pat cs_needed] [range_size] (
-       foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
+       foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
       where
        mk_index multiply_by (l, u, i)
          = genOpApp (
-              (HsApp (HsApp (HsVar index_RDR) 
-                     (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
+              (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,  
+                                   HsVar i])
           ) plus_RDR (
                genOpApp (
                    (HsApp (HsVar rangeSize_RDR) 
@@ -745,23 +686,22 @@ gen_Ix_binds tycon
 
        range_size
          = mk_easy_FunMonoBind tycon_loc rangeSize_RDR 
-                       [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
+                       [TuplePat [a_Pat, b_Pat] Boxed] [] (
                genOpApp (
-                   (HsApp (HsApp (HsVar index_RDR) 
-                          (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
-               ) plus_RDR (HsLit (HsInt 1)))
+                   (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
+                                        b_Expr])
+               ) plus_RDR (mkHsIntLit 1))
 
     ------------------
     single_con_inRange
       = mk_easy_FunMonoBind tycon_loc inRange_RDR 
-               [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, 
+               [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed, 
                 con_pat cs_needed]
                           [] (
          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
       where
-       in_range a b c = HsApp (HsApp (HsVar inRange_RDR) 
-                                     (ExplicitTuple [HsVar a, HsVar b] Boxed)) 
-                              (HsVar c)
+       in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
+                                              HsVar c]
 \end{code}
 
 %************************************************************************
@@ -770,312 +710,437 @@ gen_Ix_binds tycon
 %*                                                                     *
 %************************************************************************
 
+Example
+
+  infix 4 %%
+  data T = Int %% Int
+        | T1 { f1 :: Int }
+        | T2 Int
+
+
+instance Read T where
+  readPrec =
+    parens
+    ( prec 4 (
+        do x           <- ReadP.step Read.readPrec
+           Symbol "%%" <- Lex.lex
+           y           <- ReadP.step Read.readPrec
+           return (x %% y))
+      +++
+      prec appPrec (
+       do Ident "T1" <- Lex.lex
+          Punc '{' <- Lex.lex
+          Ident "f1" <- Lex.lex
+          Punc '=' <- Lex.lex
+          x          <- ReadP.reset Read.readPrec
+          Punc '}' <- Lex.lex
+          return (T1 { f1 = x }))
+      +++
+      prec appPrec (
+        do Ident "T2" <- Lex.lexP
+           x          <- ReadP.step Read.readPrec
+           return (T2 x))
+    )
+
+  readListPrec = readListPrecDefault
+  readList     = readListDefault
+
+
 \begin{code}
-gen_Read_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
+gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
 
 gen_Read_binds get_fixity tycon
-  = reads_prec `AndMonoBinds` read_list
+  = read_prec `AndMonoBinds` default_binds
   where
-    tycon_loc = getSrcLoc tycon
     -----------------------------------------------------------------------
-    read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
-                 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
+    default_binds 
+       = mkVarMonoBind loc readList_RDR     (HsVar readListDefault_RDR)
+               `AndMonoBinds`
+         mkVarMonoBind loc readListPrec_RDR (HsVar readListPrecDefault_RDR)
     -----------------------------------------------------------------------
-    reads_prec
-      = let
-           read_con_comprehensions
-             = map read_con (tyConDataCons tycon)
-       in
-       mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
-             foldr1 append_Expr read_con_comprehensions
-       )
+
+    loc       = getSrcLoc tycon
+    data_cons = tyConDataCons tycon
+    (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
+    
+    read_prec = mkVarMonoBind loc readPrec_RDR
+                             (HsApp (HsVar parens_RDR) read_cons)
+
+    read_cons            = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
+    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
+    
+    read_nullary_cons 
+      = case nullary_cons of
+           []    -> []
+           [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
+                                    result_stmt con []] loc]
+            _     -> [HsApp (HsVar choose_RDR) 
+                           (ExplicitList placeHolderType (map mk_pair nullary_cons))]
+    
+    mk_pair con = ExplicitTuple [HsLit (data_con_str con),
+                                HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))]
+                               Boxed
+    
+    read_non_nullary_con data_con
+      = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
       where
-       read_con data_con   -- note: "b" is the string being "read"
-         = HsApp (
-             readParen_Expr read_paren_arg $ HsPar $
-                HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
-                       HsDo ListComp stmts tycon_loc)
-             ) (HsVar b_RDR)
-         where
-          data_con_RDR = qual_orig_name data_con
-          data_con_str = occNameUserString (getOccName data_con)
-          con_arity    = dataConSourceArity data_con
-          con_expr     = mk_easy_App data_con_RDR as_needed
-          nullary_con  = con_arity == 0
-          labels       = dataConFieldLabels data_con
-          lab_fields   = length labels
-          dc_nm        = getName data_con
-          is_infix     = isDataSymOcc (getOccName dc_nm)
-
-          as_needed    = take con_arity as_RDRs
-          bs_needed   
-            | is_infix        = take (1 + con_arity) bs_RDRs
-            | lab_fields == 0 = take con_arity bs_RDRs
-            | otherwise       = take (4*lab_fields + 1) bs_RDRs
-                                 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
-
-          (as1:as2:_)     = as_needed
-          (bs1:bs2:bs3:_) = bs_needed
-
-          con_qual 
-            | not is_infix =
-                 BindStmt
-                 (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
-                 (HsApp (HsVar lex_RDR) c_Expr)
-                 tycon_loc
-            | otherwise    =
-                 BindStmt
-                 (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
-                 (HsApp (HsVar lex_RDR) (HsVar bs1))
-                 tycon_loc
-               
-
-          str_qual str res draw_from =
-               BindStmt
-                 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
-                 (HsApp (HsVar lex_RDR) draw_from)
-                 tycon_loc
-  
-          str_qual_paren str res draw_from =
-               BindStmt
-                 (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
-                 (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
-                 tycon_loc
-  
-          read_label f = [rd_lab, str_qual "="] 
-                           -- There might be spaces between the label and '='
-               where
-                 rd_lab
-                  | is_op      = str_qual_paren nm
-                  | otherwise  = str_qual nm
-
-                 occ_nm  = getOccName (fieldLabelName f)
-                 is_op   = isSymOcc occ_nm
-                 nm      = occNameUserString occ_nm
-
-          field_quals
-             | is_infix  =
-                 snd (mapAccumL mk_qual_infix
-                                c_Expr
-                                [ (mk_read_qual lp as1, bs1, bs2)
-                                , (mk_read_qual rp as2, bs3, bs3)
-                                ])
-             | lab_fields == 0 =  -- common case.
-                 snd (mapAccumL mk_qual 
-                                d_Expr 
-                                (zipWithEqual "as_needed" 
-                                              (\ con_field draw_from -> (mk_read_qual 10 con_field,
-                                                                         draw_from))
-                                               as_needed bs_needed))
-              | otherwise =
-                 snd $
-                 mapAccumL mk_qual d_Expr
-                       (zipEqual "bs_needed"        
-                          ((str_qual "{":
-                            concat (
-                            intersperse [str_qual ","] $
-                            zipWithEqual 
-                               "field_quals"
-                               (\ as b -> as ++ [b])
-                                   -- The labels
-                               (map read_label labels)
-                                   -- The fields
-                               (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
-                           bs_needed)
-
-          mk_qual_infix draw_from (f, str_left, str_left2) =
-               (HsVar str_left2,       -- what to draw from down the line...
-                f str_left draw_from)
-
-          mk_qual draw_from (f, str_left) =
-               (HsVar str_left,        -- what to draw from down the line...
-                f str_left draw_from)
-
-          mk_read_qual p con_field res draw_from =
-             BindStmt
-                (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
-                (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
-                tycon_loc
-
-          result_expr = ExplicitTuple [con_expr, if null bs_needed 
-                                                   then d_Expr 
-                                                   else HsVar (last bs_needed)] Boxed
-
-           [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
-
-           quals
-           | is_infix  = let (h:t) = field_quals in (h:con_qual:t)
-           | otherwise = con_qual:field_quals
-
-          stmts = quals ++ [ResultStmt result_expr tycon_loc]
-               
-           {-
-             c.f. Figure 18 in Haskell 1.1 report.
-           -}
-          paren_prec_limit
-            | not is_infix  = defaultPrecedence
-            | otherwise     = getPrecedence get_fixity dc_nm
-
-          read_paren_arg   -- parens depend on precedence...
-           | nullary_con  = false_Expr -- it's optional.
-           | otherwise    = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
+               stmts | is_infix          = infix_stmts
+             | length labels > 0 = lbl_stmts
+             | otherwise         = prefix_stmts
+     
+               prefix_stmts            -- T a b c
+                 = [bindLex (ident_pat (data_con_str data_con))]
+                   ++ read_args
+                   ++ [result_stmt data_con as_needed]
+        
+               infix_stmts             -- a %% b
+                 = [read_a1, 
+            bindLex (symbol_pat (data_con_str data_con)),
+            read_a2,
+            result_stmt data_con [a1,a2]]
+     
+               lbl_stmts               -- T { f1 = a, f2 = b }
+                 = [bindLex (ident_pat (data_con_str data_con)),
+                    read_punc "{"]
+                   ++ concat (intersperse [read_punc ","] field_stmts)
+                   ++ [read_punc "}", result_stmt data_con as_needed]
+     
+               field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
+     
+               con_arity    = dataConSourceArity data_con
+               nullary_con  = con_arity == 0
+               labels       = dataConFieldLabels data_con
+               lab_fields   = length labels
+               dc_nm        = getName data_con
+               is_infix     = isDataSymOcc (getOccName dc_nm)
+               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
+       (a1:a2:_)           = as_needed
+               prec         = getPrec is_infix get_fixity dc_nm
+
+    ------------------------------------------------------------------------
+    --         Helpers
+    ------------------------------------------------------------------------
+    mk_alt e1 e2     = genOpApp e1 alt_RDR e2
+    bindLex pat             = BindStmt pat (HsVar lexP_RDR) loc
+    result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
+    con_app c as     = mkHsVarApps (getRdrName c) as
+    
+    punc_pat s   = ConPatIn punc_RDR  (PrefixCon [LitPat (mkHsString s)])        -- Punc 'c'
+    ident_pat s  = ConPatIn ident_RDR (PrefixCon [LitPat s])                     -- Ident "foo"
+    symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s])                    -- Symbol ">>"
+    
+    data_con_str con = mkHsString (occNameUserString (getOccName con))
+    
+    read_punc c = bindLex (punc_pat c)
+    read_arg a ty 
+       | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
+       | otherwise = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
+    
+    read_field lbl a = read_lbl lbl ++
+                      [read_punc "=",
+                       BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
+
+       -- When reading field labels we might encounter
+       --      a  = 3
+       --      _a = 3
+       -- or   (#) = 4
+       -- Note the parens!
+    read_lbl lbl | is_id_start (head lbl_str) 
+                = [bindLex (ident_pat lbl_lit)]
+                | otherwise
+                = [read_punc "(", 
+                   bindLex (symbol_pat lbl_lit),
+                   read_punc ")"]
+                where  
+                  lbl_str = occNameUserString (getOccName (fieldLabelName lbl)) 
+                  lbl_lit = mkHsString lbl_str
+                  is_id_start c = isAlpha c || c == '_'
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsubsection{Generating @Show@ instance declarations}
 %*                                                                     *
 %************************************************************************
 
+Example
+
+    infixr 5 :^:
+
+    data Tree a =  Leaf a  |  Tree a :^: Tree a
+
+    instance (Show a) => Show (Tree a) where
+
+        showsPrec d (Leaf m) = showParen (d > app_prec) showStr
+          where
+             showStr = showString "Leaf " . showsPrec (app_prec+1) m
+
+        showsPrec d (u :^: v) = showParen (d > up_prec) showStr
+          where
+             showStr = showsPrec (up_prec+1) u . 
+                       showString " :^: "      .
+                       showsPrec (up_prec+1) v
+                -- Note: right-associativity of :^: ignored
+
+    up_prec  = 5    -- Precedence of :^:
+    app_prec = 10   -- Application has precedence one more than
+                   -- the most tightly-binding operator
+
 \begin{code}
-gen_Show_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
+gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
 
 gen_Show_binds get_fixity tycon
   = shows_prec `AndMonoBinds` show_list
   where
     tycon_loc = getSrcLoc tycon
     -----------------------------------------------------------------------
-    show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
-                 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
+    show_list = mkVarMonoBind tycon_loc showList_RDR
+                 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
     -----------------------------------------------------------------------
     shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
       where
        pats_etc data_con
          | nullary_con =  -- skip the showParen junk...
             ASSERT(null bs_needed)
-            ([wildPat, con_pat], show_con)
+            ([wildPat, con_pat], mk_showString_app con_str)
          | otherwise   =
             ([a_Pat, con_pat],
-                 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
+                 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
                                 (HsPar (nested_compose_Expr show_thingies)))
            where
-            data_con_RDR = qual_orig_name data_con
-            con_arity    = dataConSourceArity data_con
-            bs_needed    = take con_arity bs_RDRs
-            con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
-            nullary_con  = con_arity == 0
-             labels       = dataConFieldLabels data_con
-            lab_fields   = length labels
+            data_con_RDR  = getRdrName data_con
+            con_arity     = dataConSourceArity data_con
+            bs_needed     = take con_arity bs_RDRs
+            arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
+            con_pat       = mkConPat data_con_RDR bs_needed
+            nullary_con   = con_arity == 0
+             labels        = dataConFieldLabels data_con
+            lab_fields    = length labels
+            record_syntax = lab_fields > 0
 
             dc_nm          = getName data_con
             dc_occ_nm      = getOccName data_con
-             dc_occ_nm_str  = occNameUserString dc_occ_nm
-
-            is_infix     = isDataSymOcc dc_occ_nm
-
+             con_str        = occNameUserString dc_occ_nm
 
-            show_con
-              | is_infix  = mk_showString_app (' ':dc_occ_nm_str)
-              | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
-                where
-                 space_ocurly_maybe
-                    | nullary_con     = ""
-                   | lab_fields == 0 = " "
-                   | otherwise       = "{"
-                
-
-            show_all con fs@(x:xs)
-               | is_infix  = x:con:xs
-               | otherwise = 
-                 let
-                    ccurly_maybe 
-                      | lab_fields > 0  = [mk_showString_app "}"]
-                      | otherwise       = []
-                 in
-                 con:fs ++ ccurly_maybe
-
-            show_thingies = show_all show_con real_show_thingies_with_labs
+            show_thingies 
+               | is_infix      = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
+               | record_syntax = mk_showString_app (con_str ++ " {") : 
+                                 show_record_args ++ [mk_showString_app "}"]
+               | otherwise     = mk_showString_app (con_str ++ " ") : show_prefix_args
                 
-            show_label l = mk_showString_app (the_name ++ "=")
+            show_label l = mk_showString_app (the_name ++ " = ")
+                       -- 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)
-                   -- legal, but rare.
-                  is_op    = isSymOcc occ_nm
-                  the_name 
-                    | is_op     = '(':nm ++ ")"
-                    | otherwise = nm
-
                   nm       = occNameUserString occ_nm
-               
-
-             mk_showString_app str = HsApp (HsVar showString_RDR)
-                                          (HsLit (mkHsString str))
-
-             prec_cons = getLRPrecs is_infix get_fixity dc_nm
-
-             real_show_thingies
-               | is_infix  = 
-                    [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
-                    | (p,b) <- zip prec_cons bs_needed ]
-               | otherwise =
-                    [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
-                    | b <- bs_needed ]
-
-             real_show_thingies_with_labs
-               | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
-               | otherwise       = --Assumption: no of fields == no of labelled fields 
-                                    --            (and in same order)
-                   concat $
-                   intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
-                   zipWithEqual "gen_Show_binds"
-                                (\ a b -> [a,b])
-                                (map show_label labels) 
-                                real_show_thingies
+                  is_op    = isSymOcc occ_nm       -- Legal, but rare.
+                  the_name | is_op     = '(':nm ++ ")"
+                           | otherwise = nm
+
+             show_args                      = zipWith show_arg bs_needed arg_tys
+            (show_arg1:show_arg2:_) = show_args
+            show_prefix_args        = intersperse (HsVar showSpace_RDR) show_args
+
+               --  Assumption for record syntax: no of fields == no of labelled fields 
+               --            (and in same order)
+            show_record_args = concat $
+                               intersperse [mk_showString_app ", "] $
+                               [ [show_label lbl, arg] 
+                               | (lbl,arg) <- zipEqual "gen_Show_binds" 
+                                                       labels show_args ]
                               
-             {-
-               c.f. Figure 16 and 17 in Haskell 1.1 report
-             -}  
-            paren_prec_limit
-               | not is_infix = defaultPrecedence + 1
-               | otherwise    = getPrecedence get_fixity dc_nm + 1
-
+               -- Generates (showsPrec p x) for argument x, but it also boxes
+               -- the argument first if necessary.  Note that this prints unboxed
+               -- things without any '#' decorations; could change that if need be
+            show_arg b arg_ty = mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec), 
+                                                        box_if_necy "Show" tycon (HsVar b) arg_ty]
+
+               -- Fixity stuff
+            is_infix = isDataSymOcc dc_occ_nm
+             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
+
+mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
 \end{code}
 
 \begin{code}
-getLRPrecs :: Bool -> (Name -> Maybe Fixity) -> Name -> [Integer]
-getLRPrecs is_infix get_fixity nm = [lp, rp]
-    where
-     {-
-       Figuring out the fixities of the arguments to a constructor,
-       cf. Figures 16-18 in Haskell 1.1 report.
-     -}
-     (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
-     paren_con_prec = getPrecedence get_fixity nm
-
-     lp
-      | not is_infix   = defaultPrecedence + 1
-      | con_left_assoc = paren_con_prec
-      | otherwise      = paren_con_prec + 1
-                 
-     rp
-      | not is_infix    = defaultPrecedence + 1
-      | con_right_assoc = paren_con_prec
-      | otherwise       = paren_con_prec + 1
+getPrec :: Bool -> FixityEnv -> Name -> Integer
+getPrec is_infix get_fixity nm 
+  | not is_infix   = appPrecedence
+  | otherwise      = getPrecedence get_fixity nm
                  
-defaultPrecedence :: Integer
-defaultPrecedence = fromInt maxPrecedence
+appPrecedence :: Integer
+appPrecedence = fromIntegral maxPrecedence + 1
+  -- One more than the precedence of the most 
+  -- tightly-binding operator
 
-getPrecedence :: (Name -> Maybe Fixity) -> Name -> Integer
+getPrecedence :: FixityEnv -> Name -> Integer
 getPrecedence get_fixity nm 
-   = case get_fixity nm of
-        Just (Fixity x _) -> fromInt x
-        other            -> defaultPrecedence
+   = case lookupFixity get_fixity nm of
+        Fixity x _ -> fromIntegral x
 
-isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool)
+isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
 isLRAssoc get_fixity nm =
-     case get_fixity nm `orElse` defaultFixity of
+     case lookupFixity get_fixity nm of
        Fixity _ InfixN -> (False, False)
        Fixity _ InfixR -> (False, True)
        Fixity _ InfixL -> (True,  False)
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Typeable}
+%*                                                                     *
+%************************************************************************
+
+From the data type
+
+       data T a b = ....
 
-isInfixOccName :: String -> Bool
-isInfixOccName str = 
-   case str of
-     (':':_) -> True
-     _       -> False
+we generate
+
+       instance (Typeable a, Typeable b) => Typeable (T a b) where
+               typeOf _ = mkTypeRep (mkTyConRep "T")
+                                    [typeOf (undefined::a),
+                                     typeOf (undefined::b)]
+
+Notice the use of lexically scoped type variables.
+
+\begin{code}
+gen_Typeable_binds :: TyCon -> RdrNameMonoBinds
+gen_Typeable_binds tycon
+  = mk_easy_FunMonoBind tycon_loc typeOf_RDR [wildPat] []
+       (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
+  where
+    tycon_loc = getSrcLoc tycon
+    tyvars    = tyConTyVars tycon
+    tycon_rep = HsVar mkTyConRep_RDR `HsApp` HsLit (mkHsString (showSDoc (ppr tycon)))
+    arg_reps  = ExplicitList placeHolderType (map mk tyvars)
+    mk tyvar  = HsApp (HsVar typeOf_RDR) 
+                     (ExprWithTySig (HsVar undefined_RDR)
+                                    (HsTyVar (getRdrName tyvar)))
 \end{code}
 
 
+
+%************************************************************************
+%*                                                                     *
+\subsection{Data}
+%*                                                                     *
+%************************************************************************
+
+From the data type
+
+  data T a b = T1 a b | T2
+
+we generate
+
+  $cT1 = mkConstr 1 "T1" Prefix
+  $cT2 = mkConstr 2 "T2" Prefix
+  $dT  = mkDataType [$con_T1, $con_T2]
+
+  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
+    
+    toConstr (T1 _ _) = $cT1
+    toConstr T2              = $cT2
+    
+    dataTypeOf _ = $dT
+
+\begin{code}
+gen_Data_binds :: FixityEnv
+              -> TyCon 
+              -> (RdrNameMonoBinds,    -- The method bindings
+                  RdrNameMonoBinds)    -- Auxiliary bindings
+gen_Data_binds fix_env tycon
+  = (andMonoBindList [gfoldl_bind, fromCon_bind, toCon_bind, dataTypeOf_bind],
+               -- Auxiliary definitions: the data type and constructors
+     datatype_bind `AndMonoBinds` andMonoBindList (map mk_con_bind data_cons))
+  where
+    tycon_loc = getSrcLoc tycon
+    data_cons = tyConDataCons tycon
+
+       ------------ gfoldl
+    gfoldl_bind = mk_FunMonoBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
+    gfoldl_eqn con = ([VarPat k_RDR, VarPat z_RDR, mkConPat con_name as_needed], 
+                      foldl mk_k_app (HsVar z_RDR `HsApp` HsVar con_name) as_needed)
+                  where
+                    con_name :: RdrName
+                    con_name = getRdrName con
+                    as_needed = take (dataConSourceArity con) as_RDRs
+                    mk_k_app e v = HsPar (mkHsOpApp e k_RDR (HsVar v))
+
+       ------------ fromConstr
+    fromCon_bind = mk_FunMonoBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)]
+    from_con_rhs = HsCase (HsVar conIndex_RDR `HsApp` c_Expr) 
+                         (map from_con_alt data_cons) tycon_loc
+    from_con_alt dc = mk_triv_Match (ConPatIn mkInt_RDR (PrefixCon [LitPat (HsIntPrim (toInteger (dataConTag dc)))]))
+                                   (mkHsVarApps (getRdrName dc)
+                                                (replicate (dataConSourceArity dc) undefined_RDR))
+                         
+       ------------ toConstr
+    toCon_bind = mk_FunMonoBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
+    to_con_eqn dc = ([mkWildConPat dc], HsVar (mkConstrName dc))
+    
+       ------------ dataTypeOf
+    dataTypeOf_bind = mk_easy_FunMonoBind tycon_loc dataTypeOf_RDR [wildPat] 
+                                         [] (HsVar data_type_name)
+
+       ------------ $dT
+    data_type_name = mkDataTypeName tycon
+    datatype_bind  = mkVarMonoBind tycon_loc data_type_name
+                                  (HsVar mkDataType_RDR `HsApp` 
+                                   ExplicitList placeHolderType constrs)
+    constrs = [HsVar (mkConstrName con) | con <- data_cons]
+
+       ------------ $cT1 etc
+    mk_con_bind dc = mkVarMonoBind tycon_loc (mkConstrName dc) 
+                                            (mkHsApps mkConstr_RDR (constr_args dc))
+    constr_args dc = [mkHsIntLit (toInteger (dataConTag dc)),          -- Tag
+                     HsLit (mkHsString (occNameUserString dc_occ)),    -- String name
+                     HsVar fixity]                                     -- Fixity
+       where
+         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")
+
+mkDataTypeName :: TyCon -> RdrName     -- $tT
+mkDataTypeName tc = mkRdrUnqual (mkDataTOcc (getOccName tc))
+
+mkConstrName :: DataCon -> RdrName     -- $cT1
+mkConstrName con = mkRdrUnqual (mkDataCOcc (getOccName con))
+
+
+apN :: Int -> (a -> a) -> a -> a
+apN 0 k z = z
+apN n k z = apN (n-1) k (k z)
+\end{code}
+
 %************************************************************************
 %*                                                                     *
 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
@@ -1105,31 +1170,44 @@ gen_tag_n_con_monobind
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
   | lots_of_constructors
-  = mk_FunMonoBind (getSrcLoc tycon) rdr_name 
-       [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
+  = mk_FunMonoBind loc rdr_name [([], get_tag_rhs)]
 
   | otherwise
-  = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
+  = mk_FunMonoBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
 
   where
+    loc = getSrcLoc tycon
+
+       -- Give a signature to the bound variable, so 
+       -- that the case expression generated by getTag is
+       -- monomorphic.  In the push-enter model we get better code.
+    get_tag_rhs = ExprWithTySig 
+                       (HsLam (mk_match loc [VarPat a_RDR] 
+                                            (HsApp getTag_Expr a_Expr) 
+                                            EmptyBinds))
+                       (HsForAllTy Nothing [] con2tag_ty)
+                               -- Nothing => implicit quantification
+
+    con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon)) 
+                    [HsTyVar (getRdrName tv) | tv <- tyConTyVars tycon]
+               `HsFunTy` 
+               HsTyVar (getRdrName intPrimTyConName)
+
     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
 
     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
-    mk_stuff var
-      = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
-      where
-       pat    = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
-       var_RDR = qual_orig_name var
+    mk_stuff con = ([mkWildConPat con], 
+                   HsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
   = mk_FunMonoBind (getSrcLoc tycon) rdr_name 
-       [([ConPatIn mkInt_RDR [VarPatIn a_RDR]], 
+       [([mkConPat mkInt_RDR [a_RDR]], 
           ExprWithTySig (HsApp tagToEnum_Expr a_Expr) 
-                        (HsTyVar (qual_orig_name tycon)))]
+                        (HsTyVar (getRdrName tycon)))]
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
-  = mk_easy_FunMonoBind (getSrcLoc tycon) 
-               rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
+  = mkVarMonoBind (getSrcLoc tycon) rdr_name 
+                 (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
   where
     max_tag =  case (tyConDataCons tycon) of
                 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
@@ -1157,6 +1235,9 @@ multi-clause definitions; it generates:
 \end{verbatim}
 
 \begin{code}
+mkVarMonoBind :: SrcLoc -> RdrName -> RdrNameHsExpr -> RdrNameMonoBinds
+mkVarMonoBind loc var rhs = mk_easy_FunMonoBind loc var [] [] rhs
+
 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
                    -> [RdrNameMonoBinds] -> RdrNameHsExpr
                    -> RdrNameMonoBinds
@@ -1165,11 +1246,13 @@ mk_easy_FunMonoBind loc fun pats binds expr
   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
 
 mk_easy_Match loc pats binds expr
-  = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
+  = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds))
        -- The renamer expects everything in its input to be a
        -- "recursive" MonoBinds, and it is its job to sort things out
        -- from there.
 
+mk_triv_Match pat expr = mkSimpleMatch [pat] expr placeHolderType generatedSrcLoc
+
 mk_FunMonoBind :: SrcLoc -> RdrName
                -> [([RdrNamePat], RdrNameHsExpr)]
                -> RdrNameMonoBinds
@@ -1181,81 +1264,113 @@ mk_FunMonoBind loc fun pats_and_exprs
                loc
 
 mk_match loc pats expr binds
-  = Match [] (map paren pats) Nothing 
-         (GRHSs (unguardedRHS expr loc) binds Nothing)
+  = Match (map paren pats) Nothing 
+         (GRHSs (unguardedRHS expr loc) binds placeHolderType)
   where
-    paren p@(VarPatIn _) = p
-    paren other_p       = ParPatIn other_p
+    paren p@(VarPat _) = p
+    paren other_p      = ParPat other_p
 \end{code}
 
 \begin{code}
-mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
+mkHsApps    f xs = foldl HsApp (HsVar f) xs
+mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
+
+mkHsIntLit n = HsLit (HsInt n)
+mkHsString s = HsString (mkFastString s)
+mkHsChar c   = HsChar   (ord c)
+
+mkConPat con vars   = ConPatIn con (PrefixCon (map VarPat vars))
+mkNullaryConPat con = ConPatIn con (PrefixCon [])
+mkWildConPat con    = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat))
 \end{code}
 
 ToDo: Better SrcLocs.
 
 \begin{code}
-compare_Case ::
-         RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-         -> RdrNameHsExpr -> RdrNameHsExpr
-         -> RdrNameHsExpr
 compare_gen_Case ::
-         RdrName
-         -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+         RdrNameHsExpr -- What to do for equality
          -> RdrNameHsExpr -> RdrNameHsExpr
          -> RdrNameHsExpr
 careful_compare_Case :: -- checks for primitive types...
-         Type
-         -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+         TyCon                 -- The tycon we are deriving for
+         -> Type
+         -> RdrNameHsExpr      -- What to do for equality
          -> RdrNameHsExpr -> RdrNameHsExpr
          -> RdrNameHsExpr
 
-compare_Case = compare_gen_Case compare_RDR
 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
        -- Was: compare_gen_Case cmp_eq_RDR
 
-compare_gen_Case fun lt eq gt a b
-  = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
-      [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing generatedSrcLoc,
-       mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing generatedSrcLoc,
-       mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing generatedSrcLoc]
+compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR
+  = HsApp (HsApp (HsVar compare_RDR) a) b      -- Simple case 
+compare_gen_Case eq a b                                -- General case
+  = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-}
+      [mk_triv_Match (mkNullaryConPat ltTag_RDR) ltTag_Expr,
+       mk_triv_Match (mkNullaryConPat eqTag_RDR) eq,
+       mk_triv_Match (mkNullaryConPat gtTag_RDR) gtTag_Expr]
       generatedSrcLoc
 
-careful_compare_Case ty lt eq gt a b
-  = if not (isUnLiftedType ty) then
-       compare_gen_Case compare_RDR lt eq gt a b
-
-    else -- we have to do something special for primitive things...
-       HsIf (genOpApp a relevant_eq_op b)
-           eq
-           (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
-           generatedSrcLoc
+careful_compare_Case tycon ty eq a b
+  | not (isUnLiftedType ty)
+  = compare_gen_Case eq a b
+  | otherwise      -- We have to do something special for primitive things...
+  = HsIf (genOpApp a relevant_eq_op b)
+        eq
+        (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc)
+        generatedSrcLoc
   where
-    relevant_eq_op = assoc_ty_id eq_op_tbl ty
-    relevant_lt_op = assoc_ty_id lt_op_tbl ty
-
-assoc_ty_id tyids ty 
-  = if null res then panic "assoc_ty"
-    else head res
+    relevant_eq_op = assoc_ty_id "Ord" tycon eq_op_tbl ty
+    relevant_lt_op = assoc_ty_id "Ord" tycon lt_op_tbl ty
+
+
+box_if_necy :: String          -- The class involved
+           -> TyCon            -- The tycon involved
+           -> RdrNameHsExpr    -- The argument
+           -> Type             -- The argument type
+           -> RdrNameHsExpr    -- Boxed version of the arg
+box_if_necy cls_str tycon arg arg_ty
+  | isUnLiftedType arg_ty = HsApp (HsVar box_con) arg
+  | otherwise            = arg
+  where
+    box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
+
+assoc_ty_id :: String          -- The class involved
+           -> TyCon            -- The tycon involved
+           -> [(Type,a)]       -- The table
+           -> Type             -- The type
+           -> a                -- The result of the lookup
+assoc_ty_id cls_str tycon tbl ty 
+  | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+> 
+                                             text "for primitive type" <+> ppr ty)
+  | otherwise = head res
   where
-    res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
+    res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
 
 eq_op_tbl =
-    [(charPrimTy,      eqH_Char_RDR)
-    ,(intPrimTy,       eqH_Int_RDR)
-    ,(wordPrimTy,      eqH_Word_RDR)
-    ,(addrPrimTy,      eqH_Addr_RDR)
-    ,(floatPrimTy,     eqH_Float_RDR)
-    ,(doublePrimTy,    eqH_Double_RDR)
+    [(charPrimTy,      eqChar_RDR)
+    ,(intPrimTy,       eqInt_RDR)
+    ,(wordPrimTy,      eqWord_RDR)
+    ,(addrPrimTy,      eqAddr_RDR)
+    ,(floatPrimTy,     eqFloat_RDR)
+    ,(doublePrimTy,    eqDouble_RDR)
     ]
 
 lt_op_tbl =
-    [(charPrimTy,      ltH_Char_RDR)
-    ,(intPrimTy,       ltH_Int_RDR)
-    ,(wordPrimTy,      ltH_Word_RDR)
-    ,(addrPrimTy,      ltH_Addr_RDR)
-    ,(floatPrimTy,     ltH_Float_RDR)
-    ,(doublePrimTy,    ltH_Double_RDR)
+    [(charPrimTy,      ltChar_RDR)
+    ,(intPrimTy,       ltInt_RDR)
+    ,(wordPrimTy,      ltWord_RDR)
+    ,(addrPrimTy,      ltAddr_RDR)
+    ,(floatPrimTy,     ltFloat_RDR)
+    ,(doublePrimTy,    ltDouble_RDR)
+    ]
+
+box_con_tbl =
+    [(charPrimTy,      getRdrName charDataCon)
+    ,(intPrimTy,       getRdrName intDataCon)
+    ,(wordPrimTy,      getRdrName wordDataCon)
+    ,(addrPrimTy,      addrDataCon_RDR)
+    ,(floatPrimTy,     getRdrName floatDataCon)
+    ,(doublePrimTy,    getRdrName doubleDataCon)
     ]
 
 -----------------------------------------------------------------------
@@ -1267,14 +1382,15 @@ append_Expr a b = genOpApp a append_RDR b
 
 -----------------------------------------------------------------------
 
-eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-eq_Expr ty a b
-  = if not (isUnLiftedType ty) then
-       genOpApp a eq_RDR  b
-    else -- we have to do something special for primitive things...
-       genOpApp a relevant_eq_op b
-  where
-    relevant_eq_op = assoc_ty_id eq_op_tbl ty
+eq_Expr :: TyCon -> Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+eq_Expr tycon ty a b = genOpApp a eq_op b
+ where
+   eq_op
+    | not (isUnLiftedType ty) = eq_RDR
+    | otherwise               =
+         -- we have to do something special for primitive things...
+       assoc_ty_id "Eq" tycon eq_op_tbl ty
+
 \end{code}
 
 \begin{code}
@@ -1282,7 +1398,7 @@ untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
 untag_Expr tycon [] expr = expr
 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
   = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
-      [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing generatedSrcLoc]
+      [mk_triv_Match (VarPat put_tag_here) (untag_Expr tycon more expr)]
       generatedSrcLoc
 
 cmp_tags_Expr :: RdrName               -- Comparison op
@@ -1304,12 +1420,11 @@ enum_from_then_to_Expr
 enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
 
-showParen_Expr, readParen_Expr
+showParen_Expr
        :: RdrNameHsExpr -> RdrNameHsExpr
        -> RdrNameHsExpr
 
 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
-readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
 
 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
 
@@ -1319,31 +1434,31 @@ nested_compose_Expr (e:es)
 
 -- impossible_Expr is used in case RHSs that should never happen.
 -- We generate these to keep the desugarer from complaining that they *might* happen!
-impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
+impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
 
 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
 -- method. It is currently only used by Enum.{succ,pred}
 illegal_Expr meth tp msg = 
-   HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
+   HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
 
 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
 -- to include the value of a_RDR in the error string.
 illegal_toEnum_tag tp maxtag =
    HsApp (HsVar error_RDR) 
          (HsApp (HsApp (HsVar append_RDR)
-                      (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
+                      (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
                       (HsApp (HsApp (HsApp 
                           (HsVar showsPrec_RDR)
-                          (HsLit (HsInt 0)))
+                          (mkHsIntLit 0))
                           (HsVar a_RDR))
                           (HsApp (HsApp 
                               (HsVar append_RDR)
-                              (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
+                              (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
                               (HsApp (HsApp (HsApp 
                                        (HsVar showsPrec_RDR)
-                                       (HsLit (HsInt 0)))
+                                       (mkHsIntLit 0))
                                        (HsVar maxtag))
-                                       (HsLit (HsString (_PK_ ")")))))))
+                                       (HsLit (HsString (mkFastString ")")))))))
 
 parenify e@(HsVar _) = e
 parenify e          = HsPar e
@@ -1357,32 +1472,33 @@ genOpApp e1 op e2 = mkHsOpApp e1 op e2
 \end{code}
 
 \begin{code}
-qual_orig_name n = nameRdrName (getName n)
-varUnqual n      = mkUnqual varName n
-
-zz_a_RDR       = varUnqual SLIT("_a")
-a_RDR          = varUnqual SLIT("a")
-b_RDR          = varUnqual SLIT("b")
-c_RDR          = varUnqual SLIT("c")
-d_RDR          = varUnqual SLIT("d")
-ah_RDR         = varUnqual SLIT("a#")
-bh_RDR         = varUnqual SLIT("b#")
-ch_RDR         = varUnqual SLIT("c#")
-dh_RDR         = varUnqual SLIT("d#")
-cmp_eq_RDR     = varUnqual SLIT("cmp_eq")
-rangeSize_RDR  = varUnqual SLIT("rangeSize")
-
-as_RDRs                = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
-bs_RDRs                = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
-cs_RDRs                = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
-
-mkHsString s = HsString (_PK_ s)
+varUnqual n     = mkUnqual OccName.varName n
+
+zz_a_RDR       = varUnqual FSLIT("_a")
+a_RDR          = varUnqual FSLIT("a")
+b_RDR          = varUnqual FSLIT("b")
+c_RDR          = varUnqual FSLIT("c")
+d_RDR          = varUnqual FSLIT("d")
+e_RDR          = varUnqual FSLIT("e")
+k_RDR          = varUnqual FSLIT("k")
+z_RDR          = varUnqual FSLIT("z") :: RdrName
+ah_RDR         = varUnqual FSLIT("a#")
+bh_RDR         = varUnqual FSLIT("b#")
+ch_RDR         = varUnqual FSLIT("c#")
+dh_RDR         = varUnqual FSLIT("d#")
+cmp_eq_RDR     = varUnqual FSLIT("cmp_eq")
+rangeSize_RDR  = varUnqual FSLIT("rangeSize")
+
+as_RDRs                = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_RDRs                = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
+cs_RDRs                = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
 
 zz_a_Expr      = HsVar zz_a_RDR
 a_Expr         = HsVar a_RDR
 b_Expr         = HsVar b_RDR
 c_Expr         = HsVar c_RDR
 d_Expr         = HsVar d_RDR
+z_Expr         = HsVar z_RDR
 ltTag_Expr     = HsVar ltTag_RDR
 eqTag_Expr     = HsVar eqTag_RDR
 gtTag_Expr     = HsVar gtTag_RDR
@@ -1390,19 +1506,41 @@ false_Expr      = HsVar false_RDR
 true_Expr      = HsVar true_RDR
 
 getTag_Expr    = HsVar getTag_RDR
-tagToEnum_Expr         = HsVar tagToEnumH_RDR
+tagToEnum_Expr         = HsVar tagToEnum_RDR
 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
 
-wildPat                = WildPatIn
-zz_a_Pat       = VarPatIn zz_a_RDR
-a_Pat          = VarPatIn a_RDR
-b_Pat          = VarPatIn b_RDR
-c_Pat          = VarPatIn c_RDR
-d_Pat          = VarPatIn d_RDR
+wildPat                = WildPat placeHolderType
+zz_a_Pat       = VarPat zz_a_RDR
+a_Pat          = VarPat a_RDR
+b_Pat          = VarPat b_RDR
+c_Pat          = VarPat c_RDR
+d_Pat          = VarPat d_RDR
 
 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
 
-con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
-tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
-maxtag_RDR tycon  = varUnqual (_PK_ ("maxtag_"  ++ occNameString (getOccName tycon) ++ "#"))
+con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
+tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
+maxtag_RDR tycon  = varUnqual (mkFastString ("maxtag_"  ++ occNameString (getOccName tycon) ++ "#"))
+\end{code}
+
+RdrNames for PrimOps.  Can't be done in PrelNames, because PrimOp imports
+PrelNames, so PrelNames can't import PrimOp.
+
+\begin{code}
+minusInt_RDR  = nameRdrName minusIntName
+eqInt_RDR     = nameRdrName eqIntName
+ltInt_RDR     = nameRdrName ltIntName
+geInt_RDR     = nameRdrName geIntName
+leInt_RDR     = nameRdrName leIntName
+eqChar_RDR    = nameRdrName eqCharName
+eqWord_RDR    = nameRdrName eqWordName
+eqAddr_RDR    = nameRdrName eqAddrName
+eqFloat_RDR   = nameRdrName eqFloatName
+eqDouble_RDR  = nameRdrName eqDoubleName
+ltChar_RDR    = nameRdrName ltCharName
+ltWord_RDR    = nameRdrName ltWordName
+ltAddr_RDR    = nameRdrName ltAddrName
+ltFloat_RDR   = nameRdrName ltFloatName
+ltDouble_RDR  = nameRdrName ltDoubleName
+tagToEnum_RDR = nameRdrName tagToEnumName                   
 \end{code}