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         gen_Functor_binds,
  27         FFoldType(..), functorLikeTraverse,
  28         deepSubtypesContaining, foldDataConArgs,
  29         gen_Foldable_binds,
  30         gen_Traversable_binds,
  31         genAuxBind
  32     ) where
  33
  34 #include "HsVersions.h"
  35
  36 import HsSyn
  37 import RdrName
  38 import BasicTypes
  39 import DataCon
  40 import Name
  41
  42 import HscTypes
  43 import PrelInfo
  44 import MkCore   ( eRROR_ID )
  45 import PrelNames
  46 import PrimOp
  47 import SrcLoc
  48 import TyCon
  49 import TcType
  50 import TysPrim
  51 import TysWiredIn
  52 import Type
  53 import Var( TyVar )
  54 import TypeRep
  55 import VarSet
  56 import State
  57 import Util
  58 import MonadUtils
  59 import Outputable
  60 import FastString
  61 import Bag
  62 import Data.List        ( partition, intersperse )
  63 \end{code}
  64
  65 \begin{code}
  66 type DerivAuxBinds = [DerivAuxBind]
  67
  68 data DerivAuxBind               -- Please add these auxiliary top-level bindings
  69   = GenCon2Tag TyCon            -- The con2Tag for given TyCon
  70   | GenTag2Con TyCon            -- ...ditto tag2Con
  71   | GenMaxTag  TyCon            -- ...and maxTag
  72         -- All these generate ZERO-BASED tag operations
  73         -- I.e first constructor has tag 0
  74
  75         -- Scrap your boilerplate
  76   | MkDataCon DataCon           -- For constructor C we get $cC :: Constr
  77   | MkTyCon   TyCon             -- For tycon T we get       $tT :: DataType
  78
  79
  80 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
  81 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
  82 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
  83 isDupAux (GenMaxTag tc1)  (GenMaxTag tc2)  = tc1 == tc2
  84 isDupAux (MkDataCon dc1)  (MkDataCon dc2)  = dc1 == dc2
  85 isDupAux (MkTyCon tc1)    (MkTyCon tc2)    = tc1 == tc2
  86 isDupAux _                _                = False
  87 \end{code}
  88
  89
  90 %************************************************************************
  91 %*                                                                      *
  92                 Eq instances
  93 %*                                                                      *
  94 %************************************************************************
  95
  96 Here are the heuristics for the code we generate for @Eq@:
  97 \begin{itemize}
  98 \item
  99   Let's assume we have a data type with some (possibly zero) nullary
 100   data constructors and some ordinary, non-nullary ones (the rest,
 101   also possibly zero of them).  Here's an example, with both \tr{N}ullary
 102   and \tr{O}rdinary data cons.
 103 \begin{verbatim}
 104 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 105 \end{verbatim}
 106
 107 \item
 108   For the ordinary constructors (if any), we emit clauses to do The
 109   Usual Thing, e.g.,:
 110
 111 \begin{verbatim}
 112 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
 113 (==) (O2 a1)       (O2 a2)       = a1 == a2
 114 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
 115 \end{verbatim}
 116
 117   Note: if we're comparing unlifted things, e.g., if \tr{a1} and
 118   \tr{a2} are \tr{Float#}s, then we have to generate
 119 \begin{verbatim}
 120 case (a1 `eqFloat#` a2) of
 121   r -> r
 122 \end{verbatim}
 123   for that particular test.
 124
 125 \item
 126   If there are any nullary constructors, we emit a catch-all clause of
 127   the form:
 128
 129 \begin{verbatim}
 130 (==) a b  = case (con2tag_Foo a) of { a# ->
 131             case (con2tag_Foo b) of { b# ->
 132             case (a# ==# b#)     of {
 133               r -> r
 134             }}}
 135 \end{verbatim}
 136
 137   If there aren't any nullary constructors, we emit a simpler
 138   catch-all:
 139 \begin{verbatim}
 140 (==) a b  = False
 141 \end{verbatim}
 142
 143 \item
 144   For the @(/=)@ method, we normally just use the default method.
 145
 146   If the type is an enumeration type, we could/may/should? generate
 147   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 148   above.
 149
 150 \item
 151   We thought about doing this: If we're also deriving @Ord@ for this
 152   tycon, we generate:
 153 \begin{verbatim}
 154 instance ... Eq (Foo ...) where
 155   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 156   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 157 \begin{verbatim}
 158   However, that requires that \tr{Ord <whatever>} was put in the context
 159   for the instance decl, which it probably wasn't, so the decls
 160   produced don't get through the typechecker.
 161 \end{itemize}
 162
 163
 164 \begin{code}
 165 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 166 gen_Eq_binds loc tycon
 167   = (method_binds, aux_binds)
 168   where
 169     (nullary_cons, nonnullary_cons)
 170        | isNewTyCon tycon = ([], tyConDataCons tycon)
 171        | otherwise        = partition isNullarySrcDataCon (tyConDataCons tycon)
 172
 173     no_nullary_cons = null nullary_cons
 174
 175     rest | no_nullary_cons
 176          = case tyConSingleDataCon_maybe tycon of
 177                   Just _ -> []
 178                   Nothing -> -- if cons don't match, then False
 179                      [([nlWildPat, nlWildPat], false_Expr)]
 180          | otherwise -- calc. and compare the tags
 181          = [([a_Pat, b_Pat],
 182             untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 183                        (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 184
 185     aux_binds | no_nullary_cons = []
 186               | otherwise       = [GenCon2Tag tycon]
 187
 188     method_binds = listToBag [eq_bind, ne_bind]
 189     eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
 190     ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
 191                         nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
 192
 193     ------------------------------------------------------------------
 194     pats_etc data_con
 195       = let
 196             con1_pat = nlConVarPat data_con_RDR as_needed
 197             con2_pat = nlConVarPat data_con_RDR bs_needed
 198
 199             data_con_RDR = getRdrName data_con
 200             con_arity   = length tys_needed
 201             as_needed   = take con_arity as_RDRs
 202             bs_needed   = take con_arity bs_RDRs
 203             tys_needed  = dataConOrigArgTys data_con
 204         in
 205         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 206       where
 207         nested_eq_expr []  [] [] = true_Expr
 208         nested_eq_expr tys as bs
 209           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 210           where
 211             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
 212 \end{code}
 213
 214 %************************************************************************
 215 %*                                                                      *
 216         Ord instances
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 Note [Generating Ord instances]
 221 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 222 Suppose constructors are K1..Kn, and some are nullary.
 223 The general form we generate is:
 224
 225 * Do case on first argument
 226         case a of
 227           K1 ... -> rhs_1
 228           K2 ... -> rhs_2
 229           ...
 230           Kn ... -> rhs_n
 231           _ -> nullary_rhs
 232
 233 * To make rhs_i
 234      If i = 1, 2, n-1, n, generate a single case.
 235         rhs_2    case b of
 236                    K1 {}  -> LT
 237                    K2 ... -> ...eq_rhs(K2)...
 238                    _      -> GT
 239
 240      Otherwise do a tag compare against the bigger range
 241      (because this is the one most likely to succeed)
 242         rhs_3    case tag b of tb ->
 243                  if 3 <# tg then GT
 244                  else case b of
 245                          K3 ... -> ...eq_rhs(K3)....
 246                          _      -> LT
 247
 248 * To make eq_rhs(K), which knows that
 249     a = K a1 .. av
 250     b = K b1 .. bv
 251   we just want to compare (a1,b1) then (a2,b2) etc.
 252   Take care on the last field to tail-call into comparing av,bv
 253
 254 * To make nullary_rhs generate this
 255      case con2tag a of a# ->
 256      case con2tag b of ->
 257      a# `compare` b#
 258
 259 Several special cases:
 260
 261 * Two or fewer nullary constructors: don't generate nullary_rhs
 262
 263 * Be careful about unlifted comparisons.  When comparing unboxed
 264   values we can't call the overloaded functions.
 265   See function unliftedOrdOp
 266
 267 Note [Do not rely on compare]
 268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 269 It's a bad idea to define only 'compare', and build the other binary
 270 comparisions on top of it; see Trac #2130, #4019.  Reason: we don't
 271 want to laboriously make a three-way comparison, only to extract a
 272 binary result, something like this:
 273      (>) (I# x) (I# y) = case <# x y of
 274                             True -> False
 275                             False -> case ==# x y of
 276                                        True  -> False
 277                                        False -> True
 278
 279 So for sufficiently small types (few constructors, or all nullary)
 280 we generate all methods; for large ones we just use 'compare'.
 281
 282 \begin{code}
 283 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
 284
 285 ------------
 286 ordMethRdr :: OrdOp -> RdrName
 287 ordMethRdr op
 288   = case op of
 289        OrdCompare -> compare_RDR
 290        OrdLT      -> lt_RDR
 291        OrdLE      -> le_RDR
 292        OrdGE      -> ge_RDR
 293        OrdGT      -> gt_RDR
 294
 295 ------------
 296 ltResult :: OrdOp -> LHsExpr RdrName
 297 -- Knowing a<b, what is the result for a `op` b?
 298 ltResult OrdCompare = ltTag_Expr
 299 ltResult OrdLT      = true_Expr
 300 ltResult OrdLE      = true_Expr
 301 ltResult OrdGE      = false_Expr
 302 ltResult OrdGT      = false_Expr
 303
 304 ------------
 305 eqResult :: OrdOp -> LHsExpr RdrName
 306 -- Knowing a=b, what is the result for a `op` b?
 307 eqResult OrdCompare = eqTag_Expr
 308 eqResult OrdLT      = false_Expr
 309 eqResult OrdLE      = true_Expr
 310 eqResult OrdGE      = true_Expr
 311 eqResult OrdGT      = false_Expr
 312
 313 ------------
 314 gtResult :: OrdOp -> LHsExpr RdrName
 315 -- Knowing a>b, what is the result for a `op` b?
 316 gtResult OrdCompare = gtTag_Expr
 317 gtResult OrdLT      = false_Expr
 318 gtResult OrdLE      = false_Expr
 319 gtResult OrdGE      = true_Expr
 320 gtResult OrdGT      = true_Expr
 321
 322 ------------
 323 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 324 gen_Ord_binds loc tycon
 325   | null tycon_data_cons        -- No data-cons => invoke bale-out case
 326   = (unitBag $ mk_FunBind loc compare_RDR [], [])
 327   | otherwise
 328   = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
 329   where
 330     aux_binds | single_con_type = []
 331               | otherwise       = [GenCon2Tag tycon]
 332
 333         -- Note [Do not rely on compare]
 334     other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
 335                 || null non_nullary_cons        -- Or it's an enumeration
 336               = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
 337               | otherwise
 338               = emptyBag
 339
 340     get_tag con = dataConTag con - fIRST_TAG
 341         -- We want *zero-based* tags, because that's what
 342         -- con2Tag returns (generated by untag_Expr)!
 343
 344     tycon_data_cons = tyConDataCons tycon
 345     single_con_type = isSingleton tycon_data_cons
 346     (first_con : _) = tycon_data_cons
 347     (last_con : _)  = reverse tycon_data_cons
 348     first_tag       = get_tag first_con
 349     last_tag        = get_tag last_con
 350
 351     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
 352
 353
 354     mkOrdOp :: OrdOp -> LHsBind RdrName
 355     -- Returns a binding   op a b = ... compares a and b according to op ....
 356     mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
 357
 358     mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
 359     mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
 360       | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
 361       = nlHsCase (nlHsVar a_RDR) $
 362         map (mkOrdOpAlt op) tycon_data_cons
 363         -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
 364         --                   C2 x   -> case b of C2 x -> ....comopare x.... }
 365
 366       | null non_nullary_cons    -- All nullary, so go straight to comparing tags
 367       = mkTagCmp op
 368
 369       | otherwise                -- Mixed nullary and non-nullary
 370       = nlHsCase (nlHsVar a_RDR) $
 371         (map (mkOrdOpAlt op) non_nullary_cons
 372          ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
 373
 374
 375     mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName
 376     -- Make the alternative  (Ki a1 a2 .. av ->
 377     mkOrdOpAlt op data_con
 378       = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
 379       where
 380         as_needed    = take (dataConSourceArity data_con) as_RDRs
 381         data_con_RDR = getRdrName data_con
 382
 383     mkInnerRhs op data_con
 384       | single_con_type
 385       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
 386
 387       | tag == first_tag
 388       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
 389                                  , mkSimpleHsAlt nlWildPat (ltResult op) ]
 390       | tag == last_tag
 391       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
 392                                  , mkSimpleHsAlt nlWildPat (gtResult op) ]
 393
 394       | tag == first_tag + 1
 395       = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
 396                                  , mkInnerEqAlt op data_con
 397                                  , mkSimpleHsAlt nlWildPat (ltResult op) ]
 398       | tag == last_tag - 1
 399       = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
 400                                  , mkInnerEqAlt op data_con
 401                                  , mkSimpleHsAlt nlWildPat (gtResult op) ]
 402
 403       | tag > last_tag `div` 2  -- lower range is larger
 404       = untag_Expr tycon [(b_RDR, bh_RDR)] $
 405         nlHsIf (genOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
 406                (gtResult op) $  -- Definitely GT
 407         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
 408                                  , mkSimpleHsAlt nlWildPat (ltResult op) ]
 409
 410       | otherwise               -- upper range is larger
 411       = untag_Expr tycon [(b_RDR, bh_RDR)] $
 412         nlHsIf (genOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
 413                (ltResult op) $  -- Definitely LT
 414         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
 415                                  , mkSimpleHsAlt nlWildPat (gtResult op) ]
 416       where
 417         tag     = get_tag data_con
 418         tag_lit = noLoc (HsLit (HsIntPrim (toInteger tag)))
 419
 420     mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName
 421     -- First argument 'a' known to be built with K
 422     -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
 423     mkInnerEqAlt op data_con
 424       = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
 425         mkCompareFields tycon op (dataConOrigArgTys data_con)
 426       where
 427         data_con_RDR = getRdrName data_con
 428         bs_needed    = take (dataConSourceArity data_con) bs_RDRs
 429
 430     mkTagCmp :: OrdOp -> LHsExpr RdrName
 431     -- Both constructors known to be nullary
 432     -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
 433     mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
 434                   unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
 435
 436 mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
 437 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
 438 -- where the ai,bi have the given types
 439 mkCompareFields tycon op tys
 440   = go tys as_RDRs bs_RDRs
 441   where
 442     go []   _      _          = eqResult op
 443     go [ty] (a:_)  (b:_)
 444       | isUnLiftedType ty     = unliftedOrdOp tycon ty op a b
 445       | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
 446     go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
 447                                   (ltResult op)
 448                                   (go tys as bs)
 449                                   (gtResult op)
 450     go _ _ _ = panic "mkCompareFields"
 451
 452     -- (mk_compare ty a b) generates
 453     --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
 454     -- but with suitable special cases for
 455     mk_compare ty a b lt eq gt
 456       | isUnLiftedType ty
 457       = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
 458       | otherwise
 459       = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
 460           [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
 461            mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
 462            mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
 463       where
 464         a_expr = nlHsVar a
 465         b_expr = nlHsVar b
 466         (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
 467
 468 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
 469 unliftedOrdOp tycon ty op a b
 470   = case op of
 471        OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
 472                                      ltTag_Expr eqTag_Expr gtTag_Expr
 473        OrdLT      -> wrap lt_op
 474        OrdLE      -> wrap le_op
 475        OrdGE      -> wrap ge_op
 476        OrdGT      -> wrap gt_op
 477   where
 478    (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
 479    wrap prim_op = genOpApp a_expr (primOpRdrName prim_op) b_expr
 480    a_expr = nlHsVar a
 481    b_expr = nlHsVar b
 482
 483 unliftedCompare :: PrimOp -> PrimOp
 484                 -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
 485                 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName  -- Three results
 486                 -> LHsExpr RdrName
 487 -- Return (if a < b then lt else if a == b then eq else gt)
 488 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
 489   = nlHsIf (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $
 490                         -- Test (<) first, not (==), becuase the latter
 491                         -- is true less often, so putting it first would
 492                         -- mean more tests (dynamically)
 493         nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt
 494
 495 nlConWildPat :: DataCon -> LPat RdrName
 496 -- The pattern (K {})
 497 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
 498                                    (RecCon (HsRecFields { rec_flds = []
 499                                                         , rec_dotdot = Nothing })))
 500 \end{code}
 501
 502
 503
 504 %************************************************************************
 505 %*                                                                      *
 506         Enum instances
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 @Enum@ can only be derived for enumeration types.  For a type
 511 \begin{verbatim}
 512 data Foo ... = N1 | N2 | ... | Nn
 513 \end{verbatim}
 514
 515 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 516 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 517
 518 \begin{verbatim}
 519 instance ... Enum (Foo ...) where
 520     succ x   = toEnum (1 + fromEnum x)
 521     pred x   = toEnum (fromEnum x - 1)
 522
 523     toEnum i = tag2con_Foo i
 524
 525     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 526
 527     -- or, really...
 528     enumFrom a
 529       = case con2tag_Foo a of
 530           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 531
 532    enumFromThen a b
 533      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 534
 535     -- or, really...
 536     enumFromThen a b
 537       = case con2tag_Foo a of { a# ->
 538         case con2tag_Foo b of { b# ->
 539         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 540         }}
 541 \end{verbatim}
 542
 543 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 544
 545 \begin{code}
 546 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 547 gen_Enum_binds loc tycon
 548   = (method_binds, aux_binds)
 549   where
 550     method_binds = listToBag [
 551                         succ_enum,
 552                         pred_enum,
 553                         to_enum,
 554                         enum_from,
 555                         enum_from_then,
 556                         from_enum
 557                     ]
 558     aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
 559
 560     occ_nm = getOccString tycon
 561
 562     succ_enum
 563       = mk_easy_FunBind loc succ_RDR [a_Pat] $
 564         untag_Expr tycon [(a_RDR, ah_RDR)] $
 565         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
 566                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 567              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 568              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 569                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 570                                         nlHsIntLit 1]))
 571
 572     pred_enum
 573       = mk_easy_FunBind loc pred_RDR [a_Pat] $
 574         untag_Expr tycon [(a_RDR, ah_RDR)] $
 575         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
 576                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 577              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 578              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 579                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 580                                                nlHsLit (HsInt (-1))]))
 581
 582     to_enum
 583       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
 584         nlHsIf (nlHsApps and_RDR
 585                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
 586                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
 587              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
 588              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 589
 590     enum_from
 591       = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
 592           untag_Expr tycon [(a_RDR, ah_RDR)] $
 593           nlHsApps map_RDR
 594                 [nlHsVar (tag2con_RDR tycon),
 595                  nlHsPar (enum_from_to_Expr
 596                             (nlHsVarApps intDataCon_RDR [ah_RDR])
 597                             (nlHsVar (maxtag_RDR tycon)))]
 598
 599     enum_from_then
 600       = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
 601           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 602           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 603             nlHsPar (enum_from_then_to_Expr
 604                     (nlHsVarApps intDataCon_RDR [ah_RDR])
 605                     (nlHsVarApps intDataCon_RDR [bh_RDR])
 606                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 607                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
 608                            (nlHsIntLit 0)
 609                            (nlHsVar (maxtag_RDR tycon))
 610                            ))
 611
 612     from_enum
 613       = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
 614           untag_Expr tycon [(a_RDR, ah_RDR)] $
 615           (nlHsVarApps intDataCon_RDR [ah_RDR])
 616 \end{code}
 617
 618 %************************************************************************
 619 %*                                                                      *
 620         Bounded instances
 621 %*                                                                      *
 622 %************************************************************************
 623
 624 \begin{code}
 625 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 626 gen_Bounded_binds loc tycon
 627   | isEnumerationTyCon tycon
 628   = (listToBag [ min_bound_enum, max_bound_enum ], [])
 629   | otherwise
 630   = ASSERT(isSingleton data_cons)
 631     (listToBag [ min_bound_1con, max_bound_1con ], [])
 632   where
 633     data_cons = tyConDataCons tycon
 634
 635     ----- enum-flavored: ---------------------------
 636     min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
 637     max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
 638
 639     data_con_1    = head data_cons
 640     data_con_N    = last data_cons
 641     data_con_1_RDR = getRdrName data_con_1
 642     data_con_N_RDR = getRdrName data_con_N
 643
 644     ----- single-constructor-flavored: -------------
 645     arity          = dataConSourceArity data_con_1
 646
 647     min_bound_1con = mkHsVarBind loc minBound_RDR $
 648                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 649     max_bound_1con = mkHsVarBind loc maxBound_RDR $
 650                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 651 \end{code}
 652
 653 %************************************************************************
 654 %*                                                                      *
 655         Ix instances
 656 %*                                                                      *
 657 %************************************************************************
 658
 659 Deriving @Ix@ is only possible for enumeration types and
 660 single-constructor types.  We deal with them in turn.
 661
 662 For an enumeration type, e.g.,
 663 \begin{verbatim}
 664     data Foo ... = N1 | N2 | ... | Nn
 665 \end{verbatim}
 666 things go not too differently from @Enum@:
 667 \begin{verbatim}
 668 instance ... Ix (Foo ...) where
 669     range (a, b)
 670       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 671
 672     -- or, really...
 673     range (a, b)
 674       = case (con2tag_Foo a) of { a# ->
 675         case (con2tag_Foo b) of { b# ->
 676         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 677         }}
 678
 679     -- Generate code for unsafeIndex, becuase using index leads
 680     -- to lots of redundant range tests
 681     unsafeIndex c@(a, b) d
 682       = case (con2tag_Foo d -# con2tag_Foo a) of
 683                r# -> I# r#
 684
 685     inRange (a, b) c
 686       = let
 687             p_tag = con2tag_Foo c
 688         in
 689         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 690
 691     -- or, really...
 692     inRange (a, b) c
 693       = case (con2tag_Foo a)   of { a_tag ->
 694         case (con2tag_Foo b)   of { b_tag ->
 695         case (con2tag_Foo c)   of { c_tag ->
 696         if (c_tag >=# a_tag) then
 697           c_tag <=# b_tag
 698         else
 699           False
 700         }}}
 701 \end{verbatim}
 702 (modulo suitable case-ification to handle the unlifted tags)
 703
 704 For a single-constructor type (NB: this includes all tuples), e.g.,
 705 \begin{verbatim}
 706     data Foo ... = MkFoo a b Int Double c c
 707 \end{verbatim}
 708 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 709 (p.~147).
 710
 711 \begin{code}
 712 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 713
 714 gen_Ix_binds loc tycon
 715   | isEnumerationTyCon tycon
 716   = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
 717   | otherwise
 718   = (single_con_ixes, [GenCon2Tag tycon])
 719   where
 720     --------------------------------------------------------------
 721     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 722
 723     enum_range
 724       = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
 725           untag_Expr tycon [(a_RDR, ah_RDR)] $
 726           untag_Expr tycon [(b_RDR, bh_RDR)] $
 727           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 728               nlHsPar (enum_from_to_Expr
 729                         (nlHsVarApps intDataCon_RDR [ah_RDR])
 730                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 731
 732     enum_index
 733       = mk_easy_FunBind loc unsafeIndex_RDR
 734                 [noLoc (AsPat (noLoc c_RDR)
 735                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
 736                                 d_Pat] (
 737            untag_Expr tycon [(a_RDR, ah_RDR)] (
 738            untag_Expr tycon [(d_RDR, dh_RDR)] (
 739            let
 740                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
 741            in
 742            nlHsCase
 743              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
 744              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
 745            ))
 746         )
 747
 748     enum_inRange
 749       = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
 750           untag_Expr tycon [(a_RDR, ah_RDR)] (
 751           untag_Expr tycon [(b_RDR, bh_RDR)] (
 752           untag_Expr tycon [(c_RDR, ch_RDR)] (
 753           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
 754              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
 755           ) {-else-} (
 756              false_Expr
 757           ))))
 758
 759     --------------------------------------------------------------
 760     single_con_ixes
 761       = listToBag [single_con_range, single_con_index, single_con_inRange]
 762
 763     data_con
 764       = case tyConSingleDataCon_maybe tycon of -- just checking...
 765           Nothing -> panic "get_Ix_binds"
 766           Just dc -> dc
 767
 768     con_arity    = dataConSourceArity data_con
 769     data_con_RDR = getRdrName data_con
 770
 771     as_needed = take con_arity as_RDRs
 772     bs_needed = take con_arity bs_RDRs
 773     cs_needed = take con_arity cs_RDRs
 774
 775     con_pat  xs  = nlConVarPat data_con_RDR xs
 776     con_expr     = nlHsVarApps data_con_RDR cs_needed
 777
 778     --------------------------------------------------------------
 779     single_con_range
 780       = mk_easy_FunBind loc range_RDR
 781           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
 782         noLoc (mkHsComp ListComp stmts con_expr)
 783       where
 784         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 785
 786         mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
 787                                  (nlHsApp (nlHsVar range_RDR)
 788                                           (mkLHsVarTuple [a,b]))
 789
 790     ----------------
 791     single_con_index
 792       = mk_easy_FunBind loc unsafeIndex_RDR
 793                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 794                  con_pat cs_needed]
 795         -- We need to reverse the order we consider the components in
 796         -- so that
 797         --     range (l,u) !! index (l,u) i == i   -- when i is in range
 798         -- (from http://haskell.org/onlinereport/ix.html) holds.
 799                 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
 800       where
 801         -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
 802         mk_index []        = nlHsIntLit 0
 803         mk_index [(l,u,i)] = mk_one l u i
 804         mk_index ((l,u,i) : rest)
 805           = genOpApp (
 806                 mk_one l u i
 807             ) plus_RDR (
 808                 genOpApp (
 809                     (nlHsApp (nlHsVar unsafeRangeSize_RDR)
 810                              (mkLHsVarTuple [l,u]))
 811                 ) times_RDR (mk_index rest)
 812            )
 813         mk_one l u i
 814           = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
 815
 816     ------------------
 817     single_con_inRange
 818       = mk_easy_FunBind loc inRange_RDR
 819                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 820                  con_pat cs_needed] $
 821           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
 822       where
 823         in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
 824 \end{code}
 825
 826 %************************************************************************
 827 %*                                                                      *
 828         Read instances
 829 %*                                                                      *
 830 %************************************************************************
 831
 832 Example
 833
 834   infix 4 %%
 835   data T = Int %% Int
 836          | T1 { f1 :: Int }
 837          | T2 T
 838
 839
 840 instance Read T where
 841   readPrec =
 842     parens
 843     ( prec 4 (
 844         do x           <- ReadP.step Read.readPrec
 845            Symbol "%%" <- Lex.lex
 846            y           <- ReadP.step Read.readPrec
 847            return (x %% y))
 848       +++
 849       prec (appPrec+1) (
 850         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 851         -- Record construction binds even more tightly than application
 852         do Ident "T1" <- Lex.lex
 853            Punc '{' <- Lex.lex
 854            Ident "f1" <- Lex.lex
 855            Punc '=' <- Lex.lex
 856            x          <- ReadP.reset Read.readPrec
 857            Punc '}' <- Lex.lex
 858            return (T1 { f1 = x }))
 859       +++
 860       prec appPrec (
 861         do Ident "T2" <- Lex.lexP
 862            x          <- ReadP.step Read.readPrec
 863            return (T2 x))
 864     )
 865
 866   readListPrec = readListPrecDefault
 867   readList     = readListDefault
 868
 869
 870 \begin{code}
 871 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 872
 873 gen_Read_binds get_fixity loc tycon
 874   = (listToBag [read_prec, default_readlist, default_readlistprec], [])
 875   where
 876     -----------------------------------------------------------------------
 877     default_readlist
 878         = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 879
 880     default_readlistprec
 881         = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 882     -----------------------------------------------------------------------
 883
 884     data_cons = tyConDataCons tycon
 885     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 886
 887     read_prec = mkHsVarBind loc readPrec_RDR
 888                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 889
 890     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 891     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 892
 893     read_nullary_cons
 894       = case nullary_cons of
 895             []    -> []
 896             [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
 897             _     -> [nlHsApp (nlHsVar choose_RDR)
 898                               (nlList (map mk_pair nullary_cons))]
 899         -- NB For operators the parens around (:=:) are matched by the
 900         -- enclosing "parens" call, so here we must match the naked
 901         -- data_con_str con
 902
 903     match_con con | isSym con_str = [symbol_pat con_str]
 904                   | otherwise     = ident_h_pat  con_str
 905                   where
 906                     con_str = data_con_str con
 907         -- For nullary constructors we must match Ident s for normal constrs
 908         -- and   Symbol s   for operators
 909
 910     mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
 911                                   result_expr con []]
 912
 913     read_non_nullary_con data_con
 914       | is_infix  = mk_parser infix_prec  infix_stmts  body
 915       | is_record = mk_parser record_prec record_stmts body
 916 --              Using these two lines instead allows the derived
 917 --              read for infix and record bindings to read the prefix form
 918 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 919 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 920       | otherwise = prefix_parser
 921       where
 922         body = result_expr data_con as_needed
 923         con_str = data_con_str data_con
 924
 925         prefix_parser = mk_parser prefix_prec prefix_stmts body
 926
 927         read_prefix_con
 928             | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
 929             | otherwise     = ident_h_pat con_str
 930
 931         read_infix_con
 932             | isSym con_str = [symbol_pat con_str]
 933             | otherwise     = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
 934
 935         prefix_stmts            -- T a b c
 936           = read_prefix_con ++ read_args
 937
 938         infix_stmts             -- a %% b, or  a `T` b
 939           = [read_a1]
 940             ++ read_infix_con
 941             ++ [read_a2]
 942
 943         record_stmts            -- T { f1 = a, f2 = b }
 944           = read_prefix_con
 945             ++ [read_punc "{"]
 946             ++ concat (intersperse [read_punc ","] field_stmts)
 947             ++ [read_punc "}"]
 948
 949         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 950
 951         con_arity    = dataConSourceArity data_con
 952         labels       = dataConFieldLabels data_con
 953         dc_nm        = getName data_con
 954         is_infix     = dataConIsInfix data_con
 955         is_record    = length labels > 0
 956         as_needed    = take con_arity as_RDRs
 957         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 958         (read_a1:read_a2:_) = read_args
 959
 960         prefix_prec = appPrecedence
 961         infix_prec  = getPrecedence get_fixity dc_nm
 962         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 963                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 964
 965     ------------------------------------------------------------------------
 966     --          Helpers
 967     ------------------------------------------------------------------------
 968     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                         -- e1 +++ e2
 969     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p                -- prec p (do { ss ; b })
 970                                            , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
 971     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))      -- pat <- lexP
 972     con_app con as     = nlHsVarApps (getRdrName con) as                -- con as
 973     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
 974
 975     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 976
 977     -- For constructors and field labels ending in '#', we hackily
 978     -- let the lexer generate two tokens, and look for both in sequence
 979     -- Thus [Ident "I"; Symbol "#"].  See Trac #5041
 980     ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
 981                   | otherwise                    = [ ident_pat s ]
 982
 983     ident_pat  s = bindLex $ nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo" <- lexP
 984     symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>" <- lexP
 985
 986     data_con_str con = occNameString (getOccName con)
 987
 988     read_punc c = bindLex (punc_pat c)
 989     read_arg a ty = ASSERT( not (isUnLiftedType ty) )
 990                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 991
 992     read_field lbl a = read_lbl lbl ++
 993                        [read_punc "=",
 994                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 995
 996         -- When reading field labels we might encounter
 997         --      a  = 3
 998         --      _a = 3
 999         -- or   (#) = 4
1000         -- Note the parens!
1001     read_lbl lbl | isSym lbl_str
1002                  = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1003                  | otherwise
1004                  = ident_h_pat lbl_str
1005                  where
1006                    lbl_str = occNameString (getOccName lbl)
1007 \end{code}
1008
1009
1010 %************************************************************************
1011 %*                                                                      *
1012         Show instances
1013 %*                                                                      *
1014 %************************************************************************
1015
1016 Example
1017
1018     infixr 5 :^:
1019
1020     data Tree a =  Leaf a  |  Tree a :^: Tree a
1021
1022     instance (Show a) => Show (Tree a) where
1023
1024         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1025           where
1026              showStr = showString "Leaf " . showsPrec (app_prec+1) m
1027
1028         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1029           where
1030              showStr = showsPrec (up_prec+1) u .
1031                        showString " :^: "      .
1032                        showsPrec (up_prec+1) v
1033                 -- Note: right-associativity of :^: ignored
1034
1035     up_prec  = 5    -- Precedence of :^:
1036     app_prec = 10   -- Application has precedence one more than
1037                     -- the most tightly-binding operator
1038
1039 \begin{code}
1040 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1041
1042 gen_Show_binds get_fixity loc tycon
1043   = (listToBag [shows_prec, show_list], [])
1044   where
1045     -----------------------------------------------------------------------
1046     show_list = mkHsVarBind loc showList_RDR
1047                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1048     -----------------------------------------------------------------------
1049     data_cons = tyConDataCons tycon
1050     shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1051
1052     pats_etc data_con
1053       | nullary_con =  -- skip the showParen junk...
1054          ASSERT(null bs_needed)
1055          ([nlWildPat, con_pat], mk_showString_app op_con_str)
1056       | otherwise   =
1057          ([a_Pat, con_pat],
1058           showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
1059                          (nlHsPar (nested_compose_Expr show_thingies)))
1060         where
1061              data_con_RDR  = getRdrName data_con
1062              con_arity     = dataConSourceArity data_con
1063              bs_needed     = take con_arity bs_RDRs
1064              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
1065              con_pat       = nlConVarPat data_con_RDR bs_needed
1066              nullary_con   = con_arity == 0
1067              labels        = dataConFieldLabels data_con
1068              lab_fields    = length labels
1069              record_syntax = lab_fields > 0
1070
1071              dc_nm          = getName data_con
1072              dc_occ_nm      = getOccName data_con
1073              con_str        = occNameString dc_occ_nm
1074              op_con_str     = wrapOpParens con_str
1075              backquote_str  = wrapOpBackquotes con_str
1076
1077              show_thingies
1078                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1079                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1080                                   show_record_args ++ [mk_showString_app "}"]
1081                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1082
1083              show_label l = mk_showString_app (nm ++ " = ")
1084                         -- Note the spaces around the "=" sign.  If we don't have them
1085                         -- then we get Foo { x=-1 } and the "=-" parses as a single
1086                         -- lexeme.  Only the space after the '=' is necessary, but
1087                         -- it seems tidier to have them both sides.
1088                  where
1089                    occ_nm   = getOccName l
1090                    nm       = wrapOpParens (occNameString occ_nm)
1091
1092              show_args               = zipWith show_arg bs_needed arg_tys
1093              (show_arg1:show_arg2:_) = show_args
1094              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
1095
1096                 --  Assumption for record syntax: no of fields == no of labelled fields
1097                 --            (and in same order)
1098              show_record_args = concat $
1099                                 intersperse [mk_showString_app ", "] $
1100                                 [ [show_label lbl, arg]
1101                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
1102                                                         labels show_args ]
1103
1104                 -- Generates (showsPrec p x) for argument x, but it also boxes
1105                 -- the argument first if necessary.  Note that this prints unboxed
1106                 -- things without any '#' decorations; could change that if need be
1107              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1108                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1109
1110                 -- Fixity stuff
1111              is_infix = dataConIsInfix data_con
1112              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1113              arg_prec | record_syntax = 0       -- Record fields don't need parens
1114                       | otherwise     = con_prec_plus_one
1115
1116 wrapOpParens :: String -> String
1117 wrapOpParens s | isSym s   = '(' : s ++ ")"
1118                | otherwise = s
1119
1120 wrapOpBackquotes :: String -> String
1121 wrapOpBackquotes s | isSym s   = s
1122                    | otherwise = '`' : s ++ "`"
1123
1124 isSym :: String -> Bool
1125 isSym ""      = False
1126 isSym (c : _) = startsVarSym c || startsConSym c
1127
1128 mk_showString_app :: String -> LHsExpr RdrName
1129 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1130 \end{code}
1131
1132 \begin{code}
1133 getPrec :: Bool -> FixityEnv -> Name -> Integer
1134 getPrec is_infix get_fixity nm
1135   | not is_infix   = appPrecedence
1136   | otherwise      = getPrecedence get_fixity nm
1137
1138 appPrecedence :: Integer
1139 appPrecedence = fromIntegral maxPrecedence + 1
1140   -- One more than the precedence of the most
1141   -- tightly-binding operator
1142
1143 getPrecedence :: FixityEnv -> Name -> Integer
1144 getPrecedence get_fixity nm
1145    = case lookupFixity get_fixity nm of
1146         Fixity x _assoc -> fromIntegral x
1147           -- NB: the Report says that associativity is not taken
1148           --     into account for either Read or Show; hence we
1149           --     ignore associativity here
1150 \end{code}
1151
1152
1153 %************************************************************************
1154 %*                                                                      *
1155 \subsection{Typeable}
1156 %*                                                                      *
1157 %************************************************************************
1158
1159 From the data type
1160
1161         data T a b = ....
1162
1163 we generate
1164
1165         instance Typeable2 T where
1166                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1167
1168 We are passed the Typeable2 class as well as T
1169
1170 \begin{code}
1171 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1172 gen_Typeable_binds loc tycon
1173   = unitBag $
1174         mk_easy_FunBind loc
1175                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1176                 [nlWildPat]
1177                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1178   where
1179     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1180
1181 mk_typeOf_RDR :: TyCon -> RdrName
1182 -- Use the arity of the TyCon to make the right typeOfn function
1183 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1184                 where
1185                   arity = tyConArity tycon
1186                   suffix | arity == 0 = ""
1187                          | otherwise  = show arity
1188 \end{code}
1189
1190
1191
1192 %************************************************************************
1193 %*                                                                      *
1194         Data instances
1195 %*                                                                      *
1196 %************************************************************************
1197
1198 From the data type
1199
1200   data T a b = T1 a b | T2
1201
1202 we generate
1203
1204   $cT1 = mkDataCon $dT "T1" Prefix
1205   $cT2 = mkDataCon $dT "T2" Prefix
1206   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1207   -- the [] is for field labels.
1208
1209   instance (Data a, Data b) => Data (T a b) where
1210     gfoldl k z (T1 a b) = z T `k` a `k` b
1211     gfoldl k z T2           = z T2
1212     -- ToDo: add gmapT,Q,M, gfoldr
1213
1214     gunfold k z c = case conIndex c of
1215                         I# 1# -> k (k (z T1))
1216                         I# 2# -> z T2
1217
1218     toConstr (T1 _ _) = $cT1
1219     toConstr T2       = $cT2
1220
1221     dataTypeOf _ = $dT
1222
1223     dataCast1 = gcast1   -- If T :: * -> *
1224     dataCast2 = gcast2   -- if T :: * -> * -> *
1225
1226
1227 \begin{code}
1228 gen_Data_binds :: SrcSpan
1229                -> TyCon
1230                -> (LHsBinds RdrName,    -- The method bindings
1231                    DerivAuxBinds)       -- Auxiliary bindings
1232 gen_Data_binds loc tycon
1233   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1234      `unionBags` gcast_binds,
1235                 -- Auxiliary definitions: the data type and constructors
1236      MkTyCon tycon : map MkDataCon data_cons)
1237   where
1238     data_cons  = tyConDataCons tycon
1239     n_cons     = length data_cons
1240     one_constr = n_cons == 1
1241
1242         ------------ gfoldl
1243     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1244
1245     gfoldl_eqn con
1246       = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1247                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1248                    where
1249                      con_name ::  RdrName
1250                      con_name = getRdrName con
1251                      as_needed = take (dataConSourceArity con) as_RDRs
1252                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1253
1254         ------------ gunfold
1255     gunfold_bind = mk_FunBind loc
1256                               gunfold_RDR
1257                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1258                                 gunfold_rhs)]
1259
1260     gunfold_rhs
1261         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1262         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1263                                 (map gunfold_alt data_cons)
1264
1265     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1266     mk_unfold_rhs dc = foldr nlHsApp
1267                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1268                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1269
1270     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1271                         -- redundant test, and annoying warning
1272       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1273       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1274       where
1275         tag = dataConTag dc
1276
1277         ------------ toConstr
1278     toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1279     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1280
1281         ------------ dataTypeOf
1282     dataTypeOf_bind = mk_easy_FunBind
1283                         loc
1284                         dataTypeOf_RDR
1285                         [nlWildPat]
1286                         (nlHsVar (mk_data_type_name tycon))
1287
1288         ------------ gcast1/2
1289     tycon_kind = tyConKind tycon
1290     gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1291                 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1292                 | otherwise           = emptyBag
1293     mk_gcast dataCast_RDR gcast_RDR
1294       = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1295                                  (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1296
1297
1298 kind1, kind2 :: Kind
1299 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1300 kind2 = liftedTypeKind `mkArrowKind` kind1
1301
1302 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1303     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1304     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1305     constr_RDR, dataType_RDR :: RdrName
1306 gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
1307 gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
1308 toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
1309 dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")
1310 dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")
1311 dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")
1312 gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")
1313 gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")
1314 mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")
1315 constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")
1316 mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")
1317 dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")
1318 conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
1319 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1320 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1321 \end{code}
1322
1323
1324
1325 %************************************************************************
1326 %*                                                                      *
1327                         Functor instances
1328
1329  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1330
1331 %*                                                                      *
1332 %************************************************************************
1333
1334 For the data type:
1335
1336   data T a = T1 Int a | T2 (T a)
1337
1338 We generate the instance:
1339
1340   instance Functor T where
1341       fmap f (T1 b1 a) = T1 b1 (f a)
1342       fmap f (T2 ta)   = T2 (fmap f ta)
1343
1344 Notice that we don't simply apply 'fmap' to the constructor arguments.
1345 Rather
1346   - Do nothing to an argument whose type doesn't mention 'a'
1347   - Apply 'f' to an argument of type 'a'
1348   - Apply 'fmap f' to other arguments
1349 That's why we have to recurse deeply into the constructor argument types,
1350 rather than just one level, as we typically do.
1351
1352 What about types with more than one type parameter?  In general, we only
1353 derive Functor for the last position:
1354
1355   data S a b = S1 [b] | S2 (a, T a b)
1356   instance Functor (S a) where
1357     fmap f (S1 bs)    = S1 (fmap f bs)
1358     fmap f (S2 (p,q)) = S2 (a, fmap f q)
1359
1360 However, we have special cases for
1361          - tuples
1362          - functions
1363
1364 More formally, we write the derivation of fmap code over type variable
1365 'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
1366 instance for T is:
1367
1368   instance Functor T where
1369       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1370       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
1371
1372   $(fmap 'a 'b)         x  =  x     -- when b does not contain a
1373   $(fmap 'a 'a)         x  =  f x
1374   $(fmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1375   $(fmap 'a '(T b1 b2)) x  =  fmap $(fmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1376   $(fmap 'a '(b -> c))  x  =  \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1377
1378 For functions, the type parameter 'a can occur in a contravariant position,
1379 which means we need to derive a function like:
1380
1381   cofmap :: (a -> b) -> (f b -> f a)
1382
1383 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1384
1385   $(cofmap 'a 'b)         x  =  x     -- when b does not contain a
1386   $(cofmap 'a 'a)         x  =  error "type variable in contravariant position"
1387   $(cofmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1388   $(cofmap 'a '[b])       x  =  map $(cofmap 'a 'b) x
1389   $(cofmap 'a '(T b1 b2)) x  =  fmap $(cofmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1390   $(cofmap 'a '(b -> c))  x  =  \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1391
1392 \begin{code}
1393 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1394 gen_Functor_binds loc tycon
1395   = (unitBag fmap_bind, [])
1396   where
1397     data_cons = tyConDataCons tycon
1398     fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
1399
1400     fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1401       where
1402         parts = foldDataConArgs ft_fmap con
1403
1404     eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1405                                            (error_Expr "Void fmap")]
1406          | otherwise      = map fmap_eqn data_cons
1407
1408     ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1409     -- Tricky higher order type; I can't say I fully understand this code :-(
1410     ft_fmap = FT { ft_triv = \x -> return x                    -- fmap f x = x
1411                  , ft_var  = \x -> return (nlHsApp f_Expr x)   -- fmap f x = f x
1412                  , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1413                                                                -- fmap f x = \b -> h (x (g b))
1414                  , ft_tup = mkSimpleTupleCase match_for_con    -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1415                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g      -- fmap f x = fmap g x
1416                                              return $ nlHsApps fmap_RDR [gg,x]
1417                  , ft_forall = \_ g  x -> g x
1418                  , ft_bad_app = panic "in other argument"
1419                  , ft_co_var = panic "contravariant" }
1420
1421     match_for_con = mkSimpleConMatch $
1422         \con_name xsM -> do xs <- sequence xsM
1423                             return (nlHsApps con_name xs)  -- Con (g1 v1) (g2 v2) ..
1424 \end{code}
1425
1426 Utility functions related to Functor deriving.
1427
1428 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1429 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1430
1431 \begin{code}
1432 -- Generic traversal for Functor deriving
1433 data FFoldType a      -- Describes how to fold over a Type in a functor like way
1434    = FT { ft_triv    :: a                   -- Does not contain variable
1435         , ft_var     :: a                   -- The variable itself
1436         , ft_co_var  :: a                   -- The variable itself, contravariantly
1437         , ft_fun     :: a -> a -> a         -- Function type
1438         , ft_tup     :: Boxity -> [a] -> a  -- Tuple type
1439         , ft_ty_app  :: Type -> a -> a      -- Type app, variable only in last argument
1440         , ft_bad_app :: a                   -- Type app, variable other than in last argument
1441         , ft_forall  :: TcTyVar -> a -> a   -- Forall type
1442      }
1443
1444 functorLikeTraverse :: TyVar         -- ^ Variable to look for
1445                     -> FFoldType a   -- ^ How to fold
1446                     -> Type          -- ^ Type to process
1447                     -> a
1448 functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
1449                             , ft_co_var = caseCoVar,     ft_fun = caseFun
1450                             , ft_tup = caseTuple,        ft_ty_app = caseTyApp
1451                             , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1452                     ty
1453   = fst (go False ty)
1454   where -- go returns (result of type a, does type contain var)
1455         go co ty | Just ty' <- coreView ty = go co ty'
1456         go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
1457         go co (FunTy (PredTy _) b)      = go co b
1458         go co (FunTy x y)    | xc || yc = (caseFun xr yr,True)
1459             where (xr,xc) = go (not co) x
1460                   (yr,yc) = go co       y
1461         go co (AppTy    x y) | xc = (caseWrongArg,   True)
1462                              | yc = (caseTyApp x yr, True)
1463             where (_, xc) = go co x
1464                   (yr,yc) = go co y
1465         go co ty@(TyConApp con args)
1466                | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
1467                -- At this point we know that xrs, xcs is not empty,
1468                -- and at least one xr is True
1469                | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs, True)
1470                | or (init xcs)    = (caseWrongArg, True)   -- T (..var..)    ty
1471                | otherwise        =                        -- T (..no var..) ty
1472                                     (caseTyApp (fst (splitAppTy ty)) (last xrs), True)
1473             where (xrs,xcs) = unzip (map (go co) args)
1474         go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1475             where (xr,xc) = go co x
1476         go _ _ = (caseTrivial,False)
1477
1478 -- Return all syntactic subterms of ty that contain var somewhere
1479 -- These are the things that should appear in instance constraints
1480 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1481 deepSubtypesContaining tv
1482   = functorLikeTraverse tv
1483         (FT { ft_triv = []
1484             , ft_var = []
1485             , ft_fun = (++), ft_tup = \_ xs -> concat xs
1486             , ft_ty_app = (:)
1487             , ft_bad_app = panic "in other argument"
1488             , ft_co_var = panic "contravariant"
1489             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1490
1491
1492 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1493 -- Fold over the arguments of the datacon
1494 foldDataConArgs ft con
1495   = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1496   where
1497     tv = last (dataConUnivTyVars con)
1498                     -- Argument to derive for, 'a in the above description
1499                     -- The validity checks have ensured that con is
1500                     -- a vanilla data constructor
1501
1502 -- Make a HsLam using a fresh variable from a State monad
1503 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1504 -- (mkSimpleLam fn) returns (\x. fn(x))
1505 mkSimpleLam lam = do
1506     (n:names) <- get
1507     put names
1508     body <- lam (nlHsVar n)
1509     return (mkHsLam [nlVarPat n] body)
1510
1511 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1512 mkSimpleLam2 lam = do
1513     (n1:n2:names) <- get
1514     put names
1515     body <- lam (nlHsVar n1) (nlHsVar n2)
1516     return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1517
1518 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1519 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1520 mkSimpleConMatch fold extra_pats con insides = do
1521     let con_name = getRdrName con
1522     let vars_needed = takeList insides as_RDRs
1523     let pat = nlConVarPat con_name vars_needed
1524     rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1525     return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1526
1527 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1528 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1529                   -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1530 mkSimpleTupleCase match_for_con boxity insides x = do
1531     let con = tupleCon boxity (length insides)
1532     match <- match_for_con [] con insides
1533     return $ nlHsCase x [match]
1534 \end{code}
1535
1536
1537 %************************************************************************
1538 %*                                                                      *
1539                         Foldable instances
1540
1541  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1542
1543 %*                                                                      *
1544 %************************************************************************
1545
1546 Deriving Foldable instances works the same way as Functor instances,
1547 only Foldable instances are not possible for function types at all.
1548 Here the derived instance for the type T above is:
1549
1550   instance Foldable T where
1551       foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1552
1553 The cases are:
1554
1555   $(foldr 'a 'b)         x z  =  z     -- when b does not contain a
1556   $(foldr 'a 'a)         x z  =  f x z
1557   $(foldr 'a '(b1,b2))   x z  =  case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1558   $(foldr 'a '(T b1 b2)) x z  =  foldr $(foldr 'a 'b2) x z  -- when a only occurs in the last parameter, b2
1559
1560 Note that the arguments to the real foldr function are the wrong way around,
1561 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1562
1563 \begin{code}
1564 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1565 gen_Foldable_binds loc tycon
1566   = (unitBag foldr_bind, [])
1567   where
1568     data_cons = tyConDataCons tycon
1569
1570     foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1571     eqns = map foldr_eqn data_cons
1572     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1573       where
1574         parts = foldDataConArgs ft_foldr con
1575
1576     ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1577     ft_foldr = FT { ft_triv = \_ z -> return z                        -- foldr f z x = z
1578                   , ft_var  = \x z -> return (nlHsApps f_RDR [x,z])   -- foldr f z x = f x z
1579                   , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1580                   , ft_ty_app = \_ g  x z -> do gg <- mkSimpleLam2 g   -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1581                                                 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1582                   , ft_forall = \_ g  x z -> g x z
1583                   , ft_co_var = panic "covariant"
1584                   , ft_fun = panic "function"
1585                   , ft_bad_app = panic "in other argument" }
1586
1587     match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1588 \end{code}
1589
1590
1591 %************************************************************************
1592 %*                                                                      *
1593                         Traversable instances
1594
1595  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1596 %*                                                                      *
1597 %************************************************************************
1598
1599 Again, Traversable is much like Functor and Foldable.
1600
1601 The cases are:
1602
1603   $(traverse 'a 'b)         x  =  pure x     -- when b does not contain a
1604   $(traverse 'a 'a)         x  =  f x
1605   $(traverse 'a '(b1,b2))   x  =  case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1606   $(traverse 'a '(T b1 b2)) x  =  traverse $(traverse 'a 'b2) x  -- when a only occurs in the last parameter, b2
1607
1608 Note that the generated code is not as efficient as it could be. For instance:
1609
1610   data T a = T Int a  deriving Traversable
1611
1612 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1613 instead of:         traverse f (T x y) = T x <$> f y
1614
1615 \begin{code}
1616 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1617 gen_Traversable_binds loc tycon
1618   = (unitBag traverse_bind, [])
1619   where
1620     data_cons = tyConDataCons tycon
1621
1622     traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
1623     eqns = map traverse_eqn data_cons
1624     traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1625       where
1626         parts = foldDataConArgs ft_trav con
1627
1628
1629     ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1630     ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x])   -- traverse f x = pure x
1631                  , ft_var = \x -> return (nlHsApps f_RDR [x])       -- travese f x = f x
1632                  , ft_tup = mkSimpleTupleCase match_for_con         -- travese f x z = case x of (a1,a2,..) ->
1633                                                                     --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
1634                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g    -- travese f x = travese (\xx -> g xx) x
1635                                              return $ nlHsApps traverse_RDR [gg,x]
1636                  , ft_forall = \_ g  x -> g x
1637                  , ft_co_var = panic "covariant"
1638                  , ft_fun = panic "function"
1639                  , ft_bad_app = panic "in other argument" }
1640
1641     match_for_con = mkSimpleConMatch $
1642         \con_name xsM -> do xs <- sequence xsM
1643                             return (mkApCon (nlHsVar con_name) xs)
1644
1645     -- ((Con <$> x1) <*> x2) <*> ..
1646     mkApCon con []     = nlHsApps pure_RDR [con]
1647     mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1648        where appAp x y = nlHsApps ap_RDR [x,y]
1649 \end{code}
1650
1651
1652
1653 %************************************************************************
1654 %*                                                                      *
1655 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1656 %*                                                                      *
1657 %************************************************************************
1658
1659 \begin{verbatim}
1660 data Foo ... = ...
1661
1662 con2tag_Foo :: Foo ... -> Int#
1663 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1664 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1665 \end{verbatim}
1666
1667 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1668 fiddling around.
1669
1670 \begin{code}
1671 genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
1672 genAuxBind loc (GenCon2Tag tycon)
1673   = (mk_FunBind loc rdr_name eqns,
1674      L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1675   where
1676     rdr_name = con2tag_RDR tycon
1677
1678     sig_ty = HsCoreTy $
1679              mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1680              mkParentType tycon `mkFunTy` intPrimTy
1681
1682     lots_of_constructors = tyConFamilySize tycon > 8
1683                         -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1684                         -- but we don't do vectored returns any more.
1685
1686     eqns | lots_of_constructors = [get_tag_eqn]
1687          | otherwise = map mk_eqn (tyConDataCons tycon)
1688
1689     get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1690
1691     mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1692     mk_eqn con = ([nlWildConPat con],
1693                   nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1694
1695 genAuxBind loc (GenTag2Con tycon)
1696   = (mk_FunBind loc rdr_name
1697         [([nlConVarPat intDataCon_RDR [a_RDR]],
1698            nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1699      L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1700   where
1701     sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
1702              intTy `mkFunTy` mkParentType tycon
1703
1704     rdr_name = tag2con_RDR tycon
1705
1706 genAuxBind loc (GenMaxTag tycon)
1707   = (mkHsVarBind loc rdr_name rhs,
1708      L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1709   where
1710     rdr_name = maxtag_RDR tycon
1711     sig_ty = HsCoreTy intTy
1712     rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
1713     max_tag =  case (tyConDataCons tycon) of
1714                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1715
1716 genAuxBind loc (MkTyCon tycon)  --  $dT
1717   = (mkHsVarBind loc rdr_name rhs,
1718      L loc (TypeSig (L loc rdr_name) sig_ty))
1719   where
1720     rdr_name = mk_data_type_name tycon
1721     sig_ty   = nlHsTyVar dataType_RDR
1722     constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1723     rhs = nlHsVar mkDataType_RDR
1724           `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1725           `nlHsApp` nlList constrs
1726
1727 genAuxBind loc (MkDataCon dc)   --  $cT1 etc
1728   = (mkHsVarBind loc rdr_name rhs,
1729      L loc (TypeSig (L loc rdr_name) sig_ty))
1730   where
1731     rdr_name = mk_constr_name dc
1732     sig_ty   = nlHsTyVar constr_RDR
1733     rhs      = nlHsApps mkConstr_RDR constr_args
1734
1735     constr_args
1736        = [ -- nlHsIntLit (toInteger (dataConTag dc)),     -- Tag
1737            nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1738            nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
1739            nlList  labels,                                -- Field labels
1740            nlHsVar fixity]                                -- Fixity
1741
1742     labels   = map (nlHsLit . mkHsString . getOccString)
1743                    (dataConFieldLabels dc)
1744     dc_occ   = getOccName dc
1745     is_infix = isDataSymOcc dc_occ
1746     fixity | is_infix  = infix_RDR
1747            | otherwise = prefix_RDR
1748
1749 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
1750 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1751
1752 mk_constr_name :: DataCon -> RdrName    -- "$cC"
1753 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1754
1755 mkParentType :: TyCon -> Type
1756 -- Turn the representation tycon of a family into
1757 -- a use of its family constructor
1758 mkParentType tc
1759   = case tyConFamInst_maybe tc of
1760        Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1761        Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1762 \end{code}
1763
1764 %************************************************************************
1765 %*                                                                      *
1766 \subsection{Utility bits for generating bindings}
1767 %*                                                                      *
1768 %************************************************************************
1769
1770
1771 \begin{code}
1772 mk_FunBind :: SrcSpan -> RdrName
1773            -> [([LPat RdrName], LHsExpr RdrName)]
1774            -> LHsBind RdrName
1775 mk_FunBind loc fun pats_and_exprs
1776   = L loc $ mkRdrFunBind (L loc fun) matches
1777   where
1778     matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
1779
1780 mkRdrFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName
1781 mkRdrFunBind fun@(L _ fun_rdr) matches
1782  | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds]
1783         -- Catch-all eqn looks like
1784         --     fmap = error "Void fmap"
1785         -- It's needed if there no data cons at all,
1786         -- which can happen with -XEmptyDataDecls
1787         -- See Trac #4302
1788  | otherwise    = mkFunBind fun matches
1789  where
1790    str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
1791 \end{code}
1792
1793 \begin{code}
1794 box_if_necy :: String           -- The class involved
1795             -> TyCon            -- The tycon involved
1796             -> LHsExpr RdrName  -- The argument
1797             -> Type             -- The argument type
1798             -> LHsExpr RdrName  -- Boxed version of the arg
1799 box_if_necy cls_str tycon arg arg_ty
1800   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1801   | otherwise             = arg
1802   where
1803     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1804
1805 ---------------------
1806 primOrdOps :: String    -- The class involved
1807            -> TyCon     -- The tycon involved
1808            -> Type      -- The type
1809            -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp)  -- (lt,le,eq,ge,gt)
1810 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1811
1812 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1813 ord_op_tbl
1814  =  [(charPrimTy,       (CharLtOp,   CharLeOp,   CharEqOp,   CharGeOp,   CharGtOp))
1815     ,(intPrimTy,        (IntLtOp,    IntLeOp,    IntEqOp,    IntGeOp,    IntGtOp))
1816     ,(wordPrimTy,       (WordLtOp,   WordLeOp,   WordEqOp,   WordGeOp,   WordGtOp))
1817     ,(addrPrimTy,       (AddrLtOp,   AddrLeOp,   AddrEqOp,   AddrGeOp,   AddrGtOp))
1818     ,(floatPrimTy,      (FloatLtOp,  FloatLeOp,  FloatEqOp,  FloatGeOp,  FloatGtOp))
1819     ,(doublePrimTy,     (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1820
1821 box_con_tbl :: [(Type, RdrName)]
1822 box_con_tbl =
1823     [(charPrimTy,       getRdrName charDataCon)
1824     ,(intPrimTy,        getRdrName intDataCon)
1825     ,(wordPrimTy,       wordDataCon_RDR)
1826     ,(floatPrimTy,      getRdrName floatDataCon)
1827     ,(doublePrimTy,     getRdrName doubleDataCon)
1828     ]
1829
1830 assoc_ty_id :: String           -- The class involved
1831             -> TyCon            -- The tycon involved
1832             -> [(Type,a)]       -- The table
1833             -> Type             -- The type
1834             -> a                -- The result of the lookup
1835 assoc_ty_id cls_str _ tbl ty
1836   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1837                                               text "for primitive type" <+> ppr ty)
1838   | otherwise = head res
1839   where
1840     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1841
1842 -----------------------------------------------------------------------
1843
1844 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1845 and_Expr a b = genOpApp a and_RDR    b
1846
1847 -----------------------------------------------------------------------
1848
1849 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1850 eq_Expr tycon ty a b = genOpApp a eq_op b
1851  where
1852    eq_op | not (isUnLiftedType ty) = eq_RDR
1853          | otherwise               = primOpRdrName prim_eq
1854    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1855 \end{code}
1856
1857 \begin{code}
1858 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1859 untag_Expr _ [] expr = expr
1860 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1861   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1862       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1863
1864 enum_from_to_Expr
1865         :: LHsExpr RdrName -> LHsExpr RdrName
1866         -> LHsExpr RdrName
1867 enum_from_then_to_Expr
1868         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1869         -> LHsExpr RdrName
1870
1871 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1872 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1873
1874 showParen_Expr
1875         :: LHsExpr RdrName -> LHsExpr RdrName
1876         -> LHsExpr RdrName
1877
1878 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1879
1880 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1881
1882 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1883 nested_compose_Expr [e] = parenify e
1884 nested_compose_Expr (e:es)
1885   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1886
1887 -- impossible_Expr is used in case RHSs that should never happen.
1888 -- We generate these to keep the desugarer from complaining that they *might* happen!
1889 error_Expr :: String -> LHsExpr RdrName
1890 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
1891
1892 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1893 -- method. It is currently only used by Enum.{succ,pred}
1894 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1895 illegal_Expr meth tp msg =
1896    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1897
1898 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1899 -- to include the value of a_RDR in the error string.
1900 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1901 illegal_toEnum_tag tp maxtag =
1902    nlHsApp (nlHsVar error_RDR)
1903            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1904                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1905                     (nlHsApp (nlHsApp (nlHsApp
1906                            (nlHsVar showsPrec_RDR)
1907                            (nlHsIntLit 0))
1908                            (nlHsVar a_RDR))
1909                            (nlHsApp (nlHsApp
1910                                (nlHsVar append_RDR)
1911                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1912                                (nlHsApp (nlHsApp (nlHsApp
1913                                         (nlHsVar showsPrec_RDR)
1914                                         (nlHsIntLit 0))
1915                                         (nlHsVar maxtag))
1916                                         (nlHsLit (mkHsString ")"))))))
1917
1918 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1919 parenify e@(L _ (HsVar _)) = e
1920 parenify e                 = mkHsPar e
1921
1922 -- genOpApp wraps brackets round the operator application, so that the
1923 -- renamer won't subsequently try to re-associate it.
1924 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1925 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1926 \end{code}
1927
1928 \begin{code}
1929 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1930     :: RdrName
1931 a_RDR           = mkVarUnqual (fsLit "a")
1932 b_RDR           = mkVarUnqual (fsLit "b")
1933 c_RDR           = mkVarUnqual (fsLit "c")
1934 d_RDR           = mkVarUnqual (fsLit "d")
1935 f_RDR           = mkVarUnqual (fsLit "f")
1936 k_RDR           = mkVarUnqual (fsLit "k")
1937 z_RDR           = mkVarUnqual (fsLit "z")
1938 ah_RDR          = mkVarUnqual (fsLit "a#")
1939 bh_RDR          = mkVarUnqual (fsLit "b#")
1940 ch_RDR          = mkVarUnqual (fsLit "c#")
1941 dh_RDR          = mkVarUnqual (fsLit "d#")
1942
1943 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1944 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1945 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1946 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1947
1948 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1949     false_Expr, true_Expr :: LHsExpr RdrName
1950 a_Expr          = nlHsVar a_RDR
1951 -- b_Expr       = nlHsVar b_RDR
1952 c_Expr          = nlHsVar c_RDR
1953 f_Expr          = nlHsVar f_RDR
1954 z_Expr          = nlHsVar z_RDR
1955 ltTag_Expr      = nlHsVar ltTag_RDR
1956 eqTag_Expr      = nlHsVar eqTag_RDR
1957 gtTag_Expr      = nlHsVar gtTag_RDR
1958 false_Expr      = nlHsVar false_RDR
1959 true_Expr       = nlHsVar true_RDR
1960
1961 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1962 a_Pat           = nlVarPat a_RDR
1963 b_Pat           = nlVarPat b_RDR
1964 c_Pat           = nlVarPat c_RDR
1965 d_Pat           = nlVarPat d_RDR
1966 f_Pat           = nlVarPat f_RDR
1967 k_Pat           = nlVarPat k_RDR
1968 z_Pat           = nlVarPat z_RDR
1969
1970 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1971 -- Generates Orig s RdrName, for the binding positions
1972 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1973 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1974 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1975
1976 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1977 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1978
1979 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1980 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1981 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1982 -- But:  (a) that does not work well for standalone-deriving
1983 --       (b) an unqualified name is just fine, provided it can't clash with user code
1984 \end{code}
1985
1986 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1987 PrelNames, so PrelNames can't import PrimOp.
1988
1989 \begin{code}
1990 primOpRdrName :: PrimOp -> RdrName
1991 primOpRdrName op = getRdrName (primOpId op)
1992
1993 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1994     tagToEnum_RDR :: RdrName
1995 minusInt_RDR  = primOpRdrName IntSubOp
1996 eqInt_RDR     = primOpRdrName IntEqOp
1997 ltInt_RDR     = primOpRdrName IntLtOp
1998 geInt_RDR     = primOpRdrName IntGeOp
1999 gtInt_RDR     = primOpRdrName IntGtOp
2000 leInt_RDR     = primOpRdrName IntLeOp
2001 tagToEnum_RDR = primOpRdrName TagToEnumOp
2002
2003 error_RDR :: RdrName
2004 error_RDR = getRdrName eRROR_ID
2005 \end{code}