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   = (unitBag compare, aux_binds)
 309         -- `AndMonoBinds` compare
 310         -- The default declaration in PrelBase handles this
 311   where
 312     tycon_loc = getSrcSpan tycon
 313     --------------------------------------------------------------------
 314     aux_binds | single_con_type = []
 315               | otherwise       = [GenCon2Tag tycon]
 316
 317     compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
 318     compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
 319     cmp_eq_binds    = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
 320
 321     compare_rhs
 322         | single_con_type = cmp_eq_Expr a_Expr b_Expr
 323         | otherwise
 324         = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 325                   (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
 326                         (cmp_eq_Expr a_Expr b_Expr)     -- True case
 327                         -- False case; they aren't equal
 328                         -- So we need to do a less-than comparison on the tags
 329                         (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
 330
 331     tycon_data_cons = tyConDataCons tycon
 332     single_con_type = isSingleton tycon_data_cons
 333     (nullary_cons, nonnullary_cons)
 334        | isNewTyCon tycon = ([], tyConDataCons tycon)
 335        | otherwise        = partition isNullarySrcDataCon tycon_data_cons
 336
 337     cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
 338     cmp_eq_match
 339       | isEnumerationTyCon tycon
 340                            -- We know the tags are equal, so if it's an enumeration TyCon,
 341                            -- then there is nothing left to do
 342                            -- Catch this specially to avoid warnings
 343                            -- about overlapping patterns from the desugarer,
 344                            -- and to avoid unnecessary pattern-matching
 345       = [([nlWildPat,nlWildPat], eqTag_Expr)]
 346       | otherwise
 347       = map pats_etc nonnullary_cons ++
 348         (if single_con_type then        -- Omit wildcards when there's just one
 349               []                        -- constructor, to silence desugarer
 350         else
 351               [([nlWildPat, nlWildPat], default_rhs)])
 352
 353     default_rhs | null nullary_cons = impossible_Expr   -- Keep desugarer from complaining about
 354                                                         -- inexhaustive patterns
 355                 | otherwise         = eqTag_Expr        -- Some nullary constructors;
 356                                                         -- Tags are equal, no args => return EQ
 357     pats_etc data_con
 358         = ([con1_pat, con2_pat],
 359            nested_compare_expr tys_needed as_needed bs_needed)
 360         where
 361           con1_pat = nlConVarPat data_con_RDR as_needed
 362           con2_pat = nlConVarPat data_con_RDR bs_needed
 363
 364           data_con_RDR = getRdrName data_con
 365           con_arity   = length tys_needed
 366           as_needed   = take con_arity as_RDRs
 367           bs_needed   = take con_arity bs_RDRs
 368           tys_needed  = dataConOrigArgTys data_con
 369
 370           nested_compare_expr [ty] [a] [b]
 371             = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
 372
 373           nested_compare_expr (ty:tys) (a:as) (b:bs)
 374             = let eq_expr = nested_compare_expr tys as bs
 375                 in  careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
 376
 377           nested_compare_expr _ _ _ = panic "nested_compare_expr"       -- Args always equal length
 378
 379 \end{code}
 380
 381 %************************************************************************
 382 %*                                                                      *
 383         Enum instances
 384 %*                                                                      *
 385 %************************************************************************
 386
 387 @Enum@ can only be derived for enumeration types.  For a type
 388 \begin{verbatim}
 389 data Foo ... = N1 | N2 | ... | Nn
 390 \end{verbatim}
 391
 392 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 393 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 394
 395 \begin{verbatim}
 396 instance ... Enum (Foo ...) where
 397     succ x   = toEnum (1 + fromEnum x)
 398     pred x   = toEnum (fromEnum x - 1)
 399
 400     toEnum i = tag2con_Foo i
 401
 402     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 403
 404     -- or, really...
 405     enumFrom a
 406       = case con2tag_Foo a of
 407           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 408
 409    enumFromThen a b
 410      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 411
 412     -- or, really...
 413     enumFromThen a b
 414       = case con2tag_Foo a of { a# ->
 415         case con2tag_Foo b of { b# ->
 416         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 417         }}
 418 \end{verbatim}
 419
 420 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 421
 422 \begin{code}
 423 gen_Enum_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 424 gen_Enum_binds tycon
 425   = (method_binds, aux_binds)
 426   where
 427     method_binds = listToBag [
 428                         succ_enum,
 429                         pred_enum,
 430                         to_enum,
 431                         enum_from,
 432                         enum_from_then,
 433                         from_enum
 434                     ]
 435     aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
 436
 437     tycon_loc = getSrcSpan tycon
 438     occ_nm    = getOccString tycon
 439
 440     succ_enum
 441       = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
 442         untag_Expr tycon [(a_RDR, ah_RDR)] $
 443         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
 444                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 445              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 446              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 447                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 448                                         nlHsIntLit 1]))
 449
 450     pred_enum
 451       = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
 452         untag_Expr tycon [(a_RDR, ah_RDR)] $
 453         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
 454                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 455              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 456              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 457                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 458                                                nlHsLit (HsInt (-1))]))
 459
 460     to_enum
 461       = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
 462         nlHsIf (nlHsApps and_RDR
 463                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
 464                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
 465              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
 466              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 467
 468     enum_from
 469       = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
 470           untag_Expr tycon [(a_RDR, ah_RDR)] $
 471           nlHsApps map_RDR
 472                 [nlHsVar (tag2con_RDR tycon),
 473                  nlHsPar (enum_from_to_Expr
 474                             (nlHsVarApps intDataCon_RDR [ah_RDR])
 475                             (nlHsVar (maxtag_RDR tycon)))]
 476
 477     enum_from_then
 478       = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
 479           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 480           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 481             nlHsPar (enum_from_then_to_Expr
 482                     (nlHsVarApps intDataCon_RDR [ah_RDR])
 483                     (nlHsVarApps intDataCon_RDR [bh_RDR])
 484                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 485                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
 486                            (nlHsIntLit 0)
 487                            (nlHsVar (maxtag_RDR tycon))
 488                            ))
 489
 490     from_enum
 491       = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
 492           untag_Expr tycon [(a_RDR, ah_RDR)] $
 493           (nlHsVarApps intDataCon_RDR [ah_RDR])
 494 \end{code}
 495
 496 %************************************************************************
 497 %*                                                                      *
 498         Bounded instances
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 \begin{code}
 503 gen_Bounded_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 504 gen_Bounded_binds tycon
 505   | isEnumerationTyCon tycon
 506   = (listToBag [ min_bound_enum, max_bound_enum ], [])
 507   | otherwise
 508   = ASSERT(isSingleton data_cons)
 509     (listToBag [ min_bound_1con, max_bound_1con ], [])
 510   where
 511     data_cons = tyConDataCons tycon
 512     tycon_loc = getSrcSpan tycon
 513
 514     ----- enum-flavored: ---------------------------
 515     min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
 516     max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
 517
 518     data_con_1    = head data_cons
 519     data_con_N    = last data_cons
 520     data_con_1_RDR = getRdrName data_con_1
 521     data_con_N_RDR = getRdrName data_con_N
 522
 523     ----- single-constructor-flavored: -------------
 524     arity          = dataConSourceArity data_con_1
 525
 526     min_bound_1con = mkVarBind tycon_loc minBound_RDR $
 527                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 528     max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
 529                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 530 \end{code}
 531
 532 %************************************************************************
 533 %*                                                                      *
 534         Ix instances
 535 %*                                                                      *
 536 %************************************************************************
 537
 538 Deriving @Ix@ is only possible for enumeration types and
 539 single-constructor types.  We deal with them in turn.
 540
 541 For an enumeration type, e.g.,
 542 \begin{verbatim}
 543     data Foo ... = N1 | N2 | ... | Nn
 544 \end{verbatim}
 545 things go not too differently from @Enum@:
 546 \begin{verbatim}
 547 instance ... Ix (Foo ...) where
 548     range (a, b)
 549       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 550
 551     -- or, really...
 552     range (a, b)
 553       = case (con2tag_Foo a) of { a# ->
 554         case (con2tag_Foo b) of { b# ->
 555         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 556         }}
 557
 558     -- Generate code for unsafeIndex, becuase using index leads
 559     -- to lots of redundant range tests
 560     unsafeIndex c@(a, b) d
 561       = case (con2tag_Foo d -# con2tag_Foo a) of
 562                r# -> I# r#
 563
 564     inRange (a, b) c
 565       = let
 566             p_tag = con2tag_Foo c
 567         in
 568         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 569
 570     -- or, really...
 571     inRange (a, b) c
 572       = case (con2tag_Foo a)   of { a_tag ->
 573         case (con2tag_Foo b)   of { b_tag ->
 574         case (con2tag_Foo c)   of { c_tag ->
 575         if (c_tag >=# a_tag) then
 576           c_tag <=# b_tag
 577         else
 578           False
 579         }}}
 580 \end{verbatim}
 581 (modulo suitable case-ification to handle the unlifted tags)
 582
 583 For a single-constructor type (NB: this includes all tuples), e.g.,
 584 \begin{verbatim}
 585     data Foo ... = MkFoo a b Int Double c c
 586 \end{verbatim}
 587 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 588 (p.~147).
 589
 590 \begin{code}
 591 gen_Ix_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 592
 593 gen_Ix_binds tycon
 594   | isEnumerationTyCon tycon
 595   = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
 596   | otherwise
 597   = (single_con_ixes, [GenCon2Tag tycon])
 598   where
 599     tycon_loc = getSrcSpan tycon
 600
 601     --------------------------------------------------------------
 602     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 603
 604     enum_range
 605       = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
 606           untag_Expr tycon [(a_RDR, ah_RDR)] $
 607           untag_Expr tycon [(b_RDR, bh_RDR)] $
 608           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 609               nlHsPar (enum_from_to_Expr
 610                         (nlHsVarApps intDataCon_RDR [ah_RDR])
 611                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 612
 613     enum_index
 614       = mk_easy_FunBind tycon_loc unsafeIndex_RDR
 615                 [noLoc (AsPat (noLoc c_RDR)
 616                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
 617                                 d_Pat] (
 618            untag_Expr tycon [(a_RDR, ah_RDR)] (
 619            untag_Expr tycon [(d_RDR, dh_RDR)] (
 620            let
 621                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
 622            in
 623            nlHsCase
 624              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
 625              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
 626            ))
 627         )
 628
 629     enum_inRange
 630       = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
 631           untag_Expr tycon [(a_RDR, ah_RDR)] (
 632           untag_Expr tycon [(b_RDR, bh_RDR)] (
 633           untag_Expr tycon [(c_RDR, ch_RDR)] (
 634           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
 635              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
 636           ) {-else-} (
 637              false_Expr
 638           ))))
 639
 640     --------------------------------------------------------------
 641     single_con_ixes
 642       = listToBag [single_con_range, single_con_index, single_con_inRange]
 643
 644     data_con
 645       = case maybeTyConSingleCon tycon of -- just checking...
 646           Nothing -> panic "get_Ix_binds"
 647           Just dc | any isUnLiftedType (dataConOrigArgTys dc)
 648                   -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
 649                   | otherwise -> dc
 650
 651     con_arity    = dataConSourceArity data_con
 652     data_con_RDR = getRdrName data_con
 653
 654     as_needed = take con_arity as_RDRs
 655     bs_needed = take con_arity bs_RDRs
 656     cs_needed = take con_arity cs_RDRs
 657
 658     con_pat  xs  = nlConVarPat data_con_RDR xs
 659     con_expr     = nlHsVarApps data_con_RDR cs_needed
 660
 661     --------------------------------------------------------------
 662     single_con_range
 663       = mk_easy_FunBind tycon_loc range_RDR
 664           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
 665         nlHsDo ListComp stmts con_expr
 666       where
 667         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 668
 669         mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
 670                                  (nlHsApp (nlHsVar range_RDR)
 671                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
 672
 673     ----------------
 674     single_con_index
 675       = mk_easy_FunBind tycon_loc unsafeIndex_RDR
 676                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 677                  con_pat cs_needed]
 678                 (mk_index (zip3 as_needed bs_needed cs_needed))
 679       where
 680         -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
 681         mk_index []        = nlHsIntLit 0
 682         mk_index [(l,u,i)] = mk_one l u i
 683         mk_index ((l,u,i) : rest)
 684           = genOpApp (
 685                 mk_one l u i
 686             ) plus_RDR (
 687                 genOpApp (
 688                     (nlHsApp (nlHsVar unsafeRangeSize_RDR)
 689                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
 690                 ) times_RDR (mk_index rest)
 691            )
 692         mk_one l u i
 693           = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
 694
 695     ------------------
 696     single_con_inRange
 697       = mk_easy_FunBind tycon_loc inRange_RDR
 698                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 699                  con_pat cs_needed] $
 700           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
 701       where
 702         in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
 703                                                nlHsVar c]
 704 \end{code}
 705
 706 %************************************************************************
 707 %*                                                                      *
 708         Read instances
 709 %*                                                                      *
 710 %************************************************************************
 711
 712 Example
 713
 714   infix 4 %%
 715   data T = Int %% Int
 716          | T1 { f1 :: Int }
 717          | T2 T
 718
 719
 720 instance Read T where
 721   readPrec =
 722     parens
 723     ( prec 4 (
 724         do x           <- ReadP.step Read.readPrec
 725            Symbol "%%" <- Lex.lex
 726            y           <- ReadP.step Read.readPrec
 727            return (x %% y))
 728       +++
 729       prec (appPrec+1) (
 730         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 731         -- Record construction binds even more tightly than application
 732         do Ident "T1" <- Lex.lex
 733            Punc '{' <- Lex.lex
 734            Ident "f1" <- Lex.lex
 735            Punc '=' <- Lex.lex
 736            x          <- ReadP.reset Read.readPrec
 737            Punc '}' <- Lex.lex
 738            return (T1 { f1 = x }))
 739       +++
 740       prec appPrec (
 741         do Ident "T2" <- Lex.lexP
 742            x          <- ReadP.step Read.readPrec
 743            return (T2 x))
 744     )
 745
 746   readListPrec = readListPrecDefault
 747   readList     = readListDefault
 748
 749
 750 \begin{code}
 751 gen_Read_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 752
 753 gen_Read_binds get_fixity tycon
 754   = (listToBag [read_prec, default_readlist, default_readlistprec], [])
 755   where
 756     -----------------------------------------------------------------------
 757     default_readlist
 758         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 759
 760     default_readlistprec
 761         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 762     -----------------------------------------------------------------------
 763
 764     loc       = getSrcSpan tycon
 765     data_cons = tyConDataCons tycon
 766     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 767
 768     read_prec = mkVarBind loc readPrec_RDR
 769                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 770
 771     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 772     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 773
 774     read_nullary_cons
 775       = case nullary_cons of
 776             []    -> []
 777             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
 778                                     (result_expr con [])]
 779             _     -> [nlHsApp (nlHsVar choose_RDR)
 780                               (nlList (map mk_pair nullary_cons))]
 781
 782     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
 783                            result_expr con []]
 784                           Boxed
 785
 786     read_non_nullary_con data_con
 787       | is_infix  = mk_parser infix_prec  infix_stmts  body
 788       | is_record = mk_parser record_prec record_stmts body
 789 --              Using these two lines instead allows the derived
 790 --              read for infix and record bindings to read the prefix form
 791 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 792 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 793       | otherwise = prefix_parser
 794       where
 795         body = result_expr data_con as_needed
 796         con_str = data_con_str data_con
 797
 798         prefix_parser = mk_parser prefix_prec prefix_stmts body
 799         prefix_stmts            -- T a b c
 800           = (if not (isSym con_str) then
 801                   [bindLex (ident_pat con_str)]
 802              else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
 803             ++ read_args
 804
 805         infix_stmts             -- a %% b, or  a `T` b
 806           = [read_a1]
 807             ++  (if isSym con_str
 808                  then [bindLex (symbol_pat con_str)]
 809                  else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
 810             ++ [read_a2]
 811
 812         record_stmts            -- T { f1 = a, f2 = b }
 813           = [bindLex (ident_pat (wrapOpParens con_str)),
 814              read_punc "{"]
 815             ++ concat (intersperse [read_punc ","] field_stmts)
 816             ++ [read_punc "}"]
 817
 818         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 819
 820         con_arity    = dataConSourceArity data_con
 821         labels       = dataConFieldLabels data_con
 822         dc_nm        = getName data_con
 823         is_infix     = dataConIsInfix data_con
 824         is_record    = length labels > 0
 825         as_needed    = take con_arity as_RDRs
 826         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 827         (read_a1:read_a2:_) = read_args
 828
 829         prefix_prec = appPrecedence
 830         infix_prec  = getPrecedence get_fixity dc_nm
 831         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 832                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 833
 834     ------------------------------------------------------------------------
 835     --          Helpers
 836     ------------------------------------------------------------------------
 837     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
 838     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
 839     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
 840     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
 841     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
 842
 843     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 844     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 845     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 846
 847     data_con_str con = occNameString (getOccName con)
 848
 849     read_punc c = bindLex (punc_pat c)
 850     read_arg a ty
 851         | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
 852         | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 853
 854     read_field lbl a = read_lbl lbl ++
 855                        [read_punc "=",
 856                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 857
 858         -- When reading field labels we might encounter
 859         --      a  = 3
 860         --      _a = 3
 861         -- or   (#) = 4
 862         -- Note the parens!
 863     read_lbl lbl | isSym lbl_str
 864                  = [read_punc "(",
 865                     bindLex (symbol_pat lbl_str),
 866                     read_punc ")"]
 867                  | otherwise
 868                  = [bindLex (ident_pat lbl_str)]
 869                  where
 870                    lbl_str = occNameString (getOccName lbl)
 871 \end{code}
 872
 873
 874 %************************************************************************
 875 %*                                                                      *
 876         Show instances
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 Example
 881
 882     infixr 5 :^:
 883
 884     data Tree a =  Leaf a  |  Tree a :^: Tree a
 885
 886     instance (Show a) => Show (Tree a) where
 887
 888         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 889           where
 890              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 891
 892         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 893           where
 894              showStr = showsPrec (up_prec+1) u .
 895                        showString " :^: "      .
 896                        showsPrec (up_prec+1) v
 897                 -- Note: right-associativity of :^: ignored
 898
 899     up_prec  = 5    -- Precedence of :^:
 900     app_prec = 10   -- Application has precedence one more than
 901                     -- the most tightly-binding operator
 902
 903 \begin{code}
 904 gen_Show_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
 905
 906 gen_Show_binds get_fixity tycon
 907   = (listToBag [shows_prec, show_list], [])
 908   where
 909     tycon_loc = getSrcSpan tycon
 910     -----------------------------------------------------------------------
 911     show_list = mkVarBind tycon_loc showList_RDR
 912                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 913     -----------------------------------------------------------------------
 914     shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 915       where
 916         pats_etc data_con
 917           | nullary_con =  -- skip the showParen junk...
 918              ASSERT(null bs_needed)
 919              ([nlWildPat, con_pat], mk_showString_app con_str)
 920           | otherwise   =
 921              ([a_Pat, con_pat],
 922                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 923                                  (nlHsPar (nested_compose_Expr show_thingies)))
 924             where
 925              data_con_RDR  = getRdrName data_con
 926              con_arity     = dataConSourceArity data_con
 927              bs_needed     = take con_arity bs_RDRs
 928              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 929              con_pat       = nlConVarPat data_con_RDR bs_needed
 930              nullary_con   = con_arity == 0
 931              labels        = dataConFieldLabels data_con
 932              lab_fields    = length labels
 933              record_syntax = lab_fields > 0
 934
 935              dc_nm          = getName data_con
 936              dc_occ_nm      = getOccName data_con
 937              con_str        = occNameString dc_occ_nm
 938              op_con_str     = wrapOpParens con_str
 939              backquote_str  = wrapOpBackquotes con_str
 940
 941              show_thingies
 942                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
 943                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
 944                                   show_record_args ++ [mk_showString_app "}"]
 945                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
 946
 947              show_label l = mk_showString_app (nm ++ " = ")
 948                         -- Note the spaces around the "=" sign.  If we don't have them
 949                         -- then we get Foo { x=-1 } and the "=-" parses as a single
 950                         -- lexeme.  Only the space after the '=' is necessary, but
 951                         -- it seems tidier to have them both sides.
 952                  where
 953                    occ_nm   = getOccName l
 954                    nm       = wrapOpParens (occNameString occ_nm)
 955
 956              show_args               = zipWith show_arg bs_needed arg_tys
 957              (show_arg1:show_arg2:_) = show_args
 958              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
 959
 960                 --  Assumption for record syntax: no of fields == no of labelled fields
 961                 --            (and in same order)
 962              show_record_args = concat $
 963                                 intersperse [mk_showString_app ", "] $
 964                                 [ [show_label lbl, arg]
 965                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
 966                                                         labels show_args ]
 967
 968                 -- Generates (showsPrec p x) for argument x, but it also boxes
 969                 -- the argument first if necessary.  Note that this prints unboxed
 970                 -- things without any '#' decorations; could change that if need be
 971              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
 972                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
 973
 974                 -- Fixity stuff
 975              is_infix = dataConIsInfix data_con
 976              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
 977              arg_prec | record_syntax = 0       -- Record fields don't need parens
 978                       | otherwise     = con_prec_plus_one
 979
 980 wrapOpParens :: String -> String
 981 wrapOpParens s | isSym s   = '(' : s ++ ")"
 982                | otherwise = s
 983
 984 wrapOpBackquotes :: String -> String
 985 wrapOpBackquotes s | isSym s   = s
 986                    | otherwise = '`' : s ++ "`"
 987
 988 isSym :: String -> Bool
 989 isSym ""     = False
 990 isSym (c:cs) = startsVarSym c || startsConSym c
 991
 992 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 993 \end{code}
 994
 995 \begin{code}
 996 getPrec :: Bool -> FixityEnv -> Name -> Integer
 997 getPrec is_infix get_fixity nm
 998   | not is_infix   = appPrecedence
 999   | otherwise      = getPrecedence get_fixity nm
1000
1001 appPrecedence :: Integer
1002 appPrecedence = fromIntegral maxPrecedence + 1
1003   -- One more than the precedence of the most
1004   -- tightly-binding operator
1005
1006 getPrecedence :: FixityEnv -> Name -> Integer
1007 getPrecedence get_fixity nm
1008    = case lookupFixity get_fixity nm of
1009         Fixity x _ -> fromIntegral x
1010 \end{code}
1011
1012
1013 %************************************************************************
1014 %*                                                                      *
1015 \subsection{Typeable}
1016 %*                                                                      *
1017 %************************************************************************
1018
1019 From the data type
1020
1021         data T a b = ....
1022
1023 we generate
1024
1025         instance Typeable2 T where
1026                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1027
1028 We are passed the Typeable2 class as well as T
1029
1030 \begin{code}
1031 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1032 gen_Typeable_binds tycon
1033   = unitBag $
1034         mk_easy_FunBind tycon_loc
1035                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1036                 [nlWildPat]
1037                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1038   where
1039     tycon_loc = getSrcSpan tycon
1040     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1041
1042 mk_typeOf_RDR :: TyCon -> RdrName
1043 -- Use the arity of the TyCon to make the right typeOfn function
1044 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1045                 where
1046                   arity = tyConArity tycon
1047                   suffix | arity == 0 = ""
1048                          | otherwise  = show arity
1049 \end{code}
1050
1051
1052
1053 %************************************************************************
1054 %*                                                                      *
1055         Data instances
1056 %*                                                                      *
1057 %************************************************************************
1058
1059 From the data type
1060
1061   data T a b = T1 a b | T2
1062
1063 we generate
1064
1065   $cT1 = mkDataCon $dT "T1" Prefix
1066   $cT2 = mkDataCon $dT "T2" Prefix
1067   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1068   -- the [] is for field labels.
1069
1070   instance (Data a, Data b) => Data (T a b) where
1071     gfoldl k z (T1 a b) = z T `k` a `k` b
1072     gfoldl k z T2           = z T2
1073     -- ToDo: add gmapT,Q,M, gfoldr
1074
1075     gunfold k z c = case conIndex c of
1076                         I# 1# -> k (k (z T1))
1077                         I# 2# -> z T2
1078
1079     toConstr (T1 _ _) = $cT1
1080     toConstr T2       = $cT2
1081
1082     dataTypeOf _ = $dT
1083
1084 \begin{code}
1085 gen_Data_binds :: FixityEnv
1086                -> TyCon
1087                -> (LHsBinds RdrName,    -- The method bindings
1088                    DerivAuxBinds)       -- Auxiliary bindings
1089 gen_Data_binds fix_env tycon
1090   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1091                 -- Auxiliary definitions: the data type and constructors
1092      DerivAuxBind datatype_bind : map mk_con_bind data_cons)
1093   where
1094     tycon_loc  = getSrcSpan tycon
1095     tycon_name = tyConName tycon
1096     data_cons  = tyConDataCons tycon
1097     n_cons     = length data_cons
1098     one_constr = n_cons == 1
1099
1100         ------------ gfoldl
1101     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1102     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1103                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1104                    where
1105                      con_name ::  RdrName
1106                      con_name = getRdrName con
1107                      as_needed = take (dataConSourceArity con) as_RDRs
1108                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1109
1110         ------------ gunfold
1111     gunfold_bind = mk_FunBind tycon_loc
1112                               gunfold_RDR
1113                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1114                                 gunfold_rhs)]
1115
1116     gunfold_rhs
1117         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1118         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1119                                 (map gunfold_alt data_cons)
1120
1121     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1122     mk_unfold_rhs dc = foldr nlHsApp
1123                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1124                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1125
1126     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1127                         -- redundant test, and annoying warning
1128       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1129       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1130       where
1131         tag = dataConTag dc
1132
1133         ------------ toConstr
1134     toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1135     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1136
1137         ------------ dataTypeOf
1138     dataTypeOf_bind = mk_easy_FunBind
1139                         tycon_loc
1140                         dataTypeOf_RDR
1141                         [nlWildPat]
1142                         (nlHsVar data_type_name)
1143
1144         ------------  $dT
1145
1146     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1147     datatype_bind  = mkVarBind
1148                        tycon_loc
1149                        data_type_name
1150                        (           nlHsVar mkDataType_RDR
1151                          `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1152                          `nlHsApp` nlList constrs
1153                        )
1154     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1155
1156
1157         ------------  $cT1 etc
1158     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1159     mk_con_bind dc = DerivAuxBind $
1160                      mkVarBind
1161                        tycon_loc
1162                        (mk_constr_name dc)
1163                        (nlHsApps mkConstr_RDR (constr_args dc))
1164     constr_args dc =
1165          [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
1166            nlHsVar data_type_name,                              -- DataType
1167            nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1168            nlList  labels,                                      -- Field labels
1169            nlHsVar fixity]                                      -- Fixity
1170         where
1171           labels   = map (nlHsLit . mkHsString . getOccString)
1172                          (dataConFieldLabels dc)
1173           dc_occ   = getOccName dc
1174           is_infix = isDataSymOcc dc_occ
1175           fixity | is_infix  = infix_RDR
1176                  | otherwise = prefix_RDR
1177
1178 gfoldl_RDR     = varQual_RDR gENERICS FSLIT("gfoldl")
1179 gunfold_RDR    = varQual_RDR gENERICS FSLIT("gunfold")
1180 toConstr_RDR   = varQual_RDR gENERICS FSLIT("toConstr")
1181 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1182 mkConstr_RDR   = varQual_RDR gENERICS FSLIT("mkConstr")
1183 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1184 conIndex_RDR   = varQual_RDR gENERICS FSLIT("constrIndex")
1185 prefix_RDR     = dataQual_RDR gENERICS FSLIT("Prefix")
1186 infix_RDR      = dataQual_RDR gENERICS FSLIT("Infix")
1187 \end{code}
1188
1189 %************************************************************************
1190 %*                                                                      *
1191 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1192 %*                                                                      *
1193 %************************************************************************
1194
1195 \begin{verbatim}
1196 data Foo ... = ...
1197
1198 con2tag_Foo :: Foo ... -> Int#
1199 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1200 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1201 \end{verbatim}
1202
1203 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1204 fiddling around.
1205
1206 \begin{code}
1207 genAuxBind :: DerivAuxBind -> LHsBind RdrName
1208
1209 genAuxBind (DerivAuxBind bind)
1210   = bind
1211
1212 genAuxBind (GenCon2Tag tycon)
1213   | lots_of_constructors
1214   = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1215
1216   | otherwise
1217   = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1218
1219   where
1220     rdr_name = con2tag_RDR tycon
1221     tycon_loc = getSrcSpan tycon
1222
1223     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1224         -- We can't use gerRdrName because that makes an Exact  RdrName
1225         -- and we can't put them in the LocalRdrEnv
1226
1227         -- Give a signature to the bound variable, so
1228         -- that the case expression generated by getTag is
1229         -- monomorphic.  In the push-enter model we get better code.
1230     get_tag_rhs = noLoc $ ExprWithTySig
1231                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1232                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1233                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1234
1235     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1236                 `nlHsFunTy`
1237                 nlHsTyVar (getRdrName intPrimTyCon)
1238
1239     lots_of_constructors = tyConFamilySize tycon > 8
1240                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1241                                 -- but we don't do vectored returns any more.
1242
1243     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1244     mk_stuff con = ([nlWildConPat con],
1245                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1246
1247 genAuxBind (GenTag2Con tycon)
1248   = mk_FunBind (getSrcSpan tycon) rdr_name
1249         [([nlConVarPat intDataCon_RDR [a_RDR]],
1250            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1251                          (nlHsTyVar (getRdrName tycon))))]
1252   where
1253     rdr_name = tag2con_RDR tycon
1254
1255 genAuxBind (GenMaxTag tycon)
1256   = mkVarBind (getSrcSpan tycon) rdr_name
1257                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1258   where
1259     rdr_name = maxtag_RDR tycon
1260     max_tag =  case (tyConDataCons tycon) of
1261                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1262 \end{code}
1263
1264 %************************************************************************
1265 %*                                                                      *
1266 \subsection{Utility bits for generating bindings}
1267 %*                                                                      *
1268 %************************************************************************
1269
1270
1271 ToDo: Better SrcLocs.
1272
1273 \begin{code}
1274 compare_gen_Case ::
1275           LHsExpr RdrName       -- What to do for equality
1276           -> LHsExpr RdrName -> LHsExpr RdrName
1277           -> LHsExpr RdrName
1278 careful_compare_Case :: -- checks for primitive types...
1279           TyCon                 -- The tycon we are deriving for
1280           -> Type
1281           -> LHsExpr RdrName    -- What to do for equality
1282           -> LHsExpr RdrName -> LHsExpr RdrName
1283           -> LHsExpr RdrName
1284
1285 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1286         -- Was: compare_gen_Case cmp_eq_RDR
1287
1288 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1289   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1290 compare_gen_Case eq a b                         -- General case
1291   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1292       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1293        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1294        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1295
1296 careful_compare_Case tycon ty eq a b
1297   | not (isUnLiftedType ty)
1298   = compare_gen_Case eq a b
1299   | otherwise      -- We have to do something special for primitive things...
1300   = nlHsIf (genOpApp a relevant_eq_op b)
1301          eq
1302          (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1303   where
1304     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1305     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1306
1307
1308 box_if_necy :: String           -- The class involved
1309             -> TyCon            -- The tycon involved
1310             -> LHsExpr RdrName  -- The argument
1311             -> Type             -- The argument type
1312             -> LHsExpr RdrName  -- Boxed version of the arg
1313 box_if_necy cls_str tycon arg arg_ty
1314   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1315   | otherwise             = arg
1316   where
1317     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1318
1319 assoc_ty_id :: String           -- The class involved
1320             -> TyCon            -- The tycon involved
1321             -> [(Type,a)]       -- The table
1322             -> Type             -- The type
1323             -> a                -- The result of the lookup
1324 assoc_ty_id cls_str tycon tbl ty
1325   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1326                                               text "for primitive type" <+> ppr ty)
1327   | otherwise = head res
1328   where
1329     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1330
1331 eq_op_tbl :: [(Type, PrimOp)]
1332 eq_op_tbl =
1333     [(charPrimTy,       CharEqOp)
1334     ,(intPrimTy,        IntEqOp)
1335     ,(wordPrimTy,       WordEqOp)
1336     ,(addrPrimTy,       AddrEqOp)
1337     ,(floatPrimTy,      FloatEqOp)
1338     ,(doublePrimTy,     DoubleEqOp)
1339     ]
1340
1341 lt_op_tbl :: [(Type, PrimOp)]
1342 lt_op_tbl =
1343     [(charPrimTy,       CharLtOp)
1344     ,(intPrimTy,        IntLtOp)
1345     ,(wordPrimTy,       WordLtOp)
1346     ,(addrPrimTy,       AddrLtOp)
1347     ,(floatPrimTy,      FloatLtOp)
1348     ,(doublePrimTy,     DoubleLtOp)
1349     ]
1350
1351 box_con_tbl =
1352     [(charPrimTy,       getRdrName charDataCon)
1353     ,(intPrimTy,        getRdrName intDataCon)
1354     ,(wordPrimTy,       wordDataCon_RDR)
1355     ,(floatPrimTy,      getRdrName floatDataCon)
1356     ,(doublePrimTy,     getRdrName doubleDataCon)
1357     ]
1358
1359 -----------------------------------------------------------------------
1360
1361 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1362 and_Expr a b = genOpApp a and_RDR    b
1363
1364 -----------------------------------------------------------------------
1365
1366 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1367 eq_Expr tycon ty a b = genOpApp a eq_op b
1368  where
1369    eq_op
1370     | not (isUnLiftedType ty) = eq_RDR
1371     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1372          -- we have to do something special for primitive things...
1373 \end{code}
1374
1375 \begin{code}
1376 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1377 untag_Expr tycon [] expr = expr
1378 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1379   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1380       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1381
1382 cmp_tags_Expr ::  RdrName               -- Comparison op
1383              ->  RdrName ->  RdrName    -- Things to compare
1384              -> LHsExpr RdrName                 -- What to return if true
1385              -> LHsExpr RdrName         -- What to return if false
1386              -> LHsExpr RdrName
1387
1388 cmp_tags_Expr op a b true_case false_case
1389   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1390
1391 enum_from_to_Expr
1392         :: LHsExpr RdrName -> LHsExpr RdrName
1393         -> LHsExpr RdrName
1394 enum_from_then_to_Expr
1395         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1396         -> LHsExpr RdrName
1397
1398 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1399 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1400
1401 showParen_Expr
1402         :: LHsExpr RdrName -> LHsExpr RdrName
1403         -> LHsExpr RdrName
1404
1405 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1406
1407 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1408
1409 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1410 nested_compose_Expr [e] = parenify e
1411 nested_compose_Expr (e:es)
1412   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1413
1414 -- impossible_Expr is used in case RHSs that should never happen.
1415 -- We generate these to keep the desugarer from complaining that they *might* happen!
1416 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1417
1418 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1419 -- method. It is currently only used by Enum.{succ,pred}
1420 illegal_Expr meth tp msg =
1421    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1422
1423 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1424 -- to include the value of a_RDR in the error string.
1425 illegal_toEnum_tag tp maxtag =
1426    nlHsApp (nlHsVar error_RDR)
1427            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1428                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1429                     (nlHsApp (nlHsApp (nlHsApp
1430                            (nlHsVar showsPrec_RDR)
1431                            (nlHsIntLit 0))
1432                            (nlHsVar a_RDR))
1433                            (nlHsApp (nlHsApp
1434                                (nlHsVar append_RDR)
1435                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1436                                (nlHsApp (nlHsApp (nlHsApp
1437                                         (nlHsVar showsPrec_RDR)
1438                                         (nlHsIntLit 0))
1439                                         (nlHsVar maxtag))
1440                                         (nlHsLit (mkHsString ")"))))))
1441
1442 parenify e@(L _ (HsVar _)) = e
1443 parenify e                 = mkHsPar e
1444
1445 -- genOpApp wraps brackets round the operator application, so that the
1446 -- renamer won't subsequently try to re-associate it.
1447 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1448 \end{code}
1449
1450 \begin{code}
1451 a_RDR           = mkVarUnqual FSLIT("a")
1452 b_RDR           = mkVarUnqual FSLIT("b")
1453 c_RDR           = mkVarUnqual FSLIT("c")
1454 d_RDR           = mkVarUnqual FSLIT("d")
1455 k_RDR           = mkVarUnqual FSLIT("k")
1456 z_RDR           = mkVarUnqual FSLIT("z")
1457 ah_RDR          = mkVarUnqual FSLIT("a#")
1458 bh_RDR          = mkVarUnqual FSLIT("b#")
1459 ch_RDR          = mkVarUnqual FSLIT("c#")
1460 dh_RDR          = mkVarUnqual FSLIT("d#")
1461 cmp_eq_RDR      = mkVarUnqual FSLIT("cmp_eq")
1462
1463 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1464 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1465 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1466
1467 a_Expr          = nlHsVar a_RDR
1468 b_Expr          = nlHsVar b_RDR
1469 c_Expr          = nlHsVar c_RDR
1470 ltTag_Expr      = nlHsVar ltTag_RDR
1471 eqTag_Expr      = nlHsVar eqTag_RDR
1472 gtTag_Expr      = nlHsVar gtTag_RDR
1473 false_Expr      = nlHsVar false_RDR
1474 true_Expr       = nlHsVar true_RDR
1475
1476 a_Pat           = nlVarPat a_RDR
1477 b_Pat           = nlVarPat b_RDR
1478 c_Pat           = nlVarPat c_RDR
1479 d_Pat           = nlVarPat d_RDR
1480 k_Pat           = nlVarPat k_RDR
1481 z_Pat           = nlVarPat z_RDR
1482
1483 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon ->  RdrName
1484 -- Generates Orig s RdrName, for the binding positions
1485 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1486 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1487 maxtag_RDR  tycon = mk_tc_deriv_name tycon "maxtag_"
1488
1489 mk_tc_deriv_name tycon str
1490   = mkDerivedRdrName tc_name mk_occ
1491   where
1492     tc_name = tyConName tycon
1493     mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1494                   where
1495                     new_str = str ++ occNameString tc_occ ++ "#"
1496 \end{code}
1497
1498 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1499 PrelNames, so PrelNames can't import PrimOp.
1500
1501 \begin{code}
1502 primOpRdrName op = getRdrName (primOpId op)
1503
1504 minusInt_RDR  = primOpRdrName IntSubOp
1505 eqInt_RDR     = primOpRdrName IntEqOp
1506 ltInt_RDR     = primOpRdrName IntLtOp
1507 geInt_RDR     = primOpRdrName IntGeOp
1508 leInt_RDR     = primOpRdrName IntLeOp
1509 tagToEnum_RDR = primOpRdrName TagToEnumOp
1510
1511 error_RDR = getRdrName eRROR_ID
1512 \end{code}