ghc/compiler/typecheck/TcGenDeriv.lhs

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