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