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