ghc/compiler/typecheck/TcGenDeriv.lhs

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