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 T
 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+1) (
 708         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 709         -- Record construction binds even more tightly than application
 710         do Ident "T1" <- Lex.lex
 711            Punc '{' <- Lex.lex
 712            Ident "f1" <- Lex.lex
 713            Punc '=' <- Lex.lex
 714            x          <- ReadP.reset Read.readPrec
 715            Punc '}' <- Lex.lex
 716            return (T1 { f1 = x }))
 717       +++
 718       prec appPrec (
 719         do Ident "T2" <- Lex.lexP
 720            x          <- ReadP.step Read.readPrec
 721            return (T2 x))
 722     )
 723
 724   readListPrec = readListPrecDefault
 725   readList     = readListDefault
 726
 727
 728 \begin{code}
 729 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
 730
 731 gen_Read_binds get_fixity tycon
 732   = listToBag [read_prec, default_readlist, default_readlistprec]
 733   where
 734     -----------------------------------------------------------------------
 735     default_readlist
 736         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 737
 738     default_readlistprec
 739         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 740     -----------------------------------------------------------------------
 741
 742     loc       = getSrcSpan tycon
 743     data_cons = tyConDataCons tycon
 744     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 745
 746     read_prec = mkVarBind loc readPrec_RDR
 747                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 748
 749     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 750     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 751
 752     read_nullary_cons
 753       = case nullary_cons of
 754             []    -> []
 755             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
 756                                     (result_expr con [])]
 757             _     -> [nlHsApp (nlHsVar choose_RDR)
 758                             (nlList (map mk_pair nullary_cons))]
 759
 760     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
 761                                    nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
 762                                    Boxed
 763
 764     read_non_nullary_con data_con
 765       = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body]
 766       where
 767         stmts | is_infix  = infix_stmts
 768               | is_record = lbl_stmts
 769               | otherwise = prefix_stmts
 770
 771         body = result_expr data_con as_needed
 772         con_str = data_con_str data_con
 773
 774         prefix_stmts            -- T a b c
 775           = [bindLex (ident_pat (wrapOpParens con_str))]
 776             ++ read_args
 777
 778         infix_stmts             -- a %% b, or  a `T` b
 779           = [read_a1]
 780             ++  (if isSym con_str
 781                  then [bindLex (symbol_pat con_str)]
 782                  else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
 783             ++ [read_a2]
 784
 785         lbl_stmts               -- T { f1 = a, f2 = b }
 786           = [bindLex (ident_pat (wrapOpParens con_str)),
 787              read_punc "{"]
 788             ++ concat (intersperse [read_punc ","] field_stmts)
 789             ++ [read_punc "}"]
 790
 791         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 792
 793         con_arity    = dataConSourceArity data_con
 794         labels       = dataConFieldLabels data_con
 795         dc_nm        = getName data_con
 796         is_infix     = dataConIsInfix data_con
 797         is_record    = length labels > 0
 798         as_needed    = take con_arity as_RDRs
 799         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 800         (read_a1:read_a2:_) = read_args
 801         prec | is_infix  = getPrecedence get_fixity dc_nm
 802              | is_record = appPrecedence + 1    -- Record construction binds even more tightly
 803                                                 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 804              | otherwise = appPrecedence
 805
 806     ------------------------------------------------------------------------
 807     --          Helpers
 808     ------------------------------------------------------------------------
 809     mk_alt e1 e2     = genOpApp e1 alt_RDR e2
 810     bindLex pat      = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
 811     con_app c as     = nlHsVarApps (getRdrName c) as
 812     result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
 813
 814     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 815     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 816     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 817
 818     data_con_str con = occNameString (getOccName con)
 819
 820     read_punc c = bindLex (punc_pat c)
 821     read_arg a ty
 822         | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
 823         | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 824
 825     read_field lbl a = read_lbl lbl ++
 826                        [read_punc "=",
 827                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 828
 829         -- When reading field labels we might encounter
 830         --      a  = 3
 831         --      _a = 3
 832         -- or   (#) = 4
 833         -- Note the parens!
 834     read_lbl lbl | isSym lbl_str
 835                  = [read_punc "(",
 836                     bindLex (symbol_pat lbl_str),
 837                     read_punc ")"]
 838                  | otherwise
 839                  = [bindLex (ident_pat lbl_str)]
 840                  where
 841                    lbl_str = occNameString (getOccName lbl)
 842 \end{code}
 843
 844
 845 %************************************************************************
 846 %*                                                                      *
 847 \subsubsection{Generating @Show@ instance declarations}
 848 %*                                                                      *
 849 %************************************************************************
 850
 851 Example
 852
 853     infixr 5 :^:
 854
 855     data Tree a =  Leaf a  |  Tree a :^: Tree a
 856
 857     instance (Show a) => Show (Tree a) where
 858
 859         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 860           where
 861              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 862
 863         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 864           where
 865              showStr = showsPrec (up_prec+1) u .
 866                        showString " :^: "      .
 867                        showsPrec (up_prec+1) v
 868                 -- Note: right-associativity of :^: ignored
 869
 870     up_prec  = 5    -- Precedence of :^:
 871     app_prec = 10   -- Application has precedence one more than
 872                     -- the most tightly-binding operator
 873
 874 \begin{code}
 875 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
 876
 877 gen_Show_binds get_fixity tycon
 878   = listToBag [shows_prec, show_list]
 879   where
 880     tycon_loc = getSrcSpan tycon
 881     -----------------------------------------------------------------------
 882     show_list = mkVarBind tycon_loc showList_RDR
 883                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 884     -----------------------------------------------------------------------
 885     shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 886       where
 887         pats_etc data_con
 888           | nullary_con =  -- skip the showParen junk...
 889              ASSERT(null bs_needed)
 890              ([nlWildPat, con_pat], mk_showString_app con_str)
 891           | otherwise   =
 892              ([a_Pat, con_pat],
 893                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 894                                  (nlHsPar (nested_compose_Expr show_thingies)))
 895             where
 896              data_con_RDR  = getRdrName data_con
 897              con_arity     = dataConSourceArity data_con
 898              bs_needed     = take con_arity bs_RDRs
 899              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 900              con_pat       = nlConVarPat data_con_RDR bs_needed
 901              nullary_con   = con_arity == 0
 902              labels        = dataConFieldLabels data_con
 903              lab_fields    = length labels
 904              record_syntax = lab_fields > 0
 905
 906              dc_nm          = getName data_con
 907              dc_occ_nm      = getOccName data_con
 908              con_str        = occNameString dc_occ_nm
 909              op_con_str     = wrapOpParens con_str
 910              backquote_str  = wrapOpBackquotes con_str
 911
 912              show_thingies
 913                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
 914                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
 915                                   show_record_args ++ [mk_showString_app "}"]
 916                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
 917
 918              show_label l = mk_showString_app (nm ++ " = ")
 919                         -- Note the spaces around the "=" sign.  If we don't have them
 920                         -- then we get Foo { x=-1 } and the "=-" parses as a single
 921                         -- lexeme.  Only the space after the '=' is necessary, but
 922                         -- it seems tidier to have them both sides.
 923                  where
 924                    occ_nm   = getOccName l
 925                    nm       = wrapOpParens (occNameString occ_nm)
 926
 927              show_args               = zipWith show_arg bs_needed arg_tys
 928              (show_arg1:show_arg2:_) = show_args
 929              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
 930
 931                 --  Assumption for record syntax: no of fields == no of labelled fields
 932                 --            (and in same order)
 933              show_record_args = concat $
 934                                 intersperse [mk_showString_app ", "] $
 935                                 [ [show_label lbl, arg]
 936                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
 937                                                         labels show_args ]
 938
 939                 -- Generates (showsPrec p x) for argument x, but it also boxes
 940                 -- the argument first if necessary.  Note that this prints unboxed
 941                 -- things without any '#' decorations; could change that if need be
 942              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
 943                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
 944
 945                 -- Fixity stuff
 946              is_infix = dataConIsInfix data_con
 947              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
 948              arg_prec | record_syntax = 0       -- Record fields don't need parens
 949                       | otherwise     = con_prec_plus_one
 950
 951 wrapOpParens :: String -> String
 952 wrapOpParens s | isSym s   = '(' : s ++ ")"
 953                | otherwise = s
 954
 955 wrapOpBackquotes :: String -> String
 956 wrapOpBackquotes s | isSym s   = s
 957                    | otherwise = '`' : s ++ "`"
 958
 959 isSym :: String -> Bool
 960 isSym ""     = False
 961 isSym (c:cs) = startsVarSym c || startsConSym c
 962
 963 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 964 \end{code}
 965
 966 \begin{code}
 967 getPrec :: Bool -> FixityEnv -> Name -> Integer
 968 getPrec is_infix get_fixity nm
 969   | not is_infix   = appPrecedence
 970   | otherwise      = getPrecedence get_fixity nm
 971
 972 appPrecedence :: Integer
 973 appPrecedence = fromIntegral maxPrecedence + 1
 974   -- One more than the precedence of the most
 975   -- tightly-binding operator
 976
 977 getPrecedence :: FixityEnv -> Name -> Integer
 978 getPrecedence get_fixity nm
 979    = case lookupFixity get_fixity nm of
 980         Fixity x _ -> fromIntegral x
 981 \end{code}
 982
 983
 984 %************************************************************************
 985 %*                                                                      *
 986 \subsection{Typeable}
 987 %*                                                                      *
 988 %************************************************************************
 989
 990 From the data type
 991
 992         data T a b = ....
 993
 994 we generate
 995
 996         instance Typeable2 T where
 997                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
 998
 999 We are passed the Typeable2 class as well as T
1000
1001 \begin{code}
1002 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1003 gen_Typeable_binds tycon
1004   = unitBag $
1005         mk_easy_FunBind tycon_loc
1006                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1007                 [nlWildPat]
1008                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1009   where
1010     tycon_loc = getSrcSpan tycon
1011     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1012
1013 mk_typeOf_RDR :: TyCon -> RdrName
1014 -- Use the arity of the TyCon to make the right typeOfn function
1015 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1016                 where
1017                   arity = tyConArity tycon
1018                   suffix | arity == 0 = ""
1019                          | otherwise  = show arity
1020 \end{code}
1021
1022
1023
1024 %************************************************************************
1025 %*                                                                      *
1026 \subsection{Data}
1027 %*                                                                      *
1028 %************************************************************************
1029
1030 From the data type
1031
1032   data T a b = T1 a b | T2
1033
1034 we generate
1035
1036   $cT1 = mkDataCon $dT "T1" Prefix
1037   $cT2 = mkDataCon $dT "T2" Prefix
1038   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1039   -- the [] is for field labels.
1040
1041   instance (Data a, Data b) => Data (T a b) where
1042     gfoldl k z (T1 a b) = z T `k` a `k` b
1043     gfoldl k z T2           = z T2
1044     -- ToDo: add gmapT,Q,M, gfoldr
1045
1046     gunfold k z c = case conIndex c of
1047                         I# 1# -> k (k (z T1))
1048                         I# 2# -> z T2
1049
1050     toConstr (T1 _ _) = $cT1
1051     toConstr T2       = $cT2
1052
1053     dataTypeOf _ = $dT
1054
1055 \begin{code}
1056 gen_Data_binds :: FixityEnv
1057                -> TyCon
1058                -> (LHsBinds RdrName,    -- The method bindings
1059                    LHsBinds RdrName)    -- Auxiliary bindings
1060 gen_Data_binds fix_env tycon
1061   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1062                 -- Auxiliary definitions: the data type and constructors
1063      datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1064   where
1065     tycon_loc  = getSrcSpan tycon
1066     tycon_name = tyConName tycon
1067     data_cons  = tyConDataCons tycon
1068     n_cons     = length data_cons
1069     one_constr = n_cons == 1
1070
1071         ------------ gfoldl
1072     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1073     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1074                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1075                    where
1076                      con_name ::  RdrName
1077                      con_name = getRdrName con
1078                      as_needed = take (dataConSourceArity con) as_RDRs
1079                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1080
1081         ------------ gunfold
1082     gunfold_bind = mk_FunBind tycon_loc
1083                               gunfold_RDR
1084                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1085                                 gunfold_rhs)]
1086
1087     gunfold_rhs
1088         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1089         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1090                                 (map gunfold_alt data_cons)
1091
1092     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1093     mk_unfold_rhs dc = foldr nlHsApp
1094                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1095                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1096
1097     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1098                         -- redundant test, and annoying warning
1099       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1100       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1101       where
1102         tag = dataConTag dc
1103
1104         ------------ toConstr
1105     toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1106     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1107
1108         ------------ dataTypeOf
1109     dataTypeOf_bind = mk_easy_FunBind
1110                         tycon_loc
1111                         dataTypeOf_RDR
1112                         [nlWildPat]
1113                         (nlHsVar data_type_name)
1114
1115         ------------  $dT
1116
1117     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1118     datatype_bind  = mkVarBind
1119                        tycon_loc
1120                        data_type_name
1121                        (           nlHsVar mkDataType_RDR
1122                          `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1123                          `nlHsApp` nlList constrs
1124                        )
1125     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1126
1127
1128         ------------  $cT1 etc
1129     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1130     mk_con_bind dc = mkVarBind
1131                        tycon_loc
1132                        (mk_constr_name dc)
1133                        (nlHsApps mkConstr_RDR (constr_args dc))
1134     constr_args dc =
1135          [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
1136            nlHsVar data_type_name,                              -- DataType
1137            nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1138            nlList  labels,                                      -- Field labels
1139            nlHsVar fixity]                                      -- Fixity
1140         where
1141           labels   = map (nlHsLit . mkHsString . getOccString)
1142                          (dataConFieldLabels dc)
1143           dc_occ   = getOccName dc
1144           is_infix = isDataSymOcc dc_occ
1145           fixity | is_infix  = infix_RDR
1146                  | otherwise = prefix_RDR
1147
1148 gfoldl_RDR     = varQual_RDR gENERICS FSLIT("gfoldl")
1149 gunfold_RDR    = varQual_RDR gENERICS FSLIT("gunfold")
1150 toConstr_RDR   = varQual_RDR gENERICS FSLIT("toConstr")
1151 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1152 mkConstr_RDR   = varQual_RDR gENERICS FSLIT("mkConstr")
1153 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1154 conIndex_RDR   = varQual_RDR gENERICS FSLIT("constrIndex")
1155 prefix_RDR     = dataQual_RDR gENERICS FSLIT("Prefix")
1156 infix_RDR      = dataQual_RDR gENERICS FSLIT("Infix")
1157 \end{code}
1158
1159 %************************************************************************
1160 %*                                                                      *
1161 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1162 %*                                                                      *
1163 %************************************************************************
1164
1165 \begin{verbatim}
1166 data Foo ... = ...
1167
1168 con2tag_Foo :: Foo ... -> Int#
1169 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1170 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1171 \end{verbatim}
1172
1173 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1174 fiddling around.
1175
1176 \begin{code}
1177 data TagThingWanted
1178   = GenCon2Tag | GenTag2Con | GenMaxTag
1179
1180 gen_tag_n_con_monobind
1181     :: ( RdrName,           -- (proto)Name for the thing in question
1182         TyCon,              -- tycon in question
1183         TagThingWanted)
1184     -> LHsBind RdrName
1185
1186 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1187   | lots_of_constructors
1188   = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1189
1190   | otherwise
1191   = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1192
1193   where
1194     tycon_loc = getSrcSpan tycon
1195
1196     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1197         -- We can't use gerRdrName because that makes an Exact  RdrName
1198         -- and we can't put them in the LocalRdrEnv
1199
1200         -- Give a signature to the bound variable, so
1201         -- that the case expression generated by getTag is
1202         -- monomorphic.  In the push-enter model we get better code.
1203     get_tag_rhs = noLoc $ ExprWithTySig
1204                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1205                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1206                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1207
1208     con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1209                        (map nlHsTyVar tvs)
1210                 `nlHsFunTy`
1211                 nlHsTyVar (getRdrName intPrimTyCon)
1212
1213     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1214
1215     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1216     mk_stuff con = ([nlWildConPat con],
1217                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1218
1219 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1220   = mk_FunBind (getSrcSpan tycon) rdr_name
1221         [([nlConVarPat intDataCon_RDR [a_RDR]],
1222            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1223                          (nlHsTyVar (getRdrName tycon))))]
1224
1225 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1226   = mkVarBind (getSrcSpan tycon) rdr_name
1227                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1228   where
1229     max_tag =  case (tyConDataCons tycon) of
1230                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1231
1232 \end{code}
1233
1234 %************************************************************************
1235 %*                                                                      *
1236 \subsection{Utility bits for generating bindings}
1237 %*                                                                      *
1238 %************************************************************************
1239
1240
1241 ToDo: Better SrcLocs.
1242
1243 \begin{code}
1244 compare_gen_Case ::
1245           LHsExpr RdrName       -- What to do for equality
1246           -> LHsExpr RdrName -> LHsExpr RdrName
1247           -> LHsExpr RdrName
1248 careful_compare_Case :: -- checks for primitive types...
1249           TyCon                 -- The tycon we are deriving for
1250           -> Type
1251           -> LHsExpr RdrName    -- What to do for equality
1252           -> LHsExpr RdrName -> LHsExpr RdrName
1253           -> LHsExpr RdrName
1254
1255 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1256         -- Was: compare_gen_Case cmp_eq_RDR
1257
1258 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1259   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1260 compare_gen_Case eq a b                         -- General case
1261   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1262       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1263        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1264        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1265
1266 careful_compare_Case tycon ty eq a b
1267   | not (isUnLiftedType ty)
1268   = compare_gen_Case eq a b
1269   | otherwise      -- We have to do something special for primitive things...
1270   = nlHsIf (genOpApp a relevant_eq_op b)
1271          eq
1272          (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1273   where
1274     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1275     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1276
1277
1278 box_if_necy :: String           -- The class involved
1279             -> TyCon            -- The tycon involved
1280             -> LHsExpr RdrName  -- The argument
1281             -> Type             -- The argument type
1282             -> LHsExpr RdrName  -- Boxed version of the arg
1283 box_if_necy cls_str tycon arg arg_ty
1284   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1285   | otherwise             = arg
1286   where
1287     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1288
1289 assoc_ty_id :: String           -- The class involved
1290             -> TyCon            -- The tycon involved
1291             -> [(Type,a)]       -- The table
1292             -> Type             -- The type
1293             -> a                -- The result of the lookup
1294 assoc_ty_id cls_str tycon tbl ty
1295   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1296                                               text "for primitive type" <+> ppr ty)
1297   | otherwise = head res
1298   where
1299     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1300
1301 eq_op_tbl :: [(Type, PrimOp)]
1302 eq_op_tbl =
1303     [(charPrimTy,       CharEqOp)
1304     ,(intPrimTy,        IntEqOp)
1305     ,(wordPrimTy,       WordEqOp)
1306     ,(addrPrimTy,       AddrEqOp)
1307     ,(floatPrimTy,      FloatEqOp)
1308     ,(doublePrimTy,     DoubleEqOp)
1309     ]
1310
1311 lt_op_tbl :: [(Type, PrimOp)]
1312 lt_op_tbl =
1313     [(charPrimTy,       CharLtOp)
1314     ,(intPrimTy,        IntLtOp)
1315     ,(wordPrimTy,       WordLtOp)
1316     ,(addrPrimTy,       AddrLtOp)
1317     ,(floatPrimTy,      FloatLtOp)
1318     ,(doublePrimTy,     DoubleLtOp)
1319     ]
1320
1321 box_con_tbl =
1322     [(charPrimTy,       getRdrName charDataCon)
1323     ,(intPrimTy,        getRdrName intDataCon)
1324     ,(wordPrimTy,       wordDataCon_RDR)
1325     ,(floatPrimTy,      getRdrName floatDataCon)
1326     ,(doublePrimTy,     getRdrName doubleDataCon)
1327     ]
1328
1329 -----------------------------------------------------------------------
1330
1331 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1332 and_Expr a b = genOpApp a and_RDR    b
1333
1334 -----------------------------------------------------------------------
1335
1336 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1337 eq_Expr tycon ty a b = genOpApp a eq_op b
1338  where
1339    eq_op
1340     | not (isUnLiftedType ty) = eq_RDR
1341     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1342          -- we have to do something special for primitive things...
1343 \end{code}
1344
1345 \begin{code}
1346 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1347 untag_Expr tycon [] expr = expr
1348 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1349   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1350       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1351
1352 cmp_tags_Expr ::  RdrName               -- Comparison op
1353              ->  RdrName ->  RdrName    -- Things to compare
1354              -> LHsExpr RdrName                 -- What to return if true
1355              -> LHsExpr RdrName         -- What to return if false
1356              -> LHsExpr RdrName
1357
1358 cmp_tags_Expr op a b true_case false_case
1359   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1360
1361 enum_from_to_Expr
1362         :: LHsExpr RdrName -> LHsExpr RdrName
1363         -> LHsExpr RdrName
1364 enum_from_then_to_Expr
1365         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1366         -> LHsExpr RdrName
1367
1368 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1369 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1370
1371 showParen_Expr
1372         :: LHsExpr RdrName -> LHsExpr RdrName
1373         -> LHsExpr RdrName
1374
1375 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1376
1377 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1378
1379 nested_compose_Expr [e] = parenify e
1380 nested_compose_Expr (e:es)
1381   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1382
1383 -- impossible_Expr is used in case RHSs that should never happen.
1384 -- We generate these to keep the desugarer from complaining that they *might* happen!
1385 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1386
1387 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1388 -- method. It is currently only used by Enum.{succ,pred}
1389 illegal_Expr meth tp msg =
1390    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1391
1392 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1393 -- to include the value of a_RDR in the error string.
1394 illegal_toEnum_tag tp maxtag =
1395    nlHsApp (nlHsVar error_RDR)
1396            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1397                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1398                     (nlHsApp (nlHsApp (nlHsApp
1399                            (nlHsVar showsPrec_RDR)
1400                            (nlHsIntLit 0))
1401                            (nlHsVar a_RDR))
1402                            (nlHsApp (nlHsApp
1403                                (nlHsVar append_RDR)
1404                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1405                                (nlHsApp (nlHsApp (nlHsApp
1406                                         (nlHsVar showsPrec_RDR)
1407                                         (nlHsIntLit 0))
1408                                         (nlHsVar maxtag))
1409                                         (nlHsLit (mkHsString ")"))))))
1410
1411 parenify e@(L _ (HsVar _)) = e
1412 parenify e                 = mkHsPar e
1413
1414 -- genOpApp wraps brackets round the operator application, so that the
1415 -- renamer won't subsequently try to re-associate it.
1416 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1417 \end{code}
1418
1419 \begin{code}
1420 getSrcSpan = srcLocSpan . getSrcLoc
1421 \end{code}
1422
1423 \begin{code}
1424 a_RDR           = mkVarUnqual FSLIT("a")
1425 b_RDR           = mkVarUnqual FSLIT("b")
1426 c_RDR           = mkVarUnqual FSLIT("c")
1427 d_RDR           = mkVarUnqual FSLIT("d")
1428 k_RDR           = mkVarUnqual FSLIT("k")
1429 z_RDR           = mkVarUnqual FSLIT("z")
1430 ah_RDR          = mkVarUnqual FSLIT("a#")
1431 bh_RDR          = mkVarUnqual FSLIT("b#")
1432 ch_RDR          = mkVarUnqual FSLIT("c#")
1433 dh_RDR          = mkVarUnqual FSLIT("d#")
1434 cmp_eq_RDR      = mkVarUnqual FSLIT("cmp_eq")
1435
1436 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1437 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1438 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1439
1440 a_Expr          = nlHsVar a_RDR
1441 b_Expr          = nlHsVar b_RDR
1442 c_Expr          = nlHsVar c_RDR
1443 ltTag_Expr      = nlHsVar ltTag_RDR
1444 eqTag_Expr      = nlHsVar eqTag_RDR
1445 gtTag_Expr      = nlHsVar gtTag_RDR
1446 false_Expr      = nlHsVar false_RDR
1447 true_Expr       = nlHsVar true_RDR
1448
1449 a_Pat           = nlVarPat a_RDR
1450 b_Pat           = nlVarPat b_RDR
1451 c_Pat           = nlVarPat c_RDR
1452 d_Pat           = nlVarPat d_RDR
1453 k_Pat           = nlVarPat k_RDR
1454 z_Pat           = nlVarPat z_RDR
1455
1456 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon ->  RdrName
1457 -- Generates Orig s RdrName, for the binding positions
1458 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1459 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1460 maxtag_RDR  tycon = mk_tc_deriv_name tycon "maxtag_"
1461
1462 mk_tc_deriv_name tycon str
1463   = mkDerivedRdrName tc_name mk_occ
1464   where
1465     tc_name = tyConName tycon
1466     mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1467                   where
1468                     new_str = str ++ occNameString tc_occ ++ "#"
1469 \end{code}
1470
1471 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1472 PrelNames, so PrelNames can't import PrimOp.
1473
1474 \begin{code}
1475 primOpRdrName op = getRdrName (primOpId op)
1476
1477 minusInt_RDR  = primOpRdrName IntSubOp
1478 eqInt_RDR     = primOpRdrName IntEqOp
1479 ltInt_RDR     = primOpRdrName IntLtOp
1480 geInt_RDR     = primOpRdrName IntGeOp
1481 leInt_RDR     = primOpRdrName IntLeOp
1482 tagToEnum_RDR = primOpRdrName TagToEnumOp
1483
1484 error_RDR = getRdrName eRROR_ID
1485 \end{code}