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