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 _assoc -> fromIntegral x
1010           -- NB: the Report says that associativity is not taken
1011           --     into account for either Read or Show; hence we
1012           --     ignore associativity here
1013 \end{code}
1014
1015
1016 %************************************************************************
1017 %*                                                                      *
1018 \subsection{Typeable}
1019 %*                                                                      *
1020 %************************************************************************
1021
1022 From the data type
1023
1024         data T a b = ....
1025
1026 we generate
1027
1028         instance Typeable2 T where
1029                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1030
1031 We are passed the Typeable2 class as well as T
1032
1033 \begin{code}
1034 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1035 gen_Typeable_binds tycon
1036   = unitBag $
1037         mk_easy_FunBind tycon_loc
1038                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1039                 [nlWildPat]
1040                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1041   where
1042     tycon_loc = getSrcSpan tycon
1043     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1044
1045 mk_typeOf_RDR :: TyCon -> RdrName
1046 -- Use the arity of the TyCon to make the right typeOfn function
1047 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1048                 where
1049                   arity = tyConArity tycon
1050                   suffix | arity == 0 = ""
1051                          | otherwise  = show arity
1052 \end{code}
1053
1054
1055
1056 %************************************************************************
1057 %*                                                                      *
1058         Data instances
1059 %*                                                                      *
1060 %************************************************************************
1061
1062 From the data type
1063
1064   data T a b = T1 a b | T2
1065
1066 we generate
1067
1068   $cT1 = mkDataCon $dT "T1" Prefix
1069   $cT2 = mkDataCon $dT "T2" Prefix
1070   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1071   -- the [] is for field labels.
1072
1073   instance (Data a, Data b) => Data (T a b) where
1074     gfoldl k z (T1 a b) = z T `k` a `k` b
1075     gfoldl k z T2           = z T2
1076     -- ToDo: add gmapT,Q,M, gfoldr
1077
1078     gunfold k z c = case conIndex c of
1079                         I# 1# -> k (k (z T1))
1080                         I# 2# -> z T2
1081
1082     toConstr (T1 _ _) = $cT1
1083     toConstr T2       = $cT2
1084
1085     dataTypeOf _ = $dT
1086
1087 \begin{code}
1088 gen_Data_binds :: FixityEnv
1089                -> TyCon
1090                -> (LHsBinds RdrName,    -- The method bindings
1091                    DerivAuxBinds)       -- Auxiliary bindings
1092 gen_Data_binds fix_env tycon
1093   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1094                 -- Auxiliary definitions: the data type and constructors
1095      DerivAuxBind datatype_bind : map mk_con_bind data_cons)
1096   where
1097     tycon_loc  = getSrcSpan tycon
1098     tycon_name = tyConName tycon
1099     data_cons  = tyConDataCons tycon
1100     n_cons     = length data_cons
1101     one_constr = n_cons == 1
1102
1103         ------------ gfoldl
1104     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1105     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1106                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1107                    where
1108                      con_name ::  RdrName
1109                      con_name = getRdrName con
1110                      as_needed = take (dataConSourceArity con) as_RDRs
1111                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1112
1113         ------------ gunfold
1114     gunfold_bind = mk_FunBind tycon_loc
1115                               gunfold_RDR
1116                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1117                                 gunfold_rhs)]
1118
1119     gunfold_rhs
1120         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1121         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1122                                 (map gunfold_alt data_cons)
1123
1124     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1125     mk_unfold_rhs dc = foldr nlHsApp
1126                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1127                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1128
1129     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1130                         -- redundant test, and annoying warning
1131       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1132       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1133       where
1134         tag = dataConTag dc
1135
1136         ------------ toConstr
1137     toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1138     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1139
1140         ------------ dataTypeOf
1141     dataTypeOf_bind = mk_easy_FunBind
1142                         tycon_loc
1143                         dataTypeOf_RDR
1144                         [nlWildPat]
1145                         (nlHsVar data_type_name)
1146
1147         ------------  $dT
1148
1149     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1150     datatype_bind  = mkVarBind
1151                        tycon_loc
1152                        data_type_name
1153                        (           nlHsVar mkDataType_RDR
1154                          `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1155                          `nlHsApp` nlList constrs
1156                        )
1157     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1158
1159
1160         ------------  $cT1 etc
1161     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1162     mk_con_bind dc = DerivAuxBind $
1163                      mkVarBind
1164                        tycon_loc
1165                        (mk_constr_name dc)
1166                        (nlHsApps mkConstr_RDR (constr_args dc))
1167     constr_args dc =
1168          [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
1169            nlHsVar data_type_name,                              -- DataType
1170            nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1171            nlList  labels,                                      -- Field labels
1172            nlHsVar fixity]                                      -- Fixity
1173         where
1174           labels   = map (nlHsLit . mkHsString . getOccString)
1175                          (dataConFieldLabels dc)
1176           dc_occ   = getOccName dc
1177           is_infix = isDataSymOcc dc_occ
1178           fixity | is_infix  = infix_RDR
1179                  | otherwise = prefix_RDR
1180
1181 gfoldl_RDR     = varQual_RDR gENERICS FSLIT("gfoldl")
1182 gunfold_RDR    = varQual_RDR gENERICS FSLIT("gunfold")
1183 toConstr_RDR   = varQual_RDR gENERICS FSLIT("toConstr")
1184 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1185 mkConstr_RDR   = varQual_RDR gENERICS FSLIT("mkConstr")
1186 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1187 conIndex_RDR   = varQual_RDR gENERICS FSLIT("constrIndex")
1188 prefix_RDR     = dataQual_RDR gENERICS FSLIT("Prefix")
1189 infix_RDR      = dataQual_RDR gENERICS FSLIT("Infix")
1190 \end{code}
1191
1192 %************************************************************************
1193 %*                                                                      *
1194 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1195 %*                                                                      *
1196 %************************************************************************
1197
1198 \begin{verbatim}
1199 data Foo ... = ...
1200
1201 con2tag_Foo :: Foo ... -> Int#
1202 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1203 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1204 \end{verbatim}
1205
1206 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1207 fiddling around.
1208
1209 \begin{code}
1210 genAuxBind :: DerivAuxBind -> LHsBind RdrName
1211
1212 genAuxBind (DerivAuxBind bind)
1213   = bind
1214
1215 genAuxBind (GenCon2Tag tycon)
1216   | lots_of_constructors
1217   = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1218
1219   | otherwise
1220   = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1221
1222   where
1223     rdr_name = con2tag_RDR tycon
1224     tycon_loc = getSrcSpan tycon
1225
1226     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1227         -- We can't use gerRdrName because that makes an Exact  RdrName
1228         -- and we can't put them in the LocalRdrEnv
1229
1230         -- Give a signature to the bound variable, so
1231         -- that the case expression generated by getTag is
1232         -- monomorphic.  In the push-enter model we get better code.
1233     get_tag_rhs = noLoc $ ExprWithTySig
1234                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1235                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1236                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1237
1238     con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1239                 `nlHsFunTy`
1240                 nlHsTyVar (getRdrName intPrimTyCon)
1241
1242     lots_of_constructors = tyConFamilySize tycon > 8
1243                                 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1244                                 -- but we don't do vectored returns any more.
1245
1246     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1247     mk_stuff con = ([nlWildConPat con],
1248                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1249
1250 genAuxBind (GenTag2Con tycon)
1251   = mk_FunBind (getSrcSpan tycon) rdr_name
1252         [([nlConVarPat intDataCon_RDR [a_RDR]],
1253            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1254                          (nlHsTyVar (getRdrName tycon))))]
1255   where
1256     rdr_name = tag2con_RDR tycon
1257
1258 genAuxBind (GenMaxTag tycon)
1259   = mkVarBind (getSrcSpan tycon) rdr_name
1260                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1261   where
1262     rdr_name = maxtag_RDR tycon
1263     max_tag =  case (tyConDataCons tycon) of
1264                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1265 \end{code}
1266
1267 %************************************************************************
1268 %*                                                                      *
1269 \subsection{Utility bits for generating bindings}
1270 %*                                                                      *
1271 %************************************************************************
1272
1273
1274 ToDo: Better SrcLocs.
1275
1276 \begin{code}
1277 compare_gen_Case ::
1278           LHsExpr RdrName       -- What to do for equality
1279           -> LHsExpr RdrName -> LHsExpr RdrName
1280           -> LHsExpr RdrName
1281 careful_compare_Case :: -- checks for primitive types...
1282           TyCon                 -- The tycon we are deriving for
1283           -> Type
1284           -> LHsExpr RdrName    -- What to do for equality
1285           -> LHsExpr RdrName -> LHsExpr RdrName
1286           -> LHsExpr RdrName
1287
1288 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1289         -- Was: compare_gen_Case cmp_eq_RDR
1290
1291 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1292   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1293 compare_gen_Case eq a b                         -- General case
1294   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1295       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1296        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1297        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1298
1299 careful_compare_Case tycon ty eq a b
1300   | not (isUnLiftedType ty)
1301   = compare_gen_Case eq a b
1302   | otherwise      -- We have to do something special for primitive things...
1303   = nlHsIf (genOpApp a relevant_eq_op b)
1304          eq
1305          (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1306   where
1307     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1308     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1309
1310
1311 box_if_necy :: String           -- The class involved
1312             -> TyCon            -- The tycon involved
1313             -> LHsExpr RdrName  -- The argument
1314             -> Type             -- The argument type
1315             -> LHsExpr RdrName  -- Boxed version of the arg
1316 box_if_necy cls_str tycon arg arg_ty
1317   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1318   | otherwise             = arg
1319   where
1320     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1321
1322 assoc_ty_id :: String           -- The class involved
1323             -> TyCon            -- The tycon involved
1324             -> [(Type,a)]       -- The table
1325             -> Type             -- The type
1326             -> a                -- The result of the lookup
1327 assoc_ty_id cls_str tycon tbl ty
1328   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1329                                               text "for primitive type" <+> ppr ty)
1330   | otherwise = head res
1331   where
1332     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1333
1334 eq_op_tbl :: [(Type, PrimOp)]
1335 eq_op_tbl =
1336     [(charPrimTy,       CharEqOp)
1337     ,(intPrimTy,        IntEqOp)
1338     ,(wordPrimTy,       WordEqOp)
1339     ,(addrPrimTy,       AddrEqOp)
1340     ,(floatPrimTy,      FloatEqOp)
1341     ,(doublePrimTy,     DoubleEqOp)
1342     ]
1343
1344 lt_op_tbl :: [(Type, PrimOp)]
1345 lt_op_tbl =
1346     [(charPrimTy,       CharLtOp)
1347     ,(intPrimTy,        IntLtOp)
1348     ,(wordPrimTy,       WordLtOp)
1349     ,(addrPrimTy,       AddrLtOp)
1350     ,(floatPrimTy,      FloatLtOp)
1351     ,(doublePrimTy,     DoubleLtOp)
1352     ]
1353
1354 box_con_tbl =
1355     [(charPrimTy,       getRdrName charDataCon)
1356     ,(intPrimTy,        getRdrName intDataCon)
1357     ,(wordPrimTy,       wordDataCon_RDR)
1358     ,(floatPrimTy,      getRdrName floatDataCon)
1359     ,(doublePrimTy,     getRdrName doubleDataCon)
1360     ]
1361
1362 -----------------------------------------------------------------------
1363
1364 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1365 and_Expr a b = genOpApp a and_RDR    b
1366
1367 -----------------------------------------------------------------------
1368
1369 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1370 eq_Expr tycon ty a b = genOpApp a eq_op b
1371  where
1372    eq_op
1373     | not (isUnLiftedType ty) = eq_RDR
1374     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1375          -- we have to do something special for primitive things...
1376 \end{code}
1377
1378 \begin{code}
1379 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1380 untag_Expr tycon [] expr = expr
1381 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1382   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1383       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1384
1385 cmp_tags_Expr ::  RdrName               -- Comparison op
1386              ->  RdrName ->  RdrName    -- Things to compare
1387              -> LHsExpr RdrName                 -- What to return if true
1388              -> LHsExpr RdrName         -- What to return if false
1389              -> LHsExpr RdrName
1390
1391 cmp_tags_Expr op a b true_case false_case
1392   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1393
1394 enum_from_to_Expr
1395         :: LHsExpr RdrName -> LHsExpr RdrName
1396         -> LHsExpr RdrName
1397 enum_from_then_to_Expr
1398         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1399         -> LHsExpr RdrName
1400
1401 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1402 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1403
1404 showParen_Expr
1405         :: LHsExpr RdrName -> LHsExpr RdrName
1406         -> LHsExpr RdrName
1407
1408 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1409
1410 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1411
1412 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1413 nested_compose_Expr [e] = parenify e
1414 nested_compose_Expr (e:es)
1415   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1416
1417 -- impossible_Expr is used in case RHSs that should never happen.
1418 -- We generate these to keep the desugarer from complaining that they *might* happen!
1419 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1420
1421 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1422 -- method. It is currently only used by Enum.{succ,pred}
1423 illegal_Expr meth tp msg =
1424    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1425
1426 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1427 -- to include the value of a_RDR in the error string.
1428 illegal_toEnum_tag tp maxtag =
1429    nlHsApp (nlHsVar error_RDR)
1430            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1431                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1432                     (nlHsApp (nlHsApp (nlHsApp
1433                            (nlHsVar showsPrec_RDR)
1434                            (nlHsIntLit 0))
1435                            (nlHsVar a_RDR))
1436                            (nlHsApp (nlHsApp
1437                                (nlHsVar append_RDR)
1438                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1439                                (nlHsApp (nlHsApp (nlHsApp
1440                                         (nlHsVar showsPrec_RDR)
1441                                         (nlHsIntLit 0))
1442                                         (nlHsVar maxtag))
1443                                         (nlHsLit (mkHsString ")"))))))
1444
1445 parenify e@(L _ (HsVar _)) = e
1446 parenify e                 = mkHsPar e
1447
1448 -- genOpApp wraps brackets round the operator application, so that the
1449 -- renamer won't subsequently try to re-associate it.
1450 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1451 \end{code}
1452
1453 \begin{code}
1454 a_RDR           = mkVarUnqual FSLIT("a")
1455 b_RDR           = mkVarUnqual FSLIT("b")
1456 c_RDR           = mkVarUnqual FSLIT("c")
1457 d_RDR           = mkVarUnqual FSLIT("d")
1458 k_RDR           = mkVarUnqual FSLIT("k")
1459 z_RDR           = mkVarUnqual FSLIT("z")
1460 ah_RDR          = mkVarUnqual FSLIT("a#")
1461 bh_RDR          = mkVarUnqual FSLIT("b#")
1462 ch_RDR          = mkVarUnqual FSLIT("c#")
1463 dh_RDR          = mkVarUnqual FSLIT("d#")
1464 cmp_eq_RDR      = mkVarUnqual FSLIT("cmp_eq")
1465
1466 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1467 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1468 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1469
1470 a_Expr          = nlHsVar a_RDR
1471 b_Expr          = nlHsVar b_RDR
1472 c_Expr          = nlHsVar c_RDR
1473 ltTag_Expr      = nlHsVar ltTag_RDR
1474 eqTag_Expr      = nlHsVar eqTag_RDR
1475 gtTag_Expr      = nlHsVar gtTag_RDR
1476 false_Expr      = nlHsVar false_RDR
1477 true_Expr       = nlHsVar true_RDR
1478
1479 a_Pat           = nlVarPat a_RDR
1480 b_Pat           = nlVarPat b_RDR
1481 c_Pat           = nlVarPat c_RDR
1482 d_Pat           = nlVarPat d_RDR
1483 k_Pat           = nlVarPat k_RDR
1484 z_Pat           = nlVarPat z_RDR
1485
1486 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon ->  RdrName
1487 -- Generates Orig s RdrName, for the binding positions
1488 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1489 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1490 maxtag_RDR  tycon = mk_tc_deriv_name tycon "maxtag_"
1491
1492 mk_tc_deriv_name tycon str
1493   = mkDerivedRdrName tc_name mk_occ
1494   where
1495     tc_name = tyConName tycon
1496     mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1497                   where
1498                     new_str = str ++ occNameString tc_occ ++ "#"
1499 \end{code}
1500
1501 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1502 PrelNames, so PrelNames can't import PrimOp.
1503
1504 \begin{code}
1505 primOpRdrName op = getRdrName (primOpId op)
1506
1507 minusInt_RDR  = primOpRdrName IntSubOp
1508 eqInt_RDR     = primOpRdrName IntEqOp
1509 ltInt_RDR     = primOpRdrName IntLtOp
1510 geInt_RDR     = primOpRdrName IntGeOp
1511 leInt_RDR     = primOpRdrName IntLeOp
1512 tagToEnum_RDR = primOpRdrName TagToEnumOp
1513
1514 error_RDR = getRdrName eRROR_ID
1515 \end{code}