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 {-# OPTIONS -w #-}
  15 -- The above warning supression flag is a temporary kludge.
  16 -- While working on this module you are encouraged to remove it and fix
  17 -- any warnings in the module. See
  18 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  19 -- for details
  20
  21 module TcGenDeriv (
  22         DerivAuxBind(..), DerivAuxBinds, isDupAux,
  23
  24         gen_Bounded_binds,
  25         gen_Enum_binds,
  26         gen_Eq_binds,
  27         gen_Ix_binds,
  28         gen_Ord_binds,
  29         gen_Read_binds,
  30         gen_Show_binds,
  31         gen_Data_binds,
  32         gen_Typeable_binds,
  33         genAuxBind,
  34
  35         con2tag_RDR, tag2con_RDR, maxtag_RDR
  36     ) where
  37
  38 #include "HsVersions.h"
  39
  40 import HsSyn
  41 import RdrName
  42 import BasicTypes
  43 import DataCon
  44 import Name
  45
  46 import HscTypes
  47 import PrelInfo
  48 import PrelNames
  49 import MkId
  50 import PrimOp
  51 import SrcLoc
  52 import TyCon
  53 import TcType
  54 import TysPrim
  55 import TysWiredIn
  56 import Util
  57 import Outputable
  58 import FastString
  59 import OccName
  60 import Bag
  61
  62 import Data.List        ( partition, intersperse )
  63 \end{code}
  64
  65 \begin{code}
  66 type DerivAuxBinds = [DerivAuxBind]
  67
  68 data DerivAuxBind               -- Please add these auxiliary top-level bindings
  69   = DerivAuxBind (LHsBind RdrName)
  70   | GenCon2Tag TyCon            -- The con2Tag for given TyCon
  71   | GenTag2Con TyCon            -- ...ditto tag2Con
  72   | GenMaxTag  TyCon            -- ...and maxTag
  73
  74 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
  75 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1==tc2
  76 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1==tc2
  77 isDupAux (GenMaxTag tc1)  (GenMaxTag tc2)  = tc1==tc2
  78 isDupAux b1               b2               = False
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84                 Eq instances
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 Here are the heuristics for the code we generate for @Eq@:
  89 \begin{itemize}
  90 \item
  91   Let's assume we have a data type with some (possibly zero) nullary
  92   data constructors and some ordinary, non-nullary ones (the rest,
  93   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  94   and \tr{O}rdinary data cons.
  95 \begin{verbatim}
  96 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
  97 \end{verbatim}
  98
  99 \item
 100   For the ordinary constructors (if any), we emit clauses to do The
 101   Usual Thing, e.g.,:
 102
 103 \begin{verbatim}
 104 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
 105 (==) (O2 a1)       (O2 a2)       = a1 == a2
 106 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
 107 \end{verbatim}
 108
 109   Note: if we're comparing unlifted things, e.g., if \tr{a1} and
 110   \tr{a2} are \tr{Float#}s, then we have to generate
 111 \begin{verbatim}
 112 case (a1 `eqFloat#` a2) of
 113   r -> r
 114 \end{verbatim}
 115   for that particular test.
 116
 117 \item
 118   If there are any nullary constructors, we emit a catch-all clause of
 119   the form:
 120
 121 \begin{verbatim}
 122 (==) a b  = case (con2tag_Foo a) of { a# ->
 123             case (con2tag_Foo b) of { b# ->
 124             case (a# ==# b#)     of {
 125               r -> r
 126             }}}
 127 \end{verbatim}
 128
 129   If there aren't any nullary constructors, we emit a simpler
 130   catch-all:
 131 \begin{verbatim}
 132 (==) a b  = False
 133 \end{verbatim}
 134
 135 \item
 136   For the @(/=)@ method, we normally just use the default method.
 137
 138   If the type is an enumeration type, we could/may/should? generate
 139   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 140   above.
 141
 142 \item
 143   We thought about doing this: If we're also deriving @Ord@ for this
 144   tycon, we generate:
 145 \begin{verbatim}
 146 instance ... Eq (Foo ...) where
 147   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 148   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 149 \begin{verbatim}
 150   However, that requires that \tr{Ord <whatever>} was put in the context
 151   for the instance decl, which it probably wasn't, so the decls
 152   produced don't get through the typechecker.
 153 \end{itemize}
 154
 155
 156 \begin{code}
 157 gen_Eq_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 158 gen_Eq_binds tycon
 159   = (method_binds, aux_binds)
 160   where
 161     tycon_loc = getSrcSpan tycon
 162
 163     (nullary_cons, nonnullary_cons)
 164        | isNewTyCon tycon = ([], tyConDataCons tycon)
 165        | otherwise            = partition isNullarySrcDataCon (tyConDataCons tycon)
 166
 167     no_nullary_cons = null nullary_cons
 168
 169     rest | no_nullary_cons
 170          = case maybeTyConSingleCon tycon of
 171                   Just _ -> []
 172                   Nothing -> -- if cons don't match, then False
 173                      [([nlWildPat, nlWildPat], false_Expr)]
 174          | otherwise -- calc. and compare the tags
 175          = [([a_Pat, b_Pat],
 176             untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 177                        (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 178
 179     aux_binds | no_nullary_cons = []
 180               | otherwise       = [GenCon2Tag tycon]
 181
 182     method_binds = listToBag [
 183                         mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
 184                         mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
 185                         nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
 186
 187     ------------------------------------------------------------------
 188     pats_etc data_con
 189       = let
 190             con1_pat = nlConVarPat data_con_RDR as_needed
 191             con2_pat = nlConVarPat data_con_RDR bs_needed
 192
 193             data_con_RDR = getRdrName data_con
 194             con_arity   = length tys_needed
 195             as_needed   = take con_arity as_RDRs
 196             bs_needed   = take con_arity bs_RDRs
 197             tys_needed  = dataConOrigArgTys data_con
 198         in
 199         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 200       where
 201         nested_eq_expr []  [] [] = true_Expr
 202         nested_eq_expr tys as bs
 203           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 204           where
 205             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
 206 \end{code}
 207
 208 %************************************************************************
 209 %*                                                                      *
 210         Ord instances
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 For a derived @Ord@, we concentrate our attentions on @compare@
 215 \begin{verbatim}
 216 compare :: a -> a -> Ordering
 217 data Ordering = LT | EQ | GT deriving ()
 218 \end{verbatim}
 219
 220 We will use the same example data type as above:
 221 \begin{verbatim}
 222 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 223 \end{verbatim}
 224
 225 \begin{itemize}
 226 \item
 227   We do all the other @Ord@ methods with calls to @compare@:
 228 \begin{verbatim}
 229 instance ... (Ord <wurble> <wurble>) where
 230     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 231     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 232     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 233     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 234
 235     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 236     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 237
 238     -- compare to come...
 239 \end{verbatim}
 240
 241 \item
 242   @compare@ always has two parts.  First, we use the compared
 243   data-constructors' tags to deal with the case of different
 244   constructors:
 245 \begin{verbatim}
 246 compare a b = case (con2tag_Foo a) of { a# ->
 247               case (con2tag_Foo b) of { b# ->
 248               case (a# ==# b#)     of {
 249                True  -> cmp_eq a b
 250                False -> case (a# <# b#) of
 251                          True  -> _LT
 252                          False -> _GT
 253               }}}
 254   where
 255     cmp_eq = ... to come ...
 256 \end{verbatim}
 257
 258 \item
 259   We are only left with the ``help'' function @cmp_eq@, to deal with
 260   comparing data constructors with the same tag.
 261
 262   For the ordinary constructors (if any), we emit the sorta-obvious
 263   compare-style stuff; for our example:
 264 \begin{verbatim}
 265 cmp_eq (O1 a1 b1) (O1 a2 b2)
 266   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 267
 268 cmp_eq (O2 a1) (O2 a2)
 269   = compare a1 a2
 270
 271 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 272   = case (compare a1 a2) of {
 273       LT -> LT;
 274       GT -> GT;
 275       EQ -> case compare b1 b2 of {
 276               LT -> LT;
 277               GT -> GT;
 278               EQ -> compare c1 c2
 279             }
 280     }
 281 \end{verbatim}
 282
 283   Again, we must be careful about unlifted comparisons.  For example,
 284   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 285   generate:
 286
 287 \begin{verbatim}
 288 cmp_eq lt eq gt (O2 a1) (O2 a2)
 289   = compareInt# a1 a2
 290   -- or maybe the unfolded equivalent
 291 \end{verbatim}
 292
 293 \item
 294   For the remaining nullary constructors, we already know that the
 295   tags are equal so:
 296 \begin{verbatim}
 297 cmp_eq _ _ = EQ
 298 \end{verbatim}
 299 \end{itemize}
 300
 301 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
 302 JJQC-30-Nov-1997
 303
 304 \begin{code}
 305 gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 306
 307 gen_Ord_binds tycon
 308   | Just (con, prim_tc) <- primWrapperType_maybe tycon
 309   = gen_PrimOrd_binds con prim_tc
 310
 311   | otherwise
 312   = (unitBag compare, aux_binds)
 313         -- `AndMonoBinds` compare
 314         -- The default declaration in PrelBase handles this
 315   where
 316     tycon_loc = getSrcSpan tycon
 317     --------------------------------------------------------------------
 318     aux_binds | single_con_type = []
 319               | otherwise       = [GenCon2Tag tycon]
 320
 321     compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
 322     compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
 323     cmp_eq_binds    = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
 324
 325     compare_rhs
 326         | single_con_type = cmp_eq_Expr a_Expr b_Expr
 327         | otherwise
 328         = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 329                   (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
 330                         (cmp_eq_Expr a_Expr b_Expr)     -- True case
 331                         -- False case; they aren't equal
 332                         -- So we need to do a less-than comparison on the tags
 333                         (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
 334
 335     tycon_data_cons = tyConDataCons tycon
 336     single_con_type = isSingleton tycon_data_cons
 337     (nullary_cons, nonnullary_cons)
 338        | isNewTyCon tycon = ([], tyConDataCons tycon)
 339        | otherwise        = partition isNullarySrcDataCon tycon_data_cons
 340
 341     cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
 342     cmp_eq_match
 343       | isEnumerationTyCon tycon
 344                            -- We know the tags are equal, so if it's an enumeration TyCon,
 345                            -- then there is nothing left to do
 346                            -- Catch this specially to avoid warnings
 347                            -- about overlapping patterns from the desugarer,
 348                            -- and to avoid unnecessary pattern-matching
 349       = [([nlWildPat,nlWildPat], eqTag_Expr)]
 350       | otherwise
 351       = map pats_etc nonnullary_cons ++
 352         (if single_con_type then        -- Omit wildcards when there's just one
 353               []                        -- constructor, to silence desugarer
 354         else
 355               [([nlWildPat, nlWildPat], default_rhs)])
 356
 357     default_rhs | null nullary_cons = impossible_Expr   -- Keep desugarer from complaining about
 358                                                         -- inexhaustive patterns
 359                 | otherwise         = eqTag_Expr        -- Some nullary constructors;
 360                                                         -- Tags are equal, no args => return EQ
 361     pats_etc data_con
 362         = ([con1_pat, con2_pat],
 363            nested_compare_expr tys_needed as_needed bs_needed)
 364         where
 365           con1_pat = nlConVarPat data_con_RDR as_needed
 366           con2_pat = nlConVarPat data_con_RDR bs_needed
 367
 368           data_con_RDR = getRdrName data_con
 369           con_arity   = length tys_needed
 370           as_needed   = take con_arity as_RDRs
 371           bs_needed   = take con_arity bs_RDRs
 372           tys_needed  = dataConOrigArgTys data_con
 373
 374           nested_compare_expr [ty] [a] [b]
 375             = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
 376
 377           nested_compare_expr (ty:tys) (a:as) (b:bs)
 378             = let eq_expr = nested_compare_expr tys as bs
 379                 in  careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
 380
 381           nested_compare_expr _ _ _ = panic "nested_compare_expr"       -- Args always equal length
 382 \end{code}
 383
 384 Note [Comparision of primitive types]
 385 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 386 The general plan does not work well for data types like
 387         data T = MkT Int# deriving( Ord )
 388 The general plan defines the 'compare' method, gets (<) etc from it.  But
 389 that means we get silly code like:
 390    instance Ord T where
 391      (>) (I# x) (I# y) = case <# x y of
 392                             True -> False
 393                             False -> case ==# x y of
 394                                        True  -> False
 395                                        False -> True
 396 We would prefer to use the (>#) primop.  See also Trac #2130
 397
 398
 399 \begin{code}
 400 gen_PrimOrd_binds :: DataCon -> TyCon ->  (LHsBinds RdrName, DerivAuxBinds)
 401 -- See Note [Comparison of primitive types]
 402 gen_PrimOrd_binds data_con prim_tc
 403   = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
 404                 mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
 405   where
 406     mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
 407                                  [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
 408     con_RDR = getRdrName data_con
 409     apat = nlConVarPat con_RDR [a_RDR]
 410     bpat = nlConVarPat con_RDR [b_RDR]
 411
 412     (lt_op, le_op, ge_op, gt_op)
 413        | prim_tc == charPrimTyCon   = (CharLtOp,   CharLeOp,   CharGeOp,   CharGtOp)
 414        | prim_tc == intPrimTyCon    = (IntLtOp,    IntLeOp,    IntGeOp,    IntGtOp)
 415        | prim_tc == wordPrimTyCon   = (WordLtOp,   WordLeOp,   WordGeOp,   WordGtOp)
 416        | prim_tc == addrPrimTyCon   = (AddrLtOp,   AddrLeOp,   AddrGeOp,   AddrGtOp)
 417        | prim_tc == floatPrimTyCon  = (FloatLtOp,  FloatLeOp,  FloatGeOp,  FloatGtOp)
 418        | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
 419        | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
 420
 421
 422 primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
 423 -- True of data types that are wrappers around prmitive types
 424 --      data T = MkT Word#
 425 -- For these we want to generate all the (<), (<=) etc operations individually
 426 primWrapperType_maybe tc
 427   | [con] <- tyConDataCons tc
 428   , [ty]  <- dataConOrigArgTys con
 429   , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
 430   , isPrimTyCon prim_tc
 431   = Just (con, prim_tc)
 432   | otherwise
 433   = Nothing
 434 \end{code}
 435
 436 %************************************************************************
 437 %*                                                                      *
 438         Enum instances
 439 %*                                                                      *
 440 %************************************************************************
 441
 442 @Enum@ can only be derived for enumeration types.  For a type
 443 \begin{verbatim}
 444 data Foo ... = N1 | N2 | ... | Nn
 445 \end{verbatim}
 446
 447 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 448 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 449
 450 \begin{verbatim}
 451 instance ... Enum (Foo ...) where
 452     succ x   = toEnum (1 + fromEnum x)
 453     pred x   = toEnum (fromEnum x - 1)
 454
 455     toEnum i = tag2con_Foo i
 456
 457     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 458
 459     -- or, really...
 460     enumFrom a
 461       = case con2tag_Foo a of
 462           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 463
 464    enumFromThen a b
 465      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 466
 467     -- or, really...
 468     enumFromThen a b
 469       = case con2tag_Foo a of { a# ->
 470         case con2tag_Foo b of { b# ->
 471         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 472         }}
 473 \end{verbatim}
 474
 475 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 476
 477 \begin{code}
 478 gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 479 gen_Enum_binds tycon
 480   = (method_binds, aux_binds)
 481   where
 482     method_binds = listToBag [
 483                         succ_enum,
 484                         pred_enum,
 485                         to_enum,
 486                         enum_from,
 487                         enum_from_then,
 488                         from_enum
 489                     ]
 490     aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
 491
 492     tycon_loc = getSrcSpan tycon
 493     occ_nm    = getOccString tycon
 494
 495     succ_enum
 496       = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
 497         untag_Expr tycon [(a_RDR, ah_RDR)] $
 498         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
 499                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 500              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 501              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 502                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 503                                         nlHsIntLit 1]))
 504
 505     pred_enum
 506       = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
 507         untag_Expr tycon [(a_RDR, ah_RDR)] $
 508         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
 509                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 510              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 511              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 512                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 513                                                nlHsLit (HsInt (-1))]))
 514
 515     to_enum
 516       = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
 517         nlHsIf (nlHsApps and_RDR
 518                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
 519                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
 520              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
 521              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 522
 523     enum_from
 524       = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
 525           untag_Expr tycon [(a_RDR, ah_RDR)] $
 526           nlHsApps map_RDR
 527                 [nlHsVar (tag2con_RDR tycon),
 528                  nlHsPar (enum_from_to_Expr
 529                             (nlHsVarApps intDataCon_RDR [ah_RDR])
 530                             (nlHsVar (maxtag_RDR tycon)))]
 531
 532     enum_from_then
 533       = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
 534           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 535           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 536             nlHsPar (enum_from_then_to_Expr
 537                     (nlHsVarApps intDataCon_RDR [ah_RDR])
 538                     (nlHsVarApps intDataCon_RDR [bh_RDR])
 539                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 540                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
 541                            (nlHsIntLit 0)
 542                            (nlHsVar (maxtag_RDR tycon))
 543                            ))
 544
 545     from_enum
 546       = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
 547           untag_Expr tycon [(a_RDR, ah_RDR)] $
 548           (nlHsVarApps intDataCon_RDR [ah_RDR])
 549 \end{code}
 550
 551 %************************************************************************
 552 %*                                                                      *
 553         Bounded instances
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 \begin{code}
 558 gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 559 gen_Bounded_binds tycon
 560   | isEnumerationTyCon tycon
 561   = (listToBag [ min_bound_enum, max_bound_enum ], [])
 562   | otherwise
 563   = ASSERT(isSingleton data_cons)
 564     (listToBag [ min_bound_1con, max_bound_1con ], [])
 565   where
 566     data_cons = tyConDataCons tycon
 567     tycon_loc = getSrcSpan tycon
 568
 569     ----- enum-flavored: ---------------------------
 570     min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
 571     max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
 572
 573     data_con_1    = head data_cons
 574     data_con_N    = last data_cons
 575     data_con_1_RDR = getRdrName data_con_1
 576     data_con_N_RDR = getRdrName data_con_N
 577
 578     ----- single-constructor-flavored: -------------
 579     arity          = dataConSourceArity data_con_1
 580
 581     min_bound_1con = mkVarBind tycon_loc minBound_RDR $
 582                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 583     max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
 584                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 585 \end{code}
 586
 587 %************************************************************************
 588 %*                                                                      *
 589         Ix instances
 590 %*                                                                      *
 591 %************************************************************************
 592
 593 Deriving @Ix@ is only possible for enumeration types and
 594 single-constructor types.  We deal with them in turn.
 595
 596 For an enumeration type, e.g.,
 597 \begin{verbatim}
 598     data Foo ... = N1 | N2 | ... | Nn
 599 \end{verbatim}
 600 things go not too differently from @Enum@:
 601 \begin{verbatim}
 602 instance ... Ix (Foo ...) where
 603     range (a, b)
 604       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 605
 606     -- or, really...
 607     range (a, b)
 608       = case (con2tag_Foo a) of { a# ->
 609         case (con2tag_Foo b) of { b# ->
 610         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 611         }}
 612
 613     -- Generate code for unsafeIndex, becuase using index leads
 614     -- to lots of redundant range tests
 615     unsafeIndex c@(a, b) d
 616       = case (con2tag_Foo d -# con2tag_Foo a) of
 617                r# -> I# r#
 618
 619     inRange (a, b) c
 620       = let
 621             p_tag = con2tag_Foo c
 622         in
 623         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 624
 625     -- or, really...
 626     inRange (a, b) c
 627       = case (con2tag_Foo a)   of { a_tag ->
 628         case (con2tag_Foo b)   of { b_tag ->
 629         case (con2tag_Foo c)   of { c_tag ->
 630         if (c_tag >=# a_tag) then
 631           c_tag <=# b_tag
 632         else
 633           False
 634         }}}
 635 \end{verbatim}
 636 (modulo suitable case-ification to handle the unlifted tags)
 637
 638 For a single-constructor type (NB: this includes all tuples), e.g.,
 639 \begin{verbatim}
 640     data Foo ... = MkFoo a b Int Double c c
 641 \end{verbatim}
 642 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 643 (p.~147).
 644
 645 \begin{code}
 646 gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 647
 648 gen_Ix_binds tycon
 649   | isEnumerationTyCon tycon
 650   = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
 651   | otherwise
 652   = (single_con_ixes, [GenCon2Tag tycon])
 653   where
 654     tycon_loc = getSrcSpan tycon
 655
 656     --------------------------------------------------------------
 657     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 658
 659     enum_range
 660       = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
 661           untag_Expr tycon [(a_RDR, ah_RDR)] $
 662           untag_Expr tycon [(b_RDR, bh_RDR)] $
 663           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 664               nlHsPar (enum_from_to_Expr
 665                         (nlHsVarApps intDataCon_RDR [ah_RDR])
 666                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 667
 668     enum_index
 669       = mk_easy_FunBind tycon_loc unsafeIndex_RDR
 670                 [noLoc (AsPat (noLoc c_RDR)
 671                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
 672                                 d_Pat] (
 673            untag_Expr tycon [(a_RDR, ah_RDR)] (
 674            untag_Expr tycon [(d_RDR, dh_RDR)] (
 675            let
 676                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
 677            in
 678            nlHsCase
 679              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
 680              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
 681            ))
 682         )
 683
 684     enum_inRange
 685       = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
 686           untag_Expr tycon [(a_RDR, ah_RDR)] (
 687           untag_Expr tycon [(b_RDR, bh_RDR)] (
 688           untag_Expr tycon [(c_RDR, ch_RDR)] (
 689           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
 690              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
 691           ) {-else-} (
 692              false_Expr
 693           ))))
 694
 695     --------------------------------------------------------------
 696     single_con_ixes
 697       = listToBag [single_con_range, single_con_index, single_con_inRange]
 698
 699     data_con
 700       = case maybeTyConSingleCon tycon of -- just checking...
 701           Nothing -> panic "get_Ix_binds"
 702           Just dc | any isUnLiftedType (dataConOrigArgTys dc)
 703                   -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
 704                   | otherwise -> 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 tycon_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                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
 727
 728     ----------------
 729     single_con_index
 730       = mk_easy_FunBind tycon_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                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
 749                 ) times_RDR (mk_index rest)
 750            )
 751         mk_one l u i
 752           = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
 753
 754     ------------------
 755     single_con_inRange
 756       = mk_easy_FunBind tycon_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 [nlTuple [nlHsVar a, nlHsVar b] Boxed,
 762                                                nlHsVar c]
 763 \end{code}
 764
 765 %************************************************************************
 766 %*                                                                      *
 767         Read instances
 768 %*                                                                      *
 769 %************************************************************************
 770
 771 Example
 772
 773   infix 4 %%
 774   data T = Int %% Int
 775          | T1 { f1 :: Int }
 776          | T2 T
 777
 778
 779 instance Read T where
 780   readPrec =
 781     parens
 782     ( prec 4 (
 783         do x           <- ReadP.step Read.readPrec
 784            Symbol "%%" <- Lex.lex
 785            y           <- ReadP.step Read.readPrec
 786            return (x %% y))
 787       +++
 788       prec (appPrec+1) (
 789         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 790         -- Record construction binds even more tightly than application
 791         do Ident "T1" <- Lex.lex
 792            Punc '{' <- Lex.lex
 793            Ident "f1" <- Lex.lex
 794            Punc '=' <- Lex.lex
 795            x          <- ReadP.reset Read.readPrec
 796            Punc '}' <- Lex.lex
 797            return (T1 { f1 = x }))
 798       +++
 799       prec appPrec (
 800         do Ident "T2" <- Lex.lexP
 801            x          <- ReadP.step Read.readPrec
 802            return (T2 x))
 803     )
 804
 805   readListPrec = readListPrecDefault
 806   readList     = readListDefault
 807
 808
 809 \begin{code}
 810 gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 811
 812 gen_Read_binds get_fixity tycon
 813   = (listToBag [read_prec, default_readlist, default_readlistprec], [])
 814   where
 815     -----------------------------------------------------------------------
 816     default_readlist
 817         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 818
 819     default_readlistprec
 820         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 821     -----------------------------------------------------------------------
 822
 823     loc       = getSrcSpan tycon
 824     data_cons = tyConDataCons tycon
 825     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 826
 827     read_prec = mkVarBind loc readPrec_RDR
 828                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 829
 830     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 831     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 832
 833     read_nullary_cons
 834       = case nullary_cons of
 835             []    -> []
 836             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
 837                                     (result_expr con [])]
 838             _     -> [nlHsApp (nlHsVar choose_RDR)
 839                               (nlList (map mk_pair nullary_cons))]
 840
 841     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
 842                            result_expr con []]
 843                           Boxed
 844
 845     read_non_nullary_con data_con
 846       | is_infix  = mk_parser infix_prec  infix_stmts  body
 847       | is_record = mk_parser record_prec record_stmts body
 848 --              Using these two lines instead allows the derived
 849 --              read for infix and record bindings to read the prefix form
 850 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 851 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 852       | otherwise = prefix_parser
 853       where
 854         body = result_expr data_con as_needed
 855         con_str = data_con_str data_con
 856
 857         prefix_parser = mk_parser prefix_prec prefix_stmts body
 858         prefix_stmts            -- T a b c
 859           = (if not (isSym con_str) then
 860                   [bindLex (ident_pat con_str)]
 861              else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
 862             ++ read_args
 863
 864         infix_stmts             -- a %% b, or  a `T` b
 865           = [read_a1]
 866             ++  (if isSym con_str
 867                  then [bindLex (symbol_pat con_str)]
 868                  else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
 869             ++ [read_a2]
 870
 871         record_stmts            -- T { f1 = a, f2 = b }
 872           = [bindLex (ident_pat (wrapOpParens con_str)),
 873              read_punc "{"]
 874             ++ concat (intersperse [read_punc ","] field_stmts)
 875             ++ [read_punc "}"]
 876
 877         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 878
 879         con_arity    = dataConSourceArity data_con
 880         labels       = dataConFieldLabels data_con
 881         dc_nm        = getName data_con
 882         is_infix     = dataConIsInfix data_con
 883         is_record    = length labels > 0
 884         as_needed    = take con_arity as_RDRs
 885         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 886         (read_a1:read_a2:_) = read_args
 887
 888         prefix_prec = appPrecedence
 889         infix_prec  = getPrecedence get_fixity dc_nm
 890         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 891                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 892
 893     ------------------------------------------------------------------------
 894     --          Helpers
 895     ------------------------------------------------------------------------
 896     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
 897     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
 898     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
 899     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
 900     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
 901
 902     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 903     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 904     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 905
 906     data_con_str con = occNameString (getOccName con)
 907
 908     read_punc c = bindLex (punc_pat c)
 909     read_arg a ty
 910         | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
 911         | otherwise = 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 -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 964
 965 gen_Show_binds get_fixity tycon
 966   = (listToBag [shows_prec, show_list], [])
 967   where
 968     tycon_loc = getSrcSpan tycon
 969     -----------------------------------------------------------------------
 970     show_list = mkVarBind tycon_loc showList_RDR
 971                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 972     -----------------------------------------------------------------------
 973     shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 974       where
 975         pats_etc data_con
 976           | nullary_con =  -- skip the showParen junk...
 977              ASSERT(null bs_needed)
 978              ([nlWildPat, con_pat], mk_showString_app con_str)
 979           | otherwise   =
 980              ([a_Pat, con_pat],
 981                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 982                                  (nlHsPar (nested_compose_Expr show_thingies)))
 983             where
 984              data_con_RDR  = getRdrName data_con
 985              con_arity     = dataConSourceArity data_con
 986              bs_needed     = take con_arity bs_RDRs
 987              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 988              con_pat       = nlConVarPat data_con_RDR bs_needed
 989              nullary_con   = con_arity == 0
 990              labels        = dataConFieldLabels data_con
 991              lab_fields    = length labels
 992              record_syntax = lab_fields > 0
 993
 994              dc_nm          = getName data_con
 995              dc_occ_nm      = getOccName data_con
 996              con_str        = occNameString dc_occ_nm
 997              op_con_str     = wrapOpParens con_str
 998              backquote_str  = wrapOpBackquotes con_str
 999
1000              show_thingies
1001                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1002                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1003                                   show_record_args ++ [mk_showString_app "}"]
1004                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1005
1006              show_label l = mk_showString_app (nm ++ " = ")
1007                         -- Note the spaces around the "=" sign.  If we don't have them
1008                         -- then we get Foo { x=-1 } and the "=-" parses as a single
1009                         -- lexeme.  Only the space after the '=' is necessary, but
1010                         -- it seems tidier to have them both sides.
1011                  where
1012                    occ_nm   = getOccName l
1013                    nm       = wrapOpParens (occNameString occ_nm)
1014
1015              show_args               = zipWith show_arg bs_needed arg_tys
1016              (show_arg1:show_arg2:_) = show_args
1017              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
1018
1019                 --  Assumption for record syntax: no of fields == no of labelled fields
1020                 --            (and in same order)
1021              show_record_args = concat $
1022                                 intersperse [mk_showString_app ", "] $
1023                                 [ [show_label lbl, arg]
1024                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
1025                                                         labels show_args ]
1026
1027                 -- Generates (showsPrec p x) for argument x, but it also boxes
1028                 -- the argument first if necessary.  Note that this prints unboxed
1029                 -- things without any '#' decorations; could change that if need be
1030              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1031                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1032
1033                 -- Fixity stuff
1034              is_infix = dataConIsInfix data_con
1035              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1036              arg_prec | record_syntax = 0       -- Record fields don't need parens
1037                       | otherwise     = con_prec_plus_one
1038
1039 wrapOpParens :: String -> String
1040 wrapOpParens s | isSym s   = '(' : s ++ ")"
1041                | otherwise = s
1042
1043 wrapOpBackquotes :: String -> String
1044 wrapOpBackquotes s | isSym s   = s
1045                    | otherwise = '`' : s ++ "`"
1046
1047 isSym :: String -> Bool
1048 isSym ""     = False
1049 isSym (c:cs) = startsVarSym c || startsConSym c
1050
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 :: TyCon -> LHsBinds RdrName
1094 gen_Typeable_binds tycon
1095   = unitBag $
1096         mk_easy_FunBind tycon_loc
1097                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1098                 [nlWildPat]
1099                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1100   where
1101     tycon_loc = getSrcSpan tycon
1102     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1103
1104 mk_typeOf_RDR :: TyCon -> RdrName
1105 -- Use the arity of the TyCon to make the right typeOfn function
1106 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1107                 where
1108                   arity = tyConArity tycon
1109                   suffix | arity == 0 = ""
1110                          | otherwise  = show arity
1111 \end{code}
1112
1113
1114
1115 %************************************************************************
1116 %*                                                                      *
1117         Data instances
1118 %*                                                                      *
1119 %************************************************************************
1120
1121 From the data type
1122
1123   data T a b = T1 a b | T2
1124
1125 we generate
1126
1127   $cT1 = mkDataCon $dT "T1" Prefix
1128   $cT2 = mkDataCon $dT "T2" Prefix
1129   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1130   -- the [] is for field labels.
1131
1132   instance (Data a, Data b) => Data (T a b) where
1133     gfoldl k z (T1 a b) = z T `k` a `k` b
1134     gfoldl k z T2           = z T2
1135     -- ToDo: add gmapT,Q,M, gfoldr
1136
1137     gunfold k z c = case conIndex c of
1138                         I# 1# -> k (k (z T1))
1139                         I# 2# -> z T2
1140
1141     toConstr (T1 _ _) = $cT1
1142     toConstr T2       = $cT2
1143
1144     dataTypeOf _ = $dT
1145
1146 \begin{code}
1147 gen_Data_binds :: FixityEnv
1148                -> TyCon
1149                -> (LHsBinds RdrName,    -- The method bindings
1150                    DerivAuxBinds)       -- Auxiliary bindings
1151 gen_Data_binds fix_env tycon
1152   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1153                 -- Auxiliary definitions: the data type and constructors
1154      DerivAuxBind datatype_bind : map mk_con_bind data_cons)
1155   where
1156     tycon_loc  = getSrcSpan tycon
1157     tycon_name = tyConName tycon
1158     data_cons  = tyConDataCons tycon
1159     n_cons     = length data_cons
1160     one_constr = n_cons == 1
1161
1162         ------------ gfoldl
1163     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1164     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1165                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1166                    where
1167                      con_name ::  RdrName
1168                      con_name = getRdrName con
1169                      as_needed = take (dataConSourceArity con) as_RDRs
1170                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1171
1172         ------------ gunfold
1173     gunfold_bind = mk_FunBind tycon_loc
1174                               gunfold_RDR
1175                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1176                                 gunfold_rhs)]
1177
1178     gunfold_rhs
1179         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1180         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1181                                 (map gunfold_alt data_cons)
1182
1183     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1184     mk_unfold_rhs dc = foldr nlHsApp
1185                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1186                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1187
1188     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1189                         -- redundant test, and annoying warning
1190       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1191       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1192       where
1193         tag = dataConTag dc
1194
1195         ------------ toConstr
1196     toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1197     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1198
1199         ------------ dataTypeOf
1200     dataTypeOf_bind = mk_easy_FunBind
1201                         tycon_loc
1202                         dataTypeOf_RDR
1203                         [nlWildPat]
1204                         (nlHsVar data_type_name)
1205
1206         ------------  $dT
1207
1208     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1209     datatype_bind  = mkVarBind
1210                        tycon_loc
1211                        data_type_name
1212                        (           nlHsVar mkDataType_RDR
1213                          `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1214                          `nlHsApp` nlList constrs
1215                        )
1216     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1217
1218
1219         ------------  $cT1 etc
1220     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1221     mk_con_bind dc = DerivAuxBind $
1222                      mkVarBind
1223                        tycon_loc
1224                        (mk_constr_name dc)
1225                        (nlHsApps mkConstr_RDR (constr_args dc))
1226     constr_args dc =
1227          [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
1228            nlHsVar data_type_name,                              -- DataType
1229            nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1230            nlList  labels,                                      -- Field labels
1231            nlHsVar fixity]                                      -- Fixity
1232         where
1233           labels   = map (nlHsLit . mkHsString . getOccString)
1234                          (dataConFieldLabels dc)
1235           dc_occ   = getOccName dc
1236           is_infix = isDataSymOcc dc_occ
1237           fixity | is_infix  = infix_RDR
1238                  | otherwise = prefix_RDR
1239
1240 gfoldl_RDR     = varQual_RDR gENERICS (fsLit "gfoldl")
1241 gunfold_RDR    = varQual_RDR gENERICS (fsLit "gunfold")
1242 toConstr_RDR   = varQual_RDR gENERICS (fsLit "toConstr")
1243 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1244 mkConstr_RDR   = varQual_RDR gENERICS (fsLit "mkConstr")
1245 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1246 conIndex_RDR   = varQual_RDR gENERICS (fsLit "constrIndex")
1247 prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
1248 infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
1249 \end{code}
1250
1251 %************************************************************************
1252 %*                                                                      *
1253 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1254 %*                                                                      *
1255 %************************************************************************
1256
1257 \begin{verbatim}
1258 data Foo ... = ...
1259
1260 con2tag_Foo :: Foo ... -> Int#
1261 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1262 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1263 \end{verbatim}
1264
1265 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1266 fiddling around.
1267
1268 \begin{code}
1269 genAuxBind :: DerivAuxBind -> LHsBind RdrName
1270
1271 genAuxBind (DerivAuxBind bind)
1272   = bind
1273
1274 genAuxBind (GenCon2Tag tycon)
1275   | lots_of_constructors
1276   = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1277
1278   | otherwise
1279   = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1280
1281   where
1282     rdr_name = con2tag_RDR tycon
1283     tycon_loc = getSrcSpan tycon
1284
1285     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1286         -- We can't use gerRdrName because that makes an Exact  RdrName
1287         -- and we can't put them in the LocalRdrEnv
1288
1289         -- Give a signature to the bound variable, so
1290         -- that the case expression generated by getTag is
1291         -- monomorphic.  In the push-enter model we get better code.
1292     get_tag_rhs = noLoc $ ExprWithTySig
1293                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1294                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1295                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1296
1297     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1298                 `nlHsFunTy`
1299                 nlHsTyVar (getRdrName intPrimTyCon)
1300
1301     lots_of_constructors = tyConFamilySize tycon > 8
1302                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1303                                 -- but we don't do vectored returns any more.
1304
1305     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1306     mk_stuff con = ([nlWildConPat con],
1307                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1308
1309 genAuxBind (GenTag2Con tycon)
1310   = mk_FunBind (getSrcSpan tycon) rdr_name
1311         [([nlConVarPat intDataCon_RDR [a_RDR]],
1312            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1313                          (nlHsTyVar (getRdrName tycon))))]
1314   where
1315     rdr_name = tag2con_RDR tycon
1316
1317 genAuxBind (GenMaxTag tycon)
1318   = mkVarBind (getSrcSpan tycon) rdr_name
1319                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1320   where
1321     rdr_name = maxtag_RDR tycon
1322     max_tag =  case (tyConDataCons tycon) of
1323                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1324 \end{code}
1325
1326 %************************************************************************
1327 %*                                                                      *
1328 \subsection{Utility bits for generating bindings}
1329 %*                                                                      *
1330 %************************************************************************
1331
1332
1333 ToDo: Better SrcLocs.
1334
1335 \begin{code}
1336 compare_gen_Case ::
1337           LHsExpr RdrName       -- What to do for equality
1338           -> LHsExpr RdrName -> LHsExpr RdrName
1339           -> LHsExpr RdrName
1340 careful_compare_Case :: -- checks for primitive types...
1341           TyCon                 -- The tycon we are deriving for
1342           -> Type
1343           -> LHsExpr RdrName    -- What to do for equality
1344           -> LHsExpr RdrName -> LHsExpr RdrName
1345           -> LHsExpr RdrName
1346
1347 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1348         -- Was: compare_gen_Case cmp_eq_RDR
1349
1350 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1351   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1352 compare_gen_Case eq a b                         -- General case
1353   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1354       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1355        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1356        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1357
1358 careful_compare_Case tycon ty eq a b
1359   | not (isUnLiftedType ty)
1360   = compare_gen_Case eq a b
1361   | otherwise      -- We have to do something special for primitive things...
1362   = nlHsIf (genOpApp a relevant_lt_op b)        -- Test (<) first, not (==), becuase the latter
1363            ltTag_Expr                           -- is true less often, so putting it first would
1364                                                 -- mean more tests (dynamically)
1365            (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
1366   where
1367     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1368     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1369
1370
1371 box_if_necy :: String           -- The class involved
1372             -> TyCon            -- The tycon involved
1373             -> LHsExpr RdrName  -- The argument
1374             -> Type             -- The argument type
1375             -> LHsExpr RdrName  -- Boxed version of the arg
1376 box_if_necy cls_str tycon arg arg_ty
1377   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1378   | otherwise             = arg
1379   where
1380     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1381
1382 assoc_ty_id :: String           -- The class involved
1383             -> TyCon            -- The tycon involved
1384             -> [(Type,a)]       -- The table
1385             -> Type             -- The type
1386             -> a                -- The result of the lookup
1387 assoc_ty_id cls_str tycon tbl ty
1388   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1389                                               text "for primitive type" <+> ppr ty)
1390   | otherwise = head res
1391   where
1392     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1393
1394 eq_op_tbl :: [(Type, PrimOp)]
1395 eq_op_tbl =
1396     [(charPrimTy,       CharEqOp)
1397     ,(intPrimTy,        IntEqOp)
1398     ,(wordPrimTy,       WordEqOp)
1399     ,(addrPrimTy,       AddrEqOp)
1400     ,(floatPrimTy,      FloatEqOp)
1401     ,(doublePrimTy,     DoubleEqOp)
1402     ]
1403
1404 lt_op_tbl :: [(Type, PrimOp)]
1405 lt_op_tbl =
1406     [(charPrimTy,       CharLtOp)
1407     ,(intPrimTy,        IntLtOp)
1408     ,(wordPrimTy,       WordLtOp)
1409     ,(addrPrimTy,       AddrLtOp)
1410     ,(floatPrimTy,      FloatLtOp)
1411     ,(doublePrimTy,     DoubleLtOp)
1412     ]
1413
1414 box_con_tbl =
1415     [(charPrimTy,       getRdrName charDataCon)
1416     ,(intPrimTy,        getRdrName intDataCon)
1417     ,(wordPrimTy,       wordDataCon_RDR)
1418     ,(floatPrimTy,      getRdrName floatDataCon)
1419     ,(doublePrimTy,     getRdrName doubleDataCon)
1420     ]
1421
1422 -----------------------------------------------------------------------
1423
1424 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1425 and_Expr a b = genOpApp a and_RDR    b
1426
1427 -----------------------------------------------------------------------
1428
1429 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1430 eq_Expr tycon ty a b = genOpApp a eq_op b
1431  where
1432    eq_op
1433     | not (isUnLiftedType ty) = eq_RDR
1434     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1435          -- we have to do something special for primitive things...
1436 \end{code}
1437
1438 \begin{code}
1439 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1440 untag_Expr tycon [] expr = expr
1441 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1442   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1443       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1444
1445 cmp_tags_Expr ::  RdrName               -- Comparison op
1446              ->  RdrName ->  RdrName    -- Things to compare
1447              -> LHsExpr RdrName                 -- What to return if true
1448              -> LHsExpr RdrName         -- What to return if false
1449              -> LHsExpr RdrName
1450
1451 cmp_tags_Expr op a b true_case false_case
1452   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1453
1454 enum_from_to_Expr
1455         :: LHsExpr RdrName -> LHsExpr RdrName
1456         -> LHsExpr RdrName
1457 enum_from_then_to_Expr
1458         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1459         -> LHsExpr RdrName
1460
1461 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1462 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1463
1464 showParen_Expr
1465         :: LHsExpr RdrName -> LHsExpr RdrName
1466         -> LHsExpr RdrName
1467
1468 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1469
1470 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1471
1472 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1473 nested_compose_Expr [e] = parenify e
1474 nested_compose_Expr (e:es)
1475   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1476
1477 -- impossible_Expr is used in case RHSs that should never happen.
1478 -- We generate these to keep the desugarer from complaining that they *might* happen!
1479 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1480
1481 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1482 -- method. It is currently only used by Enum.{succ,pred}
1483 illegal_Expr meth tp msg =
1484    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1485
1486 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1487 -- to include the value of a_RDR in the error string.
1488 illegal_toEnum_tag tp maxtag =
1489    nlHsApp (nlHsVar error_RDR)
1490            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1491                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1492                     (nlHsApp (nlHsApp (nlHsApp
1493                            (nlHsVar showsPrec_RDR)
1494                            (nlHsIntLit 0))
1495                            (nlHsVar a_RDR))
1496                            (nlHsApp (nlHsApp
1497                                (nlHsVar append_RDR)
1498                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1499                                (nlHsApp (nlHsApp (nlHsApp
1500                                         (nlHsVar showsPrec_RDR)
1501                                         (nlHsIntLit 0))
1502                                         (nlHsVar maxtag))
1503                                         (nlHsLit (mkHsString ")"))))))
1504
1505 parenify e@(L _ (HsVar _)) = e
1506 parenify e                 = mkHsPar e
1507
1508 -- genOpApp wraps brackets round the operator application, so that the
1509 -- renamer won't subsequently try to re-associate it.
1510 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1511 \end{code}
1512
1513 \begin{code}
1514 a_RDR           = mkVarUnqual (fsLit "a")
1515 b_RDR           = mkVarUnqual (fsLit "b")
1516 c_RDR           = mkVarUnqual (fsLit "c")
1517 d_RDR           = mkVarUnqual (fsLit "d")
1518 k_RDR           = mkVarUnqual (fsLit "k")
1519 z_RDR           = mkVarUnqual (fsLit "z")
1520 ah_RDR          = mkVarUnqual (fsLit "a#")
1521 bh_RDR          = mkVarUnqual (fsLit "b#")
1522 ch_RDR          = mkVarUnqual (fsLit "c#")
1523 dh_RDR          = mkVarUnqual (fsLit "d#")
1524 cmp_eq_RDR      = mkVarUnqual (fsLit "cmp_eq")
1525
1526 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1527 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1528 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1529
1530 a_Expr          = nlHsVar a_RDR
1531 b_Expr          = nlHsVar b_RDR
1532 c_Expr          = nlHsVar c_RDR
1533 ltTag_Expr      = nlHsVar ltTag_RDR
1534 eqTag_Expr      = nlHsVar eqTag_RDR
1535 gtTag_Expr      = nlHsVar gtTag_RDR
1536 false_Expr      = nlHsVar false_RDR
1537 true_Expr       = nlHsVar true_RDR
1538
1539 a_Pat           = nlVarPat a_RDR
1540 b_Pat           = nlVarPat b_RDR
1541 c_Pat           = nlVarPat c_RDR
1542 d_Pat           = nlVarPat d_RDR
1543 k_Pat           = nlVarPat k_RDR
1544 z_Pat           = nlVarPat z_RDR
1545
1546 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon ->  RdrName
1547 -- Generates Orig s RdrName, for the binding positions
1548 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1549 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1550 maxtag_RDR  tycon = mk_tc_deriv_name tycon "maxtag_"
1551
1552 mk_tc_deriv_name tycon str
1553   = mkDerivedRdrName tc_name mk_occ
1554   where
1555     tc_name = tyConName tycon
1556     mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1557                   where
1558                     new_str = str ++ occNameString tc_occ ++ "#"
1559 \end{code}
1560
1561 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1562 PrelNames, so PrelNames can't import PrimOp.
1563
1564 \begin{code}
1565 primOpRdrName op = getRdrName (primOpId op)
1566
1567 minusInt_RDR  = primOpRdrName IntSubOp
1568 eqInt_RDR     = primOpRdrName IntEqOp
1569 ltInt_RDR     = primOpRdrName IntLtOp
1570 geInt_RDR     = primOpRdrName IntGeOp
1571 leInt_RDR     = primOpRdrName IntLeOp
1572 tagToEnum_RDR = primOpRdrName TagToEnumOp
1573
1574 error_RDR = getRdrName eRROR_ID
1575 \end{code}