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