ghc/compiler/typecheck/TcGenDeriv.lhs

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