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