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