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