compiler/typecheck/TcGenDeriv.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 TcGenDeriv: Generating derived instance declarations
   7
   8 This module is nominally ``subordinate'' to @TcDeriv@, which is the
   9 ``official'' interface to deriving-related things.
  10
  11 This is where we do all the grimy bindings' generation.
  12
  13 \begin{code}
  14 module TcGenDeriv (
  15         DerivAuxBinds, isDupAux,
  16
  17         gen_Bounded_binds,
  18         gen_Enum_binds,
  19         gen_Eq_binds,
  20         gen_Ix_binds,
  21         gen_Ord_binds,
  22         gen_Read_binds,
  23         gen_Show_binds,
  24         gen_Data_binds,
  25         gen_Typeable_binds,
  26         gen_Functor_binds, functorLikeTraverse, deepSubtypesContaining,
  27         gen_Foldable_binds,
  28         gen_Traversable_binds,
  29         genAuxBind
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import HsSyn
  35 import RdrName
  36 import BasicTypes
  37 import DataCon
  38 import Name
  39
  40 import HscTypes
  41 import PrelInfo
  42 import PrelNames
  43 import MkId
  44 import PrimOp
  45 import SrcLoc
  46 import TyCon
  47 import TcType
  48 import TysPrim
  49 import TysWiredIn
  50 import Type
  51 import TypeRep
  52 import VarSet
  53 import State
  54 import Util
  55 import MonadUtils
  56 import Outputable
  57 import FastString
  58 import OccName
  59 import Bag
  60
  61 import Data.List        ( partition, intersperse )
  62 \end{code}
  63
  64 \begin{code}
  65 type DerivAuxBinds = [DerivAuxBind]
  66
  67 data DerivAuxBind               -- Please add these auxiliary top-level bindings
  68   = GenCon2Tag TyCon            -- The con2Tag for given TyCon
  69   | GenTag2Con TyCon            -- ...ditto tag2Con
  70   | GenMaxTag  TyCon            -- ...and maxTag
  71
  72         -- Scrap your boilerplate
  73   | MkDataCon DataCon           -- For constructor C we get $cC :: Constr
  74   | MkTyCon   TyCon             -- For tycon T we get       $tT :: DataType
  75
  76
  77 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
  78 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
  79 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
  80 isDupAux (GenMaxTag tc1)  (GenMaxTag tc2)  = tc1 == tc2
  81 isDupAux (MkDataCon dc1)  (MkDataCon dc2)  = dc1 == dc2
  82 isDupAux (MkTyCon tc1)    (MkTyCon tc2)    = tc1 == tc2
  83 isDupAux _                _                = False
  84 \end{code}
  85
  86
  87 %************************************************************************
  88 %*                                                                      *
  89                 Eq instances
  90 %*                                                                      *
  91 %************************************************************************
  92
  93 Here are the heuristics for the code we generate for @Eq@:
  94 \begin{itemize}
  95 \item
  96   Let's assume we have a data type with some (possibly zero) nullary
  97   data constructors and some ordinary, non-nullary ones (the rest,
  98   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  99   and \tr{O}rdinary data cons.
 100 \begin{verbatim}
 101 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 102 \end{verbatim}
 103
 104 \item
 105   For the ordinary constructors (if any), we emit clauses to do The
 106   Usual Thing, e.g.,:
 107
 108 \begin{verbatim}
 109 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
 110 (==) (O2 a1)       (O2 a2)       = a1 == a2
 111 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
 112 \end{verbatim}
 113
 114   Note: if we're comparing unlifted things, e.g., if \tr{a1} and
 115   \tr{a2} are \tr{Float#}s, then we have to generate
 116 \begin{verbatim}
 117 case (a1 `eqFloat#` a2) of
 118   r -> r
 119 \end{verbatim}
 120   for that particular test.
 121
 122 \item
 123   If there are any nullary constructors, we emit a catch-all clause of
 124   the form:
 125
 126 \begin{verbatim}
 127 (==) a b  = case (con2tag_Foo a) of { a# ->
 128             case (con2tag_Foo b) of { b# ->
 129             case (a# ==# b#)     of {
 130               r -> r
 131             }}}
 132 \end{verbatim}
 133
 134   If there aren't any nullary constructors, we emit a simpler
 135   catch-all:
 136 \begin{verbatim}
 137 (==) a b  = False
 138 \end{verbatim}
 139
 140 \item
 141   For the @(/=)@ method, we normally just use the default method.
 142
 143   If the type is an enumeration type, we could/may/should? generate
 144   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 145   above.
 146
 147 \item
 148   We thought about doing this: If we're also deriving @Ord@ for this
 149   tycon, we generate:
 150 \begin{verbatim}
 151 instance ... Eq (Foo ...) where
 152   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 153   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 154 \begin{verbatim}
 155   However, that requires that \tr{Ord <whatever>} was put in the context
 156   for the instance decl, which it probably wasn't, so the decls
 157   produced don't get through the typechecker.
 158 \end{itemize}
 159
 160
 161 \begin{code}
 162 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 163 gen_Eq_binds loc tycon
 164   = (method_binds, aux_binds)
 165   where
 166     (nullary_cons, nonnullary_cons)
 167        | isNewTyCon tycon = ([], tyConDataCons tycon)
 168        | otherwise            = partition isNullarySrcDataCon (tyConDataCons tycon)
 169
 170     no_nullary_cons = null nullary_cons
 171
 172     rest | no_nullary_cons
 173          = case tyConSingleDataCon_maybe tycon of
 174                   Just _ -> []
 175                   Nothing -> -- if cons don't match, then False
 176                      [([nlWildPat, nlWildPat], false_Expr)]
 177          | otherwise -- calc. and compare the tags
 178          = [([a_Pat, b_Pat],
 179             untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 180                        (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 181
 182     aux_binds | no_nullary_cons = []
 183               | otherwise       = [GenCon2Tag tycon]
 184
 185     method_binds = listToBag [
 186                         mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
 187                         mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
 188                         nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
 189
 190     ------------------------------------------------------------------
 191     pats_etc data_con
 192       = let
 193             con1_pat = nlConVarPat data_con_RDR as_needed
 194             con2_pat = nlConVarPat data_con_RDR bs_needed
 195
 196             data_con_RDR = getRdrName data_con
 197             con_arity   = length tys_needed
 198             as_needed   = take con_arity as_RDRs
 199             bs_needed   = take con_arity bs_RDRs
 200             tys_needed  = dataConOrigArgTys data_con
 201         in
 202         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 203       where
 204         nested_eq_expr []  [] [] = true_Expr
 205         nested_eq_expr tys as bs
 206           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 207           where
 208             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
 209 \end{code}
 210
 211 %************************************************************************
 212 %*                                                                      *
 213         Ord instances
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 For a derived @Ord@, we concentrate our attentions on @compare@
 218 \begin{verbatim}
 219 compare :: a -> a -> Ordering
 220 data Ordering = LT | EQ | GT deriving ()
 221 \end{verbatim}
 222
 223 We will use the same example data type as above:
 224 \begin{verbatim}
 225 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 226 \end{verbatim}
 227
 228 \begin{itemize}
 229 \item
 230   We do all the other @Ord@ methods with calls to @compare@:
 231 \begin{verbatim}
 232 instance ... (Ord <wurble> <wurble>) where
 233     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 234     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 235     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 236     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 237
 238     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 239     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 240
 241     -- compare to come...
 242 \end{verbatim}
 243
 244 \item
 245   @compare@ always has two parts.  First, we use the compared
 246   data-constructors' tags to deal with the case of different
 247   constructors:
 248 \begin{verbatim}
 249 compare a b = case (con2tag_Foo a) of { a# ->
 250               case (con2tag_Foo b) of { b# ->
 251               case (a# ==# b#)     of {
 252                True  -> cmp_eq a b
 253                False -> case (a# <# b#) of
 254                          True  -> _LT
 255                          False -> _GT
 256               }}}
 257   where
 258     cmp_eq = ... to come ...
 259 \end{verbatim}
 260
 261 \item
 262   We are only left with the ``help'' function @cmp_eq@, to deal with
 263   comparing data constructors with the same tag.
 264
 265   For the ordinary constructors (if any), we emit the sorta-obvious
 266   compare-style stuff; for our example:
 267 \begin{verbatim}
 268 cmp_eq (O1 a1 b1) (O1 a2 b2)
 269   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 270
 271 cmp_eq (O2 a1) (O2 a2)
 272   = compare a1 a2
 273
 274 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 275   = case (compare a1 a2) of {
 276       LT -> LT;
 277       GT -> GT;
 278       EQ -> case compare b1 b2 of {
 279               LT -> LT;
 280               GT -> GT;
 281               EQ -> compare c1 c2
 282             }
 283     }
 284 \end{verbatim}
 285
 286   Again, we must be careful about unlifted comparisons.  For example,
 287   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 288   generate:
 289
 290 \begin{verbatim}
 291 cmp_eq lt eq gt (O2 a1) (O2 a2)
 292   = compareInt# a1 a2
 293   -- or maybe the unfolded equivalent
 294 \end{verbatim}
 295
 296 \item
 297   For the remaining nullary constructors, we already know that the
 298   tags are equal so:
 299 \begin{verbatim}
 300 cmp_eq _ _ = EQ
 301 \end{verbatim}
 302 \end{itemize}
 303
 304 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
 305 JJQC-30-Nov-1997
 306
 307 \begin{code}
 308 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 309
 310 gen_Ord_binds loc tycon
 311   | Just (con, prim_tc) <- primWrapperType_maybe tycon
 312   = gen_PrimOrd_binds con prim_tc
 313
 314   | otherwise
 315   = (unitBag compare, aux_binds)
 316         -- `AndMonoBinds` compare
 317         -- The default declaration in PrelBase handles this
 318   where
 319     aux_binds | single_con_type = []
 320               | otherwise       = [GenCon2Tag tycon]
 321
 322     compare = L loc (mkFunBind (L loc compare_RDR) compare_matches)
 323     compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
 324     cmp_eq_binds    = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
 325
 326     compare_rhs
 327         | single_con_type = cmp_eq_Expr a_Expr b_Expr
 328         | otherwise
 329         = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 330                   (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
 331                         (cmp_eq_Expr a_Expr b_Expr)     -- True case
 332                         -- False case; they aren't equal
 333                         -- So we need to do a less-than comparison on the tags
 334                         (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
 335
 336     tycon_data_cons = tyConDataCons tycon
 337     single_con_type = isSingleton tycon_data_cons
 338     (nullary_cons, nonnullary_cons)
 339        | isNewTyCon tycon = ([], tyConDataCons tycon)
 340        | otherwise        = partition isNullarySrcDataCon tycon_data_cons
 341
 342     cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match
 343     cmp_eq_match
 344       | isEnumerationTyCon tycon
 345                            -- We know the tags are equal, so if it's an enumeration TyCon,
 346                            -- then there is nothing left to do
 347                            -- Catch this specially to avoid warnings
 348                            -- about overlapping patterns from the desugarer,
 349                            -- and to avoid unnecessary pattern-matching
 350       = [([nlWildPat,nlWildPat], eqTag_Expr)]
 351       | otherwise
 352       = map pats_etc nonnullary_cons ++
 353         (if single_con_type then        -- Omit wildcards when there's just one
 354               []                        -- constructor, to silence desugarer
 355         else
 356               [([nlWildPat, nlWildPat], default_rhs)])
 357
 358     default_rhs | null nullary_cons = impossible_Expr   -- Keep desugarer from complaining about
 359                                                         -- inexhaustive patterns
 360                 | otherwise         = eqTag_Expr        -- Some nullary constructors;
 361                                                         -- Tags are equal, no args => return EQ
 362     pats_etc data_con
 363         = ([con1_pat, con2_pat],
 364            nested_compare_expr tys_needed as_needed bs_needed)
 365         where
 366           con1_pat = nlConVarPat data_con_RDR as_needed
 367           con2_pat = nlConVarPat data_con_RDR bs_needed
 368
 369           data_con_RDR = getRdrName data_con
 370           con_arity   = length tys_needed
 371           as_needed   = take con_arity as_RDRs
 372           bs_needed   = take con_arity bs_RDRs
 373           tys_needed  = dataConOrigArgTys data_con
 374
 375           nested_compare_expr [ty] [a] [b]
 376             = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
 377
 378           nested_compare_expr (ty:tys) (a:as) (b:bs)
 379             = let eq_expr = nested_compare_expr tys as bs
 380                 in  careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
 381
 382           nested_compare_expr _ _ _ = panic "nested_compare_expr"       -- Args always equal length
 383 \end{code}
 384
 385 Note [Comparision of primitive types]
 386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 387 The general plan does not work well for data types like
 388         data T = MkT Int# deriving( Ord )
 389 The general plan defines the 'compare' method, gets (<) etc from it.  But
 390 that means we get silly code like:
 391    instance Ord T where
 392      (>) (I# x) (I# y) = case <# x y of
 393                             True -> False
 394                             False -> case ==# x y of
 395                                        True  -> False
 396                                        False -> True
 397 We would prefer to use the (>#) primop.  See also Trac #2130
 398
 399
 400 \begin{code}
 401 gen_PrimOrd_binds :: DataCon -> TyCon ->  (LHsBinds RdrName, DerivAuxBinds)
 402 -- See Note [Comparison of primitive types]
 403 gen_PrimOrd_binds data_con prim_tc
 404   = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
 405                 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
 406   where
 407     mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
 408                                  [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
 409     con_RDR = getRdrName data_con
 410     apat = nlConVarPat con_RDR [a_RDR]
 411     bpat = nlConVarPat con_RDR [b_RDR]
 412
 413     (lt_op, le_op, ge_op, gt_op)
 414        | prim_tc == charPrimTyCon   = (CharLtOp,   CharLeOp,   CharGeOp,   CharGtOp)
 415        | prim_tc == intPrimTyCon    = (IntLtOp,    IntLeOp,    IntGeOp,    IntGtOp)
 416        | prim_tc == wordPrimTyCon   = (WordLtOp,   WordLeOp,   WordGeOp,   WordGtOp)
 417        | prim_tc == addrPrimTyCon   = (AddrLtOp,   AddrLeOp,   AddrGeOp,   AddrGtOp)
 418        | prim_tc == floatPrimTyCon  = (FloatLtOp,  FloatLeOp,  FloatGeOp,  FloatGtOp)
 419        | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
 420        | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
 421
 422
 423 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
 424 -- True of data types that are wrappers around prmitive types
 425 --      data T = MkT Word#
 426 -- For these we want to generate all the (<), (<=) etc operations individually
 427 primWrapperType_maybe tc
 428   | [con] <- tyConDataCons tc
 429   , [ty]  <- dataConOrigArgTys con
 430   , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
 431   , isPrimTyCon prim_tc
 432   = Just (con, prim_tc)
 433   | otherwise
 434   = Nothing
 435 \end{code}
 436
 437 %************************************************************************
 438 %*                                                                      *
 439         Enum instances
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 @Enum@ can only be derived for enumeration types.  For a type
 444 \begin{verbatim}
 445 data Foo ... = N1 | N2 | ... | Nn
 446 \end{verbatim}
 447
 448 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 449 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 450
 451 \begin{verbatim}
 452 instance ... Enum (Foo ...) where
 453     succ x   = toEnum (1 + fromEnum x)
 454     pred x   = toEnum (fromEnum x - 1)
 455
 456     toEnum i = tag2con_Foo i
 457
 458     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 459
 460     -- or, really...
 461     enumFrom a
 462       = case con2tag_Foo a of
 463           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 464
 465    enumFromThen a b
 466      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 467
 468     -- or, really...
 469     enumFromThen a b
 470       = case con2tag_Foo a of { a# ->
 471         case con2tag_Foo b of { b# ->
 472         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 473         }}
 474 \end{verbatim}
 475
 476 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 477
 478 \begin{code}
 479 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 480 gen_Enum_binds loc tycon
 481   = (method_binds, aux_binds)
 482   where
 483     method_binds = listToBag [
 484                         succ_enum,
 485                         pred_enum,
 486                         to_enum,
 487                         enum_from,
 488                         enum_from_then,
 489                         from_enum
 490                     ]
 491     aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
 492
 493     occ_nm = getOccString tycon
 494
 495     succ_enum
 496       = mk_easy_FunBind loc succ_RDR [a_Pat] $
 497         untag_Expr tycon [(a_RDR, ah_RDR)] $
 498         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
 499                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 500              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 501              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 502                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 503                                         nlHsIntLit 1]))
 504
 505     pred_enum
 506       = mk_easy_FunBind loc pred_RDR [a_Pat] $
 507         untag_Expr tycon [(a_RDR, ah_RDR)] $
 508         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
 509                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 510              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 511              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 512                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 513                                                nlHsLit (HsInt (-1))]))
 514
 515     to_enum
 516       = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
 517         nlHsIf (nlHsApps and_RDR
 518                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
 519                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
 520              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
 521              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 522
 523     enum_from
 524       = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
 525           untag_Expr tycon [(a_RDR, ah_RDR)] $
 526           nlHsApps map_RDR
 527                 [nlHsVar (tag2con_RDR tycon),
 528                  nlHsPar (enum_from_to_Expr
 529                             (nlHsVarApps intDataCon_RDR [ah_RDR])
 530                             (nlHsVar (maxtag_RDR tycon)))]
 531
 532     enum_from_then
 533       = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
 534           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 535           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 536             nlHsPar (enum_from_then_to_Expr
 537                     (nlHsVarApps intDataCon_RDR [ah_RDR])
 538                     (nlHsVarApps intDataCon_RDR [bh_RDR])
 539                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 540                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
 541                            (nlHsIntLit 0)
 542                            (nlHsVar (maxtag_RDR tycon))
 543                            ))
 544
 545     from_enum
 546       = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
 547           untag_Expr tycon [(a_RDR, ah_RDR)] $
 548           (nlHsVarApps intDataCon_RDR [ah_RDR])
 549 \end{code}
 550
 551 %************************************************************************
 552 %*                                                                      *
 553         Bounded instances
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 \begin{code}
 558 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 559 gen_Bounded_binds loc tycon
 560   | isEnumerationTyCon tycon
 561   = (listToBag [ min_bound_enum, max_bound_enum ], [])
 562   | otherwise
 563   = ASSERT(isSingleton data_cons)
 564     (listToBag [ min_bound_1con, max_bound_1con ], [])
 565   where
 566     data_cons = tyConDataCons tycon
 567
 568     ----- enum-flavored: ---------------------------
 569     min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
 570     max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
 571
 572     data_con_1    = head data_cons
 573     data_con_N    = last data_cons
 574     data_con_1_RDR = getRdrName data_con_1
 575     data_con_N_RDR = getRdrName data_con_N
 576
 577     ----- single-constructor-flavored: -------------
 578     arity          = dataConSourceArity data_con_1
 579
 580     min_bound_1con = mkVarBind loc minBound_RDR $
 581                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 582     max_bound_1con = mkVarBind loc maxBound_RDR $
 583                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 584 \end{code}
 585
 586 %************************************************************************
 587 %*                                                                      *
 588         Ix instances
 589 %*                                                                      *
 590 %************************************************************************
 591
 592 Deriving @Ix@ is only possible for enumeration types and
 593 single-constructor types.  We deal with them in turn.
 594
 595 For an enumeration type, e.g.,
 596 \begin{verbatim}
 597     data Foo ... = N1 | N2 | ... | Nn
 598 \end{verbatim}
 599 things go not too differently from @Enum@:
 600 \begin{verbatim}
 601 instance ... Ix (Foo ...) where
 602     range (a, b)
 603       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 604
 605     -- or, really...
 606     range (a, b)
 607       = case (con2tag_Foo a) of { a# ->
 608         case (con2tag_Foo b) of { b# ->
 609         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 610         }}
 611
 612     -- Generate code for unsafeIndex, becuase using index leads
 613     -- to lots of redundant range tests
 614     unsafeIndex c@(a, b) d
 615       = case (con2tag_Foo d -# con2tag_Foo a) of
 616                r# -> I# r#
 617
 618     inRange (a, b) c
 619       = let
 620             p_tag = con2tag_Foo c
 621         in
 622         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 623
 624     -- or, really...
 625     inRange (a, b) c
 626       = case (con2tag_Foo a)   of { a_tag ->
 627         case (con2tag_Foo b)   of { b_tag ->
 628         case (con2tag_Foo c)   of { c_tag ->
 629         if (c_tag >=# a_tag) then
 630           c_tag <=# b_tag
 631         else
 632           False
 633         }}}
 634 \end{verbatim}
 635 (modulo suitable case-ification to handle the unlifted tags)
 636
 637 For a single-constructor type (NB: this includes all tuples), e.g.,
 638 \begin{verbatim}
 639     data Foo ... = MkFoo a b Int Double c c
 640 \end{verbatim}
 641 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 642 (p.~147).
 643
 644 \begin{code}
 645 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 646
 647 gen_Ix_binds loc tycon
 648   | isEnumerationTyCon tycon
 649   = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
 650   | otherwise
 651   = (single_con_ixes, [GenCon2Tag tycon])
 652   where
 653     --------------------------------------------------------------
 654     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 655
 656     enum_range
 657       = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
 658           untag_Expr tycon [(a_RDR, ah_RDR)] $
 659           untag_Expr tycon [(b_RDR, bh_RDR)] $
 660           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 661               nlHsPar (enum_from_to_Expr
 662                         (nlHsVarApps intDataCon_RDR [ah_RDR])
 663                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 664
 665     enum_index
 666       = mk_easy_FunBind loc unsafeIndex_RDR
 667                 [noLoc (AsPat (noLoc c_RDR)
 668                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
 669                                 d_Pat] (
 670            untag_Expr tycon [(a_RDR, ah_RDR)] (
 671            untag_Expr tycon [(d_RDR, dh_RDR)] (
 672            let
 673                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
 674            in
 675            nlHsCase
 676              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
 677              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
 678            ))
 679         )
 680
 681     enum_inRange
 682       = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
 683           untag_Expr tycon [(a_RDR, ah_RDR)] (
 684           untag_Expr tycon [(b_RDR, bh_RDR)] (
 685           untag_Expr tycon [(c_RDR, ch_RDR)] (
 686           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
 687              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
 688           ) {-else-} (
 689              false_Expr
 690           ))))
 691
 692     --------------------------------------------------------------
 693     single_con_ixes
 694       = listToBag [single_con_range, single_con_index, single_con_inRange]
 695
 696     data_con
 697       = case tyConSingleDataCon_maybe tycon of -- just checking...
 698           Nothing -> panic "get_Ix_binds"
 699           Just dc -> dc
 700
 701     con_arity    = dataConSourceArity data_con
 702     data_con_RDR = getRdrName data_con
 703
 704     as_needed = take con_arity as_RDRs
 705     bs_needed = take con_arity bs_RDRs
 706     cs_needed = take con_arity cs_RDRs
 707
 708     con_pat  xs  = nlConVarPat data_con_RDR xs
 709     con_expr     = nlHsVarApps data_con_RDR cs_needed
 710
 711     --------------------------------------------------------------
 712     single_con_range
 713       = mk_easy_FunBind loc range_RDR
 714           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
 715         nlHsDo ListComp stmts con_expr
 716       where
 717         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 718
 719         mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
 720                                  (nlHsApp (nlHsVar range_RDR)
 721                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
 722
 723     ----------------
 724     single_con_index
 725       = mk_easy_FunBind loc unsafeIndex_RDR
 726                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 727                  con_pat cs_needed]
 728         -- We need to reverse the order we consider the components in
 729         -- so that
 730         --     range (l,u) !! index (l,u) i == i   -- when i is in range
 731         -- (from http://haskell.org/onlinereport/ix.html) holds.
 732                 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
 733       where
 734         -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
 735         mk_index []        = nlHsIntLit 0
 736         mk_index [(l,u,i)] = mk_one l u i
 737         mk_index ((l,u,i) : rest)
 738           = genOpApp (
 739                 mk_one l u i
 740             ) plus_RDR (
 741                 genOpApp (
 742                     (nlHsApp (nlHsVar unsafeRangeSize_RDR)
 743                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
 744                 ) times_RDR (mk_index rest)
 745            )
 746         mk_one l u i
 747           = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
 748
 749     ------------------
 750     single_con_inRange
 751       = mk_easy_FunBind loc inRange_RDR
 752                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 753                  con_pat cs_needed] $
 754           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
 755       where
 756         in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
 757                                                nlHsVar c]
 758 \end{code}
 759
 760 %************************************************************************
 761 %*                                                                      *
 762         Read instances
 763 %*                                                                      *
 764 %************************************************************************
 765
 766 Example
 767
 768   infix 4 %%
 769   data T = Int %% Int
 770          | T1 { f1 :: Int }
 771          | T2 T
 772
 773
 774 instance Read T where
 775   readPrec =
 776     parens
 777     ( prec 4 (
 778         do x           <- ReadP.step Read.readPrec
 779            Symbol "%%" <- Lex.lex
 780            y           <- ReadP.step Read.readPrec
 781            return (x %% y))
 782       +++
 783       prec (appPrec+1) (
 784         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 785         -- Record construction binds even more tightly than application
 786         do Ident "T1" <- Lex.lex
 787            Punc '{' <- Lex.lex
 788            Ident "f1" <- Lex.lex
 789            Punc '=' <- Lex.lex
 790            x          <- ReadP.reset Read.readPrec
 791            Punc '}' <- Lex.lex
 792            return (T1 { f1 = x }))
 793       +++
 794       prec appPrec (
 795         do Ident "T2" <- Lex.lexP
 796            x          <- ReadP.step Read.readPrec
 797            return (T2 x))
 798     )
 799
 800   readListPrec = readListPrecDefault
 801   readList     = readListDefault
 802
 803
 804 \begin{code}
 805 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 806
 807 gen_Read_binds get_fixity loc tycon
 808   = (listToBag [read_prec, default_readlist, default_readlistprec], [])
 809   where
 810     -----------------------------------------------------------------------
 811     default_readlist
 812         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 813
 814     default_readlistprec
 815         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 816     -----------------------------------------------------------------------
 817
 818     data_cons = tyConDataCons tycon
 819     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 820
 821     read_prec = mkVarBind loc readPrec_RDR
 822                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 823
 824     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 825     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 826
 827     read_nullary_cons
 828       = case nullary_cons of
 829             []    -> []
 830             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
 831                                     (result_expr con [])]
 832             _     -> [nlHsApp (nlHsVar choose_RDR)
 833                               (nlList (map mk_pair nullary_cons))]
 834
 835     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
 836                            result_expr con []]
 837                           Boxed
 838
 839     read_non_nullary_con data_con
 840       | is_infix  = mk_parser infix_prec  infix_stmts  body
 841       | is_record = mk_parser record_prec record_stmts body
 842 --              Using these two lines instead allows the derived
 843 --              read for infix and record bindings to read the prefix form
 844 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 845 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 846       | otherwise = prefix_parser
 847       where
 848         body = result_expr data_con as_needed
 849         con_str = data_con_str data_con
 850
 851         prefix_parser = mk_parser prefix_prec prefix_stmts body
 852
 853         read_prefix_con
 854             | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
 855             | otherwise     = [bindLex (ident_pat con_str)]
 856
 857         read_infix_con
 858             | isSym con_str = [bindLex (symbol_pat con_str)]
 859             | otherwise     = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
 860
 861         prefix_stmts            -- T a b c
 862           = read_prefix_con ++ read_args
 863
 864         infix_stmts             -- a %% b, or  a `T` b
 865           = [read_a1]
 866             ++ read_infix_con
 867             ++ [read_a2]
 868
 869         record_stmts            -- T { f1 = a, f2 = b }
 870           = read_prefix_con
 871             ++ [read_punc "{"]
 872             ++ concat (intersperse [read_punc ","] field_stmts)
 873             ++ [read_punc "}"]
 874
 875         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 876
 877         con_arity    = dataConSourceArity data_con
 878         labels       = dataConFieldLabels data_con
 879         dc_nm        = getName data_con
 880         is_infix     = dataConIsInfix data_con
 881         is_record    = length labels > 0
 882         as_needed    = take con_arity as_RDRs
 883         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 884         (read_a1:read_a2:_) = read_args
 885
 886         prefix_prec = appPrecedence
 887         infix_prec  = getPrecedence get_fixity dc_nm
 888         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 889                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 890
 891     ------------------------------------------------------------------------
 892     --          Helpers
 893     ------------------------------------------------------------------------
 894     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
 895     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
 896     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
 897     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
 898     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
 899
 900     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 901     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 902     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 903
 904     data_con_str con = occNameString (getOccName con)
 905
 906     read_punc c = bindLex (punc_pat c)
 907     read_arg a ty = ASSERT( not (isUnLiftedType ty) )
 908                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 909
 910     read_field lbl a = read_lbl lbl ++
 911                        [read_punc "=",
 912                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 913
 914         -- When reading field labels we might encounter
 915         --      a  = 3
 916         --      _a = 3
 917         -- or   (#) = 4
 918         -- Note the parens!
 919     read_lbl lbl | isSym lbl_str
 920                  = [read_punc "(",
 921                     bindLex (symbol_pat lbl_str),
 922                     read_punc ")"]
 923                  | otherwise
 924                  = [bindLex (ident_pat lbl_str)]
 925                  where
 926                    lbl_str = occNameString (getOccName lbl)
 927 \end{code}
 928
 929
 930 %************************************************************************
 931 %*                                                                      *
 932         Show instances
 933 %*                                                                      *
 934 %************************************************************************
 935
 936 Example
 937
 938     infixr 5 :^:
 939
 940     data Tree a =  Leaf a  |  Tree a :^: Tree a
 941
 942     instance (Show a) => Show (Tree a) where
 943
 944         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 945           where
 946              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 947
 948         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 949           where
 950              showStr = showsPrec (up_prec+1) u .
 951                        showString " :^: "      .
 952                        showsPrec (up_prec+1) v
 953                 -- Note: right-associativity of :^: ignored
 954
 955     up_prec  = 5    -- Precedence of :^:
 956     app_prec = 10   -- Application has precedence one more than
 957                     -- the most tightly-binding operator
 958
 959 \begin{code}
 960 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 961
 962 gen_Show_binds get_fixity loc tycon
 963   = (listToBag [shows_prec, show_list], [])
 964   where
 965     -----------------------------------------------------------------------
 966     show_list = mkVarBind loc showList_RDR
 967                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 968     -----------------------------------------------------------------------
 969     shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 970       where
 971         pats_etc data_con
 972           | nullary_con =  -- skip the showParen junk...
 973              ASSERT(null bs_needed)
 974              ([nlWildPat, con_pat], mk_showString_app con_str)
 975           | otherwise   =
 976              ([a_Pat, con_pat],
 977                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 978                                  (nlHsPar (nested_compose_Expr show_thingies)))
 979             where
 980              data_con_RDR  = getRdrName data_con
 981              con_arity     = dataConSourceArity data_con
 982              bs_needed     = take con_arity bs_RDRs
 983              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 984              con_pat       = nlConVarPat data_con_RDR bs_needed
 985              nullary_con   = con_arity == 0
 986              labels        = dataConFieldLabels data_con
 987              lab_fields    = length labels
 988              record_syntax = lab_fields > 0
 989
 990              dc_nm          = getName data_con
 991              dc_occ_nm      = getOccName data_con
 992              con_str        = occNameString dc_occ_nm
 993              op_con_str     = wrapOpParens con_str
 994              backquote_str  = wrapOpBackquotes con_str
 995
 996              show_thingies
 997                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
 998                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
 999                                   show_record_args ++ [mk_showString_app "}"]
1000                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1001
1002              show_label l = mk_showString_app (nm ++ " = ")
1003                         -- Note the spaces around the "=" sign.  If we don't have them
1004                         -- then we get Foo { x=-1 } and the "=-" parses as a single
1005                         -- lexeme.  Only the space after the '=' is necessary, but
1006                         -- it seems tidier to have them both sides.
1007                  where
1008                    occ_nm   = getOccName l
1009                    nm       = wrapOpParens (occNameString occ_nm)
1010
1011              show_args               = zipWith show_arg bs_needed arg_tys
1012              (show_arg1:show_arg2:_) = show_args
1013              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
1014
1015                 --  Assumption for record syntax: no of fields == no of labelled fields
1016                 --            (and in same order)
1017              show_record_args = concat $
1018                                 intersperse [mk_showString_app ", "] $
1019                                 [ [show_label lbl, arg]
1020                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
1021                                                         labels show_args ]
1022
1023                 -- Generates (showsPrec p x) for argument x, but it also boxes
1024                 -- the argument first if necessary.  Note that this prints unboxed
1025                 -- things without any '#' decorations; could change that if need be
1026              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1027                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1028
1029                 -- Fixity stuff
1030              is_infix = dataConIsInfix data_con
1031              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1032              arg_prec | record_syntax = 0       -- Record fields don't need parens
1033                       | otherwise     = con_prec_plus_one
1034
1035 wrapOpParens :: String -> String
1036 wrapOpParens s | isSym s   = '(' : s ++ ")"
1037                | otherwise = s
1038
1039 wrapOpBackquotes :: String -> String
1040 wrapOpBackquotes s | isSym s   = s
1041                    | otherwise = '`' : s ++ "`"
1042
1043 isSym :: String -> Bool
1044 isSym ""      = False
1045 isSym (c : _) = startsVarSym c || startsConSym c
1046
1047 mk_showString_app :: String -> LHsExpr RdrName
1048 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1049 \end{code}
1050
1051 \begin{code}
1052 getPrec :: Bool -> FixityEnv -> Name -> Integer
1053 getPrec is_infix get_fixity nm
1054   | not is_infix   = appPrecedence
1055   | otherwise      = getPrecedence get_fixity nm
1056
1057 appPrecedence :: Integer
1058 appPrecedence = fromIntegral maxPrecedence + 1
1059   -- One more than the precedence of the most
1060   -- tightly-binding operator
1061
1062 getPrecedence :: FixityEnv -> Name -> Integer
1063 getPrecedence get_fixity nm
1064    = case lookupFixity get_fixity nm of
1065         Fixity x _assoc -> fromIntegral x
1066           -- NB: the Report says that associativity is not taken
1067           --     into account for either Read or Show; hence we
1068           --     ignore associativity here
1069 \end{code}
1070
1071
1072 %************************************************************************
1073 %*                                                                      *
1074 \subsection{Typeable}
1075 %*                                                                      *
1076 %************************************************************************
1077
1078 From the data type
1079
1080         data T a b = ....
1081
1082 we generate
1083
1084         instance Typeable2 T where
1085                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1086
1087 We are passed the Typeable2 class as well as T
1088
1089 \begin{code}
1090 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1091 gen_Typeable_binds loc tycon
1092   = unitBag $
1093         mk_easy_FunBind loc
1094                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1095                 [nlWildPat]
1096                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1097   where
1098     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1099
1100 mk_typeOf_RDR :: TyCon -> RdrName
1101 -- Use the arity of the TyCon to make the right typeOfn function
1102 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1103                 where
1104                   arity = tyConArity tycon
1105                   suffix | arity == 0 = ""
1106                          | otherwise  = show arity
1107 \end{code}
1108
1109
1110
1111 %************************************************************************
1112 %*                                                                      *
1113         Data instances
1114 %*                                                                      *
1115 %************************************************************************
1116
1117 From the data type
1118
1119   data T a b = T1 a b | T2
1120
1121 we generate
1122
1123   $cT1 = mkDataCon $dT "T1" Prefix
1124   $cT2 = mkDataCon $dT "T2" Prefix
1125   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1126   -- the [] is for field labels.
1127
1128   instance (Data a, Data b) => Data (T a b) where
1129     gfoldl k z (T1 a b) = z T `k` a `k` b
1130     gfoldl k z T2           = z T2
1131     -- ToDo: add gmapT,Q,M, gfoldr
1132
1133     gunfold k z c = case conIndex c of
1134                         I# 1# -> k (k (z T1))
1135                         I# 2# -> z T2
1136
1137     toConstr (T1 _ _) = $cT1
1138     toConstr T2       = $cT2
1139
1140     dataTypeOf _ = $dT
1141
1142 \begin{code}
1143 gen_Data_binds :: SrcSpan
1144                -> TyCon
1145                -> (LHsBinds RdrName,    -- The method bindings
1146                    DerivAuxBinds)       -- Auxiliary bindings
1147 gen_Data_binds loc tycon
1148   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1149                 -- Auxiliary definitions: the data type and constructors
1150      MkTyCon tycon : map MkDataCon data_cons)
1151   where
1152     data_cons  = tyConDataCons tycon
1153     n_cons     = length data_cons
1154     one_constr = n_cons == 1
1155
1156         ------------ gfoldl
1157     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1158     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1159                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1160                    where
1161                      con_name ::  RdrName
1162                      con_name = getRdrName con
1163                      as_needed = take (dataConSourceArity con) as_RDRs
1164                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1165
1166         ------------ gunfold
1167     gunfold_bind = mk_FunBind loc
1168                               gunfold_RDR
1169                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1170                                 gunfold_rhs)]
1171
1172     gunfold_rhs
1173         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1174         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1175                                 (map gunfold_alt data_cons)
1176
1177     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1178     mk_unfold_rhs dc = foldr nlHsApp
1179                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1180                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1181
1182     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1183                         -- redundant test, and annoying warning
1184       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1185       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1186       where
1187         tag = dataConTag dc
1188
1189         ------------ toConstr
1190     toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1191     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1192
1193         ------------ dataTypeOf
1194     dataTypeOf_bind = mk_easy_FunBind
1195                         loc
1196                         dataTypeOf_RDR
1197                         [nlWildPat]
1198                         (nlHsVar (mk_data_type_name tycon))
1199
1200
1201 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1202     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName
1203 gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
1204 gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
1205 toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
1206 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1207 mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
1208 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1209 conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
1210 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1211 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1212 \end{code}
1213
1214
1215
1216 %************************************************************************
1217 %*                                                                      *
1218         Functor instances
1219 %*                                                                      *
1220 %************************************************************************
1221
1222 For the data type:
1223
1224   data T a = T1 Int a | T2 (T a)
1225
1226 We generate the instance:
1227
1228   instance Functor T where
1229       fmap f (T1 b1 a) = T1 b1 (f a)
1230       fmap f (T2 ta)   = T2 (fmap f ta)
1231
1232 Notice that we don't simply apply 'fmap' to the constructor arguments.
1233 Rather
1234   - Do nothing to an argument whose type doesn't mention 'a'
1235   - Apply 'f' to an argument of type 'a'
1236   - Apply 'fmap f' to other arguments
1237 That's why we have to recurse deeply into the constructor argument types,
1238 rather than just one level, as we typically do.
1239
1240 What about types with more than one type parameter?  In general, we only
1241 derive Functor for the last position:
1242
1243   data S a b = S1 [b] | S2 (a, T a b)
1244   instance Functor (S a) where
1245     fmap f (S1 bs)    = S1 (fmap f bs)
1246     fmap f (S2 (p,q)) = S2 (a, fmap f q)
1247
1248 However, we have special cases for
1249          - tuples
1250          - functions
1251
1252 More formally, we write the derivation of fmap code over type variable
1253 'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
1254 instance for T is:
1255
1256   instance Functor T where
1257       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1258       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
1259
1260   $(fmap 'a 'b)         x  =  x     -- when b does not contain a
1261   $(fmap 'a 'a)         x  =  f x
1262   $(fmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1263   $(fmap 'a '(T b1 b2)) x  =  fmap $(fmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1264   $(fmap 'a '(b -> c))  x  =  \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1265
1266 For functions, the type parameter 'a can occur in a contravariant position,
1267 which means we need to derive a function like:
1268
1269   cofmap :: (a -> b) -> (f b -> f a)
1270
1271 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1272
1273   $(cofmap 'a 'b)         x  =  x     -- when b does not contain a
1274   $(cofmap 'a 'a)         x  =  error "type variable in contravariant position"
1275   $(cofmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1276   $(cofmap 'a '[b])       x  =  map $(cofmap 'a 'b) x
1277   $(cofmap 'a '(T b1 b2)) x  =  fmap $(cofmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1278   $(cofmap 'a '(b -> c))  x  =  \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1279
1280 \begin{code}
1281 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1282 gen_Functor_binds loc tycon
1283   = (listToBag [fmap_bind], [])
1284   where
1285     data_cons = tyConDataCons tycon
1286     arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
1287
1288     fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1289     fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1290       where parts = map derive_fmap_type (dataConOrigArgTys con)
1291
1292     derive_fmap_type :: Type -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
1293     derive_fmap_type = functorLikeTraverse
1294         (\     x -> return x)                                         -- fmap f x = x
1295         (\     x -> return (nlHsApp f_Expr x))                        -- fmap f x = f x
1296         (panic "contravariant")
1297         (\g h  x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))) -- fmap f x = \b -> h (x (g b))
1298         (mkSimpleTupleCase match_for_con)                             -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1299         (\_ g  x -> do gg <- mkSimpleLam g
1300                        return $ nlHsApps fmap_RDR [gg,x])             -- fmap f x = fmap g x
1301         (panic "in other argument")
1302         (\_ g  x -> g x)
1303         arg
1304
1305     match_for_con = mkSimpleConMatch $
1306         \con_name xsM -> do xs <- sequence xsM
1307                             return (nlHsApps con_name xs)  -- Con (g1 v1) (g2 v2) ..
1308 \end{code}
1309
1310 Utility functions related to Functor deriving.
1311
1312 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1313 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1314
1315 \begin{code}
1316 -- Generic traversal for Functor deriving
1317 functorLikeTraverse :: a                    -- ^ Case: does not contain variable
1318                     -> a                    -- ^ Case: the variable itself
1319                     -> a                    -- ^ Case: the variable itself, contravariantly
1320                     -> (a -> a -> a)        -- ^ Case: function type
1321                     -> (Boxity -> [a] -> a) -- ^ Case: tuple type
1322                     -> (Type -> a -> a)     -- ^ Case: type app, variable only in last argument
1323                     -> a                    -- ^ Case: type app, variable other than in last argument
1324                     -> (TcTyVar -> a -> a)  -- ^ Case: forall type
1325                     -> TcTyVar              -- ^ Variable to look for
1326                     -> Type                 -- ^ Type to process
1327                     -> a
1328 functorLikeTraverse caseTrivial caseVar caseCoVar caseFun caseTuple caseTyApp caseWrongArg caseForAll var ty
1329     = fst (go False ty)
1330   where -- go returns (result of type a, does type contain var)
1331         go co ty | Just ty' <- coreView ty = go co ty'
1332         go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
1333         go co (FunTy (PredTy _) b)      = go co b
1334         go co (FunTy x y)    | xc || yc = (caseFun xr yr,True)
1335             where (xr,xc) = go (not co) x
1336                   (yr,yc) = go co       y
1337         go co (AppTy    x y) | xc = (caseWrongArg,   True)
1338                              | yc = (caseTyApp x yr, True)
1339             where (_, xc) = go co x
1340                   (yr,yc) = go co y
1341         go co ty@(TyConApp con args)
1342                | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1343                | null args        = (caseTrivial,False)  -- T
1344                | or (init xcs)    = (caseWrongArg,True)  -- T (..var..)    ty
1345                | last xcs         =                      -- T (..no var..) ty
1346                                     (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1347             where (xrs,xcs) = unzip (map (go co) args)
1348         go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1349             where (xr,xc) = go co x
1350         go _ _ = (caseTrivial,False)
1351
1352 -- Return all syntactic subterms of ty that contain var somewhere
1353 -- These are the things that should appear in instance constraints
1354 deepSubtypesContaining :: TcTyVar -> TcType -> [TcType]
1355 deepSubtypesContaining = functorLikeTraverse
1356       []
1357       []
1358       (panic "contravariant")
1359       (\x y   -> x ++ y)      -- function
1360       (\_  xs -> concat xs)   -- tuple
1361       (\ty x  -> ty : x)      -- tyapp
1362       (panic "in other argument")
1363       (\v x   -> filter (not . (v `elemVarSet`) . tyVarsOfType) x) -- forall v
1364
1365
1366 -- Make a HsLam using a fresh variable from a State monad
1367 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1368 mkSimpleLam lam = do
1369     (n:names) <- get
1370     put names
1371     body <- lam (nlHsVar n)
1372     return (mkHsLam [nlVarPat n] body)
1373
1374 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1375 mkSimpleLam2 lam = do
1376     (n1:n2:names) <- get
1377     put names
1378     body <- lam (nlHsVar n1) (nlHsVar n2)
1379     return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1380
1381 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1382 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1383 mkSimpleConMatch fold extra_pats con insides = do
1384     let con_name = getRdrName con
1385     let vars_needed = takeList insides as_RDRs
1386     let pat = nlConVarPat con_name vars_needed
1387     rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1388     return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1389
1390 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1391 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1392                   -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1393 mkSimpleTupleCase match_for_con boxity insides x = do
1394     let con = tupleCon boxity (length insides)
1395     match <- match_for_con [] con insides
1396     return $ nlHsCase x [match]
1397 \end{code}
1398
1399
1400 %************************************************************************
1401 %*                                                                      *
1402         Foldable instances
1403 %*                                                                      *
1404 %************************************************************************
1405
1406 Deriving Foldable instances works the same way as Functor instances,
1407 only Foldable instances are not possible for function types at all.
1408 Here the derived instance for the type T above is:
1409
1410   instance Foldable T where
1411       foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1412
1413 The cases are:
1414
1415   $(foldr 'a 'b)         x z  =  z     -- when b does not contain a
1416   $(foldr 'a 'a)         x z  =  f x z
1417   $(foldr 'a '(b1,b2))   x z  =  case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1418   $(foldr 'a '(T b1 b2)) x z  =  foldr $(foldr 'a 'b2) x z  -- when a only occurs in the last parameter, b2
1419
1420 Note that the arguments to the real foldr function are the wrong way around,
1421 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1422
1423 \begin{code}
1424 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1425 gen_Foldable_binds loc tycon
1426   = (listToBag [foldr_bind], [])
1427   where
1428     data_cons = tyConDataCons tycon
1429     arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
1430
1431     foldr_bind = L loc $ mkFunBind (L loc foldr_RDR) (map foldr_eqn data_cons)
1432     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1433       where parts = map derive_foldr_type (dataConOrigArgTys con)
1434
1435     derive_foldr_type :: Type -> LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
1436     derive_foldr_type = functorLikeTraverse
1437         (\     _ z -> return z)                            -- foldr f z x = z
1438         (\     x z -> return (nlHsApps f_RDR [x,z]))       -- foldr f z x = f x z
1439         (panic "function")
1440         (panic "function")
1441         (\b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x)
1442         (\_ g  x z -> do gg <- mkSimpleLam2 g              -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1443                          return $ nlHsApps foldable_foldr_RDR [gg,z,x])
1444         (panic "in other argument")
1445         (\_ g  x z -> g x z)
1446         arg
1447
1448     match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1449 \end{code}
1450
1451
1452 %************************************************************************
1453 %*                                                                      *
1454         Traversable instances
1455 %*                                                                      *
1456 %************************************************************************
1457
1458 Again, Traversable is much like Functor and Foldable.
1459
1460 The cases are:
1461
1462   $(traverse 'a 'b)         x  =  pure x     -- when b does not contain a
1463   $(traverse 'a 'a)         x  =  f x
1464   $(traverse 'a '(b1,b2))   x  =  case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1465   $(traverse 'a '(T b1 b2)) x  =  traverse $(traverse 'a 'b2) x  -- when a only occurs in the last parameter, b2
1466
1467 Note that the generated code is not as efficient as it could be. For instance:
1468
1469   data T a = T Int a  deriving Traversable
1470
1471 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1472 instead of:         traverse f (T x y) = T x <$> f y
1473
1474 \begin{code}
1475 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1476 gen_Traversable_binds loc tycon
1477   = (listToBag [traverse_bind], [])
1478   where
1479     data_cons = tyConDataCons tycon
1480     arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
1481
1482     traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1483     traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1484       where parts = map derive_travese_type (dataConOrigArgTys con)
1485
1486     derive_travese_type :: Type -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
1487     derive_travese_type = functorLikeTraverse
1488         (\     x -> return (nlHsApps pure_RDR [x]))    -- traverse f x = pure x
1489         (\     x -> return (nlHsApps f_RDR [x]))       -- travese f x = f x
1490         (panic "function")
1491         (panic "function")
1492         (mkSimpleTupleCase match_for_con)              -- travese f x z = case x of (a1,a2,..) -> (,,) <$> g1 a1 <*> g2 a2 <*> ..
1493         (\_ g  x -> do gg <- mkSimpleLam g             -- travese f x = travese (\xx -> g xx) x
1494                        return $ nlHsApps traverse_RDR [gg,x])
1495         (panic "in other argument")
1496         (\_ g  x -> g x)
1497         arg
1498
1499     match_for_con = mkSimpleConMatch $
1500         \con_name xsM -> do xs <- sequence xsM
1501                             return (mkApCon (nlHsVar con_name) xs)
1502
1503     -- ((Con <$> x1) <*> x2) <*> ..
1504     mkApCon con []     = nlHsApps pure_RDR [con]
1505     mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1506        where appAp x y = nlHsApps ap_RDR [x,y]
1507 \end{code}
1508
1509
1510
1511 %************************************************************************
1512 %*                                                                      *
1513 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1514 %*                                                                      *
1515 %************************************************************************
1516
1517 \begin{verbatim}
1518 data Foo ... = ...
1519
1520 con2tag_Foo :: Foo ... -> Int#
1521 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1522 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1523 \end{verbatim}
1524
1525 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1526 fiddling around.
1527
1528 \begin{code}
1529 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1530 genAuxBind loc (GenCon2Tag tycon)
1531   | lots_of_constructors
1532   = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1533
1534   | otherwise
1535   = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1536
1537   where
1538     rdr_name = con2tag_RDR tycon
1539
1540     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1541         -- We can't use gerRdrName because that makes an Exact  RdrName
1542         -- and we can't put them in the LocalRdrEnv
1543
1544         -- Give a signature to the bound variable, so
1545         -- that the case expression generated by getTag is
1546         -- monomorphic.  In the push-enter model we get better code.
1547     get_tag_rhs = L loc $ ExprWithTySig
1548                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1549                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1550                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1551
1552     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1553                 `nlHsFunTy`
1554                 nlHsTyVar (getRdrName intPrimTyCon)
1555
1556     lots_of_constructors = tyConFamilySize tycon > 8
1557                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1558                                 -- but we don't do vectored returns any more.
1559
1560     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1561     mk_stuff con = ([nlWildConPat con],
1562                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1563
1564 genAuxBind loc (GenTag2Con tycon)
1565   = mk_FunBind loc rdr_name
1566         [([nlConVarPat intDataCon_RDR [a_RDR]],
1567            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1568                          (nlHsTyVar (getRdrName tycon))))]
1569   where
1570     rdr_name = tag2con_RDR tycon
1571
1572 genAuxBind loc (GenMaxTag tycon)
1573   = mkVarBind loc rdr_name
1574                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1575   where
1576     rdr_name = maxtag_RDR tycon
1577     max_tag =  case (tyConDataCons tycon) of
1578                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1579
1580 genAuxBind loc (MkTyCon tycon)  --  $dT
1581   = mkVarBind loc (mk_data_type_name tycon)
1582                   ( nlHsVar mkDataType_RDR
1583                     `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1584                     `nlHsApp` nlList constrs )
1585   where
1586     constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1587
1588 genAuxBind loc (MkDataCon dc)   --  $cT1 etc
1589   = mkVarBind loc (mk_constr_name dc)
1590                   (nlHsApps mkConstr_RDR constr_args)
1591   where
1592     constr_args
1593        = [ -- nlHsIntLit (toInteger (dataConTag dc)),     -- Tag
1594            nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1595            nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
1596            nlList  labels,                                -- Field labels
1597            nlHsVar fixity]                                -- Fixity
1598
1599     labels   = map (nlHsLit . mkHsString . getOccString)
1600                    (dataConFieldLabels dc)
1601     dc_occ   = getOccName dc
1602     is_infix = isDataSymOcc dc_occ
1603     fixity | is_infix  = infix_RDR
1604            | otherwise = prefix_RDR
1605
1606 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
1607 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1608
1609 mk_constr_name :: DataCon -> RdrName    -- "$cC"
1610 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1611 \end{code}
1612
1613 %************************************************************************
1614 %*                                                                      *
1615 \subsection{Utility bits for generating bindings}
1616 %*                                                                      *
1617 %************************************************************************
1618
1619
1620 ToDo: Better SrcLocs.
1621
1622 \begin{code}
1623 compare_gen_Case ::
1624           LHsExpr RdrName       -- What to do for equality
1625           -> LHsExpr RdrName -> LHsExpr RdrName
1626           -> LHsExpr RdrName
1627 careful_compare_Case :: -- checks for primitive types...
1628           TyCon                 -- The tycon we are deriving for
1629           -> Type
1630           -> LHsExpr RdrName    -- What to do for equality
1631           -> LHsExpr RdrName -> LHsExpr RdrName
1632           -> LHsExpr RdrName
1633
1634 cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1635 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1636         -- Was: compare_gen_Case cmp_eq_RDR
1637
1638 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1639   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1640 compare_gen_Case eq a b                         -- General case
1641   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1642       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1643        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1644        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1645
1646 careful_compare_Case tycon ty eq a b
1647   | not (isUnLiftedType ty)
1648   = compare_gen_Case eq a b
1649   | otherwise      -- We have to do something special for primitive things...
1650   = nlHsIf (genOpApp a relevant_lt_op b)        -- Test (<) first, not (==), becuase the latter
1651            ltTag_Expr                           -- is true less often, so putting it first would
1652                                                 -- mean more tests (dynamically)
1653            (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1654   where
1655     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1656     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1657
1658
1659 box_if_necy :: String           -- The class involved
1660             -> TyCon            -- The tycon involved
1661             -> LHsExpr RdrName  -- The argument
1662             -> Type             -- The argument type
1663             -> LHsExpr RdrName  -- Boxed version of the arg
1664 box_if_necy cls_str tycon arg arg_ty
1665   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1666   | otherwise             = arg
1667   where
1668     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1669
1670 assoc_ty_id :: String           -- The class involved
1671             -> TyCon            -- The tycon involved
1672             -> [(Type,a)]       -- The table
1673             -> Type             -- The type
1674             -> a                -- The result of the lookup
1675 assoc_ty_id cls_str _ tbl ty
1676   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1677                                               text "for primitive type" <+> ppr ty)
1678   | otherwise = head res
1679   where
1680     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1681
1682 eq_op_tbl :: [(Type, PrimOp)]
1683 eq_op_tbl =
1684     [(charPrimTy,       CharEqOp)
1685     ,(intPrimTy,        IntEqOp)
1686     ,(wordPrimTy,       WordEqOp)
1687     ,(addrPrimTy,       AddrEqOp)
1688     ,(floatPrimTy,      FloatEqOp)
1689     ,(doublePrimTy,     DoubleEqOp)
1690     ]
1691
1692 lt_op_tbl :: [(Type, PrimOp)]
1693 lt_op_tbl =
1694     [(charPrimTy,       CharLtOp)
1695     ,(intPrimTy,        IntLtOp)
1696     ,(wordPrimTy,       WordLtOp)
1697     ,(addrPrimTy,       AddrLtOp)
1698     ,(floatPrimTy,      FloatLtOp)
1699     ,(doublePrimTy,     DoubleLtOp)
1700     ]
1701
1702 box_con_tbl :: [(Type, RdrName)]
1703 box_con_tbl =
1704     [(charPrimTy,       getRdrName charDataCon)
1705     ,(intPrimTy,        getRdrName intDataCon)
1706     ,(wordPrimTy,       wordDataCon_RDR)
1707     ,(floatPrimTy,      getRdrName floatDataCon)
1708     ,(doublePrimTy,     getRdrName doubleDataCon)
1709     ]
1710
1711 -----------------------------------------------------------------------
1712
1713 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1714 and_Expr a b = genOpApp a and_RDR    b
1715
1716 -----------------------------------------------------------------------
1717
1718 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1719 eq_Expr tycon ty a b = genOpApp a eq_op b
1720  where
1721    eq_op
1722     | not (isUnLiftedType ty) = eq_RDR
1723     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1724          -- we have to do something special for primitive things...
1725 \end{code}
1726
1727 \begin{code}
1728 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1729 untag_Expr _ [] expr = expr
1730 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1731   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1732       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1733
1734 cmp_tags_Expr ::  RdrName               -- Comparison op
1735              ->  RdrName ->  RdrName    -- Things to compare
1736              -> LHsExpr RdrName                 -- What to return if true
1737              -> LHsExpr RdrName         -- What to return if false
1738              -> LHsExpr RdrName
1739
1740 cmp_tags_Expr op a b true_case false_case
1741   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1742
1743 enum_from_to_Expr
1744         :: LHsExpr RdrName -> LHsExpr RdrName
1745         -> LHsExpr RdrName
1746 enum_from_then_to_Expr
1747         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1748         -> LHsExpr RdrName
1749
1750 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1751 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1752
1753 showParen_Expr
1754         :: LHsExpr RdrName -> LHsExpr RdrName
1755         -> LHsExpr RdrName
1756
1757 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1758
1759 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1760
1761 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1762 nested_compose_Expr [e] = parenify e
1763 nested_compose_Expr (e:es)
1764   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1765
1766 -- impossible_Expr is used in case RHSs that should never happen.
1767 -- We generate these to keep the desugarer from complaining that they *might* happen!
1768 impossible_Expr :: LHsExpr RdrName
1769 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1770
1771 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1772 -- method. It is currently only used by Enum.{succ,pred}
1773 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1774 illegal_Expr meth tp msg =
1775    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1776
1777 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1778 -- to include the value of a_RDR in the error string.
1779 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1780 illegal_toEnum_tag tp maxtag =
1781    nlHsApp (nlHsVar error_RDR)
1782            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1783                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1784                     (nlHsApp (nlHsApp (nlHsApp
1785                            (nlHsVar showsPrec_RDR)
1786                            (nlHsIntLit 0))
1787                            (nlHsVar a_RDR))
1788                            (nlHsApp (nlHsApp
1789                                (nlHsVar append_RDR)
1790                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1791                                (nlHsApp (nlHsApp (nlHsApp
1792                                         (nlHsVar showsPrec_RDR)
1793                                         (nlHsIntLit 0))
1794                                         (nlHsVar maxtag))
1795                                         (nlHsLit (mkHsString ")"))))))
1796
1797 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1798 parenify e@(L _ (HsVar _)) = e
1799 parenify e                 = mkHsPar e
1800
1801 -- genOpApp wraps brackets round the operator application, so that the
1802 -- renamer won't subsequently try to re-associate it.
1803 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1804 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1805 \end{code}
1806
1807 \begin{code}
1808 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR,
1809     cmp_eq_RDR :: RdrName
1810 a_RDR           = mkVarUnqual (fsLit "a")
1811 b_RDR           = mkVarUnqual (fsLit "b")
1812 c_RDR           = mkVarUnqual (fsLit "c")
1813 d_RDR           = mkVarUnqual (fsLit "d")
1814 f_RDR           = mkVarUnqual (fsLit "f")
1815 k_RDR           = mkVarUnqual (fsLit "k")
1816 z_RDR           = mkVarUnqual (fsLit "z")
1817 ah_RDR          = mkVarUnqual (fsLit "a#")
1818 bh_RDR          = mkVarUnqual (fsLit "b#")
1819 ch_RDR          = mkVarUnqual (fsLit "c#")
1820 dh_RDR          = mkVarUnqual (fsLit "d#")
1821 cmp_eq_RDR      = mkVarUnqual (fsLit "cmp_eq")
1822
1823 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1824 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1825 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1826 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1827
1828 a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1829     false_Expr, true_Expr :: LHsExpr RdrName
1830 a_Expr          = nlHsVar a_RDR
1831 b_Expr          = nlHsVar b_RDR
1832 c_Expr          = nlHsVar c_RDR
1833 f_Expr          = nlHsVar f_RDR
1834 z_Expr          = nlHsVar z_RDR
1835 ltTag_Expr      = nlHsVar ltTag_RDR
1836 eqTag_Expr      = nlHsVar eqTag_RDR
1837 gtTag_Expr      = nlHsVar gtTag_RDR
1838 false_Expr      = nlHsVar false_RDR
1839 true_Expr       = nlHsVar true_RDR
1840
1841 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1842 a_Pat           = nlVarPat a_RDR
1843 b_Pat           = nlVarPat b_RDR
1844 c_Pat           = nlVarPat c_RDR
1845 d_Pat           = nlVarPat d_RDR
1846 f_Pat           = nlVarPat f_RDR
1847 k_Pat           = nlVarPat k_RDR
1848 z_Pat           = nlVarPat z_RDR
1849
1850 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1851 -- Generates Orig s RdrName, for the binding positions
1852 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1853 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1854 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1855
1856 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1857 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1858
1859 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1860 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1861 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1862 -- But:  (a) that does not work well for standalone-deriving
1863 --       (b) an unqualified name is just fine, provided it can't clash with user code
1864 \end{code}
1865
1866 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1867 PrelNames, so PrelNames can't import PrimOp.
1868
1869 \begin{code}
1870 primOpRdrName :: PrimOp -> RdrName
1871 primOpRdrName op = getRdrName (primOpId op)
1872
1873 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
1874     tagToEnum_RDR :: RdrName
1875 minusInt_RDR  = primOpRdrName IntSubOp
1876 eqInt_RDR     = primOpRdrName IntEqOp
1877 ltInt_RDR     = primOpRdrName IntLtOp
1878 geInt_RDR     = primOpRdrName IntGeOp
1879 leInt_RDR     = primOpRdrName IntLeOp
1880 tagToEnum_RDR = primOpRdrName TagToEnumOp
1881
1882 error_RDR :: RdrName
1883 error_RDR = getRdrName eRROR_ID
1884 \end{code}