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