2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcSimplify]{TcSimplify}
10 tcSimplifyInfer, tcSimplifyInferCheck,
11 tcSimplifyCheck, tcSimplifyRestricted,
12 tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
15 tcSimplifyDeriv, tcSimplifyDefault,
19 #include "HsVersions.h"
21 import {-# SOURCE #-} TcUnify( unifyTauTy )
23 import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
24 import TcHsSyn ( TcExpr, TcId,
25 TcMonoBinds, TcDictBinds
29 import Inst ( lookupInst, LookupInstResult(..),
30 tyVarsOfInst, fdPredsOfInsts, fdPredsOfInst, newDicts,
31 isDict, isClassDict, isLinearInst, linearInstType,
32 isStdClassTyVarDict, isMethodFor, isMethod,
33 instToId, tyVarsOfInsts, cloneDict,
34 ipNamesOfInsts, ipNamesOfInst, dictPred,
35 instBindingRequired, instCanBeGeneralised,
36 newDictsFromOld, tcInstClassOp,
37 getDictClassTys, isTyVarDict,
38 instLoc, zonkInst, tidyInsts, tidyMoreInsts,
39 Inst, pprInsts, pprInstsInFull,
40 isIPDict, isInheritableInst
42 import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupId, findGlobals )
43 import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
44 import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
45 import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
46 mkClassPred, isOverloadedTy, mkTyConApp,
47 mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
49 import Id ( idType, mkUserLocal )
51 import Name ( getOccName, getSrcLoc )
52 import NameSet ( NameSet, mkNameSet, elemNameSet )
53 import Class ( classBigSig )
54 import FunDeps ( oclose, grow, improve, pprEquationDoc )
55 import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
56 import PrelNames ( splitName, fstName, sndName, showClassKey )
57 import HscTypes ( GhciMode(Interactive) )
59 import Subst ( mkTopTyVarSubst, substTheta, substTy )
60 import TysWiredIn ( unitTy, pairTyCon )
61 import ErrUtils ( Message )
63 import VarEnv ( TidyEnv )
66 import ListSetOps ( equivClasses )
67 import Unique ( hasKey )
68 import Util ( zipEqual, isSingleton )
69 import List ( partition )
74 %************************************************************************
78 %************************************************************************
80 --------------------------------------
81 Notes on quantification
82 --------------------------------------
84 Suppose we are about to do a generalisation step.
89 C the constraints from that RHS
91 The game is to figure out
93 Q the set of type variables over which to quantify
94 Ct the constraints we will *not* quantify over
95 Cq the constraints we will quantify over
97 So we're going to infer the type
101 and float the constraints Ct further outwards.
103 Here are the things that *must* be true:
105 (A) Q intersect fv(G) = EMPTY limits how big Q can be
106 (B) Q superset fv(Cq union T) \ oclose(fv(G),C) limits how small Q can be
108 (A) says we can't quantify over a variable that's free in the
109 environment. (B) says we must quantify over all the truly free
110 variables in T, else we won't get a sufficiently general type. We do
111 not *need* to quantify over any variable that is fixed by the free
112 vars of the environment G.
114 BETWEEN THESE TWO BOUNDS, ANY Q WILL DO!
116 Example: class H x y | x->y where ...
118 fv(G) = {a} C = {H a b, H c d}
121 (A) Q intersect {a} is empty
122 (B) Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d}
124 So Q can be {c,d}, {b,c,d}
126 Other things being equal, however, we'd like to quantify over as few
127 variables as possible: smaller types, fewer type applications, more
128 constraints can get into Ct instead of Cq.
131 -----------------------------------------
134 fv(T) the free type vars of T
136 oclose(vs,C) The result of extending the set of tyvars vs
137 using the functional dependencies from C
139 grow(vs,C) The result of extend the set of tyvars vs
140 using all conceivable links from C.
142 E.g. vs = {a}, C = {H [a] b, K (b,Int) c, Eq e}
143 Then grow(vs,C) = {a,b,c}
145 Note that grow(vs,C) `superset` grow(vs,simplify(C))
146 That is, simplfication can only shrink the result of grow.
149 oclose is conservative one way: v `elem` oclose(vs,C) => v is definitely fixed by vs
150 grow is conservative the other way: if v might be fixed by vs => v `elem` grow(vs,C)
153 -----------------------------------------
157 Here's a good way to choose Q:
159 Q = grow( fv(T), C ) \ oclose( fv(G), C )
161 That is, quantify over all variable that that MIGHT be fixed by the
162 call site (which influences T), but which aren't DEFINITELY fixed by
163 G. This choice definitely quantifies over enough type variables,
164 albeit perhaps too many.
166 Why grow( fv(T), C ) rather than fv(T)? Consider
168 class H x y | x->y where ...
173 If we used fv(T) = {c} we'd get the type
175 forall c. H c d => c -> b
177 And then if the fn was called at several different c's, each of
178 which fixed d differently, we'd get a unification error, because
179 d isn't quantified. Solution: quantify d. So we must quantify
180 everything that might be influenced by c.
182 Why not oclose( fv(T), C )? Because we might not be able to see
183 all the functional dependencies yet:
185 class H x y | x->y where ...
186 instance H x y => Eq (T x y) where ...
191 Now oclose(fv(T),C) = {c}, because the functional dependency isn't
192 apparent yet, and that's wrong. We must really quantify over d too.
195 There really isn't any point in quantifying over any more than
196 grow( fv(T), C ), because the call sites can't possibly influence
197 any other type variables.
201 --------------------------------------
203 --------------------------------------
205 It's very hard to be certain when a type is ambiguous. Consider
209 instance H x y => K (x,y)
211 Is this type ambiguous?
212 forall a b. (K (a,b), Eq b) => a -> a
214 Looks like it! But if we simplify (K (a,b)) we get (H a b) and
215 now we see that a fixes b. So we can't tell about ambiguity for sure
216 without doing a full simplification. And even that isn't possible if
217 the context has some free vars that may get unified. Urgle!
219 Here's another example: is this ambiguous?
220 forall a b. Eq (T b) => a -> a
221 Not if there's an insance decl (with no context)
222 instance Eq (T b) where ...
224 You may say of this example that we should use the instance decl right
225 away, but you can't always do that:
227 class J a b where ...
228 instance J Int b where ...
230 f :: forall a b. J a b => a -> a
232 (Notice: no functional dependency in J's class decl.)
233 Here f's type is perfectly fine, provided f is only called at Int.
234 It's premature to complain when meeting f's signature, or even
235 when inferring a type for f.
239 However, we don't *need* to report ambiguity right away. It'll always
240 show up at the call site.... and eventually at main, which needs special
241 treatment. Nevertheless, reporting ambiguity promptly is an excellent thing.
243 So here's the plan. We WARN about probable ambiguity if
245 fv(Cq) is not a subset of oclose(fv(T) union fv(G), C)
247 (all tested before quantification).
248 That is, all the type variables in Cq must be fixed by the the variables
249 in the environment, or by the variables in the type.
251 Notice that we union before calling oclose. Here's an example:
253 class J a b c | a b -> c
257 forall b c. (J a b c) => b -> b
259 Only if we union {a} from G with {b} from T before using oclose,
260 do we see that c is fixed.
262 It's a bit vague exactly which C we should use for this oclose call. If we
263 don't fix enough variables we might complain when we shouldn't (see
264 the above nasty example). Nothing will be perfect. That's why we can
265 only issue a warning.
268 Can we ever be *certain* about ambiguity? Yes: if there's a constraint
270 c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY
272 then c is a "bubble"; there's no way it can ever improve, and it's
273 certainly ambiguous. UNLESS it is a constant (sigh). And what about
278 instance H x y => K (x,y)
280 Is this type ambiguous?
281 forall a b. (K (a,b), Eq b) => a -> a
283 Urk. The (Eq b) looks "definitely ambiguous" but it isn't. What we are after
284 is a "bubble" that's a set of constraints
286 Cq = Ca union Cq' st fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY
288 Hence another idea. To decide Q start with fv(T) and grow it
289 by transitive closure in Cq (no functional dependencies involved).
290 Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
291 The definitely-ambiguous can then float out, and get smashed at top level
292 (which squashes out the constants, like Eq (T a) above)
295 --------------------------------------
296 Notes on principal types
297 --------------------------------------
302 f x = let g y = op (y::Int) in True
304 Here the principal type of f is (forall a. a->a)
305 but we'll produce the non-principal type
306 f :: forall a. C Int => a -> a
309 --------------------------------------
310 Notes on implicit parameters
311 --------------------------------------
313 Question 1: can we "inherit" implicit parameters
314 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
319 where f is *not* a top-level binding.
320 From the RHS of f we'll get the constraint (?y::Int).
321 There are two types we might infer for f:
325 (so we get ?y from the context of f's definition), or
327 f :: (?y::Int) => Int -> Int
329 At first you might think the first was better, becuase then
330 ?y behaves like a free variable of the definition, rather than
331 having to be passed at each call site. But of course, the WHOLE
332 IDEA is that ?y should be passed at each call site (that's what
333 dynamic binding means) so we'd better infer the second.
335 BOTTOM LINE: when *inferring types* you *must* quantify
336 over implicit parameters. See the predicate isFreeWhenInferring.
339 Question 2: type signatures
340 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
341 BUT WATCH OUT: When you supply a type signature, we can't force you
342 to quantify over implicit parameters. For example:
346 This is perfectly reasonable. We do not want to insist on
348 (?x + 1) :: (?x::Int => Int)
350 That would be silly. Here, the definition site *is* the occurrence site,
351 so the above strictures don't apply. Hence the difference between
352 tcSimplifyCheck (which *does* allow implicit paramters to be inherited)
353 and tcSimplifyCheckBind (which does not).
355 What about when you supply a type signature for a binding?
356 Is it legal to give the following explicit, user type
357 signature to f, thus:
362 At first sight this seems reasonable, but it has the nasty property
363 that adding a type signature changes the dynamic semantics.
366 (let f x = (x::Int) + ?y
367 in (f 3, f 3 with ?y=5)) with ?y = 6
373 in (f 3, f 3 with ?y=5)) with ?y = 6
377 Indeed, simply inlining f (at the Haskell source level) would change the
380 Nevertheless, as Launchbury says (email Oct 01) we can't really give the
381 semantics for a Haskell program without knowing its typing, so if you
382 change the typing you may change the semantics.
384 To make things consistent in all cases where we are *checking* against
385 a supplied signature (as opposed to inferring a type), we adopt the
388 a signature does not need to quantify over implicit params.
390 [This represents a (rather marginal) change of policy since GHC 5.02,
391 which *required* an explicit signature to quantify over all implicit
392 params for the reasons mentioned above.]
394 But that raises a new question. Consider
396 Given (signature) ?x::Int
397 Wanted (inferred) ?x::Int, ?y::Bool
399 Clearly we want to discharge the ?x and float the ?y out. But
400 what is the criterion that distinguishes them? Clearly it isn't
401 what free type variables they have. The Right Thing seems to be
402 to float a constraint that
403 neither mentions any of the quantified type variables
404 nor any of the quantified implicit parameters
406 See the predicate isFreeWhenChecking.
409 Question 3: monomorphism
410 ~~~~~~~~~~~~~~~~~~~~~~~~
411 There's a nasty corner case when the monomorphism restriction bites:
415 The argument above suggests that we *must* generalise
416 over the ?y parameter, to get
417 z :: (?y::Int) => Int,
418 but the monomorphism restriction says that we *must not*, giving
420 Why does the momomorphism restriction say this? Because if you have
422 let z = x + ?y in z+z
424 you might not expect the addition to be done twice --- but it will if
425 we follow the argument of Question 2 and generalise over ?y.
431 (A) Always generalise over implicit parameters
432 Bindings that fall under the monomorphism restriction can't
436 * Inlining remains valid
437 * No unexpected loss of sharing
438 * But simple bindings like
440 will be rejected, unless you add an explicit type signature
441 (to avoid the monomorphism restriction)
442 z :: (?y::Int) => Int
444 This seems unacceptable
446 (B) Monomorphism restriction "wins"
447 Bindings that fall under the monomorphism restriction can't
449 Always generalise over implicit parameters *except* for bindings
450 that fall under the monomorphism restriction
453 * Inlining isn't valid in general
454 * No unexpected loss of sharing
455 * Simple bindings like
457 accepted (get value of ?y from binding site)
459 (C) Always generalise over implicit parameters
460 Bindings that fall under the monomorphism restriction can't
461 be generalised, EXCEPT for implicit parameters
463 * Inlining remains valid
464 * Unexpected loss of sharing (from the extra generalisation)
465 * Simple bindings like
467 accepted (get value of ?y from occurrence sites)
472 None of these choices seems very satisfactory. But at least we should
473 decide which we want to do.
475 It's really not clear what is the Right Thing To Do. If you see
479 would you expect the value of ?y to be got from the *occurrence sites*
480 of 'z', or from the valuue of ?y at the *definition* of 'z'? In the
481 case of function definitions, the answer is clearly the former, but
482 less so in the case of non-fucntion definitions. On the other hand,
483 if we say that we get the value of ?y from the definition site of 'z',
484 then inlining 'z' might change the semantics of the program.
486 Choice (C) really says "the monomorphism restriction doesn't apply
487 to implicit parameters". Which is fine, but remember that every
488 innocent binding 'x = ...' that mentions an implicit parameter in
489 the RHS becomes a *function* of that parameter, called at each
490 use of 'x'. Now, the chances are that there are no intervening 'with'
491 clauses that bind ?y, so a decent compiler should common up all
492 those function calls. So I think I strongly favour (C). Indeed,
493 one could make a similar argument for abolishing the monomorphism
494 restriction altogether.
496 BOTTOM LINE: we choose (B) at present. See tcSimplifyRestricted
500 %************************************************************************
502 \subsection{tcSimplifyInfer}
504 %************************************************************************
506 tcSimplify is called when we *inferring* a type. Here's the overall game plan:
508 1. Compute Q = grow( fvs(T), C )
510 2. Partition C based on Q into Ct and Cq. Notice that ambiguous
511 predicates will end up in Ct; we deal with them at the top level
513 3. Try improvement, using functional dependencies
515 4. If Step 3 did any unification, repeat from step 1
516 (Unification can change the result of 'grow'.)
518 Note: we don't reduce dictionaries in step 2. For example, if we have
519 Eq (a,b), we don't simplify to (Eq a, Eq b). So Q won't be different
520 after step 2. However note that we may therefore quantify over more
521 type variables than we absolutely have to.
523 For the guts, we need a loop, that alternates context reduction and
524 improvement with unification. E.g. Suppose we have
526 class C x y | x->y where ...
528 and tcSimplify is called with:
530 Then improvement unifies a with b, giving
533 If we need to unify anything, we rattle round the whole thing all over
540 -> TcTyVarSet -- fv(T); type vars
542 -> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
543 TcDictBinds, -- Bindings
544 [TcId]) -- Dict Ids that must be bound here (zonked)
545 -- Any free (escaping) Insts are tossed into the environment
550 tcSimplifyInfer doc tau_tvs wanted_lie
551 = inferLoop doc (varSetElems tau_tvs)
552 wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
554 -- Check for non-generalisable insts
555 mappM_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenM_`
557 extendLIEs frees `thenM_`
558 returnM (qtvs, binds, map instToId irreds)
560 inferLoop doc tau_tvs wanteds
562 zonkTcTyVarsAndFV tau_tvs `thenM` \ tau_tvs' ->
563 mappM zonkInst wanteds `thenM` \ wanteds' ->
564 tcGetGlobalTyVars `thenM` \ gbl_tvs ->
566 preds = fdPredsOfInsts wanteds'
567 qtvs = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
570 | isFreeWhenInferring qtvs inst = Free
571 | isClassDict inst = DontReduceUnlessConstant -- Dicts
572 | otherwise = ReduceMe -- Lits and Methods
574 traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_`
576 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
579 if no_improvement then
580 returnM (varSetElems qtvs, frees, binds, irreds)
582 -- If improvement did some unification, we go round again. There
583 -- are two subtleties:
584 -- a) We start again with irreds, not wanteds
585 -- Using an instance decl might have introduced a fresh type variable
586 -- which might have been unified, so we'd get an infinite loop
587 -- if we started again with wanteds! See example [LOOP]
589 -- b) It's also essential to re-process frees, because unification
590 -- might mean that a type variable that looked free isn't now.
592 -- Hence the (irreds ++ frees)
594 -- However, NOTICE that when we are done, we might have some bindings, but
595 -- the final qtvs might be empty. See [NO TYVARS] below.
597 inferLoop doc tau_tvs (irreds ++ frees) `thenM` \ (qtvs1, frees1, binds1, irreds1) ->
598 returnM (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
603 class If b t e r | b t e -> r
606 class Lte a b c | a b -> c where lte :: a -> b -> c
608 instance (Lte a b l,If l b a c) => Max a b c
610 Wanted: Max Z (S x) y
612 Then we'll reduce using the Max instance to:
613 (Lte Z (S x) l, If l (S x) Z y)
614 and improve by binding l->T, after which we can do some reduction
615 on both the Lte and If constraints. What we *can't* do is start again
616 with (Max Z (S x) y)!
620 class Y a b | a -> b where
623 instance Y [[a]] a where
626 k :: X a -> X a -> X a
628 g :: Num a => [X a] -> [X a]
631 h ys = ys ++ map (k (y [[0]])) xs
633 The excitement comes when simplifying the bindings for h. Initially
634 try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
635 From this we get t1:=:t2, but also various bindings. We can't forget
636 the bindings (because of [LOOP]), but in fact t1 is what g is
639 The net effect of [NO TYVARS]
642 isFreeWhenInferring :: TyVarSet -> Inst -> Bool
643 isFreeWhenInferring qtvs inst
644 = isFreeWrtTyVars qtvs inst -- Constrains no quantified vars
645 && isInheritableInst inst -- And no implicit parameter involved
646 -- (see "Notes on implicit parameters")
648 isFreeWhenChecking :: TyVarSet -- Quantified tyvars
649 -> NameSet -- Quantified implicit parameters
651 isFreeWhenChecking qtvs ips inst
652 = isFreeWrtTyVars qtvs inst
653 && isFreeWrtIPs ips inst
655 isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
656 isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
660 %************************************************************************
662 \subsection{tcSimplifyCheck}
664 %************************************************************************
666 @tcSimplifyCheck@ is used when we know exactly the set of variables
667 we are going to quantify over. For example, a class or instance declaration.
672 -> [TcTyVar] -- Quantify over these
675 -> TcM TcDictBinds -- Bindings
677 -- tcSimplifyCheck is used when checking expression type signatures,
678 -- class decls, instance decls etc.
680 -- NB: tcSimplifyCheck does not consult the
681 -- global type variables in the environment; so you don't
682 -- need to worry about setting them before calling tcSimplifyCheck
683 tcSimplifyCheck doc qtvs givens wanted_lie
684 = tcSimplCheck doc get_qtvs
685 givens wanted_lie `thenM` \ (qtvs', binds) ->
688 get_qtvs = zonkTcTyVarsAndFV qtvs
691 -- tcSimplifyInferCheck is used when we know the constraints we are to simplify
692 -- against, but we don't know the type variables over which we are going to quantify.
693 -- This happens when we have a type signature for a mutually recursive group
696 -> TcTyVarSet -- fv(T)
699 -> TcM ([TcTyVar], -- Variables over which to quantify
700 TcDictBinds) -- Bindings
702 tcSimplifyInferCheck doc tau_tvs givens wanted_lie
703 = tcSimplCheck doc get_qtvs givens wanted_lie
705 -- Figure out which type variables to quantify over
706 -- You might think it should just be the signature tyvars,
707 -- but in bizarre cases you can get extra ones
708 -- f :: forall a. Num a => a -> a
709 -- f x = fst (g (x, head [])) + 1
711 -- Here we infer g :: forall a b. a -> b -> (b,a)
712 -- We don't want g to be monomorphic in b just because
713 -- f isn't quantified over b.
714 all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)
716 get_qtvs = zonkTcTyVarsAndFV all_tvs `thenM` \ all_tvs' ->
717 tcGetGlobalTyVars `thenM` \ gbl_tvs ->
719 qtvs = all_tvs' `minusVarSet` gbl_tvs
720 -- We could close gbl_tvs, but its not necessary for
721 -- soundness, and it'll only affect which tyvars, not which
722 -- dictionaries, we quantify over
727 Here is the workhorse function for all three wrappers.
730 tcSimplCheck doc get_qtvs givens wanted_lie
731 = check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
733 -- Complain about any irreducible ones
734 complainCheck doc givens irreds `thenM_`
737 extendLIEs frees `thenM_`
738 returnM (qtvs, binds)
741 ip_set = mkNameSet (ipNamesOfInsts givens)
743 check_loop givens wanteds
745 mappM zonkInst givens `thenM` \ givens' ->
746 mappM zonkInst wanteds `thenM` \ wanteds' ->
747 get_qtvs `thenM` \ qtvs' ->
751 -- When checking against a given signature we always reduce
752 -- until we find a match against something given, or can't reduce
753 try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free
754 | otherwise = ReduceMe
756 reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
759 if no_improvement then
760 returnM (varSetElems qtvs', frees, binds, irreds)
762 check_loop givens' (irreds ++ frees) `thenM` \ (qtvs', frees1, binds1, irreds1) ->
763 returnM (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1)
767 %************************************************************************
769 \subsection{tcSimplifyRestricted}
771 %************************************************************************
774 tcSimplifyRestricted -- Used for restricted binding groups
775 -- i.e. ones subject to the monomorphism restriction
777 -> TcTyVarSet -- Free in the type of the RHSs
778 -> [Inst] -- Free in the RHSs
779 -> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
780 TcDictBinds) -- Bindings
782 tcSimplifyRestricted doc tau_tvs wanteds
783 = -- First squash out all methods, to find the constrained tyvars
784 -- We can't just take the free vars of wanted_lie because that'll
785 -- have methods that may incidentally mention entirely unconstrained variables
786 -- e.g. a call to f :: Eq a => a -> b -> b
787 -- Here, b is unconstrained. A good example would be
789 -- We want to infer the polymorphic type
790 -- foo :: forall b. b -> b
792 -- 'reduceMe': Reduce as far as we can. Don't stop at
793 -- dicts; the idea is to get rid of as many type
794 -- variables as possible, and we don't want to stop
795 -- at (say) Monad (ST s), because that reduces
796 -- immediately, with no constraint on s.
797 simpleReduceLoop doc reduceMe wanteds `thenM` \ (foo_frees, foo_binds, constrained_dicts) ->
799 -- Next, figure out the tyvars we will quantify over
800 zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' ->
801 tcGetGlobalTyVars `thenM` \ gbl_tvs ->
803 constrained_tvs = tyVarsOfInsts constrained_dicts
804 qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs)
805 `minusVarSet` constrained_tvs
807 traceTc (text "tcSimplifyRestricted" <+> vcat [
808 pprInsts wanteds, pprInsts foo_frees, pprInsts constrained_dicts,
810 ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_`
812 -- The first step may have squashed more methods than
813 -- necessary, so try again, this time knowing the exact
814 -- set of type variables to quantify over.
816 -- We quantify only over constraints that are captured by qtvs;
817 -- these will just be a subset of non-dicts. This in contrast
818 -- to normal inference (using isFreeWhenInferring) in which we quantify over
819 -- all *non-inheritable* constraints too. This implements choice
820 -- (B) under "implicit parameter and monomorphism" above.
822 -- Remember that we may need to do *some* simplification, to
823 -- (for example) squash {Monad (ST s)} into {}. It's not enough
824 -- just to float all constraints
825 restrict_loop doc qtvs wanteds
826 -- We still need a loop because improvement can take place
827 -- E.g. if we have (C (T a)) and the instance decl
828 -- instance D Int b => C (T a) where ...
829 -- and there's a functional dependency for D. Then we may improve
830 -- the tyep variable 'b'.
832 restrict_loop doc qtvs wanteds
833 = mappM zonkInst wanteds `thenM` \ wanteds' ->
834 zonkTcTyVarsAndFV (varSetElems qtvs) `thenM` \ qtvs' ->
836 try_me inst | isFreeWrtTyVars qtvs' inst = Free
837 | otherwise = ReduceMe
839 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
840 if no_improvement then
841 ASSERT( null irreds )
842 extendLIEs frees `thenM_`
843 returnM (varSetElems qtvs', binds)
845 restrict_loop doc qtvs' (irreds ++ frees) `thenM` \ (qtvs1, binds1) ->
846 returnM (qtvs1, binds `AndMonoBinds` binds1)
850 %************************************************************************
852 \subsection{tcSimplifyToDicts}
854 %************************************************************************
856 On the LHS of transformation rules we only simplify methods and constants,
857 getting dictionaries. We want to keep all of them unsimplified, to serve
858 as the available stuff for the RHS of the rule.
860 The same thing is used for specialise pragmas. Consider
863 {-# SPECIALISE f :: Int -> Int #-}
866 The type checker generates a binding like:
868 f_spec = (f :: Int -> Int)
870 and we want to end up with
872 f_spec = _inline_me_ (f Int dNumInt)
874 But that means that we must simplify the Method for f to (f Int dNumInt)!
875 So tcSimplifyToDicts squeezes out all Methods.
877 IMPORTANT NOTE: we *don't* want to do superclass commoning up. Consider
879 fromIntegral :: (Integral a, Num b) => a -> b
880 {-# RULES "foo" fromIntegral = id :: Int -> Int #-}
882 Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
886 fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
888 because the scsel will mess up matching. Instead we want
890 forall dIntegralInt, dNumInt.
891 fromIntegral Int Int dIntegralInt dNumInt = id Int
893 Hence "DontReduce NoSCs"
896 tcSimplifyToDicts :: [Inst] -> TcM (TcDictBinds)
897 tcSimplifyToDicts wanteds
898 = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
899 -- Since try_me doesn't look at types, we don't need to
900 -- do any zonking, so it's safe to call reduceContext directly
902 extendLIEs irreds `thenM_`
906 doc = text "tcSimplifyToDicts"
908 -- Reduce methods and lits only; stop as soon as we get a dictionary
909 try_me inst | isDict inst = DontReduce NoSCs
910 | otherwise = ReduceMe
915 tcSimplifyBracket is used when simplifying the constraints arising from
916 a Template Haskell bracket [| ... |]. We want to check that there aren't
917 any constraints that can't be satisfied (e.g. Show Foo, where Foo has no
918 Show instance), but we aren't otherwise interested in the results.
919 Nor do we care about ambiguous dictionaries etc. We will type check
920 this bracket again at its usage site.
923 tcSimplifyBracket :: [Inst] -> TcM ()
924 tcSimplifyBracket wanteds
925 = simpleReduceLoop doc reduceMe wanteds `thenM_`
928 doc = text "tcSimplifyBracket"
932 %************************************************************************
934 \subsection{Filtering at a dynamic binding}
936 %************************************************************************
941 we must discharge all the ?x constraints from B. We also do an improvement
942 step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.
944 Actually, the constraints from B might improve the types in ?x. For example
946 f :: (?x::Int) => Char -> Char
949 then the constraint (?x::Int) arising from the call to f will
950 force the binding for ?x to be of type Int.
953 tcSimplifyIPs :: [Inst] -- The implicit parameters bound here
956 tcSimplifyIPs given_ips wanteds
957 = simpl_loop given_ips wanteds `thenM` \ (frees, binds) ->
958 extendLIEs frees `thenM_`
961 doc = text "tcSimplifyIPs" <+> ppr given_ips
962 ip_set = mkNameSet (ipNamesOfInsts given_ips)
964 -- Simplify any methods that mention the implicit parameter
965 try_me inst | isFreeWrtIPs ip_set inst = Free
966 | otherwise = ReduceMe
968 simpl_loop givens wanteds
969 = mappM zonkInst givens `thenM` \ givens' ->
970 mappM zonkInst wanteds `thenM` \ wanteds' ->
972 reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
974 if no_improvement then
975 ASSERT( null irreds )
976 returnM (frees, binds)
978 simpl_loop givens' (irreds ++ frees) `thenM` \ (frees1, binds1) ->
979 returnM (frees1, binds `AndMonoBinds` binds1)
983 %************************************************************************
985 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
987 %************************************************************************
989 When doing a binding group, we may have @Insts@ of local functions.
990 For example, we might have...
992 let f x = x + 1 -- orig local function (overloaded)
993 f.1 = f Int -- two instances of f
998 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
999 where @f@ is in scope; those @Insts@ must certainly not be passed
1000 upwards towards the top-level. If the @Insts@ were binding-ified up
1001 there, they would have unresolvable references to @f@.
1003 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
1004 For each method @Inst@ in the @init_lie@ that mentions one of the
1005 @Ids@, we create a binding. We return the remaining @Insts@ (in an
1006 @LIE@), as well as the @HsBinds@ generated.
1009 bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcMonoBinds
1011 bindInstsOfLocalFuns wanteds local_ids
1012 | null overloaded_ids
1014 = extendLIEs wanteds `thenM_`
1015 returnM EmptyMonoBinds
1018 = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
1019 ASSERT( null irreds )
1020 extendLIEs frees `thenM_`
1023 doc = text "bindInsts" <+> ppr local_ids
1024 overloaded_ids = filter is_overloaded local_ids
1025 is_overloaded id = isOverloadedTy (idType id)
1027 overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
1028 -- so it's worth building a set, so that
1029 -- lookup (in isMethodFor) is faster
1031 try_me inst | isMethodFor overloaded_set inst = ReduceMe
1036 %************************************************************************
1038 \subsection{Data types for the reduction mechanism}
1040 %************************************************************************
1042 The main control over context reduction is here
1046 = ReduceMe -- Try to reduce this
1047 -- If there's no instance, behave exactly like
1048 -- DontReduce: add the inst to
1049 -- the irreductible ones, but don't
1050 -- produce an error message of any kind.
1051 -- It might be quite legitimate such as (Eq a)!
1053 | DontReduce WantSCs -- Return as irreducible
1055 | DontReduceUnlessConstant -- Return as irreducible unless it can
1056 -- be reduced to a constant in one step
1058 | Free -- Return as free
1060 reduceMe :: Inst -> WhatToDo
1061 reduceMe inst = ReduceMe
1063 data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
1064 -- of a predicate when adding it to the avails
1070 type Avails = FiniteMap Inst Avail
1073 = IsFree -- Used for free Insts
1074 | Irred -- Used for irreducible dictionaries,
1075 -- which are going to be lambda bound
1077 | Given TcId -- Used for dictionaries for which we have a binding
1078 -- e.g. those "given" in a signature
1079 Bool -- True <=> actually consumed (splittable IPs only)
1081 | NoRhs -- Used for Insts like (CCallable f)
1082 -- where no witness is required.
1084 | Rhs -- Used when there is a RHS
1086 [Inst] -- Insts free in the RHS; we need these too
1088 | Linear -- Splittable Insts only.
1089 Int -- The Int is always 2 or more; indicates how
1090 -- many copies are required
1091 Inst -- The splitter
1092 Avail -- Where the "master copy" is
1094 | LinRhss -- Splittable Insts only; this is used only internally
1095 -- by extractResults, where a Linear
1096 -- is turned into an LinRhss
1097 [TcExpr] -- A supply of suitable RHSs
1099 pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
1100 | (inst,avail) <- fmToList avails ]
1102 instance Outputable Avail where
1105 pprAvail NoRhs = text "<no rhs>"
1106 pprAvail IsFree = text "Free"
1107 pprAvail Irred = text "Irred"
1108 pprAvail (Given x b) = text "Given" <+> ppr x <+>
1109 if b then text "(used)" else empty
1110 pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs)
1111 pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a
1112 pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss
1115 Extracting the bindings from a bunch of Avails.
1116 The bindings do *not* come back sorted in dependency order.
1117 We assume that they'll be wrapped in a big Rec, so that the
1118 dependency analyser can sort them out later
1122 extractResults :: Avails
1124 -> TcM (TcDictBinds, -- Bindings
1125 [Inst], -- Irreducible ones
1126 [Inst]) -- Free ones
1128 extractResults avails wanteds
1129 = go avails EmptyMonoBinds [] [] wanteds
1131 go avails binds irreds frees []
1132 = returnM (binds, irreds, frees)
1134 go avails binds irreds frees (w:ws)
1135 = case lookupFM avails w of
1136 Nothing -> pprTrace "Urk: extractResults" (ppr w) $
1137 go avails binds irreds frees ws
1139 Just NoRhs -> go avails binds irreds frees ws
1140 Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws
1141 Just Irred -> go (add_given avails w) binds (w:irreds) frees ws
1143 Just (Given id _) -> go avails new_binds irreds frees ws
1145 new_binds | id == instToId w = binds
1146 | otherwise = addBind binds w (HsVar id)
1147 -- The sought Id can be one of the givens, via a superclass chain
1148 -- and then we definitely don't want to generate an x=x binding!
1150 Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws)
1152 new_binds = addBind binds w rhs
1154 Just (Linear n split_inst avail) -- Transform Linear --> LinRhss
1155 -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) ->
1156 split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) ->
1157 go (addToFM avails w (LinRhss rhss))
1158 (binds `AndMonoBinds` binds')
1159 irreds' frees' (split_inst : w : ws)
1161 Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss
1162 -> go new_avails new_binds irreds frees ws
1164 new_binds = addBind binds w rhs
1165 new_avails = addToFM avails w (LinRhss rhss)
1167 get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
1168 get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
1169 returnM (w':irreds, frees, instToId w')
1170 get_root irreds frees IsFree w = cloneDict w `thenM` \ w' ->
1171 returnM (irreds, w':frees, instToId w')
1174 | instBindingRequired w = addToFM avails w (Given (instToId w) True)
1175 | otherwise = addToFM avails w NoRhs
1176 -- NB: make sure that CCallable/CReturnable use NoRhs rather
1177 -- than Given, else we end up with bogus bindings.
1179 add_free avails w | isMethod w = avails
1180 | otherwise = add_given avails w
1182 -- Do *not* replace Free by Given if it's a method.
1183 -- The following situation shows why this is bad:
1184 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
1185 -- From an application (truncate f i) we get
1186 -- t1 = truncate at f
1188 -- If we have also have a second occurrence of truncate, we get
1189 -- t3 = truncate at f
1191 -- When simplifying with i,f free, we might still notice that
1192 -- t1=t3; but alas, the binding for t2 (which mentions t1)
1193 -- will continue to float out!
1194 -- (split n i a) returns: n rhss
1195 -- auxiliary bindings
1196 -- 1 or 0 insts to add to irreds
1199 split :: Int -> TcId -> TcId -> Inst
1200 -> TcM (TcDictBinds, [TcExpr])
1201 -- (split n split_id root_id wanted) returns
1202 -- * a list of 'n' expressions, all of which witness 'avail'
1203 -- * a bunch of auxiliary bindings to support these expressions
1204 -- * one or zero insts needed to witness the whole lot
1205 -- (maybe be zero if the initial Inst is a Given)
1207 -- NB: 'wanted' is just a template
1209 split n split_id root_id wanted
1212 ty = linearInstType wanted
1213 pair_ty = mkTyConApp pairTyCon [ty,ty]
1214 id = instToId wanted
1218 go 1 = returnM (EmptyMonoBinds, [HsVar root_id])
1220 go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) ->
1221 expand n rhss `thenM` \ (binds2, rhss') ->
1222 returnM (binds1 `AndMonoBinds` binds2, rhss')
1225 -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
1226 -- e.g. expand 3 [rhs1, rhs2]
1227 -- = ( { x = split rhs1 },
1228 -- [fst x, snd x, rhs2] )
1230 | n `rem` 2 == 0 = go rhss -- n is even
1231 | otherwise = go (tail rhss) `thenM` \ (binds', rhss') ->
1232 returnM (binds', head rhss : rhss')
1234 go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') ->
1235 returnM (andMonoBindList binds', concat rhss')
1237 do_one rhs = newUnique `thenM` \ uniq ->
1238 tcLookupId fstName `thenM` \ fst_id ->
1239 tcLookupId sndName `thenM` \ snd_id ->
1241 x = mkUserLocal occ uniq pair_ty loc
1243 returnM (VarMonoBind x (mk_app split_id rhs),
1244 [mk_fs_app fst_id ty x, mk_fs_app snd_id ty x])
1246 mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var
1248 mk_app id rhs = HsApp (HsVar id) rhs
1250 addBind binds inst rhs = binds `AndMonoBinds` VarMonoBind (instToId inst) rhs
1254 %************************************************************************
1256 \subsection[reduce]{@reduce@}
1258 %************************************************************************
1260 When the "what to do" predicate doesn't depend on the quantified type variables,
1261 matters are easier. We don't need to do any zonking, unless the improvement step
1262 does something, in which case we zonk before iterating.
1264 The "given" set is always empty.
1267 simpleReduceLoop :: SDoc
1268 -> (Inst -> WhatToDo) -- What to do, *not* based on the quantified type variables
1270 -> TcM ([Inst], -- Free
1272 [Inst]) -- Irreducible
1274 simpleReduceLoop doc try_me wanteds
1275 = mappM zonkInst wanteds `thenM` \ wanteds' ->
1276 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
1277 if no_improvement then
1278 returnM (frees, binds, irreds)
1280 simpleReduceLoop doc try_me (irreds ++ frees) `thenM` \ (frees1, binds1, irreds1) ->
1281 returnM (frees1, binds `AndMonoBinds` binds1, irreds1)
1287 reduceContext :: SDoc
1288 -> (Inst -> WhatToDo)
1291 -> TcM (Bool, -- True <=> improve step did no unification
1293 TcDictBinds, -- Dictionary bindings
1294 [Inst]) -- Irreducible
1296 reduceContext doc try_me givens wanteds
1298 traceTc (text "reduceContext" <+> (vcat [
1299 text "----------------------",
1301 text "given" <+> ppr givens,
1302 text "wanted" <+> ppr wanteds,
1303 text "----------------------"
1306 -- Build the Avail mapping from "givens"
1307 foldlM addGiven emptyFM givens `thenM` \ init_state ->
1310 reduceList (0,[]) try_me wanteds init_state `thenM` \ avails ->
1312 -- Do improvement, using everything in avails
1313 -- In particular, avails includes all superclasses of everything
1314 tcImprove avails `thenM` \ no_improvement ->
1316 extractResults avails wanteds `thenM` \ (binds, irreds, frees) ->
1318 traceTc (text "reduceContext end" <+> (vcat [
1319 text "----------------------",
1321 text "given" <+> ppr givens,
1322 text "wanted" <+> ppr wanteds,
1324 text "avails" <+> pprAvails avails,
1325 text "frees" <+> ppr frees,
1326 text "no_improvement =" <+> ppr no_improvement,
1327 text "----------------------"
1330 returnM (no_improvement, frees, binds, irreds)
1333 = tcGetInstEnv `thenM` \ inst_env ->
1335 preds = [ (pred, pp_loc)
1336 | inst <- keysFM avails,
1337 let pp_loc = pprInstLoc (instLoc inst),
1338 pred <- fdPredsOfInst inst
1340 -- Avails has all the superclasses etc (good)
1341 -- It also has all the intermediates of the deduction (good)
1342 -- It does not have duplicates (good)
1343 -- NB that (?x::t1) and (?x::t2) will be held separately in avails
1344 -- so that improve will see them separate
1345 eqns = improve (classInstEnv inst_env) preds
1350 traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenM_`
1351 mappM_ unify eqns `thenM_`
1354 unify ((qtvs, t1, t2), doc)
1356 tcInstTyVars VanillaTv (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
1357 unifyTauTy (substTy tenv t1) (substTy tenv t2)
1360 The main context-reduction function is @reduce@. Here's its game plan.
1363 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
1364 -- along with its depth
1365 -> (Inst -> WhatToDo)
1372 try_me: given an inst, this function returns
1374 DontReduce return this in "irreds"
1375 Free return this in "frees"
1377 wanteds: The list of insts to reduce
1378 state: An accumulating parameter of type Avails
1379 that contains the state of the algorithm
1381 It returns a Avails.
1383 The (n,stack) pair is just used for error reporting.
1384 n is always the depth of the stack.
1385 The stack is the stack of Insts being reduced: to produce X
1386 I had to produce Y, to produce Y I had to produce Z, and so on.
1389 reduceList (n,stack) try_me wanteds state
1390 | n > opt_MaxContextReductionDepth
1391 = failWithTc (reduceDepthErr n stack)
1397 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
1402 go [] state = returnM state
1403 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ state' ->
1406 -- Base case: we're done!
1407 reduce stack try_me wanted state
1408 -- It's the same as an existing inst, or a superclass thereof
1409 | Just avail <- isAvailable state wanted
1410 = if isLinearInst wanted then
1411 addLinearAvailable state avail wanted `thenM` \ (state', wanteds') ->
1412 reduceList stack try_me wanteds' state'
1414 returnM state -- No op for non-linear things
1417 = case try_me wanted of {
1419 DontReduce want_scs -> addIrred want_scs state wanted
1421 ; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
1422 -- First, see if the inst can be reduced to a constant in one step
1423 try_simple (addIrred AddSCs) -- Assume want superclasses
1425 ; Free -> -- It's free so just chuck it upstairs
1426 -- First, see if the inst can be reduced to a constant in one step
1429 ; ReduceMe -> -- It should be reduced
1430 lookupInst wanted `thenM` \ lookup_result ->
1431 case lookup_result of
1432 GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenM` \ state' ->
1433 addWanted state' wanted rhs wanteds'
1434 SimpleInst rhs -> addWanted state wanted rhs []
1436 NoInstance -> -- No such instance!
1437 -- Add it and its superclasses
1438 addIrred AddSCs state wanted
1442 try_simple do_this_otherwise
1443 = lookupInst wanted `thenM` \ lookup_result ->
1444 case lookup_result of
1445 SimpleInst rhs -> addWanted state wanted rhs []
1446 other -> do_this_otherwise state wanted
1451 -------------------------
1452 isAvailable :: Avails -> Inst -> Maybe Avail
1453 isAvailable avails wanted = lookupFM avails wanted
1454 -- NB 1: the Ord instance of Inst compares by the class/type info
1455 -- *not* by unique. So
1456 -- d1::C Int == d2::C Int
1458 addLinearAvailable :: Avails -> Avail -> Inst -> TcM (Avails, [Inst])
1459 addLinearAvailable avails avail wanted
1460 -- avails currently maps [wanted -> avail]
1461 -- Extend avails to reflect a neeed for an extra copy of avail
1463 | Just avail' <- split_avail avail
1464 = returnM (addToFM avails wanted avail', [])
1467 = tcLookupId splitName `thenM` \ split_id ->
1468 tcInstClassOp (instLoc wanted) split_id
1469 [linearInstType wanted] `thenM` \ split_inst ->
1470 returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
1473 split_avail :: Avail -> Maybe Avail
1474 -- (Just av) if there's a modified version of avail that
1475 -- we can use to replace avail in avails
1476 -- Nothing if there isn't, so we need to create a Linear
1477 split_avail (Linear n i a) = Just (Linear (n+1) i a)
1478 split_avail (Given id used) | not used = Just (Given id True)
1479 | otherwise = Nothing
1480 split_avail Irred = Nothing
1481 split_avail IsFree = Nothing
1482 split_avail other = pprPanic "addLinearAvailable" (ppr avail $$ ppr wanted $$ ppr avails)
1484 -------------------------
1485 addFree :: Avails -> Inst -> TcM Avails
1486 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
1487 -- to avails, so that any other equal Insts will be commoned up right
1488 -- here rather than also being tossed upstairs. This is really just
1489 -- an optimisation, and perhaps it is more trouble that it is worth,
1490 -- as the following comments show!
1492 -- NB: do *not* add superclasses. If we have
1495 -- but a is not bound here, then we *don't* want to derive
1496 -- dn from df here lest we lose sharing.
1498 addFree avails free = returnM (addToFM avails free IsFree)
1500 addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> TcM Avails
1501 addWanted avails wanted rhs_expr wanteds
1502 = ASSERT2( not (wanted `elemFM` avails), ppr wanted $$ ppr avails )
1503 addAvailAndSCs avails wanted avail
1505 avail | instBindingRequired wanted = Rhs rhs_expr wanteds
1506 | otherwise = ASSERT( null wanteds ) NoRhs
1508 addGiven :: Avails -> Inst -> TcM Avails
1509 addGiven state given = addAvailAndSCs state given (Given (instToId given) False)
1510 -- No ASSERT( not (given `elemFM` avails) ) because in an instance
1511 -- decl for Ord t we can add both Ord t and Eq t as 'givens',
1512 -- so the assert isn't true
1514 addIrred :: WantSCs -> Avails -> Inst -> TcM Avails
1515 addIrred NoSCs avails irred = returnM (addToFM avails irred Irred)
1516 addIrred AddSCs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails )
1517 addAvailAndSCs avails irred Irred
1519 addAvailAndSCs :: Avails -> Inst -> Avail -> TcM Avails
1520 addAvailAndSCs avails inst avail
1521 | not (isClassDict inst) = returnM avails1
1522 | otherwise = addSCs is_loop avails1 inst
1524 avails1 = addToFM avails inst avail
1525 is_loop inst = inst `elem` deps -- Note: this compares by *type*, not by Unique
1526 deps = findAllDeps avails avail
1528 findAllDeps :: Avails -> Avail -> [Inst]
1529 -- Find all the Insts that this one depends on
1530 -- See Note [SUPERCLASS-LOOP]
1531 findAllDeps avails (Rhs _ kids) = kids ++ concat (map (find_all_deps_help avails) kids)
1532 findAllDeps avails other = []
1534 find_all_deps_help :: Avails -> Inst -> [Inst]
1535 find_all_deps_help avails inst
1536 = case lookupFM avails inst of
1537 Just avail -> findAllDeps avails avail
1540 addSCs :: (Inst -> Bool) -> Avails -> Inst -> TcM Avails
1541 -- Add all the superclasses of the Inst to Avails
1542 -- The first param says "dont do this because the original thing
1543 -- depends on this one, so you'd build a loop"
1544 -- Invariant: the Inst is already in Avails.
1546 addSCs is_loop avails dict
1547 = newDictsFromOld dict sc_theta' `thenM` \ sc_dicts ->
1548 foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
1550 (clas, tys) = getDictClassTys dict
1551 (tyvars, sc_theta, sc_sels, _) = classBigSig clas
1552 sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
1554 add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
1555 = case lookupFM avails sc_dict of
1556 Just (Given _ _) -> returnM avails -- Given is cheaper than
1557 -- a superclass selection
1558 Just other | is_loop sc_dict -> returnM avails -- See Note [SUPERCLASS-LOOP]
1559 | otherwise -> returnM avails' -- SCs already added
1561 Nothing -> addSCs is_loop avails' sc_dict
1563 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
1564 avail = Rhs sc_sel_rhs [dict]
1565 avails' = addToFM avails sc_dict avail
1568 Note [SUPERCLASS-LOOP]: Checking for loops
1569 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1570 We have to be careful here. If we are *given* d1:Ord a,
1571 and want to deduce (d2:C [a]) where
1573 class Ord a => C a where
1574 instance Ord a => C [a] where ...
1576 Then we'll use the instance decl to deduce C [a] and then add the
1577 superclasses of C [a] to avails. But we must not overwrite the binding
1578 for d1:Ord a (which is given) with a superclass selection or we'll just
1581 Here's another example
1582 class Eq b => Foo a b
1583 instance Eq a => Foo [a] a
1587 we'll first deduce that it holds (via the instance decl). We must not
1588 then overwrite the Eq t constraint with a superclass selection!
1590 At first I had a gross hack, whereby I simply did not add superclass constraints
1591 in addWanted, though I did for addGiven and addIrred. This was sub-optimal,
1592 becuase it lost legitimate superclass sharing, and it still didn't do the job:
1593 I found a very obscure program (now tcrun021) in which improvement meant the
1594 simplifier got two bites a the cherry... so something seemed to be an Irred
1595 first time, but reducible next time.
1597 Now we implement the Right Solution, which is to check for loops directly
1598 when adding superclasses. It's a bit like the occurs check in unification.
1602 %************************************************************************
1604 \section{tcSimplifyTop: defaulting}
1606 %************************************************************************
1609 @tcSimplifyTop@ is called once per module to simplify all the constant
1610 and ambiguous Insts.
1612 We need to be careful of one case. Suppose we have
1614 instance Num a => Num (Foo a b) where ...
1616 and @tcSimplifyTop@ is given a constraint (Num (Foo x y)). Then it'll simplify
1617 to (Num x), and default x to Int. But what about y??
1619 It's OK: the final zonking stage should zap y to (), which is fine.
1623 tcSimplifyTop :: [Inst] -> TcM TcDictBinds
1624 -- The TcLclEnv should be valid here, solely to improve
1625 -- error message generation for the monomorphism restriction
1626 tcSimplifyTop wanteds
1627 = getLclEnv `thenM` \ lcl_env ->
1628 traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) `thenM_`
1629 simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
1630 ASSERT( null frees )
1633 -- All the non-std ones are definite errors
1634 (stds, non_stds) = partition isStdClassTyVarDict irreds
1636 -- Group by type variable
1637 std_groups = equivClasses cmp_by_tyvar stds
1639 -- Pick the ones which its worth trying to disambiguate
1640 -- namely, the onese whose type variable isn't bound
1641 -- up with one of the non-standard classes
1642 (std_oks, std_bads) = partition worth_a_try std_groups
1643 worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d)
1644 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
1646 -- Collect together all the bad guys
1647 bad_guys = non_stds ++ concat std_bads
1648 (tidy_env, tidy_dicts) = tidyInsts bad_guys
1649 (bad_ips, non_ips) = partition isIPDict tidy_dicts
1650 (no_insts, ambigs) = partition no_inst non_ips
1651 no_inst d = not (isTyVarDict d)
1652 -- Previously, there was a more elaborate no_inst definition:
1653 -- no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
1654 -- fixed_tvs = oclose (fdPredsOfInsts tidy_dicts) emptyVarSet
1655 -- But that seems over-elaborate to me; it only bites for class decls with
1656 -- fundeps like this: class C a b | -> b where ...
1659 -- Report definite errors
1660 addTopInstanceErrs tidy_env no_insts `thenM_`
1661 addTopIPErrs tidy_env bad_ips `thenM_`
1663 -- Deal with ambiguity errors, but only if
1664 -- if there has not been an error so far; errors often
1665 -- give rise to spurious ambiguous Insts
1666 ifErrsM (returnM []) (
1668 -- Complain about the ones that don't fall under
1669 -- the Haskell rules for disambiguation
1670 -- This group includes both non-existent instances
1671 -- e.g. Num (IO a) and Eq (Int -> Int)
1672 -- and ambiguous dictionaries
1674 addTopAmbigErrs (tidy_env, ambigs) `thenM_`
1676 -- Disambiguate the ones that look feasible
1677 getGhciMode `thenM` \ mode ->
1678 mappM (disambigGroup mode) std_oks
1679 ) `thenM` \ binds_ambig ->
1681 returnM (binds `andMonoBinds` andMonoBindList binds_ambig)
1683 ----------------------------------
1684 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1686 get_tv d = case getDictClassTys d of
1687 (clas, [ty]) -> tcGetTyVar "tcSimplify" ty
1688 get_clas d = case getDictClassTys d of
1689 (clas, [ty]) -> clas
1692 If a dictionary constrains a type variable which is
1693 * not mentioned in the environment
1694 * and not mentioned in the type of the expression
1695 then it is ambiguous. No further information will arise to instantiate
1696 the type variable; nor will it be generalised and turned into an extra
1697 parameter to a function.
1699 It is an error for this to occur, except that Haskell provided for
1700 certain rules to be applied in the special case of numeric types.
1702 * at least one of its classes is a numeric class, and
1703 * all of its classes are numeric or standard
1704 then the type variable can be defaulted to the first type in the
1705 default-type list which is an instance of all the offending classes.
1707 So here is the function which does the work. It takes the ambiguous
1708 dictionaries and either resolves them (producing bindings) or
1709 complains. It works by splitting the dictionary list by type
1710 variable, and using @disambigOne@ to do the real business.
1712 @disambigOne@ assumes that its arguments dictionaries constrain all
1713 the same type variable.
1715 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1716 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1717 the most common use of defaulting is code like:
1719 _ccall_ foo `seqPrimIO` bar
1721 Since we're not using the result of @foo@, the result if (presumably)
1725 disambigGroup :: GhciMode
1726 -> [Inst] -- All standard classes of form (C a)
1729 disambigGroup ghci_mode dicts
1730 | any std_default_class classes -- Guaranteed all standard classes
1731 -- See comment at the end of function for reasons as to
1732 -- why the defaulting mechanism doesn't apply to groups that
1733 -- include CCallable or CReturnable dicts.
1734 && not (any isCcallishClass classes)
1735 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1736 -- SO, TRY DEFAULT TYPES IN ORDER
1738 -- Failure here is caused by there being no type in the
1739 -- default list which can satisfy all the ambiguous classes.
1740 -- For example, if Real a is reqd, but the only type in the
1741 -- default list is Int.
1742 getDefaultTys `thenM` \ default_tys ->
1744 try_default [] -- No defaults work, so fail
1747 try_default (default_ty : default_tys)
1748 = tryTcLIE_ (try_default default_tys) $ -- If default_ty fails, we try
1749 -- default_tys instead
1750 tcSimplifyDefault theta `thenM` \ _ ->
1753 theta = [mkClassPred clas [default_ty] | clas <- classes]
1755 -- See if any default works
1756 tryM (try_default default_tys) `thenM` \ mb_ty ->
1759 Right chosen_default_ty -> choose_default chosen_default_ty
1761 | all isCreturnableClass classes -- Default CCall stuff to ()
1762 = choose_default unitTy
1764 | otherwise -- No defaults
1768 tyvar = get_tv (head dicts) -- Should be non-empty
1769 classes = map get_clas dicts
1771 std_default_class cls
1772 = isNumericClass cls
1773 || (ghci_mode == Interactive && cls `hasKey` showClassKey)
1774 -- In interactive mode, we default Show a to Show ()
1775 -- to avoid graututious errors on "show []"
1777 choose_default default_ty -- Commit to tyvar = default_ty
1778 = -- Bind the type variable
1779 unifyTauTy default_ty (mkTyVarTy tyvar) `thenM_`
1780 -- and reduce the context, for real this time
1781 simpleReduceLoop (text "disambig" <+> ppr dicts)
1782 reduceMe dicts `thenM` \ (frees, binds, ambigs) ->
1783 WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
1784 warnDefault dicts default_ty `thenM_`
1787 bomb_out = addTopAmbigErrs (tidyInsts dicts) `thenM_`
1788 returnM EmptyMonoBinds
1791 [Aside - why the defaulting mechanism is turned off when
1792 dealing with arguments and results to ccalls.
1794 When typechecking _ccall_s, TcExpr ensures that the external
1795 function is only passed arguments (and in the other direction,
1796 results) of a restricted set of 'native' types. This is
1797 implemented via the help of the pseudo-type classes,
1798 @CReturnable@ (CR) and @CCallable@ (CC.)
1800 The interaction between the defaulting mechanism for numeric
1801 values and CC & CR can be a bit puzzling to the user at times.
1810 What type has 'x' got here? That depends on the default list
1811 in operation, if it is equal to Haskell 98's default-default
1812 of (Integer, Double), 'x' has type Double, since Integer
1813 is not an instance of CR. If the default list is equal to
1814 Haskell 1.4's default-default of (Int, Double), 'x' has type
1817 To try to minimise the potential for surprises here, the
1818 defaulting mechanism is turned off in the presence of
1819 CCallable and CReturnable.
1824 %************************************************************************
1826 \subsection[simple]{@Simple@ versions}
1828 %************************************************************************
1830 Much simpler versions when there are no bindings to make!
1832 @tcSimplifyThetas@ simplifies class-type constraints formed by
1833 @deriving@ declarations and when specialising instances. We are
1834 only interested in the simplified bunch of class/type constraints.
1836 It simplifies to constraints of the form (C a b c) where
1837 a,b,c are type variables. This is required for the context of
1838 instance declarations.
1841 tcSimplifyDeriv :: [TyVar]
1842 -> ThetaType -- Wanted
1843 -> TcM ThetaType -- Needed
1845 tcSimplifyDeriv tyvars theta
1846 = tcInstTyVars VanillaTv tyvars `thenM` \ (tvs, _, tenv) ->
1847 -- The main loop may do unification, and that may crash if
1848 -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
1849 -- ToDo: what if two of them do get unified?
1850 newDicts DataDeclOrigin (substTheta tenv theta) `thenM` \ wanteds ->
1851 simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
1852 ASSERT( null frees ) -- reduceMe never returns Free
1854 doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok ->
1856 tv_set = mkVarSet tvs
1857 simpl_theta = map dictPred irreds -- reduceMe squashes all non-dicts
1860 | isEmptyVarSet pred_tyvars -- Things like (Eq T) should be rejected
1861 = addErrTc (noInstErr pred)
1863 | not undecidable_ok && not (isTyVarClassPred pred)
1864 -- Check that the returned dictionaries are all of form (C a b)
1865 -- (where a, b are type variables).
1866 -- We allow this if we had -fallow-undecidable-instances,
1867 -- but note that risks non-termination in the 'deriving' context-inference
1868 -- fixpoint loop. It is useful for situations like
1869 -- data Min h a = E | M a (h a)
1870 -- which gives the instance decl
1871 -- instance (Eq a, Eq (h a)) => Eq (Min h a)
1872 = addErrTc (noInstErr pred)
1874 | not (pred_tyvars `subVarSet` tv_set)
1875 -- Check for a bizarre corner case, when the derived instance decl should
1876 -- have form instance C a b => D (T a) where ...
1877 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
1878 -- of problems; in particular, it's hard to compare solutions for
1879 -- equality when finding the fixpoint. So I just rule it out for now.
1880 = addErrTc (badDerivedPred pred)
1885 pred_tyvars = tyVarsOfPred pred
1887 rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
1888 -- This reverse-mapping is a Royal Pain,
1889 -- but the result should mention TyVars not TcTyVars
1892 mappM check_pred simpl_theta `thenM_`
1893 checkAmbiguity tvs simpl_theta tv_set `thenM_`
1894 returnM (substTheta rev_env simpl_theta)
1896 doc = ptext SLIT("deriving classes for a data type")
1899 @tcSimplifyDefault@ just checks class-type constraints, essentially;
1900 used with \tr{default} declarations. We are only interested in
1901 whether it worked or not.
1904 tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it
1907 tcSimplifyDefault theta
1908 = newDicts DataDeclOrigin theta `thenM` \ wanteds ->
1909 simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
1910 ASSERT( null frees ) -- try_me never returns Free
1911 mappM (addErrTc . noInstErr) irreds `thenM_`
1917 doc = ptext SLIT("default declaration")
1921 %************************************************************************
1923 \section{Errors and contexts}
1925 %************************************************************************
1927 ToDo: for these error messages, should we note the location as coming
1928 from the insts, or just whatever seems to be around in the monad just
1932 groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
1933 -> [Inst] -- The offending Insts
1935 -- Group together insts with the same origin
1936 -- We want to report them together in error messages
1938 groupErrs report_err []
1940 groupErrs report_err (inst:insts)
1941 = do_one (inst:friends) `thenM_`
1942 groupErrs report_err others
1945 -- (It may seem a bit crude to compare the error messages,
1946 -- but it makes sure that we combine just what the user sees,
1947 -- and it avoids need equality on InstLocs.)
1948 (friends, others) = partition is_friend insts
1949 loc_msg = showSDoc (pprInstLoc (instLoc inst))
1950 is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
1951 do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
1952 -- Add location and context information derived from the Insts
1954 -- Add the "arising from..." part to a message about bunch of dicts
1955 addInstLoc :: [Inst] -> Message -> Message
1956 addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts)))
1959 plural xs = char 's'
1962 addTopIPErrs tidy_env tidy_dicts
1963 = groupErrs report tidy_dicts
1965 report dicts = addErrTcM (tidy_env, mk_msg dicts)
1966 mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <>
1967 plural tidy_dicts <+> pprInsts tidy_dicts)
1969 -- Used for top-level irreducibles
1970 addTopInstanceErrs tidy_env tidy_dicts
1971 = groupErrs report tidy_dicts
1973 report dicts = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
1974 addErrTcM (tidy_env, mk_msg dicts $$ mono_msg)
1975 mk_msg dicts = addInstLoc dicts (ptext SLIT("No instance") <> plural tidy_dicts <+>
1976 ptext SLIT("for") <+> pprInsts tidy_dicts)
1979 addTopAmbigErrs (tidy_env, tidy_dicts)
1980 -- Divide into groups that share a common set of ambiguous tyvars
1981 = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts])
1983 tvs_of :: Inst -> [TcTyVar]
1984 tvs_of d = varSetElems (tyVarsOfInst d)
1985 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
1987 report :: [(Inst,[TcTyVar])] -> TcM ()
1988 report pairs@((_,tvs) : _) -- The pairs share a common set of ambiguous tyvars
1989 = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
1990 addErrTcM (tidy_env, msg $$ mono_msg)
1992 dicts = map fst pairs
1993 msg = sep [text "Ambiguous type variable" <> plural tvs <+>
1994 pprQuotedList tvs <+> in_msg,
1995 nest 2 (pprInstsInFull dicts)]
1996 in_msg | isSingleton dicts = text "in the top-level constraint:"
1997 | otherwise = text "in these top-level constraints:"
2000 mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message)
2001 -- There's an error with these Insts; if they have free type variables
2002 -- it's probably caused by the monomorphism restriction.
2003 -- Try to identify the offending variable
2004 -- ASSUMPTION: the Insts are fully zonked
2005 mkMonomorphismMsg tidy_env insts
2006 | isEmptyVarSet inst_tvs
2007 = returnM (tidy_env, empty)
2009 = findGlobals inst_tvs tidy_env `thenM` \ (tidy_env, docs) ->
2010 returnM (tidy_env, mk_msg docs)
2013 inst_tvs = tyVarsOfInsts insts
2015 mk_msg [] = empty -- This happens in things like
2016 -- f x = show (read "foo")
2017 -- whre monomorphism doesn't play any role
2018 mk_msg docs = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"),
2020 ptext SLIT("Probable fix: give these definition(s) an explicit type signature")]
2022 warnDefault dicts default_ty
2023 = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
2024 addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg)
2027 (_, tidy_dicts) = tidyInsts dicts
2028 warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
2029 quotes (ppr default_ty),
2030 pprInstsInFull tidy_dicts]
2032 complainCheck doc givens irreds
2033 = mappM zonkInst given_dicts_and_ips `thenM` \ givens' ->
2034 groupErrs (addNoInstanceErrs doc givens') irreds `thenM_`
2037 given_dicts_and_ips = filter (not . isMethod) givens
2038 -- Filter out methods, which are only added to
2039 -- the given set as an optimisation
2041 addNoInstanceErrs what_doc givens dicts
2042 = getDOpts `thenM` \ dflags ->
2043 tcGetInstEnv `thenM` \ inst_env ->
2045 (tidy_env1, tidy_givens) = tidyInsts givens
2046 (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts
2048 doc = vcat [addInstLoc dicts $
2049 sep [herald <+> pprInsts tidy_dicts,
2050 nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens],
2052 ptext SLIT("Probable fix:"),
2056 herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
2057 unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
2060 -- The error message when we don't find a suitable instance
2061 -- is complicated by the fact that sometimes this is because
2062 -- there is no instance, and sometimes it's because there are
2063 -- too many instances (overlap). See the comments in TcEnv.lhs
2064 -- with the InstEnv stuff.
2067 | not ambig_overlap = empty
2069 = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
2070 nest 4 (ptext SLIT("depends on the instantiation of") <+>
2071 quotes (pprWithCommas ppr (varSetElems (tyVarsOfInsts tidy_dicts))))]
2073 fix1 = sep [ptext SLIT("Add") <+> pprInsts tidy_dicts,
2074 ptext SLIT("to the") <+> what_doc]
2076 fix2 | null instance_dicts
2079 = ptext SLIT("Or add an instance declaration for") <+> pprInsts instance_dicts
2081 instance_dicts = [d | d <- tidy_dicts, isClassDict d, not (isTyVarDict d)]
2082 -- Insts for which it is worth suggesting an adding an instance declaration
2083 -- Exclude implicit parameters, and tyvar dicts
2085 -- Checks for the ambiguous case when we have overlapping instances
2086 ambig_overlap = any ambig_overlap1 dicts
2089 = case lookupInstEnv dflags inst_env clas tys of
2090 NoMatch ambig -> ambig
2094 (clas,tys) = getDictClassTys dict
2096 addErrTcM (tidy_env2, doc)
2098 -- Used for the ...Thetas variants; all top level
2099 noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred)
2102 = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
2103 ptext SLIT("type variables that are not data type parameters"),
2104 nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
2106 reduceDepthErr n stack
2107 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
2108 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
2109 nest 4 (pprInstsInFull stack)]
2111 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
2113 -----------------------------------------------
2115 = addErrTc (sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
2116 nest 4 (ppr inst <+> pprInstLoc (instLoc inst))])