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