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