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