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             nested_compare_expr _ _ _ = panic "nested_compare_expr"     -- Args always equal length
 358
 359         default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
 360                                                                 -- inexhaustive patterns
 361                     | otherwise         = eqTag_Expr            -- Some nullary constructors;
 362                                                                 -- Tags are equal, no args => return EQ
 363 \end{code}
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsubsection{Generating @Enum@ instance declarations}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 @Enum@ can only be derived for enumeration types.  For a type
 372 \begin{verbatim}
 373 data Foo ... = N1 | N2 | ... | Nn
 374 \end{verbatim}
 375
 376 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 377 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 378
 379 \begin{verbatim}
 380 instance ... Enum (Foo ...) where
 381     succ x   = toEnum (1 + fromEnum x)
 382     pred x   = toEnum (fromEnum x - 1)
 383
 384     toEnum i = tag2con_Foo i
 385
 386     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 387
 388     -- or, really...
 389     enumFrom a
 390       = case con2tag_Foo a of
 391           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 392
 393    enumFromThen a b
 394      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 395
 396     -- or, really...
 397     enumFromThen a b
 398       = case con2tag_Foo a of { a# ->
 399         case con2tag_Foo b of { b# ->
 400         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 401         }}
 402 \end{verbatim}
 403
 404 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 405
 406 \begin{code}
 407 gen_Enum_binds :: TyCon -> LHsBinds RdrName
 408
 409 gen_Enum_binds tycon
 410   = listToBag [
 411         succ_enum,
 412         pred_enum,
 413         to_enum,
 414         enum_from,
 415         enum_from_then,
 416         from_enum
 417     ]
 418   where
 419     tycon_loc = getSrcSpan tycon
 420     occ_nm    = getOccString tycon
 421
 422     succ_enum
 423       = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
 424         untag_Expr tycon [(a_RDR, ah_RDR)] $
 425         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
 426                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 427              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 428              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 429                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 430                                         nlHsIntLit 1]))
 431
 432     pred_enum
 433       = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
 434         untag_Expr tycon [(a_RDR, ah_RDR)] $
 435         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
 436                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 437              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 438              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 439                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 440                                                nlHsLit (HsInt (-1))]))
 441
 442     to_enum
 443       = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
 444         nlHsIf (nlHsApps and_RDR
 445                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
 446                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
 447              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
 448              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 449
 450     enum_from
 451       = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
 452           untag_Expr tycon [(a_RDR, ah_RDR)] $
 453           nlHsApps map_RDR
 454                 [nlHsVar (tag2con_RDR tycon),
 455                  nlHsPar (enum_from_to_Expr
 456                             (nlHsVarApps intDataCon_RDR [ah_RDR])
 457                             (nlHsVar (maxtag_RDR tycon)))]
 458
 459     enum_from_then
 460       = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
 461           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 462           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 463             nlHsPar (enum_from_then_to_Expr
 464                     (nlHsVarApps intDataCon_RDR [ah_RDR])
 465                     (nlHsVarApps intDataCon_RDR [bh_RDR])
 466                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 467                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
 468                            (nlHsIntLit 0)
 469                            (nlHsVar (maxtag_RDR tycon))
 470                            ))
 471
 472     from_enum
 473       = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
 474           untag_Expr tycon [(a_RDR, ah_RDR)] $
 475           (nlHsVarApps intDataCon_RDR [ah_RDR])
 476 \end{code}
 477
 478 %************************************************************************
 479 %*                                                                      *
 480 \subsubsection{Generating @Bounded@ instance declarations}
 481 %*                                                                      *
 482 %************************************************************************
 483
 484 \begin{code}
 485 gen_Bounded_binds tycon
 486   = if isEnumerationTyCon tycon then
 487         listToBag [ min_bound_enum, max_bound_enum ]
 488     else
 489         ASSERT(isSingleton data_cons)
 490         listToBag [ min_bound_1con, max_bound_1con ]
 491   where
 492     data_cons = tyConDataCons tycon
 493     tycon_loc = getSrcSpan tycon
 494
 495     ----- enum-flavored: ---------------------------
 496     min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
 497     max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
 498
 499     data_con_1    = head data_cons
 500     data_con_N    = last data_cons
 501     data_con_1_RDR = getRdrName data_con_1
 502     data_con_N_RDR = getRdrName data_con_N
 503
 504     ----- single-constructor-flavored: -------------
 505     arity          = dataConSourceArity data_con_1
 506
 507     min_bound_1con = mkVarBind tycon_loc minBound_RDR $
 508                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 509     max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
 510                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 511 \end{code}
 512
 513 %************************************************************************
 514 %*                                                                      *
 515 \subsubsection{Generating @Ix@ instance declarations}
 516 %*                                                                      *
 517 %************************************************************************
 518
 519 Deriving @Ix@ is only possible for enumeration types and
 520 single-constructor types.  We deal with them in turn.
 521
 522 For an enumeration type, e.g.,
 523 \begin{verbatim}
 524     data Foo ... = N1 | N2 | ... | Nn
 525 \end{verbatim}
 526 things go not too differently from @Enum@:
 527 \begin{verbatim}
 528 instance ... Ix (Foo ...) where
 529     range (a, b)
 530       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 531
 532     -- or, really...
 533     range (a, b)
 534       = case (con2tag_Foo a) of { a# ->
 535         case (con2tag_Foo b) of { b# ->
 536         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 537         }}
 538
 539     -- Generate code for unsafeIndex, becuase using index leads
 540     -- to lots of redundant range tests
 541     unsafeIndex c@(a, b) d
 542       = case (con2tag_Foo d -# con2tag_Foo a) of
 543                r# -> I# r#
 544
 545     inRange (a, b) c
 546       = let
 547             p_tag = con2tag_Foo c
 548         in
 549         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 550
 551     -- or, really...
 552     inRange (a, b) c
 553       = case (con2tag_Foo a)   of { a_tag ->
 554         case (con2tag_Foo b)   of { b_tag ->
 555         case (con2tag_Foo c)   of { c_tag ->
 556         if (c_tag >=# a_tag) then
 557           c_tag <=# b_tag
 558         else
 559           False
 560         }}}
 561 \end{verbatim}
 562 (modulo suitable case-ification to handle the unlifted tags)
 563
 564 For a single-constructor type (NB: this includes all tuples), e.g.,
 565 \begin{verbatim}
 566     data Foo ... = MkFoo a b Int Double c c
 567 \end{verbatim}
 568 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 569 (p.~147).
 570
 571 \begin{code}
 572 gen_Ix_binds :: TyCon -> LHsBinds RdrName
 573
 574 gen_Ix_binds tycon
 575   = if isEnumerationTyCon tycon
 576     then enum_ixes
 577     else single_con_ixes
 578   where
 579     tycon_loc = getSrcSpan tycon
 580
 581     --------------------------------------------------------------
 582     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 583
 584     enum_range
 585       = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
 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 unsafeIndex_RDR
 595                 [noLoc (AsPat (noLoc c_RDR)
 596                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
 597                                 d_Pat] (
 598            untag_Expr tycon [(a_RDR, ah_RDR)] (
 599            untag_Expr tycon [(d_RDR, dh_RDR)] (
 600            let
 601                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
 602            in
 603            nlHsCase
 604              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
 605              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
 606            ))
 607         )
 608
 609     enum_inRange
 610       = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
 611           untag_Expr tycon [(a_RDR, ah_RDR)] (
 612           untag_Expr tycon [(b_RDR, bh_RDR)] (
 613           untag_Expr tycon [(c_RDR, ch_RDR)] (
 614           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
 615              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
 616           ) {-else-} (
 617              false_Expr
 618           ))))
 619
 620     --------------------------------------------------------------
 621     single_con_ixes
 622       = listToBag [single_con_range, single_con_index, single_con_inRange]
 623
 624     data_con
 625       = case maybeTyConSingleCon tycon of -- just checking...
 626           Nothing -> panic "get_Ix_binds"
 627           Just dc | any isUnLiftedType (dataConOrigArgTys dc)
 628                   -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
 629                   | otherwise -> dc
 630
 631     con_arity    = dataConSourceArity data_con
 632     data_con_RDR = getRdrName data_con
 633
 634     as_needed = take con_arity as_RDRs
 635     bs_needed = take con_arity bs_RDRs
 636     cs_needed = take con_arity cs_RDRs
 637
 638     con_pat  xs  = nlConVarPat data_con_RDR xs
 639     con_expr     = nlHsVarApps data_con_RDR cs_needed
 640
 641     --------------------------------------------------------------
 642     single_con_range
 643       = mk_easy_FunBind tycon_loc range_RDR
 644           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
 645         nlHsDo ListComp stmts con_expr
 646       where
 647         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 648
 649         mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
 650                                  (nlHsApp (nlHsVar range_RDR)
 651                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
 652
 653     ----------------
 654     single_con_index
 655       = mk_easy_FunBind tycon_loc unsafeIndex_RDR
 656                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 657                  con_pat cs_needed]
 658                 (mk_index (zip3 as_needed bs_needed cs_needed))
 659       where
 660         -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
 661         mk_index []        = nlHsIntLit 0
 662         mk_index [(l,u,i)] = mk_one l u i
 663         mk_index ((l,u,i) : rest)
 664           = genOpApp (
 665                 mk_one l u i
 666             ) plus_RDR (
 667                 genOpApp (
 668                     (nlHsApp (nlHsVar unsafeRangeSize_RDR)
 669                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
 670                 ) times_RDR (mk_index rest)
 671            )
 672         mk_one l u i
 673           = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
 674
 675     ------------------
 676     single_con_inRange
 677       = mk_easy_FunBind tycon_loc inRange_RDR
 678                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 679                  con_pat cs_needed] $
 680           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
 681       where
 682         in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
 683                                                nlHsVar c]
 684 \end{code}
 685
 686 %************************************************************************
 687 %*                                                                      *
 688 \subsubsection{Generating @Read@ instance declarations}
 689 %*                                                                      *
 690 %************************************************************************
 691
 692 Example
 693
 694   infix 4 %%
 695   data T = Int %% Int
 696          | T1 { f1 :: Int }
 697          | T2 T
 698
 699
 700 instance Read T where
 701   readPrec =
 702     parens
 703     ( prec 4 (
 704         do x           <- ReadP.step Read.readPrec
 705            Symbol "%%" <- Lex.lex
 706            y           <- ReadP.step Read.readPrec
 707            return (x %% y))
 708       +++
 709       prec (appPrec+1) (
 710         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 711         -- Record construction binds even more tightly than application
 712         do Ident "T1" <- Lex.lex
 713            Punc '{' <- Lex.lex
 714            Ident "f1" <- Lex.lex
 715            Punc '=' <- Lex.lex
 716            x          <- ReadP.reset Read.readPrec
 717            Punc '}' <- Lex.lex
 718            return (T1 { f1 = x }))
 719       +++
 720       prec appPrec (
 721         do Ident "T2" <- Lex.lexP
 722            x          <- ReadP.step Read.readPrec
 723            return (T2 x))
 724     )
 725
 726   readListPrec = readListPrecDefault
 727   readList     = readListDefault
 728
 729
 730 \begin{code}
 731 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
 732
 733 gen_Read_binds get_fixity tycon
 734   = listToBag [read_prec, default_readlist, default_readlistprec]
 735   where
 736     -----------------------------------------------------------------------
 737     default_readlist
 738         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 739
 740     default_readlistprec
 741         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 742     -----------------------------------------------------------------------
 743
 744     loc       = getSrcSpan tycon
 745     data_cons = tyConDataCons tycon
 746     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 747
 748     read_prec = mkVarBind loc readPrec_RDR
 749                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 750
 751     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 752     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 753
 754     read_nullary_cons
 755       = case nullary_cons of
 756             []    -> []
 757             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
 758                                     (result_expr con [])]
 759             _     -> [nlHsApp (nlHsVar choose_RDR)
 760                               (nlList (map mk_pair nullary_cons))]
 761
 762     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
 763                            result_expr con []]
 764                           Boxed
 765
 766     read_non_nullary_con data_con
 767       | is_infix  = mk_parser infix_prec  infix_stmts  body
 768       | is_record = mk_parser record_prec record_stmts body
 769 --              Using these two lines instead allows the derived
 770 --              read for infix and record bindings to read the prefix form
 771 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 772 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 773       | otherwise = prefix_parser
 774       where
 775         body = result_expr data_con as_needed
 776         con_str = data_con_str data_con
 777
 778         prefix_parser = mk_parser prefix_prec prefix_stmts body
 779         prefix_stmts            -- T a b c
 780           = (if not (isSym con_str) then
 781                   [bindLex (ident_pat con_str)]
 782              else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
 783             ++ read_args
 784
 785         infix_stmts             -- a %% b, or  a `T` b
 786           = [read_a1]
 787             ++  (if isSym con_str
 788                  then [bindLex (symbol_pat con_str)]
 789                  else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
 790             ++ [read_a2]
 791
 792         record_stmts            -- T { f1 = a, f2 = b }
 793           = [bindLex (ident_pat (wrapOpParens con_str)),
 794              read_punc "{"]
 795             ++ concat (intersperse [read_punc ","] field_stmts)
 796             ++ [read_punc "}"]
 797
 798         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 799
 800         con_arity    = dataConSourceArity data_con
 801         labels       = dataConFieldLabels data_con
 802         dc_nm        = getName data_con
 803         is_infix     = dataConIsInfix data_con
 804         is_record    = length labels > 0
 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
 809         prefix_prec = appPrecedence
 810         infix_prec  = getPrecedence get_fixity dc_nm
 811         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 812                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 813
 814     ------------------------------------------------------------------------
 815     --          Helpers
 816     ------------------------------------------------------------------------
 817     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
 818     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
 819     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
 820     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
 821     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
 822
 823     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 824     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 825     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 826
 827     data_con_str con = occNameString (getOccName con)
 828
 829     read_punc c = bindLex (punc_pat c)
 830     read_arg a ty
 831         | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
 832         | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 833
 834     read_field lbl a = read_lbl lbl ++
 835                        [read_punc "=",
 836                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 837
 838         -- When reading field labels we might encounter
 839         --      a  = 3
 840         --      _a = 3
 841         -- or   (#) = 4
 842         -- Note the parens!
 843     read_lbl lbl | isSym lbl_str
 844                  = [read_punc "(",
 845                     bindLex (symbol_pat lbl_str),
 846                     read_punc ")"]
 847                  | otherwise
 848                  = [bindLex (ident_pat lbl_str)]
 849                  where
 850                    lbl_str = occNameString (getOccName lbl)
 851 \end{code}
 852
 853
 854 %************************************************************************
 855 %*                                                                      *
 856 \subsubsection{Generating @Show@ instance declarations}
 857 %*                                                                      *
 858 %************************************************************************
 859
 860 Example
 861
 862     infixr 5 :^:
 863
 864     data Tree a =  Leaf a  |  Tree a :^: Tree a
 865
 866     instance (Show a) => Show (Tree a) where
 867
 868         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 869           where
 870              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 871
 872         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 873           where
 874              showStr = showsPrec (up_prec+1) u .
 875                        showString " :^: "      .
 876                        showsPrec (up_prec+1) v
 877                 -- Note: right-associativity of :^: ignored
 878
 879     up_prec  = 5    -- Precedence of :^:
 880     app_prec = 10   -- Application has precedence one more than
 881                     -- the most tightly-binding operator
 882
 883 \begin{code}
 884 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
 885
 886 gen_Show_binds get_fixity tycon
 887   = listToBag [shows_prec, show_list]
 888   where
 889     tycon_loc = getSrcSpan tycon
 890     -----------------------------------------------------------------------
 891     show_list = mkVarBind tycon_loc showList_RDR
 892                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 893     -----------------------------------------------------------------------
 894     shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 895       where
 896         pats_etc data_con
 897           | nullary_con =  -- skip the showParen junk...
 898              ASSERT(null bs_needed)
 899              ([nlWildPat, con_pat], mk_showString_app con_str)
 900           | otherwise   =
 901              ([a_Pat, con_pat],
 902                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 903                                  (nlHsPar (nested_compose_Expr show_thingies)))
 904             where
 905              data_con_RDR  = getRdrName data_con
 906              con_arity     = dataConSourceArity data_con
 907              bs_needed     = take con_arity bs_RDRs
 908              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 909              con_pat       = nlConVarPat data_con_RDR bs_needed
 910              nullary_con   = con_arity == 0
 911              labels        = dataConFieldLabels data_con
 912              lab_fields    = length labels
 913              record_syntax = lab_fields > 0
 914
 915              dc_nm          = getName data_con
 916              dc_occ_nm      = getOccName data_con
 917              con_str        = occNameString dc_occ_nm
 918              op_con_str     = wrapOpParens con_str
 919              backquote_str  = wrapOpBackquotes con_str
 920
 921              show_thingies
 922                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
 923                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
 924                                   show_record_args ++ [mk_showString_app "}"]
 925                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
 926
 927              show_label l = mk_showString_app (nm ++ " = ")
 928                         -- Note the spaces around the "=" sign.  If we don't have them
 929                         -- then we get Foo { x=-1 } and the "=-" parses as a single
 930                         -- lexeme.  Only the space after the '=' is necessary, but
 931                         -- it seems tidier to have them both sides.
 932                  where
 933                    occ_nm   = getOccName l
 934                    nm       = wrapOpParens (occNameString occ_nm)
 935
 936              show_args               = zipWith show_arg bs_needed arg_tys
 937              (show_arg1:show_arg2:_) = show_args
 938              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
 939
 940                 --  Assumption for record syntax: no of fields == no of labelled fields
 941                 --            (and in same order)
 942              show_record_args = concat $
 943                                 intersperse [mk_showString_app ", "] $
 944                                 [ [show_label lbl, arg]
 945                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
 946                                                         labels show_args ]
 947
 948                 -- Generates (showsPrec p x) for argument x, but it also boxes
 949                 -- the argument first if necessary.  Note that this prints unboxed
 950                 -- things without any '#' decorations; could change that if need be
 951              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
 952                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
 953
 954                 -- Fixity stuff
 955              is_infix = dataConIsInfix data_con
 956              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
 957              arg_prec | record_syntax = 0       -- Record fields don't need parens
 958                       | otherwise     = con_prec_plus_one
 959
 960 wrapOpParens :: String -> String
 961 wrapOpParens s | isSym s   = '(' : s ++ ")"
 962                | otherwise = s
 963
 964 wrapOpBackquotes :: String -> String
 965 wrapOpBackquotes s | isSym s   = s
 966                    | otherwise = '`' : s ++ "`"
 967
 968 isSym :: String -> Bool
 969 isSym ""     = False
 970 isSym (c:cs) = startsVarSym c || startsConSym c
 971
 972 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 973 \end{code}
 974
 975 \begin{code}
 976 getPrec :: Bool -> FixityEnv -> Name -> Integer
 977 getPrec is_infix get_fixity nm
 978   | not is_infix   = appPrecedence
 979   | otherwise      = getPrecedence get_fixity nm
 980
 981 appPrecedence :: Integer
 982 appPrecedence = fromIntegral maxPrecedence + 1
 983   -- One more than the precedence of the most
 984   -- tightly-binding operator
 985
 986 getPrecedence :: FixityEnv -> Name -> Integer
 987 getPrecedence get_fixity nm
 988    = case lookupFixity get_fixity nm of
 989         Fixity x _ -> fromIntegral x
 990 \end{code}
 991
 992
 993 %************************************************************************
 994 %*                                                                      *
 995 \subsection{Typeable}
 996 %*                                                                      *
 997 %************************************************************************
 998
 999 From the data type
1000
1001         data T a b = ....
1002
1003 we generate
1004
1005         instance Typeable2 T where
1006                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1007
1008 We are passed the Typeable2 class as well as T
1009
1010 \begin{code}
1011 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1012 gen_Typeable_binds tycon
1013   = unitBag $
1014         mk_easy_FunBind tycon_loc
1015                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1016                 [nlWildPat]
1017                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1018   where
1019     tycon_loc = getSrcSpan tycon
1020     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1021
1022 mk_typeOf_RDR :: TyCon -> RdrName
1023 -- Use the arity of the TyCon to make the right typeOfn function
1024 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1025                 where
1026                   arity = tyConArity tycon
1027                   suffix | arity == 0 = ""
1028                          | otherwise  = show arity
1029 \end{code}
1030
1031
1032
1033 %************************************************************************
1034 %*                                                                      *
1035 \subsection{Data}
1036 %*                                                                      *
1037 %************************************************************************
1038
1039 From the data type
1040
1041   data T a b = T1 a b | T2
1042
1043 we generate
1044
1045   $cT1 = mkDataCon $dT "T1" Prefix
1046   $cT2 = mkDataCon $dT "T2" Prefix
1047   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1048   -- the [] is for field labels.
1049
1050   instance (Data a, Data b) => Data (T a b) where
1051     gfoldl k z (T1 a b) = z T `k` a `k` b
1052     gfoldl k z T2           = z T2
1053     -- ToDo: add gmapT,Q,M, gfoldr
1054
1055     gunfold k z c = case conIndex c of
1056                         I# 1# -> k (k (z T1))
1057                         I# 2# -> z T2
1058
1059     toConstr (T1 _ _) = $cT1
1060     toConstr T2       = $cT2
1061
1062     dataTypeOf _ = $dT
1063
1064 \begin{code}
1065 gen_Data_binds :: FixityEnv
1066                -> TyCon
1067                -> (LHsBinds RdrName,    -- The method bindings
1068                    LHsBinds RdrName)    -- Auxiliary bindings
1069 gen_Data_binds fix_env tycon
1070   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1071                 -- Auxiliary definitions: the data type and constructors
1072      datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1073   where
1074     tycon_loc  = getSrcSpan tycon
1075     tycon_name = tyConName tycon
1076     data_cons  = tyConDataCons tycon
1077     n_cons     = length data_cons
1078     one_constr = n_cons == 1
1079
1080         ------------ gfoldl
1081     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1082     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1083                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1084                    where
1085                      con_name ::  RdrName
1086                      con_name = getRdrName con
1087                      as_needed = take (dataConSourceArity con) as_RDRs
1088                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1089
1090         ------------ gunfold
1091     gunfold_bind = mk_FunBind tycon_loc
1092                               gunfold_RDR
1093                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1094                                 gunfold_rhs)]
1095
1096     gunfold_rhs
1097         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1098         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1099                                 (map gunfold_alt data_cons)
1100
1101     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1102     mk_unfold_rhs dc = foldr nlHsApp
1103                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1104                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1105
1106     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1107                         -- redundant test, and annoying warning
1108       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1109       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1110       where
1111         tag = dataConTag dc
1112
1113         ------------ toConstr
1114     toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1115     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1116
1117         ------------ dataTypeOf
1118     dataTypeOf_bind = mk_easy_FunBind
1119                         tycon_loc
1120                         dataTypeOf_RDR
1121                         [nlWildPat]
1122                         (nlHsVar data_type_name)
1123
1124         ------------  $dT
1125
1126     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1127     datatype_bind  = mkVarBind
1128                        tycon_loc
1129                        data_type_name
1130                        (           nlHsVar mkDataType_RDR
1131                          `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1132                          `nlHsApp` nlList constrs
1133                        )
1134     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1135
1136
1137         ------------  $cT1 etc
1138     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1139     mk_con_bind dc = mkVarBind
1140                        tycon_loc
1141                        (mk_constr_name dc)
1142                        (nlHsApps mkConstr_RDR (constr_args dc))
1143     constr_args dc =
1144          [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
1145            nlHsVar data_type_name,                              -- DataType
1146            nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1147            nlList  labels,                                      -- Field labels
1148            nlHsVar fixity]                                      -- Fixity
1149         where
1150           labels   = map (nlHsLit . mkHsString . getOccString)
1151                          (dataConFieldLabels dc)
1152           dc_occ   = getOccName dc
1153           is_infix = isDataSymOcc dc_occ
1154           fixity | is_infix  = infix_RDR
1155                  | otherwise = prefix_RDR
1156
1157 gfoldl_RDR     = varQual_RDR gENERICS FSLIT("gfoldl")
1158 gunfold_RDR    = varQual_RDR gENERICS FSLIT("gunfold")
1159 toConstr_RDR   = varQual_RDR gENERICS FSLIT("toConstr")
1160 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1161 mkConstr_RDR   = varQual_RDR gENERICS FSLIT("mkConstr")
1162 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1163 conIndex_RDR   = varQual_RDR gENERICS FSLIT("constrIndex")
1164 prefix_RDR     = dataQual_RDR gENERICS FSLIT("Prefix")
1165 infix_RDR      = dataQual_RDR gENERICS FSLIT("Infix")
1166 \end{code}
1167
1168 %************************************************************************
1169 %*                                                                      *
1170 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1171 %*                                                                      *
1172 %************************************************************************
1173
1174 \begin{verbatim}
1175 data Foo ... = ...
1176
1177 con2tag_Foo :: Foo ... -> Int#
1178 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1179 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1180 \end{verbatim}
1181
1182 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1183 fiddling around.
1184
1185 \begin{code}
1186 data TagThingWanted
1187   = GenCon2Tag | GenTag2Con | GenMaxTag
1188
1189 gen_tag_n_con_monobind
1190     :: ( RdrName,           -- (proto)Name for the thing in question
1191         TyCon,              -- tycon in question
1192         TagThingWanted)
1193     -> LHsBind RdrName
1194
1195 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1196   | lots_of_constructors
1197   = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1198
1199   | otherwise
1200   = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1201
1202   where
1203     tycon_loc = getSrcSpan tycon
1204
1205     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1206         -- We can't use gerRdrName because that makes an Exact  RdrName
1207         -- and we can't put them in the LocalRdrEnv
1208
1209         -- Give a signature to the bound variable, so
1210         -- that the case expression generated by getTag is
1211         -- monomorphic.  In the push-enter model we get better code.
1212     get_tag_rhs = noLoc $ ExprWithTySig
1213                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1214                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1215                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1216
1217     con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1218                        (map nlHsTyVar tvs)
1219                 `nlHsFunTy`
1220                 nlHsTyVar (getRdrName intPrimTyCon)
1221
1222     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1223
1224     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1225     mk_stuff con = ([nlWildConPat con],
1226                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1227
1228 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1229   = mk_FunBind (getSrcSpan tycon) rdr_name
1230         [([nlConVarPat intDataCon_RDR [a_RDR]],
1231            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1232                          (nlHsTyVar (getRdrName tycon))))]
1233
1234 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1235   = mkVarBind (getSrcSpan tycon) rdr_name
1236                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1237   where
1238     max_tag =  case (tyConDataCons tycon) of
1239                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1240
1241 \end{code}
1242
1243 %************************************************************************
1244 %*                                                                      *
1245 \subsection{Utility bits for generating bindings}
1246 %*                                                                      *
1247 %************************************************************************
1248
1249
1250 ToDo: Better SrcLocs.
1251
1252 \begin{code}
1253 compare_gen_Case ::
1254           LHsExpr RdrName       -- What to do for equality
1255           -> LHsExpr RdrName -> LHsExpr RdrName
1256           -> LHsExpr RdrName
1257 careful_compare_Case :: -- checks for primitive types...
1258           TyCon                 -- The tycon we are deriving for
1259           -> Type
1260           -> LHsExpr RdrName    -- What to do for equality
1261           -> LHsExpr RdrName -> LHsExpr RdrName
1262           -> LHsExpr RdrName
1263
1264 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1265         -- Was: compare_gen_Case cmp_eq_RDR
1266
1267 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1268   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1269 compare_gen_Case eq a b                         -- General case
1270   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1271       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1272        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1273        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1274
1275 careful_compare_Case tycon ty eq a b
1276   | not (isUnLiftedType ty)
1277   = compare_gen_Case eq a b
1278   | otherwise      -- We have to do something special for primitive things...
1279   = nlHsIf (genOpApp a relevant_eq_op b)
1280          eq
1281          (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1282   where
1283     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1284     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1285
1286
1287 box_if_necy :: String           -- The class involved
1288             -> TyCon            -- The tycon involved
1289             -> LHsExpr RdrName  -- The argument
1290             -> Type             -- The argument type
1291             -> LHsExpr RdrName  -- Boxed version of the arg
1292 box_if_necy cls_str tycon arg arg_ty
1293   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1294   | otherwise             = arg
1295   where
1296     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1297
1298 assoc_ty_id :: String           -- The class involved
1299             -> TyCon            -- The tycon involved
1300             -> [(Type,a)]       -- The table
1301             -> Type             -- The type
1302             -> a                -- The result of the lookup
1303 assoc_ty_id cls_str tycon tbl ty
1304   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1305                                               text "for primitive type" <+> ppr ty)
1306   | otherwise = head res
1307   where
1308     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1309
1310 eq_op_tbl :: [(Type, PrimOp)]
1311 eq_op_tbl =
1312     [(charPrimTy,       CharEqOp)
1313     ,(intPrimTy,        IntEqOp)
1314     ,(wordPrimTy,       WordEqOp)
1315     ,(addrPrimTy,       AddrEqOp)
1316     ,(floatPrimTy,      FloatEqOp)
1317     ,(doublePrimTy,     DoubleEqOp)
1318     ]
1319
1320 lt_op_tbl :: [(Type, PrimOp)]
1321 lt_op_tbl =
1322     [(charPrimTy,       CharLtOp)
1323     ,(intPrimTy,        IntLtOp)
1324     ,(wordPrimTy,       WordLtOp)
1325     ,(addrPrimTy,       AddrLtOp)
1326     ,(floatPrimTy,      FloatLtOp)
1327     ,(doublePrimTy,     DoubleLtOp)
1328     ]
1329
1330 box_con_tbl =
1331     [(charPrimTy,       getRdrName charDataCon)
1332     ,(intPrimTy,        getRdrName intDataCon)
1333     ,(wordPrimTy,       wordDataCon_RDR)
1334     ,(floatPrimTy,      getRdrName floatDataCon)
1335     ,(doublePrimTy,     getRdrName doubleDataCon)
1336     ]
1337
1338 -----------------------------------------------------------------------
1339
1340 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1341 and_Expr a b = genOpApp a and_RDR    b
1342
1343 -----------------------------------------------------------------------
1344
1345 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1346 eq_Expr tycon ty a b = genOpApp a eq_op b
1347  where
1348    eq_op
1349     | not (isUnLiftedType ty) = eq_RDR
1350     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1351          -- we have to do something special for primitive things...
1352 \end{code}
1353
1354 \begin{code}
1355 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1356 untag_Expr tycon [] expr = expr
1357 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1358   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1359       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1360
1361 cmp_tags_Expr ::  RdrName               -- Comparison op
1362              ->  RdrName ->  RdrName    -- Things to compare
1363              -> LHsExpr RdrName                 -- What to return if true
1364              -> LHsExpr RdrName         -- What to return if false
1365              -> LHsExpr RdrName
1366
1367 cmp_tags_Expr op a b true_case false_case
1368   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1369
1370 enum_from_to_Expr
1371         :: LHsExpr RdrName -> LHsExpr RdrName
1372         -> LHsExpr RdrName
1373 enum_from_then_to_Expr
1374         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1375         -> LHsExpr RdrName
1376
1377 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1378 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1379
1380 showParen_Expr
1381         :: LHsExpr RdrName -> LHsExpr RdrName
1382         -> LHsExpr RdrName
1383
1384 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1385
1386 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1387
1388 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1389 nested_compose_Expr [e] = parenify e
1390 nested_compose_Expr (e:es)
1391   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1392
1393 -- impossible_Expr is used in case RHSs that should never happen.
1394 -- We generate these to keep the desugarer from complaining that they *might* happen!
1395 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1396
1397 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1398 -- method. It is currently only used by Enum.{succ,pred}
1399 illegal_Expr meth tp msg =
1400    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1401
1402 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1403 -- to include the value of a_RDR in the error string.
1404 illegal_toEnum_tag tp maxtag =
1405    nlHsApp (nlHsVar error_RDR)
1406            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1407                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1408                     (nlHsApp (nlHsApp (nlHsApp
1409                            (nlHsVar showsPrec_RDR)
1410                            (nlHsIntLit 0))
1411                            (nlHsVar a_RDR))
1412                            (nlHsApp (nlHsApp
1413                                (nlHsVar append_RDR)
1414                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1415                                (nlHsApp (nlHsApp (nlHsApp
1416                                         (nlHsVar showsPrec_RDR)
1417                                         (nlHsIntLit 0))
1418                                         (nlHsVar maxtag))
1419                                         (nlHsLit (mkHsString ")"))))))
1420
1421 parenify e@(L _ (HsVar _)) = e
1422 parenify e                 = mkHsPar e
1423
1424 -- genOpApp wraps brackets round the operator application, so that the
1425 -- renamer won't subsequently try to re-associate it.
1426 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1427 \end{code}
1428
1429 \begin{code}
1430 getSrcSpan = srcLocSpan . getSrcLoc
1431 \end{code}
1432
1433 \begin{code}
1434 a_RDR           = mkVarUnqual FSLIT("a")
1435 b_RDR           = mkVarUnqual FSLIT("b")
1436 c_RDR           = mkVarUnqual FSLIT("c")
1437 d_RDR           = mkVarUnqual FSLIT("d")
1438 k_RDR           = mkVarUnqual FSLIT("k")
1439 z_RDR           = mkVarUnqual FSLIT("z")
1440 ah_RDR          = mkVarUnqual FSLIT("a#")
1441 bh_RDR          = mkVarUnqual FSLIT("b#")
1442 ch_RDR          = mkVarUnqual FSLIT("c#")
1443 dh_RDR          = mkVarUnqual FSLIT("d#")
1444 cmp_eq_RDR      = mkVarUnqual FSLIT("cmp_eq")
1445
1446 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1447 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1448 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1449
1450 a_Expr          = nlHsVar a_RDR
1451 b_Expr          = nlHsVar b_RDR
1452 c_Expr          = nlHsVar c_RDR
1453 ltTag_Expr      = nlHsVar ltTag_RDR
1454 eqTag_Expr      = nlHsVar eqTag_RDR
1455 gtTag_Expr      = nlHsVar gtTag_RDR
1456 false_Expr      = nlHsVar false_RDR
1457 true_Expr       = nlHsVar true_RDR
1458
1459 a_Pat           = nlVarPat a_RDR
1460 b_Pat           = nlVarPat b_RDR
1461 c_Pat           = nlVarPat c_RDR
1462 d_Pat           = nlVarPat d_RDR
1463 k_Pat           = nlVarPat k_RDR
1464 z_Pat           = nlVarPat z_RDR
1465
1466 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon ->  RdrName
1467 -- Generates Orig s RdrName, for the binding positions
1468 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1469 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1470 maxtag_RDR  tycon = mk_tc_deriv_name tycon "maxtag_"
1471
1472 mk_tc_deriv_name tycon str
1473   = mkDerivedRdrName tc_name mk_occ
1474   where
1475     tc_name = tyConName tycon
1476     mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1477                   where
1478                     new_str = str ++ occNameString tc_occ ++ "#"
1479 \end{code}
1480
1481 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1482 PrelNames, so PrelNames can't import PrimOp.
1483
1484 \begin{code}
1485 primOpRdrName op = getRdrName (primOpId op)
1486
1487 minusInt_RDR  = primOpRdrName IntSubOp
1488 eqInt_RDR     = primOpRdrName IntEqOp
1489 ltInt_RDR     = primOpRdrName IntLtOp
1490 geInt_RDR     = primOpRdrName IntGeOp
1491 leInt_RDR     = primOpRdrName IntLeOp
1492 tagToEnum_RDR = primOpRdrName TagToEnumOp
1493
1494 error_RDR = getRdrName eRROR_ID
1495 \end{code}