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