ghc/compiler/typecheck/TcGenDeriv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcGenDeriv]{Generating derived instance declarations}
   5
   6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
   7 ``official'' interface to deriving-related things.
   8
   9 This is where we do all the grimy bindings' generation.
  10
  11 \begin{code}
  12 #include "HsVersions.h"
  13
  14 module TcGenDeriv (
  15         gen_Bounded_binds,
  16         gen_Enum_binds,
  17         gen_Eval_binds,
  18         gen_Eq_binds,
  19         gen_Ix_binds,
  20         gen_Ord_binds,
  21         gen_Read_binds,
  22         gen_Show_binds,
  23         gen_tag_n_con_monobind,
  24
  25         con2tag_RDR, tag2con_RDR, maxtag_RDR,
  26
  27         TagThingWanted(..)
  28     ) where
  29
  30 IMP_Ubiq()
  31 IMPORT_1_3(List(partition))
  32
  33 import HsSyn            ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
  34                           GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..),
  35                           SYN_IE(RecFlag), recursive,
  36                           ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake )
  37 import RdrHsSyn         ( RdrName(..), varQual, varUnqual, mkOpApp,
  38                           SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
  39                         )
  40 -- import RnHsSyn               ( RenamedFixityDecl(..) )
  41
  42 import Id               ( GenId, dataConNumFields, isNullaryDataCon, dataConTag,
  43                           dataConRawArgTys, fIRST_TAG,
  44                           isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) )
  45 import Maybes           ( maybeToBool )
  46 import Name             ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name )
  47
  48 import PrimOp           ( PrimOp(..) )
  49 import PrelInfo         -- Lots of RdrNames
  50 import SrcLoc           ( mkGeneratedSrcLoc, SrcLoc )
  51 import TyCon            ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
  52 import Type             ( eqTy, isPrimType, SYN_IE(Type) )
  53 import TysPrim          ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
  54                           floatPrimTy, doublePrimTy
  55                         )
  56 import Util             ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
  57 \end{code}
  58
  59 %************************************************************************
  60 %*                                                                      *
  61 \subsection{Generating code, by derivable class}
  62 %*                                                                      *
  63 %************************************************************************
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsubsection{Generating @Eq@ instance declarations}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 Here are the heuristics for the code we generate for @Eq@:
  72 \begin{itemize}
  73 \item
  74   Let's assume we have a data type with some (possibly zero) nullary
  75   data constructors and some ordinary, non-nullary ones (the rest,
  76   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  77   and \tr{O}rdinary data cons.
  78 \begin{verbatim}
  79 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
  80 \end{verbatim}
  81
  82 \item
  83   For the ordinary constructors (if any), we emit clauses to do The
  84   Usual Thing, e.g.,:
  85
  86 \begin{verbatim}
  87 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
  88 (==) (O2 a1)       (O2 a2)       = a1 == a2
  89 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
  90 \end{verbatim}
  91
  92   Note: if we're comparing unboxed things, e.g., if \tr{a1} and
  93   \tr{a2} are \tr{Float#}s, then we have to generate
  94 \begin{verbatim}
  95 case (a1 `eqFloat#` a2) of
  96   r -> r
  97 \end{verbatim}
  98   for that particular test.
  99
 100 \item
 101   If there are any nullary constructors, we emit a catch-all clause of
 102   the form:
 103
 104 \begin{verbatim}
 105 (==) a b  = case (con2tag_Foo a) of { a# ->
 106             case (con2tag_Foo b) of { b# ->
 107             case (a# ==# b#)     of {
 108               r -> r
 109             }}}
 110 \end{verbatim}
 111
 112   If there aren't any nullary constructors, we emit a simpler
 113   catch-all:
 114 \begin{verbatim}
 115 (==) a b  = False
 116 \end{verbatim}
 117
 118 \item
 119   For the @(/=)@ method, we normally just use the default method.
 120
 121   If the type is an enumeration type, we could/may/should? generate
 122   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 123   above.
 124
 125 \item
 126   We thought about doing this: If we're also deriving @Ord@ for this
 127   tycon, we generate:
 128 \begin{verbatim}
 129 instance ... Eq (Foo ...) where
 130   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 131   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 132 \begin{verbatim}
 133   However, that requires that \tr{Ord <whatever>} was put in the context
 134   for the instance decl, which it probably wasn't, so the decls
 135   produced don't get through the typechecker.
 136 \end{itemize}
 137
 138 \begin{code}
 139 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
 140
 141 gen_Eq_binds tycon
 142   = let
 143         tycon_loc = getSrcLoc tycon
 144         (nullary_cons, nonnullary_cons)
 145           = partition isNullaryDataCon (tyConDataCons tycon)
 146
 147         rest
 148           = if (null nullary_cons) then
 149                 case maybeTyConSingleCon tycon of
 150                   Just _ -> []
 151                   Nothing -> -- if cons don't match, then False
 152                      [([a_Pat, b_Pat], false_Expr)]
 153             else -- calc. and compare the tags
 154                  [([a_Pat, b_Pat],
 155                     untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 156                       (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
 157     in
 158     mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
 159             `AndMonoBinds`
 160     mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
 161         HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
 162   where
 163     ------------------------------------------------------------------
 164     pats_etc data_con
 165       = let
 166             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
 167             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 168
 169             data_con_RDR = qual_orig_name data_con
 170             con_arity   = length tys_needed
 171             as_needed   = take con_arity as_RDRs
 172             bs_needed   = take con_arity bs_RDRs
 173             tys_needed  = dataConRawArgTys data_con
 174         in
 175         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 176       where
 177         nested_eq_expr []  [] [] = true_Expr
 178         nested_eq_expr tys as bs
 179           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 180           where
 181             nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
 182 \end{code}
 183
 184 %************************************************************************
 185 %*                                                                      *
 186 \subsubsection{Generating @Ord@ instance declarations}
 187 %*                                                                      *
 188 %************************************************************************
 189
 190 For a derived @Ord@, we concentrate our attentions on @compare@
 191 \begin{verbatim}
 192 compare :: a -> a -> Ordering
 193 data Ordering = LT | EQ | GT deriving ()
 194 \end{verbatim}
 195
 196 We will use the same example data type as above:
 197 \begin{verbatim}
 198 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 199 \end{verbatim}
 200
 201 \begin{itemize}
 202 \item
 203   We do all the other @Ord@ methods with calls to @compare@:
 204 \begin{verbatim}
 205 instance ... (Ord <wurble> <wurble>) where
 206     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 207     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 208     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 209     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 210
 211     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 212     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 213
 214     -- compare to come...
 215 \end{verbatim}
 216
 217 \item
 218   @compare@ always has two parts.  First, we use the compared
 219   data-constructors' tags to deal with the case of different
 220   constructors:
 221 \begin{verbatim}
 222 compare a b = case (con2tag_Foo a) of { a# ->
 223               case (con2tag_Foo b) of { b# ->
 224               case (a# ==# b#)     of {
 225                True  -> cmp_eq a b
 226                False -> case (a# <# b#) of
 227                          True  -> _LT
 228                          False -> _GT
 229               }}}
 230   where
 231     cmp_eq = ... to come ...
 232 \end{verbatim}
 233
 234 \item
 235   We are only left with the ``help'' function @cmp_eq@, to deal with
 236   comparing data constructors with the same tag.
 237
 238   For the ordinary constructors (if any), we emit the sorta-obvious
 239   compare-style stuff; for our example:
 240 \begin{verbatim}
 241 cmp_eq (O1 a1 b1) (O1 a2 b2)
 242   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 243
 244 cmp_eq (O2 a1) (O2 a2)
 245   = compare a1 a2
 246
 247 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 248   = case (compare a1 a2) of {
 249       LT -> LT;
 250       GT -> GT;
 251       EQ -> case compare b1 b2 of {
 252               LT -> LT;
 253               GT -> GT;
 254               EQ -> compare c1 c2
 255             }
 256     }
 257 \end{verbatim}
 258
 259   Again, we must be careful about unboxed comparisons.  For example,
 260   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 261   generate:
 262 \begin{verbatim}
 263 cmp_eq lt eq gt (O2 a1) (O2 a2)
 264   = compareInt# a1 a2
 265   -- or maybe the unfolded equivalent
 266 \end{verbatim}
 267
 268 \item
 269   For the remaining nullary constructors, we already know that the
 270   tags are equal so:
 271 \begin{verbatim}
 272 cmp_eq _ _ = EQ
 273 \end{verbatim}
 274 \end{itemize}
 275
 276 \begin{code}
 277 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
 278
 279 gen_Ord_binds tycon
 280   = defaulted `AndMonoBinds` compare
 281   where
 282     tycon_loc = getSrcLoc tycon
 283     --------------------------------------------------------------------
 284     compare = mk_easy_FunMonoBind tycon_loc compare_RDR
 285                 [a_Pat, b_Pat]
 286                 [cmp_eq]
 287             (if maybeToBool (maybeTyConSingleCon tycon) then
 288                 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 289              else
 290                 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 291                   (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
 292                         -- True case; they are equal
 293                         -- If an enumeration type we are done; else
 294                         -- recursively compare their components
 295                     (if isEnumerationTyCon tycon then
 296                         eqTag_Expr
 297                      else
 298                         cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 299                     )
 300                         -- False case; they aren't equal
 301                         -- So we need to do a less-than comparison on the tags
 302                     (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
 303
 304     (nullary_cons, nonnullary_cons)
 305       = partition isNullaryDataCon (tyConDataCons tycon)
 306
 307     cmp_eq
 308       = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++
 309                                              [([WildPatIn, WildPatIn], default_rhs)])
 310       where
 311         pats_etc data_con
 312           = ([con1_pat, con2_pat],
 313              nested_compare_expr tys_needed as_needed bs_needed)
 314           where
 315             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
 316             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 317
 318             data_con_RDR = qual_orig_name data_con
 319             con_arity   = length tys_needed
 320             as_needed   = take con_arity as_RDRs
 321             bs_needed   = take con_arity bs_RDRs
 322             tys_needed  = dataConRawArgTys data_con
 323
 324             nested_compare_expr [ty] [a] [b]
 325               = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
 326
 327             nested_compare_expr (ty:tys) (a:as) (b:bs)
 328               = let eq_expr = nested_compare_expr tys as bs
 329                 in  careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
 330
 331         default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
 332                                                                 -- inexhaustive patterns
 333                     | otherwise         = eqTag_Expr            -- Some nullary constructors;
 334                                                                 -- Tags are equal, no args => return EQ
 335     --------------------------------------------------------------------
 336
 337 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
 338
 339 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
 340             compare_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
 341 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
 342             compare_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
 343 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
 344             compare_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
 345 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
 346             compare_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
 347
 348 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
 349             compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
 350 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
 351             compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
 352 \end{code}
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsubsection{Generating @Enum@ instance declarations}
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 @Enum@ can only be derived for enumeration types.  For a type
 361 \begin{verbatim}
 362 data Foo ... = N1 | N2 | ... | Nn
 363 \end{verbatim}
 364
 365 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 366 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 367
 368 \begin{verbatim}
 369 instance ... Enum (Foo ...) where
 370     toEnum i = tag2con_Foo i
 371
 372     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 373
 374     -- or, really...
 375     enumFrom a
 376       = case con2tag_Foo a of
 377           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 378
 379    enumFromThen a b
 380      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 381
 382     -- or, really...
 383     enumFromThen a b
 384       = case con2tag_Foo a of { a# ->
 385         case con2tag_Foo b of { b# ->
 386         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 387         }}
 388 \end{verbatim}
 389
 390 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 391
 392 \begin{code}
 393 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
 394
 395 gen_Enum_binds tycon
 396   = to_enum             `AndMonoBinds`
 397     enum_from           `AndMonoBinds`
 398     enum_from_then      `AndMonoBinds`
 399     from_enum
 400   where
 401     tycon_loc = getSrcLoc tycon
 402
 403     to_enum
 404       = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
 405         mk_easy_App (tag2con_RDR tycon) [a_RDR]
 406
 407     enum_from
 408       = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
 409           untag_Expr tycon [(a_RDR, ah_RDR)] $
 410           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 411             HsPar (enum_from_to_Expr
 412                     (mk_easy_App mkInt_RDR [ah_RDR])
 413                     (HsVar (maxtag_RDR tycon)))
 414
 415     enum_from_then
 416       = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
 417           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 418           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 419             HsPar (enum_from_then_to_Expr
 420                     (mk_easy_App mkInt_RDR [ah_RDR])
 421                     (mk_easy_App mkInt_RDR [bh_RDR])
 422                     (HsVar (maxtag_RDR tycon)))
 423
 424     from_enum
 425       = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
 426           untag_Expr tycon [(a_RDR, ah_RDR)] $
 427           (mk_easy_App mkInt_RDR [ah_RDR])
 428 \end{code}
 429
 430 %************************************************************************
 431 %*                                                                      *
 432 \subsubsection{Generating @Eval@ instance declarations}
 433 %*                                                                      *
 434 %************************************************************************
 435
 436 \begin{code}
 437 gen_Eval_binds tycon = EmptyMonoBinds
 438 \end{code}
 439
 440 %************************************************************************
 441 %*                                                                      *
 442 \subsubsection{Generating @Bounded@ instance declarations}
 443 %*                                                                      *
 444 %************************************************************************
 445
 446 \begin{code}
 447 gen_Bounded_binds tycon
 448   = if isEnumerationTyCon tycon then
 449         min_bound_enum `AndMonoBinds` max_bound_enum
 450     else
 451         ASSERT(length data_cons == 1)
 452         min_bound_1con `AndMonoBinds` max_bound_1con
 453   where
 454     data_cons = tyConDataCons tycon
 455     tycon_loc = getSrcLoc tycon
 456
 457     ----- enum-flavored: ---------------------------
 458     min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
 459     max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
 460
 461     data_con_1    = head data_cons
 462     data_con_N    = last data_cons
 463     data_con_1_RDR = qual_orig_name data_con_1
 464     data_con_N_RDR = qual_orig_name data_con_N
 465
 466     ----- single-constructor-flavored: -------------
 467     arity          = dataConNumFields data_con_1
 468
 469     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
 470                      mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
 471     max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
 472                      mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
 473 \end{code}
 474
 475 %************************************************************************
 476 %*                                                                      *
 477 \subsubsection{Generating @Ix@ instance declarations}
 478 %*                                                                      *
 479 %************************************************************************
 480
 481 Deriving @Ix@ is only possible for enumeration types and
 482 single-constructor types.  We deal with them in turn.
 483
 484 For an enumeration type, e.g.,
 485 \begin{verbatim}
 486     data Foo ... = N1 | N2 | ... | Nn
 487 \end{verbatim}
 488 things go not too differently from @Enum@:
 489 \begin{verbatim}
 490 instance ... Ix (Foo ...) where
 491     range (a, b)
 492       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 493
 494     -- or, really...
 495     range (a, b)
 496       = case (con2tag_Foo a) of { a# ->
 497         case (con2tag_Foo b) of { b# ->
 498         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 499         }}
 500
 501     index c@(a, b) d
 502       = if inRange c d
 503         then case (con2tag_Foo d -# con2tag_Foo a) of
 504                r# -> I# r#
 505         else error "Ix.Foo.index: out of range"
 506
 507     inRange (a, b) c
 508       = let
 509             p_tag = con2tag_Foo c
 510         in
 511         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 512
 513     -- or, really...
 514     inRange (a, b) c
 515       = case (con2tag_Foo a)   of { a_tag ->
 516         case (con2tag_Foo b)   of { b_tag ->
 517         case (con2tag_Foo c)   of { c_tag ->
 518         if (c_tag >=# a_tag) then
 519           c_tag <=# b_tag
 520         else
 521           False
 522         }}}
 523 \end{verbatim}
 524 (modulo suitable case-ification to handle the unboxed tags)
 525
 526 For a single-constructor type (NB: this includes all tuples), e.g.,
 527 \begin{verbatim}
 528     data Foo ... = MkFoo a b Int Double c c
 529 \end{verbatim}
 530 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 531 (p.~147).
 532
 533 \begin{code}
 534 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
 535
 536 gen_Ix_binds tycon
 537   = if isEnumerationTyCon tycon
 538     then enum_ixes
 539     else single_con_ixes
 540   where
 541     tycon_str = getOccString tycon
 542     tycon_loc = getSrcLoc tycon
 543
 544     --------------------------------------------------------------
 545     enum_ixes = enum_range `AndMonoBinds`
 546                 enum_index `AndMonoBinds` enum_inRange
 547
 548     enum_range
 549       = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
 550           untag_Expr tycon [(a_RDR, ah_RDR)] $
 551           untag_Expr tycon [(b_RDR, bh_RDR)] $
 552           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 553               HsPar (enum_from_to_Expr
 554                         (mk_easy_App mkInt_RDR [ah_RDR])
 555                         (mk_easy_App mkInt_RDR [bh_RDR]))
 556
 557     enum_index
 558       = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
 559         HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
 560            untag_Expr tycon [(a_RDR, ah_RDR)] (
 561            untag_Expr tycon [(d_RDR, dh_RDR)] (
 562            let
 563                 grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc]
 564            in
 565            HsCase
 566              (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
 567              [PatMatch (VarPatIn c_RDR)
 568                                 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
 569              tycon_loc
 570            ))
 571         ) {-else-} (
 572            HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
 573         )
 574         tycon_loc)
 575
 576     enum_inRange
 577       = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
 578           untag_Expr tycon [(a_RDR, ah_RDR)] (
 579           untag_Expr tycon [(b_RDR, bh_RDR)] (
 580           untag_Expr tycon [(c_RDR, ch_RDR)] (
 581           HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
 582              (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
 583           ) {-else-} (
 584              false_Expr
 585           ) tycon_loc))))
 586
 587     --------------------------------------------------------------
 588     single_con_ixes = single_con_range `AndMonoBinds`
 589                 single_con_index `AndMonoBinds` single_con_inRange
 590
 591     data_con
 592       = case maybeTyConSingleCon tycon of -- just checking...
 593           Nothing -> panic "get_Ix_binds"
 594           Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
 595                          error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
 596                      else
 597                          dc
 598
 599     con_arity   = dataConNumFields data_con
 600     data_con_RDR = qual_orig_name data_con
 601     con_pat  xs = ConPatIn data_con_RDR (map VarPatIn xs)
 602     con_expr xs = mk_easy_App data_con_RDR xs
 603
 604     as_needed = take con_arity as_RDRs
 605     bs_needed = take con_arity bs_RDRs
 606     cs_needed = take con_arity cs_RDRs
 607
 608     --------------------------------------------------------------
 609     single_con_range
 610       = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
 611         HsDo ListComp stmts tycon_loc
 612       where
 613         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 614                 ++
 615                 [ReturnStmt (con_expr cs_needed)]
 616
 617         mk_qual a b c = BindStmt (VarPatIn c)
 618                                  (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
 619                                  tycon_loc
 620
 621     ----------------
 622     single_con_index
 623       = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
 624         foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
 625       where
 626         mk_index multiply_by (l, u, i)
 627           = genOpApp (
 628                 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
 629            ) plus_RDR (
 630                 genOpApp (
 631                     (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
 632                 ) times_RDR multiply_by
 633            )
 634
 635         range_size
 636           = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
 637                 genOpApp (
 638                     (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
 639                 ) plus_RDR (HsLit (HsInt 1)))
 640
 641     ------------------
 642     single_con_inRange
 643       = mk_easy_FunMonoBind tycon_loc inRange_RDR
 644                            [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
 645                            [] (
 646           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
 647       where
 648         in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
 649 \end{code}
 650
 651 %************************************************************************
 652 %*                                                                      *
 653 \subsubsection{Generating @Read@ instance declarations}
 654 %*                                                                      *
 655 %************************************************************************
 656
 657 Ignoring all the infix-ery mumbo jumbo (ToDo)
 658
 659 \begin{code}
 660 gen_Read_binds :: TyCon -> RdrNameMonoBinds
 661
 662 gen_Read_binds tycon
 663   = reads_prec `AndMonoBinds` read_list
 664   where
 665     tycon_loc = getSrcLoc tycon
 666     -----------------------------------------------------------------------
 667     read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
 668                   (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
 669     -----------------------------------------------------------------------
 670     reads_prec
 671       = let
 672             read_con_comprehensions
 673               = map read_con (tyConDataCons tycon)
 674         in
 675         mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
 676               foldr1 append_Expr read_con_comprehensions
 677         )
 678       where
 679         read_con data_con   -- note: "b" is the string being "read"
 680           = let
 681                 data_con_RDR = qual_orig_name data_con
 682                 data_con_str= occNameString (getOccName data_con)
 683                 con_arity   = dataConNumFields data_con
 684                 as_needed   = take con_arity as_RDRs
 685                 bs_needed   = take con_arity bs_RDRs
 686                 con_expr    = mk_easy_App data_con_RDR as_needed
 687                 nullary_con = isNullaryDataCon data_con
 688
 689                 con_qual
 690                   = BindStmt
 691                       (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
 692                       (HsApp (HsVar lex_RDR) c_Expr)
 693                       tycon_loc
 694
 695                 field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed))
 696                 mk_qual draw_from (con_field, str_left)
 697                   = (HsVar str_left,    -- what to draw from down the line...
 698                          BindStmt
 699                           (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
 700                           (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
 701                           tycon_loc
 702                     )
 703
 704                 result_expr = ExplicitTuple [con_expr, if null bs_needed
 705                                                        then d_Expr
 706                                                        else HsVar (last bs_needed)]
 707
 708                 stmts = (con_qual : field_quals) ++ [ReturnStmt result_expr]
 709
 710
 711                 read_paren_arg
 712                   = if nullary_con then -- must be False (parens are surely optional)
 713                        false_Expr
 714                     else -- parens depend on precedence...
 715                        HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
 716             in
 717             HsApp (
 718               readParen_Expr read_paren_arg $ HsPar $
 719                  HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
 720                         HsDo ListComp stmts tycon_loc)
 721               ) (HsVar b_RDR)
 722 \end{code}
 723
 724 %************************************************************************
 725 %*                                                                      *
 726 \subsubsection{Generating @Show@ instance declarations}
 727 %*                                                                      *
 728 %************************************************************************
 729
 730 Ignoring all the infix-ery mumbo jumbo (ToDo)
 731
 732 \begin{code}
 733 gen_Show_binds :: TyCon -> RdrNameMonoBinds
 734
 735 gen_Show_binds tycon
 736   = shows_prec `AndMonoBinds` show_list
 737   where
 738     tycon_loc = getSrcLoc tycon
 739     -----------------------------------------------------------------------
 740     show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
 741                   (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
 742     -----------------------------------------------------------------------
 743     shows_prec
 744       = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 745       where
 746         pats_etc data_con
 747           = let
 748                 data_con_RDR = qual_orig_name data_con
 749                 con_arity   = dataConNumFields data_con
 750                 bs_needed   = take con_arity bs_RDRs
 751                 con_pat     = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 752                 nullary_con = isNullaryDataCon data_con
 753
 754                 show_con
 755                   = let nm = occNameString (getOccName data_con)
 756                         space_maybe = if nullary_con then _NIL_ else SLIT(" ")
 757                     in
 758                         HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe)))
 759
 760                 show_thingies = show_con : (spacified real_show_thingies)
 761
 762                 real_show_thingies
 763                   = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
 764                   | b <- bs_needed ]
 765             in
 766             if nullary_con then  -- skip the showParen junk...
 767                 ASSERT(null bs_needed)
 768                 ([a_Pat, con_pat], show_con)
 769             else
 770                 ([a_Pat, con_pat],
 771                     showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
 772                                    (HsPar (nested_compose_Expr show_thingies)))
 773           where
 774             spacified []     = []
 775             spacified [x]    = [x]
 776             spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs)
 777 \end{code}
 778
 779 %************************************************************************
 780 %*                                                                      *
 781 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
 782 %*                                                                      *
 783 %************************************************************************
 784
 785 \begin{verbatim}
 786 data Foo ... = ...
 787
 788 con2tag_Foo :: Foo ... -> Int#
 789 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 790 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 791 \end{verbatim}
 792
 793 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 794 fiddling around.
 795
 796 \begin{code}
 797 data TagThingWanted
 798   = GenCon2Tag | GenTag2Con | GenMaxTag
 799
 800 gen_tag_n_con_monobind
 801     :: (RdrName,            -- (proto)Name for the thing in question
 802         TyCon,              -- tycon in question
 803         TagThingWanted)
 804     -> RdrNameMonoBinds
 805
 806 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
 807   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
 808   where
 809     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
 810
 811     mk_stuff var
 812       = ASSERT(isDataCon var)
 813         ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
 814       where
 815         pat    = ConPatIn var_RDR (nOfThem (dataConNumFields var) WildPatIn)
 816         var_RDR = qual_orig_name var
 817
 818 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
 819   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
 820                                                              [([WildPatIn], impossible_Expr)])
 821   where
 822     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
 823
 824     mk_stuff var
 825       = ASSERT(isDataCon var)
 826         ([lit_pat], HsVar var_RDR)
 827       where
 828         lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
 829         var_RDR  = qual_orig_name var
 830
 831 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
 832   = mk_easy_FunMonoBind (getSrcLoc tycon)
 833                 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
 834   where
 835     max_tag =  case (tyConDataCons tycon) of
 836                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 837
 838 \end{code}
 839
 840 %************************************************************************
 841 %*                                                                      *
 842 \subsection{Utility bits for generating bindings}
 843 %*                                                                      *
 844 %************************************************************************
 845
 846 @mk_easy_FunMonoBind fun pats binds expr@ generates:
 847 \begin{verbatim}
 848     fun pat1 pat2 ... patN = expr where binds
 849 \end{verbatim}
 850
 851 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
 852 multi-clause definitions; it generates:
 853 \begin{verbatim}
 854     fun p1a p1b ... p1N = e1
 855     fun p2a p2b ... p2N = e2
 856     ...
 857     fun pMa pMb ... pMN = eM
 858 \end{verbatim}
 859
 860 \begin{code}
 861 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
 862                     -> [RdrNameMonoBinds] -> RdrNameHsExpr
 863                     -> RdrNameMonoBinds
 864
 865 mk_easy_FunMonoBind loc fun pats binds expr
 866   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
 867
 868 mk_easy_Match loc pats binds expr
 869   = mk_match loc pats expr (mkbind binds)
 870   where
 871     mkbind [] = EmptyBinds
 872     mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] recursive
 873         -- The renamer expects everything in its input to be a
 874         -- "recursive" MonoBinds, and it is its job to sort things out
 875         -- from there.
 876
 877 mk_FunMonoBind  :: SrcLoc -> RdrName
 878                 -> [([RdrNamePat], RdrNameHsExpr)]
 879                 -> RdrNameMonoBinds
 880
 881 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
 882 mk_FunMonoBind loc fun pats_and_exprs
 883   = FunMonoBind fun False{-not infix-}
 884                 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
 885                 loc
 886
 887 mk_match loc pats expr binds
 888   = foldr PatMatch
 889           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds))
 890           (map paren pats)
 891   where
 892     paren p@(VarPatIn _) = p
 893     paren other_p        = ParPatIn other_p
 894 \end{code}
 895
 896 \begin{code}
 897 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
 898 \end{code}
 899
 900 ToDo: Better SrcLocs.
 901
 902 \begin{code}
 903 compare_Case, cmp_eq_Expr ::
 904           RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
 905           -> RdrNameHsExpr -> RdrNameHsExpr
 906           -> RdrNameHsExpr
 907 compare_gen_Case ::
 908           RdrName
 909           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
 910           -> RdrNameHsExpr -> RdrNameHsExpr
 911           -> RdrNameHsExpr
 912 careful_compare_Case :: -- checks for primitive types...
 913           Type
 914           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
 915           -> RdrNameHsExpr -> RdrNameHsExpr
 916           -> RdrNameHsExpr
 917
 918 compare_Case = compare_gen_Case compare_RDR
 919 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
 920
 921 compare_gen_Case fun lt eq gt a b
 922   = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
 923       [PatMatch (ConPatIn ltTag_RDR [])
 924           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
 925
 926        PatMatch (ConPatIn eqTag_RDR [])
 927           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
 928
 929        PatMatch (ConPatIn gtTag_RDR [])
 930           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
 931        mkGeneratedSrcLoc
 932
 933 careful_compare_Case ty lt eq gt a b
 934   = if not (isPrimType ty) then
 935        compare_gen_Case compare_RDR lt eq gt a b
 936
 937     else -- we have to do something special for primitive things...
 938        HsIf (genOpApp a relevant_eq_op b)
 939             eq
 940             (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
 941             mkGeneratedSrcLoc
 942   where
 943     relevant_eq_op = assoc_ty_id eq_op_tbl ty
 944     relevant_lt_op = assoc_ty_id lt_op_tbl ty
 945
 946 assoc_ty_id tyids ty
 947   = if null res then panic "assoc_ty"
 948     else head res
 949   where
 950     res = [id | (ty',id) <- tyids, eqTy ty ty']
 951
 952 eq_op_tbl =
 953     [(charPrimTy,       eqH_Char_RDR)
 954     ,(intPrimTy,        eqH_Int_RDR)
 955     ,(wordPrimTy,       eqH_Word_RDR)
 956     ,(addrPrimTy,       eqH_Addr_RDR)
 957     ,(floatPrimTy,      eqH_Float_RDR)
 958     ,(doublePrimTy,     eqH_Double_RDR)
 959     ]
 960
 961 lt_op_tbl =
 962     [(charPrimTy,       ltH_Char_RDR)
 963     ,(intPrimTy,        ltH_Int_RDR)
 964     ,(wordPrimTy,       ltH_Word_RDR)
 965     ,(addrPrimTy,       ltH_Addr_RDR)
 966     ,(floatPrimTy,      ltH_Float_RDR)
 967     ,(doublePrimTy,     ltH_Double_RDR)
 968     ]
 969
 970 -----------------------------------------------------------------------
 971
 972 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
 973
 974 and_Expr    a b = genOpApp a and_RDR    b
 975 append_Expr a b = genOpApp a append_RDR b
 976
 977 -----------------------------------------------------------------------
 978
 979 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
 980 eq_Expr ty a b
 981   = if not (isPrimType ty) then
 982        genOpApp a eq_RDR  b
 983     else -- we have to do something special for primitive things...
 984        genOpApp a relevant_eq_op b
 985   where
 986     relevant_eq_op = assoc_ty_id eq_op_tbl ty
 987 \end{code}
 988
 989 \begin{code}
 990 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
 991 untag_Expr tycon [] expr = expr
 992 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
 993   = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
 994       [PatMatch (VarPatIn put_tag_here)
 995                         (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
 996       mkGeneratedSrcLoc
 997   where
 998     grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
 999
1000 cmp_tags_Expr :: RdrName                -- Comparison op
1001              -> RdrName -> RdrName      -- Things to compare
1002              -> RdrNameHsExpr           -- What to return if true
1003              -> RdrNameHsExpr           -- What to return if false
1004              -> RdrNameHsExpr
1005
1006 cmp_tags_Expr op a b true_case false_case
1007   = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1008
1009 enum_from_to_Expr
1010         :: RdrNameHsExpr -> RdrNameHsExpr
1011         -> RdrNameHsExpr
1012 enum_from_then_to_Expr
1013         :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1014         -> RdrNameHsExpr
1015
1016 enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1017 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1018
1019 showParen_Expr, readParen_Expr
1020         :: RdrNameHsExpr -> RdrNameHsExpr
1021         -> RdrNameHsExpr
1022
1023 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1024 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1025
1026 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1027
1028 nested_compose_Expr [e] = parenify e
1029 nested_compose_Expr (e:es)
1030   = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1031
1032 -- impossible_Expr is used in case RHSs that should never happen.
1033 -- We generate these to keep the desugarer from complaining that they *might* happen!
1034 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1035
1036 parenify e@(HsVar _) = e
1037 parenify e           = HsPar e
1038
1039 -- genOpApp wraps brackets round the operator application, so that the
1040 -- renamer won't subsequently try to re-associate it.
1041 -- For some reason the renamer doesn't reassociate it right, and I can't
1042 -- be bothered to find out why just now.
1043
1044 genOpApp e1 op e2 = mkOpApp e1 op e2
1045 \end{code}
1046
1047 \begin{code}
1048 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n }
1049
1050 a_RDR           = varUnqual SLIT("a")
1051 b_RDR           = varUnqual SLIT("b")
1052 c_RDR           = varUnqual SLIT("c")
1053 d_RDR           = varUnqual SLIT("d")
1054 ah_RDR          = varUnqual SLIT("a#")
1055 bh_RDR          = varUnqual SLIT("b#")
1056 ch_RDR          = varUnqual SLIT("c#")
1057 dh_RDR          = varUnqual SLIT("d#")
1058 cmp_eq_RDR      = varUnqual SLIT("cmp_eq")
1059 rangeSize_RDR   = varUnqual SLIT("rangeSize")
1060
1061 as_RDRs         = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1062 bs_RDRs         = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1063 cs_RDRs         = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1064
1065 a_Expr          = HsVar a_RDR
1066 b_Expr          = HsVar b_RDR
1067 c_Expr          = HsVar c_RDR
1068 d_Expr          = HsVar d_RDR
1069 ltTag_Expr      = HsVar ltTag_RDR
1070 eqTag_Expr      = HsVar eqTag_RDR
1071 gtTag_Expr      = HsVar gtTag_RDR
1072 false_Expr      = HsVar false_RDR
1073 true_Expr       = HsVar true_RDR
1074
1075 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1076
1077 a_Pat           = VarPatIn a_RDR
1078 b_Pat           = VarPatIn b_RDR
1079 c_Pat           = VarPatIn c_RDR
1080 d_Pat           = VarPatIn d_RDR
1081
1082 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1083
1084 con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1085 tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1086 maxtag_RDR tycon  = varUnqual (SLIT("maxtag_")  _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1087 \end{code}