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