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