ghc/compiler/typecheck/TcGenDeriv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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_Eq_binds,
  16         gen_Ix_binds,
  17         gen_Ord_binds,
  18         gen_Read_binds,
  19         gen_Show_binds,
  20         gen_Data_binds,
  21         gen_Typeable_binds,
  22         gen_tag_n_con_monobind,
  23
  24         con2tag_RDR, tag2con_RDR, maxtag_RDR,
  25
  26         TagThingWanted(..)
  27     ) where
  28
  29 #include "HsVersions.h"
  30
  31 import HsSyn
  32 import RdrName          ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual,
  33                            mkDerivedRdrName )
  34 import BasicTypes       ( Fixity(..), maxPrecedence, Boxity(..) )
  35 import FieldLabel       ( fieldLabelName )
  36 import DataCon          ( isNullaryDataCon, dataConTag,
  37                           dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
  38                           DataCon, dataConName, dataConIsInfix,
  39                           dataConFieldLabels )
  40 import Name             ( getOccString, getSrcLoc, Name, NamedThing(..) )
  41
  42 import HscTypes         ( FixityEnv, lookupFixity )
  43 import PrelInfo
  44 import PrelNames
  45 import MkId             ( eRROR_ID )
  46 import PrimOp           ( PrimOp(..) )
  47 import SrcLoc           ( Located(..), noLoc, srcLocSpan )
  48 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity,
  49                           maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
  50                         )
  51 import TcType           ( isUnLiftedType, tcEqType, Type )
  52 import TysPrim          ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
  53                           intPrimTyCon )
  54 import TysWiredIn       ( charDataCon, intDataCon, floatDataCon, doubleDataCon,
  55                           intDataCon_RDR, true_RDR, false_RDR )
  56 import Util             ( zipWithEqual, isSingleton,
  57                           zipWith3Equal, nOfThem, zipEqual )
  58 import Char             ( isAlpha )
  59 import Constants
  60 import List             ( partition, intersperse )
  61 import Outputable
  62 import FastString
  63 import OccName
  64 import Bag
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection{Generating code, by derivable class}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsubsection{Generating @Eq@ instance declarations}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 Here are the heuristics for the code we generate for @Eq@:
  80 \begin{itemize}
  81 \item
  82   Let's assume we have a data type with some (possibly zero) nullary
  83   data constructors and some ordinary, non-nullary ones (the rest,
  84   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  85   and \tr{O}rdinary data cons.
  86 \begin{verbatim}
  87 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
  88 \end{verbatim}
  89
  90 \item
  91   For the ordinary constructors (if any), we emit clauses to do The
  92   Usual Thing, e.g.,:
  93
  94 \begin{verbatim}
  95 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
  96 (==) (O2 a1)       (O2 a2)       = a1 == a2
  97 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
  98 \end{verbatim}
  99
 100   Note: if we're comparing unlifted things, e.g., if \tr{a1} and
 101   \tr{a2} are \tr{Float#}s, then we have to generate
 102 \begin{verbatim}
 103 case (a1 `eqFloat#` a2) of
 104   r -> r
 105 \end{verbatim}
 106   for that particular test.
 107
 108 \item
 109   If there are any nullary constructors, we emit a catch-all clause of
 110   the form:
 111
 112 \begin{verbatim}
 113 (==) a b  = case (con2tag_Foo a) of { a# ->
 114             case (con2tag_Foo b) of { b# ->
 115             case (a# ==# b#)     of {
 116               r -> r
 117             }}}
 118 \end{verbatim}
 119
 120   If there aren't any nullary constructors, we emit a simpler
 121   catch-all:
 122 \begin{verbatim}
 123 (==) a b  = False
 124 \end{verbatim}
 125
 126 \item
 127   For the @(/=)@ method, we normally just use the default method.
 128
 129   If the type is an enumeration type, we could/may/should? generate
 130   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 131   above.
 132
 133 \item
 134   We thought about doing this: If we're also deriving @Ord@ for this
 135   tycon, we generate:
 136 \begin{verbatim}
 137 instance ... Eq (Foo ...) where
 138   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 139   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 140 \begin{verbatim}
 141   However, that requires that \tr{Ord <whatever>} was put in the context
 142   for the instance decl, which it probably wasn't, so the decls
 143   produced don't get through the typechecker.
 144 \end{itemize}
 145
 146
 147 \begin{code}
 148 gen_Eq_binds :: TyCon -> LHsBinds RdrName
 149
 150 gen_Eq_binds tycon
 151   = let
 152         tycon_loc = getSrcSpan tycon
 153
 154         (nullary_cons, nonnullary_cons)
 155            | isNewTyCon tycon = ([], tyConDataCons tycon)
 156            | otherwise        = partition isNullaryDataCon (tyConDataCons tycon)
 157
 158         rest
 159           = if (null nullary_cons) then
 160                 case maybeTyConSingleCon tycon of
 161                   Just _ -> []
 162                   Nothing -> -- if cons don't match, then False
 163                      [([nlWildPat, nlWildPat], false_Expr)]
 164             else -- calc. and compare the tags
 165                  [([a_Pat, b_Pat],
 166                     untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 167                                (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 168     in
 169     listToBag [
 170       mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
 171       mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag (
 172         nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
 173     ]
 174   where
 175     ------------------------------------------------------------------
 176     pats_etc data_con
 177       = let
 178             con1_pat = nlConVarPat data_con_RDR as_needed
 179             con2_pat = nlConVarPat data_con_RDR bs_needed
 180
 181             data_con_RDR = getRdrName data_con
 182             con_arity   = length tys_needed
 183             as_needed   = take con_arity as_RDRs
 184             bs_needed   = take con_arity bs_RDRs
 185             tys_needed  = dataConOrigArgTys data_con
 186         in
 187         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 188       where
 189         nested_eq_expr []  [] [] = true_Expr
 190         nested_eq_expr tys as bs
 191           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 192           where
 193             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
 194 \end{code}
 195
 196 %************************************************************************
 197 %*                                                                      *
 198 \subsubsection{Generating @Ord@ instance declarations}
 199 %*                                                                      *
 200 %************************************************************************
 201
 202 For a derived @Ord@, we concentrate our attentions on @compare@
 203 \begin{verbatim}
 204 compare :: a -> a -> Ordering
 205 data Ordering = LT | EQ | GT deriving ()
 206 \end{verbatim}
 207
 208 We will use the same example data type as above:
 209 \begin{verbatim}
 210 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 211 \end{verbatim}
 212
 213 \begin{itemize}
 214 \item
 215   We do all the other @Ord@ methods with calls to @compare@:
 216 \begin{verbatim}
 217 instance ... (Ord <wurble> <wurble>) where
 218     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 219     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 220     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 221     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 222
 223     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 224     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 225
 226     -- compare to come...
 227 \end{verbatim}
 228
 229 \item
 230   @compare@ always has two parts.  First, we use the compared
 231   data-constructors' tags to deal with the case of different
 232   constructors:
 233 \begin{verbatim}
 234 compare a b = case (con2tag_Foo a) of { a# ->
 235               case (con2tag_Foo b) of { b# ->
 236               case (a# ==# b#)     of {
 237                True  -> cmp_eq a b
 238                False -> case (a# <# b#) of
 239                          True  -> _LT
 240                          False -> _GT
 241               }}}
 242   where
 243     cmp_eq = ... to come ...
 244 \end{verbatim}
 245
 246 \item
 247   We are only left with the ``help'' function @cmp_eq@, to deal with
 248   comparing data constructors with the same tag.
 249
 250   For the ordinary constructors (if any), we emit the sorta-obvious
 251   compare-style stuff; for our example:
 252 \begin{verbatim}
 253 cmp_eq (O1 a1 b1) (O1 a2 b2)
 254   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 255
 256 cmp_eq (O2 a1) (O2 a2)
 257   = compare a1 a2
 258
 259 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 260   = case (compare a1 a2) of {
 261       LT -> LT;
 262       GT -> GT;
 263       EQ -> case compare b1 b2 of {
 264               LT -> LT;
 265               GT -> GT;
 266               EQ -> compare c1 c2
 267             }
 268     }
 269 \end{verbatim}
 270
 271   Again, we must be careful about unlifted comparisons.  For example,
 272   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 273   generate:
 274
 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 Pattern.
 290 JJQC-30-Nov-1997
 291
 292 \begin{code}
 293 gen_Ord_binds :: TyCon -> LHsBinds RdrName
 294
 295 gen_Ord_binds tycon
 296   = unitBag compare     -- `AndMonoBinds` compare
 297                 -- The default declaration in PrelBase handles this
 298   where
 299     tycon_loc = getSrcSpan tycon
 300     --------------------------------------------------------------------
 301
 302     compare = mk_easy_FunBind tycon_loc compare_RDR
 303                                   [a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs
 304     compare_rhs
 305         | single_con_type = cmp_eq_Expr a_Expr b_Expr
 306         | otherwise
 307         = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 308                   (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
 309                         (cmp_eq_Expr a_Expr b_Expr)     -- True case
 310                         -- False case; they aren't equal
 311                         -- So we need to do a less-than comparison on the tags
 312                         (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
 313
 314     tycon_data_cons = tyConDataCons tycon
 315     single_con_type = isSingleton tycon_data_cons
 316     (nullary_cons, nonnullary_cons)
 317        | isNewTyCon tycon = ([], tyConDataCons tycon)
 318        | otherwise        = partition isNullaryDataCon tycon_data_cons
 319
 320     cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
 321     cmp_eq_match
 322       | isEnumerationTyCon tycon
 323                            -- We know the tags are equal, so if it's an enumeration TyCon,
 324                            -- then there is nothing left to do
 325                            -- Catch this specially to avoid warnings
 326                            -- about overlapping patterns from the desugarer,
 327                            -- and to avoid unnecessary pattern-matching
 328       = [([nlWildPat,nlWildPat], eqTag_Expr)]
 329       | otherwise
 330       = map pats_etc nonnullary_cons ++
 331         (if single_con_type then        -- Omit wildcards when there's just one
 332               []                        -- constructor, to silence desugarer
 333         else
 334               [([nlWildPat, nlWildPat], default_rhs)])
 335
 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 = nlConVarPat data_con_RDR as_needed
 342             con2_pat = nlConVarPat data_con_RDR bs_needed
 343
 344             data_con_RDR = getRdrName 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  = dataConOrigArgTys data_con
 349
 350             nested_compare_expr [ty] [a] [b]
 351               = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar 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 tycon ty eq_expr (nlHsVar a) (nlHsVar 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 \end{code}
 362
 363 %************************************************************************
 364 %*                                                                      *
 365 \subsubsection{Generating @Enum@ instance declarations}
 366 %*                                                                      *
 367 %************************************************************************
 368
 369 @Enum@ can only be derived for enumeration types.  For a type
 370 \begin{verbatim}
 371 data Foo ... = N1 | N2 | ... | Nn
 372 \end{verbatim}
 373
 374 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 375 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 376
 377 \begin{verbatim}
 378 instance ... Enum (Foo ...) where
 379     succ x   = toEnum (1 + fromEnum x)
 380     pred x   = toEnum (fromEnum x - 1)
 381
 382     toEnum i = tag2con_Foo i
 383
 384     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 385
 386     -- or, really...
 387     enumFrom a
 388       = case con2tag_Foo a of
 389           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 390
 391    enumFromThen a b
 392      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 393
 394     -- or, really...
 395     enumFromThen a b
 396       = case con2tag_Foo a of { a# ->
 397         case con2tag_Foo b of { b# ->
 398         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 399         }}
 400 \end{verbatim}
 401
 402 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 403
 404 \begin{code}
 405 gen_Enum_binds :: TyCon -> LHsBinds RdrName
 406
 407 gen_Enum_binds tycon
 408   = listToBag [
 409         succ_enum,
 410         pred_enum,
 411         to_enum,
 412         enum_from,
 413         enum_from_then,
 414         from_enum
 415     ]
 416   where
 417     tycon_loc = getSrcSpan tycon
 418     occ_nm    = getOccString tycon
 419
 420     succ_enum
 421       = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $
 422         untag_Expr tycon [(a_RDR, ah_RDR)] $
 423         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
 424                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 425              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 426              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 427                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 428                                         nlHsIntLit 1]))
 429
 430     pred_enum
 431       = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $
 432         untag_Expr tycon [(a_RDR, ah_RDR)] $
 433         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
 434                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 435              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 436              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 437                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 438                                                nlHsLit (HsInt (-1))]))
 439
 440     to_enum
 441       = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $
 442         nlHsIf (nlHsApps and_RDR
 443                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
 444                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
 445              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
 446              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 447
 448     enum_from
 449       = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $
 450           untag_Expr tycon [(a_RDR, ah_RDR)] $
 451           nlHsApps map_RDR
 452                 [nlHsVar (tag2con_RDR tycon),
 453                  nlHsPar (enum_from_to_Expr
 454                             (nlHsVarApps intDataCon_RDR [ah_RDR])
 455                             (nlHsVar (maxtag_RDR tycon)))]
 456
 457     enum_from_then
 458       = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $
 459           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 460           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 461             nlHsPar (enum_from_then_to_Expr
 462                     (nlHsVarApps intDataCon_RDR [ah_RDR])
 463                     (nlHsVarApps intDataCon_RDR [bh_RDR])
 464                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 465                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
 466                            (nlHsIntLit 0)
 467                            (nlHsVar (maxtag_RDR tycon))
 468                            ))
 469
 470     from_enum
 471       = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $
 472           untag_Expr tycon [(a_RDR, ah_RDR)] $
 473           (nlHsVarApps intDataCon_RDR [ah_RDR])
 474 \end{code}
 475
 476 %************************************************************************
 477 %*                                                                      *
 478 \subsubsection{Generating @Bounded@ instance declarations}
 479 %*                                                                      *
 480 %************************************************************************
 481
 482 \begin{code}
 483 gen_Bounded_binds tycon
 484   = if isEnumerationTyCon tycon then
 485         listToBag [ min_bound_enum, max_bound_enum ]
 486     else
 487         ASSERT(isSingleton data_cons)
 488         listToBag [ min_bound_1con, max_bound_1con ]
 489   where
 490     data_cons = tyConDataCons tycon
 491     tycon_loc = getSrcSpan tycon
 492
 493     ----- enum-flavored: ---------------------------
 494     min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
 495     max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
 496
 497     data_con_1    = head data_cons
 498     data_con_N    = last data_cons
 499     data_con_1_RDR = getRdrName data_con_1
 500     data_con_N_RDR = getRdrName data_con_N
 501
 502     ----- single-constructor-flavored: -------------
 503     arity          = dataConSourceArity data_con_1
 504
 505     min_bound_1con = mkVarBind tycon_loc minBound_RDR $
 506                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 507     max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
 508                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 509 \end{code}
 510
 511 %************************************************************************
 512 %*                                                                      *
 513 \subsubsection{Generating @Ix@ instance declarations}
 514 %*                                                                      *
 515 %************************************************************************
 516
 517 Deriving @Ix@ is only possible for enumeration types and
 518 single-constructor types.  We deal with them in turn.
 519
 520 For an enumeration type, e.g.,
 521 \begin{verbatim}
 522     data Foo ... = N1 | N2 | ... | Nn
 523 \end{verbatim}
 524 things go not too differently from @Enum@:
 525 \begin{verbatim}
 526 instance ... Ix (Foo ...) where
 527     range (a, b)
 528       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 529
 530     -- or, really...
 531     range (a, b)
 532       = case (con2tag_Foo a) of { a# ->
 533         case (con2tag_Foo b) of { b# ->
 534         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 535         }}
 536
 537     index c@(a, b) d
 538       = if inRange c d
 539         then case (con2tag_Foo d -# con2tag_Foo a) of
 540                r# -> I# r#
 541         else error "Ix.Foo.index: out of range"
 542
 543     inRange (a, b) c
 544       = let
 545             p_tag = con2tag_Foo c
 546         in
 547         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 548
 549     -- or, really...
 550     inRange (a, b) c
 551       = case (con2tag_Foo a)   of { a_tag ->
 552         case (con2tag_Foo b)   of { b_tag ->
 553         case (con2tag_Foo c)   of { c_tag ->
 554         if (c_tag >=# a_tag) then
 555           c_tag <=# b_tag
 556         else
 557           False
 558         }}}
 559 \end{verbatim}
 560 (modulo suitable case-ification to handle the unlifted tags)
 561
 562 For a single-constructor type (NB: this includes all tuples), e.g.,
 563 \begin{verbatim}
 564     data Foo ... = MkFoo a b Int Double c c
 565 \end{verbatim}
 566 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 567 (p.~147).
 568
 569 \begin{code}
 570 gen_Ix_binds :: TyCon -> LHsBinds RdrName
 571
 572 gen_Ix_binds tycon
 573   = if isEnumerationTyCon tycon
 574     then enum_ixes
 575     else single_con_ixes
 576   where
 577     tycon_str = getOccString tycon
 578     tycon_loc = getSrcSpan tycon
 579
 580     --------------------------------------------------------------
 581     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 582
 583     enum_range
 584       = mk_easy_FunBind tycon_loc range_RDR
 585                 [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $
 586           untag_Expr tycon [(a_RDR, ah_RDR)] $
 587           untag_Expr tycon [(b_RDR, bh_RDR)] $
 588           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 589               nlHsPar (enum_from_to_Expr
 590                         (nlHsVarApps intDataCon_RDR [ah_RDR])
 591                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 592
 593     enum_index
 594       = mk_easy_FunBind tycon_loc index_RDR
 595                 [noLoc (AsPat (noLoc c_RDR)
 596                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
 597                                 d_Pat] emptyBag (
 598         nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
 599            untag_Expr tycon [(a_RDR, ah_RDR)] (
 600            untag_Expr tycon [(d_RDR, dh_RDR)] (
 601            let
 602                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
 603            in
 604            nlHsCase
 605              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
 606              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
 607            ))
 608         ) {-else-} (
 609            nlHsApp (nlHsVar error_RDR) (nlHsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
 610         ))
 611
 612     enum_inRange
 613       = mk_easy_FunBind tycon_loc inRange_RDR
 614           [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag (
 615           untag_Expr tycon [(a_RDR, ah_RDR)] (
 616           untag_Expr tycon [(b_RDR, bh_RDR)] (
 617           untag_Expr tycon [(c_RDR, ch_RDR)] (
 618           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
 619              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
 620           ) {-else-} (
 621              false_Expr
 622           )))))
 623
 624     --------------------------------------------------------------
 625     single_con_ixes
 626       = listToBag [single_con_range, single_con_index, single_con_inRange]
 627
 628     data_con
 629       = case maybeTyConSingleCon tycon of -- just checking...
 630           Nothing -> panic "get_Ix_binds"
 631           Just dc | any isUnLiftedType (dataConOrigArgTys dc)
 632                   -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
 633                   | otherwise -> dc
 634
 635     con_arity    = dataConSourceArity data_con
 636     data_con_RDR = getRdrName data_con
 637
 638     as_needed = take con_arity as_RDRs
 639     bs_needed = take con_arity bs_RDRs
 640     cs_needed = take con_arity cs_RDRs
 641
 642     con_pat  xs  = nlConVarPat data_con_RDR xs
 643     con_expr     = nlHsVarApps data_con_RDR cs_needed
 644
 645     --------------------------------------------------------------
 646     single_con_range
 647       = mk_easy_FunBind tycon_loc range_RDR
 648           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $
 649         nlHsDo ListComp stmts
 650       where
 651         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 652                 ++
 653                 [nlResultStmt con_expr]
 654
 655         mk_qual a b c = nlBindStmt (nlVarPat c)
 656                                  (nlHsApp (nlHsVar range_RDR)
 657                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
 658
 659     ----------------
 660     single_con_index
 661       = mk_easy_FunBind tycon_loc index_RDR
 662                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 663                  con_pat cs_needed] (unitBag range_size) (
 664         foldl mk_index (nlHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
 665       where
 666         mk_index multiply_by (l, u, i)
 667           = genOpApp (
 668                (nlHsApps index_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed,
 669                                     nlHsVar i])
 670            ) plus_RDR (
 671                 genOpApp (
 672                     (nlHsApp (nlHsVar rangeSize_RDR)
 673                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
 674                 ) times_RDR multiply_by
 675            )
 676
 677         range_size
 678           = mk_easy_FunBind tycon_loc rangeSize_RDR
 679                         [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag (
 680                 genOpApp (
 681                     (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
 682                                          b_Expr])
 683                 ) plus_RDR (nlHsIntLit 1))
 684
 685     ------------------
 686     single_con_inRange
 687       = mk_easy_FunBind tycon_loc inRange_RDR
 688                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 689                  con_pat cs_needed]
 690                            emptyBag (
 691           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
 692       where
 693         in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
 694                                                nlHsVar c]
 695 \end{code}
 696
 697 %************************************************************************
 698 %*                                                                      *
 699 \subsubsection{Generating @Read@ instance declarations}
 700 %*                                                                      *
 701 %************************************************************************
 702
 703 Example
 704
 705   infix 4 %%
 706   data T = Int %% Int
 707          | T1 { f1 :: Int }
 708          | T2 Int
 709
 710
 711 instance Read T where
 712   readPrec =
 713     parens
 714     ( prec 4 (
 715         do x           <- ReadP.step Read.readPrec
 716            Symbol "%%" <- Lex.lex
 717            y           <- ReadP.step Read.readPrec
 718            return (x %% y))
 719       +++
 720       prec appPrec (
 721         do Ident "T1" <- Lex.lex
 722            Punc '{' <- Lex.lex
 723            Ident "f1" <- Lex.lex
 724            Punc '=' <- Lex.lex
 725            x          <- ReadP.reset Read.readPrec
 726            Punc '}' <- Lex.lex
 727            return (T1 { f1 = x }))
 728       +++
 729       prec appPrec (
 730         do Ident "T2" <- Lex.lexP
 731            x          <- ReadP.step Read.readPrec
 732            return (T2 x))
 733     )
 734
 735   readListPrec = readListPrecDefault
 736   readList     = readListDefault
 737
 738
 739 \begin{code}
 740 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
 741
 742 gen_Read_binds get_fixity tycon
 743   = listToBag [read_prec, default_readlist, default_readlistprec]
 744   where
 745     -----------------------------------------------------------------------
 746     default_readlist
 747         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 748
 749     default_readlistprec
 750         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 751     -----------------------------------------------------------------------
 752
 753     loc       = getSrcSpan tycon
 754     data_cons = tyConDataCons tycon
 755     (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
 756
 757     read_prec = mkVarBind loc readPrec_RDR
 758                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 759
 760     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 761     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 762
 763     read_nullary_cons
 764       = case nullary_cons of
 765             []    -> []
 766             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
 767                                      result_stmt con []]]
 768             _     -> [nlHsApp (nlHsVar choose_RDR)
 769                             (nlList (map mk_pair nullary_cons))]
 770
 771     mk_pair con = nlTuple [nlHsLit (data_con_str con),
 772                                  nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
 773                                 Boxed
 774
 775     read_non_nullary_con data_con
 776       = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts]
 777       where
 778         stmts | is_infix          = infix_stmts
 779               | length labels > 0 = lbl_stmts
 780               | otherwise         = prefix_stmts
 781
 782         prefix_stmts            -- T a b c
 783           = [bindLex (ident_pat (data_con_str_w_parens data_con))]
 784             ++ read_args
 785             ++ [result_stmt data_con as_needed]
 786
 787         infix_stmts             -- a %% b
 788           = [read_a1,
 789              bindLex (symbol_pat (data_con_str data_con)),
 790              read_a2,
 791              result_stmt data_con [a1,a2]]
 792
 793         lbl_stmts               -- T { f1 = a, f2 = b }
 794           = [bindLex (ident_pat (data_con_str_w_parens data_con)),
 795              read_punc "{"]
 796             ++ concat (intersperse [read_punc ","] field_stmts)
 797             ++ [read_punc "}", result_stmt data_con as_needed]
 798
 799         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 800
 801         con_arity    = dataConSourceArity data_con
 802         labels       = dataConFieldLabels data_con
 803         dc_nm        = getName data_con
 804         is_infix     = dataConIsInfix data_con
 805         as_needed    = take con_arity as_RDRs
 806         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 807         (read_a1:read_a2:_) = read_args
 808         (a1:a2:_)           = as_needed
 809         prec         = getPrec is_infix get_fixity dc_nm
 810
 811     ------------------------------------------------------------------------
 812     --          Helpers
 813     ------------------------------------------------------------------------
 814     mk_alt e1 e2     = genOpApp e1 alt_RDR e2
 815     bindLex pat      = nlBindStmt pat (nlHsVar lexP_RDR)
 816     result_stmt c as = nlResultStmt (nlHsApp (nlHsVar returnM_RDR) (con_app c as))
 817     con_app c as     = nlHsVarApps (getRdrName c) as
 818
 819     punc_pat s   = nlConPat punc_RDR  [nlLitPat (mkHsString s)]   -- Punc 'c'
 820     ident_pat s  = nlConPat ident_RDR [nlLitPat s]                -- Ident "foo"
 821     symbol_pat s = nlConPat symbol_RDR [nlLitPat s]               -- Symbol ">>"
 822
 823     data_con_str          con = mkHsString (occNameUserString (getOccName con))
 824     data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
 825
 826     read_punc c = bindLex (punc_pat c)
 827     read_arg a ty
 828         | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
 829         | otherwise = nlBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])
 830
 831     read_field lbl a = read_lbl lbl ++
 832                        [read_punc "=",
 833                         nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])]
 834
 835         -- When reading field labels we might encounter
 836         --      a  = 3
 837         --      _a = 3
 838         -- or   (#) = 4
 839         -- Note the parens!
 840     read_lbl lbl | is_id_start (head lbl_str)
 841                  = [bindLex (ident_pat lbl_lit)]
 842                  | otherwise
 843                  = [read_punc "(",
 844                     bindLex (symbol_pat lbl_lit),
 845                     read_punc ")"]
 846                  where
 847                    lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
 848                    lbl_lit = mkHsString lbl_str
 849                    is_id_start c = isAlpha c || c == '_'
 850 \end{code}
 851
 852
 853 %************************************************************************
 854 %*                                                                      *
 855 \subsubsection{Generating @Show@ instance declarations}
 856 %*                                                                      *
 857 %************************************************************************
 858
 859 Example
 860
 861     infixr 5 :^:
 862
 863     data Tree a =  Leaf a  |  Tree a :^: Tree a
 864
 865     instance (Show a) => Show (Tree a) where
 866
 867         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 868           where
 869              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 870
 871         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 872           where
 873              showStr = showsPrec (up_prec+1) u .
 874                        showString " :^: "      .
 875                        showsPrec (up_prec+1) v
 876                 -- Note: right-associativity of :^: ignored
 877
 878     up_prec  = 5    -- Precedence of :^:
 879     app_prec = 10   -- Application has precedence one more than
 880                     -- the most tightly-binding operator
 881
 882 \begin{code}
 883 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
 884
 885 gen_Show_binds get_fixity tycon
 886   = listToBag [shows_prec, show_list]
 887   where
 888     tycon_loc = getSrcSpan tycon
 889     -----------------------------------------------------------------------
 890     show_list = mkVarBind tycon_loc showList_RDR
 891                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 892     -----------------------------------------------------------------------
 893     shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 894       where
 895         pats_etc data_con
 896           | nullary_con =  -- skip the showParen junk...
 897              ASSERT(null bs_needed)
 898              ([nlWildPat, con_pat], mk_showString_app con_str)
 899           | otherwise   =
 900              ([a_Pat, con_pat],
 901                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 902                                  (nlHsPar (nested_compose_Expr show_thingies)))
 903             where
 904              data_con_RDR  = getRdrName data_con
 905              con_arity     = dataConSourceArity data_con
 906              bs_needed     = take con_arity bs_RDRs
 907              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 908              con_pat       = nlConVarPat data_con_RDR bs_needed
 909              nullary_con   = con_arity == 0
 910              labels        = dataConFieldLabels data_con
 911              lab_fields    = length labels
 912              record_syntax = lab_fields > 0
 913
 914              dc_nm          = getName data_con
 915              dc_occ_nm      = getOccName data_con
 916              con_str        = occNameUserString dc_occ_nm
 917              op_con_str     = occNameUserString_with_parens dc_occ_nm
 918
 919              show_thingies
 920                 | is_infix      = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
 921                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
 922                                   show_record_args ++ [mk_showString_app "}"]
 923                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
 924
 925              show_label l = mk_showString_app (nm ++ " = ")
 926                         -- Note the spaces around the "=" sign.  If we don't have them
 927                         -- then we get Foo { x=-1 } and the "=-" parses as a single
 928                         -- lexeme.  Only the space after the '=' is necessary, but
 929                         -- it seems tidier to have them both sides.
 930                  where
 931                    occ_nm   = getOccName (fieldLabelName l)
 932                    nm       = occNameUserString_with_parens occ_nm
 933
 934              show_args               = zipWith show_arg bs_needed arg_tys
 935              (show_arg1:show_arg2:_) = show_args
 936              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
 937
 938                 --  Assumption for record syntax: no of fields == no of labelled fields
 939                 --            (and in same order)
 940              show_record_args = concat $
 941                                 intersperse [mk_showString_app ", "] $
 942                                 [ [show_label lbl, arg]
 943                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
 944                                                         labels show_args ]
 945
 946                 -- Generates (showsPrec p x) for argument x, but it also boxes
 947                 -- the argument first if necessary.  Note that this prints unboxed
 948                 -- things without any '#' decorations; could change that if need be
 949              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
 950                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
 951
 952                 -- Fixity stuff
 953              is_infix = dataConIsInfix data_con
 954              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
 955              arg_prec | record_syntax = 0       -- Record fields don't need parens
 956                       | otherwise     = con_prec_plus_one
 957
 958 occNameUserString_with_parens :: OccName -> String
 959 occNameUserString_with_parens occ
 960   | isSymOcc occ = '(':nm ++ ")"
 961   | otherwise    = nm
 962   where
 963    nm = occNameUserString occ
 964
 965 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 966 \end{code}
 967
 968 \begin{code}
 969 getPrec :: Bool -> FixityEnv -> Name -> Integer
 970 getPrec is_infix get_fixity nm
 971   | not is_infix   = appPrecedence
 972   | otherwise      = getPrecedence get_fixity nm
 973
 974 appPrecedence :: Integer
 975 appPrecedence = fromIntegral maxPrecedence + 1
 976   -- One more than the precedence of the most
 977   -- tightly-binding operator
 978
 979 getPrecedence :: FixityEnv -> Name -> Integer
 980 getPrecedence get_fixity nm
 981    = case lookupFixity get_fixity nm of
 982         Fixity x _ -> fromIntegral x
 983 \end{code}
 984
 985
 986 %************************************************************************
 987 %*                                                                      *
 988 \subsection{Typeable}
 989 %*                                                                      *
 990 %************************************************************************
 991
 992 From the data type
 993
 994         data T a b = ....
 995
 996 we generate
 997
 998         instance Typeable2 T where
 999                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1000
1001 We are passed the Typeable2 class as well as T
1002
1003 \begin{code}
1004 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1005 gen_Typeable_binds tycon
1006   = unitBag $
1007         mk_easy_FunBind tycon_loc
1008                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1009                 [nlWildPat] emptyBag
1010                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1011   where
1012     tycon_loc = getSrcSpan tycon
1013     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1014
1015 mk_typeOf_RDR :: TyCon -> RdrName
1016 -- Use the arity of the TyCon to make the right typeOfn function
1017 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix))
1018                 where
1019                   arity = tyConArity tycon
1020                   suffix | arity == 0 = ""
1021                          | otherwise  = show arity
1022 \end{code}
1023
1024
1025
1026 %************************************************************************
1027 %*                                                                      *
1028 \subsection{Data}
1029 %*                                                                      *
1030 %************************************************************************
1031
1032 From the data type
1033
1034   data T a b = T1 a b | T2
1035
1036 we generate
1037
1038   $cT1 = mkDataCon $dT "T1" Prefix
1039   $cT2 = mkDataCon $dT "T2" Prefix
1040   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1041   -- the [] is for field labels.
1042
1043   instance (Data a, Data b) => Data (T a b) where
1044     gfoldl k z (T1 a b) = z T `k` a `k` b
1045     gfoldl k z T2           = z T2
1046     -- ToDo: add gmapT,Q,M, gfoldr
1047
1048     gunfold k z c = case conIndex c of
1049                         I# 1# -> k (k (z T1))
1050                         I# 2# -> z T2
1051
1052     toConstr (T1 _ _) = $cT1
1053     toConstr T2       = $cT2
1054
1055     dataTypeOf _ = $dT
1056
1057 \begin{code}
1058 gen_Data_binds :: FixityEnv
1059                -> TyCon
1060                -> (LHsBinds RdrName,    -- The method bindings
1061                    LHsBinds RdrName)    -- Auxiliary bindings
1062 gen_Data_binds fix_env tycon
1063   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1064                 -- Auxiliary definitions: the data type and constructors
1065      datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1066   where
1067     tycon_loc  = getSrcSpan tycon
1068     tycon_name = tyConName tycon
1069     data_cons  = tyConDataCons tycon
1070     n_cons     = length data_cons
1071     one_constr = n_cons == 1
1072
1073         ------------ gfoldl
1074     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1075     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1076                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1077                    where
1078                      con_name ::  RdrName
1079                      con_name = getRdrName con
1080                      as_needed = take (dataConSourceArity con) as_RDRs
1081                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1082
1083         ------------ gunfold
1084     gunfold_bind = mk_FunBind tycon_loc
1085                               gunfold_RDR
1086                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1087                                 gunfold_rhs)]
1088
1089     gunfold_rhs
1090         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1091         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1092                                 (map gunfold_alt data_cons)
1093
1094     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1095     mk_unfold_rhs dc = foldr nlHsApp
1096                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1097                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1098
1099     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1100                         -- redundant test, and annoying warning
1101       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1102       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1103       where
1104         tag = dataConTag dc
1105
1106         ------------ toConstr
1107     toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1108     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1109
1110         ------------ dataTypeOf
1111     dataTypeOf_bind = mk_easy_FunBind
1112                         tycon_loc
1113                         dataTypeOf_RDR
1114                         [nlWildPat]
1115                         emptyBag
1116                         (nlHsVar data_type_name)
1117
1118         ------------ $dT
1119
1120     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1121     datatype_bind  = mkVarBind
1122                        tycon_loc
1123                        data_type_name
1124                        (           nlHsVar mkDataType_RDR
1125                          `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1126                          `nlHsApp` nlList constrs
1127                        )
1128     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1129
1130
1131         ------------ $cT1 etc
1132     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1133     mk_con_bind dc = mkVarBind
1134                        tycon_loc
1135                        (mk_constr_name dc)
1136                        (nlHsApps mkConstr_RDR (constr_args dc))
1137     constr_args dc =
1138          [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
1139            nlHsVar data_type_name,                              -- DataType
1140            nlHsLit (mkHsString (occNameUserString dc_occ)),     -- String name
1141            nlList  labels,                                      -- Field labels
1142            nlHsVar fixity]                                      -- Fixity
1143         where
1144           labels   = map (nlHsLit . mkHsString . getOccString . fieldLabelName)
1145                          (dataConFieldLabels dc)
1146           dc_occ   = getOccName dc
1147           is_infix = isDataSymOcc dc_occ
1148           fixity | is_infix  = infix_RDR
1149                  | otherwise = prefix_RDR
1150
1151 gfoldl_RDR     = varQual_RDR gENERICS_Name FSLIT("gfoldl")
1152 gunfold_RDR    = varQual_RDR gENERICS_Name FSLIT("gunfold")
1153 toConstr_RDR   = varQual_RDR gENERICS_Name FSLIT("toConstr")
1154 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
1155 mkConstr_RDR   = varQual_RDR gENERICS_Name FSLIT("mkConstr")
1156 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
1157 conIndex_RDR   = varQual_RDR gENERICS_Name FSLIT("constrIndex")
1158 prefix_RDR     = dataQual_RDR gENERICS_Name FSLIT("Prefix")
1159 infix_RDR      = dataQual_RDR gENERICS_Name FSLIT("Infix")
1160 \end{code}
1161
1162 %************************************************************************
1163 %*                                                                      *
1164 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1165 %*                                                                      *
1166 %************************************************************************
1167
1168 \begin{verbatim}
1169 data Foo ... = ...
1170
1171 con2tag_Foo :: Foo ... -> Int#
1172 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1173 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1174 \end{verbatim}
1175
1176 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1177 fiddling around.
1178
1179 \begin{code}
1180 data TagThingWanted
1181   = GenCon2Tag | GenTag2Con | GenMaxTag
1182
1183 gen_tag_n_con_monobind
1184     :: ( RdrName,           -- (proto)Name for the thing in question
1185         TyCon,              -- tycon in question
1186         TagThingWanted)
1187     -> LHsBind RdrName
1188
1189 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1190   | lots_of_constructors
1191   = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1192
1193   | otherwise
1194   = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1195
1196   where
1197     tycon_loc = getSrcSpan tycon
1198
1199     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1200         -- We can't use gerRdrName because that makes an Exact  RdrName
1201         -- and we can't put them in the LocalRdrEnv
1202
1203         -- Give a signature to the bound variable, so
1204         -- that the case expression generated by getTag is
1205         -- monomorphic.  In the push-enter model we get better code.
1206     get_tag_rhs = noLoc $ ExprWithTySig
1207                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1208                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1209                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1210
1211     con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1212                        (map nlHsTyVar tvs)
1213                 `nlHsFunTy`
1214                 nlHsTyVar (getRdrName intPrimTyCon)
1215
1216     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1217
1218     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1219     mk_stuff con = ([nlWildConPat con],
1220                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1221
1222 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1223   = mk_FunBind (getSrcSpan tycon) rdr_name
1224         [([nlConVarPat intDataCon_RDR [a_RDR]],
1225            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1226                          (nlHsTyVar (getRdrName tycon))))]
1227
1228 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1229   = mkVarBind (getSrcSpan tycon) rdr_name
1230                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1231   where
1232     max_tag =  case (tyConDataCons tycon) of
1233                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1234
1235 \end{code}
1236
1237 %************************************************************************
1238 %*                                                                      *
1239 \subsection{Utility bits for generating bindings}
1240 %*                                                                      *
1241 %************************************************************************
1242
1243
1244 ToDo: Better SrcLocs.
1245
1246 \begin{code}
1247 compare_gen_Case ::
1248           LHsExpr RdrName       -- What to do for equality
1249           -> LHsExpr RdrName -> LHsExpr RdrName
1250           -> LHsExpr RdrName
1251 careful_compare_Case :: -- checks for primitive types...
1252           TyCon                 -- The tycon we are deriving for
1253           -> Type
1254           -> LHsExpr RdrName    -- What to do for equality
1255           -> LHsExpr RdrName -> LHsExpr RdrName
1256           -> LHsExpr RdrName
1257
1258 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1259         -- Was: compare_gen_Case cmp_eq_RDR
1260
1261 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1262   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1263 compare_gen_Case eq a b                         -- General case
1264   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1265       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1266        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1267        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1268
1269 careful_compare_Case tycon ty eq a b
1270   | not (isUnLiftedType ty)
1271   = compare_gen_Case eq a b
1272   | otherwise      -- We have to do something special for primitive things...
1273   = nlHsIf (genOpApp a relevant_eq_op b)
1274          eq
1275          (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1276   where
1277     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1278     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1279
1280
1281 box_if_necy :: String           -- The class involved
1282             -> TyCon            -- The tycon involved
1283             -> LHsExpr RdrName  -- The argument
1284             -> Type             -- The argument type
1285             -> LHsExpr RdrName  -- Boxed version of the arg
1286 box_if_necy cls_str tycon arg arg_ty
1287   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1288   | otherwise             = arg
1289   where
1290     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1291
1292 assoc_ty_id :: String           -- The class involved
1293             -> TyCon            -- The tycon involved
1294             -> [(Type,a)]       -- The table
1295             -> Type             -- The type
1296             -> a                -- The result of the lookup
1297 assoc_ty_id cls_str tycon tbl ty
1298   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1299                                               text "for primitive type" <+> ppr ty)
1300   | otherwise = head res
1301   where
1302     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1303
1304 eq_op_tbl :: [(Type, PrimOp)]
1305 eq_op_tbl =
1306     [(charPrimTy,       CharEqOp)
1307     ,(intPrimTy,        IntEqOp)
1308     ,(wordPrimTy,       WordEqOp)
1309     ,(addrPrimTy,       AddrEqOp)
1310     ,(floatPrimTy,      FloatEqOp)
1311     ,(doublePrimTy,     DoubleEqOp)
1312     ]
1313
1314 lt_op_tbl :: [(Type, PrimOp)]
1315 lt_op_tbl =
1316     [(charPrimTy,       CharLtOp)
1317     ,(intPrimTy,        IntLtOp)
1318     ,(wordPrimTy,       WordLtOp)
1319     ,(addrPrimTy,       AddrLtOp)
1320     ,(floatPrimTy,      FloatLtOp)
1321     ,(doublePrimTy,     DoubleLtOp)
1322     ]
1323
1324 box_con_tbl =
1325     [(charPrimTy,       getRdrName charDataCon)
1326     ,(intPrimTy,        getRdrName intDataCon)
1327     ,(wordPrimTy,       wordDataCon_RDR)
1328     ,(addrPrimTy,       addrDataCon_RDR)
1329     ,(floatPrimTy,      getRdrName floatDataCon)
1330     ,(doublePrimTy,     getRdrName doubleDataCon)
1331     ]
1332
1333 -----------------------------------------------------------------------
1334
1335 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1336 and_Expr a b = genOpApp a and_RDR    b
1337
1338 -----------------------------------------------------------------------
1339
1340 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1341 eq_Expr tycon ty a b = genOpApp a eq_op b
1342  where
1343    eq_op
1344     | not (isUnLiftedType ty) = eq_RDR
1345     | otherwise               =
1346          -- we have to do something special for primitive things...
1347         primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1348 \end{code}
1349
1350 \begin{code}
1351 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1352 untag_Expr tycon [] expr = expr
1353 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1354   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1355       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1356
1357 cmp_tags_Expr ::  RdrName               -- Comparison op
1358              ->  RdrName ->  RdrName    -- Things to compare
1359              -> LHsExpr RdrName                 -- What to return if true
1360              -> LHsExpr RdrName         -- What to return if false
1361              -> LHsExpr RdrName
1362
1363 cmp_tags_Expr op a b true_case false_case
1364   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1365
1366 enum_from_to_Expr
1367         :: LHsExpr RdrName -> LHsExpr RdrName
1368         -> LHsExpr RdrName
1369 enum_from_then_to_Expr
1370         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1371         -> LHsExpr RdrName
1372
1373 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1374 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1375
1376 showParen_Expr
1377         :: LHsExpr RdrName -> LHsExpr RdrName
1378         -> LHsExpr RdrName
1379
1380 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1381
1382 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1383
1384 nested_compose_Expr [e] = parenify e
1385 nested_compose_Expr (e:es)
1386   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1387
1388 -- impossible_Expr is used in case RHSs that should never happen.
1389 -- We generate these to keep the desugarer from complaining that they *might* happen!
1390 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1391
1392 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1393 -- method. It is currently only used by Enum.{succ,pred}
1394 illegal_Expr meth tp msg =
1395    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1396
1397 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1398 -- to include the value of a_RDR in the error string.
1399 illegal_toEnum_tag tp maxtag =
1400    nlHsApp (nlHsVar error_RDR)
1401            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1402                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1403                     (nlHsApp (nlHsApp (nlHsApp
1404                            (nlHsVar showsPrec_RDR)
1405                            (nlHsIntLit 0))
1406                            (nlHsVar a_RDR))
1407                            (nlHsApp (nlHsApp
1408                                (nlHsVar append_RDR)
1409                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1410                                (nlHsApp (nlHsApp (nlHsApp
1411                                         (nlHsVar showsPrec_RDR)
1412                                         (nlHsIntLit 0))
1413                                         (nlHsVar maxtag))
1414                                         (nlHsLit (mkHsString ")"))))))
1415
1416 parenify e@(L _ (HsVar _)) = e
1417 parenify e                 = mkHsPar e
1418
1419 -- genOpApp wraps brackets round the operator application, so that the
1420 -- renamer won't subsequently try to re-associate it.
1421 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1422 \end{code}
1423
1424 \begin{code}
1425 getSrcSpan = srcLocSpan . getSrcLoc
1426 \end{code}
1427
1428 \begin{code}
1429 a_RDR           = mkVarUnqual FSLIT("a")
1430 b_RDR           = mkVarUnqual FSLIT("b")
1431 c_RDR           = mkVarUnqual FSLIT("c")
1432 d_RDR           = mkVarUnqual FSLIT("d")
1433 k_RDR           = mkVarUnqual FSLIT("k")
1434 z_RDR           = mkVarUnqual FSLIT("z")
1435 ah_RDR          = mkVarUnqual FSLIT("a#")
1436 bh_RDR          = mkVarUnqual FSLIT("b#")
1437 ch_RDR          = mkVarUnqual FSLIT("c#")
1438 dh_RDR          = mkVarUnqual FSLIT("d#")
1439 cmp_eq_RDR      = mkVarUnqual FSLIT("cmp_eq")
1440 rangeSize_RDR   = mkVarUnqual FSLIT("rangeSize")
1441
1442 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1443 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1444 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1445
1446 a_Expr          = nlHsVar a_RDR
1447 b_Expr          = nlHsVar b_RDR
1448 c_Expr          = nlHsVar c_RDR
1449 ltTag_Expr      = nlHsVar ltTag_RDR
1450 eqTag_Expr      = nlHsVar eqTag_RDR
1451 gtTag_Expr      = nlHsVar gtTag_RDR
1452 false_Expr      = nlHsVar false_RDR
1453 true_Expr       = nlHsVar true_RDR
1454
1455 a_Pat           = nlVarPat a_RDR
1456 b_Pat           = nlVarPat b_RDR
1457 c_Pat           = nlVarPat c_RDR
1458 d_Pat           = nlVarPat d_RDR
1459 k_Pat           = nlVarPat k_RDR
1460 z_Pat           = nlVarPat z_RDR
1461
1462 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon ->  RdrName
1463 -- Generates Orig s RdrName, for the binding positions
1464 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1465 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1466 maxtag_RDR  tycon = mk_tc_deriv_name tycon "maxtag_"
1467
1468 mk_tc_deriv_name tycon str
1469   = mkDerivedRdrName tc_name mk_occ
1470   where
1471     tc_name = tyConName tycon
1472     mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1473                   where
1474                     new_str = str ++ occNameString tc_occ ++ "#"
1475 \end{code}
1476
1477 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1478 PrelNames, so PrelNames can't import PrimOp.
1479
1480 \begin{code}
1481 primOpRdrName op = getRdrName (primOpId op)
1482
1483 minusInt_RDR  = primOpRdrName IntSubOp
1484 eqInt_RDR     = primOpRdrName IntEqOp
1485 ltInt_RDR     = primOpRdrName IntLtOp
1486 geInt_RDR     = primOpRdrName IntGeOp
1487 leInt_RDR     = primOpRdrName IntLeOp
1488 tagToEnum_RDR = primOpRdrName TagToEnumOp
1489
1490 error_RDR = getRdrName eRROR_ID
1491 \end{code}