2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcDeriv]{Deriving}
6 Handles @deriving@ clauses on @data@ declarations.
9 #include "HsVersions.h"
11 module TcDeriv ( tcDeriving ) where
15 import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
16 GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
17 ArithSeqInfo, Fake, MonoType )
18 import HsPragmas ( InstancePragmas(..) )
19 import RnHsSyn ( mkRnName, RnName(..), RenamedHsBinds(..), RenamedFixityDecl(..) )
20 import TcHsSyn ( TcIdOcc )
23 import Inst ( InstanceMapper(..) )
24 import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
25 import TcKind ( TcKind )
26 import TcGenDeriv -- Deriv stuff
27 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
28 import TcSimplify ( tcSimplifyThetas )
31 import RnUtils ( RnEnv(..), extendGlobalRnEnv )
32 import RnBinds ( rnMethodBinds, rnTopBinds )
34 import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
35 import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass )
36 import CmdLineOpts ( opt_CompilingPrelude )
37 import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
38 import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
39 import Maybes ( maybeToBool, Maybe(..) )
40 import Name ( moduleNamePair, isLocallyDefined, getSrcLoc,
41 mkTopLevName, origName, mkImplicitName, ExportFlag(..),
42 RdrName{-instance Outputable-}, Name{--O only-}
44 import Outputable ( Outputable(..){-instances e.g., (,)-} )
45 import PprType ( GenType, GenTyVar, GenClass, TyCon )
46 import PprStyle ( PprStyle(..) )
47 import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, Pretty(..) )
48 import Pretty--ToDo:rm
49 import FiniteMap--ToDo:rm
50 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
51 import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
52 tyConTheta, maybeTyConSingleCon,
53 isEnumerationTyCon, isDataTyCon, TyCon
55 import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon,
56 mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
57 getAppDataTyCon, getAppTyCon
59 import TysWiredIn ( voidTy )
60 import TyVar ( GenTyVar )
61 import UniqFM ( emptyUFM )
62 import Unique -- Keys stuff
63 import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc,
64 thenCmp, cmpList, panic, pprPanic, pprPanic#,
65 assertPanic, pprTrace{-ToDo:rm-}
69 %************************************************************************
71 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
73 %************************************************************************
77 data T a b = C1 (Foo a) (Bar b)
82 [NOTE: See end of these comments for what to do with
83 data (C a, D b) => T a b = ...
86 We want to come up with an instance declaration of the form
88 instance (Ping a, Pong b, ...) => Eq (T a b) where
91 It is pretty easy, albeit tedious, to fill in the code "...". The
92 trick is to figure out what the context for the instance decl is,
93 namely @Ping@, @Pong@ and friends.
95 Let's call the context reqd for the T instance of class C at types
96 (a,b, ...) C (T a b). Thus:
98 Eq (T a b) = (Ping a, Pong b, ...)
100 Now we can get a (recursive) equation from the @data@ decl:
102 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
103 u Eq (T b a) u Eq Int -- From C2
104 u Eq (T a a) -- From C3
106 Foo and Bar may have explicit instances for @Eq@, in which case we can
107 just substitute for them. Alternatively, either or both may have
108 their @Eq@ instances given by @deriving@ clauses, in which case they
109 form part of the system of equations.
111 Now all we need do is simplify and solve the equations, iterating to
112 find the least fixpoint. Notice that the order of the arguments can
113 switch around, as here in the recursive calls to T.
115 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
119 Eq (T a b) = {} -- The empty set
122 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
123 u Eq (T b a) u Eq Int -- From C2
124 u Eq (T a a) -- From C3
126 After simplification:
127 = Eq a u Ping b u {} u {} u {}
132 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
133 u Eq (T b a) u Eq Int -- From C2
134 u Eq (T a a) -- From C3
136 After simplification:
141 = Eq a u Ping b u Eq b u Ping a
143 The next iteration gives the same result, so this is the fixpoint. We
144 need to make a canonical form of the RHS to ensure convergence. We do
145 this by simplifying the RHS to a form in which
147 - the classes constrain only tyvars
148 - the list is sorted by tyvar (major key) and then class (minor key)
149 - no duplicates, of course
151 So, here are the synonyms for the ``equation'' structures:
154 type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
155 -- The tyvars bind all the variables in the RHS
156 -- NEW: it's convenient to re-use InstInfo
157 -- We'll "panic" out some fields...
159 type DerivRhs = [(Class, TauType)] -- Same as a ThetaType!
161 type DerivSoln = DerivRhs
165 A note about contexts on data decls
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
169 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
171 We will need an instance decl like:
173 instance (Read a, RealFloat a) => Read (Complex a) where
176 The RealFloat in the context is because the read method for Complex is bound
177 to construct a Complex, and doing that requires that the argument type is
180 But this ain't true for Show, Eq, Ord, etc, since they don't construct
181 a Complex; they only take them apart.
183 Our approach: identify the offending classes, and add the data type
184 context to the instance decl. The "offending classes" are
189 %************************************************************************
191 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
193 %************************************************************************
196 tcDeriving :: Module -- name of module under scrutiny
197 -> RnEnv -- for "renaming" bits of generated code
198 -> Bag InstInfo -- What we already know about instances
199 -> [RenamedFixityDecl] -- Fixity info; used by Read and Show
200 -> TcM s (Bag InstInfo, -- The generated "instance decls".
201 RenamedHsBinds, -- Extra generated bindings
202 PprStyle -> Pretty) -- Printable derived instance decls;
203 -- for debugging via -ddump-derivings.
205 tcDeriving modname rn_env inst_decl_infos_in fixities
206 = -- Fish the "deriving"-related information out of the TcEnv
207 -- and make the necessary "equations".
208 makeDerivEqns `thenTc` \ eqns ->
210 -- Take the equation list and solve it, to deliver a list of
211 -- solutions, a.k.a. the contexts for the instance decls
212 -- required for the corresponding equations.
213 solveDerivEqns inst_decl_infos_in eqns
214 `thenTc` \ new_inst_infos ->
216 -- Now augment the InstInfos, adding in the rather boring
217 -- actual-code-to-do-the-methods binds. We may also need to
218 -- generate extra not-one-inst-decl-specific binds, notably
219 -- "con2tag" and/or "tag2con" functions. We do these
222 gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
223 gen_tag_n_con_binds rn_env nm_alist_etc
224 `thenTc` \ (extra_binds, deriver_rn_env) ->
226 mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos
227 `thenTc` \ really_new_inst_infos ->
229 ddump_deriv = ddump_deriving really_new_inst_infos extra_binds
231 --pprTrace "derived:\n" (ddump_deriv PprDebug) $
233 returnTc (listToBag really_new_inst_infos,
237 maybe_mod = if opt_CompilingPrelude then Nothing else Just modname
239 ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
241 ddump_deriving inst_infos extra_binds sty
242 = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
244 pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
245 = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
250 %************************************************************************
252 \subsection[TcDeriv-eqns]{Forming the equations}
254 %************************************************************************
256 @makeDerivEqns@ fishes around to find the info about needed derived
257 instances. Complicating factors:
260 We can only derive @Enum@ if the data type is an enumeration
261 type (all nullary data constructors).
264 We can only derive @Ix@ if the data type is an enumeration {\em
265 or} has just one data constructor (e.g., tuples).
268 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
272 makeDerivEqns :: TcM s [DerivEqn]
275 = tcGetEnv `thenNF_Tc` \ env ->
276 tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
278 tycons = filter isDataTyCon (getEnv_TyCons env)
279 -- ToDo: what about newtypes???
280 think_about_deriving = need_deriving eval_clas tycons
282 mapTc chk_out think_about_deriving `thenTc_`
284 (derive_these, _) = removeDups cmp_deriv think_about_deriving
285 eqns = map mk_eqn derive_these
289 ------------------------------------------------------------------
290 need_deriving :: Class -> [TyCon] -> [(Class, TyCon)]
291 -- find the tycons that have `deriving' clauses;
292 -- we handle the "every datatype in Eval" by
293 -- doing a dummy "deriving" for it.
295 need_deriving eval_clas tycons_to_consider
296 = foldr ( \ tycon acc ->
298 acc_plus = if isLocallyDefined tycon
299 then (eval_clas, tycon) : acc
302 case (tyConDerivings tycon) of
304 cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus
309 ------------------------------------------------------------------
310 chk_out :: (Class, TyCon) -> TcM s ()
311 chk_out this_one@(clas, tycon)
313 clas_key = classKey clas
315 is_enumeration = isEnumerationTyCon tycon
316 is_single_con = maybeToBool (maybeTyConSingleCon tycon)
318 chk_clas clas_uniq clas_str cond
319 = if (clas_uniq == clas_key)
320 then checkTc cond (derivingThingErr clas_str tycon)
323 -- Are things OK for deriving Enum (if appropriate)?
324 chk_clas enumClassKey "Enum" is_enumeration `thenTc_`
326 -- Are things OK for deriving Bounded (if appropriate)?
327 chk_clas boundedClassKey "Bounded"
328 (is_enumeration || is_single_con) `thenTc_`
330 -- Are things OK for deriving Ix (if appropriate)?
331 chk_clas ixClassKey "Ix.Ix" (is_enumeration || is_single_con)
333 ------------------------------------------------------------------
334 cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
335 cmp_deriv (c1, t1) (c2, t2)
336 = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
338 ------------------------------------------------------------------
339 mk_eqn :: (Class, TyCon) -> DerivEqn
340 -- we swizzle the tyvars and datacons out of the tycon
341 -- to make the rest of the equation
344 = (clas, tycon, tyvars, if_not_Eval constraints)
346 clas_key = classKey clas
347 tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
348 tyvar_tys = mkTyVarTys tyvars
349 data_cons = tyConDataCons tycon
351 if_not_Eval cs = if clas_key == evalClassKey then [] else cs
353 constraints = extra_constraints ++ concat (map mk_constraints data_cons)
355 -- "extra_constraints": see notes above about contexts on data decls
357 | offensive_class = tyConTheta tycon
360 offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
362 mk_constraints data_con
364 | arg_ty <- instd_arg_tys,
365 not (isPrimType arg_ty) -- No constraints for primitive types
368 instd_arg_tys = dataConArgTys data_con tyvar_tys
371 %************************************************************************
373 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
375 %************************************************************************
377 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
378 terms, which is the final correct RHS for the corresponding original
382 Each (k,TyVarTy tv) in a solution constrains only a type
386 The (k,TyVarTy tv) pairs in a solution are canonically
387 ordered by sorting on type varible, tv, (major key) and then class, k,
392 solveDerivEqns :: Bag InstInfo
394 -> TcM s [InstInfo] -- Solns in same order as eqns.
395 -- This bunch is Absolutely minimal...
397 solveDerivEqns inst_decl_infos_in orig_eqns
398 = iterateDeriv initial_solutions
400 -- The initial solutions for the equations claim that each
401 -- instance has an empty context; this solution is certainly
402 -- in canonical form.
403 initial_solutions :: [DerivSoln]
404 initial_solutions = [ [] | _ <- orig_eqns ]
406 -- iterateDeriv calculates the next batch of solutions,
407 -- compares it with the current one; finishes if they are the
408 -- same, otherwise recurses with the new solutions.
410 iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
412 iterateDeriv current_solns
413 = -- Extend the inst info from the explicit instance decls
414 -- with the current set of solutions, giving a
416 add_solns inst_decl_infos_in orig_eqns current_solns
417 `thenTc` \ (new_inst_infos, inst_mapper) ->
419 class_to_inst_env cls = fst (inst_mapper cls)
423 listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs
424 | (_,_,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns ->
426 -- Canonicalise the solutions, so they compare nicely
427 let canonicalised_next_solns
428 = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
430 if (current_solns `eq_solns` canonicalised_next_solns) then
431 returnTc new_inst_infos
433 iterateDeriv canonicalised_next_solns
436 ------------------------------------------------------------------
437 lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False }
438 eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
439 cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
440 cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
441 = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
443 cmp_rhs other_1 other_2
444 = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
450 add_solns :: Bag InstInfo -- The global, non-derived ones
451 -> [DerivEqn] -> [DerivSoln]
452 -> TcM s ([InstInfo], -- The new, derived ones
454 -- the eqns and solns move "in lockstep"; we have the eqns
455 -- because we need the LHS info for addClassInstance.
457 add_solns inst_infos_in eqns solns
458 = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
459 returnTc (new_inst_infos, inst_mapper)
461 new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
463 all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
465 mk_deriv_inst_info (clas, tycon, tyvars, _) theta
466 = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
468 (my_panic "dfun_theta")
472 (my_panic "const_meth_ids")
473 (my_panic "binds") (my_panic "from_here")
474 (my_panic "modname") mkGeneratedSrcLoc
475 (my_panic "upragmas")
478 = mkDictFunId bottom bottom bottom dummy_dfun_ty
479 bottom bottom bottom bottom
481 bottom = panic "dummy_dfun_id"
483 dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
484 -- All we need from the dfun is its "theta" part, used during
485 -- equation simplification (tcSimplifyThetas). The final
486 -- dfun_id will have the superclass dictionaries as arguments too,
487 -- but that'll be added after the equations are solved. For now,
488 -- it's enough just to make a dummy dfun with the simple theta part.
490 -- The part after the theta is dummied here as voidTy; actually it's
491 -- (C (T a b)), but it doesn't seem worth constructing it.
492 -- We can't leave it as a panic because to get the theta part we
493 -- have to run down the type!
495 my_panic str = pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon])
498 %************************************************************************
500 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
502 %************************************************************************
504 After all the trouble to figure out the required context for the
505 derived instance declarations, all that's left is to chug along to
506 produce them. They will then be shoved into @tcInstDecls2@, which
507 will do all its usual business.
509 There are lots of possibilities for code to generate. Here are
510 various general remarks.
515 We want derived instances of @Eq@ and @Ord@ (both v common) to be
516 ``you-couldn't-do-better-by-hand'' efficient.
519 Deriving @Show@---also pretty common--- should also be reasonable good code.
522 Deriving for the other classes isn't that common or that big a deal.
529 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
532 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
535 We {\em normally} generate code only for the non-defaulted methods;
536 there are some exceptions for @Eq@ and (especially) @Ord@...
539 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
540 constructor's numeric (@Int#@) tag. These are generated by
541 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
542 these is around is given by @hasCon2TagFun@.
544 The examples under the different sections below will make this
548 Much less often (really just for deriving @Ix@), we use a
549 @_tag2con_<tycon>@ function. See the examples.
552 We use the renamer!!! Reason: we're supposed to be
553 producing @RenamedMonoBinds@ for the methods, but that means
554 producing correctly-uniquified code on the fly. This is entirely
555 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
556 So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
557 the renamer. What a great hack!
561 gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
562 -> [RenamedFixityDecl] -- all known fixities;
563 -- may be needed for Text
564 -> RnEnv -- lookup stuff for names we may use
565 -> InstInfo -- the main stuff to work on
566 -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
568 gen_inst_info modname fixities deriver_rn_env
569 (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
571 -- Generate the various instance-related Ids
573 True {-from_here-} locn modname
577 [{-no user pragmas-}]
578 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
580 -- Generate the bindings for the new instance declaration,
581 -- rename it, and check for errors
583 (tycon,_,_) = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $
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 fixities)
594 ,(readClassKey, gen_Read_binds fixities)
595 ,(ixClassKey, gen_Ix_binds)
601 ((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env
603 pprTrace "gen_inst:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
604 pprTrace "gen_inst:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
605 pprTrace "gen_inst:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
606 pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
608 -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
610 rnMtoTcM deriver_rn_env (
611 setExtraRn emptyUFM{-no fixities-} $
612 rnMethodBinds clas_Name proto_mbinds
613 ) `thenNF_Tc` \ (mbinds, errs) ->
615 if not (isEmptyBag errs) then
616 pprPanic "gen_inst_info:renamer errs!\n"
617 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
621 from_here = isLocallyDefined tycon -- If so, then from here
623 returnTc (InstInfo clas tyvars ty inst_decl_theta
624 dfun_theta dfun_id const_meth_ids
625 (if from_here then mbinds else EmptyMonoBinds)
626 from_here modname locn [])
628 clas_key = classKey clas
629 clas_Name = RnImplicitClass (mkImplicitName clas_key (origName clas))
632 %************************************************************************
634 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
636 %************************************************************************
640 con2tag_Foo :: Foo ... -> Int#
641 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
642 maxtag_Foo :: Int -- ditto (NB: not unboxed)
645 gen_tag_n_con_binds :: RnEnv
646 -> [(RdrName, TyCon, TagThingWanted)]
647 -> TcM s (RenamedHsBinds,
648 RnEnv) -- input one with any new names added
650 gen_tag_n_con_binds rn_env nm_alist_etc
653 -- We have the renamer's final "name funs" in our hands
654 -- (they were passed in). So we can handle ProtoNames
655 -- that refer to anything "out there". But our generated
656 -- code may also mention "con2tag" (etc.). So we need
657 -- to augment to "name funs" to include those.
659 names_to_add = [ pn | (pn,_,_) <- nm_alist_etc ]
661 tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs ->
663 pairs_to_add = [ (pn, mkRnName (mkTopLevName u pn mkGeneratedSrcLoc ExportAll []))
664 | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ]
667 = if null names_to_add
668 then rn_env else added_rn_env
670 (added_rn_env, errs_bag)
671 = extendGlobalRnEnv rn_env pairs_to_add [{-no tycons-}]
674 proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
675 proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
677 ASSERT(isEmptyBag errs_bag)
679 rnMtoTcM deriver_rn_env (
680 setExtraRn emptyUFM{-no fixities-} $
681 rnTopBinds (SingleBind (RecBind proto_mbinds))
682 ) `thenNF_Tc` \ (binds, errs) ->
684 if not (isEmptyBag errs) then
685 pprPanic "gen_tag_n_con_binds:renamer errs!\n"
686 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds))
688 returnTc (binds, deriver_rn_env)
691 %************************************************************************
693 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
695 %************************************************************************
697 We have a @con2tag@ function for a tycon if:
700 We're deriving @Eq@ and the tycon has nullary data constructors.
703 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
707 We have a @tag2con@ function for a tycon if:
710 We're deriving @Enum@, or @Ix@ (enum type only???)
713 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
716 gen_taggery_Names :: [InstInfo]
717 -> TcM s [(RdrName, -- for an assoc list
718 TyCon, -- related tycon
721 gen_taggery_Names inst_infos
722 = --pprTrace "gen_taggery:\n" (ppAboves [ppCat [ppr PprDebug c, ppr PprDebug t] | (c,t) <- all_CTs]) $
723 foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
724 foldlTc do_tag2con names_so_far tycons_of_interest
726 all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _ _ _ _) <- inst_infos ]
728 mk_CT c ty = (c, fst (getAppTyCon ty))
730 all_tycons = map snd all_CTs
731 (tycons_of_interest, _) = removeDups cmp all_tycons
733 do_con2tag acc_Names tycon
734 = if (we_are_deriving eqClassKey tycon
735 && any isNullaryDataCon (tyConDataCons tycon))
736 || (we_are_deriving ordClassKey tycon
737 && not (maybeToBool (maybeTyConSingleCon tycon)))
738 || (we_are_deriving enumClassKey tycon)
739 || (we_are_deriving ixClassKey tycon)
741 returnTc ((con2tag_PN tycon, tycon, GenCon2Tag)
746 do_tag2con acc_Names tycon
747 = if (we_are_deriving enumClassKey tycon)
748 || (we_are_deriving ixClassKey tycon)
750 returnTc ( (tag2con_PN tycon, tycon, GenTag2Con)
751 : (maxtag_PN tycon, tycon, GenMaxTag)
756 we_are_deriving clas_key tycon
757 = is_in_eqns clas_key tycon all_CTs
759 is_in_eqns clas_key tycon [] = False
760 is_in_eqns clas_key tycon ((c,t):cts)
761 = (clas_key == classKey c && tycon == t)
762 || is_in_eqns clas_key tycon cts
767 derivingThingErr :: String -> TyCon -> Error
769 derivingThingErr thing tycon sty
770 = ppHang (ppCat [ppStr "Can't make a derived instance of", ppStr thing])
771 4 (ppBesides [ppStr "for the type `", ppr sty tycon, ppStr "'"])