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 TcKind ( TcKind )
28 --import TcGenDeriv -- Deriv stuff
29 import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
30 import TcSimplify ( tcSimplifyThetas )
33 import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
34 --import RnBinds4 ( rnMethodBinds, rnTopBinds )
36 import Bag ( Bag, isEmptyBag, unionBags, listToBag )
37 import Class ( GenClass, getClassKey )
38 import CmdLineOpts ( opt_CompilingPrelude )
39 import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
40 import Id ( dataConSig, dataConArity )
41 import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
42 --import Name ( Name(..) )
44 import PprType ( GenType, GenTyVar, GenClass, TyCon )
47 import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
48 import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
49 maybeTyConSingleCon, isEnumerationTyCon, TyCon )
50 import Type ( GenType(..), TauType(..), mkTyVarTys, 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 :: Module -- 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.
166 tcDeriving = panic "tcDeriving: ToDo LATER"
169 tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
170 = -- Fish the "deriving"-related information out of the TcEnv
171 -- and make the necessary "equations".
172 makeDerivEqns `thenTc` \ eqns ->
174 -- Take the equation list and solve it, to deliver a list of
175 -- solutions, a.k.a. the contexts for the instance decls
176 -- required for the corresponding equations.
177 solveDerivEqns inst_decl_infos_in eqns
178 `thenTc` \ new_inst_infos ->
180 -- Now augment the InstInfos, adding in the rather boring
181 -- actual-code-to-do-the-methods binds. We may also need to
182 -- generate extra not-one-inst-decl-specific binds, notably
183 -- "con2tag" and/or "tag2con" functions. We do these
186 gen_taggery_Names eqns `thenTc` \ nm_alist_etc ->
188 nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
190 -- We have the renamer's final "name funs" in our hands
191 -- (they were passed in). So we can handle ProtoNames
192 -- that refer to anything "out there". But our generated
193 -- code may also mention "con2tag" (etc.). So we need
194 -- to augment to "name funs" to include those.
195 (rn_val_gnf, rn_tc_gnf) = renamer_name_funs
197 deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of
199 Nothing -> rn_val_gnf pname
201 deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
203 assoc_maybe [] _ = Nothing
204 assoc_maybe ((k,v) : vs) key
205 = if k `eqProtoName` key then Just v else assoc_maybe vs key
207 gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
209 mapTc (gen_inst_info maybe_mod fixities deriver_name_funs) new_inst_infos
210 `thenTc` \ really_new_inst_infos ->
212 returnTc (listToBag really_new_inst_infos,
214 ddump_deriving really_new_inst_infos extra_binds)
216 maybe_mod = if opt_CompilingPrelude then Nothing else Just mod_name
218 ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
220 ddump_deriving inst_infos extra_binds sty
221 = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
223 pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
224 = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
229 %************************************************************************
231 \subsection[TcDeriv-eqns]{Forming the equations}
233 %************************************************************************
235 @makeDerivEqns@ fishes around to find the info about needed derived
236 instances. Complicating factors:
239 We can only derive @Enum@ if the data type is an enumeration
240 type (all nullary data constructors).
243 We can only derive @Ix@ if the data type is an enumeration {\em
244 or} has just one data constructor (e.g., tuples).
247 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
251 makeDerivEqns :: TcM s [DerivEqn]
254 = tcGetEnv `thenNF_Tc` \ env ->
256 tycons = getEnv_TyCons env
257 think_about_deriving = need_deriving tycons
259 mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
261 (derive_these, _) = removeDups cmp_deriv think_about_deriving
262 eqns = map mk_eqn derive_these
266 ------------------------------------------------------------------
267 need_deriving :: [TyCon] -> [(Class, TyCon)]
268 -- find the tycons that have `deriving' clauses
270 need_deriving tycons_to_consider
271 = foldr ( \ tycon acc ->
272 case (tyConDerivings tycon) of
274 cs -> [ (clas,tycon) | clas <- cs ] ++ acc
279 ------------------------------------------------------------------
280 chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
281 chk_out whole_deriving_list this_one@(clas, tycon)
283 clas_key = getClassKey clas
286 -- Are things OK for deriving Enum (if appropriate)?
287 checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon))
288 (derivingEnumErr tycon) `thenTc_`
290 -- Are things OK for deriving Ix (if appropriate)?
291 checkTc (clas_key == ixClassKey
292 && not (isEnumerationTyCon tycon
293 || maybeToBool (maybeTyConSingleCon tycon)))
294 (derivingIxErr tycon)
296 ------------------------------------------------------------------
297 cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
298 cmp_deriv (c1, t1) (c2, t2)
299 = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
301 ------------------------------------------------------------------
302 mk_eqn :: (Class, TyCon) -> DerivEqn
303 -- we swizzle the tyvars and datacons out of the tycon
304 -- to make the rest of the equation
307 = (clas, tycon, tyvars, constraints)
309 tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
310 tyvar_tys = mkTyVarTys tyvars
311 data_cons = tyConDataCons tycon
312 constraints = concat (map mk_constraints data_cons)
314 mk_constraints data_con
315 = [ (clas, instantiateTy inst_env arg_ty)
317 not (isPrimType arg_ty) -- No constraints for primitive types
320 (con_tyvars, _, arg_tys, _) = dataConSig data_con
321 inst_env = con_tyvars `zipEqual` tyvar_tys
322 -- same number of tyvars in data constr and type constr!
325 %************************************************************************
327 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
329 %************************************************************************
331 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
332 terms, which is the final correct RHS for the corresponding original
336 Each (k,UniTyVarTemplate tv) in a solution constrains only a type
340 The (k,UniTyVarTemplate tv) pairs in a solution are canonically
341 ordered by sorting on type varible, tv, (major key) and then class, k,
346 solveDerivEqns :: Bag InstInfo
348 -> TcM s [InstInfo] -- Solns in same order as eqns.
349 -- This bunch is Absolutely minimal...
351 solveDerivEqns inst_decl_infos_in orig_eqns
352 = iterateDeriv initial_solutions
354 -- The initial solutions for the equations claim that each
355 -- instance has an empty context; this solution is certainly
356 -- in canonical form.
357 initial_solutions :: [DerivSoln]
358 initial_solutions = [ [] | _ <- orig_eqns ]
360 -- iterateDeriv calculates the next batch of solutions,
361 -- compares it with the current one; finishes if they are the
362 -- same, otherwise recurses with the new solutions.
364 iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
366 iterateDeriv current_solns
367 = -- Extend the inst info from the explicit instance decls
368 -- with the current set of solutions, giving a
370 add_solns inst_decl_infos_in orig_eqns current_solns
371 `thenTc` \ (new_inst_infos, inst_mapper) ->
373 -- Simplify each RHS, using a DerivingOrigin containing an
374 -- inst_mapper reflecting the previous solution
376 mk_deriv_origin clas ty
377 = DerivingOrigin inst_mapper clas tycon
379 (tycon,_) = getAppTyCon ty
381 listTc [ tcSimplifyThetas mk_deriv_origin rhs
382 | (_, _, _, rhs) <- orig_eqns
383 ] `thenTc` \ next_solns ->
385 -- Canonicalise the solutions, so they compare nicely
386 let canonicalised_next_solns
387 = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
389 if current_solns `eq_solns` canonicalised_next_solns then
390 returnTc new_inst_infos
392 iterateDeriv canonicalised_next_solns
395 ------------------------------------------------------------------
396 lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False }
397 eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
398 cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
399 cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
400 = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
402 cmp_rhs other_1 other_2
403 = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
409 add_solns :: FAST_STRING
410 -> Bag InstInfo -- The global, non-derived ones
411 -> [DerivEqn] -> [DerivSoln]
412 -> TcM s ([InstInfo], -- The new, derived ones
414 -- the eqns and solns move "in lockstep"; we have the eqns
415 -- because we need the LHS info for addClassInstance.
417 add_solns inst_infos_in eqns solns
418 = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
419 returnTc (new_inst_infos, inst_mapper)
421 new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns
423 all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
425 mk_deriv_inst_info (clas, tycon, tyvars, _) theta
426 = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
428 theta -- Blarg. This is the dfun_theta slot,
429 -- which is needed by buildInstanceEnv;
430 -- This works ok for solving the eqns, and
431 -- gen_eqns sets it to its final value
432 -- (incl super class dicts) before we
433 -- finally return it.
435 (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
436 (panic "add_soln:binds") (panic "add_soln:from_here")
437 (panic "add_soln:modname") mkGeneratedSrcLoc
438 (panic "add_soln:upragmas")
440 bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
442 bottom = panic "add_soln"
446 %************************************************************************
448 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
450 %************************************************************************
452 After all the trouble to figure out the required context for the
453 derived instance declarations, all that's left is to chug along to
454 produce them. They will then be shoved into @tcInstDecls2@, which
455 will do all its usual business.
457 There are lots of possibilities for code to generate. Here are
458 various general remarks.
463 We want derived instances of @Eq@ and @Ord@ (both v common) to be
464 ``you-couldn't-do-better-by-hand'' efficient.
467 Deriving @Text@---also pretty common, usually just for
468 @show@---should also be reasonable good code.
471 Deriving for the other classes isn't that common or that big a deal.
478 Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method.
481 Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too.
484 We {\em normally} generated code only for the non-defaulted methods;
485 there are some exceptions for @Eq@ and (especially) @Ord@...
488 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
489 constructor's numeric (@Int#@) tag. These are generated by
490 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
491 these is around is given by @hasCon2TagFun@.
494 The examples under the different sections below will make this
498 Much less often (really just for deriving @Ix@), we use a
499 @_tag2con_<tycon>@ function. See the examples.
502 We use Pass~4 of the renamer!!! Reason: we're supposed to be
503 producing @RenamedMonoBinds@ for the methods, but that means
504 producing correctly-uniquified code on the fly. This is entirely
505 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
506 So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through
507 the renamer. What a great hack!
511 gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
512 -> [RenamedFixityDecl] -- all known fixities;
513 -- may be needed for Text
514 -> GlobalNameMappers -- lookup stuff for names we may use
515 -> InstInfo -- the main stuff to work on
516 -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
518 gen_inst_info modname fixities deriver_name_funs
519 info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
521 -- Generate the various instance-related Ids
523 True {-from_here-} modname
527 [{-no user pragmas-}]
528 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
530 -- Generate the bindings for the new instance declaration,
531 -- rename it, and check for errors
533 (tycon,_,_) = getAppDataTyCon ty
536 | clas_key == eqClassKey = gen_Eq_binds tycon
537 | clas_key == showClassKey = gen_Show_binds fixities tycon
538 | clas_key == ordClassKey = gen_Ord_binds tycon
539 | clas_key == enumClassKey = gen_Enum_binds tycon
540 | clas_key == ixClassKey = gen_Ix_binds tycon
541 | clas_key == readClassKey = gen_Read_binds fixities tycon
542 | clas_key == binaryClassKey = gen_Binary_binds tycon
543 | otherwise = panic "gen_inst_info:bad derived class"
545 rn4MtoTcM deriver_name_funs (
546 rnMethodBinds clas_Name proto_mbinds
547 ) `thenNF_Tc` \ (mbinds, errs) ->
549 if not (isEmptyBag errs) then
550 pprPanic "gen_inst_info:renamer errs!\n"
551 (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
553 --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
557 from_here = isLocallyDefined tycon -- If so, then from here
559 returnTc (InstInfo clas tyvars ty inst_decl_theta
560 dfun_theta dfun_id const_meth_ids
561 (if from_here then mbinds else EmptyMonoBinds)
562 from_here modname locn [])
564 clas_key = getClassKey clas
566 = let (mod, nm) = getOrigName clas in
567 ClassName clas_key (mkPreludeCoreName mod nm) []
570 %************************************************************************
572 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
574 %************************************************************************
578 con2tag_Foo :: Foo ... -> Int#
579 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
580 maxtag_Foo :: Int -- ditto (NB: not unboxed)
583 gen_tag_n_con_binds :: GlobalNameMappers
584 -> [(RdrName, RnName, TyCon, TagThingWanted)]
585 -> TcM s RenamedHsBinds
587 gen_tag_n_con_binds deriver_name_funs nm_alist_etc
589 proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
590 proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
593 rn4MtoTcM deriver_name_funs (
594 rnTopBinds (SingleBind (RecBind proto_mbinds))
595 ) `thenNF_Tc` \ (binds, errs) ->
597 if not (isEmptyBag errs) then
598 panic "gen_inst_info:renamer errs (2)!"
603 %************************************************************************
605 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
607 %************************************************************************
609 We have a @con2tag@ function for a tycon if:
612 We're deriving @Eq@ and the tycon has nullary data constructors.
615 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
619 We have a @tag2con@ function for a tycon if:
622 We're deriving @Enum@, or @Ix@ (enum type only???)
625 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
628 gen_taggery_Names :: [DerivEqn]
629 -> TcM s [(RdrName, RnName, -- for an assoc list
630 TyCon, -- related tycon
633 gen_taggery_Names eqns
635 all_tycons = [ tc | (_, tc, _, _) <- eqns ]
636 (tycons_of_interest, _) = removeDups cmp all_tycons
638 foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
639 foldlTc do_tag2con names_so_far tycons_of_interest
641 do_con2tag acc_Names tycon
642 = if (we_are_deriving eqClassKey tycon
643 && any ( (== 0).dataConArity ) (tyConDataCons tycon))
644 || (we_are_deriving ordClassKey tycon
645 && not (maybeToBool (maybeTyConSingleCon tycon)))
646 || (we_are_deriving enumClassKey tycon)
647 || (we_are_deriving ixClassKey tycon)
649 tcGetUnique `thenNF_Tc` ( \ u ->
650 returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
655 do_tag2con acc_Names tycon
656 = if (we_are_deriving enumClassKey tycon)
657 || (we_are_deriving ixClassKey tycon)
659 tcGetUnique `thenNF_Tc` \ u1 ->
660 tcGetUnique `thenNF_Tc` \ u2 ->
661 returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con)
662 : (maxtag_PN tycon, ValName u2 (maxtag_FN tycon), tycon, GenMaxTag)
667 we_are_deriving clas_key tycon
668 = is_in_eqns clas_key tycon eqns
670 is_in_eqns clas_key tycon [] = False
671 is_in_eqns clas_key tycon ((c,t,_,_):eqns)
672 = (clas_key == getClassKey c && tycon == t)
673 || is_in_eqns clas_key tycon eqns
678 derivingEnumErr :: TyCon -> Error
679 derivingEnumErr tycon
680 = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
681 ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
683 derivingIxErr :: TyCon -> Error
685 = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
686 ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )