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