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 ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
25 import TcHsSyn ( TcExpr, TcId,
26 TcMonoBinds, TcDictBinds
30 import Inst ( lookupInst, LookupInstResult(..),
31 tyVarsOfInst, fdPredsOfInsts, fdPredsOfInst, newDicts,
32 isDict, isClassDict, isLinearInst, linearInstType,
33 isStdClassTyVarDict, isMethodFor, isMethod,
34 instToId, tyVarsOfInsts, cloneDict,
35 ipNamesOfInsts, ipNamesOfInst, dictPred,
36 instBindingRequired, instCanBeGeneralised,
37 newDictsFromOld, tcInstClassOp,
38 getDictClassTys, isTyVarDict,
39 instLoc, zonkInst, tidyInsts, tidyMoreInsts,
40 Inst, pprInsts, pprInstsInFull,
41 isIPDict, isInheritableInst
43 import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupId, findGlobals )
44 import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
45 import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity )
46 import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv),
47 mkClassPred, isOverloadedTy, mkTyConApp,
48 mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
50 import Id ( idType, mkUserLocal )
52 import Name ( getOccName, getSrcLoc )
53 import NameSet ( NameSet, mkNameSet, elemNameSet )
54 import Class ( classBigSig, classKey )
55 import FunDeps ( oclose, grow, improve, pprEquationDoc )
56 import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
57 import PrelNames ( splitName, fstName, sndName, showClassKey, eqClassKey, ordClassKey)
58 import HscTypes ( GhciMode(Interactive) )
60 import Subst ( mkTopTyVarSubst, substTheta, substTy )
61 import TysWiredIn ( unitTy, pairTyCon )
62 import ErrUtils ( Message )
64 import VarEnv ( TidyEnv )
67 import ListSetOps ( equivClasses )
68 import Unique ( hasKey )
69 import Util ( zipEqual, isSingleton )
70 import List ( partition )
75 %************************************************************************
79 %************************************************************************
81 --------------------------------------
82 Notes on quantification
83 --------------------------------------
85 Suppose we are about to do a generalisation step.
90 C the constraints from that RHS
92 The game is to figure out
94 Q the set of type variables over which to quantify
95 Ct the constraints we will *not* quantify over
96 Cq the constraints we will quantify over
98 So we're going to infer the type
102 and float the constraints Ct further outwards.
104 Here are the things that *must* be true:
106 (A) Q intersect fv(G) = EMPTY limits how big Q can be
107 (B) Q superset fv(Cq union T) \ oclose(fv(G),C) limits how small Q can be
109 (A) says we can't quantify over a variable that's free in the
110 environment. (B) says we must quantify over all the truly free
111 variables in T, else we won't get a sufficiently general type. We do
112 not *need* to quantify over any variable that is fixed by the free
113 vars of the environment G.
115 BETWEEN THESE TWO BOUNDS, ANY Q WILL DO!
117 Example: class H x y | x->y where ...
119 fv(G) = {a} C = {H a b, H c d}
122 (A) Q intersect {a} is empty
123 (B) Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d}
125 So Q can be {c,d}, {b,c,d}
127 Other things being equal, however, we'd like to quantify over as few
128 variables as possible: smaller types, fewer type applications, more
129 constraints can get into Ct instead of Cq.
132 -----------------------------------------
135 fv(T) the free type vars of T
137 oclose(vs,C) The result of extending the set of tyvars vs
138 using the functional dependencies from C
140 grow(vs,C) The result of extend the set of tyvars vs
141 using all conceivable links from C.
143 E.g. vs = {a}, C = {H [a] b, K (b,Int) c, Eq e}
144 Then grow(vs,C) = {a,b,c}
146 Note that grow(vs,C) `superset` grow(vs,simplify(C))
147 That is, simplfication can only shrink the result of grow.
150 oclose is conservative one way: v `elem` oclose(vs,C) => v is definitely fixed by vs
151 grow is conservative the other way: if v might be fixed by vs => v `elem` grow(vs,C)
154 -----------------------------------------
158 Here's a good way to choose Q:
160 Q = grow( fv(T), C ) \ oclose( fv(G), C )
162 That is, quantify over all variable that that MIGHT be fixed by the
163 call site (which influences T), but which aren't DEFINITELY fixed by
164 G. This choice definitely quantifies over enough type variables,
165 albeit perhaps too many.
167 Why grow( fv(T), C ) rather than fv(T)? Consider
169 class H x y | x->y where ...
174 If we used fv(T) = {c} we'd get the type
176 forall c. H c d => c -> b
178 And then if the fn was called at several different c's, each of
179 which fixed d differently, we'd get a unification error, because
180 d isn't quantified. Solution: quantify d. So we must quantify
181 everything that might be influenced by c.
183 Why not oclose( fv(T), C )? Because we might not be able to see
184 all the functional dependencies yet:
186 class H x y | x->y where ...
187 instance H x y => Eq (T x y) where ...
192 Now oclose(fv(T),C) = {c}, because the functional dependency isn't
193 apparent yet, and that's wrong. We must really quantify over d too.
196 There really isn't any point in quantifying over any more than
197 grow( fv(T), C ), because the call sites can't possibly influence
198 any other type variables.
202 --------------------------------------
204 --------------------------------------
206 It's very hard to be certain when a type is ambiguous. Consider
210 instance H x y => K (x,y)
212 Is this type ambiguous?
213 forall a b. (K (a,b), Eq b) => a -> a
215 Looks like it! But if we simplify (K (a,b)) we get (H a b) and
216 now we see that a fixes b. So we can't tell about ambiguity for sure
217 without doing a full simplification. And even that isn't possible if
218 the context has some free vars that may get unified. Urgle!
220 Here's another example: is this ambiguous?
221 forall a b. Eq (T b) => a -> a
222 Not if there's an insance decl (with no context)
223 instance Eq (T b) where ...
225 You may say of this example that we should use the instance decl right
226 away, but you can't always do that:
228 class J a b where ...
229 instance J Int b where ...
231 f :: forall a b. J a b => a -> a
233 (Notice: no functional dependency in J's class decl.)
234 Here f's type is perfectly fine, provided f is only called at Int.
235 It's premature to complain when meeting f's signature, or even
236 when inferring a type for f.
240 However, we don't *need* to report ambiguity right away. It'll always
241 show up at the call site.... and eventually at main, which needs special
242 treatment. Nevertheless, reporting ambiguity promptly is an excellent thing.
244 So here's the plan. We WARN about probable ambiguity if
246 fv(Cq) is not a subset of oclose(fv(T) union fv(G), C)
248 (all tested before quantification).
249 That is, all the type variables in Cq must be fixed by the the variables
250 in the environment, or by the variables in the type.
252 Notice that we union before calling oclose. Here's an example:
254 class J a b c | a b -> c
258 forall b c. (J a b c) => b -> b
260 Only if we union {a} from G with {b} from T before using oclose,
261 do we see that c is fixed.
263 It's a bit vague exactly which C we should use for this oclose call. If we
264 don't fix enough variables we might complain when we shouldn't (see
265 the above nasty example). Nothing will be perfect. That's why we can
266 only issue a warning.
269 Can we ever be *certain* about ambiguity? Yes: if there's a constraint
271 c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY
273 then c is a "bubble"; there's no way it can ever improve, and it's
274 certainly ambiguous. UNLESS it is a constant (sigh). And what about
279 instance H x y => K (x,y)
281 Is this type ambiguous?
282 forall a b. (K (a,b), Eq b) => a -> a
284 Urk. The (Eq b) looks "definitely ambiguous" but it isn't. What we are after
285 is a "bubble" that's a set of constraints
287 Cq = Ca union Cq' st fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY
289 Hence another idea. To decide Q start with fv(T) and grow it
290 by transitive closure in Cq (no functional dependencies involved).
291 Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
292 The definitely-ambiguous can then float out, and get smashed at top level
293 (which squashes out the constants, like Eq (T a) above)
296 --------------------------------------
297 Notes on principal types
298 --------------------------------------
303 f x = let g y = op (y::Int) in True
305 Here the principal type of f is (forall a. a->a)
306 but we'll produce the non-principal type
307 f :: forall a. C Int => a -> a
310 --------------------------------------
311 Notes on implicit parameters
312 --------------------------------------
314 Question 1: can we "inherit" implicit parameters
315 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
320 where f is *not* a top-level binding.
321 From the RHS of f we'll get the constraint (?y::Int).
322 There are two types we might infer for f:
326 (so we get ?y from the context of f's definition), or
328 f :: (?y::Int) => Int -> Int
330 At first you might think the first was better, becuase then
331 ?y behaves like a free variable of the definition, rather than
332 having to be passed at each call site. But of course, the WHOLE
333 IDEA is that ?y should be passed at each call site (that's what
334 dynamic binding means) so we'd better infer the second.
336 BOTTOM LINE: when *inferring types* you *must* quantify
337 over implicit parameters. See the predicate isFreeWhenInferring.
340 Question 2: type signatures
341 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
342 BUT WATCH OUT: When you supply a type signature, we can't force you
343 to quantify over implicit parameters. For example:
347 This is perfectly reasonable. We do not want to insist on
349 (?x + 1) :: (?x::Int => Int)
351 That would be silly. Here, the definition site *is* the occurrence site,
352 so the above strictures don't apply. Hence the difference between
353 tcSimplifyCheck (which *does* allow implicit paramters to be inherited)
354 and tcSimplifyCheckBind (which does not).
356 What about when you supply a type signature for a binding?
357 Is it legal to give the following explicit, user type
358 signature to f, thus:
363 At first sight this seems reasonable, but it has the nasty property
364 that adding a type signature changes the dynamic semantics.
367 (let f x = (x::Int) + ?y
368 in (f 3, f 3 with ?y=5)) with ?y = 6
374 in (f 3, f 3 with ?y=5)) with ?y = 6
378 Indeed, simply inlining f (at the Haskell source level) would change the
381 Nevertheless, as Launchbury says (email Oct 01) we can't really give the
382 semantics for a Haskell program without knowing its typing, so if you
383 change the typing you may change the semantics.
385 To make things consistent in all cases where we are *checking* against
386 a supplied signature (as opposed to inferring a type), we adopt the
389 a signature does not need to quantify over implicit params.
391 [This represents a (rather marginal) change of policy since GHC 5.02,
392 which *required* an explicit signature to quantify over all implicit
393 params for the reasons mentioned above.]
395 But that raises a new question. Consider
397 Given (signature) ?x::Int
398 Wanted (inferred) ?x::Int, ?y::Bool
400 Clearly we want to discharge the ?x and float the ?y out. But
401 what is the criterion that distinguishes them? Clearly it isn't
402 what free type variables they have. The Right Thing seems to be
403 to float a constraint that
404 neither mentions any of the quantified type variables
405 nor any of the quantified implicit parameters
407 See the predicate isFreeWhenChecking.
410 Question 3: monomorphism
411 ~~~~~~~~~~~~~~~~~~~~~~~~
412 There's a nasty corner case when the monomorphism restriction bites:
416 The argument above suggests that we *must* generalise
417 over the ?y parameter, to get
418 z :: (?y::Int) => Int,
419 but the monomorphism restriction says that we *must not*, giving
421 Why does the momomorphism restriction say this? Because if you have
423 let z = x + ?y in z+z
425 you might not expect the addition to be done twice --- but it will if
426 we follow the argument of Question 2 and generalise over ?y.
432 (A) Always generalise over implicit parameters
433 Bindings that fall under the monomorphism restriction can't
437 * Inlining remains valid
438 * No unexpected loss of sharing
439 * But simple bindings like
441 will be rejected, unless you add an explicit type signature
442 (to avoid the monomorphism restriction)
443 z :: (?y::Int) => Int
445 This seems unacceptable
447 (B) Monomorphism restriction "wins"
448 Bindings that fall under the monomorphism restriction can't
450 Always generalise over implicit parameters *except* for bindings
451 that fall under the monomorphism restriction
454 * Inlining isn't valid in general
455 * No unexpected loss of sharing
456 * Simple bindings like
458 accepted (get value of ?y from binding site)
460 (C) Always generalise over implicit parameters
461 Bindings that fall under the monomorphism restriction can't
462 be generalised, EXCEPT for implicit parameters
464 * Inlining remains valid
465 * Unexpected loss of sharing (from the extra generalisation)
466 * Simple bindings like
468 accepted (get value of ?y from occurrence sites)
473 None of these choices seems very satisfactory. But at least we should
474 decide which we want to do.
476 It's really not clear what is the Right Thing To Do. If you see
480 would you expect the value of ?y to be got from the *occurrence sites*
481 of 'z', or from the valuue of ?y at the *definition* of 'z'? In the
482 case of function definitions, the answer is clearly the former, but
483 less so in the case of non-fucntion definitions. On the other hand,
484 if we say that we get the value of ?y from the definition site of 'z',
485 then inlining 'z' might change the semantics of the program.
487 Choice (C) really says "the monomorphism restriction doesn't apply
488 to implicit parameters". Which is fine, but remember that every
489 innocent binding 'x = ...' that mentions an implicit parameter in
490 the RHS becomes a *function* of that parameter, called at each
491 use of 'x'. Now, the chances are that there are no intervening 'with'
492 clauses that bind ?y, so a decent compiler should common up all
493 those function calls. So I think I strongly favour (C). Indeed,
494 one could make a similar argument for abolishing the monomorphism
495 restriction altogether.
497 BOTTOM LINE: we choose (B) at present. See tcSimplifyRestricted
501 %************************************************************************
503 \subsection{tcSimplifyInfer}
505 %************************************************************************
507 tcSimplify is called when we *inferring* a type. Here's the overall game plan:
509 1. Compute Q = grow( fvs(T), C )
511 2. Partition C based on Q into Ct and Cq. Notice that ambiguous
512 predicates will end up in Ct; we deal with them at the top level
514 3. Try improvement, using functional dependencies
516 4. If Step 3 did any unification, repeat from step 1
517 (Unification can change the result of 'grow'.)
519 Note: we don't reduce dictionaries in step 2. For example, if we have
520 Eq (a,b), we don't simplify to (Eq a, Eq b). So Q won't be different
521 after step 2. However note that we may therefore quantify over more
522 type variables than we absolutely have to.
524 For the guts, we need a loop, that alternates context reduction and
525 improvement with unification. E.g. Suppose we have
527 class C x y | x->y where ...
529 and tcSimplify is called with:
531 Then improvement unifies a with b, giving
534 If we need to unify anything, we rattle round the whole thing all over
541 -> TcTyVarSet -- fv(T); type vars
543 -> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
544 TcDictBinds, -- Bindings
545 [TcId]) -- Dict Ids that must be bound here (zonked)
546 -- Any free (escaping) Insts are tossed into the environment
551 tcSimplifyInfer doc tau_tvs wanted_lie
552 = inferLoop doc (varSetElems tau_tvs)
553 wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
555 -- Check for non-generalisable insts
556 mappM_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenM_`
558 extendLIEs frees `thenM_`
559 returnM (qtvs, binds, map instToId irreds)
561 inferLoop doc tau_tvs wanteds
563 zonkTcTyVarsAndFV tau_tvs `thenM` \ tau_tvs' ->
564 mappM zonkInst wanteds `thenM` \ wanteds' ->
565 tcGetGlobalTyVars `thenM` \ gbl_tvs ->
567 preds = fdPredsOfInsts wanteds'
568 qtvs = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
571 | isFreeWhenInferring qtvs inst = Free
572 | isClassDict inst = DontReduceUnlessConstant -- Dicts
573 | otherwise = ReduceMe -- Lits and Methods
575 traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_`
577 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
580 if no_improvement then
581 returnM (varSetElems qtvs, frees, binds, irreds)
583 -- If improvement did some unification, we go round again. There
584 -- are two subtleties:
585 -- a) We start again with irreds, not wanteds
586 -- Using an instance decl might have introduced a fresh type variable
587 -- which might have been unified, so we'd get an infinite loop
588 -- if we started again with wanteds! See example [LOOP]
590 -- b) It's also essential to re-process frees, because unification
591 -- might mean that a type variable that looked free isn't now.
593 -- Hence the (irreds ++ frees)
595 -- However, NOTICE that when we are done, we might have some bindings, but
596 -- the final qtvs might be empty. See [NO TYVARS] below.
598 inferLoop doc tau_tvs (irreds ++ frees) `thenM` \ (qtvs1, frees1, binds1, irreds1) ->
599 returnM (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
604 class If b t e r | b t e -> r
607 class Lte a b c | a b -> c where lte :: a -> b -> c
609 instance (Lte a b l,If l b a c) => Max a b c
611 Wanted: Max Z (S x) y
613 Then we'll reduce using the Max instance to:
614 (Lte Z (S x) l, If l (S x) Z y)
615 and improve by binding l->T, after which we can do some reduction
616 on both the Lte and If constraints. What we *can't* do is start again
617 with (Max Z (S x) y)!
621 class Y a b | a -> b where
624 instance Y [[a]] a where
627 k :: X a -> X a -> X a
629 g :: Num a => [X a] -> [X a]
632 h ys = ys ++ map (k (y [[0]])) xs
634 The excitement comes when simplifying the bindings for h. Initially
635 try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
636 From this we get t1:=:t2, but also various bindings. We can't forget
637 the bindings (because of [LOOP]), but in fact t1 is what g is
640 The net effect of [NO TYVARS]
643 isFreeWhenInferring :: TyVarSet -> Inst -> Bool
644 isFreeWhenInferring qtvs inst
645 = isFreeWrtTyVars qtvs inst -- Constrains no quantified vars
646 && isInheritableInst inst -- And no implicit parameter involved
647 -- (see "Notes on implicit parameters")
649 isFreeWhenChecking :: TyVarSet -- Quantified tyvars
650 -> NameSet -- Quantified implicit parameters
652 isFreeWhenChecking qtvs ips inst
653 = isFreeWrtTyVars qtvs inst
654 && isFreeWrtIPs ips inst
656 isFreeWrtTyVars qtvs inst = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
657 isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
661 %************************************************************************
663 \subsection{tcSimplifyCheck}
665 %************************************************************************
667 @tcSimplifyCheck@ is used when we know exactly the set of variables
668 we are going to quantify over. For example, a class or instance declaration.
673 -> [TcTyVar] -- Quantify over these
676 -> TcM TcDictBinds -- Bindings
678 -- tcSimplifyCheck is used when checking expression type signatures,
679 -- class decls, instance decls etc.
681 -- NB: tcSimplifyCheck does not consult the
682 -- global type variables in the environment; so you don't
683 -- need to worry about setting them before calling tcSimplifyCheck
684 tcSimplifyCheck doc qtvs givens wanted_lie
685 = tcSimplCheck doc get_qtvs
686 givens wanted_lie `thenM` \ (qtvs', binds) ->
689 get_qtvs = zonkTcTyVarsAndFV qtvs
692 -- tcSimplifyInferCheck is used when we know the constraints we are to simplify
693 -- against, but we don't know the type variables over which we are going to quantify.
694 -- This happens when we have a type signature for a mutually recursive group
697 -> TcTyVarSet -- fv(T)
700 -> TcM ([TcTyVar], -- Variables over which to quantify
701 TcDictBinds) -- Bindings
703 tcSimplifyInferCheck doc tau_tvs givens wanted_lie
704 = tcSimplCheck doc get_qtvs givens wanted_lie
706 -- Figure out which type variables to quantify over
707 -- You might think it should just be the signature tyvars,
708 -- but in bizarre cases you can get extra ones
709 -- f :: forall a. Num a => a -> a
710 -- f x = fst (g (x, head [])) + 1
712 -- Here we infer g :: forall a b. a -> b -> (b,a)
713 -- We don't want g to be monomorphic in b just because
714 -- f isn't quantified over b.
715 all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)
717 get_qtvs = zonkTcTyVarsAndFV all_tvs `thenM` \ all_tvs' ->
718 tcGetGlobalTyVars `thenM` \ gbl_tvs ->
720 qtvs = all_tvs' `minusVarSet` gbl_tvs
721 -- We could close gbl_tvs, but its not necessary for
722 -- soundness, and it'll only affect which tyvars, not which
723 -- dictionaries, we quantify over
728 Here is the workhorse function for all three wrappers.
731 tcSimplCheck doc get_qtvs givens wanted_lie
732 = check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) ->
734 -- Complain about any irreducible ones
735 complainCheck doc givens irreds `thenM_`
738 extendLIEs frees `thenM_`
739 returnM (qtvs, binds)
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 `AndMonoBinds` 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 `AndMonoBinds` 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
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 `AndMonoBinds` 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 TcMonoBinds
1012 bindInstsOfLocalFuns wanteds local_ids
1013 | null overloaded_ids
1015 = extendLIEs wanteds `thenM_`
1016 returnM EmptyMonoBinds
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.
1085 | Rhs -- Used when there is a RHS
1087 [Inst] -- Insts free in the RHS; we need these too
1089 | Linear -- Splittable Insts only.
1090 Int -- The Int is always 2 or more; indicates how
1091 -- many copies are required
1092 Inst -- The splitter
1093 Avail -- Where the "master copy" is
1095 | LinRhss -- Splittable Insts only; this is used only internally
1096 -- by extractResults, where a Linear
1097 -- is turned into an LinRhss
1098 [TcExpr] -- A supply of suitable RHSs
1100 pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
1101 | (inst,avail) <- fmToList avails ]
1103 instance Outputable Avail where
1106 pprAvail NoRhs = text "<no rhs>"
1107 pprAvail IsFree = text "Free"
1108 pprAvail Irred = text "Irred"
1109 pprAvail (Given x b) = text "Given" <+> ppr x <+>
1110 if b then text "(used)" else empty
1111 pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs)
1112 pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a
1113 pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss
1116 Extracting the bindings from a bunch of Avails.
1117 The bindings do *not* come back sorted in dependency order.
1118 We assume that they'll be wrapped in a big Rec, so that the
1119 dependency analyser can sort them out later
1123 extractResults :: Avails
1125 -> TcM (TcDictBinds, -- Bindings
1126 [Inst], -- Irreducible ones
1127 [Inst]) -- Free ones
1129 extractResults avails wanteds
1130 = go avails EmptyMonoBinds [] [] wanteds
1132 go avails binds irreds frees []
1133 = returnM (binds, irreds, frees)
1135 go avails binds irreds frees (w:ws)
1136 = case lookupFM avails w of
1137 Nothing -> pprTrace "Urk: extractResults" (ppr w) $
1138 go avails binds irreds frees ws
1140 Just NoRhs -> go avails binds irreds frees ws
1141 Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws
1142 Just Irred -> go (add_given avails w) binds (w:irreds) frees ws
1144 Just (Given id _) -> go avails new_binds irreds frees ws
1146 new_binds | id == instToId w = binds
1147 | otherwise = addBind binds w (HsVar id)
1148 -- The sought Id can be one of the givens, via a superclass chain
1149 -- and then we definitely don't want to generate an x=x binding!
1151 Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws)
1153 new_binds = addBind binds w rhs
1155 Just (Linear n split_inst avail) -- Transform Linear --> LinRhss
1156 -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) ->
1157 split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) ->
1158 go (addToFM avails w (LinRhss rhss))
1159 (binds `AndMonoBinds` binds')
1160 irreds' frees' (split_inst : w : ws)
1162 Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss
1163 -> go new_avails new_binds irreds frees ws
1165 new_binds = addBind binds w rhs
1166 new_avails = addToFM avails w (LinRhss rhss)
1168 get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
1169 get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
1170 returnM (w':irreds, frees, instToId w')
1171 get_root irreds frees IsFree w = cloneDict w `thenM` \ w' ->
1172 returnM (irreds, w':frees, instToId w')
1175 | instBindingRequired w = addToFM avails w (Given (instToId w) True)
1176 | otherwise = addToFM avails w NoRhs
1177 -- NB: make sure that CCallable/CReturnable use NoRhs rather
1178 -- than Given, else we end up with bogus bindings.
1180 add_free avails w | isMethod w = avails
1181 | otherwise = add_given avails w
1183 -- Do *not* replace Free by Given if it's a method.
1184 -- The following situation shows why this is bad:
1185 -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
1186 -- From an application (truncate f i) we get
1187 -- t1 = truncate at f
1189 -- If we have also have a second occurrence of truncate, we get
1190 -- t3 = truncate at f
1192 -- When simplifying with i,f free, we might still notice that
1193 -- t1=t3; but alas, the binding for t2 (which mentions t1)
1194 -- will continue to float out!
1195 -- (split n i a) returns: n rhss
1196 -- auxiliary bindings
1197 -- 1 or 0 insts to add to irreds
1200 split :: Int -> TcId -> TcId -> Inst
1201 -> TcM (TcDictBinds, [TcExpr])
1202 -- (split n split_id root_id wanted) returns
1203 -- * a list of 'n' expressions, all of which witness 'avail'
1204 -- * a bunch of auxiliary bindings to support these expressions
1205 -- * one or zero insts needed to witness the whole lot
1206 -- (maybe be zero if the initial Inst is a Given)
1208 -- NB: 'wanted' is just a template
1210 split n split_id root_id wanted
1213 ty = linearInstType wanted
1214 pair_ty = mkTyConApp pairTyCon [ty,ty]
1215 id = instToId wanted
1219 go 1 = returnM (EmptyMonoBinds, [HsVar root_id])
1221 go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) ->
1222 expand n rhss `thenM` \ (binds2, rhss') ->
1223 returnM (binds1 `AndMonoBinds` binds2, rhss')
1226 -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
1227 -- e.g. expand 3 [rhs1, rhs2]
1228 -- = ( { x = split rhs1 },
1229 -- [fst x, snd x, rhs2] )
1231 | n `rem` 2 == 0 = go rhss -- n is even
1232 | otherwise = go (tail rhss) `thenM` \ (binds', rhss') ->
1233 returnM (binds', head rhss : rhss')
1235 go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') ->
1236 returnM (andMonoBindList binds', concat rhss')
1238 do_one rhs = newUnique `thenM` \ uniq ->
1239 tcLookupId fstName `thenM` \ fst_id ->
1240 tcLookupId sndName `thenM` \ snd_id ->
1242 x = mkUserLocal occ uniq pair_ty loc
1244 returnM (VarMonoBind x (mk_app split_id rhs),
1245 [mk_fs_app fst_id ty x, mk_fs_app snd_id ty x])
1247 mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var
1249 mk_app id rhs = HsApp (HsVar id) rhs
1251 addBind binds inst rhs = binds `AndMonoBinds` VarMonoBind (instToId inst) rhs
1255 %************************************************************************
1257 \subsection[reduce]{@reduce@}
1259 %************************************************************************
1261 When the "what to do" predicate doesn't depend on the quantified type variables,
1262 matters are easier. We don't need to do any zonking, unless the improvement step
1263 does something, in which case we zonk before iterating.
1265 The "given" set is always empty.
1268 simpleReduceLoop :: SDoc
1269 -> (Inst -> WhatToDo) -- What to do, *not* based on the quantified type variables
1271 -> TcM ([Inst], -- Free
1273 [Inst]) -- Irreducible
1275 simpleReduceLoop doc try_me wanteds
1276 = mappM zonkInst wanteds `thenM` \ wanteds' ->
1277 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
1278 if no_improvement then
1279 returnM (frees, binds, irreds)
1281 simpleReduceLoop doc try_me (irreds ++ frees) `thenM` \ (frees1, binds1, irreds1) ->
1282 returnM (frees1, binds `AndMonoBinds` binds1, irreds1)
1288 reduceContext :: SDoc
1289 -> (Inst -> WhatToDo)
1292 -> TcM (Bool, -- True <=> improve step did no unification
1294 TcDictBinds, -- Dictionary bindings
1295 [Inst]) -- Irreducible
1297 reduceContext doc try_me givens wanteds
1299 traceTc (text "reduceContext" <+> (vcat [
1300 text "----------------------",
1302 text "given" <+> ppr givens,
1303 text "wanted" <+> ppr wanteds,
1304 text "----------------------"
1307 -- Build the Avail mapping from "givens"
1308 foldlM addGiven emptyFM givens `thenM` \ init_state ->
1311 reduceList (0,[]) try_me wanteds init_state `thenM` \ avails ->
1313 -- Do improvement, using everything in avails
1314 -- In particular, avails includes all superclasses of everything
1315 tcImprove avails `thenM` \ no_improvement ->
1317 extractResults avails wanteds `thenM` \ (binds, irreds, frees) ->
1319 traceTc (text "reduceContext end" <+> (vcat [
1320 text "----------------------",
1322 text "given" <+> ppr givens,
1323 text "wanted" <+> ppr wanteds,
1325 text "avails" <+> pprAvails avails,
1326 text "frees" <+> ppr frees,
1327 text "no_improvement =" <+> ppr no_improvement,
1328 text "----------------------"
1331 returnM (no_improvement, frees, binds, irreds)
1334 = tcGetInstEnv `thenM` \ inst_env ->
1336 preds = [ (pred, pp_loc)
1337 | inst <- keysFM avails,
1338 let pp_loc = pprInstLoc (instLoc inst),
1339 pred <- fdPredsOfInst inst
1341 -- Avails has all the superclasses etc (good)
1342 -- It also has all the intermediates of the deduction (good)
1343 -- It does not have duplicates (good)
1344 -- NB that (?x::t1) and (?x::t2) will be held separately in avails
1345 -- so that improve will see them separate
1346 eqns = improve (classInstEnv inst_env) preds
1351 traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenM_`
1352 mappM_ unify eqns `thenM_`
1355 unify ((qtvs, t1, t2), doc)
1357 tcInstTyVars VanillaTv (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
1358 unifyTauTy (substTy tenv t1) (substTy tenv t2)
1361 The main context-reduction function is @reduce@. Here's its game plan.
1364 reduceList :: (Int,[Inst]) -- Stack (for err msgs)
1365 -- along with its depth
1366 -> (Inst -> WhatToDo)
1373 try_me: given an inst, this function returns
1375 DontReduce return this in "irreds"
1376 Free return this in "frees"
1378 wanteds: The list of insts to reduce
1379 state: An accumulating parameter of type Avails
1380 that contains the state of the algorithm
1382 It returns a Avails.
1384 The (n,stack) pair is just used for error reporting.
1385 n is always the depth of the stack.
1386 The stack is the stack of Insts being reduced: to produce X
1387 I had to produce Y, to produce Y I had to produce Z, and so on.
1390 reduceList (n,stack) try_me wanteds state
1391 | n > opt_MaxContextReductionDepth
1392 = failWithTc (reduceDepthErr n stack)
1398 pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
1403 go [] state = returnM state
1404 go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ state' ->
1407 -- Base case: we're done!
1408 reduce stack try_me wanted state
1409 -- It's the same as an existing inst, or a superclass thereof
1410 | Just avail <- isAvailable state wanted
1411 = if isLinearInst wanted then
1412 addLinearAvailable state avail wanted `thenM` \ (state', wanteds') ->
1413 reduceList stack try_me wanteds' state'
1415 returnM state -- No op for non-linear things
1418 = case try_me wanted of {
1420 DontReduce want_scs -> addIrred want_scs state wanted
1422 ; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
1423 -- First, see if the inst can be reduced to a constant in one step
1424 try_simple (addIrred AddSCs) -- Assume want superclasses
1426 ; Free -> -- It's free so just chuck it upstairs
1427 -- First, see if the inst can be reduced to a constant in one step
1430 ; ReduceMe -> -- It should be reduced
1431 lookupInst wanted `thenM` \ lookup_result ->
1432 case lookup_result of
1433 GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenM` \ state' ->
1434 addWanted state' wanted rhs wanteds'
1435 SimpleInst rhs -> addWanted state wanted rhs []
1437 NoInstance -> -- No such instance!
1438 -- Add it and its superclasses
1439 addIrred AddSCs state wanted
1443 try_simple do_this_otherwise
1444 = lookupInst wanted `thenM` \ lookup_result ->
1445 case lookup_result of
1446 SimpleInst rhs -> addWanted state wanted rhs []
1447 other -> do_this_otherwise state wanted
1452 -------------------------
1453 isAvailable :: Avails -> Inst -> Maybe Avail
1454 isAvailable avails wanted = lookupFM avails wanted
1455 -- NB 1: the Ord instance of Inst compares by the class/type info
1456 -- *not* by unique. So
1457 -- d1::C Int == d2::C Int
1459 addLinearAvailable :: Avails -> Avail -> Inst -> TcM (Avails, [Inst])
1460 addLinearAvailable avails avail wanted
1461 -- avails currently maps [wanted -> avail]
1462 -- Extend avails to reflect a neeed for an extra copy of avail
1464 | Just avail' <- split_avail avail
1465 = returnM (addToFM avails wanted avail', [])
1468 = tcLookupId splitName `thenM` \ split_id ->
1469 tcInstClassOp (instLoc wanted) split_id
1470 [linearInstType wanted] `thenM` \ split_inst ->
1471 returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
1474 split_avail :: Avail -> Maybe Avail
1475 -- (Just av) if there's a modified version of avail that
1476 -- we can use to replace avail in avails
1477 -- Nothing if there isn't, so we need to create a Linear
1478 split_avail (Linear n i a) = Just (Linear (n+1) i a)
1479 split_avail (Given id used) | not used = Just (Given id True)
1480 | otherwise = Nothing
1481 split_avail Irred = Nothing
1482 split_avail IsFree = Nothing
1483 split_avail other = pprPanic "addLinearAvailable" (ppr avail $$ ppr wanted $$ ppr avails)
1485 -------------------------
1486 addFree :: Avails -> Inst -> TcM Avails
1487 -- When an Inst is tossed upstairs as 'free' we nevertheless add it
1488 -- to avails, so that any other equal Insts will be commoned up right
1489 -- here rather than also being tossed upstairs. This is really just
1490 -- an optimisation, and perhaps it is more trouble that it is worth,
1491 -- as the following comments show!
1493 -- NB: do *not* add superclasses. If we have
1496 -- but a is not bound here, then we *don't* want to derive
1497 -- dn from df here lest we lose sharing.
1499 addFree avails free = returnM (addToFM avails free IsFree)
1501 addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> TcM Avails
1502 addWanted avails wanted rhs_expr wanteds
1503 = ASSERT2( not (wanted `elemFM` avails), ppr wanted $$ ppr avails )
1504 addAvailAndSCs avails wanted avail
1506 avail | instBindingRequired wanted = Rhs rhs_expr wanteds
1507 | otherwise = ASSERT( null wanteds ) NoRhs
1509 addGiven :: Avails -> Inst -> TcM Avails
1510 addGiven state given = addAvailAndSCs state given (Given (instToId given) False)
1511 -- No ASSERT( not (given `elemFM` avails) ) because in an instance
1512 -- decl for Ord t we can add both Ord t and Eq t as 'givens',
1513 -- so the assert isn't true
1515 addIrred :: WantSCs -> Avails -> Inst -> TcM Avails
1516 addIrred NoSCs avails irred = returnM (addToFM avails irred Irred)
1517 addIrred AddSCs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails )
1518 addAvailAndSCs avails irred Irred
1520 addAvailAndSCs :: Avails -> Inst -> Avail -> TcM Avails
1521 addAvailAndSCs avails inst avail
1522 | not (isClassDict inst) = returnM avails1
1523 | otherwise = addSCs is_loop avails1 inst
1525 avails1 = addToFM avails inst avail
1526 is_loop inst = inst `elem` deps -- Note: this compares by *type*, not by Unique
1527 deps = findAllDeps avails avail
1529 findAllDeps :: Avails -> Avail -> [Inst]
1530 -- Find all the Insts that this one depends on
1531 -- See Note [SUPERCLASS-LOOP]
1532 findAllDeps avails (Rhs _ kids) = kids ++ concat (map (find_all_deps_help avails) kids)
1533 findAllDeps avails other = []
1535 find_all_deps_help :: Avails -> Inst -> [Inst]
1536 find_all_deps_help avails inst
1537 = case lookupFM avails inst of
1538 Just avail -> findAllDeps avails avail
1541 addSCs :: (Inst -> Bool) -> Avails -> Inst -> TcM Avails
1542 -- Add all the superclasses of the Inst to Avails
1543 -- The first param says "dont do this because the original thing
1544 -- depends on this one, so you'd build a loop"
1545 -- Invariant: the Inst is already in Avails.
1547 addSCs is_loop avails dict
1548 = newDictsFromOld dict sc_theta' `thenM` \ sc_dicts ->
1549 foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
1551 (clas, tys) = getDictClassTys dict
1552 (tyvars, sc_theta, sc_sels, _) = classBigSig clas
1553 sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
1555 add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
1556 = case lookupFM avails sc_dict of
1557 Just (Given _ _) -> returnM avails -- Given is cheaper than
1558 -- a superclass selection
1559 Just other | is_loop sc_dict -> returnM avails -- See Note [SUPERCLASS-LOOP]
1560 | otherwise -> returnM avails' -- SCs already added
1562 Nothing -> addSCs is_loop avails' sc_dict
1564 sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
1565 avail = Rhs sc_sel_rhs [dict]
1566 avails' = addToFM avails sc_dict avail
1569 Note [SUPERCLASS-LOOP]: Checking for loops
1570 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1571 We have to be careful here. If we are *given* d1:Ord a,
1572 and want to deduce (d2:C [a]) where
1574 class Ord a => C a where
1575 instance Ord a => C [a] where ...
1577 Then we'll use the instance decl to deduce C [a] and then add the
1578 superclasses of C [a] to avails. But we must not overwrite the binding
1579 for d1:Ord a (which is given) with a superclass selection or we'll just
1582 Here's another example
1583 class Eq b => Foo a b
1584 instance Eq a => Foo [a] a
1588 we'll first deduce that it holds (via the instance decl). We must not
1589 then overwrite the Eq t constraint with a superclass selection!
1591 At first I had a gross hack, whereby I simply did not add superclass constraints
1592 in addWanted, though I did for addGiven and addIrred. This was sub-optimal,
1593 becuase it lost legitimate superclass sharing, and it still didn't do the job:
1594 I found a very obscure program (now tcrun021) in which improvement meant the
1595 simplifier got two bites a the cherry... so something seemed to be an Irred
1596 first time, but reducible next time.
1598 Now we implement the Right Solution, which is to check for loops directly
1599 when adding superclasses. It's a bit like the occurs check in unification.
1603 %************************************************************************
1605 \section{tcSimplifyTop: defaulting}
1607 %************************************************************************
1610 @tcSimplifyTop@ is called once per module to simplify all the constant
1611 and ambiguous Insts.
1613 We need to be careful of one case. Suppose we have
1615 instance Num a => Num (Foo a b) where ...
1617 and @tcSimplifyTop@ is given a constraint (Num (Foo x y)). Then it'll simplify
1618 to (Num x), and default x to Int. But what about y??
1620 It's OK: the final zonking stage should zap y to (), which is fine.
1624 tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
1625 tcSimplifyTop wanteds = tc_simplify_top False {- Not interactive loop -} wanteds
1626 tcSimplifyInteractive wanteds = tc_simplify_top True {- Interactive loop -} wanteds
1629 -- The TcLclEnv should be valid here, solely to improve
1630 -- error message generation for the monomorphism restriction
1631 tc_simplify_top is_interactive wanteds
1632 = getLclEnv `thenM` \ lcl_env ->
1633 traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) `thenM_`
1634 simpleReduceLoop (text "tcSimplTop") reduceMe wanteds `thenM` \ (frees, binds, irreds) ->
1635 ASSERT( null frees )
1638 -- All the non-std ones are definite errors
1639 (stds, non_stds) = partition isStdClassTyVarDict irreds
1641 -- Group by type variable
1642 std_groups = equivClasses cmp_by_tyvar stds
1644 -- Pick the ones which its worth trying to disambiguate
1645 -- namely, the onese whose type variable isn't bound
1646 -- up with one of the non-standard classes
1647 (std_oks, std_bads) = partition worth_a_try std_groups
1648 worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d)
1649 non_std_tyvars = unionVarSets (map tyVarsOfInst non_stds)
1651 -- Collect together all the bad guys
1652 bad_guys = non_stds ++ concat std_bads
1653 (tidy_env, tidy_dicts) = tidyInsts bad_guys
1654 (bad_ips, non_ips) = partition isIPDict tidy_dicts
1655 (no_insts, ambigs) = partition no_inst non_ips
1656 no_inst d = not (isTyVarDict d)
1657 -- Previously, there was a more elaborate no_inst definition:
1658 -- no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
1659 -- fixed_tvs = oclose (fdPredsOfInsts tidy_dicts) emptyVarSet
1660 -- But that seems over-elaborate to me; it only bites for class decls with
1661 -- fundeps like this: class C a b | -> b where ...
1664 -- Report definite errors
1665 addTopInstanceErrs tidy_env no_insts `thenM_`
1666 addTopIPErrs tidy_env bad_ips `thenM_`
1668 -- Deal with ambiguity errors, but only if
1669 -- if there has not been an error so far; errors often
1670 -- give rise to spurious ambiguous Insts
1671 ifErrsM (returnM []) (
1673 -- Complain about the ones that don't fall under
1674 -- the Haskell rules for disambiguation
1675 -- This group includes both non-existent instances
1676 -- e.g. Num (IO a) and Eq (Int -> Int)
1677 -- and ambiguous dictionaries
1679 addTopAmbigErrs (tidy_env, ambigs) `thenM_`
1681 -- Disambiguate the ones that look feasible
1682 mappM (disambigGroup is_interactive) std_oks
1683 ) `thenM` \ binds_ambig ->
1685 returnM (binds `andMonoBinds` andMonoBindList binds_ambig)
1687 ----------------------------------
1688 d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1690 get_tv d = case getDictClassTys d of
1691 (clas, [ty]) -> tcGetTyVar "tcSimplify" ty
1692 get_clas d = case getDictClassTys d of
1693 (clas, [ty]) -> clas
1696 If a dictionary constrains a type variable which is
1697 * not mentioned in the environment
1698 * and not mentioned in the type of the expression
1699 then it is ambiguous. No further information will arise to instantiate
1700 the type variable; nor will it be generalised and turned into an extra
1701 parameter to a function.
1703 It is an error for this to occur, except that Haskell provided for
1704 certain rules to be applied in the special case of numeric types.
1706 * at least one of its classes is a numeric class, and
1707 * all of its classes are numeric or standard
1708 then the type variable can be defaulted to the first type in the
1709 default-type list which is an instance of all the offending classes.
1711 So here is the function which does the work. It takes the ambiguous
1712 dictionaries and either resolves them (producing bindings) or
1713 complains. It works by splitting the dictionary list by type
1714 variable, and using @disambigOne@ to do the real business.
1716 @disambigOne@ assumes that its arguments dictionaries constrain all
1717 the same type variable.
1719 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1720 @()@ instead of @Int@. I reckon this is the Right Thing to do since
1721 the most common use of defaulting is code like:
1723 _ccall_ foo `seqPrimIO` bar
1725 Since we're not using the result of @foo@, the result if (presumably)
1729 disambigGroup :: Bool -- True <=> simplifying at top-level interactive loop
1730 -> [Inst] -- All standard classes of form (C a)
1733 disambigGroup is_interactive dicts
1734 | any std_default_class classes -- Guaranteed all standard classes
1735 -- See comment at the end of function for reasons as to
1736 -- why the defaulting mechanism doesn't apply to groups that
1737 -- include CCallable or CReturnable dicts.
1738 && not (any isCcallishClass classes)
1739 = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1740 -- SO, TRY DEFAULT TYPES IN ORDER
1742 -- Failure here is caused by there being no type in the
1743 -- default list which can satisfy all the ambiguous classes.
1744 -- For example, if Real a is reqd, but the only type in the
1745 -- default list is Int.
1746 getDefaultTys `thenM` \ default_tys ->
1748 try_default [] -- No defaults work, so fail
1751 try_default (default_ty : default_tys)
1752 = tryTcLIE_ (try_default default_tys) $ -- If default_ty fails, we try
1753 -- default_tys instead
1754 tcSimplifyDefault theta `thenM` \ _ ->
1757 theta = [mkClassPred clas [default_ty] | clas <- classes]
1759 -- See if any default works
1760 tryM (try_default default_tys) `thenM` \ mb_ty ->
1763 Right chosen_default_ty -> choose_default chosen_default_ty
1765 | all isCreturnableClass classes -- Default CCall stuff to ()
1766 = choose_default unitTy
1768 | otherwise -- No defaults
1772 tyvar = get_tv (head dicts) -- Should be non-empty
1773 classes = map get_clas dicts
1775 std_default_class cls
1776 = isNumericClass cls
1777 || (is_interactive &&
1778 classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
1779 -- In interactive mode, we default Show a to Show ()
1780 -- to avoid graututious errors on "show []"
1782 choose_default default_ty -- Commit to tyvar = default_ty
1783 = -- Bind the type variable
1784 unifyTauTy default_ty (mkTyVarTy tyvar) `thenM_`
1785 -- and reduce the context, for real this time
1786 simpleReduceLoop (text "disambig" <+> ppr dicts)
1787 reduceMe dicts `thenM` \ (frees, binds, ambigs) ->
1788 WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs )
1789 warnDefault dicts default_ty `thenM_`
1792 bomb_out = addTopAmbigErrs (tidyInsts dicts) `thenM_`
1793 returnM EmptyMonoBinds
1796 [Aside - why the defaulting mechanism is turned off when
1797 dealing with arguments and results to ccalls.
1799 When typechecking _ccall_s, TcExpr ensures that the external
1800 function is only passed arguments (and in the other direction,
1801 results) of a restricted set of 'native' types. This is
1802 implemented via the help of the pseudo-type classes,
1803 @CReturnable@ (CR) and @CCallable@ (CC.)
1805 The interaction between the defaulting mechanism for numeric
1806 values and CC & CR can be a bit puzzling to the user at times.
1815 What type has 'x' got here? That depends on the default list
1816 in operation, if it is equal to Haskell 98's default-default
1817 of (Integer, Double), 'x' has type Double, since Integer
1818 is not an instance of CR. If the default list is equal to
1819 Haskell 1.4's default-default of (Int, Double), 'x' has type
1822 To try to minimise the potential for surprises here, the
1823 defaulting mechanism is turned off in the presence of
1824 CCallable and CReturnable.
1829 %************************************************************************
1831 \subsection[simple]{@Simple@ versions}
1833 %************************************************************************
1835 Much simpler versions when there are no bindings to make!
1837 @tcSimplifyThetas@ simplifies class-type constraints formed by
1838 @deriving@ declarations and when specialising instances. We are
1839 only interested in the simplified bunch of class/type constraints.
1841 It simplifies to constraints of the form (C a b c) where
1842 a,b,c are type variables. This is required for the context of
1843 instance declarations.
1846 tcSimplifyDeriv :: [TyVar]
1847 -> ThetaType -- Wanted
1848 -> TcM ThetaType -- Needed
1850 tcSimplifyDeriv tyvars theta
1851 = tcInstTyVars VanillaTv tyvars `thenM` \ (tvs, _, tenv) ->
1852 -- The main loop may do unification, and that may crash if
1853 -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
1854 -- ToDo: what if two of them do get unified?
1855 newDicts DataDeclOrigin (substTheta tenv theta) `thenM` \ wanteds ->
1856 simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
1857 ASSERT( null frees ) -- reduceMe never returns Free
1859 doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok ->
1861 tv_set = mkVarSet tvs
1862 simpl_theta = map dictPred irreds -- reduceMe squashes all non-dicts
1865 | isEmptyVarSet pred_tyvars -- Things like (Eq T) should be rejected
1866 = addErrTc (noInstErr pred)
1868 | not undecidable_ok && not (isTyVarClassPred pred)
1869 -- Check that the returned dictionaries are all of form (C a b)
1870 -- (where a, b are type variables).
1871 -- We allow this if we had -fallow-undecidable-instances,
1872 -- but note that risks non-termination in the 'deriving' context-inference
1873 -- fixpoint loop. It is useful for situations like
1874 -- data Min h a = E | M a (h a)
1875 -- which gives the instance decl
1876 -- instance (Eq a, Eq (h a)) => Eq (Min h a)
1877 = addErrTc (noInstErr pred)
1879 | not (pred_tyvars `subVarSet` tv_set)
1880 -- Check for a bizarre corner case, when the derived instance decl should
1881 -- have form instance C a b => D (T a) where ...
1882 -- Note that 'b' isn't a parameter of T. This gives rise to all sorts
1883 -- of problems; in particular, it's hard to compare solutions for
1884 -- equality when finding the fixpoint. So I just rule it out for now.
1885 = addErrTc (badDerivedPred pred)
1890 pred_tyvars = tyVarsOfPred pred
1892 rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars)
1893 -- This reverse-mapping is a Royal Pain,
1894 -- but the result should mention TyVars not TcTyVars
1897 mappM check_pred simpl_theta `thenM_`
1898 checkAmbiguity tvs simpl_theta tv_set `thenM_`
1899 returnM (substTheta rev_env simpl_theta)
1901 doc = ptext SLIT("deriving classes for a data type")
1904 @tcSimplifyDefault@ just checks class-type constraints, essentially;
1905 used with \tr{default} declarations. We are only interested in
1906 whether it worked or not.
1909 tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it
1912 tcSimplifyDefault theta
1913 = newDicts DataDeclOrigin theta `thenM` \ wanteds ->
1914 simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) ->
1915 ASSERT( null frees ) -- try_me never returns Free
1916 mappM (addErrTc . noInstErr) irreds `thenM_`
1922 doc = ptext SLIT("default declaration")
1926 %************************************************************************
1928 \section{Errors and contexts}
1930 %************************************************************************
1932 ToDo: for these error messages, should we note the location as coming
1933 from the insts, or just whatever seems to be around in the monad just
1937 groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
1938 -> [Inst] -- The offending Insts
1940 -- Group together insts with the same origin
1941 -- We want to report them together in error messages
1943 groupErrs report_err []
1945 groupErrs report_err (inst:insts)
1946 = do_one (inst:friends) `thenM_`
1947 groupErrs report_err others
1950 -- (It may seem a bit crude to compare the error messages,
1951 -- but it makes sure that we combine just what the user sees,
1952 -- and it avoids need equality on InstLocs.)
1953 (friends, others) = partition is_friend insts
1954 loc_msg = showSDoc (pprInstLoc (instLoc inst))
1955 is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
1956 do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
1957 -- Add location and context information derived from the Insts
1959 -- Add the "arising from..." part to a message about bunch of dicts
1960 addInstLoc :: [Inst] -> Message -> Message
1961 addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts)))
1964 plural xs = char 's'
1967 addTopIPErrs tidy_env tidy_dicts
1968 = groupErrs report tidy_dicts
1970 report dicts = addErrTcM (tidy_env, mk_msg dicts)
1971 mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <>
1972 plural tidy_dicts <+> pprInsts tidy_dicts)
1974 -- Used for top-level irreducibles
1975 addTopInstanceErrs tidy_env tidy_dicts
1976 = groupErrs report tidy_dicts
1978 report dicts = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
1979 addErrTcM (tidy_env, mk_msg dicts $$ mono_msg)
1980 mk_msg dicts = addInstLoc dicts (ptext SLIT("No instance") <> plural tidy_dicts <+>
1981 ptext SLIT("for") <+> pprInsts tidy_dicts)
1984 addTopAmbigErrs (tidy_env, tidy_dicts)
1985 -- Divide into groups that share a common set of ambiguous tyvars
1986 = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts])
1988 tvs_of :: Inst -> [TcTyVar]
1989 tvs_of d = varSetElems (tyVarsOfInst d)
1990 cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
1992 report :: [(Inst,[TcTyVar])] -> TcM ()
1993 report pairs@((_,tvs) : _) -- The pairs share a common set of ambiguous tyvars
1994 = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) ->
1995 addErrTcM (tidy_env, msg $$ mono_msg)
1997 dicts = map fst pairs
1998 msg = sep [text "Ambiguous type variable" <> plural tvs <+>
1999 pprQuotedList tvs <+> in_msg,
2000 nest 2 (pprInstsInFull dicts)]
2001 in_msg | isSingleton dicts = text "in the top-level constraint:"
2002 | otherwise = text "in these top-level constraints:"
2005 mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message)
2006 -- There's an error with these Insts; if they have free type variables
2007 -- it's probably caused by the monomorphism restriction.
2008 -- Try to identify the offending variable
2009 -- ASSUMPTION: the Insts are fully zonked
2010 mkMonomorphismMsg tidy_env insts
2011 | isEmptyVarSet inst_tvs
2012 = returnM (tidy_env, empty)
2014 = findGlobals inst_tvs tidy_env `thenM` \ (tidy_env, docs) ->
2015 returnM (tidy_env, mk_msg docs)
2018 inst_tvs = tyVarsOfInsts insts
2020 mk_msg [] = empty -- This happens in things like
2021 -- f x = show (read "foo")
2022 -- whre monomorphism doesn't play any role
2023 mk_msg docs = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"),
2025 ptext SLIT("Probable fix: give these definition(s) an explicit type signature")]
2027 warnDefault dicts default_ty
2028 = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
2029 addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg)
2032 (_, tidy_dicts) = tidyInsts dicts
2033 warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
2034 quotes (ppr default_ty),
2035 pprInstsInFull tidy_dicts]
2037 complainCheck doc givens irreds
2038 = mappM zonkInst given_dicts_and_ips `thenM` \ givens' ->
2039 groupErrs (addNoInstanceErrs doc givens') irreds `thenM_`
2042 given_dicts_and_ips = filter (not . isMethod) givens
2043 -- Filter out methods, which are only added to
2044 -- the given set as an optimisation
2046 addNoInstanceErrs what_doc givens dicts
2047 = getDOpts `thenM` \ dflags ->
2048 tcGetInstEnv `thenM` \ inst_env ->
2050 (tidy_env1, tidy_givens) = tidyInsts givens
2051 (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts
2053 doc = vcat [addInstLoc dicts $
2054 sep [herald <+> pprInsts tidy_dicts,
2055 nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens],
2057 ptext SLIT("Probable fix:"),
2061 herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
2062 unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
2065 -- The error message when we don't find a suitable instance
2066 -- is complicated by the fact that sometimes this is because
2067 -- there is no instance, and sometimes it's because there are
2068 -- too many instances (overlap). See the comments in TcEnv.lhs
2069 -- with the InstEnv stuff.
2072 | not ambig_overlap = empty
2074 = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
2075 nest 4 (ptext SLIT("depends on the instantiation of") <+>
2076 quotes (pprWithCommas ppr (varSetElems (tyVarsOfInsts tidy_dicts))))]
2078 fix1 = sep [ptext SLIT("Add") <+> pprInsts tidy_dicts,
2079 ptext SLIT("to the") <+> what_doc]
2081 fix2 | null instance_dicts
2084 = ptext SLIT("Or add an instance declaration for") <+> pprInsts instance_dicts
2086 instance_dicts = [d | d <- tidy_dicts, isClassDict d, not (isTyVarDict d)]
2087 -- Insts for which it is worth suggesting an adding an instance declaration
2088 -- Exclude implicit parameters, and tyvar dicts
2090 -- Checks for the ambiguous case when we have overlapping instances
2091 ambig_overlap = any ambig_overlap1 dicts
2094 = case lookupInstEnv dflags inst_env clas tys of
2095 NoMatch ambig -> ambig
2099 (clas,tys) = getDictClassTys dict
2101 addErrTcM (tidy_env2, doc)
2103 -- Used for the ...Thetas variants; all top level
2104 noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred)
2107 = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
2108 ptext SLIT("type variables that are not data type parameters"),
2109 nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
2111 reduceDepthErr n stack
2112 = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
2113 ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
2114 nest 4 (pprInstsInFull stack)]
2116 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
2118 -----------------------------------------------
2120 = addErrTc (sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
2121 nest 4 (ppr inst <+> pprInstLoc (instLoc inst))])