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