compiler/typecheck/TcGenDeriv.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 TcGenDeriv: Generating derived instance declarations
   7
   8 This module is nominally ``subordinate'' to @TcDeriv@, which is the
   9 ``official'' interface to deriving-related things.
  10
  11 This is where we do all the grimy bindings' generation.
  12
  13 \begin{code}
  14 module TcGenDeriv (
  15         DerivAuxBinds, isDupAux,
  16
  17         gen_Bounded_binds,
  18         gen_Enum_binds,
  19         gen_Eq_binds,
  20         gen_Ix_binds,
  21         gen_Ord_binds,
  22         gen_Read_binds,
  23         gen_Show_binds,
  24         gen_Data_binds,
  25         gen_Typeable_binds,
  26         genAuxBind
  27     ) where
  28
  29 #include "HsVersions.h"
  30
  31 import HsSyn
  32 import RdrName
  33 import BasicTypes
  34 import DataCon
  35 import Name
  36
  37 import HscTypes
  38 import PrelInfo
  39 import PrelNames
  40 import MkId
  41 import PrimOp
  42 import SrcLoc
  43 import TyCon
  44 import TcType
  45 import TysPrim
  46 import TysWiredIn
  47 import Util
  48 import Outputable
  49 import FastString
  50 import OccName
  51 import Bag
  52
  53 import Data.List        ( partition, intersperse )
  54 \end{code}
  55
  56 \begin{code}
  57 type DerivAuxBinds = [DerivAuxBind]
  58
  59 data DerivAuxBind               -- Please add these auxiliary top-level bindings
  60   = GenCon2Tag TyCon            -- The con2Tag for given TyCon
  61   | GenTag2Con TyCon            -- ...ditto tag2Con
  62   | GenMaxTag  TyCon            -- ...and maxTag
  63
  64         -- Scrap your boilerplate
  65   | MkDataCon DataCon           -- For constructor C we get $cC :: Constr
  66   | MkTyCon   TyCon             -- For tycon T we get       $tT :: DataType
  67
  68
  69 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
  70 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
  71 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
  72 isDupAux (GenMaxTag tc1)  (GenMaxTag tc2)  = tc1 == tc2
  73 isDupAux (MkDataCon dc1)  (MkDataCon dc2)  = dc1 == dc2
  74 isDupAux (MkTyCon tc1)    (MkTyCon tc2)    = tc1 == tc2
  75 isDupAux _                _                = False
  76 \end{code}
  77
  78
  79 %************************************************************************
  80 %*                                                                      *
  81                 Eq instances
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 Here are the heuristics for the code we generate for @Eq@:
  86 \begin{itemize}
  87 \item
  88   Let's assume we have a data type with some (possibly zero) nullary
  89   data constructors and some ordinary, non-nullary ones (the rest,
  90   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  91   and \tr{O}rdinary data cons.
  92 \begin{verbatim}
  93 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
  94 \end{verbatim}
  95
  96 \item
  97   For the ordinary constructors (if any), we emit clauses to do The
  98   Usual Thing, e.g.,:
  99
 100 \begin{verbatim}
 101 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
 102 (==) (O2 a1)       (O2 a2)       = a1 == a2
 103 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
 104 \end{verbatim}
 105
 106   Note: if we're comparing unlifted things, e.g., if \tr{a1} and
 107   \tr{a2} are \tr{Float#}s, then we have to generate
 108 \begin{verbatim}
 109 case (a1 `eqFloat#` a2) of
 110   r -> r
 111 \end{verbatim}
 112   for that particular test.
 113
 114 \item
 115   If there are any nullary constructors, we emit a catch-all clause of
 116   the form:
 117
 118 \begin{verbatim}
 119 (==) a b  = case (con2tag_Foo a) of { a# ->
 120             case (con2tag_Foo b) of { b# ->
 121             case (a# ==# b#)     of {
 122               r -> r
 123             }}}
 124 \end{verbatim}
 125
 126   If there aren't any nullary constructors, we emit a simpler
 127   catch-all:
 128 \begin{verbatim}
 129 (==) a b  = False
 130 \end{verbatim}
 131
 132 \item
 133   For the @(/=)@ method, we normally just use the default method.
 134
 135   If the type is an enumeration type, we could/may/should? generate
 136   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 137   above.
 138
 139 \item
 140   We thought about doing this: If we're also deriving @Ord@ for this
 141   tycon, we generate:
 142 \begin{verbatim}
 143 instance ... Eq (Foo ...) where
 144   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 145   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 146 \begin{verbatim}
 147   However, that requires that \tr{Ord <whatever>} was put in the context
 148   for the instance decl, which it probably wasn't, so the decls
 149   produced don't get through the typechecker.
 150 \end{itemize}
 151
 152
 153 \begin{code}
 154 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 155 gen_Eq_binds loc tycon
 156   = (method_binds, aux_binds)
 157   where
 158     (nullary_cons, nonnullary_cons)
 159        | isNewTyCon tycon = ([], tyConDataCons tycon)
 160        | otherwise            = partition isNullarySrcDataCon (tyConDataCons tycon)
 161
 162     no_nullary_cons = null nullary_cons
 163
 164     rest | no_nullary_cons
 165          = case tyConSingleDataCon_maybe tycon of
 166                   Just _ -> []
 167                   Nothing -> -- if cons don't match, then False
 168                      [([nlWildPat, nlWildPat], false_Expr)]
 169          | otherwise -- calc. and compare the tags
 170          = [([a_Pat, b_Pat],
 171             untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 172                        (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 173
 174     aux_binds | no_nullary_cons = []
 175               | otherwise       = [GenCon2Tag tycon]
 176
 177     method_binds = listToBag [
 178                         mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
 179                         mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
 180                         nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
 181
 182     ------------------------------------------------------------------
 183     pats_etc data_con
 184       = let
 185             con1_pat = nlConVarPat data_con_RDR as_needed
 186             con2_pat = nlConVarPat data_con_RDR bs_needed
 187
 188             data_con_RDR = getRdrName data_con
 189             con_arity   = length tys_needed
 190             as_needed   = take con_arity as_RDRs
 191             bs_needed   = take con_arity bs_RDRs
 192             tys_needed  = dataConOrigArgTys data_con
 193         in
 194         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 195       where
 196         nested_eq_expr []  [] [] = true_Expr
 197         nested_eq_expr tys as bs
 198           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 199           where
 200             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
 201 \end{code}
 202
 203 %************************************************************************
 204 %*                                                                      *
 205         Ord instances
 206 %*                                                                      *
 207 %************************************************************************
 208
 209 For a derived @Ord@, we concentrate our attentions on @compare@
 210 \begin{verbatim}
 211 compare :: a -> a -> Ordering
 212 data Ordering = LT | EQ | GT deriving ()
 213 \end{verbatim}
 214
 215 We will use the same example data type as above:
 216 \begin{verbatim}
 217 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 218 \end{verbatim}
 219
 220 \begin{itemize}
 221 \item
 222   We do all the other @Ord@ methods with calls to @compare@:
 223 \begin{verbatim}
 224 instance ... (Ord <wurble> <wurble>) where
 225     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 226     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 227     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 228     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 229
 230     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 231     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 232
 233     -- compare to come...
 234 \end{verbatim}
 235
 236 \item
 237   @compare@ always has two parts.  First, we use the compared
 238   data-constructors' tags to deal with the case of different
 239   constructors:
 240 \begin{verbatim}
 241 compare a b = case (con2tag_Foo a) of { a# ->
 242               case (con2tag_Foo b) of { b# ->
 243               case (a# ==# b#)     of {
 244                True  -> cmp_eq a b
 245                False -> case (a# <# b#) of
 246                          True  -> _LT
 247                          False -> _GT
 248               }}}
 249   where
 250     cmp_eq = ... to come ...
 251 \end{verbatim}
 252
 253 \item
 254   We are only left with the ``help'' function @cmp_eq@, to deal with
 255   comparing data constructors with the same tag.
 256
 257   For the ordinary constructors (if any), we emit the sorta-obvious
 258   compare-style stuff; for our example:
 259 \begin{verbatim}
 260 cmp_eq (O1 a1 b1) (O1 a2 b2)
 261   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 262
 263 cmp_eq (O2 a1) (O2 a2)
 264   = compare a1 a2
 265
 266 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 267   = case (compare a1 a2) of {
 268       LT -> LT;
 269       GT -> GT;
 270       EQ -> case compare b1 b2 of {
 271               LT -> LT;
 272               GT -> GT;
 273               EQ -> compare c1 c2
 274             }
 275     }
 276 \end{verbatim}
 277
 278   Again, we must be careful about unlifted comparisons.  For example,
 279   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 280   generate:
 281
 282 \begin{verbatim}
 283 cmp_eq lt eq gt (O2 a1) (O2 a2)
 284   = compareInt# a1 a2
 285   -- or maybe the unfolded equivalent
 286 \end{verbatim}
 287
 288 \item
 289   For the remaining nullary constructors, we already know that the
 290   tags are equal so:
 291 \begin{verbatim}
 292 cmp_eq _ _ = EQ
 293 \end{verbatim}
 294 \end{itemize}
 295
 296 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
 297 JJQC-30-Nov-1997
 298
 299 \begin{code}
 300 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 301
 302 gen_Ord_binds loc tycon
 303   | Just (con, prim_tc) <- primWrapperType_maybe tycon
 304   = gen_PrimOrd_binds con prim_tc
 305
 306   | otherwise
 307   = (unitBag compare, aux_binds)
 308         -- `AndMonoBinds` compare
 309         -- The default declaration in PrelBase handles this
 310   where
 311     aux_binds | single_con_type = []
 312               | otherwise       = [GenCon2Tag tycon]
 313
 314     compare = L loc (mkFunBind (L loc compare_RDR) compare_matches)
 315     compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
 316     cmp_eq_binds    = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
 317
 318     compare_rhs
 319         | single_con_type = cmp_eq_Expr a_Expr b_Expr
 320         | otherwise
 321         = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 322                   (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
 323                         (cmp_eq_Expr a_Expr b_Expr)     -- True case
 324                         -- False case; they aren't equal
 325                         -- So we need to do a less-than comparison on the tags
 326                         (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
 327
 328     tycon_data_cons = tyConDataCons tycon
 329     single_con_type = isSingleton tycon_data_cons
 330     (nullary_cons, nonnullary_cons)
 331        | isNewTyCon tycon = ([], tyConDataCons tycon)
 332        | otherwise        = partition isNullarySrcDataCon tycon_data_cons
 333
 334     cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match
 335     cmp_eq_match
 336       | isEnumerationTyCon tycon
 337                            -- We know the tags are equal, so if it's an enumeration TyCon,
 338                            -- then there is nothing left to do
 339                            -- Catch this specially to avoid warnings
 340                            -- about overlapping patterns from the desugarer,
 341                            -- and to avoid unnecessary pattern-matching
 342       = [([nlWildPat,nlWildPat], eqTag_Expr)]
 343       | otherwise
 344       = map pats_etc nonnullary_cons ++
 345         (if single_con_type then        -- Omit wildcards when there's just one
 346               []                        -- constructor, to silence desugarer
 347         else
 348               [([nlWildPat, nlWildPat], default_rhs)])
 349
 350     default_rhs | null nullary_cons = impossible_Expr   -- Keep desugarer from complaining about
 351                                                         -- inexhaustive patterns
 352                 | otherwise         = eqTag_Expr        -- Some nullary constructors;
 353                                                         -- Tags are equal, no args => return EQ
 354     pats_etc data_con
 355         = ([con1_pat, con2_pat],
 356            nested_compare_expr tys_needed as_needed bs_needed)
 357         where
 358           con1_pat = nlConVarPat data_con_RDR as_needed
 359           con2_pat = nlConVarPat data_con_RDR bs_needed
 360
 361           data_con_RDR = getRdrName data_con
 362           con_arity   = length tys_needed
 363           as_needed   = take con_arity as_RDRs
 364           bs_needed   = take con_arity bs_RDRs
 365           tys_needed  = dataConOrigArgTys data_con
 366
 367           nested_compare_expr [ty] [a] [b]
 368             = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
 369
 370           nested_compare_expr (ty:tys) (a:as) (b:bs)
 371             = let eq_expr = nested_compare_expr tys as bs
 372                 in  careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
 373
 374           nested_compare_expr _ _ _ = panic "nested_compare_expr"       -- Args always equal length
 375 \end{code}
 376
 377 Note [Comparision of primitive types]
 378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 379 The general plan does not work well for data types like
 380         data T = MkT Int# deriving( Ord )
 381 The general plan defines the 'compare' method, gets (<) etc from it.  But
 382 that means we get silly code like:
 383    instance Ord T where
 384      (>) (I# x) (I# y) = case <# x y of
 385                             True -> False
 386                             False -> case ==# x y of
 387                                        True  -> False
 388                                        False -> True
 389 We would prefer to use the (>#) primop.  See also Trac #2130
 390
 391
 392 \begin{code}
 393 gen_PrimOrd_binds :: DataCon -> TyCon ->  (LHsBinds RdrName, DerivAuxBinds)
 394 -- See Note [Comparison of primitive types]
 395 gen_PrimOrd_binds data_con prim_tc
 396   = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
 397                 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
 398   where
 399     mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
 400                                  [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
 401     con_RDR = getRdrName data_con
 402     apat = nlConVarPat con_RDR [a_RDR]
 403     bpat = nlConVarPat con_RDR [b_RDR]
 404
 405     (lt_op, le_op, ge_op, gt_op)
 406        | prim_tc == charPrimTyCon   = (CharLtOp,   CharLeOp,   CharGeOp,   CharGtOp)
 407        | prim_tc == intPrimTyCon    = (IntLtOp,    IntLeOp,    IntGeOp,    IntGtOp)
 408        | prim_tc == wordPrimTyCon   = (WordLtOp,   WordLeOp,   WordGeOp,   WordGtOp)
 409        | prim_tc == addrPrimTyCon   = (AddrLtOp,   AddrLeOp,   AddrGeOp,   AddrGtOp)
 410        | prim_tc == floatPrimTyCon  = (FloatLtOp,  FloatLeOp,  FloatGeOp,  FloatGtOp)
 411        | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
 412        | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
 413
 414
 415 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
 416 -- True of data types that are wrappers around prmitive types
 417 --      data T = MkT Word#
 418 -- For these we want to generate all the (<), (<=) etc operations individually
 419 primWrapperType_maybe tc
 420   | [con] <- tyConDataCons tc
 421   , [ty]  <- dataConOrigArgTys con
 422   , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
 423   , isPrimTyCon prim_tc
 424   = Just (con, prim_tc)
 425   | otherwise
 426   = Nothing
 427 \end{code}
 428
 429 %************************************************************************
 430 %*                                                                      *
 431         Enum instances
 432 %*                                                                      *
 433 %************************************************************************
 434
 435 @Enum@ can only be derived for enumeration types.  For a type
 436 \begin{verbatim}
 437 data Foo ... = N1 | N2 | ... | Nn
 438 \end{verbatim}
 439
 440 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 441 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 442
 443 \begin{verbatim}
 444 instance ... Enum (Foo ...) where
 445     succ x   = toEnum (1 + fromEnum x)
 446     pred x   = toEnum (fromEnum x - 1)
 447
 448     toEnum i = tag2con_Foo i
 449
 450     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 451
 452     -- or, really...
 453     enumFrom a
 454       = case con2tag_Foo a of
 455           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 456
 457    enumFromThen a b
 458      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 459
 460     -- or, really...
 461     enumFromThen a b
 462       = case con2tag_Foo a of { a# ->
 463         case con2tag_Foo b of { b# ->
 464         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 465         }}
 466 \end{verbatim}
 467
 468 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 469
 470 \begin{code}
 471 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 472 gen_Enum_binds loc tycon
 473   = (method_binds, aux_binds)
 474   where
 475     method_binds = listToBag [
 476                         succ_enum,
 477                         pred_enum,
 478                         to_enum,
 479                         enum_from,
 480                         enum_from_then,
 481                         from_enum
 482                     ]
 483     aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
 484
 485     occ_nm = getOccString tycon
 486
 487     succ_enum
 488       = mk_easy_FunBind loc succ_RDR [a_Pat] $
 489         untag_Expr tycon [(a_RDR, ah_RDR)] $
 490         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
 491                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 492              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 493              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 494                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 495                                         nlHsIntLit 1]))
 496
 497     pred_enum
 498       = mk_easy_FunBind loc pred_RDR [a_Pat] $
 499         untag_Expr tycon [(a_RDR, ah_RDR)] $
 500         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
 501                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 502              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 503              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 504                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 505                                                nlHsLit (HsInt (-1))]))
 506
 507     to_enum
 508       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
 509         nlHsIf (nlHsApps and_RDR
 510                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
 511                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
 512              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
 513              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 514
 515     enum_from
 516       = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
 517           untag_Expr tycon [(a_RDR, ah_RDR)] $
 518           nlHsApps map_RDR
 519                 [nlHsVar (tag2con_RDR tycon),
 520                  nlHsPar (enum_from_to_Expr
 521                             (nlHsVarApps intDataCon_RDR [ah_RDR])
 522                             (nlHsVar (maxtag_RDR tycon)))]
 523
 524     enum_from_then
 525       = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
 526           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 527           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 528             nlHsPar (enum_from_then_to_Expr
 529                     (nlHsVarApps intDataCon_RDR [ah_RDR])
 530                     (nlHsVarApps intDataCon_RDR [bh_RDR])
 531                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 532                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
 533                            (nlHsIntLit 0)
 534                            (nlHsVar (maxtag_RDR tycon))
 535                            ))
 536
 537     from_enum
 538       = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
 539           untag_Expr tycon [(a_RDR, ah_RDR)] $
 540           (nlHsVarApps intDataCon_RDR [ah_RDR])
 541 \end{code}
 542
 543 %************************************************************************
 544 %*                                                                      *
 545         Bounded instances
 546 %*                                                                      *
 547 %************************************************************************
 548
 549 \begin{code}
 550 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 551 gen_Bounded_binds loc tycon
 552   | isEnumerationTyCon tycon
 553   = (listToBag [ min_bound_enum, max_bound_enum ], [])
 554   | otherwise
 555   = ASSERT(isSingleton data_cons)
 556     (listToBag [ min_bound_1con, max_bound_1con ], [])
 557   where
 558     data_cons = tyConDataCons tycon
 559
 560     ----- enum-flavored: ---------------------------
 561     min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
 562     max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
 563
 564     data_con_1    = head data_cons
 565     data_con_N    = last data_cons
 566     data_con_1_RDR = getRdrName data_con_1
 567     data_con_N_RDR = getRdrName data_con_N
 568
 569     ----- single-constructor-flavored: -------------
 570     arity          = dataConSourceArity data_con_1
 571
 572     min_bound_1con = mkVarBind loc minBound_RDR $
 573                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 574     max_bound_1con = mkVarBind loc maxBound_RDR $
 575                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 576 \end{code}
 577
 578 %************************************************************************
 579 %*                                                                      *
 580         Ix instances
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 Deriving @Ix@ is only possible for enumeration types and
 585 single-constructor types.  We deal with them in turn.
 586
 587 For an enumeration type, e.g.,
 588 \begin{verbatim}
 589     data Foo ... = N1 | N2 | ... | Nn
 590 \end{verbatim}
 591 things go not too differently from @Enum@:
 592 \begin{verbatim}
 593 instance ... Ix (Foo ...) where
 594     range (a, b)
 595       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 596
 597     -- or, really...
 598     range (a, b)
 599       = case (con2tag_Foo a) of { a# ->
 600         case (con2tag_Foo b) of { b# ->
 601         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 602         }}
 603
 604     -- Generate code for unsafeIndex, becuase using index leads
 605     -- to lots of redundant range tests
 606     unsafeIndex c@(a, b) d
 607       = case (con2tag_Foo d -# con2tag_Foo a) of
 608                r# -> I# r#
 609
 610     inRange (a, b) c
 611       = let
 612             p_tag = con2tag_Foo c
 613         in
 614         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 615
 616     -- or, really...
 617     inRange (a, b) c
 618       = case (con2tag_Foo a)   of { a_tag ->
 619         case (con2tag_Foo b)   of { b_tag ->
 620         case (con2tag_Foo c)   of { c_tag ->
 621         if (c_tag >=# a_tag) then
 622           c_tag <=# b_tag
 623         else
 624           False
 625         }}}
 626 \end{verbatim}
 627 (modulo suitable case-ification to handle the unlifted tags)
 628
 629 For a single-constructor type (NB: this includes all tuples), e.g.,
 630 \begin{verbatim}
 631     data Foo ... = MkFoo a b Int Double c c
 632 \end{verbatim}
 633 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 634 (p.~147).
 635
 636 \begin{code}
 637 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 638
 639 gen_Ix_binds loc tycon
 640   | isEnumerationTyCon tycon
 641   = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
 642   | otherwise
 643   = (single_con_ixes, [GenCon2Tag tycon])
 644   where
 645     --------------------------------------------------------------
 646     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 647
 648     enum_range
 649       = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
 650           untag_Expr tycon [(a_RDR, ah_RDR)] $
 651           untag_Expr tycon [(b_RDR, bh_RDR)] $
 652           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 653               nlHsPar (enum_from_to_Expr
 654                         (nlHsVarApps intDataCon_RDR [ah_RDR])
 655                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 656
 657     enum_index
 658       = mk_easy_FunBind loc unsafeIndex_RDR
 659                 [noLoc (AsPat (noLoc c_RDR)
 660                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
 661                                 d_Pat] (
 662            untag_Expr tycon [(a_RDR, ah_RDR)] (
 663            untag_Expr tycon [(d_RDR, dh_RDR)] (
 664            let
 665                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
 666            in
 667            nlHsCase
 668              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
 669              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
 670            ))
 671         )
 672
 673     enum_inRange
 674       = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
 675           untag_Expr tycon [(a_RDR, ah_RDR)] (
 676           untag_Expr tycon [(b_RDR, bh_RDR)] (
 677           untag_Expr tycon [(c_RDR, ch_RDR)] (
 678           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
 679              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
 680           ) {-else-} (
 681              false_Expr
 682           ))))
 683
 684     --------------------------------------------------------------
 685     single_con_ixes
 686       = listToBag [single_con_range, single_con_index, single_con_inRange]
 687
 688     data_con
 689       = case tyConSingleDataCon_maybe tycon of -- just checking...
 690           Nothing -> panic "get_Ix_binds"
 691           Just dc | any isUnLiftedType (dataConOrigArgTys dc)
 692                   -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
 693                   | otherwise -> dc
 694
 695     con_arity    = dataConSourceArity data_con
 696     data_con_RDR = getRdrName data_con
 697
 698     as_needed = take con_arity as_RDRs
 699     bs_needed = take con_arity bs_RDRs
 700     cs_needed = take con_arity cs_RDRs
 701
 702     con_pat  xs  = nlConVarPat data_con_RDR xs
 703     con_expr     = nlHsVarApps data_con_RDR cs_needed
 704
 705     --------------------------------------------------------------
 706     single_con_range
 707       = mk_easy_FunBind loc range_RDR
 708           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
 709         nlHsDo ListComp stmts con_expr
 710       where
 711         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 712
 713         mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
 714                                  (nlHsApp (nlHsVar range_RDR)
 715                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
 716
 717     ----------------
 718     single_con_index
 719       = mk_easy_FunBind loc unsafeIndex_RDR
 720                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 721                  con_pat cs_needed]
 722         -- We need to reverse the order we consider the components in
 723         -- so that
 724         --     range (l,u) !! index (l,u) i == i   -- when i is in range
 725         -- (from http://haskell.org/onlinereport/ix.html) holds.
 726                 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
 727       where
 728         -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
 729         mk_index []        = nlHsIntLit 0
 730         mk_index [(l,u,i)] = mk_one l u i
 731         mk_index ((l,u,i) : rest)
 732           = genOpApp (
 733                 mk_one l u i
 734             ) plus_RDR (
 735                 genOpApp (
 736                     (nlHsApp (nlHsVar unsafeRangeSize_RDR)
 737                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
 738                 ) times_RDR (mk_index rest)
 739            )
 740         mk_one l u i
 741           = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
 742
 743     ------------------
 744     single_con_inRange
 745       = mk_easy_FunBind loc inRange_RDR
 746                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 747                  con_pat cs_needed] $
 748           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
 749       where
 750         in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
 751                                                nlHsVar c]
 752 \end{code}
 753
 754 %************************************************************************
 755 %*                                                                      *
 756         Read instances
 757 %*                                                                      *
 758 %************************************************************************
 759
 760 Example
 761
 762   infix 4 %%
 763   data T = Int %% Int
 764          | T1 { f1 :: Int }
 765          | T2 T
 766
 767
 768 instance Read T where
 769   readPrec =
 770     parens
 771     ( prec 4 (
 772         do x           <- ReadP.step Read.readPrec
 773            Symbol "%%" <- Lex.lex
 774            y           <- ReadP.step Read.readPrec
 775            return (x %% y))
 776       +++
 777       prec (appPrec+1) (
 778         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 779         -- Record construction binds even more tightly than application
 780         do Ident "T1" <- Lex.lex
 781            Punc '{' <- Lex.lex
 782            Ident "f1" <- Lex.lex
 783            Punc '=' <- Lex.lex
 784            x          <- ReadP.reset Read.readPrec
 785            Punc '}' <- Lex.lex
 786            return (T1 { f1 = x }))
 787       +++
 788       prec appPrec (
 789         do Ident "T2" <- Lex.lexP
 790            x          <- ReadP.step Read.readPrec
 791            return (T2 x))
 792     )
 793
 794   readListPrec = readListPrecDefault
 795   readList     = readListDefault
 796
 797
 798 \begin{code}
 799 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 800
 801 gen_Read_binds get_fixity loc tycon
 802   = (listToBag [read_prec, default_readlist, default_readlistprec], [])
 803   where
 804     -----------------------------------------------------------------------
 805     default_readlist
 806         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 807
 808     default_readlistprec
 809         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 810     -----------------------------------------------------------------------
 811
 812     data_cons = tyConDataCons tycon
 813     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 814
 815     read_prec = mkVarBind loc readPrec_RDR
 816                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 817
 818     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 819     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 820
 821     read_nullary_cons
 822       = case nullary_cons of
 823             []    -> []
 824             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
 825                                     (result_expr con [])]
 826             _     -> [nlHsApp (nlHsVar choose_RDR)
 827                               (nlList (map mk_pair nullary_cons))]
 828
 829     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
 830                            result_expr con []]
 831                           Boxed
 832
 833     read_non_nullary_con data_con
 834       | is_infix  = mk_parser infix_prec  infix_stmts  body
 835       | is_record = mk_parser record_prec record_stmts body
 836 --              Using these two lines instead allows the derived
 837 --              read for infix and record bindings to read the prefix form
 838 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 839 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 840       | otherwise = prefix_parser
 841       where
 842         body = result_expr data_con as_needed
 843         con_str = data_con_str data_con
 844
 845         prefix_parser = mk_parser prefix_prec prefix_stmts body
 846
 847         read_prefix_con
 848             | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
 849             | otherwise     = [bindLex (ident_pat con_str)]
 850
 851         read_infix_con
 852             | isSym con_str = [bindLex (symbol_pat con_str)]
 853             | otherwise     = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
 854
 855         prefix_stmts            -- T a b c
 856           = read_prefix_con ++ read_args
 857
 858         infix_stmts             -- a %% b, or  a `T` b
 859           = [read_a1]
 860             ++ read_infix_con
 861             ++ [read_a2]
 862
 863         record_stmts            -- T { f1 = a, f2 = b }
 864           = read_prefix_con
 865             ++ [read_punc "{"]
 866             ++ concat (intersperse [read_punc ","] field_stmts)
 867             ++ [read_punc "}"]
 868
 869         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 870
 871         con_arity    = dataConSourceArity data_con
 872         labels       = dataConFieldLabels data_con
 873         dc_nm        = getName data_con
 874         is_infix     = dataConIsInfix data_con
 875         is_record    = length labels > 0
 876         as_needed    = take con_arity as_RDRs
 877         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 878         (read_a1:read_a2:_) = read_args
 879
 880         prefix_prec = appPrecedence
 881         infix_prec  = getPrecedence get_fixity dc_nm
 882         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 883                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 884
 885     ------------------------------------------------------------------------
 886     --          Helpers
 887     ------------------------------------------------------------------------
 888     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
 889     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
 890     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
 891     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
 892     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
 893
 894     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 895     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 896     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 897
 898     data_con_str con = occNameString (getOccName con)
 899
 900     read_punc c = bindLex (punc_pat c)
 901     read_arg a ty
 902         | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
 903         | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 904
 905     read_field lbl a = read_lbl lbl ++
 906                        [read_punc "=",
 907                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 908
 909         -- When reading field labels we might encounter
 910         --      a  = 3
 911         --      _a = 3
 912         -- or   (#) = 4
 913         -- Note the parens!
 914     read_lbl lbl | isSym lbl_str
 915                  = [read_punc "(",
 916                     bindLex (symbol_pat lbl_str),
 917                     read_punc ")"]
 918                  | otherwise
 919                  = [bindLex (ident_pat lbl_str)]
 920                  where
 921                    lbl_str = occNameString (getOccName lbl)
 922 \end{code}
 923
 924
 925 %************************************************************************
 926 %*                                                                      *
 927         Show instances
 928 %*                                                                      *
 929 %************************************************************************
 930
 931 Example
 932
 933     infixr 5 :^:
 934
 935     data Tree a =  Leaf a  |  Tree a :^: Tree a
 936
 937     instance (Show a) => Show (Tree a) where
 938
 939         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 940           where
 941              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 942
 943         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 944           where
 945              showStr = showsPrec (up_prec+1) u .
 946                        showString " :^: "      .
 947                        showsPrec (up_prec+1) v
 948                 -- Note: right-associativity of :^: ignored
 949
 950     up_prec  = 5    -- Precedence of :^:
 951     app_prec = 10   -- Application has precedence one more than
 952                     -- the most tightly-binding operator
 953
 954 \begin{code}
 955 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 956
 957 gen_Show_binds get_fixity loc tycon
 958   = (listToBag [shows_prec, show_list], [])
 959   where
 960     -----------------------------------------------------------------------
 961     show_list = mkVarBind loc showList_RDR
 962                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 963     -----------------------------------------------------------------------
 964     shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 965       where
 966         pats_etc data_con
 967           | nullary_con =  -- skip the showParen junk...
 968              ASSERT(null bs_needed)
 969              ([nlWildPat, con_pat], mk_showString_app con_str)
 970           | otherwise   =
 971              ([a_Pat, con_pat],
 972                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 973                                  (nlHsPar (nested_compose_Expr show_thingies)))
 974             where
 975              data_con_RDR  = getRdrName data_con
 976              con_arity     = dataConSourceArity data_con
 977              bs_needed     = take con_arity bs_RDRs
 978              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 979              con_pat       = nlConVarPat data_con_RDR bs_needed
 980              nullary_con   = con_arity == 0
 981              labels        = dataConFieldLabels data_con
 982              lab_fields    = length labels
 983              record_syntax = lab_fields > 0
 984
 985              dc_nm          = getName data_con
 986              dc_occ_nm      = getOccName data_con
 987              con_str        = occNameString dc_occ_nm
 988              op_con_str     = wrapOpParens con_str
 989              backquote_str  = wrapOpBackquotes con_str
 990
 991              show_thingies
 992                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
 993                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
 994                                   show_record_args ++ [mk_showString_app "}"]
 995                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
 996
 997              show_label l = mk_showString_app (nm ++ " = ")
 998                         -- Note the spaces around the "=" sign.  If we don't have them
 999                         -- then we get Foo { x=-1 } and the "=-" parses as a single
1000                         -- lexeme.  Only the space after the '=' is necessary, but
1001                         -- it seems tidier to have them both sides.
1002                  where
1003                    occ_nm   = getOccName l
1004                    nm       = wrapOpParens (occNameString occ_nm)
1005
1006              show_args               = zipWith show_arg bs_needed arg_tys
1007              (show_arg1:show_arg2:_) = show_args
1008              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
1009
1010                 --  Assumption for record syntax: no of fields == no of labelled fields
1011                 --            (and in same order)
1012              show_record_args = concat $
1013                                 intersperse [mk_showString_app ", "] $
1014                                 [ [show_label lbl, arg]
1015                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
1016                                                         labels show_args ]
1017
1018                 -- Generates (showsPrec p x) for argument x, but it also boxes
1019                 -- the argument first if necessary.  Note that this prints unboxed
1020                 -- things without any '#' decorations; could change that if need be
1021              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1022                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1023
1024                 -- Fixity stuff
1025              is_infix = dataConIsInfix data_con
1026              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1027              arg_prec | record_syntax = 0       -- Record fields don't need parens
1028                       | otherwise     = con_prec_plus_one
1029
1030 wrapOpParens :: String -> String
1031 wrapOpParens s | isSym s   = '(' : s ++ ")"
1032                | otherwise = s
1033
1034 wrapOpBackquotes :: String -> String
1035 wrapOpBackquotes s | isSym s   = s
1036                    | otherwise = '`' : s ++ "`"
1037
1038 isSym :: String -> Bool
1039 isSym ""      = False
1040 isSym (c : _) = startsVarSym c || startsConSym c
1041
1042 mk_showString_app :: String -> LHsExpr RdrName
1043 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1044 \end{code}
1045
1046 \begin{code}
1047 getPrec :: Bool -> FixityEnv -> Name -> Integer
1048 getPrec is_infix get_fixity nm
1049   | not is_infix   = appPrecedence
1050   | otherwise      = getPrecedence get_fixity nm
1051
1052 appPrecedence :: Integer
1053 appPrecedence = fromIntegral maxPrecedence + 1
1054   -- One more than the precedence of the most
1055   -- tightly-binding operator
1056
1057 getPrecedence :: FixityEnv -> Name -> Integer
1058 getPrecedence get_fixity nm
1059    = case lookupFixity get_fixity nm of
1060         Fixity x _assoc -> fromIntegral x
1061           -- NB: the Report says that associativity is not taken
1062           --     into account for either Read or Show; hence we
1063           --     ignore associativity here
1064 \end{code}
1065
1066
1067 %************************************************************************
1068 %*                                                                      *
1069 \subsection{Typeable}
1070 %*                                                                      *
1071 %************************************************************************
1072
1073 From the data type
1074
1075         data T a b = ....
1076
1077 we generate
1078
1079         instance Typeable2 T where
1080                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1081
1082 We are passed the Typeable2 class as well as T
1083
1084 \begin{code}
1085 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1086 gen_Typeable_binds loc tycon
1087   = unitBag $
1088         mk_easy_FunBind loc
1089                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1090                 [nlWildPat]
1091                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1092   where
1093     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1094
1095 mk_typeOf_RDR :: TyCon -> RdrName
1096 -- Use the arity of the TyCon to make the right typeOfn function
1097 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1098                 where
1099                   arity = tyConArity tycon
1100                   suffix | arity == 0 = ""
1101                          | otherwise  = show arity
1102 \end{code}
1103
1104
1105
1106 %************************************************************************
1107 %*                                                                      *
1108         Data instances
1109 %*                                                                      *
1110 %************************************************************************
1111
1112 From the data type
1113
1114   data T a b = T1 a b | T2
1115
1116 we generate
1117
1118   $cT1 = mkDataCon $dT "T1" Prefix
1119   $cT2 = mkDataCon $dT "T2" Prefix
1120   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1121   -- the [] is for field labels.
1122
1123   instance (Data a, Data b) => Data (T a b) where
1124     gfoldl k z (T1 a b) = z T `k` a `k` b
1125     gfoldl k z T2           = z T2
1126     -- ToDo: add gmapT,Q,M, gfoldr
1127
1128     gunfold k z c = case conIndex c of
1129                         I# 1# -> k (k (z T1))
1130                         I# 2# -> z T2
1131
1132     toConstr (T1 _ _) = $cT1
1133     toConstr T2       = $cT2
1134
1135     dataTypeOf _ = $dT
1136
1137 \begin{code}
1138 gen_Data_binds :: SrcSpan
1139                -> TyCon
1140                -> (LHsBinds RdrName,    -- The method bindings
1141                    DerivAuxBinds)       -- Auxiliary bindings
1142 gen_Data_binds loc tycon
1143   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1144                 -- Auxiliary definitions: the data type and constructors
1145      MkTyCon tycon : map MkDataCon data_cons)
1146   where
1147     data_cons  = tyConDataCons tycon
1148     n_cons     = length data_cons
1149     one_constr = n_cons == 1
1150
1151         ------------ gfoldl
1152     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1153     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1154                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1155                    where
1156                      con_name ::  RdrName
1157                      con_name = getRdrName con
1158                      as_needed = take (dataConSourceArity con) as_RDRs
1159                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1160
1161         ------------ gunfold
1162     gunfold_bind = mk_FunBind loc
1163                               gunfold_RDR
1164                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1165                                 gunfold_rhs)]
1166
1167     gunfold_rhs
1168         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1169         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1170                                 (map gunfold_alt data_cons)
1171
1172     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1173     mk_unfold_rhs dc = foldr nlHsApp
1174                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1175                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1176
1177     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1178                         -- redundant test, and annoying warning
1179       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1180       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1181       where
1182         tag = dataConTag dc
1183
1184         ------------ toConstr
1185     toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1186     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1187
1188         ------------ dataTypeOf
1189     dataTypeOf_bind = mk_easy_FunBind
1190                         loc
1191                         dataTypeOf_RDR
1192                         [nlWildPat]
1193                         (nlHsVar (mk_data_type_name tycon))
1194
1195
1196 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1197     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName
1198 gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
1199 gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
1200 toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
1201 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1202 mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
1203 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1204 conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
1205 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1206 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1207 \end{code}
1208
1209 %************************************************************************
1210 %*                                                                      *
1211 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1212 %*                                                                      *
1213 %************************************************************************
1214
1215 \begin{verbatim}
1216 data Foo ... = ...
1217
1218 con2tag_Foo :: Foo ... -> Int#
1219 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1220 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1221 \end{verbatim}
1222
1223 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1224 fiddling around.
1225
1226 \begin{code}
1227 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1228 genAuxBind loc (GenCon2Tag tycon)
1229   | lots_of_constructors
1230   = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1231
1232   | otherwise
1233   = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1234
1235   where
1236     rdr_name = con2tag_RDR tycon
1237
1238     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1239         -- We can't use gerRdrName because that makes an Exact  RdrName
1240         -- and we can't put them in the LocalRdrEnv
1241
1242         -- Give a signature to the bound variable, so
1243         -- that the case expression generated by getTag is
1244         -- monomorphic.  In the push-enter model we get better code.
1245     get_tag_rhs = L loc $ ExprWithTySig
1246                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1247                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1248                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1249
1250     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1251                 `nlHsFunTy`
1252                 nlHsTyVar (getRdrName intPrimTyCon)
1253
1254     lots_of_constructors = tyConFamilySize tycon > 8
1255                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1256                                 -- but we don't do vectored returns any more.
1257
1258     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1259     mk_stuff con = ([nlWildConPat con],
1260                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1261
1262 genAuxBind loc (GenTag2Con tycon)
1263   = mk_FunBind loc rdr_name
1264         [([nlConVarPat intDataCon_RDR [a_RDR]],
1265            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1266                          (nlHsTyVar (getRdrName tycon))))]
1267   where
1268     rdr_name = tag2con_RDR tycon
1269
1270 genAuxBind loc (GenMaxTag tycon)
1271   = mkVarBind loc rdr_name
1272                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1273   where
1274     rdr_name = maxtag_RDR tycon
1275     max_tag =  case (tyConDataCons tycon) of
1276                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1277
1278 genAuxBind loc (MkTyCon tycon)  --  $dT
1279   = mkVarBind loc (mk_data_type_name tycon)
1280                   ( nlHsVar mkDataType_RDR
1281                     `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1282                     `nlHsApp` nlList constrs )
1283   where
1284     constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1285
1286 genAuxBind loc (MkDataCon dc)   --  $cT1 etc
1287   = mkVarBind loc (mk_constr_name dc)
1288                   (nlHsApps mkConstr_RDR constr_args)
1289   where
1290     constr_args
1291        = [ -- nlHsIntLit (toInteger (dataConTag dc)),     -- Tag
1292            nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1293            nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
1294            nlList  labels,                                -- Field labels
1295            nlHsVar fixity]                                -- Fixity
1296
1297     labels   = map (nlHsLit . mkHsString . getOccString)
1298                    (dataConFieldLabels dc)
1299     dc_occ   = getOccName dc
1300     is_infix = isDataSymOcc dc_occ
1301     fixity | is_infix  = infix_RDR
1302            | otherwise = prefix_RDR
1303
1304 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
1305 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1306
1307 mk_constr_name :: DataCon -> RdrName    -- "$cC"
1308 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1309 \end{code}
1310
1311 %************************************************************************
1312 %*                                                                      *
1313 \subsection{Utility bits for generating bindings}
1314 %*                                                                      *
1315 %************************************************************************
1316
1317
1318 ToDo: Better SrcLocs.
1319
1320 \begin{code}
1321 compare_gen_Case ::
1322           LHsExpr RdrName       -- What to do for equality
1323           -> LHsExpr RdrName -> LHsExpr RdrName
1324           -> LHsExpr RdrName
1325 careful_compare_Case :: -- checks for primitive types...
1326           TyCon                 -- The tycon we are deriving for
1327           -> Type
1328           -> LHsExpr RdrName    -- What to do for equality
1329           -> LHsExpr RdrName -> LHsExpr RdrName
1330           -> LHsExpr RdrName
1331
1332 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1333 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1334         -- Was: compare_gen_Case cmp_eq_RDR
1335
1336 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1337   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1338 compare_gen_Case eq a b                         -- General case
1339   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1340       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1341        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1342        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1343
1344 careful_compare_Case tycon ty eq a b
1345   | not (isUnLiftedType ty)
1346   = compare_gen_Case eq a b
1347   | otherwise      -- We have to do something special for primitive things...
1348   = nlHsIf (genOpApp a relevant_lt_op b)        -- Test (<) first, not (==), becuase the latter
1349            ltTag_Expr                           -- is true less often, so putting it first would
1350                                                 -- mean more tests (dynamically)
1351            (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1352   where
1353     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1354     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1355
1356
1357 box_if_necy :: String           -- The class involved
1358             -> TyCon            -- The tycon involved
1359             -> LHsExpr RdrName  -- The argument
1360             -> Type             -- The argument type
1361             -> LHsExpr RdrName  -- Boxed version of the arg
1362 box_if_necy cls_str tycon arg arg_ty
1363   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1364   | otherwise             = arg
1365   where
1366     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1367
1368 assoc_ty_id :: String           -- The class involved
1369             -> TyCon            -- The tycon involved
1370             -> [(Type,a)]       -- The table
1371             -> Type             -- The type
1372             -> a                -- The result of the lookup
1373 assoc_ty_id cls_str _ tbl ty
1374   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1375                                               text "for primitive type" <+> ppr ty)
1376   | otherwise = head res
1377   where
1378     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1379
1380 eq_op_tbl :: [(Type, PrimOp)]
1381 eq_op_tbl =
1382     [(charPrimTy,       CharEqOp)
1383     ,(intPrimTy,        IntEqOp)
1384     ,(wordPrimTy,       WordEqOp)
1385     ,(addrPrimTy,       AddrEqOp)
1386     ,(floatPrimTy,      FloatEqOp)
1387     ,(doublePrimTy,     DoubleEqOp)
1388     ]
1389
1390 lt_op_tbl :: [(Type, PrimOp)]
1391 lt_op_tbl =
1392     [(charPrimTy,       CharLtOp)
1393     ,(intPrimTy,        IntLtOp)
1394     ,(wordPrimTy,       WordLtOp)
1395     ,(addrPrimTy,       AddrLtOp)
1396     ,(floatPrimTy,      FloatLtOp)
1397     ,(doublePrimTy,     DoubleLtOp)
1398     ]
1399
1400 box_con_tbl :: [(Type, RdrName)]
1401 box_con_tbl =
1402     [(charPrimTy,       getRdrName charDataCon)
1403     ,(intPrimTy,        getRdrName intDataCon)
1404     ,(wordPrimTy,       wordDataCon_RDR)
1405     ,(floatPrimTy,      getRdrName floatDataCon)
1406     ,(doublePrimTy,     getRdrName doubleDataCon)
1407     ]
1408
1409 -----------------------------------------------------------------------
1410
1411 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1412 and_Expr a b = genOpApp a and_RDR    b
1413
1414 -----------------------------------------------------------------------
1415
1416 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1417 eq_Expr tycon ty a b = genOpApp a eq_op b
1418  where
1419    eq_op
1420     | not (isUnLiftedType ty) = eq_RDR
1421     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1422          -- we have to do something special for primitive things...
1423 \end{code}
1424
1425 \begin{code}
1426 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1427 untag_Expr _ [] expr = expr
1428 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1429   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1430       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1431
1432 cmp_tags_Expr ::  RdrName               -- Comparison op
1433              ->  RdrName ->  RdrName    -- Things to compare
1434              -> LHsExpr RdrName                 -- What to return if true
1435              -> LHsExpr RdrName         -- What to return if false
1436              -> LHsExpr RdrName
1437
1438 cmp_tags_Expr op a b true_case false_case
1439   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1440
1441 enum_from_to_Expr
1442         :: LHsExpr RdrName -> LHsExpr RdrName
1443         -> LHsExpr RdrName
1444 enum_from_then_to_Expr
1445         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1446         -> LHsExpr RdrName
1447
1448 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1449 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1450
1451 showParen_Expr
1452         :: LHsExpr RdrName -> LHsExpr RdrName
1453         -> LHsExpr RdrName
1454
1455 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1456
1457 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1458
1459 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1460 nested_compose_Expr [e] = parenify e
1461 nested_compose_Expr (e:es)
1462   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1463
1464 -- impossible_Expr is used in case RHSs that should never happen.
1465 -- We generate these to keep the desugarer from complaining that they *might* happen!
1466 impossible_Expr :: LHsExpr RdrName
1467 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1468
1469 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1470 -- method. It is currently only used by Enum.{succ,pred}
1471 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1472 illegal_Expr meth tp msg =
1473    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1474
1475 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1476 -- to include the value of a_RDR in the error string.
1477 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1478 illegal_toEnum_tag tp maxtag =
1479    nlHsApp (nlHsVar error_RDR)
1480            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1481                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1482                     (nlHsApp (nlHsApp (nlHsApp
1483                            (nlHsVar showsPrec_RDR)
1484                            (nlHsIntLit 0))
1485                            (nlHsVar a_RDR))
1486                            (nlHsApp (nlHsApp
1487                                (nlHsVar append_RDR)
1488                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1489                                (nlHsApp (nlHsApp (nlHsApp
1490                                         (nlHsVar showsPrec_RDR)
1491                                         (nlHsIntLit 0))
1492                                         (nlHsVar maxtag))
1493                                         (nlHsLit (mkHsString ")"))))))
1494
1495 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1496 parenify e@(L _ (HsVar _)) = e
1497 parenify e                 = mkHsPar e
1498
1499 -- genOpApp wraps brackets round the operator application, so that the
1500 -- renamer won't subsequently try to re-associate it.
1501 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1502 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1503 \end{code}
1504
1505 \begin{code}
1506 a_RDR, b_RDR, c_RDR, d_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1507     cmp_eq_RDR :: RdrName
1508 a_RDR           = mkVarUnqual (fsLit "a")
1509 b_RDR           = mkVarUnqual (fsLit "b")
1510 c_RDR           = mkVarUnqual (fsLit "c")
1511 d_RDR           = mkVarUnqual (fsLit "d")
1512 k_RDR           = mkVarUnqual (fsLit "k")
1513 z_RDR           = mkVarUnqual (fsLit "z")
1514 ah_RDR          = mkVarUnqual (fsLit "a#")
1515 bh_RDR          = mkVarUnqual (fsLit "b#")
1516 ch_RDR          = mkVarUnqual (fsLit "c#")
1517 dh_RDR          = mkVarUnqual (fsLit "d#")
1518 cmp_eq_RDR      = mkVarUnqual (fsLit "cmp_eq")
1519
1520 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1521 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1522 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1523 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1524
1525 a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1526     false_Expr, true_Expr :: LHsExpr RdrName
1527 a_Expr          = nlHsVar a_RDR
1528 b_Expr          = nlHsVar b_RDR
1529 c_Expr          = nlHsVar c_RDR
1530 ltTag_Expr      = nlHsVar ltTag_RDR
1531 eqTag_Expr      = nlHsVar eqTag_RDR
1532 gtTag_Expr      = nlHsVar gtTag_RDR
1533 false_Expr      = nlHsVar false_RDR
1534 true_Expr       = nlHsVar true_RDR
1535
1536 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
1537 a_Pat           = nlVarPat a_RDR
1538 b_Pat           = nlVarPat b_RDR
1539 c_Pat           = nlVarPat c_RDR
1540 d_Pat           = nlVarPat d_RDR
1541 k_Pat           = nlVarPat k_RDR
1542 z_Pat           = nlVarPat z_RDR
1543
1544 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1545 -- Generates Orig s RdrName, for the binding positions
1546 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1547 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1548 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1549
1550 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1551 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1552
1553 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1554 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1555 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1556 -- But:  (a) that does not work well for standalone-deriving
1557 --       (b) an unqualified name is just fine, provided it can't clash with user code
1558 \end{code}
1559
1560 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1561 PrelNames, so PrelNames can't import PrimOp.
1562
1563 \begin{code}
1564 primOpRdrName :: PrimOp -> RdrName
1565 primOpRdrName op = getRdrName (primOpId op)
1566
1567 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1568     tagToEnum_RDR :: RdrName
1569 minusInt_RDR  = primOpRdrName IntSubOp
1570 eqInt_RDR     = primOpRdrName IntEqOp
1571 ltInt_RDR     = primOpRdrName IntLtOp
1572 geInt_RDR     = primOpRdrName IntGeOp
1573 leInt_RDR     = primOpRdrName IntLeOp
1574 tagToEnum_RDR = primOpRdrName TagToEnumOp
1575
1576 error_RDR :: RdrName
1577 error_RDR = getRdrName eRROR_ID
1578 \end{code}