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
 669                 show_con
 670                   = let (mod, nm)   = getOrigName data_con
 671                         space_maybe = if isNullaryDataCon data_con then _NIL_ else SLIT(" ")
 672                     in
 673                         App (Var showString_PN) (Lit (StringLit (nm _APPEND_ space_maybe)))
 674
 675                 show_thingies = show_con : (spacified real_show_thingies)
 676
 677                 real_show_thingies
 678                   = [ App (App (Var showsPrec_PN) (Lit (IntLit 10))) (Var b)
 679                   | b <- bs_needed ]
 680             in
 681             ([a_Pat, con_pat],
 682                 showParen_Expr (OpApp a_Expr (Var ge_PN) (Lit (IntLit 10)))
 683                                (nested_compose_Expr show_thingies))
 684           where
 685             spacified []     = []
 686             spacified [x]    = [x]
 687             spacified (x:xs) = (x : (Var showSpace_PN) : spacified xs)
 688
 689     -----------------------------------------------------------------------
 690     reads_prec  -- ignore the infix game altogether
 691       = let
 692             read_con_comprehensions
 693               = map read_con (getTyConDataCons tycon)
 694         in
 695         mk_easy_FunMonoBind readsPrec_PN [a_Pat] [] (
 696            readParen_Expr (OpApp a_Expr (Var gt_PN) (Lit (IntLit 9))) (
 697            Lam (mk_easy_Match [b_Pat] []  (
 698               foldl1 append_Expr read_con_comprehensions
 699         ))))
 700       where
 701         read_con data_con   -- note: "b" is the string being "read"
 702           = let
 703                 data_con_PN = Prel (WiredInVal data_con)
 704                 data_con_str= snd  (getOrigName data_con)
 705                 as_needed   = take (getDataConArity data_con) as_PNs
 706                 bs_needed   = take (getDataConArity data_con) bs_PNs
 707                 con_expr    = foldl App (Var data_con_PN) (map Var as_needed)
 708
 709                 con_qual
 710                   = GeneratorQual
 711                       (TuplePatIn [LitPatIn (StringLit data_con_str), c_Pat])
 712                       (App (Var lex_PN) b_Expr)
 713
 714                 field_quals = snd (mapAccumL mk_qual c_Expr (as_needed `zip` bs_needed))
 715             in
 716             ListComp (ExplicitTuple [con_expr,
 717                         if null bs_needed then c_Expr else Var (last bs_needed)])
 718               (con_qual : field_quals)
 719           where
 720             mk_qual draw_from (con_field, str_left)
 721               = (Var str_left,  -- what to draw from down the line...
 722                  GeneratorQual
 723                   (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
 724                   (App (App (Var readsPrec_PN) (Lit (IntLit 10))) draw_from))
 725 \end{code}
 726
 727 %************************************************************************
 728 %*                                                                      *
 729 \subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations}
 730 %*                                                                      *
 731 %************************************************************************
 732
 733 ToDo: NOT DONE YET.
 734
 735 \begin{code}
 736 gen_Binary_binds :: TyCon -> ProtoNameMonoBinds
 737
 738 gen_Binary_binds tycon
 739   = panic "gen_Binary_binds"
 740 \end{code}
 741
 742 %************************************************************************
 743 %*                                                                      *
 744 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
 745 %*                                                                      *
 746 %************************************************************************
 747
 748 \begin{verbatim}
 749 data Foo ... = ...
 750
 751 con2tag_Foo :: Foo ... -> Int#
 752 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 753 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 754 \end{verbatim}
 755
 756 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 757 fiddling around.
 758
 759 \begin{code}
 760 gen_tag_n_con_monobind
 761     :: (ProtoName, Name,    -- (proto)Name for the thing in question
 762         TyCon,              -- tycon in question
 763         TagThingWanted)
 764     -> ProtoNameMonoBinds
 765
 766 gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
 767   = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
 768   where
 769     mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
 770
 771     mk_stuff var
 772       = ASSERT(isDataCon var)
 773         ([pat], Lit (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG))))
 774       where
 775         pat    = ConPatIn var_PN (nOfThem (getDataConArity var) WildPatIn)
 776         var_PN = Prel (WiredInVal var)
 777
 778 gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
 779   = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
 780   where
 781     mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
 782
 783     mk_stuff var
 784       = ASSERT(isDataCon var)
 785         ([lit_pat], Var var_PN)
 786       where
 787         lit_pat = ConPatIn mkInt_PN [LitPatIn (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG)))]
 788         var_PN  = Prel (WiredInVal var)
 789
 790 gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
 791   = mk_easy_FunMonoBind pn [] [] (App (Var mkInt_PN) (Lit (IntPrimLit max_tag)))
 792   where
 793     max_tag =  case (getTyConDataCons tycon) of
 794                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 795 \end{code}
 796
 797 %************************************************************************
 798 %*                                                                      *
 799 \subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings}
 800 %*                                                                      *
 801 %************************************************************************
 802
 803 @mk_easy_FunMonoBind fun pats binds expr@ generates:
 804 \begin{verbatim}
 805     fun pat1 pat2 ... patN = expr where binds
 806 \end{verbatim}
 807
 808 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
 809 multi-clause definitions; it generates:
 810 \begin{verbatim}
 811     fun p1a p1b ... p1N = e1
 812     fun p2a p2b ... p2N = e2
 813     ...
 814     fun pMa pMb ... pMN = eM
 815 \end{verbatim}
 816
 817 \begin{code}
 818 mk_easy_FunMonoBind :: ProtoName -> [ProtoNamePat]
 819                     -> [ProtoNameMonoBinds] -> ProtoNameExpr
 820                     -> ProtoNameMonoBinds
 821
 822 mk_easy_FunMonoBind fun pats binds expr
 823   = FunMonoBind fun [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
 824
 825 mk_easy_Match pats binds expr
 826   = foldr PatMatch
 827           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
 828           pats
 829   where
 830     mkbind [] = EmptyBinds
 831     mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
 832         -- The renamer expects everything in its input to be a
 833         -- "recursive" MonoBinds, and it is its job to sort things out
 834         -- from there.
 835
 836 mk_FunMonoBind  :: ProtoName
 837                 -> [([ProtoNamePat], ProtoNameExpr)]
 838                 -> ProtoNameMonoBinds
 839
 840 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
 841 mk_FunMonoBind fun pats_and_exprs
 842   = FunMonoBind fun (map mk_match pats_and_exprs) mkGeneratedSrcLoc
 843   where
 844     mk_match (pats, expr)
 845       = foldr PatMatch
 846                 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds))
 847                 pats
 848 \end{code}
 849
 850 \begin{code}
 851 tagCmp_Case, cmp_eq_Expr ::
 852           ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 853           -> ProtoNameExpr -> ProtoNameExpr
 854           -> ProtoNameExpr
 855 tagCmp_gen_Case ::
 856           ProtoName
 857           -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 858           -> ProtoNameExpr -> ProtoNameExpr
 859           -> ProtoNameExpr
 860 careful_tagCmp_Case :: -- checks for primitive types...
 861           UniType
 862           -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 863           -> ProtoNameExpr -> ProtoNameExpr
 864           -> ProtoNameExpr
 865
 866 tagCmp_Case = tagCmp_gen_Case tagCmp_PN
 867 cmp_eq_Expr = tagCmp_gen_Case cmp_eq_PN
 868
 869 tagCmp_gen_Case fun lt eq gt a b
 870   = Case (App (App (Var fun) a) b) {-of-}
 871       [PatMatch (ConPatIn lt_TAG_PN [])
 872           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
 873
 874        PatMatch (ConPatIn eq_TAG_PN [])
 875           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
 876
 877        PatMatch (ConPatIn gt_TAG_PN [])
 878           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
 879
 880 careful_tagCmp_Case ty lt eq gt a b
 881   = if not (isPrimType ty) then
 882        tagCmp_gen_Case tagCmp_PN lt eq gt a b
 883
 884     else -- we have to do something special for primitive things...
 885        If (OpApp a (Var relevant_eq_op) b)
 886           eq
 887           (If (OpApp a (Var relevant_lt_op) b) lt gt)
 888   where
 889     relevant_eq_op = assoc "careful_tagCmp_Case" eq_op_tbl ty
 890     relevant_lt_op = assoc "careful_tagCmp_Case" lt_op_tbl ty
 891
 892 eq_op_tbl = [
 893     (charPrimTy,        Prel (WiredInVal (primOpId CharEqOp))),
 894     (intPrimTy,         Prel (WiredInVal (primOpId IntEqOp))),
 895     (wordPrimTy,        Prel (WiredInVal (primOpId WordEqOp))),
 896     (addrPrimTy,        Prel (WiredInVal (primOpId AddrEqOp))),
 897     (floatPrimTy,       Prel (WiredInVal (primOpId FloatEqOp))),
 898     (doublePrimTy,      Prel (WiredInVal (primOpId DoubleEqOp))) ]
 899
 900 lt_op_tbl = [
 901     (charPrimTy,        Prel (WiredInVal (primOpId CharLtOp))),
 902     (intPrimTy,         Prel (WiredInVal (primOpId IntLtOp))),
 903     (wordPrimTy,        Prel (WiredInVal (primOpId WordLtOp))),
 904     (addrPrimTy,        Prel (WiredInVal (primOpId AddrLtOp))),
 905     (floatPrimTy,       Prel (WiredInVal (primOpId FloatLtOp))),
 906     (doublePrimTy,      Prel (WiredInVal (primOpId DoubleLtOp))) ]
 907
 908 -----------------------------------------------------------------------
 909
 910 and_Expr, append_Expr :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 911
 912 and_Expr    a b = OpApp a (Var and_PN)    b
 913 append_Expr a b = OpApp a (Var append_PN) b
 914
 915 -----------------------------------------------------------------------
 916
 917 eq_Expr  :: UniType -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 918 eq_Expr ty a b
 919   = if not (isPrimType ty) then
 920        OpApp a (Var eq_PN)  b
 921     else -- we have to do something special for primitive things...
 922        OpApp a (Var relevant_eq_op) b
 923   where
 924     relevant_eq_op = assoc "eq_Expr" eq_op_tbl ty
 925 \end{code}
 926
 927 \begin{code}
 928 untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameExpr -> ProtoNameExpr
 929 untag_Expr tycon [] expr = expr
 930 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
 931   = Case (App (con2tag_Expr tycon) (Var untag_this)) {-of-}
 932       [PatMatch (VarPatIn put_tag_here)
 933                         (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
 934   where
 935     grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
 936
 937 cmp_tags_Expr :: ProtoName                      -- Comparison op
 938              -> ProtoName -> ProtoName          -- Things to compare
 939              -> ProtoNameExpr                   -- What to return if true
 940              -> ProtoNameExpr                   -- What to return if false
 941              -> ProtoNameExpr
 942
 943 cmp_tags_Expr op a b true_case false_case
 944   = If (OpApp (Var a) (Var op) (Var b)) true_case false_case
 945
 946 enum_from_to_Expr
 947         :: ProtoNameExpr -> ProtoNameExpr
 948         -> ProtoNameExpr
 949 enum_from_then_to_Expr
 950         :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
 951         -> ProtoNameExpr
 952
 953 enum_from_to_Expr      f   t2 = App (App (Var enumFromTo_PN) f) t2
 954 enum_from_then_to_Expr f t t2 = App (App (App (Var enumFromThenTo_PN) f) t) t2
 955
 956 showParen_Expr, readParen_Expr
 957         :: ProtoNameExpr -> ProtoNameExpr
 958         -> ProtoNameExpr
 959
 960 showParen_Expr e1 e2 = App (App (Var showParen_PN) e1) e2
 961 readParen_Expr e1 e2 = App (App (Var readParen_PN) e1) e2
 962
 963 nested_compose_Expr :: [ProtoNameExpr] -> ProtoNameExpr
 964
 965 nested_compose_Expr [e] = e
 966 nested_compose_Expr (e:es)
 967   = App (App (Var compose_PN) e) (nested_compose_Expr es)
 968 \end{code}
 969
 970 \begin{code}
 971 a_PN            = Unk SLIT("a")
 972 b_PN            = Unk SLIT("b")
 973 c_PN            = Unk SLIT("c")
 974 d_PN            = Unk SLIT("d")
 975 ah_PN           = Unk SLIT("a#")
 976 bh_PN           = Unk SLIT("b#")
 977 ch_PN           = Unk SLIT("c#")
 978 dh_PN           = Unk SLIT("d#")
 979 cmp_eq_PN       = Unk SLIT("cmp_eq")
 980 rangeSize_PN    = Unk SLIT("rangeSize")
 981
 982 as_PNs          = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
 983 bs_PNs          = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
 984 cs_PNs          = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
 985
 986 eq_PN           = prelude_method SLIT("Eq")  SLIT("==")
 987 ne_PN           = prelude_method SLIT("Eq")  SLIT("/=")
 988 le_PN           = prelude_method SLIT("Ord") SLIT("<=")
 989 lt_PN           = prelude_method SLIT("Ord") SLIT("<")
 990 ge_PN           = prelude_method SLIT("Ord") SLIT(">=")
 991 gt_PN           = prelude_method SLIT("Ord") SLIT(">")
 992 max_PN          = prelude_method SLIT("Ord") SLIT("max")
 993 min_PN          = prelude_method SLIT("Ord") SLIT("min")
 994 tagCmp_PN       = prelude_method SLIT("Ord") SLIT("_tagCmp")
 995 lt_TAG_PN       = Prel (WiredInVal ltPrimDataCon)
 996 eq_TAG_PN       = Prel (WiredInVal eqPrimDataCon)
 997 gt_TAG_PN       = Prel (WiredInVal gtPrimDataCon)
 998 enumFrom_PN      = prelude_method SLIT("Enum") SLIT("enumFrom")
 999 enumFromTo_PN    = prelude_method SLIT("Enum") SLIT("enumFromTo")
1000 enumFromThen_PN  = prelude_method SLIT("Enum") SLIT("enumFromThen")
1001 enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
1002 range_PN         = prelude_method SLIT("Ix")   SLIT("range")
1003 index_PN         = prelude_method SLIT("Ix")   SLIT("index")
1004 inRange_PN       = prelude_method SLIT("Ix")   SLIT("inRange")
1005 readsPrec_PN     = prelude_method SLIT("Text") SLIT("readsPrec")
1006 showsPrec_PN     = prelude_method SLIT("Text") SLIT("showsPrec")
1007 plus_PN          = prelude_method SLIT("Num")  SLIT("+")
1008 times_PN         = prelude_method SLIT("Num")  SLIT("*")
1009
1010 false_PN        = Prel (WiredInVal falseDataCon)
1011 true_PN         = Prel (WiredInVal trueDataCon)
1012 eqH_PN          = Prel (WiredInVal (primOpId IntEqOp))
1013 geH_PN          = Prel (WiredInVal (primOpId IntGeOp))
1014 leH_PN          = Prel (WiredInVal (primOpId IntLeOp))
1015 ltH_PN          = Prel (WiredInVal (primOpId IntLtOp))
1016 minusH_PN       = Prel (WiredInVal (primOpId IntSubOp))
1017 and_PN          = prelude_val pRELUDE     SLIT("&&")
1018 not_PN          = prelude_val pRELUDE     SLIT("not")
1019 append_PN       = prelude_val pRELUDE_LIST SLIT("++")
1020 map_PN          = prelude_val pRELUDE_LIST SLIT("map")
1021 compose_PN      = prelude_val pRELUDE     SLIT(".")
1022 mkInt_PN        = Prel (WiredInVal intDataCon)
1023 error_PN        = Prel (WiredInVal eRROR_ID)
1024 showSpace_PN    = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std
1025 showString_PN   = prelude_val pRELUDE_TEXT SLIT("showString")
1026 showParen_PN    = prelude_val pRELUDE_TEXT SLIT("showParen")
1027 readParen_PN    = prelude_val pRELUDE_TEXT SLIT("readParen")
1028 lex_PN          = prelude_val pRELUDE_TEXT SLIT("lex")
1029
1030 prelude_val    m s = Imp m s [m] s
1031 prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used...
1032
1033 a_Expr          = Var a_PN
1034 b_Expr          = Var b_PN
1035 c_Expr          = Var c_PN
1036 d_Expr          = Var d_PN
1037 lt_TAG_Expr     = Var lt_TAG_PN
1038 eq_TAG_Expr     = Var eq_TAG_PN
1039 gt_TAG_Expr     = Var gt_TAG_PN
1040 false_Expr      = Var false_PN
1041 true_Expr       = Var true_PN
1042
1043 con2tag_Expr tycon = Var (con2tag_PN tycon)
1044
1045 a_Pat           = VarPatIn a_PN
1046 b_Pat           = VarPatIn b_PN
1047 c_Pat           = VarPatIn c_PN
1048 d_Pat           = VarPatIn d_PN
1049 \end{code}
1050
1051 %************************************************************************
1052 %*                                                                      *
1053 \subsection[TcGenDeriv-misc-utils]{Miscellaneous utility bits for deriving}
1054 %*                                                                      *
1055 %************************************************************************
1056
1057 \begin{code}
1058 {- UNUSED:
1059 hasCon2TagFun :: TyCon -> Bool
1060 hasCon2TagFun tycon
1061   =  preludeClassDerivedFor ordClassKey tycon
1062   || isEnumerationTyConMostly tycon
1063
1064 hasTag2ConFun :: TyCon -> Bool
1065 hasTag2ConFun tycon
1066   =  isEnumerationTyCon tycon
1067   && (preludeClassDerivedFor ixClassKey   tycon
1068    || preludeClassDerivedFor enumClassKey tycon)
1069 -}
1070 \end{code}