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