2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
4 \section[TcDeriv]{Deriving}
6 Handles @deriving@ clauses on @data@ declarations.
9 #include "HsVersions.h"
17 import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
18 GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
19 ArithSeqInfo, Fake, MonoType )
20 import HsPragmas ( InstancePragmas(..) )
21 import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) )
22 import TcHsSyn ( TcIdOcc )
25 import Inst ( InstOrigin(..), InstanceMapper(..) )
26 import TcEnv ( getEnv_TyCons )
27 import TcGenDeriv -- Deriv stuff
28 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
29 import TcSimplify ( tcSimplifyThetas )
32 import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
33 import RnBinds4 ( rnMethodBinds, rnTopBinds )
35 import Bag ( Bag, isEmptyBag, unionBags, listToBag )
36 import Class ( GenClass, getClassKey )
37 import ErrUtils ( pprBagOfErrors, addErrLoc, TcError(..) )
38 import Id ( getDataConSig, getDataConArity )
39 import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
40 import Name ( Name(..) )
41 import NameTypes ( mkPreludeCoreName, Provenance(..) )
43 import PprType ( GenType, GenTyVar, GenClass, TyCon )
46 import ProtoName ( eqProtoName, ProtoName(..), Name )
47 import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
48 import TyCon ( getTyConTyVars, getTyConDataCons, getTyConDerivings,
49 maybeTyConSingleCon, isEnumerationTyCon, TyCon )
50 import Type ( GenType(..), TauType(..), mkTyVarTy, applyTyCon,
51 mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
52 getAppTyCon, getAppDataTyCon )
53 import TyVar ( GenTyVar )
54 import UniqFM ( eltsUFM )
55 import Unique -- Keys stuff
56 import Util ( zipWithEqual, zipEqual, sortLt, removeDups,
57 thenCmp, cmpList, panic, pprPanic, pprPanic# )
60 %************************************************************************
62 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
64 %************************************************************************
68 data T a b = C1 (Foo a) (Bar b)
73 We want to come up with an instance declaration of the form
75 instance (Ping a, Pong b, ...) => Eq (T a b) where
78 It is pretty easy, albeit tedious, to fill in the code "...". The
79 trick is to figure out what the context for the instance decl is,
80 namely @Ping@, @Pong@ and friends.
82 Let's call the context reqd for the T instance of class C at types
83 (a,b, ...) C (T a b). Thus:
85 Eq (T a b) = (Ping a, Pong b, ...)
87 Now we can get a (recursive) equation from the @data@ decl:
89 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
90 u Eq (T b a) u Eq Int -- From C2
91 u Eq (T a a) -- From C3
93 Foo and Bar may have explicit instances for @Eq@, in which case we can
94 just substitute for them. Alternatively, either or both may have
95 their @Eq@ instances given by @deriving@ clauses, in which case they
96 form part of the system of equations.
98 Now all we need do is simplify and solve the equations, iterating to
99 find the least fixpoint. Notice that the order of the arguments can
100 switch around, as here in the recursive calls to T.
102 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
106 Eq (T a b) = {} -- The empty set
109 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
110 u Eq (T b a) u Eq Int -- From C2
111 u Eq (T a a) -- From C3
113 After simplification:
114 = Eq a u Ping b u {} u {} u {}
119 Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1
120 u Eq (T b a) u Eq Int -- From C2
121 u Eq (T a a) -- From C3
123 After simplification:
128 = Eq a u Ping b u Eq b u Ping a
130 The next iteration gives the same result, so this is the fixpoint. We
131 need to make a canonical form of the RHS to ensure convergence. We do
132 this by simplifying the RHS to a form in which
134 - the classes constrain only tyvars
135 - the list is sorted by tyvar (major key) and then class (minor key)
136 - no duplicates, of course
138 So, here are the synonyms for the ``equation'' structures:
141 type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
142 -- The tyvars bind all the variables in the RHS
143 -- NEW: it's convenient to re-use InstInfo
144 -- We'll "panic" out some fields...
146 type DerivRhs = [(Class, TauType)] -- Same as a ThetaType!
148 type DerivSoln = DerivRhs
151 %************************************************************************
153 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
155 %************************************************************************
158 tcDeriving :: FAST_STRING -- name of module under scrutiny
159 -> GlobalNameMappers -- for "renaming" bits of generated code
160 -> Bag InstInfo -- What we already know about instances
161 -> [RenamedFixityDecl] -- Fixity info; used by Read and Show
162 -> TcM s (Bag InstInfo, -- The generated "instance decls".
163 RenamedHsBinds, -- Extra generated bindings
164 PprStyle -> Pretty) -- Printable derived instance decls;
165 -- for debugging via -ddump-derivings.
167 tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
168 = -- Fish the "deriving"-related information out of the TcEnv
169 -- and make the necessary "equations".
170 makeDerivEqns `thenTc` \ eqns ->
172 -- Take the equation list and solve it, to deliver a list of
173 -- solutions, a.k.a. the contexts for the instance decls
174 -- required for the corresponding equations.
175 solveDerivEqns modname inst_decl_infos_in eqns
176 `thenTc` \ new_inst_infos ->
178 -- Now augment the InstInfos, adding in the rather boring
179 -- actual-code-to-do-the-methods binds. We may also need to
180 -- generate extra not-one-inst-decl-specific binds, notably
181 -- "con2tag" and/or "tag2con" functions. We do these
184 gen_taggery_Names eqns `thenTc` \ nm_alist_etc ->
186 nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
188 -- We have the renamer's final "name funs" in our hands
189 -- (they were passed in). So we can handle ProtoNames
190 -- that refer to anything "out there". But our generated
191 -- code may also mention "con2tag" (etc.). So we need
192 -- to augment to "name funs" to include those.
193 (rn_val_gnf, rn_tc_gnf) = renamer_name_funs
195 deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of
197 Nothing -> rn_val_gnf pname
199 deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
201 assoc_maybe [] _ = Nothing
202 assoc_maybe ((k,v) : vs) key
203 = if k `eqProtoName` key then Just v else assoc_maybe vs key
205 gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
207 mapTc (gen_inst_info modname fixities deriver_name_funs) new_inst_infos
208 `thenTc` \ really_new_inst_infos ->
210 returnTc (listToBag really_new_inst_infos,
212 ddump_deriving really_new_inst_infos extra_binds)
214 ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
216 ddump_deriving inst_infos extra_binds sty
217 = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
219 pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
220 = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
225 %************************************************************************
227 \subsection[TcDeriv-eqns]{Forming the equations}
229 %************************************************************************
231 @makeDerivEqns@ fishes around to find the info about needed derived
232 instances. Complicating factors:
235 We can only derive @Enum@ if the data type is an enumeration
236 type (all nullary data constructors).
239 We can only derive @Ix@ if the data type is an enumeration {\em
240 or} has just one data constructor (e.g., tuples).
243 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
247 makeDerivEqns :: TcM s [DerivEqn]
250 = tcGetEnv `thenNF_Tc` \ env ->
252 tycons = eltsUFM (getEnv_TyCons env)
253 think_about_deriving = need_deriving tycons
255 mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
257 (derive_these, _) = removeDups cmp_deriv think_about_deriving
258 eqns = map mk_eqn derive_these
262 ------------------------------------------------------------------
263 need_deriving :: [TyCon] -> [(Class, TyCon)]
264 -- find the tycons that have `deriving' clauses
266 need_deriving tycons_to_consider
267 = foldr ( \ tycon acc ->
268 case (getTyConDerivings tycon) of
270 cs -> [ (clas,tycon) | clas <- cs ] ++ acc
275 ------------------------------------------------------------------
276 chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
277 chk_out whole_deriving_list this_one@(clas, tycon)
279 clas_key = getClassKey clas
282 -- Are things OK for deriving Enum (if appropriate)?
283 checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon))
284 (derivingEnumErr tycon) `thenTc_`
286 -- Are things OK for deriving Ix (if appropriate)?
287 checkTc (clas_key == ixClassKey
288 && not (isEnumerationTyCon tycon
289 || maybeToBool (maybeTyConSingleCon tycon)))
290 (derivingIxErr tycon)
292 ------------------------------------------------------------------
293 cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
294 cmp_deriv (c1, t1) (c2, t2)
295 = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
297 ------------------------------------------------------------------
298 mk_eqn :: (Class, TyCon) -> DerivEqn
299 -- we swizzle the tyvars and datacons out of the tycon
300 -- to make the rest of the equation
303 = (clas, tycon, tyvars, constraints)
305 tyvars = getTyConTyVars tycon -- ToDo: Do we need new tyvars ???
306 tyvar_tys = map mkTyVarTy tyvars
307 data_cons = getTyConDataCons tycon
308 constraints = concat (map mk_constraints data_cons)
310 mk_constraints data_con
311 = [ (clas, instantiateTy inst_env arg_ty)
313 not (isPrimType arg_ty) -- No constraints for primitive types
316 (con_tyvars, _, arg_tys, _) = getDataConSig data_con
317 inst_env = con_tyvars `zipEqual` tyvar_tys
318 -- same number of tyvars in data constr and type constr!
321 %************************************************************************
323 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
325 %************************************************************************
327 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
328 terms, which is the final correct RHS for the corresponding original
332 Each (k,UniTyVarTemplate tv) in a solution constrains only a type
336 The (k,UniTyVarTemplate tv) pairs in a solution are canonically
337 ordered by sorting on type varible, tv, (major key) and then class, k,
342 solveDerivEqns :: FAST_STRING
345 -> TcM s [InstInfo] -- Solns in same order as eqns.
346 -- This bunch is Absolutely minimal...
348 solveDerivEqns modname inst_decl_infos_in orig_eqns
349 = iterateDeriv initial_solutions
351 -- The initial solutions for the equations claim that each
352 -- instance has an empty context; this solution is certainly
353 -- in canonical form.
354 initial_solutions :: [DerivSoln]
355 initial_solutions = [ [] | _ <- orig_eqns ]
357 -- iterateDeriv calculates the next batch of solutions,
358 -- compares it with the current one; finishes if they are the
359 -- same, otherwise recurses with the new solutions.
361 iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
363 iterateDeriv current_solns
364 = -- Extend the inst info from the explicit instance decls
365 -- with the current set of solutions, giving a
367 add_solns modname inst_decl_infos_in orig_eqns current_solns
368 `thenTc` \ (new_inst_infos, inst_mapper) ->
370 -- Simplify each RHS, using a DerivingOrigin containing an
371 -- inst_mapper reflecting the previous solution
373 mk_deriv_origin clas ty
374 = DerivingOrigin inst_mapper clas tycon
376 (tycon,_) = getAppTyCon ty
378 listTc [ tcSimplifyThetas mk_deriv_origin rhs
379 | (_, _, _, rhs) <- orig_eqns
380 ] `thenTc` \ next_solns ->
382 -- Canonicalise the solutions, so they compare nicely
383 let canonicalised_next_solns
384 = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
386 if current_solns `eq_solns` canonicalised_next_solns then
387 returnTc new_inst_infos
389 iterateDeriv canonicalised_next_solns
392 ------------------------------------------------------------------
393 lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False }
394 eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
395 cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
396 cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
397 = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
399 cmp_rhs other_1 other_2
400 = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
406 add_solns :: FAST_STRING
407 -> Bag InstInfo -- The global, non-derived ones
408 -> [DerivEqn] -> [DerivSoln]
409 -> TcM s ([InstInfo], -- The new, derived ones
411 -- the eqns and solns move "in lockstep"; we have the eqns
412 -- because we need the LHS info for addClassInstance.
414 add_solns modname inst_infos_in eqns solns
415 = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
416 returnTc (new_inst_infos, inst_mapper)
418 new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns
420 all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
422 mk_deriv_inst_info (clas, tycon, tyvars, _) theta
423 = InstInfo clas tyvars (applyTyCon tycon (map mkTyVarTy tyvars))
425 theta -- Blarg. This is the dfun_theta slot,
426 -- which is needed by buildInstanceEnv;
427 -- This works ok for solving the eqns, and
428 -- gen_eqns sets it to its final value
429 -- (incl super class dicts) before we
430 -- finally return it.
432 (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
433 (panic "add_soln:binds") (panic "add_soln:from_here")
434 (panic "add_soln:modname") mkGeneratedSrcLoc
435 (panic "add_soln:upragmas")
437 bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
439 bottom = panic "add_soln"
443 %************************************************************************
445 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
447 %************************************************************************
449 After all the trouble to figure out the required context for the
450 derived instance declarations, all that's left is to chug along to
451 produce them. They will then be shoved into @tcInstDecls2@, which
452 will do all its usual business.
454 There are lots of possibilities for code to generate. Here are
455 various general remarks.
460 We want derived instances of @Eq@ and @Ord@ (both v common) to be
461 ``you-couldn't-do-better-by-hand'' efficient.
464 Deriving @Text@---also pretty common, usually just for
465 @show@---should also be reasonable good code.
468 Deriving for the other classes isn't that common or that big a deal.
475 Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method.
478 Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too.
481 We {\em normally} generated code only for the non-defaulted methods;
482 there are some exceptions for @Eq@ and (especially) @Ord@...
485 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
486 constructor's numeric (@Int#@) tag. These are generated by
487 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
488 these is around is given by @hasCon2TagFun@.
491 The examples under the different sections below will make this
495 Much less often (really just for deriving @Ix@), we use a
496 @_tag2con_<tycon>@ function. See the examples.
499 We use Pass~4 of the renamer!!! Reason: we're supposed to be
500 producing @RenamedMonoBinds@ for the methods, but that means
501 producing correctly-uniquified code on the fly. This is entirely
502 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
503 So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through
504 the renamer. What a great hack!
508 gen_inst_info :: FAST_STRING -- Module name
509 -> [RenamedFixityDecl] -- all known fixities;
510 -- may be needed for Text
511 -> GlobalNameMappers -- lookup stuff for names we may use
512 -> InstInfo -- the main stuff to work on
513 -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
515 gen_inst_info modname fixities deriver_name_funs
516 info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
518 -- Generate the various instance-related Ids
520 True {-from_here-} modname
524 [{-no user pragmas-}]
525 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
527 -- Generate the bindings for the new instance declaration,
528 -- rename it, and check for errors
530 (tycon,_,_) = getAppDataTyCon ty
533 | clas_key == eqClassKey = gen_Eq_binds tycon
534 | clas_key == showClassKey = gen_Show_binds fixities tycon
535 | clas_key == ordClassKey = gen_Ord_binds tycon
536 | clas_key == enumClassKey = gen_Enum_binds tycon
537 | clas_key == ixClassKey = gen_Ix_binds tycon
538 | clas_key == readClassKey = gen_Read_binds fixities tycon
539 | clas_key == binaryClassKey = gen_Binary_binds tycon
540 | otherwise = panic "gen_inst_info:bad derived class"
542 rn4MtoTcM deriver_name_funs (
543 rnMethodBinds clas_Name proto_mbinds
544 ) `thenNF_Tc` \ (mbinds, errs) ->
546 if not (isEmptyBag errs) then
547 pprPanic "gen_inst_info:renamer errs!\n"
548 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
550 --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
554 from_here = isLocallyDefined tycon -- If so, then from here
556 returnTc (InstInfo clas tyvars ty inst_decl_theta
557 dfun_theta dfun_id const_meth_ids
558 (if from_here then mbinds else EmptyMonoBinds)
559 from_here modname locn [])
561 clas_key = getClassKey clas
563 = let (mod, nm) = getOrigName clas in
564 ClassName clas_key (mkPreludeCoreName mod nm) []
567 %************************************************************************
569 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
571 %************************************************************************
575 con2tag_Foo :: Foo ... -> Int#
576 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
577 maxtag_Foo :: Int -- ditto (NB: not unboxed)
580 gen_tag_n_con_binds :: GlobalNameMappers
581 -> [(ProtoName, Name, TyCon, TagThingWanted)]
582 -> TcM s RenamedHsBinds
584 gen_tag_n_con_binds deriver_name_funs nm_alist_etc
586 proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
587 proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
590 rn4MtoTcM deriver_name_funs (
591 rnTopBinds (SingleBind (RecBind proto_mbinds))
592 ) `thenNF_Tc` \ (binds, errs) ->
594 if not (isEmptyBag errs) then
595 panic "gen_inst_info:renamer errs (2)!"
600 %************************************************************************
602 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
604 %************************************************************************
606 We have a @con2tag@ function for a tycon if:
609 We're deriving @Eq@ and the tycon has nullary data constructors.
612 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
616 We have a @tag2con@ function for a tycon if:
619 We're deriving @Enum@, or @Ix@ (enum type only???)
622 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
625 gen_taggery_Names :: [DerivEqn]
626 -> TcM s [(ProtoName, Name, -- for an assoc list
627 TyCon, -- related tycon
630 gen_taggery_Names eqns
632 all_tycons = [ tc | (_, tc, _, _) <- eqns ]
633 (tycons_of_interest, _) = removeDups cmp all_tycons
635 foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
636 foldlTc do_tag2con names_so_far tycons_of_interest
638 do_con2tag acc_Names tycon
639 = if (we_are_deriving eqClassKey tycon
640 && any ( (== 0).getDataConArity ) (getTyConDataCons tycon))
641 || (we_are_deriving ordClassKey tycon
642 && not (maybeToBool (maybeTyConSingleCon tycon)))
643 || (we_are_deriving enumClassKey tycon)
644 || (we_are_deriving ixClassKey tycon)
646 tcGetUnique `thenNF_Tc` ( \ u ->
647 returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
652 do_tag2con acc_Names tycon
653 = if (we_are_deriving enumClassKey tycon)
654 || (we_are_deriving ixClassKey tycon)
656 tcGetUnique `thenNF_Tc` \ u1 ->
657 tcGetUnique `thenNF_Tc` \ u2 ->
658 returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con)
659 : (maxtag_PN tycon, ValName u2 (maxtag_FN tycon), tycon, GenMaxTag)
664 we_are_deriving clas_key tycon
665 = is_in_eqns clas_key tycon eqns
667 is_in_eqns clas_key tycon [] = False
668 is_in_eqns clas_key tycon ((c,t,_,_):eqns)
669 = (clas_key == getClassKey c && tycon == t)
670 || is_in_eqns clas_key tycon eqns
675 derivingEnumErr :: TyCon -> TcError
676 derivingEnumErr tycon
677 = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
678 ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
680 derivingIxErr :: TyCon -> TcError
682 = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
683 ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )