ghc/compiler/typecheck/TcDeriv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[TcDeriv]{Deriving}
   5
   6 Handles @deriving@ clauses on @data@ declarations.
   7
   8 \begin{code}
   9 #include "HsVersions.h"
  10
  11 module TcDeriv (
  12         tcDeriving
  13     ) where
  14
  15 import Ubiq
  16
  17 import HsSyn            ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
  18                           GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
  19                           ArithSeqInfo, Fake, MonoType )
  20 import HsPragmas        ( InstancePragmas(..) )
  21 import RnHsSyn          ( RenamedHsBinds(..), RenamedFixityDecl(..) )
  22 import TcHsSyn          ( TcIdOcc )
  23
  24 import TcMonad
  25 import Inst             ( InstOrigin(..), InstanceMapper(..) )
  26 import TcEnv            ( getEnv_TyCons )
  27 import TcKind           ( TcKind )
  28 --import TcGenDeriv     -- Deriv stuff
  29 import TcInstUtil       ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
  30 import TcSimplify       ( tcSimplifyThetas )
  31
  32 --import RnMonad4
  33 import RnUtils          ( GlobalNameMappers(..), GlobalNameMapper(..) )
  34 --import RnBinds4               ( rnMethodBinds, rnTopBinds )
  35
  36 import Bag              ( Bag, isEmptyBag, unionBags, listToBag )
  37 import Class            ( GenClass, getClassKey )
  38 import CmdLineOpts      ( opt_CompilingPrelude )
  39 import ErrUtils         ( pprBagOfErrors, addErrLoc, Error(..) )
  40 import Id               ( dataConSig, dataConArity )
  41 import Maybes           ( assocMaybe, maybeToBool, Maybe(..) )
  42 import Outputable
  43 import PprType          ( GenType, GenTyVar, GenClass, TyCon )
  44 import PprStyle
  45 import Pretty
  46 import SrcLoc           ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
  47 import TyCon            ( tyConTyVars, tyConDataCons, tyConDerivings,
  48                           maybeTyConSingleCon, isEnumerationTyCon, TyCon )
  49 import Type             ( GenType(..), TauType(..), mkTyVarTys, applyTyCon,
  50                           mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
  51                           getAppTyCon, getAppDataTyCon )
  52 import TyVar            ( GenTyVar )
  53 import UniqFM           ( eltsUFM )
  54 import Unique           -- Keys stuff
  55 import Util             ( zipWithEqual, zipEqual, sortLt, removeDups,
  56                           thenCmp, cmpList, panic, pprPanic, pprPanic# )
  57 \end{code}
  58
  59 %************************************************************************
  60 %*                                                                      *
  61 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
  62 %*                                                                      *
  63 %************************************************************************
  64
  65 Consider
  66
  67         data T a b = C1 (Foo a) (Bar b)
  68                    | C2 Int (T b a)
  69                    | C3 (T a a)
  70                    deriving (Eq)
  71
  72 We want to come up with an instance declaration of the form
  73
  74         instance (Ping a, Pong b, ...) => Eq (T a b) where
  75                 x == y = ...
  76
  77 It is pretty easy, albeit tedious, to fill in the code "...".  The
  78 trick is to figure out what the context for the instance decl is,
  79 namely @Ping@, @Pong@ and friends.
  80
  81 Let's call the context reqd for the T instance of class C at types
  82 (a,b, ...)  C (T a b).  Thus:
  83
  84         Eq (T a b) = (Ping a, Pong b, ...)
  85
  86 Now we can get a (recursive) equation from the @data@ decl:
  87
  88         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
  89                    u Eq (T b a) u Eq Int        -- From C2
  90                    u Eq (T a a)                 -- From C3
  91
  92 Foo and Bar may have explicit instances for @Eq@, in which case we can
  93 just substitute for them.  Alternatively, either or both may have
  94 their @Eq@ instances given by @deriving@ clauses, in which case they
  95 form part of the system of equations.
  96
  97 Now all we need do is simplify and solve the equations, iterating to
  98 find the least fixpoint.  Notice that the order of the arguments can
  99 switch around, as here in the recursive calls to T.
 100
 101 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
 102
 103 We start with:
 104
 105         Eq (T a b) = {}         -- The empty set
 106
 107 Next iteration:
 108         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 109                    u Eq (T b a) u Eq Int        -- From C2
 110                    u Eq (T a a)                 -- From C3
 111
 112         After simplification:
 113                    = Eq a u Ping b u {} u {} u {}
 114                    = Eq a u Ping b
 115
 116 Next iteration:
 117
 118         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 119                    u Eq (T b a) u Eq Int        -- From C2
 120                    u Eq (T a a)                 -- From C3
 121
 122         After simplification:
 123                    = Eq a u Ping b
 124                    u (Eq b u Ping a)
 125                    u (Eq a u Ping a)
 126
 127                    = Eq a u Ping b u Eq b u Ping a
 128
 129 The next iteration gives the same result, so this is the fixpoint.  We
 130 need to make a canonical form of the RHS to ensure convergence.  We do
 131 this by simplifying the RHS to a form in which
 132
 133         - the classes constrain only tyvars
 134         - the list is sorted by tyvar (major key) and then class (minor key)
 135         - no duplicates, of course
 136
 137 So, here are the synonyms for the ``equation'' structures:
 138
 139 \begin{code}
 140 type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
 141                          -- The tyvars bind all the variables in the RHS
 142                          -- NEW: it's convenient to re-use InstInfo
 143                          -- We'll "panic" out some fields...
 144
 145 type DerivRhs = [(Class, TauType)]      -- Same as a ThetaType!
 146
 147 type DerivSoln = DerivRhs
 148 \end{code}
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 \begin{code}
 157 tcDeriving  :: Module                   -- name of module under scrutiny
 158             -> GlobalNameMappers        -- for "renaming" bits of generated code
 159             -> Bag InstInfo             -- What we already know about instances
 160             -> [RenamedFixityDecl]      -- Fixity info; used by Read and Show
 161             -> TcM s (Bag InstInfo,     -- The generated "instance decls".
 162                       RenamedHsBinds,   -- Extra generated bindings
 163                       PprStyle -> Pretty)  -- Printable derived instance decls;
 164                                            -- for debugging via -ddump-derivings.
 165 tcDeriving = panic "tcDeriving: ToDo LATER"
 166 {- LATER:
 167
 168 tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
 169   =     -- Fish the "deriving"-related information out of the TcEnv
 170         -- and make the necessary "equations".
 171     makeDerivEqns               `thenTc` \ eqns ->
 172
 173         -- Take the equation list and solve it, to deliver a list of
 174         -- solutions, a.k.a. the contexts for the instance decls
 175         -- required for the corresponding equations.
 176     solveDerivEqns inst_decl_infos_in eqns
 177                                 `thenTc` \ new_inst_infos ->
 178
 179         -- Now augment the InstInfos, adding in the rather boring
 180         -- actual-code-to-do-the-methods binds.  We may also need to
 181         -- generate extra not-one-inst-decl-specific binds, notably
 182         -- "con2tag" and/or "tag2con" functions.  We do these
 183         -- separately.
 184
 185     gen_taggery_Names eqns      `thenTc` \ nm_alist_etc ->
 186     let
 187         nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
 188
 189         -- We have the renamer's final "name funs" in our hands
 190         -- (they were passed in).  So we can handle ProtoNames
 191         -- that refer to anything "out there".  But our generated
 192         -- code may also mention "con2tag" (etc.).  So we need
 193         -- to augment to "name funs" to include those.
 194         (rn_val_gnf, rn_tc_gnf) = renamer_name_funs
 195
 196         deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of
 197                                 Just xx -> Just xx
 198                                 Nothing -> rn_val_gnf pname
 199
 200         deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
 201
 202         assoc_maybe [] _ = Nothing
 203         assoc_maybe ((k,v) : vs) key
 204           = if k `eqProtoName` key then Just v else assoc_maybe vs key
 205     in
 206     gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
 207
 208     mapTc (gen_inst_info maybe_mod fixities deriver_name_funs) new_inst_infos
 209                                                   `thenTc` \ really_new_inst_infos ->
 210
 211     returnTc (listToBag really_new_inst_infos,
 212               extra_binds,
 213               ddump_deriving really_new_inst_infos extra_binds)
 214   where
 215     maybe_mod = if opt_CompilingPrelude then Nothing else Just mod_name
 216
 217     ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
 218
 219     ddump_deriving inst_infos extra_binds sty
 220       = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
 221       where
 222         pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
 223           = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
 224                     (ppr sty mbinds)
 225 \end{code}
 226
 227
 228 %************************************************************************
 229 %*                                                                      *
 230 \subsection[TcDeriv-eqns]{Forming the equations}
 231 %*                                                                      *
 232 %************************************************************************
 233
 234 @makeDerivEqns@ fishes around to find the info about needed derived
 235 instances.  Complicating factors:
 236 \begin{itemize}
 237 \item
 238 We can only derive @Enum@ if the data type is an enumeration
 239 type (all nullary data constructors).
 240
 241 \item
 242 We can only derive @Ix@ if the data type is an enumeration {\em
 243 or} has just one data constructor (e.g., tuples).
 244 \end{itemize}
 245
 246 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
 247 all those.
 248
 249 \begin{code}
 250 makeDerivEqns :: TcM s [DerivEqn]
 251
 252 makeDerivEqns
 253   = tcGetEnv `thenNF_Tc` \ env ->
 254     let
 255         tycons = getEnv_TyCons env
 256         think_about_deriving = need_deriving tycons
 257     in
 258     mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
 259     let
 260         (derive_these, _) = removeDups cmp_deriv think_about_deriving
 261         eqns = map mk_eqn derive_these
 262     in
 263     returnTc eqns
 264   where
 265     ------------------------------------------------------------------
 266     need_deriving :: [TyCon] -> [(Class, TyCon)]
 267         -- find the tycons that have `deriving' clauses
 268
 269     need_deriving tycons_to_consider
 270       = foldr ( \ tycon acc ->
 271                    case (tyConDerivings tycon) of
 272                      [] -> acc
 273                      cs -> [ (clas,tycon) | clas <- cs ] ++ acc
 274               )
 275               []
 276               tycons_to_consider
 277
 278     ------------------------------------------------------------------
 279     chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
 280     chk_out whole_deriving_list this_one@(clas, tycon)
 281       = let
 282             clas_key = getClassKey clas
 283         in
 284
 285             -- Are things OK for deriving Enum (if appropriate)?
 286         checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon))
 287                 (derivingEnumErr tycon)                 `thenTc_`
 288
 289             -- Are things OK for deriving Ix (if appropriate)?
 290         checkTc (clas_key == ixClassKey
 291                  && not (isEnumerationTyCon tycon
 292                          || maybeToBool (maybeTyConSingleCon tycon)))
 293                 (derivingIxErr tycon)
 294
 295     ------------------------------------------------------------------
 296     cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
 297     cmp_deriv (c1, t1) (c2, t2)
 298       = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
 299
 300     ------------------------------------------------------------------
 301     mk_eqn :: (Class, TyCon) -> DerivEqn
 302         -- we swizzle the tyvars and datacons out of the tycon
 303         -- to make the rest of the equation
 304
 305     mk_eqn (clas, tycon)
 306       = (clas, tycon, tyvars, constraints)
 307       where
 308         tyvars    = tyConTyVars tycon   -- ToDo: Do we need new tyvars ???
 309         tyvar_tys = mkTyVarTys tyvars
 310         data_cons = tyConDataCons tycon
 311         constraints = concat (map mk_constraints data_cons)
 312
 313         mk_constraints data_con
 314            = [ (clas, instantiateTy inst_env arg_ty)
 315              | arg_ty <- arg_tys,
 316                not (isPrimType arg_ty)  -- No constraints for primitive types
 317              ]
 318            where
 319              (con_tyvars, _, arg_tys, _) = dataConSig data_con
 320              inst_env = con_tyvars `zipEqual` tyvar_tys
 321                         -- same number of tyvars in data constr and type constr!
 322 \end{code}
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
 331 terms, which is the final correct RHS for the corresponding original
 332 equation.
 333 \begin{itemize}
 334 \item
 335 Each (k,UniTyVarTemplate tv) in a solution constrains only a type
 336 variable, tv.
 337
 338 \item
 339 The (k,UniTyVarTemplate tv) pairs in a solution are canonically
 340 ordered by sorting on type varible, tv, (major key) and then class, k,
 341 (minor key)
 342 \end{itemize}
 343
 344 \begin{code}
 345 solveDerivEqns :: Bag InstInfo
 346                -> [DerivEqn]
 347                -> TcM s [InstInfo]      -- Solns in same order as eqns.
 348                                         -- This bunch is Absolutely minimal...
 349
 350 solveDerivEqns inst_decl_infos_in orig_eqns
 351   = iterateDeriv initial_solutions
 352   where
 353         -- The initial solutions for the equations claim that each
 354         -- instance has an empty context; this solution is certainly
 355         -- in canonical form.
 356     initial_solutions :: [DerivSoln]
 357     initial_solutions = [ [] | _ <- orig_eqns ]
 358
 359         -- iterateDeriv calculates the next batch of solutions,
 360         -- compares it with the current one; finishes if they are the
 361         -- same, otherwise recurses with the new solutions.
 362
 363     iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
 364
 365     iterateDeriv current_solns
 366       =     -- Extend the inst info from the explicit instance decls
 367             -- with the current set of solutions, giving a
 368
 369         add_solns inst_decl_infos_in orig_eqns current_solns
 370                                 `thenTc` \ (new_inst_infos, inst_mapper) ->
 371
 372             -- Simplify each RHS, using a DerivingOrigin containing an
 373             -- inst_mapper reflecting the previous solution
 374         let
 375             mk_deriv_origin clas ty
 376               = DerivingOrigin inst_mapper clas tycon
 377               where
 378                 (tycon,_) = getAppTyCon ty
 379         in
 380         listTc [ tcSimplifyThetas mk_deriv_origin rhs
 381                | (_, _, _, rhs) <- orig_eqns
 382                ]                `thenTc` \ next_solns ->
 383
 384             -- Canonicalise the solutions, so they compare nicely
 385         let canonicalised_next_solns
 386               = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
 387
 388         if current_solns `eq_solns` canonicalised_next_solns then
 389             returnTc new_inst_infos
 390         else
 391             iterateDeriv canonicalised_next_solns
 392
 393       where
 394         ------------------------------------------------------------------
 395         lt_rhs    r1 r2 = case cmp_rhs   r1 r2 of { LT_ -> True; _ -> False }
 396         eq_solns  s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
 397         cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
 398         cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
 399           = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
 400 #ifdef DEBUG
 401         cmp_rhs other_1 other_2
 402           = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
 403 #endif
 404
 405 \end{code}
 406
 407 \begin{code}
 408 add_solns :: FAST_STRING
 409           -> Bag InstInfo                       -- The global, non-derived ones
 410           -> [DerivEqn] -> [DerivSoln]
 411           -> TcM s ([InstInfo],                 -- The new, derived ones
 412                     InstanceMapper)
 413     -- the eqns and solns move "in lockstep"; we have the eqns
 414     -- because we need the LHS info for addClassInstance.
 415
 416 add_solns inst_infos_in eqns solns
 417   = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
 418     returnTc (new_inst_infos, inst_mapper)
 419   where
 420     new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns
 421
 422     all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
 423
 424     mk_deriv_inst_info (clas, tycon, tyvars, _) theta
 425       = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
 426                  theta
 427                  theta                  -- Blarg.  This is the dfun_theta slot,
 428                                         -- which is needed by buildInstanceEnv;
 429                                         -- This works ok for solving the eqns, and
 430                                         -- gen_eqns sets it to its final value
 431                                         -- (incl super class dicts) before we
 432                                         -- finally return it.
 433 #ifdef DEBUG
 434                  (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
 435                  (panic "add_soln:binds")   (panic "add_soln:from_here")
 436                  (panic "add_soln:modname") mkGeneratedSrcLoc
 437                  (panic "add_soln:upragmas")
 438 #else
 439                 bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
 440       where
 441         bottom = panic "add_soln"
 442 #endif
 443 \end{code}
 444
 445 %************************************************************************
 446 %*                                                                      *
 447 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
 448 %*                                                                      *
 449 %************************************************************************
 450
 451 After all the trouble to figure out the required context for the
 452 derived instance declarations, all that's left is to chug along to
 453 produce them.  They will then be shoved into @tcInstDecls2@, which
 454 will do all its usual business.
 455
 456 There are lots of possibilities for code to generate.  Here are
 457 various general remarks.
 458
 459 PRINCIPLES:
 460 \begin{itemize}
 461 \item
 462 We want derived instances of @Eq@ and @Ord@ (both v common) to be
 463 ``you-couldn't-do-better-by-hand'' efficient.
 464
 465 \item
 466 Deriving @Text@---also pretty common, usually just for
 467 @show@---should also be reasonable good code.
 468
 469 \item
 470 Deriving for the other classes isn't that common or that big a deal.
 471 \end{itemize}
 472
 473 PRAGMATICS:
 474
 475 \begin{itemize}
 476 \item
 477 Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method.
 478
 479 \item
 480 Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too.
 481
 482 \item
 483 We {\em normally} generated code only for the non-defaulted methods;
 484 there are some exceptions for @Eq@ and (especially) @Ord@...
 485
 486 \item
 487 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
 488 constructor's numeric (@Int#@) tag.  These are generated by
 489 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
 490 these is around is given by @hasCon2TagFun@.
 491
 492
 493 The examples under the different sections below will make this
 494 clearer.
 495
 496 \item
 497 Much less often (really just for deriving @Ix@), we use a
 498 @_tag2con_<tycon>@ function.  See the examples.
 499
 500 \item
 501 We use Pass~4 of the renamer!!!  Reason: we're supposed to be
 502 producing @RenamedMonoBinds@ for the methods, but that means
 503 producing correctly-uniquified code on the fly.  This is entirely
 504 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
 505 So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through
 506 the renamer.  What a great hack!
 507 \end{itemize}
 508
 509 \begin{code}
 510 gen_inst_info :: Maybe Module           -- Module name; Nothing => Prelude
 511               -> [RenamedFixityDecl]    -- all known fixities;
 512                                         -- may be needed for Text
 513               -> GlobalNameMappers              -- lookup stuff for names we may use
 514               -> InstInfo               -- the main stuff to work on
 515               -> TcM s InstInfo         -- the gen'd (filled-in) "instance decl"
 516
 517 gen_inst_info modname fixities deriver_name_funs
 518     info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
 519   =
 520         -- Generate the various instance-related Ids
 521     mkInstanceRelatedIds
 522                 True {-from_here-} modname
 523                 NoInstancePragmas
 524                 clas tyvars ty
 525                 inst_decl_theta
 526                 [{-no user pragmas-}]
 527                         `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 528
 529         -- Generate the bindings for the new instance declaration,
 530         -- rename it, and check for errors
 531     let
 532         (tycon,_,_)  = getAppDataTyCon ty
 533
 534         proto_mbinds
 535           | clas_key == eqClassKey     = gen_Eq_binds tycon
 536           | clas_key == showClassKey   = gen_Show_binds fixities tycon
 537           | clas_key == ordClassKey    = gen_Ord_binds tycon
 538           | clas_key == enumClassKey   = gen_Enum_binds tycon
 539           | clas_key == ixClassKey     = gen_Ix_binds tycon
 540           | clas_key == readClassKey   = gen_Read_binds fixities tycon
 541           | clas_key == binaryClassKey = gen_Binary_binds tycon
 542           | otherwise = panic "gen_inst_info:bad derived class"
 543     in
 544     rn4MtoTcM deriver_name_funs (
 545         rnMethodBinds clas_Name proto_mbinds
 546     )                   `thenNF_Tc` \ (mbinds, errs) ->
 547
 548     if not (isEmptyBag errs) then
 549         pprPanic "gen_inst_info:renamer errs!\n"
 550                  (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
 551     else
 552     --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
 553
 554         -- All done
 555     let
 556         from_here = isLocallyDefined tycon      -- If so, then from here
 557     in
 558     returnTc (InstInfo clas tyvars ty inst_decl_theta
 559                        dfun_theta dfun_id const_meth_ids
 560                        (if from_here then mbinds else EmptyMonoBinds)
 561                        from_here modname locn [])
 562   where
 563     clas_key = getClassKey clas
 564     clas_Name
 565       = let  (mod, nm) = getOrigName clas  in
 566         ClassName clas_key (mkPreludeCoreName mod nm) []
 567 \end{code}
 568
 569 %************************************************************************
 570 %*                                                                      *
 571 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
 572 %*                                                                      *
 573 %************************************************************************
 574
 575 data Foo ... = ...
 576
 577 con2tag_Foo :: Foo ... -> Int#
 578 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 579 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 580
 581 \begin{code}
 582 gen_tag_n_con_binds :: GlobalNameMappers
 583                     -> [(RdrName, RnName, TyCon, TagThingWanted)]
 584                     -> TcM s RenamedHsBinds
 585
 586 gen_tag_n_con_binds deriver_name_funs nm_alist_etc
 587   = let
 588       proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
 589       proto_mbinds     = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
 590     in
 591
 592     rn4MtoTcM deriver_name_funs (
 593         rnTopBinds (SingleBind (RecBind proto_mbinds))
 594     )                   `thenNF_Tc` \ (binds, errs) ->
 595
 596     if not (isEmptyBag errs) then
 597         panic "gen_inst_info:renamer errs (2)!"
 598     else
 599         returnTc binds
 600 \end{code}
 601
 602 %************************************************************************
 603 %*                                                                      *
 604 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
 605 %*                                                                      *
 606 %************************************************************************
 607
 608 We have a @con2tag@ function for a tycon if:
 609 \begin{itemize}
 610 \item
 611 We're deriving @Eq@ and the tycon has nullary data constructors.
 612
 613 \item
 614 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
 615 (enum type only????)
 616 \end{itemize}
 617
 618 We have a @tag2con@ function for a tycon if:
 619 \begin{itemize}
 620 \item
 621 We're deriving @Enum@, or @Ix@ (enum type only???)
 622 \end{itemize}
 623
 624 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
 625
 626 \begin{code}
 627 gen_taggery_Names :: [DerivEqn]
 628                   -> TcM s [(RdrName, RnName,   -- for an assoc list
 629                              TyCon,             -- related tycon
 630                              TagThingWanted)]
 631
 632 gen_taggery_Names eqns
 633   = let
 634         all_tycons = [ tc | (_, tc, _, _) <- eqns ]
 635         (tycons_of_interest, _) = removeDups cmp all_tycons
 636     in
 637         foldlTc do_con2tag []           tycons_of_interest `thenTc` \ names_so_far ->
 638         foldlTc do_tag2con names_so_far tycons_of_interest
 639   where
 640     do_con2tag acc_Names tycon
 641       = if (we_are_deriving eqClassKey tycon
 642             && any ( (== 0).dataConArity ) (tyConDataCons tycon))
 643         || (we_are_deriving ordClassKey  tycon
 644             && not (maybeToBool (maybeTyConSingleCon tycon)))
 645         || (we_are_deriving enumClassKey tycon)
 646         || (we_are_deriving ixClassKey   tycon)
 647         then
 648           tcGetUnique   `thenNF_Tc` ( \ u ->
 649           returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
 650                    : acc_Names) )
 651         else
 652           returnTc acc_Names
 653
 654     do_tag2con acc_Names tycon
 655       = if (we_are_deriving enumClassKey tycon)
 656         || (we_are_deriving ixClassKey   tycon)
 657         then
 658           tcGetUnique   `thenNF_Tc` \ u1 ->
 659           tcGetUnique   `thenNF_Tc` \ u2 ->
 660           returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con)
 661                    : (maxtag_PN  tycon, ValName u2 (maxtag_FN  tycon), tycon, GenMaxTag)
 662                    : acc_Names)
 663         else
 664           returnTc acc_Names
 665
 666     we_are_deriving clas_key tycon
 667       = is_in_eqns clas_key tycon eqns
 668       where
 669         is_in_eqns clas_key tycon [] = False
 670         is_in_eqns clas_key tycon ((c,t,_,_):eqns)
 671           =  (clas_key == getClassKey c && tycon == t)
 672           || is_in_eqns clas_key tycon eqns
 673
 674 \end{code}
 675
 676 \begin{code}
 677 derivingEnumErr :: TyCon -> Error
 678 derivingEnumErr tycon
 679   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
 680     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 681
 682 derivingIxErr :: TyCon -> Error
 683 derivingIxErr tycon
 684   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
 685     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 686 -}
 687 \end{code}