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