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(..), SYN_IE(RenamedHsBinds), RenamedFixityDecl(..) )
20 import TcHsSyn ( TcIdOcc )
23 import Inst ( SYN_IE(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 ( SYN_IE(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 ErrUtils ( pprBagOfErrors, addErrLoc, SYN_IE(Error) )
37 import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
38 import Maybes ( maybeToBool )
39 import Name ( isLocallyDefined, getSrcLoc,
40 mkTopLevName, origName, mkImplicitName, ExportFlag(..),
41 RdrName(..), Name{--O only-}
43 import Outputable ( Outputable(..){-instances e.g., (,)-} )
44 import PprType ( GenType, GenTyVar, GenClass, TyCon )
45 import PprStyle ( PprStyle(..) )
46 import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, SYN_IE(Pretty) )
47 import Pretty--ToDo:rm
48 import FiniteMap--ToDo:rm
49 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
50 import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
51 tyConTheta, maybeTyConSingleCon,
52 isEnumerationTyCon, isDataTyCon, TyCon
54 import Type ( GenType(..), SYN_IE(TauType), mkTyVarTys, applyTyCon,
55 mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
56 getAppDataTyCon, getAppTyCon
58 import TysPrim ( voidTy )
59 import TyVar ( GenTyVar )
60 import UniqFM ( emptyUFM )
61 import Unique -- Keys stuff
62 import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc,
63 thenCmp, cmpList, panic, pprPanic, pprPanic#,
64 assertPanic, pprTrace{-ToDo:rm-}
68 %************************************************************************
70 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
72 %************************************************************************
76 data T a b = C1 (Foo a) (Bar b)
81 [NOTE: See end of these comments for what to do with
82 data (C a, D b) => T a b = ...
85 We want to come up with an instance declaration of the form
87 instance (Ping a, Pong b, ...) => Eq (T a b) where
90 It is pretty easy, albeit tedious, to fill in the code "...". The
91 trick is to figure out what the context for the instance decl is,
92 namely @Ping@, @Pong@ and friends.
94 Let's call the context reqd for the T instance of class C at types
95 (a,b, ...) C (T a b). Thus:
97 Eq (T a b) = (Ping a, Pong b, ...)
99 Now we can get a (recursive) equation from the @data@ decl:
101 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
102 u Eq (T b a) u Eq Int -- From C2
103 u Eq (T a a) -- From C3
105 Foo and Bar may have explicit instances for @Eq@, in which case we can
106 just substitute for them. Alternatively, either or both may have
107 their @Eq@ instances given by @deriving@ clauses, in which case they
108 form part of the system of equations.
110 Now all we need do is simplify and solve the equations, iterating to
111 find the least fixpoint. Notice that the order of the arguments can
112 switch around, as here in the recursive calls to T.
114 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
118 Eq (T a b) = {} -- The empty set
121 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
122 u Eq (T b a) u Eq Int -- From C2
123 u Eq (T a a) -- From C3
125 After simplification:
126 = Eq a u Ping b u {} u {} u {}
131 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
132 u Eq (T b a) u Eq Int -- From C2
133 u Eq (T a a) -- From C3
135 After simplification:
140 = Eq a u Ping b u Eq b u Ping a
142 The next iteration gives the same result, so this is the fixpoint. We
143 need to make a canonical form of the RHS to ensure convergence. We do
144 this by simplifying the RHS to a form in which
146 - the classes constrain only tyvars
147 - the list is sorted by tyvar (major key) and then class (minor key)
148 - no duplicates, of course
150 So, here are the synonyms for the ``equation'' structures:
153 type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
154 -- The tyvars bind all the variables in the RHS
155 -- NEW: it's convenient to re-use InstInfo
156 -- We'll "panic" out some fields...
158 type DerivRhs = [(Class, TauType)] -- Same as a ThetaType!
160 type DerivSoln = DerivRhs
164 A note about contexts on data decls
165 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
168 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
170 We will need an instance decl like:
172 instance (Read a, RealFloat a) => Read (Complex a) where
175 The RealFloat in the context is because the read method for Complex is bound
176 to construct a Complex, and doing that requires that the argument type is
179 But this ain't true for Show, Eq, Ord, etc, since they don't construct
180 a Complex; they only take them apart.
182 Our approach: identify the offending classes, and add the data type
183 context to the instance decl. The "offending classes" are
188 %************************************************************************
190 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
192 %************************************************************************
195 tcDeriving :: Module -- name of module under scrutiny
196 -> RnEnv -- for "renaming" bits of generated code
197 -> Bag InstInfo -- What we already know about instances
198 -> [RenamedFixityDecl] -- Fixity info; used by Read and Show
199 -> TcM s (Bag InstInfo, -- The generated "instance decls".
200 RenamedHsBinds, -- Extra generated bindings
201 PprStyle -> Pretty) -- Printable derived instance decls;
202 -- for debugging via -ddump-derivings.
204 tcDeriving modname rn_env inst_decl_infos_in fixities
205 = -- Fish the "deriving"-related information out of the TcEnv
206 -- and make the necessary "equations".
207 makeDerivEqns `thenTc` \ eqns ->
209 -- Take the equation list and solve it, to deliver a list of
210 -- solutions, a.k.a. the contexts for the instance decls
211 -- required for the corresponding equations.
212 solveDerivEqns inst_decl_infos_in eqns
213 `thenTc` \ new_inst_infos ->
215 -- Now augment the InstInfos, adding in the rather boring
216 -- actual-code-to-do-the-methods binds. We may also need to
217 -- generate extra not-one-inst-decl-specific binds, notably
218 -- "con2tag" and/or "tag2con" functions. We do these
221 gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
222 gen_tag_n_con_binds rn_env nm_alist_etc
223 `thenTc` \ (extra_binds, deriver_rn_env) ->
225 mapTc (gen_inst_info modname fixities deriver_rn_env) new_inst_infos
226 `thenTc` \ really_new_inst_infos ->
228 ddump_deriv = ddump_deriving really_new_inst_infos extra_binds
230 --pprTrace "derived:\n" (ddump_deriv PprDebug) $
232 returnTc (listToBag really_new_inst_infos,
236 ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
238 ddump_deriving inst_infos extra_binds sty
239 = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
241 pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
242 = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
247 %************************************************************************
249 \subsection[TcDeriv-eqns]{Forming the equations}
251 %************************************************************************
253 @makeDerivEqns@ fishes around to find the info about needed derived
254 instances. Complicating factors:
257 We can only derive @Enum@ if the data type is an enumeration
258 type (all nullary data constructors).
261 We can only derive @Ix@ if the data type is an enumeration {\em
262 or} has just one data constructor (e.g., tuples).
265 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
269 makeDerivEqns :: TcM s [DerivEqn]
272 = tcGetEnv `thenNF_Tc` \ env ->
273 tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
275 tycons = filter isDataTyCon (getEnv_TyCons env)
276 -- ToDo: what about newtypes???
277 think_about_deriving = need_deriving eval_clas tycons
279 mapTc chk_out think_about_deriving `thenTc_`
281 (derive_these, _) = removeDups cmp_deriv think_about_deriving
282 eqns = map mk_eqn derive_these
286 ------------------------------------------------------------------
287 need_deriving :: Class -> [TyCon] -> [(Class, TyCon)]
288 -- find the tycons that have `deriving' clauses;
289 -- we handle the "every datatype in Eval" by
290 -- doing a dummy "deriving" for it.
292 need_deriving eval_clas tycons_to_consider
293 = foldr ( \ tycon acc ->
295 acc_plus = if isLocallyDefined tycon
296 then (eval_clas, tycon) : acc
299 case (tyConDerivings tycon) of
301 cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus
306 ------------------------------------------------------------------
307 chk_out :: (Class, TyCon) -> TcM s ()
308 chk_out this_one@(clas, tycon)
310 clas_key = classKey clas
312 is_enumeration = isEnumerationTyCon tycon
313 is_single_con = maybeToBool (maybeTyConSingleCon tycon)
315 chk_clas clas_uniq clas_str cond
316 = if (clas_uniq == clas_key)
317 then checkTc cond (derivingThingErr clas_str tycon)
320 -- Are things OK for deriving Enum (if appropriate)?
321 chk_clas enumClassKey "Enum" is_enumeration `thenTc_`
323 -- Are things OK for deriving Bounded (if appropriate)?
324 chk_clas boundedClassKey "Bounded"
325 (is_enumeration || is_single_con) `thenTc_`
327 -- Are things OK for deriving Ix (if appropriate)?
328 chk_clas ixClassKey "Ix.Ix" (is_enumeration || is_single_con)
330 ------------------------------------------------------------------
331 cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
332 cmp_deriv (c1, t1) (c2, t2)
333 = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
335 ------------------------------------------------------------------
336 mk_eqn :: (Class, TyCon) -> DerivEqn
337 -- we swizzle the tyvars and datacons out of the tycon
338 -- to make the rest of the equation
341 = (clas, tycon, tyvars, if_not_Eval constraints)
343 clas_key = classKey clas
344 tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
345 tyvar_tys = mkTyVarTys tyvars
346 data_cons = tyConDataCons tycon
348 if_not_Eval cs = if clas_key == evalClassKey then [] else cs
350 constraints = extra_constraints ++ concat (map mk_constraints data_cons)
352 -- "extra_constraints": see notes above about contexts on data decls
354 | offensive_class = tyConTheta tycon
357 offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
359 mk_constraints data_con
361 | arg_ty <- instd_arg_tys,
362 not (isPrimType arg_ty) -- No constraints for primitive types
365 instd_arg_tys = dataConArgTys data_con tyvar_tys
368 %************************************************************************
370 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
372 %************************************************************************
374 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
375 terms, which is the final correct RHS for the corresponding original
379 Each (k,TyVarTy tv) in a solution constrains only a type
383 The (k,TyVarTy tv) pairs in a solution are canonically
384 ordered by sorting on type varible, tv, (major key) and then class, k,
389 solveDerivEqns :: Bag InstInfo
391 -> TcM s [InstInfo] -- Solns in same order as eqns.
392 -- This bunch is Absolutely minimal...
394 solveDerivEqns inst_decl_infos_in orig_eqns
395 = iterateDeriv initial_solutions
397 -- The initial solutions for the equations claim that each
398 -- instance has an empty context; this solution is certainly
399 -- in canonical form.
400 initial_solutions :: [DerivSoln]
401 initial_solutions = [ [] | _ <- orig_eqns ]
403 -- iterateDeriv calculates the next batch of solutions,
404 -- compares it with the current one; finishes if they are the
405 -- same, otherwise recurses with the new solutions.
407 iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
409 iterateDeriv current_solns
410 = -- Extend the inst info from the explicit instance decls
411 -- with the current set of solutions, giving a
413 add_solns inst_decl_infos_in orig_eqns current_solns
414 `thenTc` \ (new_inst_infos, inst_mapper) ->
416 class_to_inst_env cls = fst (inst_mapper cls)
420 listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs
421 | (_,_,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns ->
423 -- Canonicalise the solutions, so they compare nicely
424 let canonicalised_next_solns
425 = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
427 if (current_solns `eq_solns` canonicalised_next_solns) then
428 returnTc new_inst_infos
430 iterateDeriv canonicalised_next_solns
433 ------------------------------------------------------------------
434 lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False }
435 eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
436 cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
437 cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
438 = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
440 cmp_rhs other_1 other_2
441 = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
447 add_solns :: Bag InstInfo -- The global, non-derived ones
448 -> [DerivEqn] -> [DerivSoln]
449 -> TcM s ([InstInfo], -- The new, derived ones
451 -- the eqns and solns move "in lockstep"; we have the eqns
452 -- because we need the LHS info for addClassInstance.
454 add_solns inst_infos_in eqns solns
455 = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
456 returnTc (new_inst_infos, inst_mapper)
458 new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
460 all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
462 mk_deriv_inst_info (clas, tycon, tyvars, _) theta
463 = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
465 (my_panic "dfun_theta")
469 (my_panic "const_meth_ids")
470 (my_panic "binds") (my_panic "from_here")
471 (my_panic "modname") mkGeneratedSrcLoc
472 (my_panic "upragmas")
475 = mkDictFunId bottom bottom bottom dummy_dfun_ty
476 bottom bottom bottom bottom
478 bottom = panic "dummy_dfun_id"
480 dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
481 -- All we need from the dfun is its "theta" part, used during
482 -- equation simplification (tcSimplifyThetas). The final
483 -- dfun_id will have the superclass dictionaries as arguments too,
484 -- but that'll be added after the equations are solved. For now,
485 -- it's enough just to make a dummy dfun with the simple theta part.
487 -- The part after the theta is dummied here as voidTy; actually it's
488 -- (C (T a b)), but it doesn't seem worth constructing it.
489 -- We can't leave it as a panic because to get the theta part we
490 -- have to run down the type!
492 my_panic str = pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon])
495 %************************************************************************
497 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
499 %************************************************************************
501 After all the trouble to figure out the required context for the
502 derived instance declarations, all that's left is to chug along to
503 produce them. They will then be shoved into @tcInstDecls2@, which
504 will do all its usual business.
506 There are lots of possibilities for code to generate. Here are
507 various general remarks.
512 We want derived instances of @Eq@ and @Ord@ (both v common) to be
513 ``you-couldn't-do-better-by-hand'' efficient.
516 Deriving @Show@---also pretty common--- should also be reasonable good code.
519 Deriving for the other classes isn't that common or that big a deal.
526 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
529 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
532 We {\em normally} generate code only for the non-defaulted methods;
533 there are some exceptions for @Eq@ and (especially) @Ord@...
536 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
537 constructor's numeric (@Int#@) tag. These are generated by
538 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
539 these is around is given by @hasCon2TagFun@.
541 The examples under the different sections below will make this
545 Much less often (really just for deriving @Ix@), we use a
546 @_tag2con_<tycon>@ function. See the examples.
549 We use the renamer!!! Reason: we're supposed to be
550 producing @RenamedMonoBinds@ for the methods, but that means
551 producing correctly-uniquified code on the fly. This is entirely
552 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
553 So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
554 the renamer. What a great hack!
558 gen_inst_info :: Module -- Module name
559 -> [RenamedFixityDecl] -- all known fixities;
560 -- may be needed for Text
561 -> RnEnv -- lookup stuff for names we may use
562 -> InstInfo -- the main stuff to work on
563 -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
565 gen_inst_info modname fixities deriver_rn_env
566 (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
568 -- Generate the various instance-related Ids
570 True {-from_here-} locn modname
574 [{-no user pragmas-}]
575 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
577 -- Generate the bindings for the new instance declaration,
578 -- rename it, and check for errors
580 (tycon,_,_) = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $
584 = assoc "gen_inst_info:bad derived class"
585 [(eqClassKey, gen_Eq_binds)
586 ,(ordClassKey, gen_Ord_binds)
587 ,(enumClassKey, gen_Enum_binds)
588 ,(evalClassKey, gen_Eval_binds)
589 ,(boundedClassKey, gen_Bounded_binds)
590 ,(showClassKey, gen_Show_binds fixities)
591 ,(readClassKey, gen_Read_binds fixities)
592 ,(ixClassKey, gen_Ix_binds)
598 ((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env
600 pprTrace "gen_inst:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
601 pprTrace "gen_inst:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
602 pprTrace "gen_inst:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
603 pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
605 -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
607 rnMtoTcM deriver_rn_env (
608 setExtraRn emptyUFM{-no fixities-} $
609 rnMethodBinds clas_Name proto_mbinds
610 ) `thenNF_Tc` \ (mbinds, errs) ->
612 if not (isEmptyBag errs) then
613 pprPanic "gen_inst_info:renamer errs!\n"
614 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
618 from_here = isLocallyDefined tycon -- If so, then from here
620 returnTc (InstInfo clas tyvars ty inst_decl_theta
621 dfun_theta dfun_id const_meth_ids
622 (if from_here then mbinds else EmptyMonoBinds)
623 from_here modname locn [])
625 clas_key = classKey clas
626 clas_Name = RnImplicitClass (mkImplicitName clas_key (origName "gen_inst_info" clas))
629 %************************************************************************
631 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
633 %************************************************************************
637 con2tag_Foo :: Foo ... -> Int#
638 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
639 maxtag_Foo :: Int -- ditto (NB: not unboxed)
642 gen_tag_n_con_binds :: RnEnv
643 -> [(RdrName, TyCon, TagThingWanted)]
644 -> TcM s (RenamedHsBinds,
645 RnEnv) -- input one with any new names added
647 gen_tag_n_con_binds rn_env nm_alist_etc
650 -- We have the renamer's final "name funs" in our hands
651 -- (they were passed in). So we can handle ProtoNames
652 -- that refer to anything "out there". But our generated
653 -- code may also mention "con2tag" (etc.). So we need
654 -- to augment to "name funs" to include those.
656 names_to_add = [ pn | (pn,_,_) <- nm_alist_etc ]
658 tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs ->
660 pairs_to_add = [ case pn of { Qual pnm pnn ->
661 (pn, mkRnName (mkTopLevName u (OrigName pnm pnn) mkGeneratedSrcLoc ExportAll [])) }
662 | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ]
665 = if null names_to_add
666 then rn_env else added_rn_env
668 (added_rn_env, errs_bag)
669 = extendGlobalRnEnv rn_env pairs_to_add [{-no tycons-}]
672 proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
673 proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
675 ASSERT(isEmptyBag errs_bag)
677 rnMtoTcM deriver_rn_env (
678 setExtraRn emptyUFM{-no fixities-} $
679 rnTopBinds (SingleBind (RecBind proto_mbinds))
680 ) `thenNF_Tc` \ (binds, errs) ->
682 if not (isEmptyBag errs) then
683 pprPanic "gen_tag_n_con_binds:renamer errs!\n"
684 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds))
686 returnTc (binds, deriver_rn_env)
689 %************************************************************************
691 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
693 %************************************************************************
695 We have a @con2tag@ function for a tycon if:
698 We're deriving @Eq@ and the tycon has nullary data constructors.
701 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
705 We have a @tag2con@ function for a tycon if:
708 We're deriving @Enum@, or @Ix@ (enum type only???)
711 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
714 gen_taggery_Names :: [InstInfo]
715 -> TcM s [(RdrName, -- for an assoc list
716 TyCon, -- related tycon
719 gen_taggery_Names inst_infos
720 = --pprTrace "gen_taggery:\n" (ppAboves [ppCat [ppr PprDebug c, ppr PprDebug t] | (c,t) <- all_CTs]) $
721 foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
722 foldlTc do_tag2con names_so_far tycons_of_interest
724 all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _ _ _ _) <- inst_infos ]
726 mk_CT c ty = (c, fst (getAppTyCon ty))
728 all_tycons = map snd all_CTs
729 (tycons_of_interest, _) = removeDups cmp all_tycons
731 do_con2tag acc_Names tycon
732 = if (we_are_deriving eqClassKey tycon
733 && any isNullaryDataCon (tyConDataCons tycon))
734 || (we_are_deriving ordClassKey tycon
735 && not (maybeToBool (maybeTyConSingleCon tycon)))
736 || (we_are_deriving enumClassKey tycon)
737 || (we_are_deriving ixClassKey tycon)
739 returnTc ((con2tag_PN tycon, tycon, GenCon2Tag)
744 do_tag2con acc_Names tycon
745 = if (we_are_deriving enumClassKey tycon)
746 || (we_are_deriving ixClassKey tycon)
748 returnTc ( (tag2con_PN tycon, tycon, GenTag2Con)
749 : (maxtag_PN tycon, tycon, GenMaxTag)
754 we_are_deriving clas_key tycon
755 = is_in_eqns clas_key tycon all_CTs
757 is_in_eqns clas_key tycon [] = False
758 is_in_eqns clas_key tycon ((c,t):cts)
759 = (clas_key == classKey c && tycon == t)
760 || is_in_eqns clas_key tycon cts
765 derivingThingErr :: String -> TyCon -> Error
767 derivingThingErr thing tycon sty
768 = ppHang (ppCat [ppStr "Can't make a derived instance of", ppStr thing])
769 4 (ppBesides [ppStr "for the type `", ppr sty tycon, ppStr "'"])