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