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