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 -> dc
 692
 693     con_arity    = dataConSourceArity data_con
 694     data_con_RDR = getRdrName data_con
 695
 696     as_needed = take con_arity as_RDRs
 697     bs_needed = take con_arity bs_RDRs
 698     cs_needed = take con_arity cs_RDRs
 699
 700     con_pat  xs  = nlConVarPat data_con_RDR xs
 701     con_expr     = nlHsVarApps data_con_RDR cs_needed
 702
 703     --------------------------------------------------------------
 704     single_con_range
 705       = mk_easy_FunBind loc range_RDR
 706           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
 707         nlHsDo ListComp stmts con_expr
 708       where
 709         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 710
 711         mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
 712                                  (nlHsApp (nlHsVar range_RDR)
 713                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
 714
 715     ----------------
 716     single_con_index
 717       = mk_easy_FunBind loc unsafeIndex_RDR
 718                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 719                  con_pat cs_needed]
 720         -- We need to reverse the order we consider the components in
 721         -- so that
 722         --     range (l,u) !! index (l,u) i == i   -- when i is in range
 723         -- (from http://haskell.org/onlinereport/ix.html) holds.
 724                 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
 725       where
 726         -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
 727         mk_index []        = nlHsIntLit 0
 728         mk_index [(l,u,i)] = mk_one l u i
 729         mk_index ((l,u,i) : rest)
 730           = genOpApp (
 731                 mk_one l u i
 732             ) plus_RDR (
 733                 genOpApp (
 734                     (nlHsApp (nlHsVar unsafeRangeSize_RDR)
 735                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
 736                 ) times_RDR (mk_index rest)
 737            )
 738         mk_one l u i
 739           = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
 740
 741     ------------------
 742     single_con_inRange
 743       = mk_easy_FunBind loc inRange_RDR
 744                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 745                  con_pat cs_needed] $
 746           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
 747       where
 748         in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
 749                                                nlHsVar c]
 750 \end{code}
 751
 752 %************************************************************************
 753 %*                                                                      *
 754         Read instances
 755 %*                                                                      *
 756 %************************************************************************
 757
 758 Example
 759
 760   infix 4 %%
 761   data T = Int %% Int
 762          | T1 { f1 :: Int }
 763          | T2 T
 764
 765
 766 instance Read T where
 767   readPrec =
 768     parens
 769     ( prec 4 (
 770         do x           <- ReadP.step Read.readPrec
 771            Symbol "%%" <- Lex.lex
 772            y           <- ReadP.step Read.readPrec
 773            return (x %% y))
 774       +++
 775       prec (appPrec+1) (
 776         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 777         -- Record construction binds even more tightly than application
 778         do Ident "T1" <- Lex.lex
 779            Punc '{' <- Lex.lex
 780            Ident "f1" <- Lex.lex
 781            Punc '=' <- Lex.lex
 782            x          <- ReadP.reset Read.readPrec
 783            Punc '}' <- Lex.lex
 784            return (T1 { f1 = x }))
 785       +++
 786       prec appPrec (
 787         do Ident "T2" <- Lex.lexP
 788            x          <- ReadP.step Read.readPrec
 789            return (T2 x))
 790     )
 791
 792   readListPrec = readListPrecDefault
 793   readList     = readListDefault
 794
 795
 796 \begin{code}
 797 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 798
 799 gen_Read_binds get_fixity loc tycon
 800   = (listToBag [read_prec, default_readlist, default_readlistprec], [])
 801   where
 802     -----------------------------------------------------------------------
 803     default_readlist
 804         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 805
 806     default_readlistprec
 807         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 808     -----------------------------------------------------------------------
 809
 810     data_cons = tyConDataCons tycon
 811     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 812
 813     read_prec = mkVarBind loc readPrec_RDR
 814                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 815
 816     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 817     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 818
 819     read_nullary_cons
 820       = case nullary_cons of
 821             []    -> []
 822             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
 823                                     (result_expr con [])]
 824             _     -> [nlHsApp (nlHsVar choose_RDR)
 825                               (nlList (map mk_pair nullary_cons))]
 826
 827     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
 828                            result_expr con []]
 829                           Boxed
 830
 831     read_non_nullary_con data_con
 832       | is_infix  = mk_parser infix_prec  infix_stmts  body
 833       | is_record = mk_parser record_prec record_stmts body
 834 --              Using these two lines instead allows the derived
 835 --              read for infix and record bindings to read the prefix form
 836 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 837 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 838       | otherwise = prefix_parser
 839       where
 840         body = result_expr data_con as_needed
 841         con_str = data_con_str data_con
 842
 843         prefix_parser = mk_parser prefix_prec prefix_stmts body
 844
 845         read_prefix_con
 846             | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
 847             | otherwise     = [bindLex (ident_pat con_str)]
 848
 849         read_infix_con
 850             | isSym con_str = [bindLex (symbol_pat con_str)]
 851             | otherwise     = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
 852
 853         prefix_stmts            -- T a b c
 854           = read_prefix_con ++ read_args
 855
 856         infix_stmts             -- a %% b, or  a `T` b
 857           = [read_a1]
 858             ++ read_infix_con
 859             ++ [read_a2]
 860
 861         record_stmts            -- T { f1 = a, f2 = b }
 862           = read_prefix_con
 863             ++ [read_punc "{"]
 864             ++ concat (intersperse [read_punc ","] field_stmts)
 865             ++ [read_punc "}"]
 866
 867         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 868
 869         con_arity    = dataConSourceArity data_con
 870         labels       = dataConFieldLabels data_con
 871         dc_nm        = getName data_con
 872         is_infix     = dataConIsInfix data_con
 873         is_record    = length labels > 0
 874         as_needed    = take con_arity as_RDRs
 875         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 876         (read_a1:read_a2:_) = read_args
 877
 878         prefix_prec = appPrecedence
 879         infix_prec  = getPrecedence get_fixity dc_nm
 880         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 881                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 882
 883     ------------------------------------------------------------------------
 884     --          Helpers
 885     ------------------------------------------------------------------------
 886     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
 887     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
 888     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
 889     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
 890     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
 891
 892     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 893     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 894     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 895
 896     data_con_str con = occNameString (getOccName con)
 897
 898     read_punc c = bindLex (punc_pat c)
 899     read_arg a ty = ASSERT( not (isUnLiftedType ty) )
 900                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 901
 902     read_field lbl a = read_lbl lbl ++
 903                        [read_punc "=",
 904                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 905
 906         -- When reading field labels we might encounter
 907         --      a  = 3
 908         --      _a = 3
 909         -- or   (#) = 4
 910         -- Note the parens!
 911     read_lbl lbl | isSym lbl_str
 912                  = [read_punc "(",
 913                     bindLex (symbol_pat lbl_str),
 914                     read_punc ")"]
 915                  | otherwise
 916                  = [bindLex (ident_pat lbl_str)]
 917                  where
 918                    lbl_str = occNameString (getOccName lbl)
 919 \end{code}
 920
 921
 922 %************************************************************************
 923 %*                                                                      *
 924         Show instances
 925 %*                                                                      *
 926 %************************************************************************
 927
 928 Example
 929
 930     infixr 5 :^:
 931
 932     data Tree a =  Leaf a  |  Tree a :^: Tree a
 933
 934     instance (Show a) => Show (Tree a) where
 935
 936         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 937           where
 938              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 939
 940         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 941           where
 942              showStr = showsPrec (up_prec+1) u .
 943                        showString " :^: "      .
 944                        showsPrec (up_prec+1) v
 945                 -- Note: right-associativity of :^: ignored
 946
 947     up_prec  = 5    -- Precedence of :^:
 948     app_prec = 10   -- Application has precedence one more than
 949                     -- the most tightly-binding operator
 950
 951 \begin{code}
 952 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 953
 954 gen_Show_binds get_fixity loc tycon
 955   = (listToBag [shows_prec, show_list], [])
 956   where
 957     -----------------------------------------------------------------------
 958     show_list = mkVarBind loc showList_RDR
 959                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 960     -----------------------------------------------------------------------
 961     shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 962       where
 963         pats_etc data_con
 964           | nullary_con =  -- skip the showParen junk...
 965              ASSERT(null bs_needed)
 966              ([nlWildPat, con_pat], mk_showString_app con_str)
 967           | otherwise   =
 968              ([a_Pat, con_pat],
 969                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 970                                  (nlHsPar (nested_compose_Expr show_thingies)))
 971             where
 972              data_con_RDR  = getRdrName data_con
 973              con_arity     = dataConSourceArity data_con
 974              bs_needed     = take con_arity bs_RDRs
 975              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 976              con_pat       = nlConVarPat data_con_RDR bs_needed
 977              nullary_con   = con_arity == 0
 978              labels        = dataConFieldLabels data_con
 979              lab_fields    = length labels
 980              record_syntax = lab_fields > 0
 981
 982              dc_nm          = getName data_con
 983              dc_occ_nm      = getOccName data_con
 984              con_str        = occNameString dc_occ_nm
 985              op_con_str     = wrapOpParens con_str
 986              backquote_str  = wrapOpBackquotes con_str
 987
 988              show_thingies
 989                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
 990                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
 991                                   show_record_args ++ [mk_showString_app "}"]
 992                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
 993
 994              show_label l = mk_showString_app (nm ++ " = ")
 995                         -- Note the spaces around the "=" sign.  If we don't have them
 996                         -- then we get Foo { x=-1 } and the "=-" parses as a single
 997                         -- lexeme.  Only the space after the '=' is necessary, but
 998                         -- it seems tidier to have them both sides.
 999                  where
1000                    occ_nm   = getOccName l
1001                    nm       = wrapOpParens (occNameString occ_nm)
1002
1003              show_args               = zipWith show_arg bs_needed arg_tys
1004              (show_arg1:show_arg2:_) = show_args
1005              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
1006
1007                 --  Assumption for record syntax: no of fields == no of labelled fields
1008                 --            (and in same order)
1009              show_record_args = concat $
1010                                 intersperse [mk_showString_app ", "] $
1011                                 [ [show_label lbl, arg]
1012                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
1013                                                         labels show_args ]
1014
1015                 -- Generates (showsPrec p x) for argument x, but it also boxes
1016                 -- the argument first if necessary.  Note that this prints unboxed
1017                 -- things without any '#' decorations; could change that if need be
1018              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1019                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1020
1021                 -- Fixity stuff
1022              is_infix = dataConIsInfix data_con
1023              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1024              arg_prec | record_syntax = 0       -- Record fields don't need parens
1025                       | otherwise     = con_prec_plus_one
1026
1027 wrapOpParens :: String -> String
1028 wrapOpParens s | isSym s   = '(' : s ++ ")"
1029                | otherwise = s
1030
1031 wrapOpBackquotes :: String -> String
1032 wrapOpBackquotes s | isSym s   = s
1033                    | otherwise = '`' : s ++ "`"
1034
1035 isSym :: String -> Bool
1036 isSym ""      = False
1037 isSym (c : _) = startsVarSym c || startsConSym c
1038
1039 mk_showString_app :: String -> LHsExpr RdrName
1040 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1041 \end{code}
1042
1043 \begin{code}
1044 getPrec :: Bool -> FixityEnv -> Name -> Integer
1045 getPrec is_infix get_fixity nm
1046   | not is_infix   = appPrecedence
1047   | otherwise      = getPrecedence get_fixity nm
1048
1049 appPrecedence :: Integer
1050 appPrecedence = fromIntegral maxPrecedence + 1
1051   -- One more than the precedence of the most
1052   -- tightly-binding operator
1053
1054 getPrecedence :: FixityEnv -> Name -> Integer
1055 getPrecedence get_fixity nm
1056    = case lookupFixity get_fixity nm of
1057         Fixity x _assoc -> fromIntegral x
1058           -- NB: the Report says that associativity is not taken
1059           --     into account for either Read or Show; hence we
1060           --     ignore associativity here
1061 \end{code}
1062
1063
1064 %************************************************************************
1065 %*                                                                      *
1066 \subsection{Typeable}
1067 %*                                                                      *
1068 %************************************************************************
1069
1070 From the data type
1071
1072         data T a b = ....
1073
1074 we generate
1075
1076         instance Typeable2 T where
1077                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1078
1079 We are passed the Typeable2 class as well as T
1080
1081 \begin{code}
1082 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1083 gen_Typeable_binds loc tycon
1084   = unitBag $
1085         mk_easy_FunBind loc
1086                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1087                 [nlWildPat]
1088                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1089   where
1090     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1091
1092 mk_typeOf_RDR :: TyCon -> RdrName
1093 -- Use the arity of the TyCon to make the right typeOfn function
1094 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1095                 where
1096                   arity = tyConArity tycon
1097                   suffix | arity == 0 = ""
1098                          | otherwise  = show arity
1099 \end{code}
1100
1101
1102
1103 %************************************************************************
1104 %*                                                                      *
1105         Data instances
1106 %*                                                                      *
1107 %************************************************************************
1108
1109 From the data type
1110
1111   data T a b = T1 a b | T2
1112
1113 we generate
1114
1115   $cT1 = mkDataCon $dT "T1" Prefix
1116   $cT2 = mkDataCon $dT "T2" Prefix
1117   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1118   -- the [] is for field labels.
1119
1120   instance (Data a, Data b) => Data (T a b) where
1121     gfoldl k z (T1 a b) = z T `k` a `k` b
1122     gfoldl k z T2           = z T2
1123     -- ToDo: add gmapT,Q,M, gfoldr
1124
1125     gunfold k z c = case conIndex c of
1126                         I# 1# -> k (k (z T1))
1127                         I# 2# -> z T2
1128
1129     toConstr (T1 _ _) = $cT1
1130     toConstr T2       = $cT2
1131
1132     dataTypeOf _ = $dT
1133
1134 \begin{code}
1135 gen_Data_binds :: SrcSpan
1136                -> TyCon
1137                -> (LHsBinds RdrName,    -- The method bindings
1138                    DerivAuxBinds)       -- Auxiliary bindings
1139 gen_Data_binds loc tycon
1140   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1141                 -- Auxiliary definitions: the data type and constructors
1142      MkTyCon tycon : map MkDataCon data_cons)
1143   where
1144     data_cons  = tyConDataCons tycon
1145     n_cons     = length data_cons
1146     one_constr = n_cons == 1
1147
1148         ------------ gfoldl
1149     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1150     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1151                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1152                    where
1153                      con_name ::  RdrName
1154                      con_name = getRdrName con
1155                      as_needed = take (dataConSourceArity con) as_RDRs
1156                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1157
1158         ------------ gunfold
1159     gunfold_bind = mk_FunBind loc
1160                               gunfold_RDR
1161                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1162                                 gunfold_rhs)]
1163
1164     gunfold_rhs
1165         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1166         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1167                                 (map gunfold_alt data_cons)
1168
1169     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1170     mk_unfold_rhs dc = foldr nlHsApp
1171                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1172                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1173
1174     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1175                         -- redundant test, and annoying warning
1176       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1177       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1178       where
1179         tag = dataConTag dc
1180
1181         ------------ toConstr
1182     toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1183     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1184
1185         ------------ dataTypeOf
1186     dataTypeOf_bind = mk_easy_FunBind
1187                         loc
1188                         dataTypeOf_RDR
1189                         [nlWildPat]
1190                         (nlHsVar (mk_data_type_name tycon))
1191
1192
1193 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1194     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName
1195 gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
1196 gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
1197 toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
1198 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1199 mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
1200 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1201 conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
1202 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1203 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1204 \end{code}
1205
1206 %************************************************************************
1207 %*                                                                      *
1208 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1209 %*                                                                      *
1210 %************************************************************************
1211
1212 \begin{verbatim}
1213 data Foo ... = ...
1214
1215 con2tag_Foo :: Foo ... -> Int#
1216 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1217 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1218 \end{verbatim}
1219
1220 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1221 fiddling around.
1222
1223 \begin{code}
1224 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1225 genAuxBind loc (GenCon2Tag tycon)
1226   | lots_of_constructors
1227   = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1228
1229   | otherwise
1230   = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1231
1232   where
1233     rdr_name = con2tag_RDR tycon
1234
1235     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1236         -- We can't use gerRdrName because that makes an Exact  RdrName
1237         -- and we can't put them in the LocalRdrEnv
1238
1239         -- Give a signature to the bound variable, so
1240         -- that the case expression generated by getTag is
1241         -- monomorphic.  In the push-enter model we get better code.
1242     get_tag_rhs = L loc $ ExprWithTySig
1243                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1244                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1245                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1246
1247     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1248                 `nlHsFunTy`
1249                 nlHsTyVar (getRdrName intPrimTyCon)
1250
1251     lots_of_constructors = tyConFamilySize tycon > 8
1252                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1253                                 -- but we don't do vectored returns any more.
1254
1255     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1256     mk_stuff con = ([nlWildConPat con],
1257                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1258
1259 genAuxBind loc (GenTag2Con tycon)
1260   = mk_FunBind loc rdr_name
1261         [([nlConVarPat intDataCon_RDR [a_RDR]],
1262            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1263                          (nlHsTyVar (getRdrName tycon))))]
1264   where
1265     rdr_name = tag2con_RDR tycon
1266
1267 genAuxBind loc (GenMaxTag tycon)
1268   = mkVarBind loc rdr_name
1269                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1270   where
1271     rdr_name = maxtag_RDR tycon
1272     max_tag =  case (tyConDataCons tycon) of
1273                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1274
1275 genAuxBind loc (MkTyCon tycon)  --  $dT
1276   = mkVarBind loc (mk_data_type_name tycon)
1277                   ( nlHsVar mkDataType_RDR
1278                     `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1279                     `nlHsApp` nlList constrs )
1280   where
1281     constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1282
1283 genAuxBind loc (MkDataCon dc)   --  $cT1 etc
1284   = mkVarBind loc (mk_constr_name dc)
1285                   (nlHsApps mkConstr_RDR constr_args)
1286   where
1287     constr_args
1288        = [ -- nlHsIntLit (toInteger (dataConTag dc)),     -- Tag
1289            nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1290            nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
1291            nlList  labels,                                -- Field labels
1292            nlHsVar fixity]                                -- Fixity
1293
1294     labels   = map (nlHsLit . mkHsString . getOccString)
1295                    (dataConFieldLabels dc)
1296     dc_occ   = getOccName dc
1297     is_infix = isDataSymOcc dc_occ
1298     fixity | is_infix  = infix_RDR
1299            | otherwise = prefix_RDR
1300
1301 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
1302 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1303
1304 mk_constr_name :: DataCon -> RdrName    -- "$cC"
1305 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1306 \end{code}
1307
1308 %************************************************************************
1309 %*                                                                      *
1310 \subsection{Utility bits for generating bindings}
1311 %*                                                                      *
1312 %************************************************************************
1313
1314
1315 ToDo: Better SrcLocs.
1316
1317 \begin{code}
1318 compare_gen_Case ::
1319           LHsExpr RdrName       -- What to do for equality
1320           -> LHsExpr RdrName -> LHsExpr RdrName
1321           -> LHsExpr RdrName
1322 careful_compare_Case :: -- checks for primitive types...
1323           TyCon                 -- The tycon we are deriving for
1324           -> Type
1325           -> LHsExpr RdrName    -- What to do for equality
1326           -> LHsExpr RdrName -> LHsExpr RdrName
1327           -> LHsExpr RdrName
1328
1329 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1330 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1331         -- Was: compare_gen_Case cmp_eq_RDR
1332
1333 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1334   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1335 compare_gen_Case eq a b                         -- General case
1336   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1337       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1338        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1339        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1340
1341 careful_compare_Case tycon ty eq a b
1342   | not (isUnLiftedType ty)
1343   = compare_gen_Case eq a b
1344   | otherwise      -- We have to do something special for primitive things...
1345   = nlHsIf (genOpApp a relevant_lt_op b)        -- Test (<) first, not (==), becuase the latter
1346            ltTag_Expr                           -- is true less often, so putting it first would
1347                                                 -- mean more tests (dynamically)
1348            (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1349   where
1350     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1351     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1352
1353
1354 box_if_necy :: String           -- The class involved
1355             -> TyCon            -- The tycon involved
1356             -> LHsExpr RdrName  -- The argument
1357             -> Type             -- The argument type
1358             -> LHsExpr RdrName  -- Boxed version of the arg
1359 box_if_necy cls_str tycon arg arg_ty
1360   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1361   | otherwise             = arg
1362   where
1363     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1364
1365 assoc_ty_id :: String           -- The class involved
1366             -> TyCon            -- The tycon involved
1367             -> [(Type,a)]       -- The table
1368             -> Type             -- The type
1369             -> a                -- The result of the lookup
1370 assoc_ty_id cls_str _ tbl ty
1371   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1372                                               text "for primitive type" <+> ppr ty)
1373   | otherwise = head res
1374   where
1375     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1376
1377 eq_op_tbl :: [(Type, PrimOp)]
1378 eq_op_tbl =
1379     [(charPrimTy,       CharEqOp)
1380     ,(intPrimTy,        IntEqOp)
1381     ,(wordPrimTy,       WordEqOp)
1382     ,(addrPrimTy,       AddrEqOp)
1383     ,(floatPrimTy,      FloatEqOp)
1384     ,(doublePrimTy,     DoubleEqOp)
1385     ]
1386
1387 lt_op_tbl :: [(Type, PrimOp)]
1388 lt_op_tbl =
1389     [(charPrimTy,       CharLtOp)
1390     ,(intPrimTy,        IntLtOp)
1391     ,(wordPrimTy,       WordLtOp)
1392     ,(addrPrimTy,       AddrLtOp)
1393     ,(floatPrimTy,      FloatLtOp)
1394     ,(doublePrimTy,     DoubleLtOp)
1395     ]
1396
1397 box_con_tbl :: [(Type, RdrName)]
1398 box_con_tbl =
1399     [(charPrimTy,       getRdrName charDataCon)
1400     ,(intPrimTy,        getRdrName intDataCon)
1401     ,(wordPrimTy,       wordDataCon_RDR)
1402     ,(floatPrimTy,      getRdrName floatDataCon)
1403     ,(doublePrimTy,     getRdrName doubleDataCon)
1404     ]
1405
1406 -----------------------------------------------------------------------
1407
1408 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1409 and_Expr a b = genOpApp a and_RDR    b
1410
1411 -----------------------------------------------------------------------
1412
1413 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1414 eq_Expr tycon ty a b = genOpApp a eq_op b
1415  where
1416    eq_op
1417     | not (isUnLiftedType ty) = eq_RDR
1418     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1419          -- we have to do something special for primitive things...
1420 \end{code}
1421
1422 \begin{code}
1423 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1424 untag_Expr _ [] expr = expr
1425 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1426   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1427       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1428
1429 cmp_tags_Expr ::  RdrName               -- Comparison op
1430              ->  RdrName ->  RdrName    -- Things to compare
1431              -> LHsExpr RdrName                 -- What to return if true
1432              -> LHsExpr RdrName         -- What to return if false
1433              -> LHsExpr RdrName
1434
1435 cmp_tags_Expr op a b true_case false_case
1436   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1437
1438 enum_from_to_Expr
1439         :: LHsExpr RdrName -> LHsExpr RdrName
1440         -> LHsExpr RdrName
1441 enum_from_then_to_Expr
1442         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1443         -> LHsExpr RdrName
1444
1445 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1446 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1447
1448 showParen_Expr
1449         :: LHsExpr RdrName -> LHsExpr RdrName
1450         -> LHsExpr RdrName
1451
1452 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1453
1454 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1455
1456 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1457 nested_compose_Expr [e] = parenify e
1458 nested_compose_Expr (e:es)
1459   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1460
1461 -- impossible_Expr is used in case RHSs that should never happen.
1462 -- We generate these to keep the desugarer from complaining that they *might* happen!
1463 impossible_Expr :: LHsExpr RdrName
1464 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1465
1466 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1467 -- method. It is currently only used by Enum.{succ,pred}
1468 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1469 illegal_Expr meth tp msg =
1470    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1471
1472 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1473 -- to include the value of a_RDR in the error string.
1474 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1475 illegal_toEnum_tag tp maxtag =
1476    nlHsApp (nlHsVar error_RDR)
1477            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1478                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1479                     (nlHsApp (nlHsApp (nlHsApp
1480                            (nlHsVar showsPrec_RDR)
1481                            (nlHsIntLit 0))
1482                            (nlHsVar a_RDR))
1483                            (nlHsApp (nlHsApp
1484                                (nlHsVar append_RDR)
1485                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1486                                (nlHsApp (nlHsApp (nlHsApp
1487                                         (nlHsVar showsPrec_RDR)
1488                                         (nlHsIntLit 0))
1489                                         (nlHsVar maxtag))
1490                                         (nlHsLit (mkHsString ")"))))))
1491
1492 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1493 parenify e@(L _ (HsVar _)) = e
1494 parenify e                 = mkHsPar e
1495
1496 -- genOpApp wraps brackets round the operator application, so that the
1497 -- renamer won't subsequently try to re-associate it.
1498 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1499 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1500 \end{code}
1501
1502 \begin{code}
1503 a_RDR, b_RDR, c_RDR, d_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1504     cmp_eq_RDR :: RdrName
1505 a_RDR           = mkVarUnqual (fsLit "a")
1506 b_RDR           = mkVarUnqual (fsLit "b")
1507 c_RDR           = mkVarUnqual (fsLit "c")
1508 d_RDR           = mkVarUnqual (fsLit "d")
1509 k_RDR           = mkVarUnqual (fsLit "k")
1510 z_RDR           = mkVarUnqual (fsLit "z")
1511 ah_RDR          = mkVarUnqual (fsLit "a#")
1512 bh_RDR          = mkVarUnqual (fsLit "b#")
1513 ch_RDR          = mkVarUnqual (fsLit "c#")
1514 dh_RDR          = mkVarUnqual (fsLit "d#")
1515 cmp_eq_RDR      = mkVarUnqual (fsLit "cmp_eq")
1516
1517 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1518 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1519 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1520 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1521
1522 a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1523     false_Expr, true_Expr :: LHsExpr RdrName
1524 a_Expr          = nlHsVar a_RDR
1525 b_Expr          = nlHsVar b_RDR
1526 c_Expr          = nlHsVar c_RDR
1527 ltTag_Expr      = nlHsVar ltTag_RDR
1528 eqTag_Expr      = nlHsVar eqTag_RDR
1529 gtTag_Expr      = nlHsVar gtTag_RDR
1530 false_Expr      = nlHsVar false_RDR
1531 true_Expr       = nlHsVar true_RDR
1532
1533 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
1534 a_Pat           = nlVarPat a_RDR
1535 b_Pat           = nlVarPat b_RDR
1536 c_Pat           = nlVarPat c_RDR
1537 d_Pat           = nlVarPat d_RDR
1538 k_Pat           = nlVarPat k_RDR
1539 z_Pat           = nlVarPat z_RDR
1540
1541 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1542 -- Generates Orig s RdrName, for the binding positions
1543 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1544 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1545 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1546
1547 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1548 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1549
1550 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1551 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1552 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1553 -- But:  (a) that does not work well for standalone-deriving
1554 --       (b) an unqualified name is just fine, provided it can't clash with user code
1555 \end{code}
1556
1557 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1558 PrelNames, so PrelNames can't import PrimOp.
1559
1560 \begin{code}
1561 primOpRdrName :: PrimOp -> RdrName
1562 primOpRdrName op = getRdrName (primOpId op)
1563
1564 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1565     tagToEnum_RDR :: RdrName
1566 minusInt_RDR  = primOpRdrName IntSubOp
1567 eqInt_RDR     = primOpRdrName IntEqOp
1568 ltInt_RDR     = primOpRdrName IntLtOp
1569 geInt_RDR     = primOpRdrName IntGeOp
1570 leInt_RDR     = primOpRdrName IntLeOp
1571 tagToEnum_RDR = primOpRdrName TagToEnumOp
1572
1573 error_RDR :: RdrName
1574 error_RDR = getRdrName eRROR_ID
1575 \end{code}