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