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