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              ( emptyBag{-ToDo:rm-}, 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
 166 tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
 167   = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil))
 168 {- LATER:
 169
 170 tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
 171   =     -- Fish the "deriving"-related information out of the TcEnv
 172         -- and make the necessary "equations".
 173     makeDerivEqns               `thenTc` \ eqns ->
 174
 175         -- Take the equation list and solve it, to deliver a list of
 176         -- solutions, a.k.a. the contexts for the instance decls
 177         -- required for the corresponding equations.
 178     solveDerivEqns inst_decl_infos_in eqns
 179                                 `thenTc` \ new_inst_infos ->
 180
 181         -- Now augment the InstInfos, adding in the rather boring
 182         -- actual-code-to-do-the-methods binds.  We may also need to
 183         -- generate extra not-one-inst-decl-specific binds, notably
 184         -- "con2tag" and/or "tag2con" functions.  We do these
 185         -- separately.
 186
 187     gen_taggery_Names eqns      `thenTc` \ nm_alist_etc ->
 188     let
 189         nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
 190
 191         -- We have the renamer's final "name funs" in our hands
 192         -- (they were passed in).  So we can handle ProtoNames
 193         -- that refer to anything "out there".  But our generated
 194         -- code may also mention "con2tag" (etc.).  So we need
 195         -- to augment to "name funs" to include those.
 196         (rn_val_gnf, rn_tc_gnf) = renamer_name_funs
 197
 198         deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of
 199                                 Just xx -> Just xx
 200                                 Nothing -> rn_val_gnf pname
 201
 202         deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
 203
 204         assoc_maybe [] _ = Nothing
 205         assoc_maybe ((k,v) : vs) key
 206           = if k `eqProtoName` key then Just v else assoc_maybe vs key
 207     in
 208     gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
 209
 210     mapTc (gen_inst_info maybe_mod fixities deriver_name_funs) new_inst_infos
 211                                                   `thenTc` \ really_new_inst_infos ->
 212
 213     returnTc (listToBag really_new_inst_infos,
 214               extra_binds,
 215               ddump_deriving really_new_inst_infos extra_binds)
 216   where
 217     maybe_mod = if opt_CompilingPrelude then Nothing else Just mod_name
 218
 219     ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
 220
 221     ddump_deriving inst_infos extra_binds sty
 222       = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
 223       where
 224         pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
 225           = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
 226                     (ppr sty mbinds)
 227 \end{code}
 228
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \subsection[TcDeriv-eqns]{Forming the equations}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 @makeDerivEqns@ fishes around to find the info about needed derived
 237 instances.  Complicating factors:
 238 \begin{itemize}
 239 \item
 240 We can only derive @Enum@ if the data type is an enumeration
 241 type (all nullary data constructors).
 242
 243 \item
 244 We can only derive @Ix@ if the data type is an enumeration {\em
 245 or} has just one data constructor (e.g., tuples).
 246 \end{itemize}
 247
 248 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
 249 all those.
 250
 251 \begin{code}
 252 makeDerivEqns :: TcM s [DerivEqn]
 253
 254 makeDerivEqns
 255   = tcGetEnv `thenNF_Tc` \ env ->
 256     let
 257         tycons = getEnv_TyCons env
 258         think_about_deriving = need_deriving tycons
 259     in
 260     mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
 261     let
 262         (derive_these, _) = removeDups cmp_deriv think_about_deriving
 263         eqns = map mk_eqn derive_these
 264     in
 265     returnTc eqns
 266   where
 267     ------------------------------------------------------------------
 268     need_deriving :: [TyCon] -> [(Class, TyCon)]
 269         -- find the tycons that have `deriving' clauses
 270
 271     need_deriving tycons_to_consider
 272       = foldr ( \ tycon acc ->
 273                    case (tyConDerivings tycon) of
 274                      [] -> acc
 275                      cs -> [ (clas,tycon) | clas <- cs ] ++ acc
 276               )
 277               []
 278               tycons_to_consider
 279
 280     ------------------------------------------------------------------
 281     chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
 282     chk_out whole_deriving_list this_one@(clas, tycon)
 283       = let
 284             clas_key = getClassKey clas
 285         in
 286
 287             -- Are things OK for deriving Enum (if appropriate)?
 288         checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon))
 289                 (derivingEnumErr tycon)                 `thenTc_`
 290
 291             -- Are things OK for deriving Ix (if appropriate)?
 292         checkTc (clas_key == ixClassKey
 293                  && not (isEnumerationTyCon tycon
 294                          || maybeToBool (maybeTyConSingleCon tycon)))
 295                 (derivingIxErr tycon)
 296
 297     ------------------------------------------------------------------
 298     cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
 299     cmp_deriv (c1, t1) (c2, t2)
 300       = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
 301
 302     ------------------------------------------------------------------
 303     mk_eqn :: (Class, TyCon) -> DerivEqn
 304         -- we swizzle the tyvars and datacons out of the tycon
 305         -- to make the rest of the equation
 306
 307     mk_eqn (clas, tycon)
 308       = (clas, tycon, tyvars, constraints)
 309       where
 310         tyvars    = tyConTyVars tycon   -- ToDo: Do we need new tyvars ???
 311         tyvar_tys = mkTyVarTys tyvars
 312         data_cons = tyConDataCons tycon
 313         constraints = concat (map mk_constraints data_cons)
 314
 315         mk_constraints data_con
 316            = [ (clas, instantiateTy inst_env arg_ty)
 317              | arg_ty <- arg_tys,
 318                not (isPrimType arg_ty)  -- No constraints for primitive types
 319              ]
 320            where
 321              (con_tyvars, _, arg_tys, _) = dataConSig data_con
 322              inst_env = con_tyvars `zipEqual` tyvar_tys
 323                         -- same number of tyvars in data constr and type constr!
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
 333 terms, which is the final correct RHS for the corresponding original
 334 equation.
 335 \begin{itemize}
 336 \item
 337 Each (k,UniTyVarTemplate tv) in a solution constrains only a type
 338 variable, tv.
 339
 340 \item
 341 The (k,UniTyVarTemplate tv) pairs in a solution are canonically
 342 ordered by sorting on type varible, tv, (major key) and then class, k,
 343 (minor key)
 344 \end{itemize}
 345
 346 \begin{code}
 347 solveDerivEqns :: Bag InstInfo
 348                -> [DerivEqn]
 349                -> TcM s [InstInfo]      -- Solns in same order as eqns.
 350                                         -- This bunch is Absolutely minimal...
 351
 352 solveDerivEqns inst_decl_infos_in orig_eqns
 353   = iterateDeriv initial_solutions
 354   where
 355         -- The initial solutions for the equations claim that each
 356         -- instance has an empty context; this solution is certainly
 357         -- in canonical form.
 358     initial_solutions :: [DerivSoln]
 359     initial_solutions = [ [] | _ <- orig_eqns ]
 360
 361         -- iterateDeriv calculates the next batch of solutions,
 362         -- compares it with the current one; finishes if they are the
 363         -- same, otherwise recurses with the new solutions.
 364
 365     iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
 366
 367     iterateDeriv current_solns
 368       =     -- Extend the inst info from the explicit instance decls
 369             -- with the current set of solutions, giving a
 370
 371         add_solns inst_decl_infos_in orig_eqns current_solns
 372                                 `thenTc` \ (new_inst_infos, inst_mapper) ->
 373
 374             -- Simplify each RHS, using a DerivingOrigin containing an
 375             -- inst_mapper reflecting the previous solution
 376         let
 377             mk_deriv_origin clas ty
 378               = DerivingOrigin inst_mapper clas tycon
 379               where
 380                 (tycon,_) = getAppTyCon ty
 381         in
 382         listTc [ tcSimplifyThetas mk_deriv_origin rhs
 383                | (_, _, _, rhs) <- orig_eqns
 384                ]                `thenTc` \ next_solns ->
 385
 386             -- Canonicalise the solutions, so they compare nicely
 387         let canonicalised_next_solns
 388               = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
 389
 390         if current_solns `eq_solns` canonicalised_next_solns then
 391             returnTc new_inst_infos
 392         else
 393             iterateDeriv canonicalised_next_solns
 394
 395       where
 396         ------------------------------------------------------------------
 397         lt_rhs    r1 r2 = case cmp_rhs   r1 r2 of { LT_ -> True; _ -> False }
 398         eq_solns  s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
 399         cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
 400         cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
 401           = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
 402 #ifdef DEBUG
 403         cmp_rhs other_1 other_2
 404           = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
 405 #endif
 406
 407 \end{code}
 408
 409 \begin{code}
 410 add_solns :: FAST_STRING
 411           -> Bag InstInfo                       -- The global, non-derived ones
 412           -> [DerivEqn] -> [DerivSoln]
 413           -> TcM s ([InstInfo],                 -- The new, derived ones
 414                     InstanceMapper)
 415     -- the eqns and solns move "in lockstep"; we have the eqns
 416     -- because we need the LHS info for addClassInstance.
 417
 418 add_solns inst_infos_in eqns solns
 419   = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
 420     returnTc (new_inst_infos, inst_mapper)
 421   where
 422     new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns
 423
 424     all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
 425
 426     mk_deriv_inst_info (clas, tycon, tyvars, _) theta
 427       = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
 428                  theta
 429                  theta                  -- Blarg.  This is the dfun_theta slot,
 430                                         -- which is needed by buildInstanceEnv;
 431                                         -- This works ok for solving the eqns, and
 432                                         -- gen_eqns sets it to its final value
 433                                         -- (incl super class dicts) before we
 434                                         -- finally return it.
 435 #ifdef DEBUG
 436                  (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
 437                  (panic "add_soln:binds")   (panic "add_soln:from_here")
 438                  (panic "add_soln:modname") mkGeneratedSrcLoc
 439                  (panic "add_soln:upragmas")
 440 #else
 441                 bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
 442       where
 443         bottom = panic "add_soln"
 444 #endif
 445 \end{code}
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 After all the trouble to figure out the required context for the
 454 derived instance declarations, all that's left is to chug along to
 455 produce them.  They will then be shoved into @tcInstDecls2@, which
 456 will do all its usual business.
 457
 458 There are lots of possibilities for code to generate.  Here are
 459 various general remarks.
 460
 461 PRINCIPLES:
 462 \begin{itemize}
 463 \item
 464 We want derived instances of @Eq@ and @Ord@ (both v common) to be
 465 ``you-couldn't-do-better-by-hand'' efficient.
 466
 467 \item
 468 Deriving @Text@---also pretty common, usually just for
 469 @show@---should also be reasonable good code.
 470
 471 \item
 472 Deriving for the other classes isn't that common or that big a deal.
 473 \end{itemize}
 474
 475 PRAGMATICS:
 476
 477 \begin{itemize}
 478 \item
 479 Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method.
 480
 481 \item
 482 Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too.
 483
 484 \item
 485 We {\em normally} generated code only for the non-defaulted methods;
 486 there are some exceptions for @Eq@ and (especially) @Ord@...
 487
 488 \item
 489 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
 490 constructor's numeric (@Int#@) tag.  These are generated by
 491 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
 492 these is around is given by @hasCon2TagFun@.
 493
 494
 495 The examples under the different sections below will make this
 496 clearer.
 497
 498 \item
 499 Much less often (really just for deriving @Ix@), we use a
 500 @_tag2con_<tycon>@ function.  See the examples.
 501
 502 \item
 503 We use Pass~4 of the renamer!!!  Reason: we're supposed to be
 504 producing @RenamedMonoBinds@ for the methods, but that means
 505 producing correctly-uniquified code on the fly.  This is entirely
 506 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
 507 So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through
 508 the renamer.  What a great hack!
 509 \end{itemize}
 510
 511 \begin{code}
 512 gen_inst_info :: Maybe Module           -- Module name; Nothing => Prelude
 513               -> [RenamedFixityDecl]    -- all known fixities;
 514                                         -- may be needed for Text
 515               -> GlobalNameMappers              -- lookup stuff for names we may use
 516               -> InstInfo               -- the main stuff to work on
 517               -> TcM s InstInfo         -- the gen'd (filled-in) "instance decl"
 518
 519 gen_inst_info modname fixities deriver_name_funs
 520     info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
 521   =
 522         -- Generate the various instance-related Ids
 523     mkInstanceRelatedIds
 524                 True {-from_here-} modname
 525                 NoInstancePragmas
 526                 clas tyvars ty
 527                 inst_decl_theta
 528                 [{-no user pragmas-}]
 529                         `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 530
 531         -- Generate the bindings for the new instance declaration,
 532         -- rename it, and check for errors
 533     let
 534         (tycon,_,_)  = getAppDataTyCon ty
 535
 536         proto_mbinds
 537           | clas_key == eqClassKey     = gen_Eq_binds tycon
 538           | clas_key == showClassKey   = gen_Show_binds fixities tycon
 539           | clas_key == ordClassKey    = gen_Ord_binds tycon
 540           | clas_key == enumClassKey   = gen_Enum_binds tycon
 541           | clas_key == ixClassKey     = gen_Ix_binds tycon
 542           | clas_key == readClassKey   = gen_Read_binds fixities tycon
 543           | clas_key == binaryClassKey = gen_Binary_binds tycon
 544           | otherwise = panic "gen_inst_info:bad derived class"
 545     in
 546     rn4MtoTcM deriver_name_funs (
 547         rnMethodBinds clas_Name proto_mbinds
 548     )                   `thenNF_Tc` \ (mbinds, errs) ->
 549
 550     if not (isEmptyBag errs) then
 551         pprPanic "gen_inst_info:renamer errs!\n"
 552                  (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
 553     else
 554     --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
 555
 556         -- All done
 557     let
 558         from_here = isLocallyDefined tycon      -- If so, then from here
 559     in
 560     returnTc (InstInfo clas tyvars ty inst_decl_theta
 561                        dfun_theta dfun_id const_meth_ids
 562                        (if from_here then mbinds else EmptyMonoBinds)
 563                        from_here modname locn [])
 564   where
 565     clas_key = getClassKey clas
 566     clas_Name
 567       = let  (mod, nm) = moduleNamePair clas  in
 568         ClassName clas_key (mkPreludeCoreName mod nm) []
 569 \end{code}
 570
 571 %************************************************************************
 572 %*                                                                      *
 573 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 data Foo ... = ...
 578
 579 con2tag_Foo :: Foo ... -> Int#
 580 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 581 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 582
 583 \begin{code}
 584 gen_tag_n_con_binds :: GlobalNameMappers
 585                     -> [(RdrName, RnName, TyCon, TagThingWanted)]
 586                     -> TcM s RenamedHsBinds
 587
 588 gen_tag_n_con_binds deriver_name_funs nm_alist_etc
 589   = let
 590       proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
 591       proto_mbinds     = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
 592     in
 593
 594     rn4MtoTcM deriver_name_funs (
 595         rnTopBinds (SingleBind (RecBind proto_mbinds))
 596     )                   `thenNF_Tc` \ (binds, errs) ->
 597
 598     if not (isEmptyBag errs) then
 599         panic "gen_inst_info:renamer errs (2)!"
 600     else
 601         returnTc binds
 602 \end{code}
 603
 604 %************************************************************************
 605 %*                                                                      *
 606 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
 607 %*                                                                      *
 608 %************************************************************************
 609
 610 We have a @con2tag@ function for a tycon if:
 611 \begin{itemize}
 612 \item
 613 We're deriving @Eq@ and the tycon has nullary data constructors.
 614
 615 \item
 616 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
 617 (enum type only????)
 618 \end{itemize}
 619
 620 We have a @tag2con@ function for a tycon if:
 621 \begin{itemize}
 622 \item
 623 We're deriving @Enum@, or @Ix@ (enum type only???)
 624 \end{itemize}
 625
 626 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
 627
 628 \begin{code}
 629 gen_taggery_Names :: [DerivEqn]
 630                   -> TcM s [(RdrName, RnName,   -- for an assoc list
 631                              TyCon,             -- related tycon
 632                              TagThingWanted)]
 633
 634 gen_taggery_Names eqns
 635   = let
 636         all_tycons = [ tc | (_, tc, _, _) <- eqns ]
 637         (tycons_of_interest, _) = removeDups cmp all_tycons
 638     in
 639         foldlTc do_con2tag []           tycons_of_interest `thenTc` \ names_so_far ->
 640         foldlTc do_tag2con names_so_far tycons_of_interest
 641   where
 642     do_con2tag acc_Names tycon
 643       = if (we_are_deriving eqClassKey tycon
 644             && any ( (== 0).dataConArity ) (tyConDataCons tycon))
 645         || (we_are_deriving ordClassKey  tycon
 646             && not (maybeToBool (maybeTyConSingleCon tycon)))
 647         || (we_are_deriving enumClassKey tycon)
 648         || (we_are_deriving ixClassKey   tycon)
 649         then
 650           tcGetUnique   `thenNF_Tc` ( \ u ->
 651           returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
 652                    : acc_Names) )
 653         else
 654           returnTc acc_Names
 655
 656     do_tag2con acc_Names tycon
 657       = if (we_are_deriving enumClassKey tycon)
 658         || (we_are_deriving ixClassKey   tycon)
 659         then
 660           tcGetUnique   `thenNF_Tc` \ u1 ->
 661           tcGetUnique   `thenNF_Tc` \ u2 ->
 662           returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con)
 663                    : (maxtag_PN  tycon, ValName u2 (maxtag_FN  tycon), tycon, GenMaxTag)
 664                    : acc_Names)
 665         else
 666           returnTc acc_Names
 667
 668     we_are_deriving clas_key tycon
 669       = is_in_eqns clas_key tycon eqns
 670       where
 671         is_in_eqns clas_key tycon [] = False
 672         is_in_eqns clas_key tycon ((c,t,_,_):eqns)
 673           =  (clas_key == getClassKey c && tycon == t)
 674           || is_in_eqns clas_key tycon eqns
 675
 676 \end{code}
 677
 678 \begin{code}
 679 derivingEnumErr :: TyCon -> Error
 680 derivingEnumErr tycon
 681   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
 682     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 683
 684 derivingIxErr :: TyCon -> Error
 685 derivingIxErr tycon
 686   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
 687     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 688 -}
 689 \end{code}