ghc/compiler/typecheck/TcGenDeriv.lhs

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