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 ( HsDecl, FixityDecl, Fixity, InstDecl,
16 Sig, HsBinds(..), Bind(..), MonoBinds(..),
17 GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
18 ArithSeqInfo, Fake, HsType
20 import HsPragmas ( InstancePragmas(..) )
21 import RdrHsSyn ( RdrName, SYN_IE(RdrNameMonoBinds) )
22 import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), SYN_IE(RenamedFixityDecl) )
23 import TcHsSyn ( TcIdOcc )
26 import Inst ( SYN_IE(InstanceMapper) )
27 import TcEnv ( getEnv_TyCons, tcLookupClassByKey )
28 import SpecEnv ( SpecEnv )
29 import TcKind ( TcKind )
30 import TcGenDeriv -- Deriv stuff
31 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
32 import TcSimplify ( tcSimplifyThetas )
34 import RnBinds ( rnMethodBinds, rnTopMonoBinds )
35 import RnEnv ( newDfunName )
36 import RnMonad ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..),
37 setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn )
39 import Bag ( Bag, isEmptyBag, unionBags, listToBag )
40 import Class ( classKey, GenClass )
41 import ErrUtils ( pprBagOfErrors, addErrLoc, SYN_IE(Error) )
42 import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
43 import PrelInfo ( needsDataDeclCtxtClassKeys )
44 import Maybes ( maybeToBool )
45 import Name ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance,
48 import Outputable ( Outputable(..){-instances e.g., (,)-} )
49 import PprType ( GenType, GenTyVar, GenClass, TyCon )
50 import PprStyle ( PprStyle(..) )
51 import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, SYN_IE(Pretty) )
52 --import Pretty--ToDo:rm
53 --import FiniteMap--ToDo:rm
54 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
55 import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
56 tyConTheta, maybeTyConSingleCon,
57 isEnumerationTyCon, isDataTyCon, TyCon
59 import Type ( GenType(..), SYN_IE(TauType), mkTyVarTys, applyTyCon,
60 mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
61 getAppDataTyCon, getAppTyCon
63 import TysPrim ( voidTy )
64 import TyVar ( GenTyVar )
65 import UniqFM ( emptyUFM )
66 import Unique -- Keys stuff
67 import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc,
68 thenCmp, cmpList, panic, panic#, pprPanic, pprPanic#,
69 assertPanic-- , pprTrace{-ToDo:rm-}
73 %************************************************************************
75 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
77 %************************************************************************
81 data T a b = C1 (Foo a) (Bar b)
86 [NOTE: See end of these comments for what to do with
87 data (C a, D b) => T a b = ...
90 We want to come up with an instance declaration of the form
92 instance (Ping a, Pong b, ...) => Eq (T a b) where
95 It is pretty easy, albeit tedious, to fill in the code "...". The
96 trick is to figure out what the context for the instance decl is,
97 namely @Ping@, @Pong@ and friends.
99 Let's call the context reqd for the T instance of class C at types
100 (a,b, ...) C (T a b). Thus:
102 Eq (T a b) = (Ping a, Pong b, ...)
104 Now we can get a (recursive) equation from the @data@ decl:
106 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
107 u Eq (T b a) u Eq Int -- From C2
108 u Eq (T a a) -- From C3
110 Foo and Bar may have explicit instances for @Eq@, in which case we can
111 just substitute for them. Alternatively, either or both may have
112 their @Eq@ instances given by @deriving@ clauses, in which case they
113 form part of the system of equations.
115 Now all we need do is simplify and solve the equations, iterating to
116 find the least fixpoint. Notice that the order of the arguments can
117 switch around, as here in the recursive calls to T.
119 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
123 Eq (T a b) = {} -- The empty set
126 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
127 u Eq (T b a) u Eq Int -- From C2
128 u Eq (T a a) -- From C3
130 After simplification:
131 = Eq a u Ping b u {} u {} u {}
136 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
137 u Eq (T b a) u Eq Int -- From C2
138 u Eq (T a a) -- From C3
140 After simplification:
145 = Eq a u Ping b u Eq b u Ping a
147 The next iteration gives the same result, so this is the fixpoint. We
148 need to make a canonical form of the RHS to ensure convergence. We do
149 this by simplifying the RHS to a form in which
151 - the classes constrain only tyvars
152 - the list is sorted by tyvar (major key) and then class (minor key)
153 - no duplicates, of course
155 So, here are the synonyms for the ``equation'' structures:
158 type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
159 -- The tyvars bind all the variables in the RHS
160 -- NEW: it's convenient to re-use InstInfo
161 -- We'll "panic" out some fields...
163 type DerivRhs = [(Class, TauType)] -- Same as a ThetaType!
165 type DerivSoln = DerivRhs
169 A note about contexts on data decls
170 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
173 data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
175 We will need an instance decl like:
177 instance (Read a, RealFloat a) => Read (Complex a) where
180 The RealFloat in the context is because the read method for Complex is bound
181 to construct a Complex, and doing that requires that the argument type is
184 But this ain't true for Show, Eq, Ord, etc, since they don't construct
185 a Complex; they only take them apart.
187 Our approach: identify the offending classes, and add the data type
188 context to the instance decl. The "offending classes" are
193 %************************************************************************
195 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
197 %************************************************************************
200 tcDeriving :: Module -- name of module under scrutiny
201 -> RnNameSupply -- for "renaming" bits of generated code
202 -> Bag InstInfo -- What we already know about instances
203 -> TcM s (Bag InstInfo, -- The generated "instance decls".
204 RenamedHsBinds, -- Extra generated bindings
205 PprStyle -> Pretty) -- Printable derived instance decls;
206 -- for debugging via -ddump-derivings.
208 tcDeriving modname rn_name_supply inst_decl_infos_in
209 = -- Fish the "deriving"-related information out of the TcEnv
210 -- and make the necessary "equations".
211 makeDerivEqns `thenTc` \ eqns ->
213 -- Take the equation list and solve it, to deliver a list of
214 -- solutions, a.k.a. the contexts for the instance decls
215 -- required for the corresponding equations.
216 solveDerivEqns inst_decl_infos_in eqns `thenTc` \ new_inst_infos ->
218 -- Now augment the InstInfos, adding in the rather boring
219 -- actual-code-to-do-the-methods binds. We may also need to
220 -- generate extra not-one-inst-decl-specific binds, notably
221 -- "con2tag" and/or "tag2con" functions. We do these
224 gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
228 extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
229 extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
230 method_binds_s = map gen_bind new_inst_infos
232 -- Rename to get RenamedBinds.
233 -- The only tricky bit is that the extra_binds must scope over the
234 -- method bindings for the instances.
235 (dfun_names_w_method_binds, rn_extra_binds)
236 = renameSourceCode modname rn_name_supply (
237 rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds ->
238 mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
239 returnRn (dfun_names_w_method_binds, rn_extra_binds)
241 rn_one meth_binds = newDfunName mkGeneratedSrcLoc `thenRn` \ dfun_name ->
242 rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
243 returnRn (dfun_name, rn_meth_binds)
246 mapTc (gen_inst_info modname)
247 (new_inst_infos `zip` dfun_names_w_method_binds) `thenTc` \ really_new_inst_infos ->
249 ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
251 --pprTrace "derived:\n" (ddump_deriv PprDebug) $
253 returnTc (listToBag really_new_inst_infos,
257 ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
259 ddump_deriving inst_infos extra_binds sty
260 = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
262 pp_info (InstInfo clas tvs ty inst_decl_theta _ _ mbinds _ _)
263 = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
268 %************************************************************************
270 \subsection[TcDeriv-eqns]{Forming the equations}
272 %************************************************************************
274 @makeDerivEqns@ fishes around to find the info about needed derived
275 instances. Complicating factors:
278 We can only derive @Enum@ if the data type is an enumeration
279 type (all nullary data constructors).
282 We can only derive @Ix@ if the data type is an enumeration {\em
283 or} has just one data constructor (e.g., tuples).
286 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
290 makeDerivEqns :: TcM s [DerivEqn]
293 = tcGetEnv `thenNF_Tc` \ env ->
295 local_data_tycons = filter (\tc -> isLocallyDefined tc && isDataTyCon tc)
297 -- ToDo: what about newtypes???
299 if null local_data_tycons then
300 -- Bale out now; evalClass may not be loaded if there aren't any
303 tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
305 think_about_deriving = need_deriving eval_clas local_data_tycons
306 (derive_these, _) = removeDups cmp_deriv think_about_deriving
307 eqns = map mk_eqn derive_these
309 mapTc chk_out think_about_deriving `thenTc_`
312 ------------------------------------------------------------------
313 need_deriving :: Class -> [TyCon] -> [(Class, TyCon)]
314 -- find the tycons that have `deriving' clauses;
315 -- we handle the "every datatype in Eval" by
316 -- doing a dummy "deriving" for it.
318 need_deriving eval_clas tycons_to_consider
319 = foldr ( \ tycon acc ->
321 acc_plus = if isLocallyDefined tycon
322 then (eval_clas, tycon) : acc
325 case (tyConDerivings tycon) of
327 cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus
332 ------------------------------------------------------------------
333 chk_out :: (Class, TyCon) -> TcM s ()
334 chk_out this_one@(clas, tycon)
336 clas_key = classKey clas
338 is_enumeration = isEnumerationTyCon tycon
339 is_single_con = maybeToBool (maybeTyConSingleCon tycon)
341 chk_clas clas_uniq clas_str cond
342 = if (clas_uniq == clas_key)
343 then checkTc cond (derivingThingErr clas_str tycon)
346 -- Are things OK for deriving Enum (if appropriate)?
347 chk_clas enumClassKey "Enum" is_enumeration `thenTc_`
349 -- Are things OK for deriving Bounded (if appropriate)?
350 chk_clas boundedClassKey "Bounded"
351 (is_enumeration || is_single_con) `thenTc_`
353 -- Are things OK for deriving Ix (if appropriate)?
354 chk_clas ixClassKey "Ix.Ix" (is_enumeration || is_single_con)
356 ------------------------------------------------------------------
357 cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
358 cmp_deriv (c1, t1) (c2, t2)
359 = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
361 ------------------------------------------------------------------
362 mk_eqn :: (Class, TyCon) -> DerivEqn
363 -- we swizzle the tyvars and datacons out of the tycon
364 -- to make the rest of the equation
367 = (clas, tycon, tyvars, if_not_Eval constraints)
369 clas_key = classKey clas
370 tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
371 tyvar_tys = mkTyVarTys tyvars
372 data_cons = tyConDataCons tycon
374 if_not_Eval cs = if clas_key == evalClassKey then [] else cs
376 constraints = extra_constraints ++ concat (map mk_constraints data_cons)
378 -- "extra_constraints": see notes above about contexts on data decls
380 | offensive_class = tyConTheta tycon
383 offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
385 mk_constraints data_con
387 | arg_ty <- instd_arg_tys,
388 not (isPrimType arg_ty) -- No constraints for primitive types
391 instd_arg_tys = dataConArgTys data_con tyvar_tys
394 %************************************************************************
396 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
398 %************************************************************************
400 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
401 terms, which is the final correct RHS for the corresponding original
405 Each (k,TyVarTy tv) in a solution constrains only a type
409 The (k,TyVarTy tv) pairs in a solution are canonically
410 ordered by sorting on type varible, tv, (major key) and then class, k,
415 solveDerivEqns :: Bag InstInfo
417 -> TcM s [InstInfo] -- Solns in same order as eqns.
418 -- This bunch is Absolutely minimal...
420 solveDerivEqns inst_decl_infos_in orig_eqns
421 = iterateDeriv initial_solutions
423 -- The initial solutions for the equations claim that each
424 -- instance has an empty context; this solution is certainly
425 -- in canonical form.
426 initial_solutions :: [DerivSoln]
427 initial_solutions = [ [] | _ <- orig_eqns ]
429 -- iterateDeriv calculates the next batch of solutions,
430 -- compares it with the current one; finishes if they are the
431 -- same, otherwise recurses with the new solutions.
433 iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
435 iterateDeriv current_solns
436 = -- Extend the inst info from the explicit instance decls
437 -- with the current set of solutions, giving a
439 add_solns inst_decl_infos_in orig_eqns current_solns
440 `thenTc` \ (new_inst_infos, inst_mapper) ->
442 class_to_inst_env cls = fst (inst_mapper cls)
446 listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs
447 | (_,_,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns ->
449 -- Canonicalise the solutions, so they compare nicely
450 let canonicalised_next_solns
451 = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
453 if (current_solns `eq_solns` canonicalised_next_solns) then
454 returnTc new_inst_infos
456 iterateDeriv canonicalised_next_solns
459 ------------------------------------------------------------------
460 lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False }
461 eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
462 cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
463 cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
464 = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
466 cmp_rhs other_1 other_2
467 = panic# "tcDeriv:cmp_rhs:" --(ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
473 add_solns :: Bag InstInfo -- The global, non-derived ones
474 -> [DerivEqn] -> [DerivSoln]
475 -> TcM s ([InstInfo], -- The new, derived ones
477 -- the eqns and solns move "in lockstep"; we have the eqns
478 -- because we need the LHS info for addClassInstance.
480 add_solns inst_infos_in eqns solns
481 = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
482 returnTc (new_inst_infos, inst_mapper)
484 new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
486 all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
488 mk_deriv_inst_info (clas, tycon, tyvars, _) theta
489 = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
491 (my_panic "dfun_theta")
495 (my_panic "binds") (getSrcLoc tycon)
496 (my_panic "upragmas")
499 = mkDictFunId bottom dummy_dfun_ty bottom bottom
501 bottom = panic "dummy_dfun_id"
503 dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
504 -- All we need from the dfun is its "theta" part, used during
505 -- equation simplification (tcSimplifyThetas). The final
506 -- dfun_id will have the superclass dictionaries as arguments too,
507 -- but that'll be added after the equations are solved. For now,
508 -- it's enough just to make a dummy dfun with the simple theta part.
510 -- The part after the theta is dummied here as voidTy; actually it's
511 -- (C (T a b)), but it doesn't seem worth constructing it.
512 -- We can't leave it as a panic because to get the theta part we
513 -- have to run down the type!
515 my_panic str = panic "add_soln" -- pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon])
518 %************************************************************************
520 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
522 %************************************************************************
524 After all the trouble to figure out the required context for the
525 derived instance declarations, all that's left is to chug along to
526 produce them. They will then be shoved into @tcInstDecls2@, which
527 will do all its usual business.
529 There are lots of possibilities for code to generate. Here are
530 various general remarks.
535 We want derived instances of @Eq@ and @Ord@ (both v common) to be
536 ``you-couldn't-do-better-by-hand'' efficient.
539 Deriving @Show@---also pretty common--- should also be reasonable good code.
542 Deriving for the other classes isn't that common or that big a deal.
549 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
552 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
555 We {\em normally} generate code only for the non-defaulted methods;
556 there are some exceptions for @Eq@ and (especially) @Ord@...
559 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
560 constructor's numeric (@Int#@) tag. These are generated by
561 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
562 these is around is given by @hasCon2TagFun@.
564 The examples under the different sections below will make this
568 Much less often (really just for deriving @Ix@), we use a
569 @_tag2con_<tycon>@ function. See the examples.
572 We use the renamer!!! Reason: we're supposed to be
573 producing @RenamedMonoBinds@ for the methods, but that means
574 producing correctly-uniquified code on the fly. This is entirely
575 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
576 So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
577 the renamer. What a great hack!
581 -- Generate the method bindings for the required instance
582 gen_bind :: InstInfo -> RdrNameMonoBinds
583 gen_bind (InstInfo clas _ 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)
594 ,(readClassKey, gen_Read_binds)
595 ,(ixClassKey, gen_Ix_binds)
600 from_here = isLocallyDefined tycon
601 (tycon,_,_) = getAppDataTyCon ty
604 gen_inst_info :: Module -- Module name
605 -> (InstInfo, (Name, RenamedMonoBinds)) -- the main stuff to work on
606 -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
608 gen_inst_info modname
609 (InstInfo clas tyvars ty inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds))
611 -- Generate the various instance-related Ids
616 `thenNF_Tc` \ (dfun_id, dfun_theta) ->
618 returnTc (InstInfo clas tyvars ty inst_decl_theta
623 from_here = isLocallyDefined tycon
624 (tycon,_,_) = getAppDataTyCon ty
628 %************************************************************************
630 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
632 %************************************************************************
637 con2tag_Foo :: Foo ... -> Int#
638 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
639 maxtag_Foo :: Int -- ditto (NB: not unboxed)
642 We have a @con2tag@ function for a tycon if:
645 We're deriving @Eq@ and the tycon has nullary data constructors.
648 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
652 We have a @tag2con@ function for a tycon if:
655 We're deriving @Enum@, or @Ix@ (enum type only???)
658 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
661 gen_taggery_Names :: [InstInfo]
662 -> TcM s [(RdrName, -- for an assoc list
663 TyCon, -- related tycon
666 gen_taggery_Names inst_infos
667 = --pprTrace "gen_taggery:\n" (ppAboves [ppCat [ppr PprDebug c, ppr PprDebug t] | (c,t) <- all_CTs]) $
668 foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
669 foldlTc do_tag2con names_so_far tycons_of_interest
671 all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _) <- inst_infos ]
673 mk_CT c ty = (c, fst (getAppTyCon ty))
675 all_tycons = map snd all_CTs
676 (tycons_of_interest, _) = removeDups cmp all_tycons
678 do_con2tag acc_Names tycon
679 = if (we_are_deriving eqClassKey tycon
680 && any isNullaryDataCon (tyConDataCons tycon))
681 || (we_are_deriving ordClassKey tycon
682 && not (maybeToBool (maybeTyConSingleCon tycon)))
683 || (we_are_deriving enumClassKey tycon)
684 || (we_are_deriving ixClassKey tycon)
686 returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag)
691 do_tag2con acc_Names tycon
692 = if (we_are_deriving enumClassKey tycon)
693 || (we_are_deriving ixClassKey tycon)
695 returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
696 : (maxtag_RDR tycon, tycon, GenMaxTag)
701 we_are_deriving clas_key tycon
702 = is_in_eqns clas_key tycon all_CTs
704 is_in_eqns clas_key tycon [] = False
705 is_in_eqns clas_key tycon ((c,t):cts)
706 = (clas_key == classKey c && tycon == t)
707 || is_in_eqns clas_key tycon cts
712 derivingThingErr :: String -> TyCon -> Error
714 derivingThingErr thing tycon sty
715 = ppHang (ppCat [ppStr "Can't make a derived instance of", ppStr thing])
716 4 (ppBesides [ppStr "for the type `", ppr sty tycon, ppStr "'"])