2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcDeriv]{Deriving}
6 Handles @deriving@ clauses on @data@ declarations.
9 module TcDeriv ( tcDeriving ) where
11 #include "HsVersions.h"
13 import HsSyn ( HsBinds(..), MonoBinds(..), TyClDecl(..),
14 collectLocatedMonoBinders )
15 import RdrHsSyn ( RdrNameMonoBinds )
16 import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred )
17 import CmdLineOpts ( DynFlag(..), DynFlags )
20 import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
21 tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
23 import TcGenDeriv -- Deriv stuff
24 import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv )
25 import TcMonoType ( tcHsPred )
26 import TcSimplify ( tcSimplifyDeriv )
28 import RnBinds ( rnMethodBinds, rnTopMonoBinds )
29 import RnEnv ( bindLocatedLocalsRn )
30 import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn )
31 import HscTypes ( DFunId, PersistentRenamerState )
33 import BasicTypes ( Fixity, NewOrData(..) )
34 import Class ( className, classKey, classTyVars, Class )
35 import ErrUtils ( dumpIfSet_dyn, Message )
36 import MkId ( mkDictFunId )
37 import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon )
38 import PrelInfo ( needsDataDeclCtxtClassKeys )
39 import Maybes ( maybeToBool, catMaybes )
40 import Module ( Module )
41 import Name ( Name, getSrcLoc, nameUnique )
42 import RdrName ( RdrName )
44 import TyCon ( tyConTyVars, tyConDataCons, tyConArity, newTyConRep,
45 tyConTheta, maybeTyConSingleCon, isDataTyCon,
46 isEnumerationTyCon, TyCon
48 import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
49 isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys,
50 tcSplitTyConApp_maybe, tcEqTypes, tyVarsOfTheta )
51 import Var ( TyVar, tyVarKind )
52 import VarSet ( mkVarSet, subVarSet )
54 import Util ( zipWithEqual, sortLt, eqListBy )
55 import ListSetOps ( removeDups, assoc )
57 import Maybe ( isJust )
59 import FastString ( FastString )
62 %************************************************************************
64 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
66 %************************************************************************
70 data T a b = C1 (Foo a) (Bar b)
75 [NOTE: See end of these comments for what to do with
76 data (C a, D b) => T a b = ...
79 We want to come up with an instance declaration of the form
81 instance (Ping a, Pong b, ...) => Eq (T a b) where
84 It is pretty easy, albeit tedious, to fill in the code "...". The
85 trick is to figure out what the context for the instance decl is,
86 namely @Ping@, @Pong@ and friends.
88 Let's call the context reqd for the T instance of class C at types
89 (a,b, ...) C (T a b). Thus:
91 Eq (T a b) = (Ping a, Pong b, ...)
93 Now we can get a (recursive) equation from the @data@ decl:
95 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
96 u Eq (T b a) u Eq Int -- From C2
97 u Eq (T a a) -- From C3
99 Foo and Bar may have explicit instances for @Eq@, in which case we can
100 just substitute for them. Alternatively, either or both may have
101 their @Eq@ instances given by @deriving@ clauses, in which case they
102 form part of the system of equations.
104 Now all we need do is simplify and solve the equations, iterating to
105 find the least fixpoint. Notice that the order of the arguments can
106 switch around, as here in the recursive calls to T.
108 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
112 Eq (T a b) = {} -- The empty set
115 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
116 u Eq (T b a) u Eq Int -- From C2
117 u Eq (T a a) -- From C3
119 After simplification:
120 = Eq a u Ping b u {} u {} u {}
125 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
126 u Eq (T b a) u Eq Int -- From C2
127 u Eq (T a a) -- From C3
129 After simplification:
134 = Eq a u Ping b u Eq b u Ping a
136 The next iteration gives the same result, so this is the fixpoint. We
137 need to make a canonical form of the RHS to ensure convergence. We do
138 this by simplifying the RHS to a form in which
140 - the classes constrain only tyvars
141 - the list is sorted by tyvar (major key) and then class (minor key)
142 - no duplicates, of course
144 So, here are the synonyms for the ``equation'' structures:
147 type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs)
148 -- The Name is the name for the DFun we'll build
149 -- The tyvars bind all the variables in the RHS
151 pprDerivEqn (n,c,tc,tvs,rhs)
152 = parens (hsep [ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs)
154 type DerivRhs = ThetaType
155 type DerivSoln = DerivRhs
159 A note about contexts on data decls
160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
163 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
165 We will need an instance decl like:
167 instance (Read a, RealFloat a) => Read (Complex a) where
170 The RealFloat in the context is because the read method for Complex is bound
171 to construct a Complex, and doing that requires that the argument type is
174 But this ain't true for Show, Eq, Ord, etc, since they don't construct
175 a Complex; they only take them apart.
177 Our approach: identify the offending classes, and add the data type
178 context to the instance decl. The "offending classes" are
183 %************************************************************************
185 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
187 %************************************************************************
190 tcDeriving :: PersistentRenamerState
191 -> Module -- name of module under scrutiny
192 -> InstEnv -- What we already know about instances
193 -> (Name -> Maybe Fixity) -- used in deriving Show and Read
194 -> [RenamedTyClDecl] -- All type constructors
195 -> TcM ([InstInfo], -- The generated "instance decls".
196 RenamedHsBinds) -- Extra generated bindings
198 tcDeriving prs mod inst_env get_fixity tycl_decls
199 = recoverTc (returnTc ([], EmptyBinds)) $
200 getDOptsTc `thenNF_Tc` \ dflags ->
202 -- Fish the "deriving"-related information out of the TcEnv
203 -- and make the necessary "equations".
204 makeDerivEqns tycl_decls `thenTc` \ (ordinary_eqns, newtype_inst_info) ->
206 -- Add the newtype-derived instances to the inst env
207 -- before tacking the "ordinary" ones
208 inst_env1 = extend_inst_env dflags inst_env
209 (map iDFunId newtype_inst_info)
211 deriveOrdinaryStuff mod prs inst_env1 get_fixity
212 ordinary_eqns `thenTc` \ (ordinary_inst_info, binds) ->
214 inst_info = newtype_inst_info ++ ordinary_inst_info
217 ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
218 (ddump_deriving inst_info binds)) `thenTc_`
220 returnTc (inst_info, binds)
223 ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
224 ddump_deriving inst_infos extra_binds
225 = vcat (map pprInstInfo inst_infos) $$ ppr extra_binds
228 -----------------------------------------
229 deriveOrdinaryStuff mod prs inst_env_in get_fixity [] -- Short cut
230 = returnTc ([], EmptyBinds)
232 deriveOrdinaryStuff mod prs inst_env_in get_fixity eqns
233 = -- Take the equation list and solve it, to deliver a list of
234 -- solutions, a.k.a. the contexts for the instance decls
235 -- required for the corresponding equations.
236 solveDerivEqns inst_env_in eqns `thenTc` \ new_dfuns ->
238 -- Now augment the InstInfos, adding in the rather boring
239 -- actual-code-to-do-the-methods binds. We may also need to
240 -- generate extra not-one-inst-decl-specific binds, notably
241 -- "con2tag" and/or "tag2con" functions. We do these
243 gen_taggery_Names new_dfuns `thenTc` \ nm_alist_etc ->
245 tcGetEnv `thenNF_Tc` \ env ->
246 getDOptsTc `thenNF_Tc` \ dflags ->
248 extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
249 extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
250 method_binds_s = map (gen_bind get_fixity) new_dfuns
251 mbinders = collectLocatedMonoBinders extra_mbinds
253 -- Rename to get RenamedBinds.
254 -- The only tricky bit is that the extra_binds must scope over the
255 -- method bindings for the instances.
256 (rn_method_binds_s, rn_extra_binds)
257 = renameDerivedCode dflags mod prs (
258 bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ ->
259 rnTopMonoBinds extra_mbinds [] `thenRn` \ (rn_extra_binds, _) ->
260 mapRn rn_meths method_binds_s `thenRn` \ rn_method_binds_s ->
261 returnRn (rn_method_binds_s, rn_extra_binds)
263 new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s
265 returnTc (new_inst_infos, rn_extra_binds)
268 -- Make a Real dfun instead of the dummy one we have so far
269 gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
270 gen_inst_info dfun binds
271 = InstInfo { iDFunId = dfun, iBinds = binds, iPrags = [] }
273 rn_meths (cls, meths) = rnMethodBinds cls [] meths `thenRn` \ (meths', _) ->
274 returnRn meths' -- Ignore the free vars returned
278 %************************************************************************
280 \subsection[TcDeriv-eqns]{Forming the equations}
282 %************************************************************************
284 @makeDerivEqns@ fishes around to find the info about needed derived
285 instances. Complicating factors:
288 We can only derive @Enum@ if the data type is an enumeration
289 type (all nullary data constructors).
292 We can only derive @Ix@ if the data type is an enumeration {\em
293 or} has just one data constructor (e.g., tuples).
296 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
300 makeDerivEqns :: [RenamedTyClDecl]
301 -> TcM ([DerivEqn], -- Ordinary derivings
302 [InstInfo]) -- Special newtype derivings
304 makeDerivEqns tycl_decls
305 = mapAndUnzipTc mk_eqn derive_these `thenTc` \ (maybe_ordinaries, maybe_newtypes) ->
306 returnTc (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
308 ------------------------------------------------------------------
309 derive_these :: [(NewOrData, Name, RenamedHsPred)]
310 -- Find the (nd, TyCon, Pred) pairs that must be `derived'
311 -- NB: only source-language decls have deriving, no imported ones do
312 derive_these = [ (nd, tycon, pred)
313 | TyData {tcdND = nd, tcdName = tycon, tcdDerivs = Just preds} <- tycl_decls,
316 ------------------------------------------------------------------
317 mk_eqn :: (NewOrData, Name, RenamedHsPred) -> NF_TcM (Maybe DerivEqn, Maybe InstInfo)
318 -- We swizzle the tyvars and datacons out of the tycon
319 -- to make the rest of the equation
321 mk_eqn (new_or_data, tycon_name, pred)
322 = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
323 tcAddSrcLoc (getSrcLoc tycon) $
324 tcAddErrCtxt (derivCtxt Nothing tycon) $
325 tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention
326 -- the type variables for the type constructor
327 tcHsPred pred `thenTc` \ pred' ->
328 case getClassPredTys_maybe pred' of
329 Nothing -> bale_out (malformedPredErr tycon pred)
330 Just (clas, tys) -> mk_eqn_help new_or_data tycon clas tys
332 ------------------------------------------------------------------
333 mk_eqn_help DataType tycon clas tys
334 | Just err <- chk_out clas tycon tys
335 = bale_out (derivingThingErr clas tys tycon tyvars err)
337 = new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
338 returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing)
340 tyvars = tyConTyVars tycon
341 data_cons = tyConDataCons tycon
342 constraints = extra_constraints ++
343 [ mkClassPred clas [arg_ty]
344 | data_con <- tyConDataCons tycon,
345 arg_ty <- dataConRepArgTys data_con,
346 -- Use the same type variables
347 -- as the type constructor,
348 -- hence no need to instantiate
349 not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
353 -- "extra_constraints": see notes above about contexts on data decls
354 extra_constraints | offensive_class = tyConTheta tycon
357 offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
360 mk_eqn_help NewType tycon clas tys
361 = doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
362 if can_derive_via_isomorphism && (gla_exts || standard_instance) then
363 -- Go ahead and use the isomorphism
364 new_dfun_name clas tycon `thenNF_Tc` \ dfun_name ->
365 returnTc (Nothing, Just (NewTypeDerived (mk_dfun dfun_name)))
367 if standard_instance then
368 mk_eqn_help DataType tycon clas [] -- Go via bale-out route
370 bale_out cant_derive_err
372 -- Here is the plan for newtype derivings. We see
373 -- newtype T a1...an = T (t ak...an) deriving (C1...Cm)
374 -- where aj...an do not occur free in t, and the Ci are *partial applications* of
375 -- classes with the last parameter missing
377 -- We generate the instances
378 -- instance Ci (t ak...aj) => Ci (T a1...aj)
379 -- where T a1...aj is the partial application of the LHS of the correct kind
381 -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
383 kind = tyVarKind (last (classTyVars clas))
384 -- Kind of the thing we want to instance
385 -- e.g. argument kind of Monad, *->*
387 (arg_kinds, _) = tcSplitFunTys kind
388 n_args_to_drop = length arg_kinds
389 -- Want to drop 1 arg from (T s a) and (ST s a)
390 -- to get instance Monad (ST s) => Monad (T s)
392 (tyvars, rep_ty) = newTyConRep tycon
393 maybe_rep_app = tcSplitTyConApp_maybe rep_ty
394 Just (rep_tc, rep_ty_args) = maybe_rep_app
396 n_tyvars_to_keep = tyConArity tycon - n_args_to_drop
397 tyvars_to_drop = drop n_tyvars_to_keep tyvars
398 tyvars_to_keep = take n_tyvars_to_keep tyvars
400 n_args_to_keep = tyConArity rep_tc - n_args_to_drop
401 args_to_drop = drop n_args_to_keep rep_ty_args
402 args_to_keep = take n_args_to_keep rep_ty_args
404 ctxt_pred = mkClassPred clas (tys ++ [mkTyConApp rep_tc args_to_keep])
406 mk_dfun dfun_name = mkDictFunId dfun_name clas tyvars
407 (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)] )
410 -- We can only do this newtype deriving thing if:
411 standard_instance = null tys && classKey clas `elem` derivableClassKeys
413 can_derive_via_isomorphism
414 = not (clas `hasKey` readClassKey) -- Never derive Read,Show this way
415 && not (clas `hasKey` showClassKey)
416 && n_tyvars_to_keep >= 0 -- Well kinded;
417 -- eg not: newtype T = T Int deriving( Monad )
418 && isJust maybe_rep_app -- The rep type is a type constructor app
419 && n_args_to_keep >= 0 -- Well kinded:
420 -- eg not: newtype T a = T Int deriving( Monad )
421 && eta_ok -- Eta reduction works
423 -- Check that eta reduction is OK
424 -- (a) the dropped-off args are identical
425 -- (b) the remaining type args mention
426 -- only the remaining type variables
427 eta_ok = (args_to_drop `tcEqTypes` mkTyVarTys tyvars_to_drop)
428 && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep)
430 cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
431 SLIT("too hard for cunning newtype deriving")
434 bale_out err = addErrTc err `thenNF_Tc_` returnNF_Tc (Nothing, Nothing)
436 ------------------------------------------------------------------
437 chk_out :: Class -> TyCon -> [TcType] -> Maybe FastString
438 chk_out clas tycon tys
439 | not (null tys) = Just non_std_why
440 | not (getUnique clas `elem` derivableClassKeys) = Just non_std_why
441 | clas `hasKey` enumClassKey && not is_enumeration = Just nullary_why
442 | clas `hasKey` boundedClassKey && not is_enumeration_or_single = Just single_nullary_why
443 | clas `hasKey` ixClassKey && not is_enumeration_or_single = Just single_nullary_why
444 | null data_cons = Just no_cons_why
445 | any isExistentialDataCon data_cons = Just existential_why
446 | otherwise = Nothing
448 data_cons = tyConDataCons tycon
449 is_enumeration = isEnumerationTyCon tycon
450 is_single_con = maybeToBool (maybeTyConSingleCon tycon)
451 is_enumeration_or_single = is_enumeration || is_single_con
453 single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
454 nullary_why = SLIT("data type with all nullary constructors expected")
455 no_cons_why = SLIT("type has no data constructors")
456 non_std_why = SLIT("not a derivable class")
457 existential_why = SLIT("it has existentially-quantified constructor(s)")
459 new_dfun_name clas tycon -- Just a simple wrapper
460 = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
461 -- The type passed to newDFunName is only used to generate
462 -- a suitable string; hence the empty type arg list
465 %************************************************************************
467 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
469 %************************************************************************
471 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
472 terms, which is the final correct RHS for the corresponding original
476 Each (k,TyVarTy tv) in a solution constrains only a type
480 The (k,TyVarTy tv) pairs in a solution are canonically
481 ordered by sorting on type varible, tv, (major key) and then class, k,
486 solveDerivEqns :: InstEnv
488 -> TcM [DFunId] -- Solns in same order as eqns.
489 -- This bunch is Absolutely minimal...
491 solveDerivEqns inst_env_in orig_eqns
492 = iterateDeriv 1 initial_solutions
494 -- The initial solutions for the equations claim that each
495 -- instance has an empty context; this solution is certainly
496 -- in canonical form.
497 initial_solutions :: [DerivSoln]
498 initial_solutions = [ [] | _ <- orig_eqns ]
500 ------------------------------------------------------------------
501 -- iterateDeriv calculates the next batch of solutions,
502 -- compares it with the current one; finishes if they are the
503 -- same, otherwise recurses with the new solutions.
504 -- It fails if any iteration fails
505 iterateDeriv :: Int -> [DerivSoln] ->TcM [DFunId]
506 iterateDeriv n current_solns
507 | n > 20 -- Looks as if we are in an infinite loop
508 -- This can happen if we have -fallow-undecidable-instances
509 -- (See TcSimplify.tcSimplifyDeriv.)
510 = pprPanic "solveDerivEqns: probable loop"
511 (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns)
513 = getDOptsTc `thenNF_Tc` \ dflags ->
515 dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
516 inst_env = extend_inst_env dflags inst_env_in dfuns
519 -- Extend the inst info from the explicit instance decls
520 -- with the current set of solutions, and simplify each RHS
521 tcSetInstEnv inst_env $
522 mapTc gen_soln orig_eqns
523 ) `thenTc` \ new_solns ->
524 if (current_solns == new_solns) then
527 iterateDeriv (n+1) new_solns
529 ------------------------------------------------------------------
531 gen_soln (_, clas, tc,tyvars,deriv_rhs)
532 = tcAddSrcLoc (getSrcLoc tc) $
533 tcAddErrCtxt (derivCtxt (Just clas) tc) $
534 tcSimplifyDeriv tyvars deriv_rhs `thenTc` \ theta ->
535 returnTc (sortLt (<) theta) -- Canonicalise before returning the soluction
539 extend_inst_env dflags inst_env new_dfuns
542 (new_inst_env, _errs) = extendInstEnv dflags inst_env new_dfuns
543 -- Ignore the errors about duplicate instances.
544 -- We don't want repeated error messages
545 -- They'll appear later, when we do the top-level extendInstEnvs
547 mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
548 = mkDictFunId dfun_name clas tyvars
549 [mkTyConApp tycon (mkTyVarTys tyvars)]
553 %************************************************************************
555 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
557 %************************************************************************
559 After all the trouble to figure out the required context for the
560 derived instance declarations, all that's left is to chug along to
561 produce them. They will then be shoved into @tcInstDecls2@, which
562 will do all its usual business.
564 There are lots of possibilities for code to generate. Here are
565 various general remarks.
570 We want derived instances of @Eq@ and @Ord@ (both v common) to be
571 ``you-couldn't-do-better-by-hand'' efficient.
574 Deriving @Show@---also pretty common--- should also be reasonable good code.
577 Deriving for the other classes isn't that common or that big a deal.
584 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
587 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
590 We {\em normally} generate code only for the non-defaulted methods;
591 there are some exceptions for @Eq@ and (especially) @Ord@...
594 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
595 constructor's numeric (@Int#@) tag. These are generated by
596 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
597 these is around is given by @hasCon2TagFun@.
599 The examples under the different sections below will make this
603 Much less often (really just for deriving @Ix@), we use a
604 @_tag2con_<tycon>@ function. See the examples.
607 We use the renamer!!! Reason: we're supposed to be
608 producing @RenamedMonoBinds@ for the methods, but that means
609 producing correctly-uniquified code on the fly. This is entirely
610 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
611 So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
612 the renamer. What a great hack!
616 -- Generate the method bindings for the required instance
617 -- (paired with class name, as we need that when renaming
619 gen_bind :: (Name -> Maybe Fixity) -> DFunId -> (Name, RdrNameMonoBinds)
620 gen_bind get_fixity dfun
623 cls_nm = className clas
624 (clas, tycon) = simpleDFunClassTyCon dfun
626 binds = assoc "gen_bind:bad derived class" gen_list
627 (nameUnique cls_nm) tycon
629 gen_list = [(eqClassKey, gen_Eq_binds)
630 ,(ordClassKey, gen_Ord_binds)
631 ,(enumClassKey, gen_Enum_binds)
632 ,(boundedClassKey, gen_Bounded_binds)
633 ,(ixClassKey, gen_Ix_binds)
634 ,(showClassKey, gen_Show_binds get_fixity)
635 ,(readClassKey, gen_Read_binds get_fixity)
640 %************************************************************************
642 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
644 %************************************************************************
649 con2tag_Foo :: Foo ... -> Int#
650 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
651 maxtag_Foo :: Int -- ditto (NB: not unlifted)
654 We have a @con2tag@ function for a tycon if:
657 We're deriving @Eq@ and the tycon has nullary data constructors.
660 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
664 We have a @tag2con@ function for a tycon if:
667 We're deriving @Enum@, or @Ix@ (enum type only???)
670 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
673 gen_taggery_Names :: [DFunId]
674 -> TcM [(RdrName, -- for an assoc list
675 TyCon, -- related tycon
678 gen_taggery_Names dfuns
679 = foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
680 foldlTc do_tag2con names_so_far tycons_of_interest
682 all_CTs = map simpleDFunClassTyCon dfuns
683 all_tycons = map snd all_CTs
684 (tycons_of_interest, _) = removeDups compare all_tycons
686 do_con2tag acc_Names tycon
687 | isDataTyCon tycon &&
688 ((we_are_deriving eqClassKey tycon
689 && any isNullaryDataCon (tyConDataCons tycon))
690 || (we_are_deriving ordClassKey tycon
691 && not (maybeToBool (maybeTyConSingleCon tycon)))
692 || (we_are_deriving enumClassKey tycon)
693 || (we_are_deriving ixClassKey tycon))
695 = returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag)
700 do_tag2con acc_Names tycon
701 | isDataTyCon tycon &&
702 (we_are_deriving enumClassKey tycon ||
703 we_are_deriving ixClassKey tycon
704 && isEnumerationTyCon tycon)
705 = returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
706 : (maxtag_RDR tycon, tycon, GenMaxTag)
711 we_are_deriving clas_key tycon
712 = is_in_eqns clas_key tycon all_CTs
714 is_in_eqns clas_key tycon [] = False
715 is_in_eqns clas_key tycon ((c,t):cts)
716 = (clas_key == classKey c && tycon == t)
717 || is_in_eqns clas_key tycon cts
721 derivingThingErr clas tys tycon tyvars why
722 = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
725 pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
727 malformedPredErr tycon pred = ptext SLIT("Illegal deriving item") <+> ppr pred
729 derivCtxt :: Maybe Class -> TyCon -> SDoc
730 derivCtxt maybe_cls tycon
731 = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
733 cls = case maybe_cls of
734 Nothing -> ptext SLIT("instances")
735 Just c -> ptext SLIT("the") <+> quotes (ppr c) <+> ptext SLIT("instance")