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 (ident_pat (data_con_str con))]
 893                                     (result_expr con [])]
 894             _     -> [nlHsApp (nlHsVar choose_RDR)
 895                               (nlList (map mk_pair nullary_cons))]
 896
 897     mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
 898                                   result_expr con []]
 899
 900     read_non_nullary_con data_con
 901       | is_infix  = mk_parser infix_prec  infix_stmts  body
 902       | is_record = mk_parser record_prec record_stmts body
 903 --              Using these two lines instead allows the derived
 904 --              read for infix and record bindings to read the prefix form
 905 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 906 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 907       | otherwise = prefix_parser
 908       where
 909         body = result_expr data_con as_needed
 910         con_str = data_con_str data_con
 911
 912         prefix_parser = mk_parser prefix_prec prefix_stmts body
 913
 914         read_prefix_con
 915             | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
 916             | otherwise     = [bindLex (ident_pat con_str)]
 917
 918         read_infix_con
 919             | isSym con_str = [bindLex (symbol_pat con_str)]
 920             | otherwise     = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
 921
 922         prefix_stmts            -- T a b c
 923           = read_prefix_con ++ read_args
 924
 925         infix_stmts             -- a %% b, or  a `T` b
 926           = [read_a1]
 927             ++ read_infix_con
 928             ++ [read_a2]
 929
 930         record_stmts            -- T { f1 = a, f2 = b }
 931           = read_prefix_con
 932             ++ [read_punc "{"]
 933             ++ concat (intersperse [read_punc ","] field_stmts)
 934             ++ [read_punc "}"]
 935
 936         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 937
 938         con_arity    = dataConSourceArity data_con
 939         labels       = dataConFieldLabels data_con
 940         dc_nm        = getName data_con
 941         is_infix     = dataConIsInfix data_con
 942         is_record    = length labels > 0
 943         as_needed    = take con_arity as_RDRs
 944         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 945         (read_a1:read_a2:_) = read_args
 946
 947         prefix_prec = appPrecedence
 948         infix_prec  = getPrecedence get_fixity dc_nm
 949         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 950                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 951
 952     ------------------------------------------------------------------------
 953     --          Helpers
 954     ------------------------------------------------------------------------
 955     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
 956     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
 957     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
 958     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
 959     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
 960
 961     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 962     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 963     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 964
 965     data_con_str con = occNameString (getOccName con)
 966
 967     read_punc c = bindLex (punc_pat c)
 968     read_arg a ty = ASSERT( not (isUnLiftedType ty) )
 969                     noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 970
 971     read_field lbl a = read_lbl lbl ++
 972                        [read_punc "=",
 973                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 974
 975         -- When reading field labels we might encounter
 976         --      a  = 3
 977         --      _a = 3
 978         -- or   (#) = 4
 979         -- Note the parens!
 980     read_lbl lbl | isSym lbl_str
 981                  = [read_punc "(",
 982                     bindLex (symbol_pat lbl_str),
 983                     read_punc ")"]
 984                  | otherwise
 985                  = [bindLex (ident_pat lbl_str)]
 986                  where
 987                    lbl_str = occNameString (getOccName lbl)
 988 \end{code}
 989
 990
 991 %************************************************************************
 992 %*                                                                      *
 993         Show instances
 994 %*                                                                      *
 995 %************************************************************************
 996
 997 Example
 998
 999     infixr 5 :^:
1000
1001     data Tree a =  Leaf a  |  Tree a :^: Tree a
1002
1003     instance (Show a) => Show (Tree a) where
1004
1005         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1006           where
1007              showStr = showString "Leaf " . showsPrec (app_prec+1) m
1008
1009         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1010           where
1011              showStr = showsPrec (up_prec+1) u .
1012                        showString " :^: "      .
1013                        showsPrec (up_prec+1) v
1014                 -- Note: right-associativity of :^: ignored
1015
1016     up_prec  = 5    -- Precedence of :^:
1017     app_prec = 10   -- Application has precedence one more than
1018                     -- the most tightly-binding operator
1019
1020 \begin{code}
1021 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1022
1023 gen_Show_binds get_fixity loc tycon
1024   = (listToBag [shows_prec, show_list], [])
1025   where
1026     -----------------------------------------------------------------------
1027     show_list = mkHsVarBind loc showList_RDR
1028                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1029     -----------------------------------------------------------------------
1030     shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
1031       where
1032         pats_etc data_con
1033           | nullary_con =  -- skip the showParen junk...
1034              ASSERT(null bs_needed)
1035              ([nlWildPat, con_pat], mk_showString_app con_str)
1036           | otherwise   =
1037              ([a_Pat, con_pat],
1038                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
1039                                  (nlHsPar (nested_compose_Expr show_thingies)))
1040             where
1041              data_con_RDR  = getRdrName data_con
1042              con_arity     = dataConSourceArity data_con
1043              bs_needed     = take con_arity bs_RDRs
1044              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
1045              con_pat       = nlConVarPat data_con_RDR bs_needed
1046              nullary_con   = con_arity == 0
1047              labels        = dataConFieldLabels data_con
1048              lab_fields    = length labels
1049              record_syntax = lab_fields > 0
1050
1051              dc_nm          = getName data_con
1052              dc_occ_nm      = getOccName data_con
1053              con_str        = occNameString dc_occ_nm
1054              op_con_str     = wrapOpParens con_str
1055              backquote_str  = wrapOpBackquotes con_str
1056
1057              show_thingies
1058                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1059                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1060                                   show_record_args ++ [mk_showString_app "}"]
1061                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1062
1063              show_label l = mk_showString_app (nm ++ " = ")
1064                         -- Note the spaces around the "=" sign.  If we don't have them
1065                         -- then we get Foo { x=-1 } and the "=-" parses as a single
1066                         -- lexeme.  Only the space after the '=' is necessary, but
1067                         -- it seems tidier to have them both sides.
1068                  where
1069                    occ_nm   = getOccName l
1070                    nm       = wrapOpParens (occNameString occ_nm)
1071
1072              show_args               = zipWith show_arg bs_needed arg_tys
1073              (show_arg1:show_arg2:_) = show_args
1074              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
1075
1076                 --  Assumption for record syntax: no of fields == no of labelled fields
1077                 --            (and in same order)
1078              show_record_args = concat $
1079                                 intersperse [mk_showString_app ", "] $
1080                                 [ [show_label lbl, arg]
1081                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
1082                                                         labels show_args ]
1083
1084                 -- Generates (showsPrec p x) for argument x, but it also boxes
1085                 -- the argument first if necessary.  Note that this prints unboxed
1086                 -- things without any '#' decorations; could change that if need be
1087              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1088                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1089
1090                 -- Fixity stuff
1091              is_infix = dataConIsInfix data_con
1092              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1093              arg_prec | record_syntax = 0       -- Record fields don't need parens
1094                       | otherwise     = con_prec_plus_one
1095
1096 wrapOpParens :: String -> String
1097 wrapOpParens s | isSym s   = '(' : s ++ ")"
1098                | otherwise = s
1099
1100 wrapOpBackquotes :: String -> String
1101 wrapOpBackquotes s | isSym s   = s
1102                    | otherwise = '`' : s ++ "`"
1103
1104 isSym :: String -> Bool
1105 isSym ""      = False
1106 isSym (c : _) = startsVarSym c || startsConSym c
1107
1108 mk_showString_app :: String -> LHsExpr RdrName
1109 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1110 \end{code}
1111
1112 \begin{code}
1113 getPrec :: Bool -> FixityEnv -> Name -> Integer
1114 getPrec is_infix get_fixity nm
1115   | not is_infix   = appPrecedence
1116   | otherwise      = getPrecedence get_fixity nm
1117
1118 appPrecedence :: Integer
1119 appPrecedence = fromIntegral maxPrecedence + 1
1120   -- One more than the precedence of the most
1121   -- tightly-binding operator
1122
1123 getPrecedence :: FixityEnv -> Name -> Integer
1124 getPrecedence get_fixity nm
1125    = case lookupFixity get_fixity nm of
1126         Fixity x _assoc -> fromIntegral x
1127           -- NB: the Report says that associativity is not taken
1128           --     into account for either Read or Show; hence we
1129           --     ignore associativity here
1130 \end{code}
1131
1132
1133 %************************************************************************
1134 %*                                                                      *
1135 \subsection{Typeable}
1136 %*                                                                      *
1137 %************************************************************************
1138
1139 From the data type
1140
1141         data T a b = ....
1142
1143 we generate
1144
1145         instance Typeable2 T where
1146                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1147
1148 We are passed the Typeable2 class as well as T
1149
1150 \begin{code}
1151 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1152 gen_Typeable_binds loc tycon
1153   = unitBag $
1154         mk_easy_FunBind loc
1155                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1156                 [nlWildPat]
1157                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1158   where
1159     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1160
1161 mk_typeOf_RDR :: TyCon -> RdrName
1162 -- Use the arity of the TyCon to make the right typeOfn function
1163 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1164                 where
1165                   arity = tyConArity tycon
1166                   suffix | arity == 0 = ""
1167                          | otherwise  = show arity
1168 \end{code}
1169
1170
1171
1172 %************************************************************************
1173 %*                                                                      *
1174         Data instances
1175 %*                                                                      *
1176 %************************************************************************
1177
1178 From the data type
1179
1180   data T a b = T1 a b | T2
1181
1182 we generate
1183
1184   $cT1 = mkDataCon $dT "T1" Prefix
1185   $cT2 = mkDataCon $dT "T2" Prefix
1186   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1187   -- the [] is for field labels.
1188
1189   instance (Data a, Data b) => Data (T a b) where
1190     gfoldl k z (T1 a b) = z T `k` a `k` b
1191     gfoldl k z T2           = z T2
1192     -- ToDo: add gmapT,Q,M, gfoldr
1193
1194     gunfold k z c = case conIndex c of
1195                         I# 1# -> k (k (z T1))
1196                         I# 2# -> z T2
1197
1198     toConstr (T1 _ _) = $cT1
1199     toConstr T2       = $cT2
1200
1201     dataTypeOf _ = $dT
1202
1203     dataCast1 = gcast1   -- If T :: * -> *
1204     dataCast2 = gcast2   -- if T :: * -> * -> *
1205
1206
1207 \begin{code}
1208 gen_Data_binds :: SrcSpan
1209                -> TyCon
1210                -> (LHsBinds RdrName,    -- The method bindings
1211                    DerivAuxBinds)       -- Auxiliary bindings
1212 gen_Data_binds loc tycon
1213   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1214      `unionBags` gcast_binds,
1215                 -- Auxiliary definitions: the data type and constructors
1216      MkTyCon tycon : map MkDataCon data_cons)
1217   where
1218     data_cons  = tyConDataCons tycon
1219     n_cons     = length data_cons
1220     one_constr = n_cons == 1
1221
1222         ------------ gfoldl
1223     gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1224     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1225                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1226                    where
1227                      con_name ::  RdrName
1228                      con_name = getRdrName con
1229                      as_needed = take (dataConSourceArity con) as_RDRs
1230                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1231
1232         ------------ gunfold
1233     gunfold_bind = mk_FunBind loc
1234                               gunfold_RDR
1235                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1236                                 gunfold_rhs)]
1237
1238     gunfold_rhs
1239         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1240         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1241                                 (map gunfold_alt data_cons)
1242
1243     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1244     mk_unfold_rhs dc = foldr nlHsApp
1245                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1246                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1247
1248     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1249                         -- redundant test, and annoying warning
1250       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1251       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1252       where
1253         tag = dataConTag dc
1254
1255         ------------ toConstr
1256     toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1257     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1258
1259         ------------ dataTypeOf
1260     dataTypeOf_bind = mk_easy_FunBind
1261                         loc
1262                         dataTypeOf_RDR
1263                         [nlWildPat]
1264                         (nlHsVar (mk_data_type_name tycon))
1265
1266         ------------ gcast1/2
1267     tycon_kind = tyConKind tycon
1268     gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1269                 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1270                 | otherwise           = emptyBag
1271     mk_gcast dataCast_RDR gcast_RDR
1272       = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1273                                  (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1274
1275
1276 kind1, kind2 :: Kind
1277 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1278 kind2 = liftedTypeKind `mkArrowKind` kind1
1279
1280 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1281     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1282     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
1283 gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
1284 gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
1285 toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
1286 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1287 dataCast1_RDR  = varQual_RDR gENERICS (fsLit "dataCast1")
1288 dataCast2_RDR  = varQual_RDR gENERICS (fsLit "dataCast2")
1289 gcast1_RDR     = varQual_RDR tYPEABLE (fsLit "gcast1")
1290 gcast2_RDR     = varQual_RDR tYPEABLE (fsLit "gcast2")
1291 mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
1292 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1293 conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
1294 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1295 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1296 \end{code}
1297
1298
1299
1300 %************************************************************************
1301 %*                                                                      *
1302                         Functor instances
1303
1304  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1305
1306 %*                                                                      *
1307 %************************************************************************
1308
1309 For the data type:
1310
1311   data T a = T1 Int a | T2 (T a)
1312
1313 We generate the instance:
1314
1315   instance Functor T where
1316       fmap f (T1 b1 a) = T1 b1 (f a)
1317       fmap f (T2 ta)   = T2 (fmap f ta)
1318
1319 Notice that we don't simply apply 'fmap' to the constructor arguments.
1320 Rather
1321   - Do nothing to an argument whose type doesn't mention 'a'
1322   - Apply 'f' to an argument of type 'a'
1323   - Apply 'fmap f' to other arguments
1324 That's why we have to recurse deeply into the constructor argument types,
1325 rather than just one level, as we typically do.
1326
1327 What about types with more than one type parameter?  In general, we only
1328 derive Functor for the last position:
1329
1330   data S a b = S1 [b] | S2 (a, T a b)
1331   instance Functor (S a) where
1332     fmap f (S1 bs)    = S1 (fmap f bs)
1333     fmap f (S2 (p,q)) = S2 (a, fmap f q)
1334
1335 However, we have special cases for
1336          - tuples
1337          - functions
1338
1339 More formally, we write the derivation of fmap code over type variable
1340 'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
1341 instance for T is:
1342
1343   instance Functor T where
1344       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1345       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
1346
1347   $(fmap 'a 'b)         x  =  x     -- when b does not contain a
1348   $(fmap 'a 'a)         x  =  f x
1349   $(fmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1350   $(fmap 'a '(T b1 b2)) x  =  fmap $(fmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1351   $(fmap 'a '(b -> c))  x  =  \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1352
1353 For functions, the type parameter 'a can occur in a contravariant position,
1354 which means we need to derive a function like:
1355
1356   cofmap :: (a -> b) -> (f b -> f a)
1357
1358 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1359
1360   $(cofmap 'a 'b)         x  =  x     -- when b does not contain a
1361   $(cofmap 'a 'a)         x  =  error "type variable in contravariant position"
1362   $(cofmap 'a '(b1,b2))   x  =  case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1363   $(cofmap 'a '[b])       x  =  map $(cofmap 'a 'b) x
1364   $(cofmap 'a '(T b1 b2)) x  =  fmap $(cofmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
1365   $(cofmap 'a '(b -> c))  x  =  \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1366
1367 \begin{code}
1368 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1369 gen_Functor_binds loc tycon
1370   = (unitBag fmap_bind, [])
1371   where
1372     data_cons = tyConDataCons tycon
1373
1374     fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1375     fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1376       where
1377         parts = foldDataConArgs ft_fmap con
1378
1379     ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1380     -- Tricky higher order type; I can't say I fully understand this code :-(
1381     ft_fmap = FT { ft_triv = \x -> return x                    -- fmap f x = x
1382                  , ft_var  = \x -> return (nlHsApp f_Expr x)   -- fmap f x = f x
1383                  , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1384                                                                -- fmap f x = \b -> h (x (g b))
1385                  , ft_tup = mkSimpleTupleCase match_for_con    -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1386                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g      -- fmap f x = fmap g x
1387                                              return $ nlHsApps fmap_RDR [gg,x]
1388                  , ft_forall = \_ g  x -> g x
1389                  , ft_bad_app = panic "in other argument"
1390                  , ft_co_var = panic "contravariant" }
1391
1392     match_for_con = mkSimpleConMatch $
1393         \con_name xsM -> do xs <- sequence xsM
1394                             return (nlHsApps con_name xs)  -- Con (g1 v1) (g2 v2) ..
1395 \end{code}
1396
1397 Utility functions related to Functor deriving.
1398
1399 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1400 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1401
1402 \begin{code}
1403 -- Generic traversal for Functor deriving
1404 data FFoldType a      -- Describes how to fold over a Type in a functor like way
1405    = FT { ft_triv    :: a                   -- Does not contain variable
1406         , ft_var     :: a                   -- The variable itself
1407         , ft_co_var  :: a                   -- The variable itself, contravariantly
1408         , ft_fun     :: a -> a -> a         -- Function type
1409         , ft_tup     :: Boxity -> [a] -> a  -- Tuple type
1410         , ft_ty_app  :: Type -> a -> a      -- Type app, variable only in last argument
1411         , ft_bad_app :: a                   -- Type app, variable other than in last argument
1412         , ft_forall  :: TcTyVar -> a -> a   -- Forall type
1413      }
1414
1415 functorLikeTraverse :: TyVar         -- ^ Variable to look for
1416                     -> FFoldType a   -- ^ How to fold
1417                     -> Type          -- ^ Type to process
1418                     -> a
1419 functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
1420                             , ft_co_var = caseCoVar,     ft_fun = caseFun
1421                             , ft_tup = caseTuple,        ft_ty_app = caseTyApp
1422                             , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1423                     ty
1424   = fst (go False ty)
1425   where -- go returns (result of type a, does type contain var)
1426         go co ty | Just ty' <- coreView ty = go co ty'
1427         go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
1428         go co (FunTy (PredTy _) b)      = go co b
1429         go co (FunTy x y)    | xc || yc = (caseFun xr yr,True)
1430             where (xr,xc) = go (not co) x
1431                   (yr,yc) = go co       y
1432         go co (AppTy    x y) | xc = (caseWrongArg,   True)
1433                              | yc = (caseTyApp x yr, True)
1434             where (_, xc) = go co x
1435                   (yr,yc) = go co y
1436         go co ty@(TyConApp con args)
1437                | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1438                | null args        = (caseTrivial,False)  -- T
1439                | or (init xcs)    = (caseWrongArg,True)  -- T (..var..)    ty
1440                | last xcs         =                      -- T (..no var..) ty
1441                                     (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1442             where (xrs,xcs) = unzip (map (go co) args)
1443         go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1444             where (xr,xc) = go co x
1445         go _ _ = (caseTrivial,False)
1446
1447 -- Return all syntactic subterms of ty that contain var somewhere
1448 -- These are the things that should appear in instance constraints
1449 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1450 deepSubtypesContaining tv
1451   = functorLikeTraverse tv
1452         (FT { ft_triv = []
1453             , ft_var = []
1454             , ft_fun = (++), ft_tup = \_ xs -> concat xs
1455             , ft_ty_app = (:)
1456             , ft_bad_app = panic "in other argument"
1457             , ft_co_var = panic "contravariant"
1458             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1459
1460
1461 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1462 -- Fold over the arguments of the datacon
1463 foldDataConArgs ft con
1464   = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1465   where
1466     tv = last (dataConUnivTyVars con)
1467                     -- Argument to derive for, 'a in the above description
1468                     -- The validity checks have ensured that con is
1469                     -- a vanilla data constructor
1470
1471 -- Make a HsLam using a fresh variable from a State monad
1472 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1473 -- (mkSimpleLam fn) returns (\x. fn(x))
1474 mkSimpleLam lam = do
1475     (n:names) <- get
1476     put names
1477     body <- lam (nlHsVar n)
1478     return (mkHsLam [nlVarPat n] body)
1479
1480 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1481 mkSimpleLam2 lam = do
1482     (n1:n2:names) <- get
1483     put names
1484     body <- lam (nlHsVar n1) (nlHsVar n2)
1485     return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1486
1487 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1488 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1489 mkSimpleConMatch fold extra_pats con insides = do
1490     let con_name = getRdrName con
1491     let vars_needed = takeList insides as_RDRs
1492     let pat = nlConVarPat con_name vars_needed
1493     rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1494     return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1495
1496 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1497 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1498                   -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1499 mkSimpleTupleCase match_for_con boxity insides x = do
1500     let con = tupleCon boxity (length insides)
1501     match <- match_for_con [] con insides
1502     return $ nlHsCase x [match]
1503 \end{code}
1504
1505
1506 %************************************************************************
1507 %*                                                                      *
1508                         Foldable instances
1509
1510  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1511
1512 %*                                                                      *
1513 %************************************************************************
1514
1515 Deriving Foldable instances works the same way as Functor instances,
1516 only Foldable instances are not possible for function types at all.
1517 Here the derived instance for the type T above is:
1518
1519   instance Foldable T where
1520       foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1521
1522 The cases are:
1523
1524   $(foldr 'a 'b)         x z  =  z     -- when b does not contain a
1525   $(foldr 'a 'a)         x z  =  f x z
1526   $(foldr 'a '(b1,b2))   x z  =  case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1527   $(foldr 'a '(T b1 b2)) x z  =  foldr $(foldr 'a 'b2) x z  -- when a only occurs in the last parameter, b2
1528
1529 Note that the arguments to the real foldr function are the wrong way around,
1530 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1531
1532 \begin{code}
1533 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1534 gen_Foldable_binds loc tycon
1535   = (unitBag foldr_bind, [])
1536   where
1537     data_cons = tyConDataCons tycon
1538
1539     foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
1540     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1541       where
1542         parts = foldDataConArgs ft_foldr con
1543
1544     ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1545     ft_foldr = FT { ft_triv = \_ z -> return z                        -- foldr f z x = z
1546                   , ft_var  = \x z -> return (nlHsApps f_RDR [x,z])   -- foldr f z x = f x z
1547                   , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1548                   , ft_ty_app = \_ g  x z -> do gg <- mkSimpleLam2 g   -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1549                                                 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1550                   , ft_forall = \_ g  x z -> g x z
1551                   , ft_co_var = panic "covariant"
1552                   , ft_fun = panic "function"
1553                   , ft_bad_app = panic "in other argument" }
1554
1555     match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1556 \end{code}
1557
1558
1559 %************************************************************************
1560 %*                                                                      *
1561                         Traversable instances
1562
1563  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1564 %*                                                                      *
1565 %************************************************************************
1566
1567 Again, Traversable is much like Functor and Foldable.
1568
1569 The cases are:
1570
1571   $(traverse 'a 'b)         x  =  pure x     -- when b does not contain a
1572   $(traverse 'a 'a)         x  =  f x
1573   $(traverse 'a '(b1,b2))   x  =  case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1574   $(traverse 'a '(T b1 b2)) x  =  traverse $(traverse 'a 'b2) x  -- when a only occurs in the last parameter, b2
1575
1576 Note that the generated code is not as efficient as it could be. For instance:
1577
1578   data T a = T Int a  deriving Traversable
1579
1580 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1581 instead of:         traverse f (T x y) = T x <$> f y
1582
1583 \begin{code}
1584 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1585 gen_Traversable_binds loc tycon
1586   = (unitBag traverse_bind, [])
1587   where
1588     data_cons = tyConDataCons tycon
1589
1590     traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1591     traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1592       where
1593         parts = foldDataConArgs ft_trav con
1594
1595
1596     ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1597     ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x])   -- traverse f x = pure x
1598                  , ft_var = \x -> return (nlHsApps f_RDR [x])       -- travese f x = f x
1599                  , ft_tup = mkSimpleTupleCase match_for_con         -- travese f x z = case x of (a1,a2,..) ->
1600                                                                     --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
1601                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g    -- travese f x = travese (\xx -> g xx) x
1602                                              return $ nlHsApps traverse_RDR [gg,x]
1603                  , ft_forall = \_ g  x -> g x
1604                  , ft_co_var = panic "covariant"
1605                  , ft_fun = panic "function"
1606                  , ft_bad_app = panic "in other argument" }
1607
1608     match_for_con = mkSimpleConMatch $
1609         \con_name xsM -> do xs <- sequence xsM
1610                             return (mkApCon (nlHsVar con_name) xs)
1611
1612     -- ((Con <$> x1) <*> x2) <*> ..
1613     mkApCon con []     = nlHsApps pure_RDR [con]
1614     mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1615        where appAp x y = nlHsApps ap_RDR [x,y]
1616 \end{code}
1617
1618
1619
1620 %************************************************************************
1621 %*                                                                      *
1622 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1623 %*                                                                      *
1624 %************************************************************************
1625
1626 \begin{verbatim}
1627 data Foo ... = ...
1628
1629 con2tag_Foo :: Foo ... -> Int#
1630 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1631 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1632 \end{verbatim}
1633
1634 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1635 fiddling around.
1636
1637 \begin{code}
1638 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1639 genAuxBind loc (GenCon2Tag tycon)
1640   | lots_of_constructors
1641   = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1642
1643   | otherwise
1644   = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1645
1646   where
1647     rdr_name = con2tag_RDR tycon
1648
1649     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1650         -- We can't use gerRdrName because that makes an Exact  RdrName
1651         -- and we can't put them in the LocalRdrEnv
1652
1653         -- Give a signature to the bound variable, so
1654         -- that the case expression generated by getTag is
1655         -- monomorphic.  In the push-enter model we get better code.
1656     get_tag_rhs = L loc $ ExprWithTySig
1657                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1658                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1659                         (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs))
1660                                                      (noLoc []) con2tag_ty))
1661
1662     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1663                 `nlHsFunTy`
1664                 nlHsTyVar (getRdrName intPrimTyCon)
1665
1666     lots_of_constructors = tyConFamilySize tycon > 8
1667                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1668                                 -- but we don't do vectored returns any more.
1669
1670     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1671     mk_stuff con = ([nlWildConPat con],
1672                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1673
1674 genAuxBind loc (GenTag2Con tycon)
1675   = mk_FunBind loc rdr_name
1676         [([nlConVarPat intDataCon_RDR [a_RDR]],
1677            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1678                          (nlHsTyVar (getRdrName tycon))))]
1679   where
1680     rdr_name = tag2con_RDR tycon
1681
1682 genAuxBind loc (GenMaxTag tycon)
1683   = mkHsVarBind loc rdr_name
1684                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1685   where
1686     rdr_name = maxtag_RDR tycon
1687     max_tag =  case (tyConDataCons tycon) of
1688                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1689
1690 genAuxBind loc (MkTyCon tycon)  --  $dT
1691   = mkHsVarBind loc (mk_data_type_name tycon)
1692                     ( nlHsVar mkDataType_RDR
1693                     `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1694                     `nlHsApp` nlList constrs )
1695   where
1696     constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1697
1698 genAuxBind loc (MkDataCon dc)   --  $cT1 etc
1699   = mkHsVarBind loc (mk_constr_name dc)
1700                     (nlHsApps mkConstr_RDR constr_args)
1701   where
1702     constr_args
1703        = [ -- nlHsIntLit (toInteger (dataConTag dc)),     -- Tag
1704            nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1705            nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
1706            nlList  labels,                                -- Field labels
1707            nlHsVar fixity]                                -- Fixity
1708
1709     labels   = map (nlHsLit . mkHsString . getOccString)
1710                    (dataConFieldLabels dc)
1711     dc_occ   = getOccName dc
1712     is_infix = isDataSymOcc dc_occ
1713     fixity | is_infix  = infix_RDR
1714            | otherwise = prefix_RDR
1715
1716 mk_data_type_name :: TyCon -> RdrName   -- "$tT"
1717 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1718
1719 mk_constr_name :: DataCon -> RdrName    -- "$cC"
1720 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1721 \end{code}
1722
1723 %************************************************************************
1724 %*                                                                      *
1725 \subsection{Utility bits for generating bindings}
1726 %*                                                                      *
1727 %************************************************************************
1728
1729
1730 ToDo: Better SrcLocs.
1731
1732 \begin{code}
1733 box_if_necy :: String           -- The class involved
1734             -> TyCon            -- The tycon involved
1735             -> LHsExpr RdrName  -- The argument
1736             -> Type             -- The argument type
1737             -> LHsExpr RdrName  -- Boxed version of the arg
1738 box_if_necy cls_str tycon arg arg_ty
1739   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1740   | otherwise             = arg
1741   where
1742     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1743
1744 ---------------------
1745 primOrdOps :: String    -- The class involved
1746            -> TyCon     -- The tycon involved
1747            -> Type      -- The type
1748            -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp)  -- (lt,le,eq,ge,gt)
1749 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1750
1751 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1752 ord_op_tbl
1753  =  [(charPrimTy,       (CharLtOp,   CharLeOp,   CharEqOp,   CharGeOp,   CharGtOp))
1754     ,(intPrimTy,        (IntLtOp,    IntLeOp,    IntEqOp,    IntGeOp,    IntGtOp))
1755     ,(wordPrimTy,       (WordLtOp,   WordLeOp,   WordEqOp,   WordGeOp,   WordGtOp))
1756     ,(addrPrimTy,       (AddrLtOp,   AddrLeOp,   AddrEqOp,   AddrGeOp,   AddrGtOp))
1757     ,(floatPrimTy,      (FloatLtOp,  FloatLeOp,  FloatEqOp,  FloatGeOp,  FloatGtOp))
1758     ,(doublePrimTy,     (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1759
1760 box_con_tbl :: [(Type, RdrName)]
1761 box_con_tbl =
1762     [(charPrimTy,       getRdrName charDataCon)
1763     ,(intPrimTy,        getRdrName intDataCon)
1764     ,(wordPrimTy,       wordDataCon_RDR)
1765     ,(floatPrimTy,      getRdrName floatDataCon)
1766     ,(doublePrimTy,     getRdrName doubleDataCon)
1767     ]
1768
1769 assoc_ty_id :: String           -- The class involved
1770             -> TyCon            -- The tycon involved
1771             -> [(Type,a)]       -- The table
1772             -> Type             -- The type
1773             -> a                -- The result of the lookup
1774 assoc_ty_id cls_str _ tbl ty
1775   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1776                                               text "for primitive type" <+> ppr ty)
1777   | otherwise = head res
1778   where
1779     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1780
1781 -----------------------------------------------------------------------
1782
1783 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1784 and_Expr a b = genOpApp a and_RDR    b
1785
1786 -----------------------------------------------------------------------
1787
1788 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1789 eq_Expr tycon ty a b = genOpApp a eq_op b
1790  where
1791    eq_op | not (isUnLiftedType ty) = eq_RDR
1792          | otherwise               = primOpRdrName prim_eq
1793    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1794 \end{code}
1795
1796 \begin{code}
1797 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1798 untag_Expr _ [] expr = expr
1799 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1800   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1801       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1802
1803 enum_from_to_Expr
1804         :: LHsExpr RdrName -> LHsExpr RdrName
1805         -> LHsExpr RdrName
1806 enum_from_then_to_Expr
1807         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1808         -> LHsExpr RdrName
1809
1810 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1811 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1812
1813 showParen_Expr
1814         :: LHsExpr RdrName -> LHsExpr RdrName
1815         -> LHsExpr RdrName
1816
1817 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1818
1819 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1820
1821 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1822 nested_compose_Expr [e] = parenify e
1823 nested_compose_Expr (e:es)
1824   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1825
1826 -- impossible_Expr is used in case RHSs that should never happen.
1827 -- We generate these to keep the desugarer from complaining that they *might* happen!
1828 -- impossible_Expr :: LHsExpr RdrName
1829 -- impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1830
1831 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1832 -- method. It is currently only used by Enum.{succ,pred}
1833 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1834 illegal_Expr meth tp msg =
1835    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1836
1837 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1838 -- to include the value of a_RDR in the error string.
1839 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1840 illegal_toEnum_tag tp maxtag =
1841    nlHsApp (nlHsVar error_RDR)
1842            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1843                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1844                     (nlHsApp (nlHsApp (nlHsApp
1845                            (nlHsVar showsPrec_RDR)
1846                            (nlHsIntLit 0))
1847                            (nlHsVar a_RDR))
1848                            (nlHsApp (nlHsApp
1849                                (nlHsVar append_RDR)
1850                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1851                                (nlHsApp (nlHsApp (nlHsApp
1852                                         (nlHsVar showsPrec_RDR)
1853                                         (nlHsIntLit 0))
1854                                         (nlHsVar maxtag))
1855                                         (nlHsLit (mkHsString ")"))))))
1856
1857 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1858 parenify e@(L _ (HsVar _)) = e
1859 parenify e                 = mkHsPar e
1860
1861 -- genOpApp wraps brackets round the operator application, so that the
1862 -- renamer won't subsequently try to re-associate it.
1863 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1864 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1865 \end{code}
1866
1867 \begin{code}
1868 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1869     :: RdrName
1870 a_RDR           = mkVarUnqual (fsLit "a")
1871 b_RDR           = mkVarUnqual (fsLit "b")
1872 c_RDR           = mkVarUnqual (fsLit "c")
1873 d_RDR           = mkVarUnqual (fsLit "d")
1874 f_RDR           = mkVarUnqual (fsLit "f")
1875 k_RDR           = mkVarUnqual (fsLit "k")
1876 z_RDR           = mkVarUnqual (fsLit "z")
1877 ah_RDR          = mkVarUnqual (fsLit "a#")
1878 bh_RDR          = mkVarUnqual (fsLit "b#")
1879 ch_RDR          = mkVarUnqual (fsLit "c#")
1880 dh_RDR          = mkVarUnqual (fsLit "d#")
1881
1882 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1883 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1884 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1885 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1886
1887 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1888     false_Expr, true_Expr :: LHsExpr RdrName
1889 a_Expr          = nlHsVar a_RDR
1890 -- b_Expr       = nlHsVar b_RDR
1891 c_Expr          = nlHsVar c_RDR
1892 f_Expr          = nlHsVar f_RDR
1893 z_Expr          = nlHsVar z_RDR
1894 ltTag_Expr      = nlHsVar ltTag_RDR
1895 eqTag_Expr      = nlHsVar eqTag_RDR
1896 gtTag_Expr      = nlHsVar gtTag_RDR
1897 false_Expr      = nlHsVar false_RDR
1898 true_Expr       = nlHsVar true_RDR
1899
1900 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1901 a_Pat           = nlVarPat a_RDR
1902 b_Pat           = nlVarPat b_RDR
1903 c_Pat           = nlVarPat c_RDR
1904 d_Pat           = nlVarPat d_RDR
1905 f_Pat           = nlVarPat f_RDR
1906 k_Pat           = nlVarPat k_RDR
1907 z_Pat           = nlVarPat z_RDR
1908
1909 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1910 -- Generates Orig s RdrName, for the binding positions
1911 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1912 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1913 maxtag_RDR  tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1914
1915 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1916 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1917
1918 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1919 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1920 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1921 -- But:  (a) that does not work well for standalone-deriving
1922 --       (b) an unqualified name is just fine, provided it can't clash with user code
1923 \end{code}
1924
1925 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1926 PrelNames, so PrelNames can't import PrimOp.
1927
1928 \begin{code}
1929 primOpRdrName :: PrimOp -> RdrName
1930 primOpRdrName op = getRdrName (primOpId op)
1931
1932 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1933     tagToEnum_RDR :: RdrName
1934 minusInt_RDR  = primOpRdrName IntSubOp
1935 eqInt_RDR     = primOpRdrName IntEqOp
1936 ltInt_RDR     = primOpRdrName IntLtOp
1937 geInt_RDR     = primOpRdrName IntGeOp
1938 gtInt_RDR     = primOpRdrName IntGtOp
1939 leInt_RDR     = primOpRdrName IntLeOp
1940 tagToEnum_RDR = primOpRdrName TagToEnumOp
1941
1942 error_RDR :: RdrName
1943 error_RDR = getRdrName eRROR_ID
1944 \end{code}