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