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