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 ********** Don't forget
   9
  10 Multi-instance checking in renamer should include deriving.
  11
  12 \begin{code}
  13 #include "HsVersions.h"
  14
  15 module TcDeriv (
  16         tcDeriving,
  17         con2tag_PN, tag2con_PN, maxtag_PN,
  18         TagThingWanted(..), DerivEqn(..)
  19     ) where
  20
  21 IMPORT_Trace            -- ToDo:rm debugging
  22 import Outputable
  23 import Pretty
  24
  25 import TcMonad          -- typechecking monad machinery
  26 import TcMonadFns       ( copyTyVars )
  27 import AbsSyn           -- the stuff being typechecked
  28 import TcGenDeriv       -- support code that generates all the grimy bindings
  29                         -- for derived instance decls.
  30
  31 import AbsPrel          ( mkFunTy )
  32 import AbsUniType
  33 import UniType          ( UniType(..) ) -- *********** CHEATING!!! ****************
  34 import Bag
  35 import CE               ( CE(..) )
  36 import CmdLineOpts      ( GlobalSwitch(..) )
  37 import E                ( E )
  38 import Errors
  39 import HsCore           -- ****** NEED TO SEE CONSTRUCTORS ******
  40 import HsPragmas        -- InstancePragmas(..)
  41 import Id               ( getDataConSig, isNullaryDataCon, DataCon(..) )
  42 import IdInfo
  43 import Inst             ( InstOrigin(..) )
  44 import InstEnv
  45 import Maybes           ( assocMaybe, maybeToBool, Maybe(..) )
  46 import NameTypes        ( mkFullName, mkPreludeCoreName,
  47                           Provenance(..), FullName, ShortName
  48                         )
  49 import ProtoName        ( eqProtoName, ProtoName(..), Name )
  50 import RenameAuxFuns    -- why not? take all of it...
  51 import RenameBinds4     ( rnMethodBinds4, rnTopBinds4 )
  52 import RenameMonad4     -- initRn4, etc.
  53 import SrcLoc           ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
  54 import TCE              -- ( rngTCE, TCE(..), UniqFM )
  55 import TcInstDcls       ( InstInfo(..), buildInstanceEnvs, mkInstanceRelatedIds )
  56 import TcSimplify       ( tcSimplifyThetas )
  57 import Unique           -- *Key stuff
  58 import Util
  59 \end{code}
  60
  61 %************************************************************************
  62 %*                                                                      *
  63 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 Consider
  68
  69         data T a b = C1 (Foo a) (Bar b)
  70                    | C2 Int (T b a)
  71                    | C3 (T a a)
  72                    deriving (Eq)
  73
  74 We want to come up with an instance declaration of the form
  75
  76         instance (Ping a, Pong b, ...) => Eq (T a b) where
  77                 x == y = ...
  78
  79 It is pretty easy, albeit tedious, to fill in the code "...".  The
  80 trick is to figure out what the context for the instance decl is,
  81 namely @Ping@, @Pong@ and friends.
  82
  83 Let's call the context reqd for the T instance of class C at types
  84 (a,b, ...)  C (T a b).  Thus:
  85
  86         Eq (T a b) = (Ping a, Pong b, ...)
  87
  88 Now we can get a (recursive) equation from the @data@ decl:
  89
  90         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
  91                    u Eq (T b a) u Eq Int        -- From C2
  92                    u Eq (T a a)                 -- From C3
  93
  94 Foo and Bar may have explicit instances for @Eq@, in which case we can
  95 just substitute for them.  Alternatively, either or both may have
  96 their @Eq@ instances given by @deriving@ clauses, in which case they
  97 form part of the system of equations.
  98
  99 Now all we need do is simplify and solve the equations, iterating to
 100 find the least fixpoint.  Notice that the order of the arguments can
 101 switch around, as here in the recursive calls to T.
 102
 103 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
 104
 105 We start with:
 106
 107         Eq (T a b) = {}         -- The empty set
 108
 109 Next iteration:
 110         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 111                    u Eq (T b a) u Eq Int        -- From C2
 112                    u Eq (T a a)                 -- From C3
 113
 114         After simplification:
 115                    = Eq a u Ping b u {} u {} u {}
 116                    = Eq a u Ping b
 117
 118 Next iteration:
 119
 120         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 121                    u Eq (T b a) u Eq Int        -- From C2
 122                    u Eq (T a a)                 -- From C3
 123
 124         After simplification:
 125                    = Eq a u Ping b
 126                    u (Eq b u Ping a)
 127                    u (Eq a u Ping a)
 128
 129                    = Eq a u Ping b u Eq b u Ping a
 130
 131 The next iteration gives the same result, so this is the fixpoint.  We
 132 need to make a canonical form of the RHS to ensure convergence.  We do
 133 this by simplifying the RHS to a form in which
 134
 135         - the classes constrain only tyvars
 136         - the list is sorted by tyvar (major key) and then class (minor key)
 137         - no duplicates, of course
 138
 139 So, here are the synonyms for the ``equation'' structures:
 140
 141 \begin{code}
 142 type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
 143                          -- The tyvars bind all the variables in the RHS
 144                          -- NEW: it's convenient to re-use InstInfo
 145                          -- We'll "panic" out some fields...
 146
 147 type DerivRhs = [(Class, TauType)]      -- Same as a ThetaType!
 148
 149 type DerivSoln = DerivRhs
 150 \end{code}
 151
 152 %************************************************************************
 153 %*                                                                      *
 154 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
 155 %*                                                                      *
 156 %************************************************************************
 157
 158 \begin{code}
 159 tcDeriving  :: FAST_STRING              -- name of module under scrutiny
 160             -> GlobalNameFuns           -- for "renaming" bits of generated code
 161             -> Bag InstInfo             -- What we already know about instances
 162             -> TCE                      -- All known TyCon info
 163             -> [RenamedFixityDecl]      -- Fixity info; may be used for Text
 164             -> TcM (Bag InstInfo,       -- The generated "instance decls".
 165                     RenamedBinds,       -- Extra generated bindings
 166                     PprStyle -> Pretty) -- Printable derived instance decls;
 167                                         -- for debugging via -ddump-derivings.
 168
 169 tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities
 170   =     -- Fish the "deriving"-related information out of the TCE,
 171         -- from which we make the necessary "equations".
 172     makeDerivEqns tce       `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 modname 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 ((v,xxx) : vs) key
 205            = if v `eqProtoName` key then Just xxx 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 modname 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     ddump_deriving :: [InstInfo] -> RenamedBinds -> (PprStyle -> Pretty)
 217
 218     ddump_deriving inst_infos extra_binds sty
 219       = ppAboves ((map (pp_1 sty) inst_infos) ++ [ppr sty extra_binds])
 220       where
 221         pp_1 sty (InstInfo clas tv_tmpls ty inst_decl_theta _ _ _ mbinds _ _ _ _)
 222           = ppAbove (ppr sty (mkSigmaTy tv_tmpls inst_decl_theta
 223                                   (UniDict 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 :: TCE -> TcM [DerivEqn]
 251
 252 makeDerivEqns tce
 253   = let
 254         think_about_deriving = need_deriving (rngTCE tce)
 255     in
 256     mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
 257
 258     let
 259         (derive_these, _) = removeDups cmp think_about_deriving
 260     in
 261
 262     listNF_Tc (map mk_eqn derive_these)         `thenNF_Tc` \ eqns ->
 263
 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 (getTyConDerivings tycon) of
 273                      [] -> acc
 274                      cs -> [ (clas,tycon) | clas <- cs ] ++ acc
 275               )
 276               []                -- init accumulator
 277               tycons_to_consider
 278
 279     ------------------------------------------------------------------
 280     chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM ()
 281
 282     chk_out whole_deriving_list this_one@(clas, tycon)
 283       =     -- Are the relevant superclasses catered for?
 284             -- E.g., for "... deriving Ord", is there an
 285             -- instance of "Eq"?
 286         let
 287             (_, super_classes, _) = getClassSig clas
 288             clas_key = getClassKey clas
 289         in
 290
 291             -- Are things OK for deriving Enum (if appropriate)?
 292         checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon))
 293                 (derivingEnumErr tycon)                 `thenTc_`
 294
 295             -- Are things OK for deriving Ix (if appropriate)?
 296         checkTc (clas_key == ixClassKey
 297              && not (isEnumerationTyCon tycon
 298                   || maybeToBool (maybeSingleConstructorTyCon tycon)))
 299                 (derivingIxErr tycon)
 300
 301     ------------------------------------------------------------------
 302     cmp :: (Class, TyCon) -> (Class, TyCon) -> TAG_
 303
 304     cmp (c1, t1) (c2, t2)
 305       = case cmpClass c1 c2 of
 306           EQ_   -> cmpTyCon t1 t2
 307           other -> other
 308
 309     ------------------------------------------------------------------
 310     mk_eqn :: (Class, TyCon) -> NF_TcM DerivEqn
 311         -- we swizzle the tyvars, data cons, etc., out of the tycon,
 312         -- to make the rest of the equation
 313
 314     mk_eqn (clas, tycon)
 315       = let
 316             tyvar_tmpls  = getTyConTyVarTemplates tycon
 317             data_cons    = getTyConDataCons tycon
 318         in
 319         copyTyVars tyvar_tmpls  `thenNF_Tc` \ (_, tyvars, tyvar_tys) ->
 320
 321         let
 322             constraints = concat [mk_constraints tyvar_tys con | con <- data_cons]
 323         in
 324         returnNF_Tc (clas, tycon, tyvars, constraints)
 325       where
 326         mk_constraints tyvar_tys data_con
 327            = [ (clas, instantiateTy inst_env arg_ty)
 328              | arg_ty <- arg_tys,
 329                not (isPrimType arg_ty)  -- No constraints for primitive types
 330              ]
 331            where
 332              (con_tyvar_tmpls, _, arg_tys, _) = getDataConSig data_con
 333              inst_env = con_tyvar_tmpls `zipEqual` tyvar_tys
 334                         -- Type vars in data contructor should be same in number
 335                         -- as in the type contsructor!
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 A ``solution'' (to one of the equations) is a list of (k,UniTyVar tv)
 345 terms, which is the final correct RHS for the corresponding original
 346 equation.
 347 \begin{itemize}
 348 \item
 349 Each (k,UniTyVarTemplate tv) in a solution constrains only a type
 350 variable, tv.
 351
 352 \item
 353 The (k,UniTyVarTemplate tv) pairs in a solution are canonically
 354 ordered by sorting on type varible, tv, (major key) and then class, k,
 355 (minor key)
 356 \end{itemize}
 357
 358 \begin{code}
 359 solveDerivEqns :: FAST_STRING
 360                -> Bag InstInfo
 361                -> [DerivEqn]
 362                -> TcM [InstInfo]        -- Solns in same order as eqns.
 363                                         -- This bunch is Absolutely minimal...
 364
 365 solveDerivEqns modname inst_decl_infos_in orig_eqns
 366   = iterateDeriv initial_solutions
 367   where
 368         -- The initial solutions for the equations claim that each
 369         -- instance has an empty context; this solution is certainly
 370         -- in canonical form.
 371     initial_solutions :: [DerivSoln]
 372     initial_solutions = [ [] | _ <- orig_eqns ]
 373
 374         -- iterateDeriv calculates the next batch of solutions,
 375         -- compares it with the current one; finishes if they are the
 376         -- same, otherwise recurses with the new solutions.
 377
 378     iterateDeriv :: [DerivSoln] ->TcM [InstInfo]
 379
 380     iterateDeriv current_solns
 381       =     -- Extend the inst info from the explicit instance decls
 382             -- with the current set of solutions, giving a
 383
 384         add_solns modname inst_decl_infos_in orig_eqns current_solns
 385                                 `thenTc` \ (new_inst_infos, inst_mapper) ->
 386
 387             -- Simplify each RHS, using a DerivingOrigin containing an
 388             -- inst_mapper reflecting the previous solution
 389         let
 390             mk_deriv_origin clas ty
 391               = DerivingOrigin inst_mapper clas is_fun_type tycon locn
 392               where
 393                 is_fun_type = isFunType ty
 394                 (tycon,_,_) = getUniDataTyCon ty
 395                 locn = if is_fun_type then mkUnknownSrcLoc{-sigh-} else getSrcLoc tycon
 396         in
 397         listTc [ tcSimplifyThetas mk_deriv_origin rhs
 398                | (_, _, _, rhs) <- orig_eqns
 399                ]                `thenTc` \ next_solns ->
 400
 401             -- Canonicalise the solutions, so they compare nicely
 402         let canonicalised_next_solns
 403               = [ sortLt less_than next_soln | next_soln <- next_solns ] in
 404
 405         if current_solns == canonicalised_next_solns then
 406           returnTc new_inst_infos
 407         else
 408           iterateDeriv canonicalised_next_solns
 409
 410       where
 411         ------------------------------------------------------------------
 412         less_than :: (Class, TauType) -> (Class, TauType) -> Bool
 413
 414         less_than (clas1, UniTyVar tv1) (clas2, UniTyVar tv2)
 415           = tv1 < tv2 || (tv1 == tv2 && clas1 < clas2)
 416 #ifdef DEBUG
 417         less_than other_1 other_2
 418           = pprPanic "tcDeriv:less_than:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
 419 #endif
 420 \end{code}
 421
 422 \begin{code}
 423 add_solns :: FAST_STRING
 424           -> Bag InstInfo                       -- The global, non-derived ones
 425           -> [DerivEqn] -> [DerivSoln]
 426           -> TcM ([InstInfo],                   -- The new, derived ones
 427                   InstanceMapper)
 428     -- the eqns and solns move "in lockstep"; we have the eqns
 429     -- because we need the LHS info for addClassInstance.
 430
 431 add_solns modname inst_infos_in eqns solns
 432   = listTc (zipWith mk_deriv_inst_info eqns solns) `thenTc` \ new_inst_infos ->
 433
 434     buildInstanceEnvs (inst_infos_in `unionBags`
 435                        listToBag new_inst_infos) `thenTc` \ inst_mapper ->
 436
 437     returnTc (new_inst_infos, inst_mapper)
 438   where
 439     mk_deriv_inst_info (clas, tycon, tyvars, _) theta
 440         -- The complication here is rather boring: InstInfos need TyVarTemplates,
 441         -- and we have only TyVars in our hand.
 442       = let
 443             tyvar_tmpls         = mkTemplateTyVars tyvars
 444             tv_tmpl_tys         = map mkTyVarTemplateTy tyvar_tmpls
 445
 446             env                 = tyvars `zipEqual` tv_tmpl_tys
 447
 448             tycon_tmpl_ty       = applyTyCon tycon tv_tmpl_tys
 449             theta_tmpl          = [(clas, mapOverTyVars to_tmpl ty) | (clas,ty) <- theta]
 450
 451             to_tmpl = assoc "mk_deriv_inst_info" env
 452
 453             (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
 454         in
 455         returnTc (
 456           InstInfo clas tyvar_tmpls tycon_tmpl_ty
 457                 theta_tmpl
 458                 theta_tmpl              -- Blarg.  This is the dfun_theta slot,
 459                                         -- which is needed by buildInstanceEnv;
 460                                         -- This works ok for solving the eqns, and
 461                                         -- gen_eqns sets it to its final value
 462                                         -- (incl super class dicts) before we
 463                                         -- finally return it.
 464 #ifndef DEBUG
 465                 (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
 466                 (panic "add_soln:binds")   (panic "add_soln:from_here")
 467                 (panic "add_soln:modname") mkGeneratedSrcLoc
 468                 (panic "add_soln:upragmas")
 469         )
 470 #else
 471                 bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
 472         )
 473       where
 474         bottom = panic "add_soln"
 475 #endif
 476 \end{code}
 477
 478 %************************************************************************
 479 %*                                                                      *
 480 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
 481 %*                                                                      *
 482 %************************************************************************
 483
 484 After all the trouble to figure out the required context for the
 485 derived instance declarations, all that's left is to chug along to
 486 produce them.  They will then be shoved into @tcInstDecls2@, which
 487 will do all its usual business.
 488
 489 There are lots of possibilities for code to generate.  Here are
 490 various general remarks.
 491
 492 PRINCIPLES:
 493 \begin{itemize}
 494 \item
 495 We want derived instances of @Eq@ and @Ord@ (both v common) to be
 496 ``you-couldn't-do-better-by-hand'' efficient.
 497
 498 \item
 499 Deriving @Text@---also pretty common, usually just for
 500 @show@---should also be reasonable good code.
 501
 502 \item
 503 Deriving for the other classes isn't that common or that big a deal.
 504 \end{itemize}
 505
 506 PRAGMATICS:
 507
 508 \begin{itemize}
 509 \item
 510 Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method.
 511
 512 \item
 513 Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too.
 514
 515 \item
 516 We {\em normally} generated code only for the non-defaulted methods;
 517 there are some exceptions for @Eq@ and (especially) @Ord@...
 518
 519 \item
 520 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
 521 constructor's numeric (@Int#@) tag.  These are generated by
 522 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
 523 these is around is given by @hasCon2TagFun@.
 524
 525
 526 The examples under the different sections below will make this
 527 clearer.
 528
 529 \item
 530 Much less often (really just for deriving @Ix@), we use a
 531 @_tag2con_<tycon>@ function.  See the examples.
 532
 533 \item
 534 We use Pass~4 of the renamer!!!  Reason: we're supposed to be
 535 producing @RenamedMonoBinds@ for the methods, but that means
 536 producing correctly-uniquified code on the fly.  This is entirely
 537 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
 538 So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through
 539 the renamer.  What a great hack!
 540 \end{itemize}
 541
 542 \begin{code}
 543 gen_inst_info :: FAST_STRING            -- Module name
 544               -> [RenamedFixityDecl]    -- all known fixities;
 545                                         -- may be needed for Text
 546               -> GlobalNameFuns         -- lookup stuff for names we may use
 547               -> InstInfo               -- the main stuff to work on
 548               -> TcM InstInfo           -- the gen'd (filled-in) "instance decl"
 549
 550 gen_inst_info modname fixities deriver_name_funs
 551     info@(InstInfo clas tyvar_tmpls ty inst_decl_theta _ _ _ _ _ _ locn _)
 552   =
 553         -- Generate the various instance-related Ids
 554     mkInstanceRelatedIds
 555                 (panic "add_solns:E")
 556                         -- These two are only needed if there are pragmas to typecheck;
 557                         -- but there ain't since we are generating the code right here.
 558                 True {-yes, from_here-}
 559                 NoInstancePragmas
 560                 mkGeneratedSrcLoc
 561                 clas
 562                 tyvar_tmpls ty
 563                 inst_decl_theta
 564                 [{-no user pragmas-}]
 565                         `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 566
 567         -- Generate the bindings for the new instance declaration,
 568         -- rename it, and check for errors
 569     getSwitchCheckerTc  `thenNF_Tc` \ sw_chkr ->
 570     let
 571         (tycon,_,_)  = getUniDataTyCon ty
 572
 573         omit_readsPrec = sw_chkr OmitDerivedRead
 574
 575         proto_mbinds
 576           = if      clas_key == textClassKey    then gen_Text_binds fixities omit_readsPrec tycon
 577             else if clas_key == eqClassKey      then gen_Eq_binds tycon
 578             else if clas_key == ordClassKey     then gen_Ord_binds tycon
 579             else if clas_key == enumClassKey    then gen_Enum_binds tycon
 580             else if clas_key == ixClassKey      then gen_Ix_binds tycon
 581             else if clas_key == binaryClassKey  then gen_Binary_binds tycon
 582             else panic "gen_inst_info:bad derived class"
 583     in
 584     rn4MtoTcM deriver_name_funs (
 585         rnMethodBinds4 clas_Name proto_mbinds
 586     )                   `thenNF_Tc` \ (mbinds, errs) ->
 587
 588     if not (isEmptyBag errs) then
 589         pprPanic "gen_inst_info:renamer errs!\n" (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
 590     else
 591 --  pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
 592
 593         -- All done
 594     let
 595         from_here = isLocallyDefined tycon      -- If so, then from here
 596     in
 597     returnTc (InstInfo clas tyvar_tmpls ty
 598                        inst_decl_theta dfun_theta dfun_id const_meth_ids
 599                        -- and here comes the main point...
 600                        (if from_here then mbinds else EmptyMonoBinds)
 601                        from_here modname locn [])
 602   where
 603     clas_key = getClassKey clas
 604     clas_Name
 605       = let  (mod, nm) = getOrigName clas  in
 606         PreludeClass clas_key (mkPreludeCoreName mod nm)
 607 \end{code}
 608
 609 %************************************************************************
 610 %*                                                                      *
 611 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
 612 %*                                                                      *
 613 %************************************************************************
 614
 615 data Foo ... = ...
 616
 617 con2tag_Foo :: Foo ... -> Int#
 618 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 619 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 620
 621 \begin{code}
 622 gen_tag_n_con_binds :: GlobalNameFuns
 623                     -> [(ProtoName, Name, TyCon, TagThingWanted)]
 624                     -> TcM RenamedBinds
 625
 626 gen_tag_n_con_binds deriver_name_funs nm_alist_etc
 627   = let
 628       proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
 629       proto_mbinds     = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
 630     in
 631
 632     rn4MtoTcM deriver_name_funs (
 633         rnTopBinds4 (SingleBind (RecBind proto_mbinds))
 634     )                   `thenNF_Tc` \ (binds, errs) ->
 635
 636     if not (isEmptyBag errs) then
 637         panic "gen_inst_info:renamer errs (2)!"
 638     else
 639         returnTc binds
 640 \end{code}
 641
 642 %************************************************************************
 643 %*                                                                      *
 644 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
 645 %*                                                                      *
 646 %************************************************************************
 647
 648 We have a @con2tag@ function for a tycon if:
 649 \begin{itemize}
 650 \item
 651 We're deriving @Eq@ and the tycon has nullary data constructors.
 652
 653 \item
 654 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
 655 (enum type only????)
 656 \end{itemize}
 657
 658 We have a @tag2con@ function for a tycon if:
 659 \begin{itemize}
 660 \item
 661 We're deriving @Enum@, or @Ix@ (enum type only???)
 662 \end{itemize}
 663
 664 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
 665
 666 \begin{code}
 667 data TagThingWanted
 668   = GenCon2Tag | GenTag2Con | GenMaxTag
 669
 670 gen_taggery_Names :: [DerivEqn]
 671                   -> TcM [(ProtoName, Name,     -- for an assoc list
 672                            TyCon,               -- related tycon
 673                            TagThingWanted)]
 674
 675 gen_taggery_Names eqns
 676   = let all_tycons = [ tc | (_, tc, _, _) <- eqns ]
 677         (tycons_of_interest, _) = removeDups cmpTyCon all_tycons
 678     in
 679         foldlTc do_con2tag []           tycons_of_interest `thenTc` \ names_so_far ->
 680         foldlTc do_tag2con names_so_far tycons_of_interest
 681   where
 682     do_con2tag acc_Names tycon
 683       = if (we_are_deriving eqClassKey tycon
 684             && any isNullaryDataCon (getTyConDataCons tycon))
 685         || (we_are_deriving ordClassKey  tycon
 686             && not (maybeToBool (maybeSingleConstructorTyCon tycon)))
 687         || (we_are_deriving enumClassKey tycon)
 688         || (we_are_deriving ixClassKey   tycon)
 689         then
 690           getUniqueTc   `thenNF_Tc` ( \ u ->
 691           returnTc ((con2tag_PN tycon, OtherTopId u (con2tag_FN tycon), tycon, GenCon2Tag)
 692                    : acc_Names) )
 693         else
 694           returnTc acc_Names
 695
 696     do_tag2con acc_Names tycon
 697       = if (we_are_deriving enumClassKey tycon)
 698         || (we_are_deriving ixClassKey   tycon)
 699         then
 700           getUniqueTc   `thenNF_Tc` \ u1 ->
 701           getUniqueTc   `thenNF_Tc` \ u2 ->
 702           returnTc ( (tag2con_PN tycon, OtherTopId u1 (tag2con_FN tycon), tycon, GenTag2Con)
 703                    : (maxtag_PN  tycon, OtherTopId u2 (maxtag_FN  tycon), tycon, GenMaxTag)
 704                    : acc_Names)
 705         else
 706           returnTc acc_Names
 707
 708     we_are_deriving clas_key tycon
 709       = is_in_eqns clas_key tycon eqns
 710       where
 711         is_in_eqns clas_key tycon [] = False
 712         is_in_eqns clas_key tycon ((c,t,_,_):eqns) -- ToDo: InstInfo
 713           =  (clas_key == getClassKey c && tycon == t)
 714           || is_in_eqns clas_key tycon eqns
 715
 716 con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName
 717 con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName
 718
 719 con2tag_PN tycon
 720   = let (mod, nm) = getOrigName tycon
 721         con2tag   = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
 722     in
 723     Imp mod con2tag [mod] con2tag
 724
 725 con2tag_FN tycon
 726   = let (mod, nm) = getOrigName tycon
 727         con2tag   = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
 728     in
 729     mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc
 730
 731 tag2con_PN tycon
 732   = let (mod, nm) = getOrigName tycon
 733         tag2con   = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
 734     in
 735     Imp mod tag2con [mod] tag2con
 736
 737 tag2con_FN tycon
 738   = let (mod, nm) = getOrigName tycon
 739         tag2con   = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
 740     in
 741     mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
 742
 743 maxtag_PN tycon
 744   = let (mod, nm) = getOrigName tycon
 745         maxtag    = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
 746     in
 747     Imp mod maxtag [mod] maxtag
 748
 749 maxtag_FN tycon
 750   = let (mod, nm) = getOrigName tycon
 751         maxtag    = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
 752     in
 753     mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
 754 \end{code}