compiler/typecheck/TcGenDeriv.lhs

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