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_tag_n_con_monobind,
  21
  22         con2tag_RDR, tag2con_RDR, maxtag_RDR,
  23
  24         TagThingWanted(..)
  25     ) where
  26
  27 #include "HsVersions.h"
  28
  29 import HsSyn            ( InPat(..), HsExpr(..), MonoBinds(..),
  30                           Match(..), GRHSsAndBinds(..), Stmt(..), HsLit(..),
  31                           HsBinds(..), StmtCtxt(..),
  32                           unguardedRHS
  33                         )
  34 import RdrHsSyn         ( RdrName(..), varUnqual, mkOpApp,
  35                           RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat
  36                         )
  37 import BasicTypes       ( IfaceFlavour(..), RecFlag(..) )
  38 import FieldLabel       ( fieldLabelName )
  39 import DataCon          ( isNullaryDataCon, dataConTag,
  40                           dataConRawArgTys, fIRST_TAG,
  41                           DataCon, ConTag,
  42                           dataConFieldLabels )
  43 import Name             ( getOccString, getOccName, getSrcLoc, occNameString,
  44                           modAndOcc, OccName, Name )
  45
  46 import PrimOp           ( PrimOp(..) )
  47 import PrelInfo         -- Lots of RdrNames
  48 import SrcLoc           ( mkGeneratedSrcLoc, SrcLoc )
  49 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
  50                           maybeTyConSingleCon
  51                         )
  52 import Type             ( isUnLiftedType, isUnboxedType, Type )
  53 import TysPrim          ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
  54                           floatPrimTy, doublePrimTy
  55                         )
  56 import Util             ( mapAccumL, zipEqual, zipWithEqual,
  57                           zipWith3Equal, nOfThem, panic, assertPanic )
  58 import Maybes           ( maybeToBool )
  59 import List             ( partition, intersperse )
  60 \end{code}
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsection{Generating code, by derivable class}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsubsection{Generating @Eq@ instance declarations}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 Here are the heuristics for the code we generate for @Eq@:
  75 \begin{itemize}
  76 \item
  77   Let's assume we have a data type with some (possibly zero) nullary
  78   data constructors and some ordinary, non-nullary ones (the rest,
  79   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  80   and \tr{O}rdinary data cons.
  81 \begin{verbatim}
  82 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
  83 \end{verbatim}
  84
  85 \item
  86   For the ordinary constructors (if any), we emit clauses to do The
  87   Usual Thing, e.g.,:
  88
  89 \begin{verbatim}
  90 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
  91 (==) (O2 a1)       (O2 a2)       = a1 == a2
  92 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
  93 \end{verbatim}
  94
  95   Note: if we're comparing unboxed things, e.g., if \tr{a1} and
  96   \tr{a2} are \tr{Float#}s, then we have to generate
  97 \begin{verbatim}
  98 case (a1 `eqFloat#` a2) of
  99   r -> r
 100 \end{verbatim}
 101   for that particular test.
 102
 103 \item
 104   If there are any nullary constructors, we emit a catch-all clause of
 105   the form:
 106
 107 \begin{verbatim}
 108 (==) a b  = case (con2tag_Foo a) of { a# ->
 109             case (con2tag_Foo b) of { b# ->
 110             case (a# ==# b#)     of {
 111               r -> r
 112             }}}
 113 \end{verbatim}
 114
 115   If there aren't any nullary constructors, we emit a simpler
 116   catch-all:
 117 \begin{verbatim}
 118 (==) a b  = False
 119 \end{verbatim}
 120
 121 \item
 122   For the @(/=)@ method, we normally just use the default method.
 123
 124   If the type is an enumeration type, we could/may/should? generate
 125   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 126   above.
 127
 128 \item
 129   We thought about doing this: If we're also deriving @Ord@ for this
 130   tycon, we generate:
 131 \begin{verbatim}
 132 instance ... Eq (Foo ...) where
 133   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 134   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 135 \begin{verbatim}
 136   However, that requires that \tr{Ord <whatever>} was put in the context
 137   for the instance decl, which it probably wasn't, so the decls
 138   produced don't get through the typechecker.
 139 \end{itemize}
 140
 141
 142 deriveEq :: RdrName                             -- Class
 143          -> RdrName                             -- Type constructor
 144          -> [ (RdrName, [RdrType]) ]    -- Constructors
 145          -> (RdrContext,                -- Context for the inst decl
 146              [RdrBind],                 -- Binds in the inst decl
 147              [RdrBind])                 -- Extra value bindings outside
 148
 149 deriveEq clas tycon constrs
 150   = (context, [eq_bind, ne_bind], [])
 151   where
 152     context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
 153
 154     ne_bind = mkBind
 155     (nullary_cons, non_nullary_cons) = partition is_nullary constrs
 156     is_nullary (_, args) = null args
 157
 158 \begin{code}
 159 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
 160
 161 gen_Eq_binds tycon
 162   = let
 163         tycon_loc = getSrcLoc tycon
 164         (nullary_cons, nonnullary_cons)
 165            | isNewTyCon tycon = ([], tyConDataCons tycon)
 166            | otherwise        = partition isNullaryDataCon (tyConDataCons tycon)
 167
 168         rest
 169           = if (null nullary_cons) then
 170                 case maybeTyConSingleCon tycon of
 171                   Just _ -> []
 172                   Nothing -> -- if cons don't match, then False
 173                      [([a_Pat, b_Pat], false_Expr)]
 174             else -- calc. and compare the tags
 175                  [([a_Pat, b_Pat],
 176                     untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 177                       (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
 178     in
 179     mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
 180             `AndMonoBinds`
 181     mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
 182         HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
 183   where
 184     ------------------------------------------------------------------
 185     pats_etc data_con
 186       = let
 187             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
 188             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 189
 190             data_con_RDR = qual_orig_name data_con
 191             con_arity   = length tys_needed
 192             as_needed   = take con_arity as_RDRs
 193             bs_needed   = take con_arity bs_RDRs
 194             tys_needed  = dataConRawArgTys data_con
 195         in
 196         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 197       where
 198         nested_eq_expr []  [] [] = true_Expr
 199         nested_eq_expr tys as bs
 200           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 201           where
 202             nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
 203 \end{code}
 204
 205 %************************************************************************
 206 %*                                                                      *
 207 \subsubsection{Generating @Ord@ instance declarations}
 208 %*                                                                      *
 209 %************************************************************************
 210
 211 For a derived @Ord@, we concentrate our attentions on @compare@
 212 \begin{verbatim}
 213 compare :: a -> a -> Ordering
 214 data Ordering = LT | EQ | GT deriving ()
 215 \end{verbatim}
 216
 217 We will use the same example data type as above:
 218 \begin{verbatim}
 219 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 220 \end{verbatim}
 221
 222 \begin{itemize}
 223 \item
 224   We do all the other @Ord@ methods with calls to @compare@:
 225 \begin{verbatim}
 226 instance ... (Ord <wurble> <wurble>) where
 227     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 228     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 229     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 230     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 231
 232     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 233     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 234
 235     -- compare to come...
 236 \end{verbatim}
 237
 238 \item
 239   @compare@ always has two parts.  First, we use the compared
 240   data-constructors' tags to deal with the case of different
 241   constructors:
 242 \begin{verbatim}
 243 compare a b = case (con2tag_Foo a) of { a# ->
 244               case (con2tag_Foo b) of { b# ->
 245               case (a# ==# b#)     of {
 246                True  -> cmp_eq a b
 247                False -> case (a# <# b#) of
 248                          True  -> _LT
 249                          False -> _GT
 250               }}}
 251   where
 252     cmp_eq = ... to come ...
 253 \end{verbatim}
 254
 255 \item
 256   We are only left with the ``help'' function @cmp_eq@, to deal with
 257   comparing data constructors with the same tag.
 258
 259   For the ordinary constructors (if any), we emit the sorta-obvious
 260   compare-style stuff; for our example:
 261 \begin{verbatim}
 262 cmp_eq (O1 a1 b1) (O1 a2 b2)
 263   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 264
 265 cmp_eq (O2 a1) (O2 a2)
 266   = compare a1 a2
 267
 268 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 269   = case (compare a1 a2) of {
 270       LT -> LT;
 271       GT -> GT;
 272       EQ -> case compare b1 b2 of {
 273               LT -> LT;
 274               GT -> GT;
 275               EQ -> compare c1 c2
 276             }
 277     }
 278 \end{verbatim}
 279
 280   Again, we must be careful about unboxed comparisons.  For example,
 281   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 282   generate:
 283
 284 \begin{verbatim}
 285 cmp_eq lt eq gt (O2 a1) (O2 a2)
 286   = compareInt# a1 a2
 287   -- or maybe the unfolded equivalent
 288 \end{verbatim}
 289
 290 \item
 291   For the remaining nullary constructors, we already know that the
 292   tags are equal so:
 293 \begin{verbatim}
 294 cmp_eq _ _ = EQ
 295 \end{verbatim}
 296 \end{itemize}
 297
 298 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
 299 JJQC-30-Nov-1997
 300
 301 \begin{code}
 302 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
 303
 304 gen_Ord_binds tycon
 305   = defaulted `AndMonoBinds` compare
 306   where
 307     tycon_loc = getSrcLoc tycon
 308     --------------------------------------------------------------------
 309     compare = mk_easy_FunMonoBind tycon_loc compare_RDR
 310                 [a_Pat, b_Pat]
 311                 [cmp_eq]
 312             (if maybeToBool (maybeTyConSingleCon tycon) then
 313                 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 314              else
 315                 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 316                   (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
 317                         -- True case; they are equal
 318                         -- If an enumeration type we are done; else
 319                         -- recursively compare their components
 320                     (if isEnumerationTyCon tycon then
 321                         eqTag_Expr
 322                      else
 323                         cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 324                     )
 325                         -- False case; they aren't equal
 326                         -- So we need to do a less-than comparison on the tags
 327                     (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
 328
 329     tycon_data_cons = tyConDataCons tycon
 330     (nullary_cons, nonnullary_cons)
 331        | isNewTyCon tycon = ([], tyConDataCons tycon)
 332        | otherwise        = partition isNullaryDataCon tycon_data_cons
 333
 334     cmp_eq =
 335        mk_FunMonoBind tycon_loc
 336                       cmp_eq_RDR
 337                       (if null nonnullary_cons && (length nullary_cons == 1) then
 338                            -- catch this specially to avoid warnings
 339                            -- about overlapping patterns from the desugarer.
 340                           let
 341                            data_con     = head nullary_cons
 342                            data_con_RDR = qual_orig_name data_con
 343                            pat          = ConPatIn data_con_RDR []
 344                           in
 345                           [([pat,pat], eqTag_Expr)]
 346                        else
 347                           map pats_etc nonnullary_cons ++
 348                           -- leave out wildcards to silence desugarer.
 349                           (if length tycon_data_cons == 1 then
 350                               []
 351                            else
 352                               [([WildPatIn, WildPatIn], default_rhs)]))
 353       where
 354         pats_etc data_con
 355           = ([con1_pat, con2_pat],
 356              nested_compare_expr tys_needed as_needed bs_needed)
 357           where
 358             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
 359             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 360
 361             data_con_RDR = qual_orig_name data_con
 362             con_arity   = length tys_needed
 363             as_needed   = take con_arity as_RDRs
 364             bs_needed   = take con_arity bs_RDRs
 365             tys_needed  = dataConRawArgTys data_con
 366
 367             nested_compare_expr [ty] [a] [b]
 368               = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
 369
 370             nested_compare_expr (ty:tys) (a:as) (b:bs)
 371               = let eq_expr = nested_compare_expr tys as bs
 372                 in  careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
 373
 374         default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
 375                                                                 -- inexhaustive patterns
 376                     | otherwise         = eqTag_Expr            -- Some nullary constructors;
 377                                                                 -- Tags are equal, no args => return EQ
 378     --------------------------------------------------------------------
 379
 380 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
 381
 382 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
 383             compare_Case true_Expr  false_Expr false_Expr a_Expr b_Expr)
 384 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
 385             compare_Case true_Expr  true_Expr  false_Expr a_Expr b_Expr)
 386 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
 387             compare_Case false_Expr true_Expr  true_Expr  a_Expr b_Expr)
 388 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
 389             compare_Case false_Expr false_Expr true_Expr  a_Expr b_Expr)
 390
 391 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
 392             compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
 393 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
 394             compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
 395 \end{code}
 396
 397 %************************************************************************
 398 %*                                                                      *
 399 \subsubsection{Generating @Enum@ instance declarations}
 400 %*                                                                      *
 401 %************************************************************************
 402
 403 @Enum@ can only be derived for enumeration types.  For a type
 404 \begin{verbatim}
 405 data Foo ... = N1 | N2 | ... | Nn
 406 \end{verbatim}
 407
 408 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 409 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 410
 411 \begin{verbatim}
 412 instance ... Enum (Foo ...) where
 413     toEnum i = tag2con_Foo i
 414
 415     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 416
 417     -- or, really...
 418     enumFrom a
 419       = case con2tag_Foo a of
 420           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 421
 422    enumFromThen a b
 423      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 424
 425     -- or, really...
 426     enumFromThen a b
 427       = case con2tag_Foo a of { a# ->
 428         case con2tag_Foo b of { b# ->
 429         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 430         }}
 431 \end{verbatim}
 432
 433 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 434
 435 \begin{code}
 436 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
 437
 438 gen_Enum_binds tycon
 439   = to_enum             `AndMonoBinds`
 440     enum_from           `AndMonoBinds`
 441     enum_from_then      `AndMonoBinds`
 442     from_enum
 443   where
 444     tycon_loc = getSrcLoc tycon
 445
 446     to_enum
 447       = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
 448         mk_easy_App (tag2con_RDR tycon) [a_RDR]
 449
 450     enum_from
 451       = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
 452           untag_Expr tycon [(a_RDR, ah_RDR)] $
 453           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 454             HsPar (enum_from_to_Expr
 455                     (mk_easy_App mkInt_RDR [ah_RDR])
 456                     (HsVar (maxtag_RDR tycon)))
 457
 458     enum_from_then
 459       = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
 460           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 461           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 462             HsPar (enum_from_then_to_Expr
 463                     (mk_easy_App mkInt_RDR [ah_RDR])
 464                     (mk_easy_App mkInt_RDR [bh_RDR])
 465                     (HsVar (maxtag_RDR tycon)))
 466
 467     from_enum
 468       = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
 469           untag_Expr tycon [(a_RDR, ah_RDR)] $
 470           (mk_easy_App mkInt_RDR [ah_RDR])
 471 \end{code}
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsubsection{Generating @Bounded@ instance declarations}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 \begin{code}
 480 gen_Bounded_binds tycon
 481   = if isEnumerationTyCon tycon then
 482         min_bound_enum `AndMonoBinds` max_bound_enum
 483     else
 484         ASSERT(length data_cons == 1)
 485         min_bound_1con `AndMonoBinds` max_bound_1con
 486   where
 487     data_cons = tyConDataCons tycon
 488     tycon_loc = getSrcLoc tycon
 489
 490     ----- enum-flavored: ---------------------------
 491     min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
 492     max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
 493
 494     data_con_1    = head data_cons
 495     data_con_N    = last data_cons
 496     data_con_1_RDR = qual_orig_name data_con_1
 497     data_con_N_RDR = qual_orig_name data_con_N
 498
 499     ----- single-constructor-flavored: -------------
 500     arity          = argFieldCount data_con_1
 501
 502     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
 503                      mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
 504     max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
 505                      mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
 506 \end{code}
 507
 508 %************************************************************************
 509 %*                                                                      *
 510 \subsubsection{Generating @Ix@ instance declarations}
 511 %*                                                                      *
 512 %************************************************************************
 513
 514 Deriving @Ix@ is only possible for enumeration types and
 515 single-constructor types.  We deal with them in turn.
 516
 517 For an enumeration type, e.g.,
 518 \begin{verbatim}
 519     data Foo ... = N1 | N2 | ... | Nn
 520 \end{verbatim}
 521 things go not too differently from @Enum@:
 522 \begin{verbatim}
 523 instance ... Ix (Foo ...) where
 524     range (a, b)
 525       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 526
 527     -- or, really...
 528     range (a, b)
 529       = case (con2tag_Foo a) of { a# ->
 530         case (con2tag_Foo b) of { b# ->
 531         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 532         }}
 533
 534     index c@(a, b) d
 535       = if inRange c d
 536         then case (con2tag_Foo d -# con2tag_Foo a) of
 537                r# -> I# r#
 538         else error "Ix.Foo.index: out of range"
 539
 540     inRange (a, b) c
 541       = let
 542             p_tag = con2tag_Foo c
 543         in
 544         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 545
 546     -- or, really...
 547     inRange (a, b) c
 548       = case (con2tag_Foo a)   of { a_tag ->
 549         case (con2tag_Foo b)   of { b_tag ->
 550         case (con2tag_Foo c)   of { c_tag ->
 551         if (c_tag >=# a_tag) then
 552           c_tag <=# b_tag
 553         else
 554           False
 555         }}}
 556 \end{verbatim}
 557 (modulo suitable case-ification to handle the unboxed tags)
 558
 559 For a single-constructor type (NB: this includes all tuples), e.g.,
 560 \begin{verbatim}
 561     data Foo ... = MkFoo a b Int Double c c
 562 \end{verbatim}
 563 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 564 (p.~147).
 565
 566 \begin{code}
 567 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
 568
 569 gen_Ix_binds tycon
 570   = if isEnumerationTyCon tycon
 571     then enum_ixes
 572     else single_con_ixes
 573   where
 574     tycon_str = getOccString tycon
 575     tycon_loc = getSrcLoc tycon
 576
 577     --------------------------------------------------------------
 578     enum_ixes = enum_range `AndMonoBinds`
 579                 enum_index `AndMonoBinds` enum_inRange
 580
 581     enum_range
 582       = mk_easy_FunMonoBind tycon_loc range_RDR
 583                 [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $
 584           untag_Expr tycon [(a_RDR, ah_RDR)] $
 585           untag_Expr tycon [(b_RDR, bh_RDR)] $
 586           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 587               HsPar (enum_from_to_Expr
 588                         (mk_easy_App mkInt_RDR [ah_RDR])
 589                         (mk_easy_App mkInt_RDR [bh_RDR]))
 590
 591     enum_index
 592       = mk_easy_FunMonoBind tycon_loc index_RDR
 593                 [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat] True{-boxed-}),
 594                                 d_Pat] [] (
 595         HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
 596            untag_Expr tycon [(a_RDR, ah_RDR)] (
 597            untag_Expr tycon [(d_RDR, dh_RDR)] (
 598            let
 599                 grhs = unguardedRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc
 600            in
 601            HsCase
 602              (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
 603              [PatMatch (VarPatIn c_RDR)
 604                                 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
 605              tycon_loc
 606            ))
 607         ) {-else-} (
 608            HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
 609         )
 610         tycon_loc)
 611
 612     enum_inRange
 613       = mk_easy_FunMonoBind tycon_loc inRange_RDR
 614           [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] (
 615           untag_Expr tycon [(a_RDR, ah_RDR)] (
 616           untag_Expr tycon [(b_RDR, bh_RDR)] (
 617           untag_Expr tycon [(c_RDR, ch_RDR)] (
 618           HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
 619              (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
 620           ) {-else-} (
 621              false_Expr
 622           ) tycon_loc))))
 623
 624     --------------------------------------------------------------
 625     single_con_ixes
 626       = single_con_range `AndMonoBinds`
 627         single_con_index `AndMonoBinds`
 628         single_con_inRange
 629
 630     data_con
 631       = case maybeTyConSingleCon tycon of -- just checking...
 632           Nothing -> panic "get_Ix_binds"
 633           Just dc -> if (any isUnLiftedType (dataConRawArgTys dc)) then
 634                          error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
 635                      else
 636                          dc
 637
 638     con_arity    = argFieldCount data_con
 639     data_con_RDR = qual_orig_name data_con
 640
 641     as_needed = take con_arity as_RDRs
 642     bs_needed = take con_arity bs_RDRs
 643     cs_needed = take con_arity cs_RDRs
 644
 645     con_pat  xs  = ConPatIn data_con_RDR (map VarPatIn xs)
 646     con_expr     = mk_easy_App data_con_RDR cs_needed
 647
 648     --------------------------------------------------------------
 649     single_con_range
 650       = mk_easy_FunMonoBind tycon_loc range_RDR
 651           [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $
 652         HsDo ListComp stmts tycon_loc
 653       where
 654         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 655                 ++
 656                 [ReturnStmt con_expr]
 657
 658         mk_qual a b c = BindStmt (VarPatIn c)
 659                                  (HsApp (HsVar range_RDR)
 660                                         (ExplicitTuple [HsVar a, HsVar b] True))
 661                                  tycon_loc
 662
 663     ----------------
 664     single_con_index
 665       = mk_easy_FunMonoBind tycon_loc index_RDR
 666                 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
 667                  con_pat cs_needed] [range_size] (
 668         foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
 669       where
 670         mk_index multiply_by (l, u, i)
 671           = genOpApp (
 672                (HsApp (HsApp (HsVar index_RDR)
 673                       (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i))
 674            ) plus_RDR (
 675                 genOpApp (
 676                     (HsApp (HsVar rangeSize_RDR)
 677                            (ExplicitTuple [HsVar l, HsVar u] True))
 678                 ) times_RDR multiply_by
 679            )
 680
 681         range_size
 682           = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
 683                         [TuplePatIn [a_Pat, b_Pat] True] [] (
 684                 genOpApp (
 685                     (HsApp (HsApp (HsVar index_RDR)
 686                            (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr)
 687                 ) plus_RDR (HsLit (HsInt 1)))
 688
 689     ------------------
 690     single_con_inRange
 691       = mk_easy_FunMonoBind tycon_loc inRange_RDR
 692                 [TuplePatIn [con_pat as_needed, con_pat bs_needed] True,
 693                  con_pat cs_needed]
 694                            [] (
 695           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
 696       where
 697         in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
 698                                       (ExplicitTuple [HsVar a, HsVar b] True))
 699                                (HsVar c)
 700 \end{code}
 701
 702 %************************************************************************
 703 %*                                                                      *
 704 \subsubsection{Generating @Read@ instance declarations}
 705 %*                                                                      *
 706 %************************************************************************
 707
 708 Ignoring all the infix-ery mumbo jumbo (ToDo)
 709
 710 \begin{code}
 711 gen_Read_binds :: TyCon -> RdrNameMonoBinds
 712
 713 gen_Read_binds tycon
 714   = reads_prec `AndMonoBinds` read_list
 715   where
 716     tycon_loc = getSrcLoc tycon
 717     -----------------------------------------------------------------------
 718     read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
 719                   (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
 720     -----------------------------------------------------------------------
 721     reads_prec
 722       = let
 723             read_con_comprehensions
 724               = map read_con (tyConDataCons tycon)
 725         in
 726         mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
 727               foldr1 append_Expr read_con_comprehensions
 728         )
 729       where
 730         read_con data_con   -- note: "b" is the string being "read"
 731           = let
 732                 data_con_RDR = qual_orig_name data_con
 733                 data_con_str= occNameString (getOccName data_con)
 734                 con_arity   = argFieldCount data_con
 735                 con_expr    = mk_easy_App data_con_RDR as_needed
 736                 nullary_con = con_arity == 0
 737                 labels      = dataConFieldLabels data_con
 738                 lab_fields  = length labels
 739
 740                 as_needed   = take con_arity as_RDRs
 741                 bs_needed
 742                  | lab_fields == 0 = take con_arity bs_RDRs
 743                  | otherwise       = take (4*lab_fields + 1) bs_RDRs
 744                                        -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
 745                 con_qual
 746                   = BindStmt
 747                           (TuplePatIn [LitPatIn (HsString data_con_str),
 748                                        d_Pat] True)
 749                           (HsApp (HsVar lex_RDR) c_Expr)
 750                           tycon_loc
 751
 752                 str_qual str res draw_from
 753                   = BindStmt
 754                        (TuplePatIn [LitPatIn (HsString str), VarPatIn res] True)
 755                        (HsApp (HsVar lex_RDR) draw_from)
 756                        tycon_loc
 757
 758                 read_label f
 759                   = let nm = occNameString (getOccName (fieldLabelName f))
 760                     in
 761                         [str_qual nm, str_qual SLIT("=")]
 762                             -- There might be spaces between the label and '='
 763
 764                 field_quals
 765                   | lab_fields == 0 =
 766                      snd (mapAccumL mk_qual
 767                                     d_Expr
 768                                     (zipWithEqual "as_needed"
 769                                                   (\ con_field draw_from -> (mk_read_qual con_field,
 770                                                                              draw_from))
 771                                                   as_needed bs_needed))
 772                   | otherwise =
 773                      snd $
 774                      mapAccumL mk_qual d_Expr
 775                         (zipEqual "bs_needed"
 776                            ((str_qual (SLIT("{")):
 777                              concat (
 778                              intersperse ([str_qual (_CONS_ ',' _NIL_)]) $
 779                              zipWithEqual
 780                                 "field_quals"
 781                                 (\ as b -> as ++ [b])
 782                                     -- The labels
 783                                 (map read_label labels)
 784                                     -- The fields
 785                                 (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))])
 786                             bs_needed)
 787
 788                 mk_qual draw_from (f, str_left)
 789                   = (HsVar str_left,    -- what to draw from down the line...
 790                      f str_left draw_from)
 791
 792                 mk_read_qual con_field res draw_from =
 793                   BindStmt
 794                    (TuplePatIn [VarPatIn con_field, VarPatIn res] True)
 795                    (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
 796                    tycon_loc
 797
 798                 result_expr = ExplicitTuple [con_expr, if null bs_needed
 799                                                        then d_Expr
 800                                                        else HsVar (last bs_needed)] True
 801
 802                 stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
 803
 804                 read_paren_arg
 805                   = if nullary_con then -- must be False (parens are surely optional)
 806                        false_Expr
 807                     else -- parens depend on precedence...
 808                        HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
 809             in
 810             HsApp (
 811               readParen_Expr read_paren_arg $ HsPar $
 812                  HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
 813                         HsDo ListComp stmts tycon_loc)
 814               ) (HsVar b_RDR)
 815
 816 \end{code}
 817
 818 %************************************************************************
 819 %*                                                                      *
 820 \subsubsection{Generating @Show@ instance declarations}
 821 %*                                                                      *
 822 %************************************************************************
 823
 824 Ignoring all the infix-ery mumbo jumbo (ToDo)
 825
 826 \begin{code}
 827 gen_Show_binds :: TyCon -> RdrNameMonoBinds
 828
 829 gen_Show_binds tycon
 830   = shows_prec `AndMonoBinds` show_list
 831   where
 832     tycon_loc = getSrcLoc tycon
 833     -----------------------------------------------------------------------
 834     show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
 835                   (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
 836     -----------------------------------------------------------------------
 837     shows_prec
 838       = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 839       where
 840         pats_etc data_con
 841           = let
 842                 data_con_RDR = qual_orig_name data_con
 843                 con_arity    = argFieldCount data_con
 844                 bs_needed    = take con_arity bs_RDRs
 845                 con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 846                 nullary_con  = con_arity == 0
 847                 labels       = dataConFieldLabels data_con
 848                 lab_fields   = length labels
 849
 850                 show_con
 851                   = let nm = occNameString (getOccName data_con)
 852                         space_ocurly_maybe
 853                           | nullary_con     = _NIL_
 854                           | lab_fields == 0 = SLIT(" ")
 855                           | otherwise       = SLIT("{")
 856
 857                     in
 858                         mk_showString_app (nm _APPEND_ space_ocurly_maybe)
 859
 860                 show_all con fs
 861                   = let
 862                         ccurly_maybe
 863                           | lab_fields > 0  = [mk_showString_app (SLIT("}"))]
 864                           | otherwise       = []
 865                     in
 866                         con:fs ++ ccurly_maybe
 867
 868                 show_thingies = show_all show_con real_show_thingies_with_labs
 869
 870                 show_label l
 871                   = let nm = occNameString (getOccName (fieldLabelName l))
 872                     in
 873                         mk_showString_app (nm _APPEND_ SLIT("="))
 874
 875                 mk_showString_app str = HsApp (HsVar showString_RDR)
 876                                               (HsLit (HsString str))
 877
 878                 real_show_thingies =
 879                      [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
 880                      | b <- bs_needed ]
 881
 882                 real_show_thingies_with_labs
 883                  | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
 884                  | otherwise       = --Assumption: no of fields == no of labelled fields
 885                                      --            (and in same order)
 886                     concat $
 887                     intersperse ([mk_showString_app (_CONS_ ',' _NIL_)]) $ -- Using SLIT()s containing ,s spells trouble.
 888                     zipWithEqual "gen_Show_binds"
 889                                  (\ a b -> [a,b])
 890                                  (map show_label labels)
 891                                  real_show_thingies
 892
 893
 894             in
 895             if nullary_con then  -- skip the showParen junk...
 896                 ASSERT(null bs_needed)
 897                 ([a_Pat, con_pat], show_con)
 898             else
 899                 ([a_Pat, con_pat],
 900                     showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
 901                                    (HsPar (nested_compose_Expr show_thingies)))
 902 \end{code}
 903
 904 %************************************************************************
 905 %*                                                                      *
 906 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
 907 %*                                                                      *
 908 %************************************************************************
 909
 910 \begin{verbatim}
 911 data Foo ... = ...
 912
 913 con2tag_Foo :: Foo ... -> Int#
 914 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 915 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 916 \end{verbatim}
 917
 918 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 919 fiddling around.
 920
 921 \begin{code}
 922 data TagThingWanted
 923   = GenCon2Tag | GenTag2Con | GenMaxTag
 924
 925 gen_tag_n_con_monobind
 926     :: (RdrName,            -- (proto)Name for the thing in question
 927         TyCon,              -- tycon in question
 928         TagThingWanted)
 929     -> RdrNameMonoBinds
 930
 931 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
 932   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
 933   where
 934     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
 935
 936     mk_stuff var
 937       = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
 938       where
 939         pat    = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
 940         var_RDR = qual_orig_name var
 941
 942 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
 943   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
 944                                                              [([WildPatIn], impossible_Expr)])
 945   where
 946     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
 947     mk_stuff var = ([lit_pat], HsVar var_RDR)
 948       where
 949         lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
 950         var_RDR  = qual_orig_name var
 951
 952 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
 953   = mk_easy_FunMonoBind (getSrcLoc tycon)
 954                 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
 955   where
 956     max_tag =  case (tyConDataCons tycon) of
 957                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
 958
 959 \end{code}
 960
 961 %************************************************************************
 962 %*                                                                      *
 963 \subsection{Utility bits for generating bindings}
 964 %*                                                                      *
 965 %************************************************************************
 966
 967 @mk_easy_FunMonoBind fun pats binds expr@ generates:
 968 \begin{verbatim}
 969     fun pat1 pat2 ... patN = expr where binds
 970 \end{verbatim}
 971
 972 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
 973 multi-clause definitions; it generates:
 974 \begin{verbatim}
 975     fun p1a p1b ... p1N = e1
 976     fun p2a p2b ... p2N = e2
 977     ...
 978     fun pMa pMb ... pMN = eM
 979 \end{verbatim}
 980
 981 \begin{code}
 982 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
 983                     -> [RdrNameMonoBinds] -> RdrNameHsExpr
 984                     -> RdrNameMonoBinds
 985
 986 mk_easy_FunMonoBind loc fun pats binds expr
 987   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
 988
 989 mk_easy_Match loc pats binds expr
 990   = mk_match loc pats expr (mkbind binds)
 991   where
 992     mkbind [] = EmptyBinds
 993     mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
 994         -- The renamer expects everything in its input to be a
 995         -- "recursive" MonoBinds, and it is its job to sort things out
 996         -- from there.
 997
 998 mk_FunMonoBind  :: SrcLoc -> RdrName
 999                 -> [([RdrNamePat], RdrNameHsExpr)]
1000                 -> RdrNameMonoBinds
1001
1002 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1003 mk_FunMonoBind loc fun pats_and_exprs
1004   = FunMonoBind fun False{-not infix-}
1005                 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1006                 loc
1007
1008 mk_match loc pats expr binds
1009   = foldr PatMatch
1010           (GRHSMatch (GRHSsAndBindsIn (unguardedRHS expr loc) binds))
1011           (map paren pats)
1012   where
1013     paren p@(VarPatIn _) = p
1014     paren other_p        = ParPatIn other_p
1015 \end{code}
1016
1017 \begin{code}
1018 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1019 \end{code}
1020
1021 ToDo: Better SrcLocs.
1022
1023 \begin{code}
1024 compare_Case, cmp_eq_Expr ::
1025           RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1026           -> RdrNameHsExpr -> RdrNameHsExpr
1027           -> RdrNameHsExpr
1028 compare_gen_Case ::
1029           RdrName
1030           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1031           -> RdrNameHsExpr -> RdrNameHsExpr
1032           -> RdrNameHsExpr
1033 careful_compare_Case :: -- checks for primitive types...
1034           Type
1035           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1036           -> RdrNameHsExpr -> RdrNameHsExpr
1037           -> RdrNameHsExpr
1038
1039 compare_Case = compare_gen_Case compare_RDR
1040 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
1041
1042 compare_gen_Case fun lt eq gt a b
1043   = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1044       [PatMatch (ConPatIn ltTag_RDR [])
1045           (GRHSMatch (GRHSsAndBindsIn (unguardedRHS lt mkGeneratedSrcLoc) EmptyBinds)),
1046
1047        PatMatch (ConPatIn eqTag_RDR [])
1048           (GRHSMatch (GRHSsAndBindsIn (unguardedRHS eq mkGeneratedSrcLoc) EmptyBinds)),
1049
1050        PatMatch (ConPatIn gtTag_RDR [])
1051           (GRHSMatch (GRHSsAndBindsIn (unguardedRHS gt mkGeneratedSrcLoc) EmptyBinds))]
1052        mkGeneratedSrcLoc
1053
1054 careful_compare_Case ty lt eq gt a b
1055   = if not (isUnboxedType ty) then
1056        compare_gen_Case compare_RDR lt eq gt a b
1057
1058     else -- we have to do something special for primitive things...
1059        HsIf (genOpApp a relevant_eq_op b)
1060             eq
1061             (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1062             mkGeneratedSrcLoc
1063   where
1064     relevant_eq_op = assoc_ty_id eq_op_tbl ty
1065     relevant_lt_op = assoc_ty_id lt_op_tbl ty
1066
1067 assoc_ty_id tyids ty
1068   = if null res then panic "assoc_ty"
1069     else head res
1070   where
1071     res = [id | (ty',id) <- tyids, ty == ty']
1072
1073 eq_op_tbl =
1074     [(charPrimTy,       eqH_Char_RDR)
1075     ,(intPrimTy,        eqH_Int_RDR)
1076     ,(wordPrimTy,       eqH_Word_RDR)
1077     ,(addrPrimTy,       eqH_Addr_RDR)
1078     ,(floatPrimTy,      eqH_Float_RDR)
1079     ,(doublePrimTy,     eqH_Double_RDR)
1080     ]
1081
1082 lt_op_tbl =
1083     [(charPrimTy,       ltH_Char_RDR)
1084     ,(intPrimTy,        ltH_Int_RDR)
1085     ,(wordPrimTy,       ltH_Word_RDR)
1086     ,(addrPrimTy,       ltH_Addr_RDR)
1087     ,(floatPrimTy,      ltH_Float_RDR)
1088     ,(doublePrimTy,     ltH_Double_RDR)
1089     ]
1090
1091 -----------------------------------------------------------------------
1092
1093 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1094
1095 and_Expr    a b = genOpApp a and_RDR    b
1096 append_Expr a b = genOpApp a append_RDR b
1097
1098 -----------------------------------------------------------------------
1099
1100 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1101 eq_Expr ty a b
1102   = if not (isUnboxedType ty) then
1103        genOpApp a eq_RDR  b
1104     else -- we have to do something special for primitive things...
1105        genOpApp a relevant_eq_op b
1106   where
1107     relevant_eq_op = assoc_ty_id eq_op_tbl ty
1108 \end{code}
1109
1110 \begin{code}
1111 argFieldCount :: DataCon -> Int -- Works on data and newtype constructors
1112 argFieldCount con = length (dataConRawArgTys con)
1113 \end{code}
1114
1115 \begin{code}
1116 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1117 untag_Expr tycon [] expr = expr
1118 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1119   = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1120       [PatMatch (VarPatIn put_tag_here)
1121                         (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
1122       mkGeneratedSrcLoc
1123   where
1124     grhs = unguardedRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc
1125
1126 cmp_tags_Expr :: RdrName                -- Comparison op
1127              -> RdrName -> RdrName      -- Things to compare
1128              -> RdrNameHsExpr           -- What to return if true
1129              -> RdrNameHsExpr           -- What to return if false
1130              -> RdrNameHsExpr
1131
1132 cmp_tags_Expr op a b true_case false_case
1133   = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1134
1135 enum_from_to_Expr
1136         :: RdrNameHsExpr -> RdrNameHsExpr
1137         -> RdrNameHsExpr
1138 enum_from_then_to_Expr
1139         :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1140         -> RdrNameHsExpr
1141
1142 enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1143 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1144
1145 showParen_Expr, readParen_Expr
1146         :: RdrNameHsExpr -> RdrNameHsExpr
1147         -> RdrNameHsExpr
1148
1149 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1150 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1151
1152 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1153
1154 nested_compose_Expr [e] = parenify e
1155 nested_compose_Expr (e:es)
1156   = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1157
1158 -- impossible_Expr is used in case RHSs that should never happen.
1159 -- We generate these to keep the desugarer from complaining that they *might* happen!
1160 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1161
1162 parenify e@(HsVar _) = e
1163 parenify e           = HsPar e
1164
1165 -- genOpApp wraps brackets round the operator application, so that the
1166 -- renamer won't subsequently try to re-associate it.
1167 -- For some reason the renamer doesn't reassociate it right, and I can't
1168 -- be bothered to find out why just now.
1169
1170 genOpApp e1 op e2 = mkOpApp e1 op e2
1171 \end{code}
1172
1173 \begin{code}
1174 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
1175
1176 a_RDR           = varUnqual SLIT("a")
1177 b_RDR           = varUnqual SLIT("b")
1178 c_RDR           = varUnqual SLIT("c")
1179 d_RDR           = varUnqual SLIT("d")
1180 ah_RDR          = varUnqual SLIT("a#")
1181 bh_RDR          = varUnqual SLIT("b#")
1182 ch_RDR          = varUnqual SLIT("c#")
1183 dh_RDR          = varUnqual SLIT("d#")
1184 cmp_eq_RDR      = varUnqual SLIT("cmp_eq")
1185 rangeSize_RDR   = varUnqual SLIT("rangeSize")
1186
1187 as_RDRs         = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1188 bs_RDRs         = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1189 cs_RDRs         = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1190
1191 a_Expr          = HsVar a_RDR
1192 b_Expr          = HsVar b_RDR
1193 c_Expr          = HsVar c_RDR
1194 d_Expr          = HsVar d_RDR
1195 ltTag_Expr      = HsVar ltTag_RDR
1196 eqTag_Expr      = HsVar eqTag_RDR
1197 gtTag_Expr      = HsVar gtTag_RDR
1198 false_Expr      = HsVar false_RDR
1199 true_Expr       = HsVar true_RDR
1200
1201 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1202
1203 a_Pat           = VarPatIn a_RDR
1204 b_Pat           = VarPatIn b_RDR
1205 c_Pat           = VarPatIn c_RDR
1206 d_Pat           = VarPatIn d_RDR
1207
1208 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1209
1210 con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1211 tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1212 maxtag_RDR tycon  = varUnqual (SLIT("maxtag_")  _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1213 \end{code}