ghc/compiler/typecheck/TcDeriv.lhs

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