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