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_Typeable_binds,
  21         gen_tag_n_con_monobind,
  22
  23         con2tag_RDR, tag2con_RDR, maxtag_RDR,
  24
  25         TagThingWanted(..)
  26     ) where
  27
  28 #include "HsVersions.h"
  29
  30 import HsSyn            ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..),
  31                           Match(..), GRHSs(..), Stmt(..), HsLit(..),
  32                           HsBinds(..), HsType(..), HsStmtContext(..),
  33                           unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
  34                         )
  35 import RdrName          ( RdrName, mkUnqual, nameRdrName, getRdrName )
  36 import RdrHsSyn         ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
  37 import BasicTypes       ( RecFlag(..), Fixity(..), FixityDirection(..)
  38                         , maxPrecedence
  39                         , Boxity(..)
  40                         )
  41 import FieldLabel       ( fieldLabelName )
  42 import DataCon          ( isNullaryDataCon, dataConTag,
  43                           dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
  44                           DataCon,
  45                           dataConFieldLabels )
  46 import Name             ( getOccString, getOccName, getSrcLoc, occNameString,
  47                           occNameUserString, varName,
  48                           Name, NamedThing(..),
  49                           isDataSymOcc, isSymOcc
  50                         )
  51
  52 import HscTypes         ( FixityEnv, lookupFixity )
  53 import PrelNames        -- Lots of Names
  54 import PrimOp           -- Lots of Names
  55 import SrcLoc           ( generatedSrcLoc, SrcLoc )
  56 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
  57                           maybeTyConSingleCon, tyConFamilySize, tyConTyVars
  58                         )
  59 import TcType           ( isUnLiftedType, tcEqType, Type )
  60 import TysPrim          ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
  61                           floatPrimTy, doublePrimTy
  62                         )
  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 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 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 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 = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
 516     max_bound_enum = mk_easy_FunMonoBind 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 = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
 527                      mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 528     max_bound_1con = mk_easy_FunMonoBind 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 -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
 657                          error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
 658                      else
 659                          dc
 660
 661     con_arity    = dataConSourceArity data_con
 662     data_con_RDR = getRdrName data_con
 663
 664     as_needed = take con_arity as_RDRs
 665     bs_needed = take con_arity bs_RDRs
 666     cs_needed = take con_arity cs_RDRs
 667
 668     con_pat  xs  = mkConPat data_con_RDR xs
 669     con_expr     = mkHsVarApps data_con_RDR cs_needed
 670
 671     --------------------------------------------------------------
 672     single_con_range
 673       = mk_easy_FunMonoBind tycon_loc range_RDR
 674           [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $
 675         mkHsDo ListComp stmts tycon_loc
 676       where
 677         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 678                 ++
 679                 [ResultStmt con_expr tycon_loc]
 680
 681         mk_qual a b c = BindStmt (VarPat c)
 682                                  (HsApp (HsVar range_RDR)
 683                                         (ExplicitTuple [HsVar a, HsVar b] Boxed))
 684                                  tycon_loc
 685
 686     ----------------
 687     single_con_index
 688       = mk_easy_FunMonoBind tycon_loc index_RDR
 689                 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 690                  con_pat cs_needed] [range_size] (
 691         foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
 692       where
 693         mk_index multiply_by (l, u, i)
 694           = genOpApp (
 695                (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
 696                                     HsVar i])
 697            ) plus_RDR (
 698                 genOpApp (
 699                     (HsApp (HsVar rangeSize_RDR)
 700                            (ExplicitTuple [HsVar l, HsVar u] Boxed))
 701                 ) times_RDR multiply_by
 702            )
 703
 704         range_size
 705           = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
 706                         [TuplePat [a_Pat, b_Pat] Boxed] [] (
 707                 genOpApp (
 708                     (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
 709                                          b_Expr])
 710                 ) plus_RDR (mkHsIntLit 1))
 711
 712     ------------------
 713     single_con_inRange
 714       = mk_easy_FunMonoBind tycon_loc inRange_RDR
 715                 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 716                  con_pat cs_needed]
 717                            [] (
 718           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
 719       where
 720         in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
 721                                                HsVar c]
 722 \end{code}
 723
 724 %************************************************************************
 725 %*                                                                      *
 726 \subsubsection{Generating @Read@ instance declarations}
 727 %*                                                                      *
 728 %************************************************************************
 729
 730 Example
 731
 732   infix 4 %%
 733   data T = Int %% Int
 734          | T1 { f1 :: Int }
 735          | T2 Int
 736
 737
 738 instance Read T where
 739   readPrec =
 740     parens
 741     ( prec 4 (
 742         do x           <- ReadP.step Read.readPrec
 743            Symbol "%%" <- Lex.lex
 744            y           <- ReadP.step Read.readPrec
 745            return (x %% y))
 746       +++
 747       prec appPrec (
 748         do Ident "T1" <- Lex.lex
 749            Punc '{' <- Lex.lex
 750            Ident "f1" <- Lex.lex
 751            Punc '=' <- Lex.lex
 752            x          <- ReadP.reset Read.readPrec
 753            Punc '}' <- Lex.lex
 754            return (T1 { f1 = x }))
 755       +++
 756       prec appPrec (
 757         do Ident "T2" <- Lex.lexP
 758            x          <- ReadP.step Read.readPrec
 759            return (T2 x))
 760     )
 761
 762   readListPrec = readListPrecDefault
 763   readList     = readListDefault
 764
 765
 766 \begin{code}
 767 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
 768
 769 gen_Read_binds get_fixity tycon
 770   = read_prec `AndMonoBinds` default_binds
 771   where
 772     -----------------------------------------------------------------------
 773     default_binds
 774         = mk_easy_FunMonoBind loc readList_RDR     [] [] (HsVar readListDefault_RDR)
 775                 `AndMonoBinds`
 776           mk_easy_FunMonoBind loc readListPrec_RDR [] [] (HsVar readListPrecDefault_RDR)
 777     -----------------------------------------------------------------------
 778
 779     loc       = getSrcLoc tycon
 780     data_cons = tyConDataCons tycon
 781     (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
 782
 783     read_prec = mk_easy_FunMonoBind loc readPrec_RDR [] []
 784                                     (HsApp (HsVar parens_RDR) read_cons)
 785
 786     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 787     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 788
 789     read_nullary_cons
 790       = case nullary_cons of
 791             []    -> []
 792             [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
 793                                      result_stmt con []] loc]
 794             _     -> [HsApp (HsVar choose_RDR)
 795                             (ExplicitList placeHolderType (map mk_pair nullary_cons))]
 796
 797     mk_pair con = ExplicitTuple [HsLit (data_con_str con),
 798                                  HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))]
 799                                 Boxed
 800
 801     read_non_nullary_con data_con
 802       = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
 803       where
 804         stmts | is_infix          = infix_stmts
 805               | length labels > 0 = lbl_stmts
 806               | otherwise         = prefix_stmts
 807
 808         prefix_stmts            -- T a b c
 809           = [bindLex (ident_pat (data_con_str data_con))]
 810             ++ map read_arg as_needed
 811             ++ [result_stmt data_con as_needed]
 812
 813         infix_stmts             -- a %% b
 814           = [read_arg a1,
 815              bindLex (symbol_pat (data_con_str data_con)),
 816              read_arg a2,
 817              result_stmt data_con [a1,a2]]
 818
 819         lbl_stmts               -- T { f1 = a, f2 = b }
 820           = [bindLex (ident_pat (data_con_str data_con)),
 821              read_punc "{"]
 822             ++ concat (intersperse [read_punc ","] field_stmts)
 823             ++ [read_punc "}", result_stmt data_con as_needed]
 824
 825         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 826
 827         con_arity    = dataConSourceArity data_con
 828         nullary_con  = con_arity == 0
 829         labels       = dataConFieldLabels data_con
 830         lab_fields   = length labels
 831         dc_nm        = getName data_con
 832         is_infix     = isDataSymOcc (getOccName dc_nm)
 833         as_needed    = take con_arity as_RDRs
 834         (a1:a2:_)    = as_needed
 835         prec         = getPrec is_infix get_fixity dc_nm
 836
 837     ------------------------------------------------------------------------
 838     --          Helpers
 839     ------------------------------------------------------------------------
 840     mk_alt e1 e2     = genOpApp e1 alt_RDR e2
 841     bindLex pat      = BindStmt pat (HsVar lexP_RDR) loc
 842     result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
 843     con_app c as     = mkHsVarApps (getRdrName c) as
 844
 845     punc_pat s   = ConPatIn punc_RDR  (PrefixCon [LitPat (mkHsString s)])         -- Punc 'c'
 846     ident_pat s  = ConPatIn ident_RDR (PrefixCon [LitPat s])                      -- Ident "foo"
 847     symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s])                     -- Symbol ">>"
 848
 849     data_con_str con = mkHsString (occNameUserString (getOccName con))
 850
 851     read_punc c = bindLex (punc_pat c)
 852     read_arg a  = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
 853
 854     read_field lbl a = read_lbl lbl ++
 855                        [read_punc "=",
 856                         BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
 857
 858         -- When reading field labels we might encounter
 859         --      a  = 3
 860         --      _a = 3
 861         -- or   (#) = 4
 862         -- Note the parens!
 863     read_lbl lbl | is_id_start (head lbl_str)
 864                  = [bindLex (ident_pat lbl_lit)]
 865                  | otherwise
 866                  = [read_punc "(",
 867                     bindLex (symbol_pat lbl_lit),
 868                     read_punc ")"]
 869                  where
 870                    lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
 871                    lbl_lit = mkHsString lbl_str
 872                    is_id_start c = isAlpha c || c == '_'
 873 \end{code}
 874
 875
 876 %************************************************************************
 877 %*                                                                      *
 878 \subsubsection{Generating @Show@ instance declarations}
 879 %*                                                                      *
 880 %************************************************************************
 881
 882 Example
 883
 884     infixr 5 :^:
 885
 886     data Tree a =  Leaf a  |  Tree a :^: Tree a
 887
 888     instance (Show a) => Show (Tree a) where
 889
 890         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 891           where
 892              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 893
 894         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 895           where
 896              showStr = showsPrec (up_prec+1) u .
 897                        showString " :^: "      .
 898                        showsPrec (up_prec+1) v
 899                 -- Note: right-associativity of :^: ignored
 900
 901     up_prec  = 5    -- Precedence of :^:
 902     app_prec = 10   -- Application has precedence one more than
 903                     -- the most tightly-binding operator
 904
 905 \begin{code}
 906 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
 907
 908 gen_Show_binds get_fixity tycon
 909   = shows_prec `AndMonoBinds` show_list
 910   where
 911     tycon_loc = getSrcLoc tycon
 912     -----------------------------------------------------------------------
 913     show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
 914                   (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
 915     -----------------------------------------------------------------------
 916     shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 917       where
 918         pats_etc data_con
 919           | nullary_con =  -- skip the showParen junk...
 920              ASSERT(null bs_needed)
 921              ([wildPat, con_pat], mk_showString_app con_str)
 922           | otherwise   =
 923              ([a_Pat, con_pat],
 924                   showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
 925                                  (HsPar (nested_compose_Expr show_thingies)))
 926             where
 927              data_con_RDR  = getRdrName data_con
 928              con_arity     = dataConSourceArity data_con
 929              bs_needed     = take con_arity bs_RDRs
 930              con_pat       = mkConPat data_con_RDR bs_needed
 931              nullary_con   = con_arity == 0
 932              labels        = dataConFieldLabels data_con
 933              lab_fields    = length labels
 934              record_syntax = lab_fields > 0
 935
 936              dc_nm          = getName data_con
 937              dc_occ_nm      = getOccName data_con
 938              con_str        = occNameUserString dc_occ_nm
 939
 940              show_thingies
 941                 | is_infix      = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
 942                 | record_syntax = mk_showString_app (con_str ++ " {") :
 943                                   show_record_args ++ [mk_showString_app "}"]
 944                 | otherwise     = mk_showString_app (con_str ++ " ") : show_prefix_args
 945
 946              show_label l = mk_showString_app (the_name ++ " = ")
 947                         -- Note the spaces around the "=" sign.  If we don't have them
 948                         -- then we get Foo { x=-1 } and the "=-" parses as a single
 949                         -- lexeme.  Only the space after the '=' is necessary, but
 950                         -- it seems tidier to have them both sides.
 951                  where
 952                    occ_nm   = getOccName (fieldLabelName l)
 953                    nm       = occNameUserString occ_nm
 954
 955                    is_op    = isSymOcc occ_nm       -- Legal, but rare.
 956                    the_name
 957                      | is_op     = '(':nm ++ ")"
 958                      | otherwise = nm
 959
 960              show_args = [ mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec), HsVar b]
 961                          | b <- bs_needed ]
 962              (show_arg1:show_arg2:_) = show_args
 963              show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
 964
 965                 --  Assumption for record syntax: no of fields == no of labelled fields
 966                 --            (and in same order)
 967              show_record_args = concat $
 968                                 intersperse [mk_showString_app ", "] $
 969                                 [ [show_label lbl, arg]
 970                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
 971                                                         labels show_args ]
 972
 973                 -- Fixity stuff
 974              is_infix = isDataSymOcc dc_occ_nm
 975              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
 976              arg_prec | record_syntax = 0       -- Record fields don't need parens
 977                       | otherwise     = con_prec_plus_one
 978
 979 mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
 980 \end{code}
 981
 982 \begin{code}
 983 getPrec :: Bool -> FixityEnv -> Name -> Integer
 984 getPrec is_infix get_fixity nm
 985   | not is_infix   = appPrecedence
 986   | otherwise      = getPrecedence get_fixity nm
 987
 988 appPrecedence :: Integer
 989 appPrecedence = fromIntegral maxPrecedence + 1
 990   -- One more than the precedence of the most
 991   -- tightly-binding operator
 992
 993 getPrecedence :: FixityEnv -> Name -> Integer
 994 getPrecedence get_fixity nm
 995    = case lookupFixity get_fixity nm of
 996         Fixity x _ -> fromIntegral x
 997
 998 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
 999 isLRAssoc get_fixity nm =
1000      case lookupFixity get_fixity nm of
1001        Fixity _ InfixN -> (False, False)
1002        Fixity _ InfixR -> (False, True)
1003        Fixity _ InfixL -> (True,  False)
1004 \end{code}
1005
1006
1007 %************************************************************************
1008 %*                                                                      *
1009 \subsection{Typeable}
1010 %*                                                                      *
1011 %************************************************************************
1012
1013 From the data type
1014
1015         data T a b = ....
1016
1017 we generate
1018
1019         instance (Typeable a, Typeable b) => Typeable (T a b) where
1020                 typeOf _ = mkTypeRep (mkTyConRep "T")
1021                                      [typeOf (undefined::a),
1022                                       typeOf (undefined::b)]
1023
1024 Notice the use of lexically scoped type variables.
1025
1026 \begin{code}
1027 gen_Typeable_binds :: TyCon -> RdrNameMonoBinds
1028 gen_Typeable_binds tycon
1029   = mk_easy_FunMonoBind tycon_loc typeOf_RDR [WildPat placeHolderType] []
1030         (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
1031   where
1032     tycon_loc = getSrcLoc tycon
1033     tyvars    = tyConTyVars tycon
1034     tycon_rep = HsVar mkTyConRep_RDR `HsApp` HsLit (mkHsString (showSDoc (ppr tycon)))
1035     arg_reps  = ExplicitList placeHolderType (map mk tyvars)
1036     mk tyvar  = HsApp (HsVar typeOf_RDR)
1037                       (ExprWithTySig (HsVar undefined_RDR)
1038                                      (HsTyVar (getRdrName tyvar)))
1039 \end{code}
1040
1041
1042
1043 %************************************************************************
1044 %*                                                                      *
1045 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1046 %*                                                                      *
1047 %************************************************************************
1048
1049 \begin{verbatim}
1050 data Foo ... = ...
1051
1052 con2tag_Foo :: Foo ... -> Int#
1053 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1054 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1055 \end{verbatim}
1056
1057 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1058 fiddling around.
1059
1060 \begin{code}
1061 data TagThingWanted
1062   = GenCon2Tag | GenTag2Con | GenMaxTag
1063
1064 gen_tag_n_con_monobind
1065     :: (RdrName,            -- (proto)Name for the thing in question
1066         TyCon,              -- tycon in question
1067         TagThingWanted)
1068     -> RdrNameMonoBinds
1069
1070 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1071   | lots_of_constructors
1072   = mk_FunMonoBind loc rdr_name [([], get_tag_rhs)]
1073
1074   | otherwise
1075   = mk_FunMonoBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1076
1077   where
1078     loc = getSrcLoc tycon
1079
1080         -- Give a signature to the bound variable, so
1081         -- that the case expression generated by getTag is
1082         -- monomorphic.  In the push-enter model we get better code.
1083     get_tag_rhs = ExprWithTySig
1084                         (HsLam (mk_match loc [VarPat a_RDR]
1085                                              (HsApp getTag_Expr a_Expr)
1086                                              EmptyBinds))
1087                         (HsForAllTy Nothing [] con2tag_ty)
1088                                 -- Nothing => implicit quantification
1089
1090     con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon))
1091                      [HsTyVar (getRdrName tv) | tv <- tyConTyVars tycon]
1092                 `HsFunTy`
1093                 HsTyVar (getRdrName intPrimTyConName)
1094
1095     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1096
1097     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1098     mk_stuff var
1099       = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1100       where
1101         pat    = ConPatIn var_RDR (PrefixCon (nOfThem (dataConSourceArity var) wildPat))
1102         var_RDR = getRdrName var
1103
1104 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1105   = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1106         [([mkConPat mkInt_RDR [a_RDR]],
1107            ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1108                          (HsTyVar (getRdrName tycon)))]
1109
1110 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1111   = mk_easy_FunMonoBind (getSrcLoc tycon)
1112                 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1113   where
1114     max_tag =  case (tyConDataCons tycon) of
1115                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1116
1117 \end{code}
1118
1119 %************************************************************************
1120 %*                                                                      *
1121 \subsection{Utility bits for generating bindings}
1122 %*                                                                      *
1123 %************************************************************************
1124
1125 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1126 \begin{verbatim}
1127     fun pat1 pat2 ... patN = expr where binds
1128 \end{verbatim}
1129
1130 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1131 multi-clause definitions; it generates:
1132 \begin{verbatim}
1133     fun p1a p1b ... p1N = e1
1134     fun p2a p2b ... p2N = e2
1135     ...
1136     fun pMa pMb ... pMN = eM
1137 \end{verbatim}
1138
1139 \begin{code}
1140 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1141                     -> [RdrNameMonoBinds] -> RdrNameHsExpr
1142                     -> RdrNameMonoBinds
1143
1144 mk_easy_FunMonoBind loc fun pats binds expr
1145   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1146
1147 mk_easy_Match loc pats binds expr
1148   = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds))
1149         -- The renamer expects everything in its input to be a
1150         -- "recursive" MonoBinds, and it is its job to sort things out
1151         -- from there.
1152
1153 mk_FunMonoBind  :: SrcLoc -> RdrName
1154                 -> [([RdrNamePat], RdrNameHsExpr)]
1155                 -> RdrNameMonoBinds
1156
1157 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1158 mk_FunMonoBind loc fun pats_and_exprs
1159   = FunMonoBind fun False{-not infix-}
1160                 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1161                 loc
1162
1163 mk_match loc pats expr binds
1164   = Match (map paren pats) Nothing
1165           (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1166   where
1167     paren p@(VarPat _) = p
1168     paren other_p      = ParPat other_p
1169 \end{code}
1170
1171 \begin{code}
1172 mkHsApps    f xs = foldl HsApp (HsVar f) xs
1173 mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
1174
1175 mkHsIntLit n = HsLit (HsInt n)
1176 mkHsString s = HsString (mkFastString s)
1177 mkHsChar c   = HsChar   (ord c)
1178
1179 mkConPat con vars   = ConPatIn con (PrefixCon (map VarPat vars))
1180 mkNullaryConPat con = ConPatIn con (PrefixCon [])
1181 \end{code}
1182
1183 ToDo: Better SrcLocs.
1184
1185 \begin{code}
1186 compare_gen_Case ::
1187           RdrNameHsExpr -- What to do for equality
1188           -> RdrNameHsExpr -> RdrNameHsExpr
1189           -> RdrNameHsExpr
1190 careful_compare_Case :: -- checks for primitive types...
1191           Type
1192           -> RdrNameHsExpr      -- What to do for equality
1193           -> RdrNameHsExpr -> RdrNameHsExpr
1194           -> RdrNameHsExpr
1195
1196 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1197         -- Was: compare_gen_Case cmp_eq_RDR
1198
1199 compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR
1200   = HsApp (HsApp (HsVar compare_RDR) a) b       -- Simple case
1201 compare_gen_Case eq a b                         -- General case
1202   = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-}
1203       [mkSimpleMatch [mkNullaryConPat ltTag_RDR] ltTag_Expr placeHolderType generatedSrcLoc,
1204        mkSimpleMatch [mkNullaryConPat eqTag_RDR] eq placeHolderType generatedSrcLoc,
1205        mkSimpleMatch [mkNullaryConPat gtTag_RDR] gtTag_Expr placeHolderType generatedSrcLoc]
1206       generatedSrcLoc
1207
1208 careful_compare_Case ty eq a b
1209   | not (isUnLiftedType ty) =
1210        compare_gen_Case eq a b
1211   | otherwise               =
1212          -- we have to do something special for primitive things...
1213        HsIf (genOpApp a relevant_eq_op b)
1214             eq
1215             (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc)
1216             generatedSrcLoc
1217   where
1218     relevant_eq_op = assoc_ty_id eq_op_tbl ty
1219     relevant_lt_op = assoc_ty_id lt_op_tbl ty
1220
1221 assoc_ty_id tyids ty
1222   = if null res then panic "assoc_ty"
1223     else head res
1224   where
1225     res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1226
1227 eq_op_tbl =
1228     [(charPrimTy,       eqChar_RDR)
1229     ,(intPrimTy,        eqInt_RDR)
1230     ,(wordPrimTy,       eqWord_RDR)
1231     ,(addrPrimTy,       eqAddr_RDR)
1232     ,(floatPrimTy,      eqFloat_RDR)
1233     ,(doublePrimTy,     eqDouble_RDR)
1234     ]
1235
1236 lt_op_tbl =
1237     [(charPrimTy,       ltChar_RDR)
1238     ,(intPrimTy,        ltInt_RDR)
1239     ,(wordPrimTy,       ltWord_RDR)
1240     ,(addrPrimTy,       ltAddr_RDR)
1241     ,(floatPrimTy,      ltFloat_RDR)
1242     ,(doublePrimTy,     ltDouble_RDR)
1243     ]
1244
1245 -----------------------------------------------------------------------
1246
1247 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1248
1249 and_Expr    a b = genOpApp a and_RDR    b
1250 append_Expr a b = genOpApp a append_RDR b
1251
1252 -----------------------------------------------------------------------
1253
1254 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1255 eq_Expr ty a b = genOpApp a eq_op b
1256  where
1257    eq_op
1258     | not (isUnLiftedType ty) = eq_RDR
1259     | otherwise               =
1260          -- we have to do something special for primitive things...
1261         assoc_ty_id eq_op_tbl ty
1262
1263 \end{code}
1264
1265 \begin{code}
1266 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1267 untag_Expr tycon [] expr = expr
1268 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1269   = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1270       [mkSimpleMatch [VarPat put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1271       generatedSrcLoc
1272
1273 cmp_tags_Expr :: RdrName                -- Comparison op
1274              -> RdrName -> RdrName      -- Things to compare
1275              -> RdrNameHsExpr           -- What to return if true
1276              -> RdrNameHsExpr           -- What to return if false
1277              -> RdrNameHsExpr
1278
1279 cmp_tags_Expr op a b true_case false_case
1280   = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1281
1282 enum_from_to_Expr
1283         :: RdrNameHsExpr -> RdrNameHsExpr
1284         -> RdrNameHsExpr
1285 enum_from_then_to_Expr
1286         :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1287         -> RdrNameHsExpr
1288
1289 enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1290 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1291
1292 showParen_Expr
1293         :: RdrNameHsExpr -> RdrNameHsExpr
1294         -> RdrNameHsExpr
1295
1296 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1297
1298 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1299
1300 nested_compose_Expr [e] = parenify e
1301 nested_compose_Expr (e:es)
1302   = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1303
1304 -- impossible_Expr is used in case RHSs that should never happen.
1305 -- We generate these to keep the desugarer from complaining that they *might* happen!
1306 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
1307
1308 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1309 -- method. It is currently only used by Enum.{succ,pred}
1310 illegal_Expr meth tp msg =
1311    HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
1312
1313 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1314 -- to include the value of a_RDR in the error string.
1315 illegal_toEnum_tag tp maxtag =
1316    HsApp (HsVar error_RDR)
1317          (HsApp (HsApp (HsVar append_RDR)
1318                        (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
1319                        (HsApp (HsApp (HsApp
1320                            (HsVar showsPrec_RDR)
1321                            (mkHsIntLit 0))
1322                            (HsVar a_RDR))
1323                            (HsApp (HsApp
1324                                (HsVar append_RDR)
1325                                (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
1326                                (HsApp (HsApp (HsApp
1327                                         (HsVar showsPrec_RDR)
1328                                         (mkHsIntLit 0))
1329                                         (HsVar maxtag))
1330                                         (HsLit (HsString (mkFastString ")")))))))
1331
1332 parenify e@(HsVar _) = e
1333 parenify e           = HsPar e
1334
1335 -- genOpApp wraps brackets round the operator application, so that the
1336 -- renamer won't subsequently try to re-associate it.
1337 -- For some reason the renamer doesn't reassociate it right, and I can't
1338 -- be bothered to find out why just now.
1339
1340 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1341 \end{code}
1342
1343 \begin{code}
1344 varUnqual n     = mkUnqual OccName.varName n
1345
1346 zz_a_RDR        = varUnqual FSLIT("_a")
1347 a_RDR           = varUnqual FSLIT("a")
1348 b_RDR           = varUnqual FSLIT("b")
1349 c_RDR           = varUnqual FSLIT("c")
1350 d_RDR           = varUnqual FSLIT("d")
1351 ah_RDR          = varUnqual FSLIT("a#")
1352 bh_RDR          = varUnqual FSLIT("b#")
1353 ch_RDR          = varUnqual FSLIT("c#")
1354 dh_RDR          = varUnqual FSLIT("d#")
1355 cmp_eq_RDR      = varUnqual FSLIT("cmp_eq")
1356 rangeSize_RDR   = varUnqual FSLIT("rangeSize")
1357
1358 as_RDRs         = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1359 bs_RDRs         = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1360 cs_RDRs         = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1361
1362 zz_a_Expr       = HsVar zz_a_RDR
1363 a_Expr          = HsVar a_RDR
1364 b_Expr          = HsVar b_RDR
1365 c_Expr          = HsVar c_RDR
1366 d_Expr          = HsVar d_RDR
1367 ltTag_Expr      = HsVar ltTag_RDR
1368 eqTag_Expr      = HsVar eqTag_RDR
1369 gtTag_Expr      = HsVar gtTag_RDR
1370 false_Expr      = HsVar false_RDR
1371 true_Expr       = HsVar true_RDR
1372
1373 getTag_Expr     = HsVar getTag_RDR
1374 tagToEnum_Expr  = HsVar tagToEnum_RDR
1375 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1376
1377 wildPat         = WildPat placeHolderType
1378 zz_a_Pat        = VarPat zz_a_RDR
1379 a_Pat           = VarPat a_RDR
1380 b_Pat           = VarPat b_RDR
1381 c_Pat           = VarPat c_RDR
1382 d_Pat           = VarPat d_RDR
1383
1384 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1385
1386 con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1387 tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1388 maxtag_RDR tycon  = varUnqual (mkFastString ("maxtag_"  ++ occNameString (getOccName tycon) ++ "#"))
1389 \end{code}
1390
1391 RdrNames for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1392 PrelNames, so PrelNames can't import PrimOp.
1393
1394 \begin{code}
1395 minusInt_RDR  = nameRdrName minusIntName
1396 eqInt_RDR     = nameRdrName eqIntName
1397 ltInt_RDR     = nameRdrName ltIntName
1398 geInt_RDR     = nameRdrName geIntName
1399 leInt_RDR     = nameRdrName leIntName
1400 eqChar_RDR    = nameRdrName eqCharName
1401 eqWord_RDR    = nameRdrName eqWordName
1402 eqAddr_RDR    = nameRdrName eqAddrName
1403 eqFloat_RDR   = nameRdrName eqFloatName
1404 eqDouble_RDR  = nameRdrName eqDoubleName
1405 ltChar_RDR    = nameRdrName ltCharName
1406 ltWord_RDR    = nameRdrName ltWordName
1407 ltAddr_RDR    = nameRdrName ltAddrName
1408 ltFloat_RDR   = nameRdrName ltFloatName
1409 ltDouble_RDR  = nameRdrName ltDoubleName
1410 tagToEnum_RDR = nameRdrName tagToEnumName
1411 \end{code}