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         gen_Bounded_binds,
  16         gen_Enum_binds,
  17         gen_Eval_binds,
  18         gen_Eq_binds,
  19         gen_Ix_binds,
  20         gen_Ord_binds,
  21         gen_Read_binds,
  22         gen_Show_binds,
  23         gen_tag_n_con_monobind,
  24
  25         con2tag_RDR, tag2con_RDR, maxtag_RDR,
  26
  27         TagThingWanted(..)
  28     ) where
  29
  30 IMP_Ubiq()
  31 IMPORT_1_3(List(partition,intersperse))
  32
  33 import HsSyn            ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
  34                           GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..),
  35                           SYN_IE(RecFlag), recursive,
  36                           ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake )
  37 import RdrHsSyn         ( RdrName(..), varQual, varUnqual, mkOpApp,
  38                           SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
  39                         )
  40 import BasicTypes       ( IfaceFlavour(..) )
  41 import FieldLabel       ( fieldLabelName )
  42 import Id               ( GenId, isNullaryDataCon, dataConTag,
  43                           dataConRawArgTys, fIRST_TAG,
  44                           isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
  45                           dataConFieldLabels, SYN_IE(Id) )
  46 import Maybes           ( maybeToBool )
  47 import Name             ( getOccString, getOccName, getSrcLoc, occNameString,
  48                           modAndOcc, OccName, Name )
  49
  50 import PrimOp           ( PrimOp(..) )
  51 import PrelInfo         -- Lots of RdrNames
  52 import SrcLoc           ( mkGeneratedSrcLoc, SrcLoc )
  53 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
  54 import Type             ( eqTy, isPrimType, SYN_IE(Type) )
  55 import TysPrim          ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
  56                           floatPrimTy, doublePrimTy
  57                         )
  58 import Util             ( mapAccumL, zipEqual, zipWithEqual,
  59                           zipWith3Equal, nOfThem, panic, assertPanic )
  60
  61
  62 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200
  63 intersperse :: a -> [a] -> [a]
  64 intersperse s []     = []
  65 intersperse s [x]    = [x]
  66 intersperse s (x:xs) = x : s : intersperse s xs
  67 #endif
  68
  69 \end{code}
  70
  71 %************************************************************************
  72 %*                                                                      *
  73 \subsection{Generating code, by derivable class}
  74 %*                                                                      *
  75 %************************************************************************
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsubsection{Generating @Eq@ instance declarations}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 Here are the heuristics for the code we generate for @Eq@:
  84 \begin{itemize}
  85 \item
  86   Let's assume we have a data type with some (possibly zero) nullary
  87   data constructors and some ordinary, non-nullary ones (the rest,
  88   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  89   and \tr{O}rdinary data cons.
  90 \begin{verbatim}
  91 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
  92 \end{verbatim}
  93
  94 \item
  95   For the ordinary constructors (if any), we emit clauses to do The
  96   Usual Thing, e.g.,:
  97
  98 \begin{verbatim}
  99 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
 100 (==) (O2 a1)       (O2 a2)       = a1 == a2
 101 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
 102 \end{verbatim}
 103
 104   Note: if we're comparing unboxed things, e.g., if \tr{a1} and
 105   \tr{a2} are \tr{Float#}s, then we have to generate
 106 \begin{verbatim}
 107 case (a1 `eqFloat#` a2) of
 108   r -> r
 109 \end{verbatim}
 110   for that particular test.
 111
 112 \item
 113   If there are any nullary constructors, we emit a catch-all clause of
 114   the form:
 115
 116 \begin{verbatim}
 117 (==) a b  = case (con2tag_Foo a) of { a# ->
 118             case (con2tag_Foo b) of { b# ->
 119             case (a# ==# b#)     of {
 120               r -> r
 121             }}}
 122 \end{verbatim}
 123
 124   If there aren't any nullary constructors, we emit a simpler
 125   catch-all:
 126 \begin{verbatim}
 127 (==) a b  = False
 128 \end{verbatim}
 129
 130 \item
 131   For the @(/=)@ method, we normally just use the default method.
 132
 133   If the type is an enumeration type, we could/may/should? generate
 134   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 135   above.
 136
 137 \item
 138   We thought about doing this: If we're also deriving @Ord@ for this
 139   tycon, we generate:
 140 \begin{verbatim}
 141 instance ... Eq (Foo ...) where
 142   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 143   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 144 \begin{verbatim}
 145   However, that requires that \tr{Ord <whatever>} was put in the context
 146   for the instance decl, which it probably wasn't, so the decls
 147   produced don't get through the typechecker.
 148 \end{itemize}
 149
 150 \begin{code}
 151 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
 152
 153 gen_Eq_binds tycon
 154   = let
 155         tycon_loc = getSrcLoc tycon
 156         (nullary_cons, nonnullary_cons)
 157            | isNewTyCon tycon = ([], tyConDataCons tycon)
 158            | otherwise        = partition isNullaryDataCon (tyConDataCons tycon)
 159
 160         rest
 161           = if (null nullary_cons) then
 162                 case maybeTyConSingleCon tycon of
 163                   Just _ -> []
 164                   Nothing -> -- if cons don't match, then False
 165                      [([a_Pat, b_Pat], false_Expr)]
 166             else -- calc. and compare the tags
 167                  [([a_Pat, b_Pat],
 168                     untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 169                       (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
 170     in
 171     mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
 172             `AndMonoBinds`
 173     mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
 174         HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
 175   where
 176     ------------------------------------------------------------------
 177     pats_etc data_con
 178       = let
 179             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
 180             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 181
 182             data_con_RDR = qual_orig_name data_con
 183             con_arity   = length tys_needed
 184             as_needed   = take con_arity as_RDRs
 185             bs_needed   = take con_arity bs_RDRs
 186             tys_needed  = dataConRawArgTys data_con
 187         in
 188         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 189       where
 190         nested_eq_expr []  [] [] = true_Expr
 191         nested_eq_expr tys as bs
 192           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 193           where
 194             nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
 195 \end{code}
 196
 197 %************************************************************************
 198 %*                                                                      *
 199 \subsubsection{Generating @Ord@ instance declarations}
 200 %*                                                                      *
 201 %************************************************************************
 202
 203 For a derived @Ord@, we concentrate our attentions on @compare@
 204 \begin{verbatim}
 205 compare :: a -> a -> Ordering
 206 data Ordering = LT | EQ | GT deriving ()
 207 \end{verbatim}
 208
 209 We will use the same example data type as above:
 210 \begin{verbatim}
 211 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 212 \end{verbatim}
 213
 214 \begin{itemize}
 215 \item
 216   We do all the other @Ord@ methods with calls to @compare@:
 217 \begin{verbatim}
 218 instance ... (Ord <wurble> <wurble>) where
 219     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 220     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 221     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 222     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 223
 224     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 225     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 226
 227     -- compare to come...
 228 \end{verbatim}
 229
 230 \item
 231   @compare@ always has two parts.  First, we use the compared
 232   data-constructors' tags to deal with the case of different
 233   constructors:
 234 \begin{verbatim}
 235 compare a b = case (con2tag_Foo a) of { a# ->
 236               case (con2tag_Foo b) of { b# ->
 237               case (a# ==# b#)     of {
 238                True  -> cmp_eq a b
 239                False -> case (a# <# b#) of
 240                          True  -> _LT
 241                          False -> _GT
 242               }}}
 243   where
 244     cmp_eq = ... to come ...
 245 \end{verbatim}
 246
 247 \item
 248   We are only left with the ``help'' function @cmp_eq@, to deal with
 249   comparing data constructors with the same tag.
 250
 251   For the ordinary constructors (if any), we emit the sorta-obvious
 252   compare-style stuff; for our example:
 253 \begin{verbatim}
 254 cmp_eq (O1 a1 b1) (O1 a2 b2)
 255   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 256
 257 cmp_eq (O2 a1) (O2 a2)
 258   = compare a1 a2
 259
 260 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 261   = case (compare a1 a2) of {
 262       LT -> LT;
 263       GT -> GT;
 264       EQ -> case compare b1 b2 of {
 265               LT -> LT;
 266               GT -> GT;
 267               EQ -> compare c1 c2
 268             }
 269     }
 270 \end{verbatim}
 271
 272   Again, we must be careful about unboxed comparisons.  For example,
 273   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 274   generate:
 275 \begin{verbatim}
 276 cmp_eq lt eq gt (O2 a1) (O2 a2)
 277   = compareInt# a1 a2
 278   -- or maybe the unfolded equivalent
 279 \end{verbatim}
 280
 281 \item
 282   For the remaining nullary constructors, we already know that the
 283   tags are equal so:
 284 \begin{verbatim}
 285 cmp_eq _ _ = EQ
 286 \end{verbatim}
 287 \end{itemize}
 288
 289 If there is only one constructor in the Data Type we don't need the WildCard Patern.
 290 JJQC-30-Nov-1997
 291
 292 \begin{code}
 293 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
 294
 295 gen_Ord_binds tycon
 296   = defaulted `AndMonoBinds` compare
 297   where
 298     tycon_loc = getSrcLoc tycon
 299     --------------------------------------------------------------------
 300     compare = mk_easy_FunMonoBind tycon_loc compare_RDR
 301                 [a_Pat, b_Pat]
 302                 [cmp_eq]
 303             (if maybeToBool (maybeTyConSingleCon tycon) then
 304                 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 305              else
 306                 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 307                   (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
 308                         -- True case; they are equal
 309                         -- If an enumeration type we are done; else
 310                         -- recursively compare their components
 311                     (if isEnumerationTyCon tycon then
 312                         eqTag_Expr
 313                      else
 314                         cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 315                     )
 316                         -- False case; they aren't equal
 317                         -- So we need to do a less-than comparison on the tags
 318                     (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
 319
 320     (nullary_cons, nonnullary_cons)
 321        | isNewTyCon tycon = ([], tyConDataCons tycon)
 322        | otherwise        = partition isNullaryDataCon (tyConDataCons tycon)
 323
 324     cmp_eq
 325       = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++
 326           if ((length nonnullary_cons + length nullary_cons) == 1)
 327             then []
 328             else [([WildPatIn, WildPatIn],
 329           default_rhs)])
 330       where
 331         pats_etc data_con
 332           = ([con1_pat, con2_pat],
 333              nested_compare_expr tys_needed as_needed bs_needed)
 334           where
 335             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
 336             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 337
 338             data_con_RDR = qual_orig_name data_con
 339             con_arity   = length tys_needed
 340             as_needed   = take con_arity as_RDRs
 341             bs_needed   = take con_arity bs_RDRs
 342             tys_needed  = dataConRawArgTys data_con
 343
 344             nested_compare_expr [ty] [a] [b]
 345               = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
 346
 347             nested_compare_expr (ty:tys) (a:as) (b:bs)
 348               = let eq_expr = nested_compare_expr tys as bs
 349                 in  careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
 350
 351         default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
 352                                                                 -- inexhaustive patterns
 353                     | otherwise         = eqTag_Expr            -- Some nullary constructors;
 354                                                                 -- Tags are equal, no args => return EQ
 355     --------------------------------------------------------------------
 356
 357 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
 358
 359 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
 360             compare_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
 361 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
 362             compare_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
 363 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
 364             compare_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
 365 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
 366             compare_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
 367
 368 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
 369             compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
 370 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
 371             compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
 372 \end{code}
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsubsection{Generating @Enum@ instance declarations}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 @Enum@ can only be derived for enumeration types.  For a type
 381 \begin{verbatim}
 382 data Foo ... = N1 | N2 | ... | Nn
 383 \end{verbatim}
 384
 385 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 386 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 387
 388 \begin{verbatim}
 389 instance ... Enum (Foo ...) where
 390     toEnum i = tag2con_Foo i
 391
 392     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 393
 394     -- or, really...
 395     enumFrom a
 396       = case con2tag_Foo a of
 397           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 398
 399    enumFromThen a b
 400      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 401
 402     -- or, really...
 403     enumFromThen a b
 404       = case con2tag_Foo a of { a# ->
 405         case con2tag_Foo b of { b# ->
 406         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 407         }}
 408 \end{verbatim}
 409
 410 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 411
 412 \begin{code}
 413 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
 414
 415 gen_Enum_binds tycon
 416   = to_enum             `AndMonoBinds`
 417     enum_from           `AndMonoBinds`
 418     enum_from_then      `AndMonoBinds`
 419     from_enum
 420   where
 421     tycon_loc = getSrcLoc tycon
 422
 423     to_enum
 424       = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
 425         mk_easy_App (tag2con_RDR tycon) [a_RDR]
 426
 427     enum_from
 428       = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
 429           untag_Expr tycon [(a_RDR, ah_RDR)] $
 430           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 431             HsPar (enum_from_to_Expr
 432                     (mk_easy_App mkInt_RDR [ah_RDR])
 433                     (HsVar (maxtag_RDR tycon)))
 434
 435     enum_from_then
 436       = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
 437           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 438           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 439             HsPar (enum_from_then_to_Expr
 440                     (mk_easy_App mkInt_RDR [ah_RDR])
 441                     (mk_easy_App mkInt_RDR [bh_RDR])
 442                     (HsVar (maxtag_RDR tycon)))
 443
 444     from_enum
 445       = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
 446           untag_Expr tycon [(a_RDR, ah_RDR)] $
 447           (mk_easy_App mkInt_RDR [ah_RDR])
 448 \end{code}
 449
 450 %************************************************************************
 451 %*                                                                      *
 452 \subsubsection{Generating @Eval@ instance declarations}
 453 %*                                                                      *
 454 %************************************************************************
 455
 456 \begin{code}
 457 gen_Eval_binds tycon = EmptyMonoBinds
 458 \end{code}
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsubsection{Generating @Bounded@ instance declarations}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 \begin{code}
 467 gen_Bounded_binds tycon
 468   = if isEnumerationTyCon tycon then
 469         min_bound_enum `AndMonoBinds` max_bound_enum
 470     else
 471         ASSERT(length data_cons == 1)
 472         min_bound_1con `AndMonoBinds` max_bound_1con
 473   where
 474     data_cons = tyConDataCons tycon
 475     tycon_loc = getSrcLoc tycon
 476
 477     ----- enum-flavored: ---------------------------
 478     min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
 479     max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
 480
 481     data_con_1    = head data_cons
 482     data_con_N    = last data_cons
 483     data_con_1_RDR = qual_orig_name data_con_1
 484     data_con_N_RDR = qual_orig_name data_con_N
 485
 486     ----- single-constructor-flavored: -------------
 487     arity          = argFieldCount data_con_1
 488
 489     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
 490                      mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
 491     max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
 492                      mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
 493 \end{code}
 494
 495 %************************************************************************
 496 %*                                                                      *
 497 \subsubsection{Generating @Ix@ instance declarations}
 498 %*                                                                      *
 499 %************************************************************************
 500
 501 Deriving @Ix@ is only possible for enumeration types and
 502 single-constructor types.  We deal with them in turn.
 503
 504 For an enumeration type, e.g.,
 505 \begin{verbatim}
 506     data Foo ... = N1 | N2 | ... | Nn
 507 \end{verbatim}
 508 things go not too differently from @Enum@:
 509 \begin{verbatim}
 510 instance ... Ix (Foo ...) where
 511     range (a, b)
 512       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 513
 514     -- or, really...
 515     range (a, b)
 516       = case (con2tag_Foo a) of { a# ->
 517         case (con2tag_Foo b) of { b# ->
 518         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 519         }}
 520
 521     index c@(a, b) d
 522       = if inRange c d
 523         then case (con2tag_Foo d -# con2tag_Foo a) of
 524                r# -> I# r#
 525         else error "Ix.Foo.index: out of range"
 526
 527     inRange (a, b) c
 528       = let
 529             p_tag = con2tag_Foo c
 530         in
 531         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 532
 533     -- or, really...
 534     inRange (a, b) c
 535       = case (con2tag_Foo a)   of { a_tag ->
 536         case (con2tag_Foo b)   of { b_tag ->
 537         case (con2tag_Foo c)   of { c_tag ->
 538         if (c_tag >=# a_tag) then
 539           c_tag <=# b_tag
 540         else
 541           False
 542         }}}
 543 \end{verbatim}
 544 (modulo suitable case-ification to handle the unboxed tags)
 545
 546 For a single-constructor type (NB: this includes all tuples), e.g.,
 547 \begin{verbatim}
 548     data Foo ... = MkFoo a b Int Double c c
 549 \end{verbatim}
 550 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 551 (p.~147).
 552
 553 \begin{code}
 554 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
 555
 556 gen_Ix_binds tycon
 557   = if isEnumerationTyCon tycon
 558     then enum_ixes
 559     else single_con_ixes
 560   where
 561     tycon_str = getOccString tycon
 562     tycon_loc = getSrcLoc tycon
 563
 564     --------------------------------------------------------------
 565     enum_ixes = enum_range `AndMonoBinds`
 566                 enum_index `AndMonoBinds` enum_inRange
 567
 568     enum_range
 569       = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
 570           untag_Expr tycon [(a_RDR, ah_RDR)] $
 571           untag_Expr tycon [(b_RDR, bh_RDR)] $
 572           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 573               HsPar (enum_from_to_Expr
 574                         (mk_easy_App mkInt_RDR [ah_RDR])
 575                         (mk_easy_App mkInt_RDR [bh_RDR]))
 576
 577     enum_index
 578       = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
 579         HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
 580            untag_Expr tycon [(a_RDR, ah_RDR)] (
 581            untag_Expr tycon [(d_RDR, dh_RDR)] (
 582            let
 583                 grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc]
 584            in
 585            HsCase
 586              (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
 587              [PatMatch (VarPatIn c_RDR)
 588                                 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
 589              tycon_loc
 590            ))
 591         ) {-else-} (
 592            HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
 593         )
 594         tycon_loc)
 595
 596     enum_inRange
 597       = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
 598           untag_Expr tycon [(a_RDR, ah_RDR)] (
 599           untag_Expr tycon [(b_RDR, bh_RDR)] (
 600           untag_Expr tycon [(c_RDR, ch_RDR)] (
 601           HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
 602              (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
 603           ) {-else-} (
 604              false_Expr
 605           ) tycon_loc))))
 606
 607     --------------------------------------------------------------
 608     single_con_ixes
 609       = single_con_range `AndMonoBinds`
 610         single_con_index `AndMonoBinds`
 611         single_con_inRange
 612
 613     data_con
 614       = case maybeTyConSingleCon tycon of -- just checking...
 615           Nothing -> panic "get_Ix_binds"
 616           Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
 617                          error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
 618                      else
 619                          dc
 620
 621     con_arity    = argFieldCount data_con
 622     data_con_RDR = qual_orig_name data_con
 623
 624     as_needed = take con_arity as_RDRs
 625     bs_needed = take con_arity bs_RDRs
 626     cs_needed = take con_arity cs_RDRs
 627
 628     con_pat  xs  = ConPatIn data_con_RDR (map VarPatIn xs)
 629     con_expr     = mk_easy_App data_con_RDR cs_needed
 630
 631     --------------------------------------------------------------
 632     single_con_range
 633       = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
 634         HsDo ListComp stmts tycon_loc
 635       where
 636         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 637                 ++
 638                 [ReturnStmt con_expr]
 639
 640         mk_qual a b c = BindStmt (VarPatIn c)
 641                                  (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
 642                                  tycon_loc
 643
 644     ----------------
 645     single_con_index
 646       = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
 647         foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
 648       where
 649         mk_index multiply_by (l, u, i)
 650           = genOpApp (
 651                 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
 652            ) plus_RDR (
 653                 genOpApp (
 654                     (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
 655                 ) times_RDR multiply_by
 656            )
 657
 658         range_size
 659           = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
 660                 genOpApp (
 661                     (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
 662                 ) plus_RDR (HsLit (HsInt 1)))
 663
 664     ------------------
 665     single_con_inRange
 666       = mk_easy_FunMonoBind tycon_loc inRange_RDR
 667                            [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
 668                            [] (
 669           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
 670       where
 671         in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
 672 \end{code}
 673
 674 %************************************************************************
 675 %*                                                                      *
 676 \subsubsection{Generating @Read@ instance declarations}
 677 %*                                                                      *
 678 %************************************************************************
 679
 680 Ignoring all the infix-ery mumbo jumbo (ToDo)
 681
 682 \begin{code}
 683 gen_Read_binds :: TyCon -> RdrNameMonoBinds
 684
 685 gen_Read_binds tycon
 686   = reads_prec `AndMonoBinds` read_list
 687   where
 688     tycon_loc = getSrcLoc tycon
 689     -----------------------------------------------------------------------
 690     read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
 691                   (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
 692     -----------------------------------------------------------------------
 693     reads_prec
 694       = let
 695             read_con_comprehensions
 696               = map read_con (tyConDataCons tycon)
 697         in
 698         mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
 699               foldr1 append_Expr read_con_comprehensions
 700         )
 701       where
 702         read_con data_con   -- note: "b" is the string being "read"
 703           = let
 704                 data_con_RDR = qual_orig_name data_con
 705                 data_con_str= occNameString (getOccName data_con)
 706                 con_arity   = argFieldCount data_con
 707                 con_expr    = mk_easy_App data_con_RDR as_needed
 708                 nullary_con = con_arity == 0
 709                 labels      = dataConFieldLabels data_con
 710                 lab_fields  = length labels
 711
 712                 as_needed   = take con_arity as_RDRs
 713                 bs_needed
 714                  | lab_fields == 0 = take con_arity bs_RDRs
 715                  | otherwise       = take (4*lab_fields + 1) bs_RDRs
 716                                        -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
 717                 con_qual
 718                   = BindStmt
 719                           (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
 720                           (HsApp (HsVar lex_RDR) c_Expr)
 721                           tycon_loc
 722
 723                 str_qual str res draw_from
 724                   = BindStmt
 725                        (TuplePatIn [LitPatIn (HsString str), VarPatIn res])
 726                        (HsApp (HsVar lex_RDR) draw_from)
 727                        tycon_loc
 728
 729                 read_label f
 730                   = let nm = occNameString (getOccName (fieldLabelName f))
 731                     in
 732                         [str_qual nm, str_qual SLIT("=")]
 733                             -- There might be spaces between the label and '='
 734
 735                 field_quals
 736                   | lab_fields == 0 =
 737                      snd (mapAccumL mk_qual
 738                                     d_Expr
 739                                     (zipWithEqual "as_needed"
 740                                                   (\ con_field draw_from -> (mk_read_qual con_field,
 741                                                                              draw_from))
 742                                                   as_needed bs_needed))
 743                   | otherwise =
 744                      snd $
 745                      mapAccumL mk_qual d_Expr
 746                         (zipEqual "bs_needed"
 747                            ((str_qual (SLIT("{")):
 748                              concat (
 749                              intersperse ([str_qual (_CONS_ ',' _NIL_)]) $
 750                              zipWithEqual
 751                                 "field_quals"
 752                                 (\ as b -> as ++ [b])
 753                                     -- The labels
 754                                 (map read_label labels)
 755                                     -- The fields
 756                                 (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))])
 757                             bs_needed)
 758
 759                 mk_qual draw_from (f, str_left)
 760                   = (HsVar str_left,    -- what to draw from down the line...
 761                      f str_left draw_from)
 762
 763                 mk_read_qual con_field res draw_from =
 764                   BindStmt
 765                    (TuplePatIn [VarPatIn con_field, VarPatIn res])
 766                    (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
 767                    tycon_loc
 768
 769                 result_expr = ExplicitTuple [con_expr, if null bs_needed
 770                                                        then d_Expr
 771                                                        else HsVar (last bs_needed)]
 772
 773                 stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
 774
 775                 read_paren_arg
 776                   = if nullary_con then -- must be False (parens are surely optional)
 777                        false_Expr
 778                     else -- parens depend on precedence...
 779                        HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
 780             in
 781             HsApp (
 782               readParen_Expr read_paren_arg $ HsPar $
 783                  HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
 784                         HsDo ListComp stmts tycon_loc)
 785               ) (HsVar b_RDR)
 786
 787 \end{code}
 788
 789 %************************************************************************
 790 %*                                                                      *
 791 \subsubsection{Generating @Show@ instance declarations}
 792 %*                                                                      *
 793 %************************************************************************
 794
 795 Ignoring all the infix-ery mumbo jumbo (ToDo)
 796
 797 \begin{code}
 798 gen_Show_binds :: TyCon -> RdrNameMonoBinds
 799
 800 gen_Show_binds tycon
 801   = shows_prec `AndMonoBinds` show_list
 802   where
 803     tycon_loc = getSrcLoc tycon
 804     -----------------------------------------------------------------------
 805     show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
 806                   (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
 807     -----------------------------------------------------------------------
 808     shows_prec
 809       = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 810       where
 811         pats_etc data_con
 812           = let
 813                 data_con_RDR = qual_orig_name data_con
 814                 con_arity    = argFieldCount data_con
 815                 bs_needed    = take con_arity bs_RDRs
 816                 con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 817                 nullary_con  = con_arity == 0
 818                 labels       = dataConFieldLabels data_con
 819                 lab_fields   = length labels
 820
 821                 show_con
 822                   = let nm = occNameString (getOccName data_con)
 823                         space_ocurly_maybe
 824                           | nullary_con     = _NIL_
 825                           | lab_fields == 0 = SLIT(" ")
 826                           | otherwise       = SLIT("{")
 827
 828                     in
 829                         mk_showString_app (nm _APPEND_ space_ocurly_maybe)
 830
 831                 show_all con fs
 832                   = let
 833                         ccurly_maybe
 834                           | lab_fields > 0  = [mk_showString_app (SLIT("}"))]
 835                           | otherwise       = []
 836                     in
 837                         con:fs ++ ccurly_maybe
 838
 839                 show_thingies = show_all show_con real_show_thingies_with_labs
 840
 841                 show_label l
 842                   = let nm = occNameString (getOccName (fieldLabelName l))
 843                     in
 844                         mk_showString_app (nm _APPEND_ SLIT("="))
 845
 846                 mk_showString_app str = HsApp (HsVar showString_RDR)
 847                                               (HsLit (HsString str))
 848
 849                 real_show_thingies =
 850                      [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
 851                      | b <- bs_needed ]
 852
 853                 real_show_thingies_with_labs
 854                  | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
 855                  | otherwise       = --Assumption: no of fields == no of labelled fields
 856                                      --            (and in same order)
 857                     concat $
 858                     intersperse ([mk_showString_app (_CONS_ ',' _NIL_ )]) $ -- Using SLIT() is not cool here.
 859                     zipWithEqual "gen_Show_binds"
 860                                  (\ a b -> [a,b])
 861                                  (map show_label labels)
 862                                  real_show_thingies
 863
 864
 865             in
 866             if nullary_con then  -- skip the showParen junk...
 867                 ASSERT(null bs_needed)
 868                 ([a_Pat, con_pat], show_con)
 869             else
 870                 ([a_Pat, con_pat],
 871                     showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
 872                                    (HsPar (nested_compose_Expr show_thingies)))
 873 \end{code}
 874
 875 %************************************************************************
 876 %*                                                                      *
 877 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
 878 %*                                                                      *
 879 %************************************************************************
 880
 881 \begin{verbatim}
 882 data Foo ... = ...
 883
 884 con2tag_Foo :: Foo ... -> Int#
 885 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 886 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 887 \end{verbatim}
 888
 889 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 890 fiddling around.
 891
 892 \begin{code}
 893 data TagThingWanted
 894   = GenCon2Tag | GenTag2Con | GenMaxTag
 895
 896 gen_tag_n_con_monobind
 897     :: (RdrName,            -- (proto)Name for the thing in question
 898         TyCon,              -- tycon in question
 899         TagThingWanted)
 900     -> RdrNameMonoBinds
 901
 902 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
 903   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
 904   where
 905     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
 906
 907     mk_stuff var
 908       = ASSERT(isDataCon var)
 909         ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
 910       where
 911         pat    = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
 912         var_RDR = qual_orig_name var
 913
 914 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
 915   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
 916                                                              [([WildPatIn], impossible_Expr)])
 917   where
 918     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
 919
 920     mk_stuff var
 921       = ASSERT(isDataCon var)
 922         ([lit_pat], HsVar var_RDR)
 923       where
 924         lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
 925         var_RDR  = qual_orig_name var
 926
 927 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
 928   = mk_easy_FunMonoBind (getSrcLoc tycon)
 929                 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
 930   where
 931     max_tag =  case (tyConDataCons tycon) of
 932                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 933
 934 \end{code}
 935
 936 %************************************************************************
 937 %*                                                                      *
 938 \subsection{Utility bits for generating bindings}
 939 %*                                                                      *
 940 %************************************************************************
 941
 942 @mk_easy_FunMonoBind fun pats binds expr@ generates:
 943 \begin{verbatim}
 944     fun pat1 pat2 ... patN = expr where binds
 945 \end{verbatim}
 946
 947 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
 948 multi-clause definitions; it generates:
 949 \begin{verbatim}
 950     fun p1a p1b ... p1N = e1
 951     fun p2a p2b ... p2N = e2
 952     ...
 953     fun pMa pMb ... pMN = eM
 954 \end{verbatim}
 955
 956 \begin{code}
 957 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
 958                     -> [RdrNameMonoBinds] -> RdrNameHsExpr
 959                     -> RdrNameMonoBinds
 960
 961 mk_easy_FunMonoBind loc fun pats binds expr
 962   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
 963
 964 mk_easy_Match loc pats binds expr
 965   = mk_match loc pats expr (mkbind binds)
 966   where
 967     mkbind [] = EmptyBinds
 968     mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] recursive
 969         -- The renamer expects everything in its input to be a
 970         -- "recursive" MonoBinds, and it is its job to sort things out
 971         -- from there.
 972
 973 mk_FunMonoBind  :: SrcLoc -> RdrName
 974                 -> [([RdrNamePat], RdrNameHsExpr)]
 975                 -> RdrNameMonoBinds
 976
 977 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
 978 mk_FunMonoBind loc fun pats_and_exprs
 979   = FunMonoBind fun False{-not infix-}
 980                 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
 981                 loc
 982
 983 mk_match loc pats expr binds
 984   = foldr PatMatch
 985           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds))
 986           (map paren pats)
 987   where
 988     paren p@(VarPatIn _) = p
 989     paren other_p        = ParPatIn other_p
 990 \end{code}
 991
 992 \begin{code}
 993 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
 994 \end{code}
 995
 996 ToDo: Better SrcLocs.
 997
 998 \begin{code}
 999 compare_Case, cmp_eq_Expr ::
1000           RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1001           -> RdrNameHsExpr -> RdrNameHsExpr
1002           -> RdrNameHsExpr
1003 compare_gen_Case ::
1004           RdrName
1005           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1006           -> RdrNameHsExpr -> RdrNameHsExpr
1007           -> RdrNameHsExpr
1008 careful_compare_Case :: -- checks for primitive types...
1009           Type
1010           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1011           -> RdrNameHsExpr -> RdrNameHsExpr
1012           -> RdrNameHsExpr
1013
1014 compare_Case = compare_gen_Case compare_RDR
1015 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
1016
1017 compare_gen_Case fun lt eq gt a b
1018   = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1019       [PatMatch (ConPatIn ltTag_RDR [])
1020           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
1021
1022        PatMatch (ConPatIn eqTag_RDR [])
1023           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
1024
1025        PatMatch (ConPatIn gtTag_RDR [])
1026           (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
1027        mkGeneratedSrcLoc
1028
1029 careful_compare_Case ty lt eq gt a b
1030   = if not (isPrimType ty) then
1031        compare_gen_Case compare_RDR lt eq gt a b
1032
1033     else -- we have to do something special for primitive things...
1034        HsIf (genOpApp a relevant_eq_op b)
1035             eq
1036             (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1037             mkGeneratedSrcLoc
1038   where
1039     relevant_eq_op = assoc_ty_id eq_op_tbl ty
1040     relevant_lt_op = assoc_ty_id lt_op_tbl ty
1041
1042 assoc_ty_id tyids ty
1043   = if null res then panic "assoc_ty"
1044     else head res
1045   where
1046     res = [id | (ty',id) <- tyids, eqTy ty ty']
1047
1048 eq_op_tbl =
1049     [(charPrimTy,       eqH_Char_RDR)
1050     ,(intPrimTy,        eqH_Int_RDR)
1051     ,(wordPrimTy,       eqH_Word_RDR)
1052     ,(addrPrimTy,       eqH_Addr_RDR)
1053     ,(floatPrimTy,      eqH_Float_RDR)
1054     ,(doublePrimTy,     eqH_Double_RDR)
1055     ]
1056
1057 lt_op_tbl =
1058     [(charPrimTy,       ltH_Char_RDR)
1059     ,(intPrimTy,        ltH_Int_RDR)
1060     ,(wordPrimTy,       ltH_Word_RDR)
1061     ,(addrPrimTy,       ltH_Addr_RDR)
1062     ,(floatPrimTy,      ltH_Float_RDR)
1063     ,(doublePrimTy,     ltH_Double_RDR)
1064     ]
1065
1066 -----------------------------------------------------------------------
1067
1068 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1069
1070 and_Expr    a b = genOpApp a and_RDR    b
1071 append_Expr a b = genOpApp a append_RDR b
1072
1073 -----------------------------------------------------------------------
1074
1075 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1076 eq_Expr ty a b
1077   = if not (isPrimType ty) then
1078        genOpApp a eq_RDR  b
1079     else -- we have to do something special for primitive things...
1080        genOpApp a relevant_eq_op b
1081   where
1082     relevant_eq_op = assoc_ty_id eq_op_tbl ty
1083 \end{code}
1084
1085 \begin{code}
1086 argFieldCount :: Id -> Int      -- Works on data and newtype constructors
1087 argFieldCount con = length (dataConRawArgTys con)
1088 \end{code}
1089
1090 \begin{code}
1091 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1092 untag_Expr tycon [] expr = expr
1093 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1094   = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1095       [PatMatch (VarPatIn put_tag_here)
1096                         (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
1097       mkGeneratedSrcLoc
1098   where
1099     grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
1100
1101 cmp_tags_Expr :: RdrName                -- Comparison op
1102              -> RdrName -> RdrName      -- Things to compare
1103              -> RdrNameHsExpr           -- What to return if true
1104              -> RdrNameHsExpr           -- What to return if false
1105              -> RdrNameHsExpr
1106
1107 cmp_tags_Expr op a b true_case false_case
1108   = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1109
1110 enum_from_to_Expr
1111         :: RdrNameHsExpr -> RdrNameHsExpr
1112         -> RdrNameHsExpr
1113 enum_from_then_to_Expr
1114         :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1115         -> RdrNameHsExpr
1116
1117 enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1118 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1119
1120 showParen_Expr, readParen_Expr
1121         :: RdrNameHsExpr -> RdrNameHsExpr
1122         -> RdrNameHsExpr
1123
1124 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1125 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1126
1127 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1128
1129 nested_compose_Expr [e] = parenify e
1130 nested_compose_Expr (e:es)
1131   = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1132
1133 -- impossible_Expr is used in case RHSs that should never happen.
1134 -- We generate these to keep the desugarer from complaining that they *might* happen!
1135 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1136
1137 parenify e@(HsVar _) = e
1138 parenify e           = HsPar e
1139
1140 -- genOpApp wraps brackets round the operator application, so that the
1141 -- renamer won't subsequently try to re-associate it.
1142 -- For some reason the renamer doesn't reassociate it right, and I can't
1143 -- be bothered to find out why just now.
1144
1145 genOpApp e1 op e2 = mkOpApp e1 op e2
1146 \end{code}
1147
1148 \begin{code}
1149 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
1150
1151 a_RDR           = varUnqual SLIT("a")
1152 b_RDR           = varUnqual SLIT("b")
1153 c_RDR           = varUnqual SLIT("c")
1154 d_RDR           = varUnqual SLIT("d")
1155 ah_RDR          = varUnqual SLIT("a#")
1156 bh_RDR          = varUnqual SLIT("b#")
1157 ch_RDR          = varUnqual SLIT("c#")
1158 dh_RDR          = varUnqual SLIT("d#")
1159 cmp_eq_RDR      = varUnqual SLIT("cmp_eq")
1160 rangeSize_RDR   = varUnqual SLIT("rangeSize")
1161
1162 as_RDRs         = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1163 bs_RDRs         = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1164 cs_RDRs         = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1165
1166 a_Expr          = HsVar a_RDR
1167 b_Expr          = HsVar b_RDR
1168 c_Expr          = HsVar c_RDR
1169 d_Expr          = HsVar d_RDR
1170 ltTag_Expr      = HsVar ltTag_RDR
1171 eqTag_Expr      = HsVar eqTag_RDR
1172 gtTag_Expr      = HsVar gtTag_RDR
1173 false_Expr      = HsVar false_RDR
1174 true_Expr       = HsVar true_RDR
1175
1176 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1177
1178 a_Pat           = VarPatIn a_RDR
1179 b_Pat           = VarPatIn b_RDR
1180 c_Pat           = VarPatIn c_RDR
1181 d_Pat           = VarPatIn d_RDR
1182
1183 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1184
1185 con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1186 tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1187 maxtag_RDR tycon  = varUnqual (SLIT("maxtag_")  _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1188 \end{code}