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