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