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