ghc/compiler/typecheck/TcGenDeriv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   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_PN,
  33         eq_TAG_Expr,
  34         eq_TAG_PN,
  35         error_PN,
  36         false_Expr,
  37         false_PN,
  38         geH_PN,
  39         gen_Binary_binds,
  40         gen_Enum_binds,
  41         gen_Eq_binds,
  42         gen_Ix_binds,
  43         gen_Ord_binds,
  44         gen_Text_binds,
  45         gen_tag_n_con_monobind,
  46         gt_TAG_Expr,
  47         gt_TAG_PN,
  48         leH_PN,
  49         ltH_PN,
  50         lt_TAG_Expr,
  51         lt_TAG_PN,
  52         minusH_PN,
  53         mkInt_PN,
  54         rangeSize_PN,
  55         true_Expr,
  56         true_PN
  57     ) where
  58
  59 IMPORT_Trace            -- ToDo:rm debugging
  60 import Outputable
  61 import Pretty
  62
  63 import AbsSyn           -- the stuff being typechecked
  64
  65 import AbsPrel          {-( trueDataCon, falseDataCon, intDataCon, eRROR_ID,
  66                           ltPrimDataCon, eqPrimDataCon, gtPrimDataCon,
  67                           charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
  68                           floatPrimTy, doublePrimTy
  69                         )-}
  70 import PrimOps          -- *********** ditto
  71
  72 import AbsUniType       ( getTyConDataCons, isEnumerationTyCon,
  73                           maybeSingleConstructorTyCon, --UNUSED: preludeClassDerivedFor,
  74                           -- UNUSED: isEnumerationTyConMostly,
  75                           isPrimType, UniType,
  76                           TauType(..), TyVarTemplate, ThetaType(..)
  77                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  78                         )
  79 import Id               ( getDataConArity, getDataConTag,
  80                           getDataConSig, isNullaryDataCon, fIRST_TAG,
  81                           isDataCon, DataCon(..), ConTag(..), Id
  82                         )
  83 import Maybes           ( maybeToBool, Maybe(..) )
  84 import Name             ( Name(..) )
  85 import ProtoName        ( ProtoName(..) )
  86 import RenameAuxFuns    -- why not? take all of it...
  87 import RenameMonad4     -- initRn4, etc.
  88 import SrcLoc           ( mkGeneratedSrcLoc )
  89 import TcDeriv          ( con2tag_PN, tag2con_PN, maxtag_PN,
  90                           TagThingWanted(..), DerivEqn(..)
  91                         )
  92 import Unique           -- some ClassKey stuff
  93 import Util
  94 \end{code}
  95
  96 %************************************************************************
  97 %*                                                                      *
  98 \subsection[TcGenDeriv-classes]{Generating code, by derivable class}
  99 %*                                                                      *
 100 %************************************************************************
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsubsection[TcGenDeriv-Eq]{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 (tagCmp a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 168   (/=) a b  = case (tagCmp 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 -> ProtoNameMonoBinds
 177
 178 gen_Eq_binds tycon
 179   = case (partition isNullaryDataCon (getTyConDataCons tycon))
 180                                 of { (nullary_cons, nonnullary_cons) ->
 181     let
 182         rest
 183           = if null nullary_cons then
 184                 case maybeSingleConstructorTyCon 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_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     }
 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 = Prel (WiredInVal data_con)
 204             as_needed   = take (getDataConArity data_con) as_PNs
 205             bs_needed   = take (getDataConArity data_con) bs_PNs
 206             tys_needed  = case (getDataConSig data_con) of
 207                             (_,_, arg_tys, _) -> arg_tys
 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 [ty]   [a]    [b] = eq_Expr ty (Var a) (Var b)
 213         nested_eq_expr (t:ts) (a:as) (b:bs)
 214           = let
 215                 rest_expr = nested_eq_expr ts as bs
 216             in
 217             and_Expr (eq_Expr t (Var a) (Var b)) rest_expr
 218
 219 boring_ne_method
 220   = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] (
 221         App (Var not_PN) (App (App (Var eq_PN) a_Expr) b_Expr)
 222         )
 223 \end{code}
 224
 225 %************************************************************************
 226 %*                                                                      *
 227 \subsubsection[TcGenDeriv-Ord]{Generating @Ord@ instance declarations}
 228 %*                                                                      *
 229 %************************************************************************
 230
 231 For a derived @Ord@, we concentrate our attentions on the non-standard
 232 @_tagCmp@ method, which type:
 233 \begin{verbatim}
 234 _tagCmp :: a -> a -> _CMP_TAG
 235
 236 -- and the builtin tag type is:
 237
 238 data _CMP_TAG = _LT | _EQ | _GT deriving ()
 239 \end{verbatim}
 240
 241 (All this @_tagCmp@ stuff is due to the sterling analysis by Julian
 242 Seward.)
 243
 244 We will use the same example data type as above:
 245 \begin{verbatim}
 246 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 247 \end{verbatim}
 248
 249 \begin{itemize}
 250 \item
 251   We do all the other @Ord@ methods with calls to @_tagCmp@:
 252 \begin{verbatim}
 253 instance ... (Ord <wurble> <wurble>) where
 254     a <  b  = case _tagCmp a b of { _LT -> True;  _EQ -> False; _GT -> False }
 255     a <= b  = case _tagCmp a b of { _LT -> True;  _EQ -> True;  _GT -> False }
 256     a >= b  = case _tagCmp a b of { _LT -> False; _EQ -> True;  _GT -> True  }
 257     a >  b  = case _tagCmp a b of { _LT -> False; _EQ -> False; _GT -> True  }
 258
 259     max a b = case _tagCmp a b of { _LT -> b; _EQ -> a;  _GT -> a }
 260     min a b = case _tagCmp a b of { _LT -> a; _EQ -> a;  _GT -> b }
 261
 262     -- _tagCmp to come...
 263 \end{verbatim}
 264
 265 \item
 266   @_tagCmp@ always has two parts.  First, we use the compared
 267   data-constructors' tags to deal with the case of different
 268   constructors:
 269 \begin{verbatim}
 270 _tagCmp a b = case (con2tag_Foo a) of { a# ->
 271              case (con2tag_Foo b) of { b# ->
 272              case (a# ==# b#)    of {
 273                True  -> cmp_eq a b
 274                False -> case (a# <# b#) of
 275                          True  -> _LT
 276                          False -> _GT
 277              }}}
 278   where
 279     cmp_eq = ... to come ...
 280 \end{verbatim}
 281
 282 \item
 283   We are only left with the ``help'' function @cmp_eq@, to deal with
 284   comparing data constructors with the same tag.
 285
 286   For the ordinary constructors (if any), we emit the sorta-obvious
 287   tagCmp-style stuff; for our example:
 288 \begin{verbatim}
 289 cmp_eq (O1 a1 b1) (O1 a2 b2)
 290   = case (_tagCmp a1 a2) of { _LT -> _LT; _EQ -> _tagCmp b1 b2; _GT -> _GT }
 291
 292 cmp_eq (O2 a1) (O2 a2)
 293   = _tagCmp a1 a2
 294
 295 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 296   = case (_tagCmp a1 a2) of {
 297       _LT -> _LT;
 298       _GT -> _GT;
 299       _EQ -> case _tagCmp b1 b2 of {
 300                   _LT -> _LT;
 301                   _GT -> _GT;
 302                   _EQ -> _tagCmp c1 c2
 303                 }
 304     }
 305 \end{verbatim}
 306
 307   Again, we must be careful about unboxed comparisons.  For example,
 308   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 309   generate:
 310 \begin{verbatim}
 311 cmp_eq lt eq gt (O2 a1) (O2 a2)
 312   = tagCmpInt# a1 a2
 313   -- or maybe the unfolded equivalent
 314 \end{verbatim}
 315
 316 \item
 317   For the remaining nullary constructors, we already know that the
 318   tags are equal so:
 319 \begin{verbatim}
 320 cmp_eq _ _ = _EQ
 321 \end{verbatim}
 322 \end{itemize}
 323
 324 \begin{code}
 325 gen_Ord_binds :: TyCon -> ProtoNameMonoBinds
 326
 327 gen_Ord_binds tycon
 328   = defaulted `AndMonoBinds` tagCmp
 329   where
 330     --------------------------------------------------------------------
 331     tagCmp = mk_easy_FunMonoBind tagCmp_PN
 332                 [a_Pat, b_Pat]
 333                 [cmp_eq]
 334             (if maybeToBool (maybeSingleConstructorTyCon tycon) then
 335                 cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr
 336              else
 337                 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
 338                   (cmp_tags_Expr eqH_PN ah_PN bh_PN
 339                         -- True case; they are equal
 340                         -- If an enumeration type we are done; else
 341                         -- recursively compare their components
 342                     (if isEnumerationTyCon tycon then
 343                         eq_TAG_Expr
 344                      else
 345                         cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr
 346                     )
 347                         -- False case; they aren't equal
 348                         -- So we need to do a less-than comparison on the tags
 349                     (cmp_tags_Expr ltH_PN ah_PN bh_PN lt_TAG_Expr gt_TAG_Expr)))
 350
 351     (nullary_cons, nonnullary_cons)
 352       = partition isNullaryDataCon (getTyConDataCons tycon)
 353
 354     cmp_eq
 355       = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
 356       where
 357         pats_etc data_con
 358           = ([con1_pat, con2_pat],
 359              nested_tagCmp_expr tys_needed as_needed bs_needed)
 360           where
 361             con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
 362             con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
 363
 364             data_con_PN = Prel (WiredInVal data_con)
 365             as_needed   = take (getDataConArity data_con) as_PNs
 366             bs_needed   = take (getDataConArity data_con) bs_PNs
 367             tys_needed  = case (getDataConSig data_con) of
 368                             (_,_, arg_tys, _) -> arg_tys
 369
 370             nested_tagCmp_expr [ty] [a] [b]
 371               = careful_tagCmp_Case ty lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr (Var a) (Var b)
 372
 373             nested_tagCmp_expr (ty:tys) (a:as) (b:bs)
 374               = let eq_expr = nested_tagCmp_expr tys as bs
 375                 in  careful_tagCmp_Case ty lt_TAG_Expr eq_expr gt_TAG_Expr (Var a) (Var b)
 376
 377         deflt_pats_etc
 378           = if null nullary_cons
 379             then []
 380             else [([a_Pat, b_Pat], eq_TAG_Expr)]
 381     --------------------------------------------------------------------
 382
 383 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
 384
 385 lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
 386             tagCmp_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
 387 le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
 388             tagCmp_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
 389 ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
 390             tagCmp_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
 391 gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
 392             tagCmp_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
 393
 394 max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
 395             tagCmp_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
 396 min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
 397             tagCmp_Case a_Expr a_Expr b_Expr a_Expr b_Expr)
 398 \end{code}
 399
 400 %************************************************************************
 401 %*                                                                      *
 402 \subsubsection[TcGenDeriv-Enum]{Generating @Enum@ instance declarations}
 403 %*                                                                      *
 404 %************************************************************************
 405
 406 @Enum@ can only be derived for enumeration types.  For a type
 407 \begin{verbatim}
 408 data Foo ... = N1 | N2 | ... | Nn
 409 \end{verbatim}
 410
 411 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 412 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 413
 414 \begin{verbatim}
 415 instance ... Enum (Foo ...) where
 416     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 417
 418     -- or, really...
 419     enumFrom a
 420       = case con2tag_Foo a of
 421           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 422
 423    enumFromThen a b
 424      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 425
 426     -- or, really...
 427     enumFromThen a b
 428       = case con2tag_Foo a of { a# ->
 429         case con2tag_Foo b of { b# ->
 430         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 431         }}
 432 \end{verbatim}
 433
 434 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 435
 436 \begin{code}
 437 gen_Enum_binds :: TyCon -> ProtoNameMonoBinds
 438
 439 gen_Enum_binds tycon
 440   = enum_from `AndMonoBinds` enum_from_then
 441   where
 442     enum_from
 443       = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] (
 444           untag_Expr tycon [(a_PN, ah_PN)] (
 445           App (App (Var map_PN) (Var (tag2con_PN tycon))) (
 446               enum_from_to_Expr
 447                 (App (Var mkInt_PN) (Var ah_PN))
 448                 (Var (maxtag_PN tycon)))))
 449
 450     enum_from_then
 451       = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] (
 452           untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] (
 453           App (App (Var map_PN) (Var (tag2con_PN tycon))) (
 454               enum_from_then_to_Expr
 455                 (App (Var mkInt_PN) (Var ah_PN))
 456                 (App (Var mkInt_PN) (Var bh_PN))
 457                 (Var (maxtag_PN tycon)))))
 458 \end{code}
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsubsection[TcGenDeriv-Ix]{Generating @Ix@ instance declarations}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 Deriving @Ix@ is only possible for enumeration types and
 467 single-constructor types.  We deal with them in turn.
 468
 469 For an enumeration type, e.g.,
 470 \begin{verbatim}
 471     data Foo ... = N1 | N2 | ... | Nn
 472 \end{verbatim}
 473 things go not too differently from @Enum@:
 474 \begin{verbatim}
 475 instance ... Ix (Foo ...) where
 476     range (a, b)
 477       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 478
 479     -- or, really...
 480     range (a, b)
 481       = case (con2tag_Foo a) of { a# ->
 482         case (con2tag_Foo b) of { b# ->
 483         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 484         }}
 485
 486     index c@(a, b) d
 487       = if inRange c d
 488         then case (con2tag_Foo d -# con2tag_Foo a) of
 489                r# -> I# r#
 490         else error "Ix.Foo.index: out of range"
 491
 492     inRange (a, b) c
 493       = let
 494             p_tag = con2tag_Foo c
 495         in
 496         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 497
 498     -- or, really...
 499     inRange (a, b) c
 500       = case (con2tag_Foo a)   of { a_tag ->
 501         case (con2tag_Foo b)   of { b_tag ->
 502         case (con2tag_Foo c)   of { c_tag ->
 503         if (c_tag >=# a_tag) then
 504           c_tag <=# b_tag
 505         else
 506           False
 507         }}}
 508 \end{verbatim}
 509 (modulo suitable case-ification to handle the unboxed tags)
 510
 511 For a single-constructor type (NB: this includes all tuples), e.g.,
 512 \begin{verbatim}
 513     data Foo ... = MkFoo a b Int Double c c
 514 \end{verbatim}
 515 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 516 (p.~147).
 517
 518 \begin{code}
 519 gen_Ix_binds :: TyCon -> ProtoNameMonoBinds
 520
 521 gen_Ix_binds tycon
 522   = if isEnumerationTyCon tycon
 523     then enum_ixes
 524     else single_con_ixes
 525   where
 526     tycon_str = _UNPK_ (snd (getOrigName tycon))
 527
 528     --------------------------------------------------------------
 529     enum_ixes = enum_range `AndMonoBinds`
 530                 enum_index `AndMonoBinds` enum_inRange
 531
 532     enum_range
 533       = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] (
 534           untag_Expr tycon [(a_PN, ah_PN)] (
 535           untag_Expr tycon [(b_PN, bh_PN)] (
 536           App (App (Var map_PN) (Var (tag2con_PN tycon))) (
 537               enum_from_to_Expr
 538                 (App (Var mkInt_PN) (Var ah_PN))
 539                 (App (Var mkInt_PN) (Var bh_PN))
 540         ))))
 541
 542     enum_index
 543       = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
 544         If (App (App (Var inRange_PN) c_Expr) d_Expr) (
 545            untag_Expr tycon [(a_PN, ah_PN)] (
 546            untag_Expr tycon [(d_PN, dh_PN)] (
 547            let
 548                 grhs = [OtherwiseGRHS (App (Var mkInt_PN) (Var c_PN)) mkGeneratedSrcLoc]
 549            in
 550            Case (OpApp (Var dh_PN) (Var minusH_PN) (Var ah_PN)) {-of-}
 551              [PatMatch (VarPatIn c_PN)
 552                                 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
 553            ))
 554         ) {-else-} (
 555            App (Var error_PN) (Lit (StringLit (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
 556         )
 557         )
 558
 559     enum_inRange
 560       = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
 561           untag_Expr tycon [(a_PN, ah_PN)] (
 562           untag_Expr tycon [(b_PN, bh_PN)] (
 563           untag_Expr tycon [(c_PN, ch_PN)] (
 564           If (OpApp (Var ch_PN) (Var geH_PN) (Var ah_PN)) (
 565              (OpApp (Var ch_PN) (Var leH_PN) (Var bh_PN))
 566           ) {-else-} (
 567              false_Expr
 568           )))))
 569
 570     --------------------------------------------------------------
 571     single_con_ixes = single_con_range `AndMonoBinds`
 572                 single_con_index `AndMonoBinds` single_con_inRange
 573
 574     data_con
 575       = case maybeSingleConstructorTyCon tycon of -- just checking...
 576           Nothing -> panic "get_Ix_binds"
 577           Just dc -> let
 578                          (_, _, arg_tys, _) = getDataConSig dc
 579                      in
 580                      if any isPrimType arg_tys then
 581                          error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
 582                      else
 583                          dc
 584
 585     con_arity   = getDataConArity data_con
 586     data_con_PN = Prel (WiredInVal data_con)
 587     con_pat  xs = ConPatIn data_con_PN (map VarPatIn xs)
 588     con_expr xs = foldl App (Var data_con_PN) (map Var xs)
 589
 590     as_needed = take (getDataConArity data_con) as_PNs
 591     bs_needed = take (getDataConArity data_con) bs_PNs
 592     cs_needed = take (getDataConArity data_con) cs_PNs
 593
 594     --------------------------------------------------------------
 595     single_con_range
 596       = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
 597           ListComp (con_expr cs_needed) (zipWith3 mk_qual as_needed bs_needed cs_needed)
 598         )
 599       where
 600         mk_qual a b c = GeneratorQual (VarPatIn c)
 601                             (App (Var range_PN) (ExplicitTuple [Var a, Var b]))
 602
 603     ----------------
 604     single_con_index
 605       = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
 606         foldl mk_index (Lit (IntLit 0)) (zip3 as_needed bs_needed cs_needed))
 607       where
 608         mk_index multiply_by (l, u, i)
 609           =OpApp (
 610                 (App (App (Var index_PN) (ExplicitTuple [Var l, Var u])) (Var i))
 611            ) (Var plus_PN) (
 612                 OpApp (
 613                     (App (Var rangeSize_PN) (ExplicitTuple [Var l, Var u]))
 614                 ) (Var times_PN) multiply_by
 615            )
 616
 617         range_size
 618           = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
 619                 OpApp (
 620                     (App (App (Var index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
 621                 ) (Var plus_PN) (Lit (IntLit 1)))
 622
 623     ------------------
 624     single_con_inRange
 625       = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
 626           foldl1 and_Expr (zipWith3 in_range as_needed bs_needed cs_needed))
 627       where
 628         in_range a b c = App (App (Var inRange_PN) (ExplicitTuple [Var a, Var b])) (Var c)
 629 \end{code}
 630
 631 %************************************************************************
 632 %*                                                                      *
 633 \subsubsection[TcGenDeriv-Text]{Generating @Text@ instance declarations}
 634 %*                                                                      *
 635 %************************************************************************
 636
 637 Deriving @Text@ is a pain.  @show@ is commonly used; @read@ is rarely
 638 used---but we're supposed to generate massive amounts of code for it
 639 anyway.  We provide a command-line flag to say ``Don't bother''
 640 (@OmitDerivedRead@).
 641
 642 We just use the default methods for @showList@ and @readList@.
 643
 644 Also: ignoring all the infix-ery mumbo jumbo (ToDo)
 645
 646 The part of the Haskell report that deals with this (pages~147--151,
 647 1.2~version) is an adequate guide to what needs to be done.  Note that
 648 this is where we may (eventually) use the fixity info that's been
 649 passed around.
 650
 651 \begin{code}
 652 gen_Text_binds :: [RenamedFixityDecl] -> Bool -> TyCon -> ProtoNameMonoBinds
 653
 654 gen_Text_binds fixities omit_derived_read tycon
 655   = if omit_derived_read
 656     then shows_prec
 657     else shows_prec `AndMonoBinds` reads_prec
 658   where
 659     -----------------------------------------------------------------------
 660     shows_prec
 661       = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon))
 662       where
 663         pats_etc data_con
 664           = let
 665                 data_con_PN = Prel (WiredInVal data_con)
 666                 bs_needed   = take (getDataConArity data_con) bs_PNs
 667                 con_pat     = ConPatIn data_con_PN (map VarPatIn bs_needed)
 668                 is_nullary_con = isNullaryDataCon data_con
 669
 670                 show_con
 671                   = let (mod, nm)   = getOrigName data_con
 672                         space_maybe = if is_nullary_con then _NIL_ else SLIT(" ")
 673                     in
 674                         App (Var showString_PN) (Lit (StringLit (nm _APPEND_ space_maybe)))
 675
 676                 show_thingies = show_con : (spacified real_show_thingies)
 677
 678                 real_show_thingies
 679                   = [ App (App (Var showsPrec_PN) (Lit (IntLit 10))) (Var b)
 680                   | b <- bs_needed ]
 681             in
 682             if is_nullary_con then  -- skip the showParen junk...
 683                 ASSERT(null bs_needed)
 684                 ([a_Pat, con_pat], show_con)
 685             else
 686                 ([a_Pat, con_pat],
 687                     showParen_Expr (OpApp a_Expr (Var ge_PN) (Lit (IntLit 10)))
 688                                    (nested_compose_Expr show_thingies))
 689           where
 690             spacified []     = []
 691             spacified [x]    = [x]
 692             spacified (x:xs) = (x : (Var showSpace_PN) : spacified xs)
 693
 694     -----------------------------------------------------------------------
 695     reads_prec  -- ignore the infix game altogether
 696       = let
 697             read_con_comprehensions
 698               = map read_con (getTyConDataCons tycon)
 699         in
 700         mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
 701               foldl1 append_Expr read_con_comprehensions
 702         )
 703       where
 704         read_con data_con   -- note: "b" is the string being "read"
 705           = let
 706                 data_con_PN = Prel (WiredInVal data_con)
 707                 data_con_str= snd  (getOrigName data_con)
 708                 as_needed   = take (getDataConArity data_con) as_PNs
 709                 bs_needed   = take (getDataConArity data_con) bs_PNs
 710                 con_expr    = foldl App (Var data_con_PN) (map Var as_needed)
 711                 is_nullary_con = isNullaryDataCon data_con
 712
 713                 con_qual
 714                   = GeneratorQual
 715                       (TuplePatIn [LitPatIn (StringLit data_con_str), d_Pat])
 716                       (App (Var lex_PN) c_Expr)
 717
 718                 field_quals = snd (mapAccumL mk_qual d_Expr (as_needed `zip` bs_needed))
 719
 720                 read_paren_arg
 721                   = if is_nullary_con then -- must be False (parens are surely optional)
 722                        false_Expr
 723                     else -- parens depend on precedence...
 724                        OpApp a_Expr (Var gt_PN) (Lit (IntLit 9))
 725             in
 726             App (
 727               readParen_Expr read_paren_arg (
 728                  Lam (mk_easy_Match [c_Pat] []  (
 729                    ListComp (ExplicitTuple [con_expr,
 730                             if null bs_needed then d_Expr else Var (last bs_needed)])
 731                     (con_qual : field_quals)))
 732             )) (Var b_PN)
 733           where
 734             mk_qual draw_from (con_field, str_left)
 735               = (Var str_left,  -- what to draw from down the line...
 736                  GeneratorQual
 737                   (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
 738                   (App (App (Var readsPrec_PN) (Lit (IntLit 10))) draw_from))
 739 \end{code}
 740
 741 %************************************************************************
 742 %*                                                                      *
 743 \subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations}
 744 %*                                                                      *
 745 %************************************************************************
 746
 747 ToDo: NOT DONE YET.
 748
 749 \begin{code}
 750 gen_Binary_binds :: TyCon -> ProtoNameMonoBinds
 751
 752 gen_Binary_binds tycon
 753   = panic "gen_Binary_binds"
 754 \end{code}
 755
 756 %************************************************************************
 757 %*                                                                      *
 758 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
 759 %*                                                                      *
 760 %************************************************************************
 761
 762 \begin{verbatim}
 763 data Foo ... = ...
 764
 765 con2tag_Foo :: Foo ... -> Int#
 766 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 767 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 768 \end{verbatim}
 769
 770 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 771 fiddling around.
 772
 773 \begin{code}
 774 gen_tag_n_con_monobind
 775     :: (ProtoName, Name,    -- (proto)Name for the thing in question
 776         TyCon,              -- tycon in question
 777         TagThingWanted)
 778     -> ProtoNameMonoBinds
 779
 780 gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
 781   = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
 782   where
 783     mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
 784
 785     mk_stuff var
 786       = ASSERT(isDataCon var)
 787         ([pat], Lit (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG))))
 788       where
 789         pat    = ConPatIn var_PN (nOfThem (getDataConArity var) WildPatIn)
 790         var_PN = Prel (WiredInVal var)
 791
 792 gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
 793   = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
 794   where
 795     mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
 796
 797     mk_stuff var
 798       = ASSERT(isDataCon var)
 799         ([lit_pat], Var var_PN)
 800       where
 801         lit_pat = ConPatIn mkInt_PN [LitPatIn (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG)))]
 802         var_PN  = Prel (WiredInVal var)
 803
 804 gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
 805   = mk_easy_FunMonoBind pn [] [] (App (Var mkInt_PN) (Lit (IntPrimLit max_tag)))
 806   where
 807     max_tag =  case (getTyConDataCons tycon) of
 808                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 809 \end{code}
 810
 811 %************************************************************************
 812 %*                                                                      *
 813 \subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings}
 814 %*                                                                      *
 815 %************************************************************************
 816
 817 @mk_easy_FunMonoBind fun pats binds expr@ generates:
 818 \begin{verbatim}
 819     fun pat1 pat2 ... patN = expr where binds
 820 \end{verbatim}
 821
 822 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
 823 multi-clause definitions; it generates:
 824 \begin{verbatim}
 825     fun p1a p1b ... p1N = e1
 826     fun p2a p2b ... p2N = e2
 827     ...
 828     fun pMa pMb ... pMN = eM
 829 \end{verbatim}
 830
 831 \begin{code}
 832 mk_easy_FunMonoBind :: ProtoName -> [ProtoNamePat]
 833                     -> [ProtoNameMonoBinds] -> ProtoNameExpr
 834                     -> ProtoNameMonoBinds
 835
 836 mk_easy_FunMonoBind fun pats binds expr
 837   = FunMonoBind fun [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
 838
 839 mk_easy_Match pats binds expr
 840   = foldr PatMatch
 841           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
 842           pats
 843   where
 844     mkbind [] = EmptyBinds
 845     mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
 846         -- The renamer expects everything in its input to be a
 847         -- "recursive" MonoBinds, and it is its job to sort things out
 848         -- from there.
 849
 850 mk_FunMonoBind  :: ProtoName
 851                 -> [([ProtoNamePat], ProtoNameExpr)]
 852                 -> ProtoNameMonoBinds
 853
 854 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
 855 mk_FunMonoBind fun pats_and_exprs
 856   = FunMonoBind fun (map mk_match pats_and_exprs) mkGeneratedSrcLoc
 857   where
 858     mk_match (pats, expr)
 859       = foldr PatMatch
 860                 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds))
 861                 pats
 862 \end{code}
 863
 864 \begin{code}
 865 tagCmp_Case, cmp_eq_Expr ::
 866           ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 867           -> ProtoNameExpr -> ProtoNameExpr
 868           -> ProtoNameExpr
 869 tagCmp_gen_Case ::
 870           ProtoName
 871           -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 872           -> ProtoNameExpr -> ProtoNameExpr
 873           -> ProtoNameExpr
 874 careful_tagCmp_Case :: -- checks for primitive types...
 875           UniType
 876           -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 877           -> ProtoNameExpr -> ProtoNameExpr
 878           -> ProtoNameExpr
 879
 880 tagCmp_Case = tagCmp_gen_Case tagCmp_PN
 881 cmp_eq_Expr = tagCmp_gen_Case cmp_eq_PN
 882
 883 tagCmp_gen_Case fun lt eq gt a b
 884   = Case (App (App (Var fun) a) b) {-of-}
 885       [PatMatch (ConPatIn lt_TAG_PN [])
 886           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
 887
 888        PatMatch (ConPatIn eq_TAG_PN [])
 889           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
 890
 891        PatMatch (ConPatIn gt_TAG_PN [])
 892           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
 893
 894 careful_tagCmp_Case ty lt eq gt a b
 895   = if not (isPrimType ty) then
 896        tagCmp_gen_Case tagCmp_PN lt eq gt a b
 897
 898     else -- we have to do something special for primitive things...
 899        If (OpApp a (Var relevant_eq_op) b)
 900           eq
 901           (If (OpApp a (Var relevant_lt_op) b) lt gt)
 902   where
 903     relevant_eq_op = assoc "careful_tagCmp_Case" eq_op_tbl ty
 904     relevant_lt_op = assoc "careful_tagCmp_Case" lt_op_tbl ty
 905
 906 eq_op_tbl = [
 907     (charPrimTy,        Prel (WiredInVal (primOpId CharEqOp))),
 908     (intPrimTy,         Prel (WiredInVal (primOpId IntEqOp))),
 909     (wordPrimTy,        Prel (WiredInVal (primOpId WordEqOp))),
 910     (addrPrimTy,        Prel (WiredInVal (primOpId AddrEqOp))),
 911     (floatPrimTy,       Prel (WiredInVal (primOpId FloatEqOp))),
 912     (doublePrimTy,      Prel (WiredInVal (primOpId DoubleEqOp))) ]
 913
 914 lt_op_tbl = [
 915     (charPrimTy,        Prel (WiredInVal (primOpId CharLtOp))),
 916     (intPrimTy,         Prel (WiredInVal (primOpId IntLtOp))),
 917     (wordPrimTy,        Prel (WiredInVal (primOpId WordLtOp))),
 918     (addrPrimTy,        Prel (WiredInVal (primOpId AddrLtOp))),
 919     (floatPrimTy,       Prel (WiredInVal (primOpId FloatLtOp))),
 920     (doublePrimTy,      Prel (WiredInVal (primOpId DoubleLtOp))) ]
 921
 922 -----------------------------------------------------------------------
 923
 924 and_Expr, append_Expr :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 925
 926 and_Expr    a b = OpApp a (Var and_PN)    b
 927 append_Expr a b = OpApp a (Var append_PN) b
 928
 929 -----------------------------------------------------------------------
 930
 931 eq_Expr  :: UniType -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 932 eq_Expr ty a b
 933   = if not (isPrimType ty) then
 934        OpApp a (Var eq_PN)  b
 935     else -- we have to do something special for primitive things...
 936        OpApp a (Var relevant_eq_op) b
 937   where
 938     relevant_eq_op = assoc "eq_Expr" eq_op_tbl ty
 939 \end{code}
 940
 941 \begin{code}
 942 untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameExpr -> ProtoNameExpr
 943 untag_Expr tycon [] expr = expr
 944 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
 945   = Case (App (con2tag_Expr tycon) (Var untag_this)) {-of-}
 946       [PatMatch (VarPatIn put_tag_here)
 947                         (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
 948   where
 949     grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
 950
 951 cmp_tags_Expr :: ProtoName                      -- Comparison op
 952              -> ProtoName -> ProtoName          -- Things to compare
 953              -> ProtoNameExpr                   -- What to return if true
 954              -> ProtoNameExpr                   -- What to return if false
 955              -> ProtoNameExpr
 956
 957 cmp_tags_Expr op a b true_case false_case
 958   = If (OpApp (Var a) (Var op) (Var b)) true_case false_case
 959
 960 enum_from_to_Expr
 961         :: ProtoNameExpr -> ProtoNameExpr
 962         -> ProtoNameExpr
 963 enum_from_then_to_Expr
 964         :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 965         -> ProtoNameExpr
 966
 967 enum_from_to_Expr      f   t2 = App (App (Var enumFromTo_PN) f) t2
 968 enum_from_then_to_Expr f t t2 = App (App (App (Var enumFromThenTo_PN) f) t) t2
 969
 970 showParen_Expr, readParen_Expr
 971         :: ProtoNameExpr -> ProtoNameExpr
 972         -> ProtoNameExpr
 973
 974 showParen_Expr e1 e2 = App (App (Var showParen_PN) e1) e2
 975 readParen_Expr e1 e2 = App (App (Var readParen_PN) e1) e2
 976
 977 nested_compose_Expr :: [ProtoNameExpr] -> ProtoNameExpr
 978
 979 nested_compose_Expr [e] = e
 980 nested_compose_Expr (e:es)
 981   = App (App (Var compose_PN) e) (nested_compose_Expr es)
 982 \end{code}
 983
 984 \begin{code}
 985 a_PN            = Unk SLIT("a")
 986 b_PN            = Unk SLIT("b")
 987 c_PN            = Unk SLIT("c")
 988 d_PN            = Unk SLIT("d")
 989 ah_PN           = Unk SLIT("a#")
 990 bh_PN           = Unk SLIT("b#")
 991 ch_PN           = Unk SLIT("c#")
 992 dh_PN           = Unk SLIT("d#")
 993 cmp_eq_PN       = Unk SLIT("cmp_eq")
 994 rangeSize_PN    = Unk SLIT("rangeSize")
 995
 996 as_PNs          = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
 997 bs_PNs          = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
 998 cs_PNs          = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
 999
1000 eq_PN           = prelude_method SLIT("Eq")  SLIT("==")
1001 ne_PN           = prelude_method SLIT("Eq")  SLIT("/=")
1002 le_PN           = prelude_method SLIT("Ord") SLIT("<=")
1003 lt_PN           = prelude_method SLIT("Ord") SLIT("<")
1004 ge_PN           = prelude_method SLIT("Ord") SLIT(">=")
1005 gt_PN           = prelude_method SLIT("Ord") SLIT(">")
1006 max_PN          = prelude_method SLIT("Ord") SLIT("max")
1007 min_PN          = prelude_method SLIT("Ord") SLIT("min")
1008 tagCmp_PN       = prelude_method SLIT("Ord") SLIT("_tagCmp")
1009 lt_TAG_PN       = Prel (WiredInVal ltPrimDataCon)
1010 eq_TAG_PN       = Prel (WiredInVal eqPrimDataCon)
1011 gt_TAG_PN       = Prel (WiredInVal gtPrimDataCon)
1012 enumFrom_PN      = prelude_method SLIT("Enum") SLIT("enumFrom")
1013 enumFromTo_PN    = prelude_method SLIT("Enum") SLIT("enumFromTo")
1014 enumFromThen_PN  = prelude_method SLIT("Enum") SLIT("enumFromThen")
1015 enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
1016 range_PN         = prelude_method SLIT("Ix")   SLIT("range")
1017 index_PN         = prelude_method SLIT("Ix")   SLIT("index")
1018 inRange_PN       = prelude_method SLIT("Ix")   SLIT("inRange")
1019 readsPrec_PN     = prelude_method SLIT("Text") SLIT("readsPrec")
1020 showsPrec_PN     = prelude_method SLIT("Text") SLIT("showsPrec")
1021 plus_PN          = prelude_method SLIT("Num")  SLIT("+")
1022 times_PN         = prelude_method SLIT("Num")  SLIT("*")
1023
1024 false_PN        = Prel (WiredInVal falseDataCon)
1025 true_PN         = Prel (WiredInVal trueDataCon)
1026 eqH_PN          = Prel (WiredInVal (primOpId IntEqOp))
1027 geH_PN          = Prel (WiredInVal (primOpId IntGeOp))
1028 leH_PN          = Prel (WiredInVal (primOpId IntLeOp))
1029 ltH_PN          = Prel (WiredInVal (primOpId IntLtOp))
1030 minusH_PN       = Prel (WiredInVal (primOpId IntSubOp))
1031 and_PN          = prelude_val pRELUDE     SLIT("&&")
1032 not_PN          = prelude_val pRELUDE     SLIT("not")
1033 append_PN       = prelude_val pRELUDE_LIST SLIT("++")
1034 map_PN          = prelude_val pRELUDE_LIST SLIT("map")
1035 compose_PN      = prelude_val pRELUDE     SLIT(".")
1036 mkInt_PN        = Prel (WiredInVal intDataCon)
1037 error_PN        = Prel (WiredInVal eRROR_ID)
1038 showSpace_PN    = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std
1039 showString_PN   = prelude_val pRELUDE_TEXT SLIT("showString")
1040 showParen_PN    = prelude_val pRELUDE_TEXT SLIT("showParen")
1041 readParen_PN    = prelude_val pRELUDE_TEXT SLIT("readParen")
1042 lex_PN          = prelude_val pRELUDE_TEXT SLIT("lex")
1043
1044 prelude_val    m s = Imp m s [m] s
1045 prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used...
1046
1047 a_Expr          = Var a_PN
1048 b_Expr          = Var b_PN
1049 c_Expr          = Var c_PN
1050 d_Expr          = Var d_PN
1051 lt_TAG_Expr     = Var lt_TAG_PN
1052 eq_TAG_Expr     = Var eq_TAG_PN
1053 gt_TAG_Expr     = Var gt_TAG_PN
1054 false_Expr      = Var false_PN
1055 true_Expr       = Var true_PN
1056
1057 con2tag_Expr tycon = Var (con2tag_PN tycon)
1058
1059 a_Pat           = VarPatIn a_PN
1060 b_Pat           = VarPatIn b_PN
1061 c_Pat           = VarPatIn c_PN
1062 d_Pat           = VarPatIn d_PN
1063 \end{code}
1064
1065 %************************************************************************
1066 %*                                                                      *
1067 \subsection[TcGenDeriv-misc-utils]{Miscellaneous utility bits for deriving}
1068 %*                                                                      *
1069 %************************************************************************
1070
1071 \begin{code}
1072 {- UNUSED:
1073 hasCon2TagFun :: TyCon -> Bool
1074 hasCon2TagFun tycon
1075   =  preludeClassDerivedFor ordClassKey tycon
1076   || isEnumerationTyConMostly tycon
1077
1078 hasTag2ConFun :: TyCon -> Bool
1079 hasTag2ConFun tycon
1080   =  isEnumerationTyCon tycon
1081   && (preludeClassDerivedFor ixClassKey   tycon
1082    || preludeClassDerivedFor enumClassKey tycon)
1083 -}
1084 \end{code}