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