ghc/compiler/typecheck/TcDeriv.lhs

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