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