2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcSimplify]{TcSimplify}
10 tcSimplifyInfer, tcSimplifyInferCheck,
11 tcSimplifyCheck, tcSimplifyRestricted,
12 tcSimplifyToDicts, tcSimplifyIPs,
13 tcSimplifyTop, tcSimplifyInteractive,
16 tcSimplifyDeriv, tcSimplifyDefault,
20 #include "HsVersions.h"
22 import {-# SOURCE #-} TcUnify( unifyTauTy )
24 import HsSyn ( HsBind(..), LHsBinds, HsExpr(..), LHsExpr )
25 import TcHsSyn ( TcId, TcDictBinds, mkHsApp, mkHsTyApp, mkHsDictApp )
28 import Inst ( lookupInst, LookupInstResult(..),
29 tyVarsOfInst, fdPredsOfInsts, fdPredsOfInst, newDicts,
30 isDict, isClassDict, isLinearInst, linearInstType,
31 isStdClassTyVarDict, isMethodFor, isMethod,
32 instToId, tyVarsOfInsts, cloneDict,
33 ipNamesOfInsts, ipNamesOfInst, dictPred,
35 newDictsFromOld, tcInstClassOp,
36 getDictClassTys, isTyVarDict,
37 instLoc, zonkInst, tidyInsts, tidyMoreInsts,
38 Inst, pprInsts, pprInstsInFull, tcGetInstEnvs,
39 isIPDict, isInheritableInst, pprDFuns
41 import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals )
42 import InstEnv ( lookupInstEnv, classInstEnv )
43 import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
44 import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
45 mkClassPred, isOverloadedTy, mkTyConApp,
46 mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
47 tyVarsOfPred, tcEqType )
48 import Id ( idType, mkUserLocal )
50 import Name ( getOccName, getSrcLoc )
51 import NameSet ( NameSet, mkNameSet, elemNameSet )
52 import Class ( classBigSig, classKey )
53 import FunDeps ( oclose, grow, improve, pprEquationDoc )
54 import PrelInfo ( isNumericClass )
55 import PrelNames ( splitName, fstName, sndName, integerTyConName,
56 showClassKey, eqClassKey, ordClassKey )
57 import Subst ( mkTopTyVarSubst, substTheta, substTy )
58 import TysWiredIn ( pairTyCon, doubleTy )
59 import ErrUtils ( Message )
61 import VarEnv ( TidyEnv )
65 import ListSetOps ( equivClasses )
66 import Util ( zipEqual, isSingleton )
67 import List ( partition )
68 import SrcLoc ( Located(..) )
73 %************************************************************************
77 %************************************************************************
79 --------------------------------------
80 Notes on quantification
81 --------------------------------------
83 Suppose we are about to do a generalisation step.
88 C the constraints from that RHS
90 The game is to figure out
92 Q the set of type variables over which to quantify
93 Ct the constraints we will *not* quantify over
94 Cq the constraints we will quantify over
96 So we're going to infer the type
100 and float the constraints Ct further outwards.
102 Here are the things that *must* be true:
104 (A) Q intersect fv(G) = EMPTY limits how big Q can be
105 (B) Q superset fv(Cq union T) \ oclose(fv(G),C) limits how small Q can be
107 (A) says we can't quantify over a variable that's free in the
108 environment. (B) says we must quantify over all the truly free
109 variables in T, else we won't get a sufficiently general type. We do
110 not *need* to quantify over any variable that is fixed by the free
111 vars of the environment G.
113 BETWEEN THESE TWO BOUNDS, ANY Q WILL DO!
115 Example: class H x y | x->y where ...
117 fv(G) = {a} C = {H a b, H c d}
120 (A) Q intersect {a} is empty
121 (B) Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d}
123 So Q can be {c,d}, {b,c,d}
125 Other things being equal, however, we'd like to quantify over as few
126 variables as possible: smaller types, fewer type applications, more
127 constraints can get into Ct instead of Cq.
130 -----------------------------------------
133 fv(T) the free type vars of T
135 oclose(vs,C) The result of extending the set of tyvars vs
136 using the functional dependencies from C
138 grow(vs,C) The result of extend the set of tyvars vs
139 using all conceivable links from C.
141 E.g. vs = {a}, C = {H [a] b, K (b,Int) c, Eq e}
142 Then grow(vs,C) = {a,b,c}
144 Note that grow(vs,C) `superset` grow(vs,simplify(C))
145 That is, simplfication can only shrink the result of grow.
148 oclose is conservative one way: v `elem` oclose(vs,C) => v is definitely fixed by vs
149 grow is conservative the other way: if v might be fixed by vs => v `elem` grow(vs,C)
152 -----------------------------------------
156 Here's a good way to choose Q:
158 Q = grow( fv(T), C ) \ oclose( fv(G), C )
160 That is, quantify over all variable that that MIGHT be fixed by the
161 call site (which influences T), but which aren't DEFINITELY fixed by
162 G. This choice definitely quantifies over enough type variables,
163 albeit perhaps too many.
165 Why grow( fv(T), C ) rather than fv(T)? Consider
167 class H x y | x->y where ...
172 If we used fv(T) = {c} we'd get the type
174 forall c. H c d => c -> b
176 And then if the fn was called at several different c's, each of
177 which fixed d differently, we'd get a unification error, because
178 d isn't quantified. Solution: quantify d. So we must quantify
179 everything that might be influenced by c.
181 Why not oclose( fv(T), C )? Because we might not be able to see
182 all the functional dependencies yet:
184 class H x y | x->y where ...
185 instance H x y => Eq (T x y) where ...
190 Now oclose(fv(T),C) = {c}, because the functional dependency isn't
191 apparent yet, and that's wrong. We must really quantify over d too.
194 There really isn't any point in quantifying over any more than
195 grow( fv(T), C ), because the call sites can't possibly influence
196 any other type variables.
200 --------------------------------------
202 --------------------------------------
204 It's very hard to be certain when a type is ambiguous. Consider
208 instance H x y => K (x,y)
210 Is this type ambiguous?
211 forall a b. (K (a,b), Eq b) => a -> a
213 Looks like it! But if we simplify (K (a,b)) we get (H a b) and
214 now we see that a fixes b. So we can't tell about ambiguity for sure
215 without doing a full simplification. And even that isn't possible if
216 the context has some free vars that may get unified. Urgle!
218 Here's another example: is this ambiguous?
219 forall a b. Eq (T b) => a -> a
220 Not if there's an insance decl (with no context)
221 instance Eq (T b) where ...
223 You may say of this example that we should use the instance decl right
224 away, but you can't always do that:
226 class J a b where ...
227 instance J Int b where ...
229 f :: forall a b. J a b => a -> a
231 (Notice: no functional dependency in J's class decl.)
232 Here f's type is perfectly fine, provided f is only called at Int.
233 It's premature to complain when meeting f's signature, or even
234 when inferring a type for f.
238 However, we don't *need* to report ambiguity right away. It'll always
239 show up at the call site.... and eventually at main, which needs special
240 treatment. Nevertheless, reporting ambiguity promptly is an excellent thing.
242 So here's the plan. We WARN about probable ambiguity if
244 fv(Cq) is not a subset of oclose(fv(T) union fv(G), C)
246 (all tested before quantification).
247 That is, all the type variables in Cq must be fixed by the the variables
248 in the environment, or by the variables in the type.
250 Notice that we union before calling oclose. Here's an example:
252 class J a b c | a b -> c
256 forall b c. (J a b c) => b -> b
258 Only if we union {a} from G with {b} from T before using oclose,
259 do we see that c is fixed.
261 It's a bit vague exactly which C we should use for this oclose call. If we
262 don't fix enough variables we might complain when we shouldn't (see
263 the above nasty example). Nothing will be perfect. That's why we can
264 only issue a warning.
267 Can we ever be *certain* about ambiguity? Yes: if there's a constraint
269 c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY
271 then c is a "bubble"; there's no way it can ever improve, and it's
272 certainly ambiguous. UNLESS it is a constant (sigh). And what about
277 instance H x y => K (x,y)
279 Is this type ambiguous?
280 forall a b. (K (a,b), Eq b) => a -> a
282 Urk. The (Eq b) looks "definitely ambiguous" but it isn't. What we are after
283 is a "bubble" that's a set of constraints
285 Cq = Ca union Cq' st fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY
287 Hence another idea. To decide Q start with fv(T) and grow it
288 by transitive closure in Cq (no functional dependencies involved).
289 Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
290 The definitely-ambiguous can then float out, and get smashed at top level
291 (which squashes out the constants, like Eq (T a) above)
294 --------------------------------------
295 Notes on principal types
296 --------------------------------------
301 f x = let g y = op (y::Int) in True
303 Here the principal type of f is (forall a. a->a)
304 but we'll produce the non-principal type
305 f :: forall a. C Int => a -> a
308 --------------------------------------
309 Notes on implicit parameters
310 --------------------------------------
312 Question 1: can we "inherit" implicit parameters
313 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
318 where f is *not* a top-level binding.
319 From the RHS of f we'll get the constraint (?y::Int).
320 There are two types we might infer for f:
324 (so we get ?y from the context of f's definition), or
326 f :: (?y::Int) => Int -> Int
328 At first you might think the first was better, becuase then
329 ?y behaves like a free variable of the definition, rather than
330 having to be passed at each call site. But of course, the WHOLE
331 IDEA is that ?y should be passed at each call site (that's what
332 dynamic binding means) so we'd better infer the second.
334 BOTTOM LINE: when *inferring types* you *must* quantify
335 over implicit parameters. See the predicate isFreeWhenInferring.
338 Question 2: type signatures
339 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
340 BUT WATCH OUT: When you supply a type signature, we can't force you
341 to quantify over implicit parameters. For example:
345 This is perfectly reasonable. We do not want to insist on
347 (?x + 1) :: (?x::Int => Int)
349 That would be silly. Here, the definition site *is* the occurrence site,
350 so the above strictures don't apply. Hence the difference between
351 tcSimplifyCheck (which *does* allow implicit paramters to be inherited)
352 and tcSimplifyCheckBind (which does not).
354 What about when you supply a type signature for a binding?
355 Is it legal to give the following explicit, user type
356 signature to f, thus:
361 At first sight this seems reasonable, but it has the nasty property
362 that adding a type signature changes the dynamic semantics.
365 (let f x = (x::Int) + ?y
366 in (f 3, f 3 with ?y=5)) with ?y = 6
372 in (f 3, f 3 with ?y=5)) with ?y = 6
376 Indeed, simply inlining f (at the Haskell source level) would change the
379 Nevertheless, as Launchbury says (email Oct 01) we can't really give the
380 semantics for a Haskell program without knowing its typing, so if you
381 change the typing you may change the semantics.
383 To make things consistent in all cases where we are *checking* against
384 a supplied signature (as opposed to inferring a type), we adopt the
387 a signature does not need to quantify over implicit params.
389 [This represents a (rather marginal) change of policy since GHC 5.02,
390 which *required* an explicit signature to quantify over all implicit
391 params for the reasons mentioned above.]
393 But that raises a new question. Consider
395 Given (signature) ?x::Int
396 Wanted (inferred) ?x::Int, ?y::Bool
398 Clearly we want to discharge the ?x and float the ?y out. But
399 what is the criterion that distinguishes them? Clearly it isn't
400 what free type variables they have. The Right Thing seems to be
401 to float a constraint that
402 neither mentions any of the quantified type variables
403 nor any of the quantified implicit parameters
405 See the predicate isFreeWhenChecking.
408 Question 3: monomorphism
409 ~~~~~~~~~~~~~~~~~~~~~~~~
410 There's a nasty corner case when the monomorphism restriction bites:
414 The argument above suggests that we *must* generalise
415 over the ?y parameter, to get
416 z :: (?y::Int) => Int,
417 but the monomorphism restriction says that we *must not*, giving
419 Why does the momomorphism restriction say this? Because if you have
421 let z = x + ?y in z+z
423 you might not expect the addition to be done twice --- but it will if
424 we follow the argument of Question 2 and generalise over ?y.
430 (A) Always generalise over implicit parameters
431 Bindings that fall under the monomorphism restriction can't
435 * Inlining remains valid
436 * No unexpected loss of sharing
437 * But simple bindings like
439 will be rejected, unless you add an explicit type signature
440 (to avoid the monomorphism restriction)
441 z :: (?y::Int) => Int
443 This seems unacceptable
445 (B) Monomorphism restriction "wins"
446 Bindings that fall under the monomorphism restriction can't
448 Always generalise over implicit parameters *except* for bindings
449 that fall under the monomorphism restriction
452 * Inlining isn't valid in general
453 * No unexpected loss of sharing
454 * Simple bindings like
456 accepted (get value of ?y from binding site)
458 (C) Always generalise over implicit parameters
459 Bindings that fall under the monomorphism restriction can't
460 be generalised, EXCEPT for implicit parameters
462 * Inlining remains valid
463 * Unexpected loss of sharing (from the extra generalisation)
464 * Simple bindings like
466 accepted (get value of ?y from occurrence sites)
471 None of these choices seems very satisfactory. But at least we should
472 decide which we want to do.
474 It's really not clear what is the Right Thing To Do. If you see
478 would you expect the value of ?y to be got from the *occurrence sites*
479 of 'z', or from the valuue of ?y at the *definition* of 'z'? In the
480 case of function definitions, the answer is clearly the former, but
481 less so in the case of non-fucntion definitions. On the other hand,
482 if we say that we get the value of ?y from the definition site of 'z',
483 then inlining 'z' might change the semantics of the program.
485 Choice (C) really says "the monomorphism restriction doesn't apply
486 to implicit parameters". Which is fine, but remember that every
487 innocent binding 'x = ...' that mentions an implicit parameter in
488 the RHS becomes a *function* of that parameter, called at each
489 use of 'x'. Now, the chances are that there are no intervening 'with'
490 clauses that bind ?y, so a decent compiler should common up all
491 those function calls. So I think I strongly favour (C). Indeed,
492 one could make a similar argument for abolishing the monomorphism
493 restriction altogether.
495 BOTTOM LINE: we choose (B) at present. See tcSimplifyRestricted
499 %************************************************************************
501 \subsection{tcSimplifyInfer}
503 %************************************************************************
505 tcSimplify is called when we *inferring* a type. Here's the overall game plan:
507 1. Compute Q = grow( fvs(T), C )
509 2. Partition C based on Q into Ct and Cq. Notice that ambiguous
510 predicates will end up in Ct; we deal with them at the top level
512 3. Try improvement, using functional dependencies
514 4. If Step 3 did any unification, repeat from step 1
515 (Unification can change the result of 'grow'.)
517 Note: we don't reduce dictionaries in step 2. For example, if we have
518 Eq (a,b), we don't simplify to (Eq a, Eq b). So Q won't be different
519 after step 2. However note that we may therefore quantify over more
520 type variables than we absolutely have to.
522 For the guts, we need a loop, that alternates context reduction and
523 improvement with unification. E.g. Suppose we have
525 class C x y | x->y where ...
527 and tcSimplify is called with:
529 Then improvement unifies a with b, giving
532 If we need to unify anything, we rattle round the whole thing all over
539 -> TcTyVarSet -- fv(T); type vars
541 -> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
542 TcDictBinds, -- Bindings
543 [TcId]) -- Dict Ids that must be bound here (zonked)
544 -- Any free (escaping) Insts are tossed into the environment
549 tcSimplifyInfer doc tau_tvs wanted_lie
550 = inferLoop doc (varSetElems tau_tvs)
551 wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
553 extendLIEs frees `thenM_`
554 returnM (qtvs, binds, map instToId irreds)
556 inferLoop doc tau_tvs wanteds
558 zonkTcTyVarsAndFV tau_tvs `thenM` \ tau_tvs' ->
559 mappM zonkInst wanteds `thenM` \ wanteds' ->
560 tcGetGlobalTyVars `thenM` \ gbl_tvs ->
562 preds = fdPredsOfInsts wanteds'
563 qtvs = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
566 | isFreeWhenInferring qtvs inst = Free
567 | isClassDict inst = DontReduceUnlessConstant -- Dicts
568 | otherwise = ReduceMe -- Lits and Methods
570 traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_`
572 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
575 if no_improvement then
576 returnM (varSetElems qtvs, frees, binds, irreds)
578 -- If improvement did some unification, we go round again. There
579 -- are two subtleties:
580 -- a) We start again with irreds, not wanteds
581 -- Using an instance decl might have introduced a fresh type variable
582 -- which might have been unified, so we'd get an infinite loop
583 -- if we started again with wanteds! See example [LOOP]
585 -- b) It's also essential to re-process frees, because unification
586 -- might mean that a type variable that looked free isn't now.
588 -- Hence the (irreds ++ frees)
590 -- However, NOTICE that when we are done, we might have some bindings, but
591 -- the final qtvs might be empty. See [NO TYVARS] below.
593 inferLoop doc tau_tvs (irreds ++ frees) `thenM` \ (qtvs1, frees1, binds1, irreds1) ->
594 returnM (qtvs1, frees1, binds `unionBags` binds1, irreds1)
599 class If b t e r | b t e -> r
602 class Lte a b c | a b -> c where lte :: a -> b -> c
604 instance (Lte a b l,If l b a c) => Max a b c
606 Wanted: Max Z (S x) y
608 Then we'll reduce using the Max instance to:
609 (Lte Z (S x) l, If l (S x) Z y)
610 and improve by binding l->T, after which we can do some reduction
611 on both the Lte and If constraints. What we *can't* do is start again
612 with (Max Z (S x) y)!
616 class Y a b | a -> b where
619 instance Y [[a]] a where
622 k :: X a -> X a -> X a
624 g :: Num a => [X a] -> [X a]
627 h ys = ys ++ map (k (y [[0]])) xs
629 The excitement comes when simplifying the bindings for h. Initially
630 try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
631 From this we get t1:=:t2, but also various bindings. We can't forget
632 the bindings (because of [LOOP]), but in fact t1 is what g is
635 The net effect of [NO TYVARS]
638 isFreeWhenInferring :: TyVarSet -> Inst -> Bool
639 isFreeWhenInferring qtvs inst
640 = isFreeWrtTyVars qtvs inst -- Constrains no quantified vars
641 && isInheritableInst inst -- And no implicit parameter involved
642 -- (see "Notes on implicit parameters")
644 isFreeWhenChecking :: TyVarSet -- Quantified tyvars
645 -> NameSet -- Quantified implicit parameters
647 isFreeWhenChecking qtvs ips inst
648 = isFreeWrtTyVars qtvs inst
649 && isFreeWrtIPs ips inst
651 isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
652 isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
656 %************************************************************************
658 \subsection{tcSimplifyCheck}
660 %************************************************************************
662 @tcSimplifyCheck@ is used when we know exactly the set of variables
663 we are going to quantify over. For example, a class or instance declaration.
668 -> [TcTyVar] -- Quantify over these
671 -> TcM TcDictBinds -- Bindings
673 -- tcSimplifyCheck is used when checking expression type signatures,
674 -- class decls, instance decls etc.
676 -- NB: tcSimplifyCheck does not consult the
677 -- global type variables in the environment; so you don't
678 -- need to worry about setting them before calling tcSimplifyCheck
679 tcSimplifyCheck doc qtvs givens wanted_lie
680 = tcSimplCheck doc get_qtvs
681 givens wanted_lie `thenM` \ (qtvs', binds) ->
684 get_qtvs = zonkTcTyVarsAndFV qtvs
687 -- tcSimplifyInferCheck is used when we know the constraints we are to simplify
688 -- against, but we don't know the type variables over which we are going to quantify.
689 -- This happens when we have a type signature for a mutually recursive group
692 -> TcTyVarSet -- fv(T)
695 -> TcM ([TcTyVar], -- Variables over which to quantify
696 TcDictBinds) -- Bindings
698 tcSimplifyInferCheck doc tau_tvs givens wanted_lie
699 = tcSimplCheck doc get_qtvs givens wanted_lie
701 -- Figure out which type variables to quantify over
702 -- You might think it should just be the signature tyvars,
703 -- but in bizarre cases you can get extra ones
704 -- f :: forall a. Num a => a -> a
705 -- f x = fst (g (x, head [])) + 1
707 -- Here we infer g :: forall a b. a -> b -> (b,a)
708 -- We don't want g to be monomorphic in b just because
709 -- f isn't quantified over b.
710 all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)
712 get_qtvs = zonkTcTyVarsAndFV all_tvs `thenM` \ all_tvs' ->
713 tcGetGlobalTyVars `thenM` \ gbl_tvs ->
715 qtvs = all_tvs' `minusVarSet` gbl_tvs
716 -- We could close gbl_tvs, but its not necessary for
717 -- soundness, and it'll only affect which tyvars, not which
718 -- dictionaries, we quantify over
723 Here is the workhorse function for all three wrappers.
726 tcSimplCheck doc get_qtvs givens wanted_lie
727 = check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
729 -- Complain about any irreducible ones
730 mappM zonkInst given_dicts_and_ips `thenM` \ givens' ->
731 groupErrs (addNoInstanceErrs (Just doc) givens') irreds `thenM_`
734 extendLIEs frees `thenM_`
735 returnM (qtvs, binds)
738 given_dicts_and_ips = filter (not . isMethod) givens
739 -- For error reporting, filter out methods, which are
740 -- only added to the given set as an optimisation
742 ip_set = mkNameSet (ipNamesOfInsts givens)
744 check_loop givens wanteds
746 mappM zonkInst givens `thenM` \ givens' ->
747 mappM zonkInst wanteds `thenM` \ wanteds' ->
748 get_qtvs `thenM` \ qtvs' ->
752 -- When checking against a given signature we always reduce
753 -- until we find a match against something given, or can't reduce
754 try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free
755 | otherwise = ReduceMe
757 reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
760 if no_improvement then
761 returnM (varSetElems qtvs', frees, binds, irreds)
763 check_loop givens' (irreds ++ frees) `thenM` \ (qtvs', frees1, binds1, irreds1) ->
764 returnM (qtvs', frees1, binds `unionBags` binds1, irreds1)
768 %************************************************************************
770 \subsection{tcSimplifyRestricted}
772 %************************************************************************
775 tcSimplifyRestricted -- Used for restricted binding groups
776 -- i.e. ones subject to the monomorphism restriction
778 -> TcTyVarSet -- Free in the type of the RHSs
779 -> [Inst] -- Free in the RHSs
780 -> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
781 TcDictBinds) -- Bindings
783 tcSimplifyRestricted doc tau_tvs wanteds
784 = -- First squash out all methods, to find the constrained tyvars
785 -- We can't just take the free vars of wanted_lie because that'll
786 -- have methods that may incidentally mention entirely unconstrained variables
787 -- e.g. a call to f :: Eq a => a -> b -> b
788 -- Here, b is unconstrained. A good example would be
790 -- We want to infer the polymorphic type
791 -- foo :: forall b. b -> b
793 -- 'reduceMe': Reduce as far as we can. Don't stop at
794 -- dicts; the idea is to get rid of as many type
795 -- variables as possible, and we don't want to stop
796 -- at (say) Monad (ST s), because that reduces
797 -- immediately, with no constraint on s.
798 simpleReduceLoop doc reduceMe wanteds `thenM` \ (foo_frees, foo_binds, constrained_dicts) ->
800 -- Next, figure out the tyvars we will quantify over
801 zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
802 tcGetGlobalTyVars `thenM` \ gbl_tvs ->
804 constrained_tvs = tyVarsOfInsts constrained_dicts
805 qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs)
806 `minusVarSet` constrained_tvs
808 traceTc (text "tcSimplifyRestricted" <+> vcat [
809 pprInsts wanteds, pprInsts foo_frees, pprInsts constrained_dicts,
811 ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_`
813 -- The first step may have squashed more methods than
814 -- necessary, so try again, this time knowing the exact
815 -- set of type variables to quantify over.
817 -- We quantify only over constraints that are captured by qtvs;
818 -- these will just be a subset of non-dicts. This in contrast
819 -- to normal inference (using isFreeWhenInferring) in which we quantify over
820 -- all *non-inheritable* constraints too. This implements choice
821 -- (B) under "implicit parameter and monomorphism" above.
823 -- Remember that we may need to do *some* simplification, to
824 -- (for example) squash {Monad (ST s)} into {}. It's not enough
825 -- just to float all constraints
826 restrict_loop doc qtvs wanteds
827 -- We still need a loop because improvement can take place
828 -- E.g. if we have (C (T a)) and the instance decl
829 -- instance D Int b => C (T a) where ...
830 -- and there's a functional dependency for D. Then we may improve
831 -- the tyep variable 'b'.
833 restrict_loop doc qtvs wanteds
834 = mappM zonkInst wanteds `thenM` \ wanteds' ->
835 zonkTcTyVarsAndFV (varSetElems qtvs) `thenM` \ qtvs' ->
837 try_me inst | isFreeWrtTyVars qtvs' inst = Free
838 | otherwise = ReduceMe
840 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
841 if no_improvement then
842 ASSERT( null irreds )
843 extendLIEs frees `thenM_`
844 returnM (varSetElems qtvs', binds)
846 restrict_loop doc qtvs' (irreds ++ frees) `thenM` \ (qtvs1, binds1) ->
847 returnM (qtvs1, binds `unionBags` binds1)
851 %************************************************************************
853 \subsection{tcSimplifyToDicts}
855 %************************************************************************
857 On the LHS of transformation rules we only simplify methods and constants,
858 getting dictionaries. We want to keep all of them unsimplified, to serve
859 as the available stuff for the RHS of the rule.
861 The same thing is used for specialise pragmas. Consider
864 {-# SPECIALISE f :: Int -> Int #-}
867 The type checker generates a binding like:
869 f_spec = (f :: Int -> Int)
871 and we want to end up with
873 f_spec = _inline_me_ (f Int dNumInt)
875 But that means that we must simplify the Method for f to (f Int dNumInt)!
876 So tcSimplifyToDicts squeezes out all Methods.
878 IMPORTANT NOTE: we *don't* want to do superclass commoning up. Consider
880 fromIntegral :: (Integral a, Num b) => a -> b
881 {-# RULES "foo" fromIntegral = id :: Int -> Int #-}
883 Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
887 fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
889 because the scsel will mess up matching. Instead we want
891 forall dIntegralInt, dNumInt.
892 fromIntegral Int Int dIntegralInt dNumInt = id Int
894 Hence "DontReduce NoSCs"
897 tcSimplifyToDicts :: [Inst] -> TcM (TcDictBinds)
898 tcSimplifyToDicts wanteds
899 = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
900 -- Since try_me doesn't look at types, we don't need to
901 -- do any zonking, so it's safe to call reduceContext directly
903 extendLIEs irreds `thenM_`
907 doc = text "tcSimplifyToDicts"
909 -- Reduce methods and lits only; stop as soon as we get a dictionary
910 try_me inst | isDict inst = DontReduce NoSCs -- See notes above for why NoSCs
911 | otherwise = ReduceMe
916 tcSimplifyBracket is used when simplifying the constraints arising from
917 a Template Haskell bracket [| ... |]. We want to check that there aren't
918 any constraints that can't be satisfied (e.g. Show Foo, where Foo has no
919 Show instance), but we aren't otherwise interested in the results.
920 Nor do we care about ambiguous dictionaries etc. We will type check
921 this bracket again at its usage site.
924 tcSimplifyBracket :: [Inst] -> TcM ()
925 tcSimplifyBracket wanteds
926 = simpleReduceLoop doc reduceMe wanteds `thenM_`
929 doc = text "tcSimplifyBracket"
933 %************************************************************************
935 \subsection{Filtering at a dynamic binding}
937 %************************************************************************
942 we must discharge all the ?x constraints from B. We also do an improvement
943 step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.
945 Actually, the constraints from B might improve the types in ?x. For example
947 f :: (?x::Int) => Char -> Char
950 then the constraint (?x::Int) arising from the call to f will
951 force the binding for ?x to be of type Int.
954 tcSimplifyIPs :: [Inst] -- The implicit parameters bound here
957 tcSimplifyIPs given_ips wanteds
958 = simpl_loop given_ips wanteds `thenM` \ (frees, binds) ->
959 extendLIEs frees `thenM_`
962 doc = text "tcSimplifyIPs" <+> ppr given_ips
963 ip_set = mkNameSet (ipNamesOfInsts given_ips)
965 -- Simplify any methods that mention the implicit parameter
966 try_me inst | isFreeWrtIPs ip_set inst = Free
967 | otherwise = ReduceMe
969 simpl_loop givens wanteds
970 = mappM zonkInst givens `thenM` \ givens' ->
971 mappM zonkInst wanteds `thenM` \ wanteds' ->
973 reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
975 if no_improvement then
976 ASSERT( null irreds )
977 returnM (frees, binds)
979 simpl_loop givens' (irreds ++ frees) `thenM` \ (frees1, binds1) ->
980 returnM (frees1, binds `unionBags` binds1)
984 %************************************************************************
986 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
988 %************************************************************************
990 When doing a binding group, we may have @Insts@ of local functions.
991 For example, we might have...
993 let f x = x + 1 -- orig local function (overloaded)
994 f.1 = f Int -- two instances of f
999 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
1000 where @f@ is in scope; those @Insts@ must certainly not be passed
1001 upwards towards the top-level. If the @Insts@ were binding-ified up
1002 there, they would have unresolvable references to @f@.
1004 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
1005 For each method @Inst@ in the @init_lie@ that mentions one of the
1006 @Ids@, we create a binding. We return the remaining @Insts@ (in an
1007 @LIE@), as well as the @HsBinds@ generated.
1010 bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM (LHsBinds TcId)
1012 bindInstsOfLocalFuns wanteds local_ids
1013 | null overloaded_ids
1015 = extendLIEs wanteds `thenM_`
1019 = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
1020 ASSERT( null irreds )
1021 extendLIEs frees `thenM_`
1024 doc = text "bindInsts" <+> ppr local_ids
1025 overloaded_ids = filter is_overloaded local_ids
1026 is_overloaded id = isOverloadedTy (idType id)
1028 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
1029 -- so it's worth building a set, so that
1030 -- lookup (in isMethodFor) is faster
1032 try_me inst | isMethodFor overloaded_set inst = ReduceMe
1037 %************************************************************************
1039 \subsection{Data types for the reduction mechanism}
1041 %************************************************************************
1043 The main control over context reduction is here
1047 = ReduceMe -- Try to reduce this
1048 -- If there's no instance, behave exactly like
1049 -- DontReduce: add the inst to
1050 -- the irreductible ones, but don't
1051 -- produce an error message of any kind.
1052 -- It might be quite legitimate such as (Eq a)!
1054 | DontReduce WantSCs -- Return as irreducible
1056 | DontReduceUnlessConstant -- Return as irreducible unless it can
1057 -- be reduced to a constant in one step
1059 | Free -- Return as free
1061 reduceMe :: Inst -> WhatToDo
1062 reduceMe inst = ReduceMe
1064 data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
1065 -- of a predicate when adding it to the avails
1071 type Avails = FiniteMap Inst Avail
1074 = IsFree -- Used for free Insts
1075 | Irred -- Used for irreducible dictionaries,
1076 -- which are going to be lambda bound
1078 | Given TcId -- Used for dictionaries for which we have a binding
1079 -- e.g. those "given" in a signature
1080 Bool -- True <=> actually consumed (splittable IPs only)
1082 | NoRhs -- Used for Insts like (CCallable f)
1083 -- where no witness is required.
1086 | Rhs -- Used when there is a RHS
1087 (LHsExpr TcId) -- The RHS
1088 [Inst] -- Insts free in the RHS; we need these too
1090 | Linear -- Splittable Insts only.
1091 Int -- The Int is always 2 or more; indicates how
1092 -- many copies are required
1093 Inst -- The splitter
1094 Avail -- Where the "master copy" is
1096 | LinRhss -- Splittable Insts only; this is used only internally
1097 -- by extractResults, where a Linear
1098 -- is turned into an LinRhss
1099 [LHsExpr TcId] -- A supply of suitable RHSs
1101 pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
1102 | (inst,avail) <- fmToList avails ]
1104 instance Outputable Avail where
1107 pprAvail NoRhs = text "<no rhs>"
1108 pprAvail IsFree = text "Free"
1109 pprAvail Irred = text "Irred"
1110 pprAvail (Given x b) = text "Given" <+> ppr x <+>
1111 if b then text "(used)" else empty
1112 pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs)
1113 pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a
1114 pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss
1117 Extracting the bindings from a bunch of Avails.
1118 The bindings do *not* come back sorted in dependency order.
1119 We assume that they'll be wrapped in a big Rec, so that the
1120 dependency analyser can sort them out later
1124 extractResults :: Avails
1126 -> TcM (TcDictBinds, -- Bindings
1127 [Inst], -- Irreducible ones
1128 [Inst]) -- Free ones
1130 extractResults avails wanteds
1131 = go avails emptyBag [] [] wanteds
1133 go avails binds irreds frees []
1134 = returnM (binds, irreds, frees)
1136 go avails binds irreds frees (w:ws)
1137 = case lookupFM avails w of
1138 Nothing -> pprTrace "Urk: extractResults" (ppr w) $
1139 go avails binds irreds frees ws
1141 Just NoRhs -> go avails binds irreds frees ws
1142 Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws
1143 Just Irred -> go (add_given avails w) binds (w:irreds) frees ws
1145 Just (Given id _) -> go avails new_binds irreds frees ws
1147 new_binds | id == instToId w = binds
1148 | otherwise = addBind binds w (L (instSpan w) (HsVar id))
1149 -- The sought Id can be one of the givens, via a superclass chain
1150 -- and then we definitely don't want to generate an x=x binding!
1152 Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws)
1154 new_binds = addBind binds w rhs
1156 Just (Linear n split_inst avail) -- Transform Linear --> LinRhss
1157 -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) ->
1158 split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) ->
1159 go (addToFM avails w (LinRhss rhss))
1160 (binds `unionBags` binds')
1161 irreds' frees' (split_inst : w : ws)
1163 Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss
1164 -> go new_avails new_binds irreds frees ws
1166 new_binds = addBind binds w rhs
1167 new_avails = addToFM avails w (LinRhss rhss)
1169 get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
1170 get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
1171 returnM (w':irreds, frees, instToId w')
1172 get_root irreds frees IsFree w = cloneDict w `thenM` \ w' ->
1173 returnM (irreds, w':frees, instToId w')
1176 | instBindingRequired w = addToFM avails w (Given (instToId w) True)
1177 | otherwise = addToFM avails w NoRhs
1178 -- NB: make sure that CCallable/CReturnable use NoRhs rather
1179 -- than Given, else we end up with bogus bindings.
1181 add_free avails w | isMethod w = avails
1182 | otherwise = add_given avails w
1184 -- Do *not* replace Free by Given if it's a method.
1185 -- The following situation shows why this is bad:
1186 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
1187 -- From an application (truncate f i) we get
1188 -- t1 = truncate at f
1190 -- If we have also have a second occurrence of truncate, we get
1191 -- t3 = truncate at f
1193 -- When simplifying with i,f free, we might still notice that
1194 -- t1=t3; but alas, the binding for t2 (which mentions t1)
1195 -- will continue to float out!
1196 -- (split n i a) returns: n rhss
1197 -- auxiliary bindings
1198 -- 1 or 0 insts to add to irreds
1201 split :: Int -> TcId -> TcId -> Inst
1202 -> TcM (TcDictBinds, [LHsExpr TcId])
1203 -- (split n split_id root_id wanted) returns
1204 -- * a list of 'n' expressions, all of which witness 'avail'
1205 -- * a bunch of auxiliary bindings to support these expressions
1206 -- * one or zero insts needed to witness the whole lot
1207 -- (maybe be zero if the initial Inst is a Given)
1209 -- NB: 'wanted' is just a template
1211 split n split_id root_id wanted
1214 ty = linearInstType wanted
1215 pair_ty = mkTyConApp pairTyCon [ty,ty]
1216 id = instToId wanted
1219 span = instSpan wanted
1221 go 1 = returnM (emptyBag, [L span $ HsVar root_id])
1223 go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) ->
1224 expand n rhss `thenM` \ (binds2, rhss') ->
1225 returnM (binds1 `unionBags` binds2, rhss')
1228 -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
1229 -- e.g. expand 3 [rhs1, rhs2]
1230 -- = ( { x = split rhs1 },
1231 -- [fst x, snd x, rhs2] )
1233 | n `rem` 2 == 0 = go rhss -- n is even
1234 | otherwise = go (tail rhss) `thenM` \ (binds', rhss') ->
1235 returnM (binds', head rhss : rhss')
1237 go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') ->
1238 returnM (listToBag binds', concat rhss')
1240 do_one rhs = newUnique `thenM` \ uniq ->
1241 tcLookupId fstName `thenM` \ fst_id ->
1242 tcLookupId sndName `thenM` \ snd_id ->
1244 x = mkUserLocal occ uniq pair_ty loc
1246 returnM (L span (VarBind x (mk_app span split_id rhs)),
1247 [mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x])
1249 mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var))
1251 mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs)
1253 addBind binds inst rhs = binds `unionBags` unitBag (L (instLocSrcSpan (instLoc inst))
1254 (VarBind (instToId inst) rhs))
1255 instSpan wanted = instLocSrcSpan (instLoc wanted)
1259 %************************************************************************
1261 \subsection[reduce]{@reduce@}
1263 %************************************************************************
1265 When the "what to do" predicate doesn't depend on the quantified type variables,
1266 matters are easier. We don't need to do any zonking, unless the improvement step
1267 does something, in which case we zonk before iterating.
1269 The "given" set is always empty.
1272 simpleReduceLoop :: SDoc
1273 -> (Inst -> WhatToDo) -- What to do, *not* based on the quantified type variables
1275 -> TcM ([Inst], -- Free
1277 [Inst]) -- Irreducible
1279 simpleReduceLoop doc try_me wanteds
1280 = mappM zonkInst wanteds `thenM` \ wanteds' ->
1281 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
1282 if no_improvement then
1283 returnM (frees, binds, irreds)
1285 simpleReduceLoop doc try_me (irreds ++ frees) `thenM` \ (frees1, binds1, irreds1) ->
1286 returnM (frees1, binds `unionBags` binds1, irreds1)
1292 reduceContext :: SDoc
1293 -> (Inst -> WhatToDo)
1296 -> TcM (Bool, -- True <=> improve step did no unification
1298 TcDictBinds, -- Dictionary bindings
1299 [Inst]) -- Irreducible
1301 reduceContext doc try_me givens wanteds
1303 traceTc (text "reduceContext" <+> (vcat [
1304 text "----------------------",
1306 text "given" <+> ppr givens,
1307 text "wanted" <+> ppr wanteds,
1308 text "----------------------"
1311 -- Build the Avail mapping from "givens"
1312 foldlM addGiven emptyFM givens `thenM` \ init_state ->
1315 reduceList (0,[]) try_me wanteds init_state `thenM` \ avails ->
1317 -- Do improvement, using everything in avails
1318 -- In particular, avails includes all superclasses of everything
1319 tcImprove avails `thenM` \ no_improvement ->
1321 extractResults avails wanteds `thenM` \ (binds, irreds, frees) ->
1323 traceTc (text "reduceContext end" <+> (vcat [
1324 text "----------------------",
1326 text "given" <+> ppr givens,
1327 text "wanted" <+> ppr wanteds,
1329 text "avails" <+> pprAvails avails,
1330 text "frees" <+> ppr frees,
1331 text "no_improvement =" <+> ppr no_improvement,
1332 text "----------------------"
1335 returnM (no_improvement, frees, binds, irreds)
1337 tcImprove :: Avails -> TcM Bool -- False <=> no change
1338 -- Perform improvement using all the predicates in Avails
1340 = tcGetInstEnvs `thenM` \ (home_ie, pkg_ie) ->
1342 preds = [ (pred, pp_loc)
1343 | inst <- keysFM avails,
1344 let pp_loc = pprInstLoc (instLoc inst),
1345 pred <- fdPredsOfInst inst
1347 -- Avails has all the superclasses etc (good)
1348 -- It also has all the intermediates of the deduction (good)
1349 -- It does not have duplicates (good)
1350 -- NB that (?x::t1) and (?x::t2) will be held separately in avails
1351 -- so that improve will see them separate
1352 eqns = improve get_insts preds
1353 get_insts clas = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas
1358 traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenM_`
1359 mappM_ unify eqns `thenM_`
1362 unify ((qtvs, t1, t2), doc)
1364 tcInstTyVars VanillaTv (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
1365 unifyTauTy (substTy tenv t1) (substTy tenv t2)
1368 The main context-reduction function is @reduce@. Here's its game plan.
1371 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
1372 -- along with its depth
1373 -> (Inst -> WhatToDo)
1380 try_me: given an inst, this function returns
1382 DontReduce return this in "irreds"
1383 Free return this in "frees"
1385 wanteds: The list of insts to reduce
1386 state: An accumulating parameter of type Avails
1387 that contains the state of the algorithm
1389 It returns a Avails.
1391 The (n,stack) pair is just used for error reporting.
1392 n is always the depth of the stack.
1393 The stack is the stack of Insts being reduced: to produce X
1394 I had to produce Y, to produce Y I had to produce Z, and so on.
1397 reduceList (n,stack) try_me wanteds state
1398 | n > opt_MaxContextReductionDepth
1399 = failWithTc (reduceDepthErr n stack)
1405 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
1410 go [] state = returnM state
1411 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ state' ->
1414 -- Base case: we're done!
1415 reduce stack try_me wanted avails
1416 -- It's the same as an existing inst, or a superclass thereof
1417 | Just avail <- isAvailable avails wanted
1418 = if isLinearInst wanted then
1419 addLinearAvailable avails avail wanted `thenM` \ (avails', wanteds') ->
1420 reduceList stack try_me wanteds' avails'
1422 returnM avails -- No op for non-linear things
1425 = case try_me wanted of {
1427 DontReduce want_scs -> addIrred want_scs avails wanted
1429 ; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
1430 -- First, see if the inst can be reduced to a constant in one step
1431 try_simple (addIrred AddSCs) -- Assume want superclasses
1433 ; Free -> -- It's free so just chuck it upstairs
1434 -- First, see if the inst can be reduced to a constant in one step
1437 ; ReduceMe -> -- It should be reduced
1438 lookupInst wanted `thenM` \ lookup_result ->
1439 case lookup_result of
1440 GenInst wanteds' rhs -> addIrred NoSCs avails wanted `thenM` \ avails1 ->
1441 reduceList stack try_me wanteds' avails1 `thenM` \ avails2 ->
1442 addWanted avails2 wanted rhs wanteds'
1443 -- Experiment with temporarily doing addIrred *before* the reduceList,
1444 -- which has the effect of adding the thing we are trying
1445 -- to prove to the database before trying to prove the things it
1446 -- needs. See note [RECURSIVE DICTIONARIES]
1447 -- NB: we must not do an addWanted before, because that adds the
1448 -- superclasses too, and thaat can lead to a spurious loop; see
1449 -- the examples in [SUPERCLASS-LOOP]
1450 -- So we do an addIrred before, and then overwrite it afterwards with addWanted
1452 SimpleInst rhs -> addWanted avails wanted rhs []
1454 NoInstance -> -- No such instance!
1455 -- Add it and its superclasses
1456 addIrred AddSCs avails wanted
1459 try_simple do_this_otherwise
1460 = lookupInst wanted `thenM` \ lookup_result ->
1461 case lookup_result of
1462 SimpleInst rhs -> addWanted avails wanted rhs []
1463 other -> do_this_otherwise avails wanted
1468 -------------------------
1469 isAvailable :: Avails -> Inst -> Maybe Avail
1470 isAvailable avails wanted = lookupFM avails wanted
1471 -- NB 1: the Ord instance of Inst compares by the class/type info
1472 -- *not* by unique. So
1473 -- d1::C Int == d2::C Int
1475 addLinearAvailable :: Avails -> Avail -> Inst -> TcM (Avails, [Inst])
1476 addLinearAvailable avails avail wanted
1477 -- avails currently maps [wanted -> avail]
1478 -- Extend avails to reflect a neeed for an extra copy of avail
1480 | Just avail' <- split_avail avail
1481 = returnM (addToFM avails wanted avail', [])
1484 = tcLookupId splitName `thenM` \ split_id ->
1485 tcInstClassOp (instLoc wanted) split_id
1486 [linearInstType wanted] `thenM` \ split_inst ->
1487 returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
1490 split_avail :: Avail -> Maybe Avail
1491 -- (Just av) if there's a modified version of avail that
1492 -- we can use to replace avail in avails
1493 -- Nothing if there isn't, so we need to create a Linear
1494 split_avail (Linear n i a) = Just (Linear (n+1) i a)
1495 split_avail (Given id used) | not used = Just (Given id True)
1496 | otherwise = Nothing
1497 split_avail Irred = Nothing
1498 split_avail IsFree = Nothing
1499 split_avail other = pprPanic "addLinearAvailable" (ppr avail $$ ppr wanted $$ ppr avails)
1501 -------------------------
1502 addFree :: Avails -> Inst -> TcM Avails
1503 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
1504 -- to avails, so that any other equal Insts will be commoned up right
1505 -- here rather than also being tossed upstairs. This is really just
1506 -- an optimisation, and perhaps it is more trouble that it is worth,
1507 -- as the following comments show!
1509 -- NB: do *not* add superclasses. If we have
1512 -- but a is not bound here, then we *don't* want to derive
1513 -- dn from df here lest we lose sharing.
1515 addFree avails free = returnM (addToFM avails free IsFree)
1517 addWanted :: Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails
1518 addWanted avails wanted rhs_expr wanteds
1519 = addAvailAndSCs avails wanted avail
1521 avail | instBindingRequired wanted = Rhs rhs_expr wanteds
1522 | otherwise = ASSERT( null wanteds ) NoRhs
1524 addGiven :: Avails -> Inst -> TcM Avails
1525 addGiven avails given = addAvailAndSCs avails given (Given (instToId given) False)
1526 -- No ASSERT( not (given `elemFM` avails) ) because in an instance
1527 -- decl for Ord t we can add both Ord t and Eq t as 'givens',
1528 -- so the assert isn't true
1530 addIrred :: WantSCs -> Avails -> Inst -> TcM Avails
1531 addIrred NoSCs avails irred = returnM (addToFM avails irred Irred)
1532 addIrred AddSCs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails )
1533 addAvailAndSCs avails irred Irred
1535 addAvailAndSCs :: Avails -> Inst -> Avail -> TcM Avails
1536 addAvailAndSCs avails inst avail
1537 | not (isClassDict inst) = returnM avails1
1538 | otherwise = traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) `thenM_`
1539 addSCs is_loop avails1 inst
1541 avails1 = addToFM avails inst avail
1542 is_loop inst = any (`tcEqType` idType (instToId inst)) dep_tys
1543 -- Note: this compares by *type*, not by Unique
1544 deps = findAllDeps emptyVarSet avail
1545 dep_tys = map idType (varSetElems deps)
1547 findAllDeps :: IdSet -> Avail -> IdSet
1548 -- Find all the Insts that this one depends on
1549 -- See Note [SUPERCLASS-LOOP]
1550 -- Watch out, though. Since the avails may contain loops
1551 -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far
1552 findAllDeps so_far (Rhs _ kids)
1554 (extendVarSetList so_far (map instToId kids)) -- Add the kids to so_far
1555 [a | Just a <- map (lookupFM avails) kids] -- Find the kids' Avail
1556 findAllDeps so_far other = so_far
1559 addSCs :: (Inst -> Bool) -> Avails -> Inst -> TcM Avails
1560 -- Add all the superclasses of the Inst to Avails
1561 -- The first param says "dont do this because the original thing
1562 -- depends on this one, so you'd build a loop"
1563 -- Invariant: the Inst is already in Avails.
1565 addSCs is_loop avails dict
1566 = newDictsFromOld dict sc_theta' `thenM` \ sc_dicts ->
1567 foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
1569 (clas, tys) = getDictClassTys dict
1570 (tyvars, sc_theta, sc_sels, _) = classBigSig clas
1571 sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
1573 add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
1574 | add_me sc_dict = addSCs is_loop avails' sc_dict
1575 | otherwise = returnM avails
1577 sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict]
1578 avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict])
1580 add_me :: Inst -> Bool
1582 | is_loop sc_dict = False -- See Note [SUPERCLASS-LOOP]
1583 | otherwise = case lookupFM avails sc_dict of
1584 Just (Given _ _) -> False -- Given is cheaper than superclass selection
1588 Note [SUPERCLASS-LOOP]: Checking for loops
1589 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1590 We have to be careful here. If we are *given* d1:Ord a,
1591 and want to deduce (d2:C [a]) where
1593 class Ord a => C a where
1594 instance Ord a => C [a] where ...
1596 Then we'll use the instance decl to deduce C [a] and then add the
1597 superclasses of C [a] to avails. But we must not overwrite the binding
1598 for d1:Ord a (which is given) with a superclass selection or we'll just
1601 Here's another variant, immortalised in tcrun020
1602 class Monad m => C1 m
1603 class C1 m => C2 m x
1604 instance C2 Maybe Bool
1605 For the instance decl we need to build (C1 Maybe), and it's no good if
1606 we run around and add (C2 Maybe Bool) and its superclasses to the avails
1607 before we search for C1 Maybe.
1609 Here's another example
1610 class Eq b => Foo a b
1611 instance Eq a => Foo [a] a
1615 we'll first deduce that it holds (via the instance decl). We must not
1616 then overwrite the Eq t constraint with a superclass selection!
1618 At first I had a gross hack, whereby I simply did not add superclass constraints
1619 in addWanted, though I did for addGiven and addIrred. This was sub-optimal,
1620 becuase it lost legitimate superclass sharing, and it still didn't do the job:
1621 I found a very obscure program (now tcrun021) in which improvement meant the
1622 simplifier got two bites a the cherry... so something seemed to be an Irred
1623 first time, but reducible next time.
1625 Now we implement the Right Solution, which is to check for loops directly
1626 when adding superclasses. It's a bit like the occurs check in unification.
1629 Note [RECURSIVE DICTIONARIES]
1630 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1632 data D r = ZeroD | SuccD (r (D r));
1634 instance (Eq (r (D r))) => Eq (D r) where
1635 ZeroD == ZeroD = True
1636 (SuccD a) == (SuccD b) = a == b
1639 equalDC :: D [] -> D [] -> Bool;
1642 We need to prove (Eq (D [])). Here's how we go:
1646 by instance decl, holds if
1650 by instance decl of Eq, holds if
1652 where d2 = dfEqList d3
1655 But now we can "tie the knot" to give
1661 and it'll even run! The trick is to put the thing we are trying to prove
1662 (in this case Eq (D []) into the database before trying to prove its
1663 contributing clauses.
1666 %************************************************************************
1668 \section{tcSimplifyTop: defaulting}
1670 %************************************************************************
1673 @tcSimplifyTop@ is called once per module to simplify all the constant
1674 and ambiguous Insts.
1676 We need to be careful of one case. Suppose we have
1678 instance Num a => Num (Foo a b) where ...
1680 and @tcSimplifyTop@ is given a constraint (Num (Foo x y)). Then it'll simplify
1681 to (Num x), and default x to Int. But what about y??
1683 It's OK: the final zonking stage should zap y to (), which is fine.
1687 tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
1688 tcSimplifyTop wanteds = tc_simplify_top False {- Not interactive loop -} wanteds
1689 tcSimplifyInteractive wanteds = tc_simplify_top True {- Interactive loop -} wanteds
1692 -- The TcLclEnv should be valid here, solely to improve
1693 -- error message generation for the monomorphism restriction
1694 tc_simplify_top is_interactive wanteds
1695 = getLclEnv `thenM` \ lcl_env ->
1696 traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) `thenM_`
1697 simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
1698 ASSERT( null frees )
1701 -- All the non-std ones are definite errors
1702 (stds, non_stds) = partition isStdClassTyVarDict irreds
1704 -- Group by type variable
1705 std_groups = equivClasses cmp_by_tyvar stds
1707 -- Pick the ones which its worth trying to disambiguate
1708 -- namely, the onese whose type variable isn't bound
1709 -- up with one of the non-standard classes
1710 (std_oks, std_bads) = partition worth_a_try std_groups
1711 worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d)
1712 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
1714 -- Collect together all the bad guys
1715 bad_guys = non_stds ++ concat std_bads
1716 (bad_ips, non_ips) = partition isIPDict bad_guys
1717 (no_insts, ambigs) = partition no_inst non_ips
1718 no_inst d = not (isTyVarDict d)
1719 -- Previously, there was a more elaborate no_inst definition:
1720 -- no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
1721 -- fixed_tvs = oclose (fdPredsOfInsts tidy_dicts) emptyVarSet
1722 -- But that seems over-elaborate to me; it only bites for class decls with
1723 -- fundeps like this: class C a b | -> b where ...
1726 -- Report definite errors
1727 groupErrs (addNoInstanceErrs Nothing []) no_insts `thenM_`
1728 addTopIPErrs bad_ips `thenM_`
1730 -- Deal with ambiguity errors, but only if
1731 -- if there has not been an error so far; errors often
1732 -- give rise to spurious ambiguous Insts
1733 ifErrsM (returnM []) (
1735 -- Complain about the ones that don't fall under
1736 -- the Haskell rules for disambiguation
1737 -- This group includes both non-existent instances
1738 -- e.g. Num (IO a) and Eq (Int -> Int)
1739 -- and ambiguous dictionaries
1741 addTopAmbigErrs ambigs `thenM_`
1743 -- Disambiguate the ones that look feasible
1744 mappM (disambigGroup is_interactive) std_oks
1745 ) `thenM` \ binds_ambig ->
1747 returnM (binds `unionBags` unionManyBags binds_ambig)
1749 ----------------------------------
1750 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1752 get_tv d = case getDictClassTys d of
1753 (clas, [ty]) -> tcGetTyVar "tcSimplify" ty
1754 get_clas d = case getDictClassTys d of
1755 (clas, [ty]) -> clas
1758 If a dictionary constrains a type variable which is
1759 * not mentioned in the environment
1760 * and not mentioned in the type of the expression
1761 then it is ambiguous. No further information will arise to instantiate
1762 the type variable; nor will it be generalised and turned into an extra
1763 parameter to a function.
1765 It is an error for this to occur, except that Haskell provided for
1766 certain rules to be applied in the special case of numeric types.
1768 * at least one of its classes is a numeric class, and
1769 * all of its classes are numeric or standard
1770 then the type variable can be defaulted to the first type in the
1771 default-type list which is an instance of all the offending classes.
1773 So here is the function which does the work. It takes the ambiguous
1774 dictionaries and either resolves them (producing bindings) or
1775 complains. It works by splitting the dictionary list by type
1776 variable, and using @disambigOne@ to do the real business.
1778 @disambigOne@ assumes that its arguments dictionaries constrain all
1779 the same type variable.
1781 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1782 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1783 the most common use of defaulting is code like:
1785 _ccall_ foo `seqPrimIO` bar
1787 Since we're not using the result of @foo@, the result if (presumably)
1791 disambigGroup :: Bool -- True <=> simplifying at top-level interactive loop
1792 -> [Inst] -- All standard classes of form (C a)
1795 disambigGroup is_interactive dicts
1796 | any std_default_class classes -- Guaranteed all standard classes
1797 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1798 -- SO, TRY DEFAULT TYPES IN ORDER
1800 -- Failure here is caused by there being no type in the
1801 -- default list which can satisfy all the ambiguous classes.
1802 -- For example, if Real a is reqd, but the only type in the
1803 -- default list is Int.
1804 get_default_tys `thenM` \ default_tys ->
1806 try_default [] -- No defaults work, so fail
1809 try_default (default_ty : default_tys)
1810 = tryTcLIE_ (try_default default_tys) $ -- If default_ty fails, we try
1811 -- default_tys instead
1812 tcSimplifyDefault theta `thenM` \ _ ->
1815 theta = [mkClassPred clas [default_ty] | clas <- classes]
1817 -- See if any default works
1818 tryM (try_default default_tys) `thenM` \ mb_ty ->
1821 Right chosen_default_ty -> choose_default chosen_default_ty
1823 | otherwise -- No defaults
1827 tyvar = get_tv (head dicts) -- Should be non-empty
1828 classes = map get_clas dicts
1830 std_default_class cls
1831 = isNumericClass cls
1832 || (is_interactive &&
1833 classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
1834 -- In interactive mode, we default Show a to Show ()
1835 -- to avoid graututious errors on "show []"
1837 choose_default default_ty -- Commit to tyvar = default_ty
1838 = -- Bind the type variable
1839 unifyTauTy default_ty (mkTyVarTy tyvar) `thenM_`
1840 -- and reduce the context, for real this time
1841 simpleReduceLoop (text "disambig" <+> ppr dicts)
1842 reduceMe dicts `thenM` \ (frees, binds, ambigs) ->
1843 WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
1844 warnDefault dicts default_ty `thenM_`
1847 bomb_out = addTopAmbigErrs dicts `thenM_`
1851 = do { mb_defaults <- getDefaultTys
1852 ; case mb_defaults of
1853 Just tys -> return tys
1854 Nothing -> -- No use-supplied default;
1855 -- use [Integer, Double]
1856 do { integer_ty <- tcMetaTy integerTyConName
1857 ; return [integer_ty, doubleTy] } }
1860 [Aside - why the defaulting mechanism is turned off when
1861 dealing with arguments and results to ccalls.
1863 When typechecking _ccall_s, TcExpr ensures that the external
1864 function is only passed arguments (and in the other direction,
1865 results) of a restricted set of 'native' types. This is
1866 implemented via the help of the pseudo-type classes,
1867 @CReturnable@ (CR) and @CCallable@ (CC.)
1869 The interaction between the defaulting mechanism for numeric
1870 values and CC & CR can be a bit puzzling to the user at times.
1879 What type has 'x' got here? That depends on the default list
1880 in operation, if it is equal to Haskell 98's default-default
1881 of (Integer, Double), 'x' has type Double, since Integer
1882 is not an instance of CR. If the default list is equal to
1883 Haskell 1.4's default-default of (Int, Double), 'x' has type
1886 To try to minimise the potential for surprises here, the
1887 defaulting mechanism is turned off in the presence of
1888 CCallable and CReturnable.
1893 %************************************************************************
1895 \subsection[simple]{@Simple@ versions}
1897 %************************************************************************
1899 Much simpler versions when there are no bindings to make!
1901 @tcSimplifyThetas@ simplifies class-type constraints formed by
1902 @deriving@ declarations and when specialising instances. We are
1903 only interested in the simplified bunch of class/type constraints.
1905 It simplifies to constraints of the form (C a b c) where
1906 a,b,c are type variables. This is required for the context of
1907 instance declarations.
1910 tcSimplifyDeriv :: [TyVar]
1911 -> ThetaType -- Wanted
1912 -> TcM ThetaType -- Needed
1914 tcSimplifyDeriv tyvars theta
1915 = tcInstTyVars VanillaTv tyvars `thenM` \ (tvs, _, tenv) ->
1916 -- The main loop may do unification, and that may crash if
1917 -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
1918 -- ToDo: what if two of them do get unified?
1919 newDicts DataDeclOrigin (substTheta tenv theta) `thenM` \ wanteds ->
1920 simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
1921 ASSERT( null frees ) -- reduceMe never returns Free
1923 doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok ->
1925 tv_set = mkVarSet tvs
1926 simpl_theta = map dictPred irreds -- reduceMe squashes all non-dicts
1929 | isEmptyVarSet pred_tyvars -- Things like (Eq T) should be rejected
1930 = addErrTc (noInstErr pred)
1932 | not undecidable_ok && not (isTyVarClassPred pred)
1933 -- Check that the returned dictionaries are all of form (C a b)
1934 -- (where a, b are type variables).
1935 -- We allow this if we had -fallow-undecidable-instances,
1936 -- but note that risks non-termination in the 'deriving' context-inference
1937 -- fixpoint loop. It is useful for situations like
1938 -- data Min h a = E | M a (h a)
1939 -- which gives the instance decl
1940 -- instance (Eq a, Eq (h a)) => Eq (Min h a)
1941 = addErrTc (noInstErr pred)
1943 | not (pred_tyvars `subVarSet` tv_set)
1944 -- Check for a bizarre corner case, when the derived instance decl should
1945 -- have form instance C a b => D (T a) where ...
1946 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
1947 -- of problems; in particular, it's hard to compare solutions for
1948 -- equality when finding the fixpoint. So I just rule it out for now.
1949 = addErrTc (badDerivedPred pred)
1954 pred_tyvars = tyVarsOfPred pred
1956 rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
1957 -- This reverse-mapping is a Royal Pain,
1958 -- but the result should mention TyVars not TcTyVars
1961 mappM check_pred simpl_theta `thenM_`
1962 checkAmbiguity tvs simpl_theta tv_set `thenM_`
1963 returnM (substTheta rev_env simpl_theta)
1965 doc = ptext SLIT("deriving classes for a data type")
1968 @tcSimplifyDefault@ just checks class-type constraints, essentially;
1969 used with \tr{default} declarations. We are only interested in
1970 whether it worked or not.
1973 tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it
1976 tcSimplifyDefault theta
1977 = newDicts DataDeclOrigin theta `thenM` \ wanteds ->
1978 simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
1979 ASSERT( null frees ) -- try_me never returns Free
1980 mappM (addErrTc . noInstErr) irreds `thenM_`
1986 doc = ptext SLIT("default declaration")
1990 %************************************************************************
1992 \section{Errors and contexts}
1994 %************************************************************************
1996 ToDo: for these error messages, should we note the location as coming
1997 from the insts, or just whatever seems to be around in the monad just
2001 groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
2002 -> [Inst] -- The offending Insts
2004 -- Group together insts with the same origin
2005 -- We want to report them together in error messages
2007 groupErrs report_err []
2009 groupErrs report_err (inst:insts)
2010 = do_one (inst:friends) `thenM_`
2011 groupErrs report_err others
2014 -- (It may seem a bit crude to compare the error messages,
2015 -- but it makes sure that we combine just what the user sees,
2016 -- and it avoids need equality on InstLocs.)
2017 (friends, others) = partition is_friend insts
2018 loc_msg = showSDoc (pprInstLoc (instLoc inst))
2019 is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
2020 do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
2021 -- Add location and context information derived from the Insts
2023 -- Add the "arising from..." part to a message about bunch of dicts
2024 addInstLoc :: [Inst] -> Message -> Message
2025 addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts)))
2028 plural xs = char 's'
2031 = groupErrs report tidy_dicts
2033 (tidy_env, tidy_dicts) = tidyInsts dicts
2034 report dicts = addErrTcM (tidy_env, mk_msg dicts)
2035 mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <>
2036 plural tidy_dicts <+> pprInsts tidy_dicts)
2038 addNoInstanceErrs :: Maybe SDoc -- Nothing => top level
2039 -- Just d => d describes the construct
2040 -> [Inst] -- What is given by the context or type sig
2041 -> [Inst] -- What is wanted
2043 addNoInstanceErrs mb_what givens []
2045 addNoInstanceErrs mb_what givens dicts
2046 = -- Some of the dicts are here because there is no instances
2047 -- and some because there are too many instances (overlap)
2048 -- The first thing we do is separate them
2049 getDOpts `thenM` \ dflags ->
2050 tcGetInstEnvs `thenM` \ inst_envs ->
2052 (tidy_env1, tidy_givens) = tidyInsts givens
2053 (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts
2055 -- Run through the dicts, generating a message for each
2056 -- overlapping one, but simply accumulating all the
2057 -- no-instance ones so they can be reported as a group
2058 (overlap_doc, no_inst_dicts) = foldl check_overlap (empty, []) tidy_dicts
2059 check_overlap (overlap_doc, no_inst_dicts) dict
2060 | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts)
2062 = case lookupInstEnv dflags inst_envs clas tys of
2064 | length ms > 1 -> (mk_overlap_msg dict res $$ overlap_doc, no_inst_dicts)
2065 | otherwise -> (overlap_doc, dict : no_inst_dicts) -- No match
2066 -- NB: there can be exactly one match, in the case where we have
2067 -- instance C a where ...
2068 -- (In this case, lookupInst doesn't bother to look up,
2069 -- unless -fallow-undecidable-instances is set.)
2070 -- So we report this as "no instance" rather than "overlap"; the fix is
2071 -- to specify -fallow-undecidable-instances, but we leave that to the programmer!
2073 (clas,tys) = getDictClassTys dict
2075 mk_probable_fix tidy_env2 mb_what no_inst_dicts `thenM` \ (tidy_env3, probable_fix) ->
2077 no_inst_doc | null no_inst_dicts = empty
2078 | otherwise = vcat [addInstLoc no_inst_dicts heading, probable_fix]
2079 heading | null givens = ptext SLIT("No instance") <> plural no_inst_dicts <+>
2080 ptext SLIT("for") <+> pprInsts no_inst_dicts
2081 | otherwise = sep [ptext SLIT("Could not deduce") <+> pprInsts no_inst_dicts,
2082 nest 2 $ ptext SLIT("from the context") <+> pprInsts tidy_givens]
2084 addErrTcM (tidy_env3, no_inst_doc $$ overlap_doc)
2087 mk_overlap_msg dict (matches, unifiers)
2088 = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") <+> ppr dict)),
2089 sep [ptext SLIT("Matching instances") <> colon,
2090 nest 2 (pprDFuns (dfuns ++ unifiers))],
2093 else parens (ptext SLIT("The choice depends on the instantiation of") <+>
2094 quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))))]
2096 dfuns = [df | (_, (_,_,df)) <- matches]
2098 mk_probable_fix tidy_env Nothing dicts -- Top level
2099 = mkMonomorphismMsg tidy_env dicts
2100 mk_probable_fix tidy_env (Just what) dicts -- Nested (type signatures, instance decls)
2101 = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 fix1, nest 2 fix2])
2103 fix1 = sep [ptext SLIT("Add") <+> pprInsts dicts,
2104 ptext SLIT("to the") <+> what]
2106 fix2 | null instance_dicts = empty
2107 | otherwise = ptext SLIT("Or add an instance declaration for")
2108 <+> pprInsts instance_dicts
2109 instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)]
2110 -- Insts for which it is worth suggesting an adding an instance declaration
2111 -- Exclude implicit parameters, and tyvar dicts
2114 addTopAmbigErrs dicts
2115 -- Divide into groups that share a common set of ambiguous tyvars
2116 = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts])
2118 (tidy_env, tidy_dicts) = tidyInsts dicts
2120 tvs_of :: Inst -> [TcTyVar]
2121 tvs_of d = varSetElems (tyVarsOfInst d)
2122 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
2124 report :: [(Inst,[TcTyVar])] -> TcM ()
2125 report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars
2126 = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
2127 addSrcSpan (instLocSrcSpan (instLoc inst)) $
2128 -- the location of the first one will do for the err message
2129 addErrTcM (tidy_env, msg $$ mono_msg)
2131 dicts = map fst pairs
2132 msg = sep [text "Ambiguous type variable" <> plural tvs <+>
2133 pprQuotedList tvs <+> in_msg,
2134 nest 2 (pprInstsInFull dicts)]
2135 in_msg | isSingleton dicts = text "in the top-level constraint:"
2136 | otherwise = text "in these top-level constraints:"
2139 mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message)
2140 -- There's an error with these Insts; if they have free type variables
2141 -- it's probably caused by the monomorphism restriction.
2142 -- Try to identify the offending variable
2143 -- ASSUMPTION: the Insts are fully zonked
2144 mkMonomorphismMsg tidy_env insts
2145 | isEmptyVarSet inst_tvs
2146 = returnM (tidy_env, empty)
2148 = findGlobals inst_tvs tidy_env `thenM` \ (tidy_env, docs) ->
2149 returnM (tidy_env, mk_msg docs)
2152 inst_tvs = tyVarsOfInsts insts
2154 mk_msg [] = empty -- This happens in things like
2155 -- f x = show (read "foo")
2156 -- whre monomorphism doesn't play any role
2157 mk_msg docs = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"),
2159 ptext SLIT("Probable fix: give these definition(s) an explicit type signature")]
2161 warnDefault dicts default_ty
2162 = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
2163 addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg)
2166 (_, tidy_dicts) = tidyInsts dicts
2167 warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
2168 quotes (ppr default_ty),
2169 pprInstsInFull tidy_dicts]
2171 -- Used for the ...Thetas variants; all top level
2172 noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred)
2175 = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
2176 ptext SLIT("type variables that are not data type parameters"),
2177 nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
2179 reduceDepthErr n stack
2180 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
2181 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
2182 nest 4 (pprInstsInFull stack)]
2184 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)