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