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