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 :: RdrName
1292 gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
1293 gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
1294 toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
1295 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1296 dataCast1_RDR  = varQual_RDR gENERICS (fsLit "dataCast1")
1297 dataCast2_RDR  = varQual_RDR gENERICS (fsLit "dataCast2")
1298 gcast1_RDR     = varQual_RDR tYPEABLE (fsLit "gcast1")
1299 gcast2_RDR     = varQual_RDR tYPEABLE (fsLit "gcast2")
1300 mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
1301 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1302 conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
1303 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1304 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1305 \end{code}
1306
1307
1308
1309 %************************************************************************
1310 %*                                                                      *
1311                         Functor instances
1312
1313  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1314
1315 %*                                                                      *
1316 %************************************************************************
1317
1318 For the data type:
1319
1320   data T a = T1 Int a | T2 (T a)
1321
1322 We generate the instance:
1323
1324   instance Functor T where
1325       fmap f (T1 b1 a) = T1 b1 (f a)
1326       fmap f (T2 ta)   = T2 (fmap f ta)
1327
1328 Notice that we don't simply apply 'fmap' to the constructor arguments.
1329 Rather
1330   - Do nothing to an argument whose type doesn't mention 'a'
1331   - Apply 'f' to an argument of type 'a'
1332   - Apply 'fmap f' to other arguments
1333 That's why we have to recurse deeply into the constructor argument types,
1334 rather than just one level, as we typically do.
1335
1336 What about types with more than one type parameter?  In general, we only
1337 derive Functor for the last position:
1338
1339   data S a b = S1 [b] | S2 (a, T a b)
1340   instance Functor (S a) where
1341     fmap f (S1 bs)    = S1 (fmap f bs)
1342     fmap f (S2 (p,q)) = S2 (a, fmap f q)
1343
1344 However, we have special cases for
1345          - tuples
1346          - functions
1347
1348 More formally, we write the derivation of fmap code over type variable
1349 'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
1350 instance for T is:
1351
1352   instance Functor T where
1353       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1354       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
1355
1356   $(fmap 'a 'b)         x  =  x     -- when b does not contain a
1357   $(fmap 'a 'a)         x  =  f x
1358   $(fmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1359   $(fmap 'a '(T b1 b2)) x  =  fmap $(fmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1360   $(fmap 'a '(b -> c))  x  =  \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1361
1362 For functions, the type parameter 'a can occur in a contravariant position,
1363 which means we need to derive a function like:
1364
1365   cofmap :: (a -> b) -> (f b -> f a)
1366
1367 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1368
1369   $(cofmap 'a 'b)         x  =  x     -- when b does not contain a
1370   $(cofmap 'a 'a)         x  =  error "type variable in contravariant position"
1371   $(cofmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1372   $(cofmap 'a '[b])       x  =  map $(cofmap 'a 'b) x
1373   $(cofmap 'a '(T b1 b2)) x  =  fmap $(cofmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1374   $(cofmap 'a '(b -> c))  x  =  \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1375
1376 \begin{code}
1377 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1378 gen_Functor_binds loc tycon
1379   = (unitBag fmap_bind, [])
1380   where
1381     data_cons = tyConDataCons tycon
1382
1383     fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1384     fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1385       where
1386         parts = foldDataConArgs ft_fmap con
1387
1388     ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1389     -- Tricky higher order type; I can't say I fully understand this code :-(
1390     ft_fmap = FT { ft_triv = \x -> return x                    -- fmap f x = x
1391                  , ft_var  = \x -> return (nlHsApp f_Expr x)   -- fmap f x = f x
1392                  , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1393                                                                -- fmap f x = \b -> h (x (g b))
1394                  , ft_tup = mkSimpleTupleCase match_for_con    -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1395                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g      -- fmap f x = fmap g x
1396                                              return $ nlHsApps fmap_RDR [gg,x]
1397                  , ft_forall = \_ g  x -> g x
1398                  , ft_bad_app = panic "in other argument"
1399                  , ft_co_var = panic "contravariant" }
1400
1401     match_for_con = mkSimpleConMatch $
1402         \con_name xsM -> do xs <- sequence xsM
1403                             return (nlHsApps con_name xs)  -- Con (g1 v1) (g2 v2) ..
1404 \end{code}
1405
1406 Utility functions related to Functor deriving.
1407
1408 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1409 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1410
1411 \begin{code}
1412 -- Generic traversal for Functor deriving
1413 data FFoldType a      -- Describes how to fold over a Type in a functor like way
1414    = FT { ft_triv    :: a                   -- Does not contain variable
1415         , ft_var     :: a                   -- The variable itself
1416         , ft_co_var  :: a                   -- The variable itself, contravariantly
1417         , ft_fun     :: a -> a -> a         -- Function type
1418         , ft_tup     :: Boxity -> [a] -> a  -- Tuple type
1419         , ft_ty_app  :: Type -> a -> a      -- Type app, variable only in last argument
1420         , ft_bad_app :: a                   -- Type app, variable other than in last argument
1421         , ft_forall  :: TcTyVar -> a -> a   -- Forall type
1422      }
1423
1424 functorLikeTraverse :: TyVar         -- ^ Variable to look for
1425                     -> FFoldType a   -- ^ How to fold
1426                     -> Type          -- ^ Type to process
1427                     -> a
1428 functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
1429                             , ft_co_var = caseCoVar,     ft_fun = caseFun
1430                             , ft_tup = caseTuple,        ft_ty_app = caseTyApp
1431                             , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1432                     ty
1433   = fst (go False ty)
1434   where -- go returns (result of type a, does type contain var)
1435         go co ty | Just ty' <- coreView ty = go co ty'
1436         go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
1437         go co (FunTy (PredTy _) b)      = go co b
1438         go co (FunTy x y)    | xc || yc = (caseFun xr yr,True)
1439             where (xr,xc) = go (not co) x
1440                   (yr,yc) = go co       y
1441         go co (AppTy    x y) | xc = (caseWrongArg,   True)
1442                              | yc = (caseTyApp x yr, True)
1443             where (_, xc) = go co x
1444                   (yr,yc) = go co y
1445         go co ty@(TyConApp con args)
1446                | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1447                | null args        = (caseTrivial,False)  -- T
1448                | or (init xcs)    = (caseWrongArg,True)  -- T (..var..)    ty
1449                | last xcs         =                      -- T (..no var..) ty
1450                                     (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1451             where (xrs,xcs) = unzip (map (go co) args)
1452         go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1453             where (xr,xc) = go co x
1454         go _ _ = (caseTrivial,False)
1455
1456 -- Return all syntactic subterms of ty that contain var somewhere
1457 -- These are the things that should appear in instance constraints
1458 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1459 deepSubtypesContaining tv
1460   = functorLikeTraverse tv
1461         (FT { ft_triv = []
1462             , ft_var = []
1463             , ft_fun = (++), ft_tup = \_ xs -> concat xs
1464             , ft_ty_app = (:)
1465             , ft_bad_app = panic "in other argument"
1466             , ft_co_var = panic "contravariant"
1467             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1468
1469
1470 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1471 -- Fold over the arguments of the datacon
1472 foldDataConArgs ft con
1473   = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1474   where
1475     tv = last (dataConUnivTyVars con)
1476                     -- Argument to derive for, 'a in the above description
1477                     -- The validity checks have ensured that con is
1478                     -- a vanilla data constructor
1479
1480 -- Make a HsLam using a fresh variable from a State monad
1481 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1482 -- (mkSimpleLam fn) returns (\x. fn(x))
1483 mkSimpleLam lam = do
1484     (n:names) <- get
1485     put names
1486     body <- lam (nlHsVar n)
1487     return (mkHsLam [nlVarPat n] body)
1488
1489 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1490 mkSimpleLam2 lam = do
1491     (n1:n2:names) <- get
1492     put names
1493     body <- lam (nlHsVar n1) (nlHsVar n2)
1494     return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1495
1496 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1497 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1498 mkSimpleConMatch fold extra_pats con insides = do
1499     let con_name = getRdrName con
1500     let vars_needed = takeList insides as_RDRs
1501     let pat = nlConVarPat con_name vars_needed
1502     rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1503     return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1504
1505 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1506 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1507                   -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1508 mkSimpleTupleCase match_for_con boxity insides x = do
1509     let con = tupleCon boxity (length insides)
1510     match <- match_for_con [] con insides
1511     return $ nlHsCase x [match]
1512 \end{code}
1513
1514
1515 %************************************************************************
1516 %*                                                                      *
1517                         Foldable instances
1518
1519  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1520
1521 %*                                                                      *
1522 %************************************************************************
1523
1524 Deriving Foldable instances works the same way as Functor instances,
1525 only Foldable instances are not possible for function types at all.
1526 Here the derived instance for the type T above is:
1527
1528   instance Foldable T where
1529       foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1530
1531 The cases are:
1532
1533   $(foldr 'a 'b)         x z  =  z     -- when b does not contain a
1534   $(foldr 'a 'a)         x z  =  f x z
1535   $(foldr 'a '(b1,b2))   x z  =  case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1536   $(foldr 'a '(T b1 b2)) x z  =  foldr $(foldr 'a 'b2) x z  -- when a only occurs in the last parameter, b2
1537
1538 Note that the arguments to the real foldr function are the wrong way around,
1539 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1540
1541 \begin{code}
1542 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1543 gen_Foldable_binds loc tycon
1544   = (unitBag foldr_bind, [])
1545   where
1546     data_cons = tyConDataCons tycon
1547
1548     foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
1549     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1550       where
1551         parts = foldDataConArgs ft_foldr con
1552
1553     ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1554     ft_foldr = FT { ft_triv = \_ z -> return z                        -- foldr f z x = z
1555                   , ft_var  = \x z -> return (nlHsApps f_RDR [x,z])   -- foldr f z x = f x z
1556                   , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1557                   , ft_ty_app = \_ g  x z -> do gg <- mkSimpleLam2 g   -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1558                                                 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1559                   , ft_forall = \_ g  x z -> g x z
1560                   , ft_co_var = panic "covariant"
1561                   , ft_fun = panic "function"
1562                   , ft_bad_app = panic "in other argument" }
1563
1564     match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1565 \end{code}
1566
1567
1568 %************************************************************************
1569 %*                                                                      *
1570                         Traversable instances
1571
1572  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1573 %*                                                                      *
1574 %************************************************************************
1575
1576 Again, Traversable is much like Functor and Foldable.
1577
1578 The cases are:
1579
1580   $(traverse 'a 'b)         x  =  pure x     -- when b does not contain a
1581   $(traverse 'a 'a)         x  =  f x
1582   $(traverse 'a '(b1,b2))   x  =  case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1583   $(traverse 'a '(T b1 b2)) x  =  traverse $(traverse 'a 'b2) x  -- when a only occurs in the last parameter, b2
1584
1585 Note that the generated code is not as efficient as it could be. For instance:
1586
1587   data T a = T Int a  deriving Traversable
1588
1589 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1590 instead of:         traverse f (T x y) = T x <$> f y
1591
1592 \begin{code}
1593 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1594 gen_Traversable_binds loc tycon
1595   = (unitBag traverse_bind, [])
1596   where
1597     data_cons = tyConDataCons tycon
1598
1599     traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1600     traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1601       where
1602         parts = foldDataConArgs ft_trav con
1603
1604
1605     ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1606     ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x])   -- traverse f x = pure x
1607                  , ft_var = \x -> return (nlHsApps f_RDR [x])       -- travese f x = f x
1608                  , ft_tup = mkSimpleTupleCase match_for_con         -- travese f x z = case x of (a1,a2,..) ->
1609                                                                     --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
1610                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g    -- travese f x = travese (\xx -> g xx) x
1611                                              return $ nlHsApps traverse_RDR [gg,x]
1612                  , ft_forall = \_ g  x -> g x
1613                  , ft_co_var = panic "covariant"
1614                  , ft_fun = panic "function"
1615                  , ft_bad_app = panic "in other argument" }
1616
1617     match_for_con = mkSimpleConMatch $
1618         \con_name xsM -> do xs <- sequence xsM
1619                             return (mkApCon (nlHsVar con_name) xs)
1620
1621     -- ((Con <$> x1) <*> x2) <*> ..
1622     mkApCon con []     = nlHsApps pure_RDR [con]
1623     mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1624        where appAp x y = nlHsApps ap_RDR [x,y]
1625 \end{code}
1626
1627
1628
1629 %************************************************************************
1630 %*                                                                      *
1631 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1632 %*                                                                      *
1633 %************************************************************************
1634
1635 \begin{verbatim}
1636 data Foo ... = ...
1637
1638 con2tag_Foo :: Foo ... -> Int#
1639 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1640 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1641 \end{verbatim}
1642
1643 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1644 fiddling around.
1645
1646 \begin{code}
1647 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1648 genAuxBind loc (GenCon2Tag tycon)
1649   | lots_of_constructors
1650   = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1651
1652   | otherwise
1653   = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1654
1655   where
1656     rdr_name = con2tag_RDR tycon
1657
1658     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1659         -- We can't use gerRdrName because that makes an Exact  RdrName
1660         -- and we can't put them in the LocalRdrEnv
1661
1662         -- Give a signature to the bound variable, so
1663         -- that the case expression generated by getTag is
1664         -- monomorphic.  In the push-enter model we get better code.
1665     get_tag_rhs = L loc $ ExprWithTySig
1666                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1667                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1668                         (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs))
1669                                                      (noLoc []) con2tag_ty))
1670
1671     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1672                 `nlHsFunTy`
1673                 nlHsTyVar (getRdrName intPrimTyCon)
1674
1675     lots_of_constructors = tyConFamilySize tycon > 8
1676                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1677                                 -- but we don't do vectored returns any more.
1678
1679     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1680     mk_stuff con = ([nlWildConPat con],
1681                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1682
1683 genAuxBind loc (GenTag2Con tycon)
1684   = mk_FunBind loc rdr_name
1685         [([nlConVarPat intDataCon_RDR [a_RDR]],
1686            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1687                          (nlHsTyVar (getRdrName tycon))))]
1688   where
1689     rdr_name = tag2con_RDR tycon
1690
1691 genAuxBind loc (GenMaxTag tycon)
1692   = mkHsVarBind loc rdr_name
1693                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1694   where
1695     rdr_name = maxtag_RDR tycon
1696     max_tag =  case (tyConDataCons tycon) of
1697                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1698
1699 genAuxBind loc (MkTyCon tycon)  --  $dT
1700   = mkHsVarBind loc (mk_data_type_name tycon)
1701                     ( nlHsVar mkDataType_RDR
1702                     `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1703                     `nlHsApp` nlList constrs )
1704   where
1705     constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1706
1707 genAuxBind loc (MkDataCon dc)   --  $cT1 etc
1708   = mkHsVarBind loc (mk_constr_name dc)
1709                     (nlHsApps mkConstr_RDR constr_args)
1710   where
1711     constr_args
1712        = [ -- nlHsIntLit (toInteger (dataConTag dc)),     -- Tag
1713            nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1714            nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
1715            nlList  labels,                                -- Field labels
1716            nlHsVar fixity]                                -- Fixity
1717
1718     labels   = map (nlHsLit . mkHsString . getOccString)
1719                    (dataConFieldLabels dc)
1720     dc_occ   = getOccName dc
1721     is_infix = isDataSymOcc dc_occ
1722     fixity | is_infix  = infix_RDR
1723            | otherwise = prefix_RDR
1724
1725 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
1726 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1727
1728 mk_constr_name :: DataCon -> RdrName    -- "$cC"
1729 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1730 \end{code}
1731
1732 %************************************************************************
1733 %*                                                                      *
1734 \subsection{Utility bits for generating bindings}
1735 %*                                                                      *
1736 %************************************************************************
1737
1738
1739 ToDo: Better SrcLocs.
1740
1741 \begin{code}
1742 box_if_necy :: String           -- The class involved
1743             -> TyCon            -- The tycon involved
1744             -> LHsExpr RdrName  -- The argument
1745             -> Type             -- The argument type
1746             -> LHsExpr RdrName  -- Boxed version of the arg
1747 box_if_necy cls_str tycon arg arg_ty
1748   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1749   | otherwise             = arg
1750   where
1751     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1752
1753 ---------------------
1754 primOrdOps :: String    -- The class involved
1755            -> TyCon     -- The tycon involved
1756            -> Type      -- The type
1757            -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp)  -- (lt,le,eq,ge,gt)
1758 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1759
1760 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1761 ord_op_tbl
1762  =  [(charPrimTy,       (CharLtOp,   CharLeOp,   CharEqOp,   CharGeOp,   CharGtOp))
1763     ,(intPrimTy,        (IntLtOp,    IntLeOp,    IntEqOp,    IntGeOp,    IntGtOp))
1764     ,(wordPrimTy,       (WordLtOp,   WordLeOp,   WordEqOp,   WordGeOp,   WordGtOp))
1765     ,(addrPrimTy,       (AddrLtOp,   AddrLeOp,   AddrEqOp,   AddrGeOp,   AddrGtOp))
1766     ,(floatPrimTy,      (FloatLtOp,  FloatLeOp,  FloatEqOp,  FloatGeOp,  FloatGtOp))
1767     ,(doublePrimTy,     (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1768
1769 box_con_tbl :: [(Type, RdrName)]
1770 box_con_tbl =
1771     [(charPrimTy,       getRdrName charDataCon)
1772     ,(intPrimTy,        getRdrName intDataCon)
1773     ,(wordPrimTy,       wordDataCon_RDR)
1774     ,(floatPrimTy,      getRdrName floatDataCon)
1775     ,(doublePrimTy,     getRdrName doubleDataCon)
1776     ]
1777
1778 assoc_ty_id :: String           -- The class involved
1779             -> TyCon            -- The tycon involved
1780             -> [(Type,a)]       -- The table
1781             -> Type             -- The type
1782             -> a                -- The result of the lookup
1783 assoc_ty_id cls_str _ tbl ty
1784   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1785                                               text "for primitive type" <+> ppr ty)
1786   | otherwise = head res
1787   where
1788     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1789
1790 -----------------------------------------------------------------------
1791
1792 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1793 and_Expr a b = genOpApp a and_RDR    b
1794
1795 -----------------------------------------------------------------------
1796
1797 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1798 eq_Expr tycon ty a b = genOpApp a eq_op b
1799  where
1800    eq_op | not (isUnLiftedType ty) = eq_RDR
1801          | otherwise               = primOpRdrName prim_eq
1802    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1803 \end{code}
1804
1805 \begin{code}
1806 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1807 untag_Expr _ [] expr = expr
1808 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1809   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1810       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1811
1812 enum_from_to_Expr
1813         :: LHsExpr RdrName -> LHsExpr RdrName
1814         -> LHsExpr RdrName
1815 enum_from_then_to_Expr
1816         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1817         -> LHsExpr RdrName
1818
1819 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1820 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1821
1822 showParen_Expr
1823         :: LHsExpr RdrName -> LHsExpr RdrName
1824         -> LHsExpr RdrName
1825
1826 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1827
1828 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1829
1830 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1831 nested_compose_Expr [e] = parenify e
1832 nested_compose_Expr (e:es)
1833   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1834
1835 -- impossible_Expr is used in case RHSs that should never happen.
1836 -- We generate these to keep the desugarer from complaining that they *might* happen!
1837 -- impossible_Expr :: LHsExpr RdrName
1838 -- impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1839
1840 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1841 -- method. It is currently only used by Enum.{succ,pred}
1842 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1843 illegal_Expr meth tp msg =
1844    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1845
1846 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1847 -- to include the value of a_RDR in the error string.
1848 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1849 illegal_toEnum_tag tp maxtag =
1850    nlHsApp (nlHsVar error_RDR)
1851            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1852                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1853                     (nlHsApp (nlHsApp (nlHsApp
1854                            (nlHsVar showsPrec_RDR)
1855                            (nlHsIntLit 0))
1856                            (nlHsVar a_RDR))
1857                            (nlHsApp (nlHsApp
1858                                (nlHsVar append_RDR)
1859                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1860                                (nlHsApp (nlHsApp (nlHsApp
1861                                         (nlHsVar showsPrec_RDR)
1862                                         (nlHsIntLit 0))
1863                                         (nlHsVar maxtag))
1864                                         (nlHsLit (mkHsString ")"))))))
1865
1866 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1867 parenify e@(L _ (HsVar _)) = e
1868 parenify e                 = mkHsPar e
1869
1870 -- genOpApp wraps brackets round the operator application, so that the
1871 -- renamer won't subsequently try to re-associate it.
1872 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1873 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1874 \end{code}
1875
1876 \begin{code}
1877 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1878     :: RdrName
1879 a_RDR           = mkVarUnqual (fsLit "a")
1880 b_RDR           = mkVarUnqual (fsLit "b")
1881 c_RDR           = mkVarUnqual (fsLit "c")
1882 d_RDR           = mkVarUnqual (fsLit "d")
1883 f_RDR           = mkVarUnqual (fsLit "f")
1884 k_RDR           = mkVarUnqual (fsLit "k")
1885 z_RDR           = mkVarUnqual (fsLit "z")
1886 ah_RDR          = mkVarUnqual (fsLit "a#")
1887 bh_RDR          = mkVarUnqual (fsLit "b#")
1888 ch_RDR          = mkVarUnqual (fsLit "c#")
1889 dh_RDR          = mkVarUnqual (fsLit "d#")
1890
1891 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1892 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1893 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1894 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1895
1896 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1897     false_Expr, true_Expr :: LHsExpr RdrName
1898 a_Expr          = nlHsVar a_RDR
1899 -- b_Expr       = nlHsVar b_RDR
1900 c_Expr          = nlHsVar c_RDR
1901 f_Expr          = nlHsVar f_RDR
1902 z_Expr          = nlHsVar z_RDR
1903 ltTag_Expr      = nlHsVar ltTag_RDR
1904 eqTag_Expr      = nlHsVar eqTag_RDR
1905 gtTag_Expr      = nlHsVar gtTag_RDR
1906 false_Expr      = nlHsVar false_RDR
1907 true_Expr       = nlHsVar true_RDR
1908
1909 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1910 a_Pat           = nlVarPat a_RDR
1911 b_Pat           = nlVarPat b_RDR
1912 c_Pat           = nlVarPat c_RDR
1913 d_Pat           = nlVarPat d_RDR
1914 f_Pat           = nlVarPat f_RDR
1915 k_Pat           = nlVarPat k_RDR
1916 z_Pat           = nlVarPat z_RDR
1917
1918 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1919 -- Generates Orig s RdrName, for the binding positions
1920 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1921 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1922 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1923
1924 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1925 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1926
1927 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1928 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1929 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1930 -- But:  (a) that does not work well for standalone-deriving
1931 --       (b) an unqualified name is just fine, provided it can't clash with user code
1932 \end{code}
1933
1934 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1935 PrelNames, so PrelNames can't import PrimOp.
1936
1937 \begin{code}
1938 primOpRdrName :: PrimOp -> RdrName
1939 primOpRdrName op = getRdrName (primOpId op)
1940
1941 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1942     tagToEnum_RDR :: RdrName
1943 minusInt_RDR  = primOpRdrName IntSubOp
1944 eqInt_RDR     = primOpRdrName IntEqOp
1945 ltInt_RDR     = primOpRdrName IntLtOp
1946 geInt_RDR     = primOpRdrName IntGeOp
1947 gtInt_RDR     = primOpRdrName IntGtOp
1948 leInt_RDR     = primOpRdrName IntLeOp
1949 tagToEnum_RDR = primOpRdrName TagToEnumOp
1950
1951 error_RDR :: RdrName
1952 error_RDR = getRdrName eRROR_ID
1953 \end{code}