\begin{code}
module TcSimplify (
- tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
- tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
+ tcSimplifyInfer, tcSimplifyInferCheck,
+ tcSimplifyCheck, tcSimplifyRestricted,
+ tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
+
tcSimplifyThetas, tcSimplifyCheckThetas,
bindInstsOfLocalFuns
) where
#include "HsVersions.h"
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
-import TcHsSyn ( TcExpr, TcId,
+import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
)
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst, predsOfInsts,
- isDict, isClassDict,
+ tyVarsOfInst, predsOfInsts, predsOfInst,
+ isDict, isClassDict, instName,
isStdClassTyVarDict, isMethodFor,
instToId, tyVarsOfInsts,
instBindingRequired, instCanBeGeneralised,
newDictsFromOld, instMentionsIPs,
- getDictClassTys, getIPs, isTyVarDict,
- instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
+ getDictClassTys, isTyVarDict,
+ instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts,
Inst, LIE, pprInsts, pprInstsInFull,
- mkLIE,
- lieToList
+ mkLIE, lieToList
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
-import TcType ( zonkTcTyVarsAndFV )
-import TcUnify ( unifyTauTy )
+import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, unifyTauTy )
+import TcType ( ThetaType, PredType, mkClassPred, isOverloadedTy,
+ mkTyVarTy, tcGetTyVar, isTyVarClassPred,
+ tyVarsOfPred, getClassPredTys_maybe, isClassPred, isIPPred,
+ inheritablePred, predHasFDs )
import Id ( idType )
-import Name ( Name )
import NameSet ( mkNameSet )
-import Class ( Class, classBigSig )
-import FunDeps ( oclose, grow, improve )
+import Class ( classBigSig )
+import FunDeps ( oclose, grow, improve, pprEquationDoc )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
-import Type ( Type, ClassContext,
- mkTyVarTy, getTyVar,
- isTyVarTy, splitSigmaTy, tyVarsOfTypes
- )
-import Subst ( mkTopTyVarSubst, substClasses )
-import PprType ( pprClassPred )
+import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy )
import VarSet
import FiniteMap
import Outputable
import ListSetOps ( equivClasses )
-import Util ( zipEqual, mapAccumL )
+import Util ( zipEqual )
import List ( partition )
import CmdLineOpts
\end{code}
%* *
%************************************************************************
- --------------------------------------
+ --------------------------------------
Notes on quantification
- --------------------------------------
+ --------------------------------------
Suppose we are about to do a generalisation step.
We have in our hand
forall Q. Cq => T
-and float the constraints Ct further outwards.
+and float the constraints Ct further outwards.
Here are the things that *must* be true:
using the functional dependencies from C
grow(vs,C) The result of extend the set of tyvars vs
- using all conceivable links from C.
+ using all conceivable links from C.
E.g. vs = {a}, C = {H [a] b, K (b,Int) c, Eq e}
Then grow(vs,C) = {a,b,c}
Note that grow(vs,C) `superset` grow(vs,simplify(C))
That is, simplfication can only shrink the result of grow.
-Notice that
+Notice that
oclose is conservative one way: v `elem` oclose(vs,C) => v is definitely fixed by vs
grow is conservative the other way: if v might be fixed by vs => v `elem` grow(vs,C)
Why grow( fv(T), C ) rather than fv(T)? Consider
class H x y | x->y where ...
-
+
T = c->c
C = (H c d)
forall c. H c d => c -> b
- And then if the fn was called at several different c's, each of
+ And then if the fn was called at several different c's, each of
which fixed d differently, we'd get a unification error, because
d isn't quantified. Solution: quantify d. So we must quantify
everything that might be influenced by c.
- --------------------------------------
- Notes on ambiguity
- --------------------------------------
+ --------------------------------------
+ Notes on ambiguity
+ --------------------------------------
It's very hard to be certain when a type is ambiguous. Consider
show up at the call site.... and eventually at main, which needs special
treatment. Nevertheless, reporting ambiguity promptly is an excellent thing.
-So heres the plan. We WARN about probable ambiguity if
+So here's the plan. We WARN about probable ambiguity if
fv(Cq) is not a subset of oclose(fv(T) union fv(G), C)
(all tested before quantification).
That is, all the type variables in Cq must be fixed by the the variables
-in the environment, or by the variables in the type.
+in the environment, or by the variables in the type.
Notice that we union before calling oclose. Here's an example:
forall b c. (J a b c) => b -> b
Only if we union {a} from G with {b} from T before using oclose,
-do we see that c is fixed.
+do we see that c is fixed.
-It's a bit vague exactly which C we should use for this oclose call. If we
+It's a bit vague exactly which C we should use for this oclose call. If we
don't fix enough variables we might complain when we shouldn't (see
the above nasty example). Nothing will be perfect. That's why we can
only issue a warning.
c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY
-then c is a "bubble"; there's no way it can ever improve, and it's
+then c is a "bubble"; there's no way it can ever improve, and it's
certainly ambiguous. UNLESS it is a constant (sigh). And what about
the nasty example?
Hence another idea. To decide Q start with fv(T) and grow it
by transitive closure in Cq (no functional dependencies involved).
Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
-The definitely-ambigous can then float out, and get smashed at top level
+The definitely-ambiguous can then float out, and get smashed at top level
(which squashes out the constants, like Eq (T a) above)
- --------------------------------------
+ --------------------------------------
+ Notes on principal types
+ --------------------------------------
+
+ class C a where
+ op :: a -> a
+
+ f x = let g y = op (y::Int) in True
+
+Here the principal type of f is (forall a. a->a)
+but we'll produce the non-principal type
+ f :: forall a. C Int => a -> a
+
+
+ --------------------------------------
Notes on implicit parameters
- --------------------------------------
+ --------------------------------------
-Consider
+Question 1: can we "inherit" implicit parameters
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
- f x = ...?y...
+ f x = (x::Int) + ?y
-Then we get an LIE like (?y::Int). Doesn't constrain a type variable,
-but we must nevertheless infer a type like
+where f is *not* a top-level binding.
+From the RHS of f we'll get the constraint (?y::Int).
+There are two types we might infer for f:
+
+ f :: Int -> Int
+
+(so we get ?y from the context of f's definition), or
f :: (?y::Int) => Int -> Int
-so that f is passed the value of y at the call site. Is this legal?
-
+At first you might think the first was better, becuase then
+?y behaves like a free variable of the definition, rather than
+having to be passed at each call site. But of course, the WHOLE
+IDEA is that ?y should be passed at each call site (that's what
+dynamic binding means) so we'd better infer the second.
+
+BOTTOM LINE: you *must* quantify over implicit parameters. See
+isFreeAndInheritable.
+
+BUT WATCH OUT: for *expressions*, this isn't right. Consider:
+
+ (?x + 1) :: Int
+
+This is perfectly reasonable. We do not want to insist on
+
+ (?x + 1) :: (?x::Int => Int)
+
+That would be silly. Here, the definition site *is* the occurrence site,
+so the above strictures don't apply. Hence the difference between
+tcSimplifyCheck (which *does* allow implicit paramters to be inherited)
+and tcSimplifyCheckBind (which does not).
+
+
+Question 2: type signatures
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+OK, so is it legal to give an explicit, user type signature to f, thus:
+
f :: Int -> Int
- f x = x + ?y
+ f x = (x::Int) + ?y
-Should f be overloaded on "?y" ? Or does the type signature say that it
-shouldn't be? Our position is that it should be illegal. Otherwise
-you can change the *dynamic* semantics by adding a type signature:
+At first sight this seems reasonable, but it has the nasty property
+that adding a type signature changes the dynamic semantics.
+Consider this:
- (let f x = x + ?y -- f :: (?y::Int) => Int -> Int
+ (let f x = (x::Int) + ?y
in (f 3, f 3 with ?y=5)) with ?y = 6
returns (3+6, 3+5)
vs
- (let f :: Int -> Int
- f x = x + ?y
+ (let f :: Int -> Int
+ f x = x + ?y
in (f 3, f 3 with ?y=5)) with ?y = 6
returns (3+6, 3+6)
-URK! Let's not do this. So this is illegal:
+Indeed, simply inlining f (at the Haskell source level) would change the
+dynamic semantics.
- f :: Int -> Int
- f x = x + ?y
+Conclusion: the above type signature is illegal. You'll get a message
+of the form "could not deduce (?y::Int) from ()".
-BOTTOM LINE: you *must* quantify over implicit parameters.
+Question 3: monomorphism
+~~~~~~~~~~~~~~~~~~~~~~~~
+There's a nasty corner case when the monomorphism restriction bites:
- --------------------------------------
- Notes on principal types
- --------------------------------------
+ z = (x::Int) + ?y
+
+The argument above suggests that we *must* generalise
+over the ?y parameter, to get
+ z :: (?y::Int) => Int,
+but the monomorphism restriction says that we *must not*, giving
+ z :: Int.
+Why does the momomorphism restriction say this? Because if you have
+
+ let z = x + ?y in z+z
+
+you might not expect the addition to be done twice --- but it will if
+we follow the argument of Question 2 and generalise over ?y.
+
+
+
+Possible choices
+~~~~~~~~~~~~~~~~
+(A) Always generalise over implicit parameters
+ Bindings that fall under the monomorphism restriction can't
+ be generalised
+
+ Consequences:
+ * Inlining remains valid
+ * No unexpected loss of sharing
+ * But simple bindings like
+ z = ?y + 1
+ will be rejected, unless you add an explicit type signature
+ (to avoid the monomorphism restriction)
+ z :: (?y::Int) => Int
+ z = ?y + 1
+ This seems unacceptable
+
+(B) Monomorphism restriction "wins"
+ Bindings that fall under the monomorphism restriction can't
+ be generalised
+ Always generalise over implicit parameters *except* for bindings
+ that fall under the monomorphism restriction
+
+ Consequences
+ * Inlining isn't valid in general
+ * No unexpected loss of sharing
+ * Simple bindings like
+ z = ?y + 1
+ accepted (get value of ?y from binding site)
+
+(C) Always generalise over implicit parameters
+ Bindings that fall under the monomorphism restriction can't
+ be generalised, EXCEPT for implicit parameters
+ Consequences
+ * Inlining remains valid
+ * Unexpected loss of sharing (from the extra generalisation)
+ * Simple bindings like
+ z = ?y + 1
+ accepted (get value of ?y from occurrence sites)
+
+
+Discussion
+~~~~~~~~~~
+None of these choices seems very satisfactory. But at least we should
+decide which we want to do.
+
+It's really not clear what is the Right Thing To Do. If you see
+
+ z = (x::Int) + ?y
+
+would you expect the value of ?y to be got from the *occurrence sites*
+of 'z', or from the valuue of ?y at the *definition* of 'z'? In the
+case of function definitions, the answer is clearly the former, but
+less so in the case of non-fucntion definitions. On the other hand,
+if we say that we get the value of ?y from the definition site of 'z',
+then inlining 'z' might change the semantics of the program.
+
+Choice (C) really says "the monomorphism restriction doesn't apply
+to implicit parameters". Which is fine, but remember that every
+innocent binding 'x = ...' that mentions an implicit parameter in
+the RHS becomes a *function* of that parameter, called at each
+use of 'x'. Now, the chances are that there are no intervening 'with'
+clauses that bind ?y, so a decent compiler should common up all
+those function calls. So I think I strongly favour (C). Indeed,
+one could make a similar argument for abolishing the monomorphism
+restriction altogether.
+
+BOTTOM LINE: we choose (B) at present. See tcSimplifyRestricted
- class C a where
- op :: a -> a
-
- f x = let g y = op (y::Int) in True
-Here the principal type of f is (forall a. a->a)
-but we'll produce the non-principal type
- f :: forall a. C Int => a -> a
-
%************************************************************************
%* *
\subsection{tcSimplifyInfer}
tcSimplify is called when we *inferring* a type. Here's the overall game plan:
1. Compute Q = grow( fvs(T), C )
-
- 2. Partition C based on Q into Ct and Cq. Notice that ambiguous
+
+ 2. Partition C based on Q into Ct and Cq. Notice that ambiguous
predicates will end up in Ct; we deal with them at the top level
-
+
3. Try improvement, using functional dependencies
-
+
4. If Step 3 did any unification, repeat from step 1
(Unification can change the result of 'grow'.)
Note: we don't reduce dictionaries in step 2. For example, if we have
-Eq (a,b), we don't simplify to (Eq a, Eq b). So Q won't be different
+Eq (a,b), we don't simplify to (Eq a, Eq b). So Q won't be different
after step 2. However note that we may therefore quantify over more
type variables than we absolutely have to.
improvement with unification. E.g. Suppose we have
class C x y | x->y where ...
-
+
and tcSimplify is called with:
(C Int a, C Int b)
Then improvement unifies a with b, giving
(C Int a, C Int a)
If we need to unify anything, we rattle round the whole thing all over
-again.
+again.
\begin{code}
tcSimplifyInfer
- :: SDoc
- -> [TcTyVar] -- fv(T); type vars
+ :: SDoc
+ -> TcTyVarSet -- fv(T); type vars
-> LIE -- Wanted
-> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
LIE, -- Free
\begin{code}
tcSimplifyInfer doc tau_tvs wanted_lie
- = inferLoop doc tau_tvs (lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
+ = inferLoop doc (varSetElems tau_tvs)
+ (lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
-- Check for non-generalisable insts
mapTc_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenTc_`
let
preds = predsOfInsts wanteds'
qtvs = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
-
- try_me inst
- | isFree qtvs inst = Free
- | isClassDict inst = DontReduceUnlessConstant -- Dicts
- | otherwise = ReduceMe AddToIrreds -- Lits and Methods
+
+ try_me inst
+ | isFreeAndInheritable qtvs inst = Free
+ | isClassDict inst = DontReduceUnlessConstant -- Dicts
+ | otherwise = ReduceMe -- Lits and Methods
in
-- Step 2
reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
-
+
-- Step 3
if no_improvement then
- returnTc (varSetElems qtvs, frees, binds, irreds)
+ returnTc (varSetElems qtvs, frees, binds, irreds)
else
- inferLoop doc tau_tvs wanteds
-\end{code}
+ -- If improvement did some unification, we go round again. There
+ -- are two subtleties:
+ -- a) We start again with irreds, not wanteds
+ -- Using an instance decl might have introduced a fresh type variable
+ -- which might have been unified, so we'd get an infinite loop
+ -- if we started again with wanteds! See example [LOOP]
+ --
+ -- b) It's also essential to re-process frees, because unification
+ -- might mean that a type variable that looked free isn't now.
+ --
+ -- Hence the (irreds ++ frees)
+
+ -- However, NOTICE that when we are done, we might have some bindings, but
+ -- the final qtvs might be empty. See [NO TYVARS] below.
+
+ inferLoop doc tau_tvs (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
+ returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
+\end{code}
+
+Example [LOOP]
+
+ class If b t e r | b t e -> r
+ instance If T t e t
+ instance If F t e e
+ class Lte a b c | a b -> c where lte :: a -> b -> c
+ instance Lte Z b T
+ instance (Lte a b l,If l b a c) => Max a b c
+
+Wanted: Max Z (S x) y
+
+Then we'll reduce using the Max instance to:
+ (Lte Z (S x) l, If l (S x) Z y)
+and improve by binding l->T, after which we can do some reduction
+on both the Lte and If constraints. What we *can't* do is start again
+with (Max Z (S x) y)!
+
+[NO TYVARS]
+
+ class Y a b | a -> b where
+ y :: a -> X b
+
+ instance Y [[a]] a where
+ y ((x:_):_) = X x
+
+ k :: X a -> X a -> X a
+
+ g :: Num a => [X a] -> [X a]
+ g xs = h xs
+ where
+ h ys = ys ++ map (k (y [[0]])) xs
+
+The excitement comes when simplifying the bindings for h. Initially
+try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
+From this we get t1:=:t2, but also various bindings. We can't forget
+the bindings (because of [LOOP]), but in fact t1 is what g is
+polymorphic in.
\begin{code}
-isFree qtvs inst
- = not (tyVarsOfInst inst `intersectsVarSet` qtvs) -- Constrains no quantified vars
- && null (getIPs inst) -- And no implicit parameter involved
+isFreeAndInheritable qtvs inst
+ = isFree qtvs inst -- Constrains no quantified vars
+ && all inheritablePred (predsOfInst inst) -- And no implicit parameter involved
-- (see "Notes on implicit parameters")
+
+isFree qtvs inst
+ = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
\end{code}
%************************************************************************
@tcSimplifyCheck@ is used when we know exactly the set of variables
-we are going to quantify over.
+we are going to quantify over. For example, a class or instance declaration.
\begin{code}
tcSimplifyCheck
- :: SDoc
+ :: SDoc
-> [TcTyVar] -- Quantify over these
-> [Inst] -- Given
-> LIE -- Wanted
-> TcM (LIE, -- Free
TcDictBinds) -- Bindings
+-- tcSimplifyCheck is used when checking exprssion type signatures,
+-- class decls, instance decls etc.
+-- Note that we psss isFree (not isFreeAndInheritable) to tcSimplCheck
+-- It's important that we can float out non-inheritable predicates
+-- Example: (?x :: Int) is ok!
tcSimplifyCheck doc qtvs givens wanted_lie
- = checkLoop doc qtvs givens (lieToList wanted_lie) `thenTc` \ (frees, binds, irreds) ->
-
- -- Complain about any irreducible ones
- complainCheck doc givens irreds `thenNF_Tc_`
-
- -- Done
- returnTc (mkLIE frees, binds)
-
-checkLoop doc qtvs givens wanteds
- = -- Step 1
- zonkTcTyVarsAndFV qtvs `thenNF_Tc` \ qtvs' ->
- mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
- mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
- let
- -- When checking against a given signature we always reduce
- -- until we find a match against something given, or can't reduce
- try_me inst | isFree qtvs' inst = Free
- | otherwise = ReduceMe AddToIrreds
- in
- -- Step 2
- reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
-
- -- Step 3
- if no_improvement then
- returnTc (frees, binds, irreds)
- else
- checkLoop doc qtvs givens wanteds
-
-complainCheck doc givens irreds
- = mapNF_Tc zonkInst given_dicts `thenNF_Tc` \ givens' ->
- mapNF_Tc (addNoInstanceErr doc given_dicts) irreds `thenNF_Tc_`
- returnTc ()
+ = tcSimplCheck doc isFree get_qtvs
+ givens wanted_lie `thenTc` \ (qtvs', frees, binds) ->
+ returnTc (frees, binds)
where
- given_dicts = filter isDict givens
- -- Filter out methods, which are only added to
- -- the given set as an optimisation
-\end{code}
-
+ get_qtvs = zonkTcTyVarsAndFV qtvs
-%************************************************************************
-%* *
-\subsection{tcSimplifyAndCheck}
-%* *
-%************************************************************************
-
-@tcSimplifyInferCheck@ is used when we know the consraints we are to simplify
-against, but we don't know the type variables over which we are going to quantify.
-
-\begin{code}
+-- tcSimplifyInferCheck is used when we know the constraints we are to simplify
+-- against, but we don't know the type variables over which we are going to quantify.
+-- This happens when we have a type signature for a mutually recursive group
tcSimplifyInferCheck
- :: SDoc
- -> [TcTyVar] -- fv(T)
+ :: SDoc
+ -> TcTyVarSet -- fv(T)
-> [Inst] -- Given
-> LIE -- Wanted
-> TcM ([TcTyVar], -- Variables over which to quantify
LIE, -- Free
TcDictBinds) -- Bindings
-tcSimplifyInferCheck doc tau_tvs givens wanted
- = inferCheckLoop doc tau_tvs givens (lieToList wanted) `thenTc` \ (qtvs, frees, binds, irreds) ->
-
- -- Complain about any irreducible ones
- complainCheck doc givens irreds `thenNF_Tc_`
-
- -- Done
- returnTc (qtvs, mkLIE frees, binds)
-
-inferCheckLoop doc tau_tvs givens wanteds
- = -- Step 1
- zonkTcTyVarsAndFV tau_tvs `thenNF_Tc` \ tau_tvs' ->
- mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
- mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
- tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
-
- let
- -- Figure out what we are going to generalise over
+tcSimplifyInferCheck doc tau_tvs givens wanted_lie
+ = tcSimplCheck doc isFreeAndInheritable get_qtvs givens wanted_lie
+ where
+ -- Figure out which type variables to quantify over
-- You might think it should just be the signature tyvars,
-- but in bizarre cases you can get extra ones
-- f :: forall a. Num a => a -> a
-- Here we infer g :: forall a b. a -> b -> (b,a)
-- We don't want g to be monomorphic in b just because
-- f isn't quantified over b.
- qtvs = (tau_tvs' `unionVarSet` tyVarsOfInsts givens') `minusVarSet` gbl_tvs
+ all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)
+
+ get_qtvs = zonkTcTyVarsAndFV all_tvs `thenNF_Tc` \ all_tvs' ->
+ tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
+ let
+ qtvs = all_tvs' `minusVarSet` gbl_tvs
-- We could close gbl_tvs, but its not necessary for
- -- soundness, and it'll only affect which tyvars, not which
+ -- soundness, and it'll only affect which tyvars, not which
-- dictionaries, we quantify over
+ in
+ returnNF_Tc qtvs
+\end{code}
- -- When checking against a given signature we always reduce
- -- until we find a match against something given, or can't reduce
- try_me inst | isFree qtvs inst = Free
- | otherwise = ReduceMe AddToIrreds
- in
- -- Step 2
- reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
-
- -- Step 3
- if no_improvement then
- returnTc (varSetElems qtvs, frees, binds, irreds)
- else
- inferCheckLoop doc tau_tvs givens wanteds
+Here is the workhorse function for all three wrappers.
+
+\begin{code}
+tcSimplCheck doc is_free get_qtvs givens wanted_lie
+ = check_loop givens (lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
+
+ -- Complain about any irreducible ones
+ complainCheck doc givens irreds `thenNF_Tc_`
+
+ -- Done
+ returnTc (qtvs, mkLIE frees, binds)
+
+ where
+ check_loop givens wanteds
+ = -- Step 1
+ mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
+ mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
+ get_qtvs `thenNF_Tc` \ qtvs' ->
+
+ -- Step 2
+ let
+ -- When checking against a given signature we always reduce
+ -- until we find a match against something given, or can't reduce
+ try_me inst | is_free qtvs' inst = Free
+ | otherwise = ReduceMe
+ in
+ reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+
+ -- Step 3
+ if no_improvement then
+ returnTc (varSetElems qtvs', frees, binds, irreds)
+ else
+ check_loop givens' (irreds ++ frees) `thenTc` \ (qtvs', frees1, binds1, irreds1) ->
+ returnTc (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1)
\end{code}
+%************************************************************************
+%* *
+\subsection{tcSimplifyRestricted}
+%* *
+%************************************************************************
+
+\begin{code}
+tcSimplifyRestricted -- Used for restricted binding groups
+ -- i.e. ones subject to the monomorphism restriction
+ :: SDoc
+ -> TcTyVarSet -- Free in the type of the RHSs
+ -> LIE -- Free in the RHSs
+ -> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
+ LIE, -- Free
+ TcDictBinds) -- Bindings
+
+tcSimplifyRestricted doc tau_tvs wanted_lie
+ = -- First squash out all methods, to find the constrained tyvars
+ -- We can't just take the free vars of wanted_lie because that'll
+ -- have methods that may incidentally mention entirely unconstrained variables
+ -- e.g. a call to f :: Eq a => a -> b -> b
+ -- Here, b is unconstrained. A good example would be
+ -- foo = f (3::Int)
+ -- We want to infer the polymorphic type
+ -- foo :: forall b. b -> b
+ let
+ wanteds = lieToList wanted_lie
+ try_me inst = ReduceMe -- Reduce as far as we can. Don't stop at
+ -- dicts; the idea is to get rid of as many type
+ -- variables as possible, and we don't want to stop
+ -- at (say) Monad (ST s), because that reduces
+ -- immediately, with no constraint on s.
+ in
+ simpleReduceLoop doc try_me wanteds `thenTc` \ (_, _, constrained_dicts) ->
+
+ -- Next, figure out the tyvars we will quantify over
+ zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenNF_Tc` \ tau_tvs' ->
+ tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
+ let
+ constrained_tvs = tyVarsOfInsts constrained_dicts
+ qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts constrained_dicts) gbl_tvs)
+ `minusVarSet` constrained_tvs
+ in
+
+ -- The first step may have squashed more methods than
+ -- necessary, so try again, this time knowing the exact
+ -- set of type variables to quantify over.
+ --
+ -- We quantify only over constraints that are captured by qtvs;
+ -- these will just be a subset of non-dicts. This in contrast
+ -- to normal inference (using isFreeAndInheritable) in which we quantify over
+ -- all *non-inheritable* constraints too. This implements choice
+ -- (B) under "implicit parameter and monomorphism" above.
+ mapNF_Tc zonkInst (lieToList wanted_lie) `thenNF_Tc` \ wanteds' ->
+ let
+ try_me inst | isFree qtvs inst = Free
+ | otherwise = ReduceMe
+ in
+ reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ ASSERT( no_improvement )
+ ASSERT( null irreds )
+ -- No need to loop because simpleReduceLoop will have
+ -- already done any improvement necessary
+
+ returnTc (varSetElems qtvs, mkLIE frees, binds)
+\end{code}
+
%************************************************************************
%* *
as the available stuff for the RHS of the rule.
The same thing is used for specialise pragmas. Consider
-
+
f :: Num a => a -> a
{-# SPECIALISE f :: Int -> Int #-}
f = ...
f_spec = _inline_me_ (f Int dNumInt)
-But that means that we must simplify the Method for f to (f Int dNumInt)!
+But that means that we must simplify the Method for f to (f Int dNumInt)!
So tcSimplifyToDicts squeezes out all Methods.
+IMPORTANT NOTE: we *don't* want to do superclass commoning up. Consider
+
+ fromIntegral :: (Integral a, Num b) => a -> b
+ {-# RULES "foo" fromIntegral = id :: Int -> Int #-}
+
+Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
+want to get
+
+ forall dIntegralInt.
+ fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
+
+because the scsel will mess up matching. Instead we want
+
+ forall dIntegralInt, dNumInt.
+ fromIntegral Int Int dIntegralInt dNumInt = id Int
+
+Hence "DontReduce NoSCs"
+
\begin{code}
tcSimplifyToDicts :: LIE -> TcM ([Inst], TcDictBinds)
tcSimplifyToDicts wanted_lie
= simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
- -- Since try_me doesn't look at types, we don't need to
+ -- Since try_me doesn't look at types, we don't need to
-- do any zonking, so it's safe to call reduceContext directly
ASSERT( null frees )
returnTc (irreds, binds)
wanteds = lieToList wanted_lie
-- Reduce methods and lits only; stop as soon as we get a dictionary
- try_me inst | isDict inst = DontReduce
- | otherwise = ReduceMe AddToIrreds
+ try_me inst | isDict inst = DontReduce NoSCs
+ | otherwise = ReduceMe
\end{code}
let ?x = R in B
we must discharge all the ?x constraints from B. We also do an improvement
-step; if we have ?x::t1 and ?x::t2 we must unify t1, t2. No need to iterate, though.
+step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.
+
+Actually, the constraints from B might improve the types in ?x. For example
+
+ f :: (?x::Int) => Char -> Char
+ let ?x = 3 in f 'c'
+
+then the constraint (?x::Int) arising from the call to f will
+force the binding for ?x to be of type Int.
\begin{code}
-tcSimplifyIPs :: [Name] -- The implicit parameters bound here
+tcSimplifyIPs :: [Inst] -- The implicit parameters bound here
-> LIE
-> TcM (LIE, TcDictBinds)
-tcSimplifyIPs ip_names wanted_lie
- = simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
- -- The irreducible ones should be a subset of the implicit
- -- parameters we provided
- ASSERT( all here_ip irreds )
+tcSimplifyIPs given_ips wanted_lie
+ = simpl_loop given_ips wanteds `thenTc` \ (frees, binds) ->
returnTc (mkLIE frees, binds)
-
where
- doc = text "tcSimplifyIPs" <+> ppr ip_names
- wanteds = lieToList wanted_lie
- ip_set = mkNameSet ip_names
- here_ip ip = isDict ip && ip `instMentionsIPs` ip_set
+ doc = text "tcSimplifyIPs" <+> ppr ip_names
+ wanteds = lieToList wanted_lie
+ ip_names = map instName given_ips
+ ip_set = mkNameSet ip_names
-- Simplify any methods that mention the implicit parameter
- try_me inst | inst `instMentionsIPs` ip_set = ReduceMe AddToIrreds
+ try_me inst | inst `instMentionsIPs` ip_set = ReduceMe
| otherwise = Free
+
+ simpl_loop givens wanteds
+ = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
+ mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
+
+ reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+
+ if no_improvement then
+ ASSERT( null irreds )
+ returnTc (frees, binds)
+ else
+ simpl_loop givens' (irreds ++ frees) `thenTc` \ (frees1, binds1) ->
+ returnTc (frees1, binds `AndMonoBinds` binds1)
\end{code}
bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM (LIE, TcMonoBinds)
bindInstsOfLocalFuns init_lie local_ids
- | null overloaded_ids
+ | null overloaded_ids
-- Common case
= returnTc (init_lie, EmptyMonoBinds)
| otherwise
- = simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
+ = simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
ASSERT( null irreds )
returnTc (mkLIE frees, binds)
where
doc = text "bindInsts" <+> ppr local_ids
wanteds = lieToList init_lie
overloaded_ids = filter is_overloaded local_ids
- is_overloaded id = case splitSigmaTy (idType id) of
- (_, theta, _) -> not (null theta)
+ is_overloaded id = isOverloadedTy (idType id)
overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
- -- so it's worth building a set, so that
+ -- so it's worth building a set, so that
-- lookup (in isMethodFor) is faster
- try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
+ try_me inst | isMethodFor overloaded_set inst = ReduceMe
| otherwise = Free
\end{code}
The main control over context reduction is here
\begin{code}
-data WhatToDo
- = ReduceMe -- Try to reduce this
- NoInstanceAction -- What to do if there's no such instance
+data WhatToDo
+ = ReduceMe -- Try to reduce this
+ -- If there's no instance, behave exactly like
+ -- DontReduce: add the inst to
+ -- the irreductible ones, but don't
+ -- produce an error message of any kind.
+ -- It might be quite legitimate such as (Eq a)!
- | DontReduce -- Return as irreducible
+ | DontReduce WantSCs -- Return as irreducible
| DontReduceUnlessConstant -- Return as irreducible unless it can
-- be reduced to a constant in one step
| Free -- Return as free
-data NoInstanceAction
- = Stop -- Fail; no error message
- -- (Only used when tautology checking.)
-
- | AddToIrreds -- Just add the inst to the irreductible ones; don't
- -- produce an error message of any kind.
- -- It might be quite legitimate such as (Eq a)!
+data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
+ -- of a predicate when adding it to the avails
\end{code}
| NoRhs -- Used for Insts like (CCallable f)
-- where no witness is required.
- | Rhs -- Used when there is a RHS
+ | Rhs -- Used when there is a RHS
TcExpr -- The RHS
[Inst] -- Insts free in the RHS; we need these too
-pprAvails avails = vcat (map pprAvail (eltsFM avails))
+pprAvails avails = vcat [ppr inst <+> equals <+> pprAvail avail
+ | (inst,avail) <- fmToList avails ]
instance Outputable Avail where
ppr = pprAvail
-- For implicit parameters, all occurrences share the same
-- Id, so there is no need for synonym bindings
new_binds | new_id == id = binds
- | otherwise = binds `AndMonoBinds` new_bind
- new_bind = VarMonoBind new_id (HsVar id)
+ | otherwise = addBind binds new_id (HsVar id)
new_id = instToId w
- Just (Rhs rhs ws') -> go avails' (binds `AndMonoBinds` new_bind) irreds (ws' ++ ws)
+ Just (Rhs rhs ws') -> go avails' (addBind binds id rhs) irreds (ws' ++ ws)
where
id = instToId w
avails' = addToFM avails w (BoundTo id)
- new_bind = VarMonoBind id rhs
+
+addBind binds id rhs = binds `AndMonoBinds` VarMonoBind id rhs
\end{code}
if no_improvement then
returnTc (frees, binds, irreds)
else
- simpleReduceLoop doc try_me wanteds
-\end{code}
+ simpleReduceLoop doc try_me (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
+ returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
+\end{code}
reduceContext doc try_me givens wanteds
=
-{- traceTc (text "reduceContext" <+> (vcat [
+ traceTc (text "reduceContext" <+> (vcat [
text "----------------------",
doc,
text "given" <+> ppr givens,
text "----------------------"
])) `thenNF_Tc_`
--}
-- Build the Avail mapping from "givens"
foldlNF_Tc addGiven (emptyFM, []) givens `thenNF_Tc` \ init_state ->
-- In particular, avails includes all superclasses of everything
tcImprove avails `thenTc` \ no_improvement ->
-{-
traceTc (text "reduceContext end" <+> (vcat [
text "----------------------",
doc,
text "given" <+> ppr givens,
text "wanted" <+> ppr wanteds,
- text "----",
+ text "----",
text "avails" <+> pprAvails avails,
text "frees" <+> ppr frees,
text "no_improvement =" <+> ppr no_improvement,
text "----------------------"
])) `thenNF_Tc_`
--}
let
(binds, irreds) = bindsAndIrreds avails wanteds
in
tcImprove avails
= tcGetInstEnv `thenTc` \ inst_env ->
let
- preds = predsOfInsts (keysFM avails)
+ preds = [ (pred, pp_loc)
+ | inst <- keysFM avails,
+ let pp_loc = pprInstLoc (instLoc inst),
+ pred <- predsOfInst inst,
+ predHasFDs pred
+ ]
-- Avails has all the superclasses etc (good)
-- It also has all the intermediates of the deduction (good)
-- It does not have duplicates (good)
if null eqns then
returnTc True
else
- mapTc_ (\ (t1,t2) -> unifyTauTy t1 t2) eqns `thenTc_`
+ traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenNF_Tc_`
+ mapTc_ unify eqns `thenTc_`
returnTc False
+ where
+ unify ((qtvs, t1, t2), doc)
+ = tcAddErrCtxt doc $
+ tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ unifyTauTy (substTy tenv t1) (substTy tenv t2)
\end{code}
The main context-reduction function is @reduce@. Here's its game plan.
Free return this in "frees"
wanteds: The list of insts to reduce
- state: An accumulating parameter of type RedState
+ state: An accumulating parameter of type RedState
that contains the state of the algorithm
-
+
It returns a RedState.
-The (n,stack) pair is just used for error reporting.
+The (n,stack) pair is just used for error reporting.
n is always the depth of the stack.
The stack is the stack of Insts being reduced: to produce X
I had to produce Y, to produce Y I had to produce Z, and so on.
| otherwise
= case try_me wanted of {
- DontReduce -> addIrred state wanted
+ DontReduce want_scs -> addIrred want_scs state wanted
; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
-- First, see if the inst can be reduced to a constant in one step
- try_simple addIrred
+ try_simple (addIrred AddSCs) -- Assume want superclasses
; Free -> -- It's free so just chuck it upstairs
-- First, see if the inst can be reduced to a constant in one step
try_simple addFree
- ; ReduceMe no_instance_action -> -- It should be reduced
+ ; ReduceMe -> -- It should be reduced
lookupInst wanted `thenNF_Tc` \ lookup_result ->
case lookup_result of
- GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenTc` \ state' ->
+ GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenTc` \ state' ->
addWanted state' wanted rhs wanteds'
SimpleInst rhs -> addWanted state wanted rhs []
- NoInstance -> -- No such instance!
- case no_instance_action of
- Stop -> failTc
- AddToIrreds -> addIrred state wanted
+ NoInstance -> -- No such instance!
+ -- Add it and its superclasses
+ addIrred AddSCs state wanted
}
where
isAvailable :: RedState -> Inst -> Bool
isAvailable (avails, _) wanted = wanted `elemFM` avails
-- NB: the Ord instance of Inst compares by the class/type info
- -- *not* by unique. So
+ -- *not* by unique. So
-- d1::C Int == d2::C Int
-------------------------
-- NB1: do *not* add superclasses. If we have
-- df::Floating a
-- dn::Num a
- -- but a is not bound here, then we *don't* want to derive
+ -- but a is not bound here, then we *don't* want to derive
-- dn from df here lest we lose sharing.
--
-- NB2: do *not* add the Inst to avails at all if it's a method.
-- The following situation shows why this is bad:
-- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
-- From an application (truncate f i) we get
- -- t1 = truncate at f
+ -- t1 = truncate at f
-- t2 = t1 at i
-- If we have also have a second occurrence of truncate, we get
-- t3 = truncate at f
addWanted :: RedState -> Inst -> TcExpr -> [Inst] -> NF_TcM RedState
addWanted state@(avails, frees) wanted rhs_expr wanteds
-- Do *not* add superclasses as well. Here's an example of why not
--- class Eq a => Foo a b
+-- class Eq a => Foo a b
-- instance Eq a => Foo [a] a
-- If we are reducing
-- (Foo [t] t)
--- we'll first deduce that it holds (via the instance decl). We
+-- we'll first deduce that it holds (via the instance decl). We
-- must not then overwrite the Eq t constraint with a superclass selection!
-- ToDo: this isn't entirely unsatisfactory, because
-- we may also lose some entirely-legitimate sharing this way
= ASSERT( not (isAvailable state wanted) )
returnNF_Tc (addToFM avails wanted avail, frees)
- where
+ where
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
addGiven :: RedState -> Inst -> NF_TcM RedState
-addGiven state given = add_avail state given (BoundTo (instToId given))
+addGiven state given = addAvailAndSCs state given (BoundTo (instToId given))
-addIrred :: RedState -> Inst -> NF_TcM RedState
-addIrred state irred = add_avail state irred Irred
+addIrred :: WantSCs -> RedState -> Inst -> NF_TcM RedState
+addIrred NoSCs (avails,frees) irred = returnNF_Tc (addToFM avails irred Irred, frees)
+addIrred AddSCs state irred = addAvailAndSCs state irred Irred
-add_avail :: RedState -> Inst -> Avail -> NF_TcM RedState
-add_avail (avails, frees) wanted avail
- = addAvail avails wanted avail `thenNF_Tc` \ avails' ->
+addAvailAndSCs :: RedState -> Inst -> Avail -> NF_TcM RedState
+addAvailAndSCs (avails, frees) wanted avail
+ = add_avail_and_scs avails wanted avail `thenNF_Tc` \ avails' ->
returnNF_Tc (avails', frees)
---------------------
-addAvail :: Avails -> Inst -> Avail -> NF_TcM Avails
-addAvail avails wanted avail
- = addSuperClasses (addToFM avails wanted avail) wanted
+add_avail_and_scs :: Avails -> Inst -> Avail -> NF_TcM Avails
+add_avail_and_scs avails wanted avail
+ = add_scs (addToFM avails wanted avail) wanted
-addSuperClasses :: Avails -> Inst -> NF_TcM Avails
+add_scs :: Avails -> Inst -> NF_TcM Avails
-- Add all the superclasses of the Inst to Avails
-- Invariant: the Inst is already in Avails.
-addSuperClasses avails dict
+add_scs avails dict
| not (isClassDict dict)
= returnNF_Tc avails
| otherwise -- It is a dictionary
= newDictsFromOld dict sc_theta' `thenNF_Tc` \ sc_dicts ->
- foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_dicts sc_sels)
+ foldlNF_Tc add_sc avails (zipEqual "add_scs" sc_dicts sc_sels)
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
- sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
+ sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
= case lookupFM avails sc_dict of
Just (BoundTo _) -> returnNF_Tc avails -- See Note [SUPER] below
- other -> addAvail avails sc_dict avail
+ other -> add_avail_and_scs avails sc_dict avail
where
sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
avail = Rhs sc_sel_rhs [dict]
class Ord a => C a where
instance Ord a => C [a] where ...
-Then we'll use the instance decl to deduce C [a] and then add the
+Then we'll use the instance decl to deduce C [a] and then add the
superclasses of C [a] to avails. But we must not overwrite the binding
for d1:Ord a (which is given) with a superclass selection or we'll just
build a loop! Hence looking for BoundTo. Crudely, BoundTo is cheaper
instance Num a => Num (Foo a b) where ...
and @tcSimplifyTop@ is given a constraint (Num (Foo x y)). Then it'll simplify
-to (Num x), and default x to Int. But what about y??
+to (Num x), and default x to Int. But what about y??
It's OK: the final zonking stage should zap y to (), which is fine.
let
-- All the non-std ones are definite errors
(stds, non_stds) = partition isStdClassTyVarDict irreds
-
+
-- Group by type variable
std_groups = equivClasses cmp_by_tyvar stds
-- Pick the ones which its worth trying to disambiguate
(std_oks, std_bads) = partition worth_a_try std_groups
- -- Have a try at disambiguation
+ -- Have a try at disambiguation
-- if the type variable isn't bound
-- up with one of the non-standard classes
worth_a_try group@(d:_) = not (non_std_tyvars `intersectsVarSet` tyVarsOfInst d)
mapTc disambigGroup std_oks `thenTc` \ binds_ambig ->
-- And complain about the ones that don't
+ -- This group includes both non-existent instances
+ -- e.g. Num (IO a) and Eq (Int -> Int)
+ -- and ambiguous dictionaries
+ -- e.g. Num a
addTopAmbigErrs bad_guys `thenNF_Tc_`
returnTc (binds `andMonoBinds` andMonoBindList binds_ambig)
where
wanteds = lieToList wanted_lie
- try_me inst = ReduceMe AddToIrreds
+ try_me inst = ReduceMe
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
get_tv d = case getDictClassTys d of
- (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
+ (clas, [ty]) -> tcGetTyVar "tcSimplify" ty
get_clas d = case getDictClassTys d of
(clas, [ty]) -> clas
\end{code}
disambigGroup dicts
| any isNumericClass classes -- Guaranteed all standard classes
- -- see comment at the end of function for reasons as to
+ -- see comment at the end of function for reasons as to
-- why the defaulting mechanism doesn't apply to groups that
-- include CCallable or CReturnable dicts.
&& not (any isCcallishClass classes)
try_default (default_ty : default_tys)
= tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
- tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
+ tcSimplifyCheckThetas [] theta `thenTc` \ _ ->
returnTc default_ty
where
- thetas = classes `zip` repeat [default_ty]
+ theta = [mkClassPred clas [default_ty] | clas <- classes]
in
-- See if any default works, and if so bind the type variable to it
-- If not, add an AmbigErr
- recoverTc (addAmbigErrs dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $
+ recoverTc (addAmbigErrs dicts `thenNF_Tc_`
+ returnTc EmptyMonoBinds) $
try_default default_tys `thenTc` \ chosen_default_ty ->
returnTc binds
| all isCreturnableClass classes
- = -- Default CCall stuff to (); we don't even both to check that () is an
+ = -- Default CCall stuff to (); we don't even both to check that () is an
-- instance of CReturnable, because we know it is.
unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
returnTc EmptyMonoBinds
-
+
| otherwise -- No defaults
= addAmbigErrs dicts `thenNF_Tc_`
returnTc EmptyMonoBinds
where
- try_me inst = ReduceMe AddToIrreds -- This reduce should not fail
+ try_me inst = ReduceMe -- This reduce should not fail
tyvar = get_tv (head dicts) -- Should be non-empty
classes = map get_clas dicts
\end{code}
results) of a restricted set of 'native' types. This is
implemented via the help of the pseudo-type classes,
@CReturnable@ (CR) and @CCallable@ (CC.)
-
+
The interaction between the defaulting mechanism for numeric
values and CC & CR can be a bit puzzling to the user at times.
For example,
of (Integer, Double), 'x' has type Double, since Integer
is not an instance of CR. If the default list is equal to
Haskell 1.4's default-default of (Int, Double), 'x' has type
-Int.
+Int.
To try to minimise the potential for surprises here, the
defaulting mechanism is turned off in the presence of
CCallable and CReturnable.
-]
+End of aside]
%************************************************************************
instance declarations.
\begin{code}
-tcSimplifyThetas :: ClassContext -- Wanted
- -> TcM ClassContext -- Needed
+tcSimplifyThetas :: ThetaType -- Wanted
+ -> TcM ThetaType -- Needed
tcSimplifyThetas wanteds
= doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts ->
-- we expect an instance here
-- For Haskell 98, check that all the constraints are of the form C a,
-- where a is a type variable
- bad_guys | glaExts = [ct | ct@(clas,tys) <- irreds,
- isEmptyVarSet (tyVarsOfTypes tys)]
- | otherwise = [ct | ct@(clas,tys) <- irreds,
- not (all isTyVarTy tys)]
+ bad_guys | glaExts = [pred | pred <- irreds,
+ isEmptyVarSet (tyVarsOfPred pred)]
+ | otherwise = [pred | pred <- irreds,
+ not (isTyVarClassPred pred)]
in
if null bad_guys then
returnTc irreds
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: ClassContext -- Given
- -> ClassContext -- Wanted
+tcSimplifyCheckThetas :: ThetaType -- Given
+ -> ThetaType -- Wanted
-> TcM ()
tcSimplifyCheckThetas givens wanteds
\begin{code}
-type AvailsSimple = FiniteMap (Class,[Type]) Bool
- -- True => irreducible
+type AvailsSimple = FiniteMap PredType Bool
+ -- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
-reduceSimple :: ClassContext -- Given
- -> ClassContext -- Wanted
- -> NF_TcM ClassContext -- Irreducible
+reduceSimple :: ThetaType -- Given
+ -> ThetaType -- Wanted
+ -> NF_TcM ThetaType -- Irreducible
reduceSimple givens wanteds
= reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
- returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
+ returnNF_Tc [pred | (pred,True) <- fmToList givens_fm']
where
givens_fm = foldl addNonIrred emptyFM givens
-reduce_simple :: (Int,ClassContext) -- Stack
+reduce_simple :: (Int,ThetaType) -- Stack
-> AvailsSimple
- -> ClassContext
+ -> ThetaType
-> NF_TcM AvailsSimple
reduce_simple (n,stack) avails wanteds
go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' ->
go avails' ws
-reduce_simple_help stack givens wanted@(clas,tys)
+reduce_simple_help stack givens wanted
| wanted `elemFM` givens
= returnNF_Tc givens
- | otherwise
+ | Just (clas, tys) <- getClassPredTys_maybe wanted
= lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta ->
-
case maybe_theta of
Nothing -> returnNF_Tc (addSimpleIrred givens wanted)
Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
-addSimpleIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
-addSimpleIrred givens ct@(clas,tys)
- = addSCs (addToFM givens ct True) ct
+ | otherwise
+ = returnNF_Tc (addSimpleIrred givens wanted)
+
+addSimpleIrred :: AvailsSimple -> PredType -> AvailsSimple
+addSimpleIrred givens pred
+ = addSCs (addToFM givens pred True) pred
-addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
-addNonIrred givens ct@(clas,tys)
- = addSCs (addToFM givens ct False) ct
+addNonIrred :: AvailsSimple -> PredType -> AvailsSimple
+addNonIrred givens pred
+ = addSCs (addToFM givens pred False) pred
-addSCs givens ct@(clas,tys)
- = foldl add givens sc_theta
+addSCs givens pred
+ | not (isClassPred pred) = givens
+ | otherwise = foldl add givens sc_theta
where
+ Just (clas,tys) = getClassPredTys_maybe pred
(tyvars, sc_theta_tmpl, _, _) = classBigSig clas
- sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
+ sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
- add givens ct@(clas, tys)
+ add givens ct
= case lookupFM givens ct of
Nothing -> -- Add it and its superclasses
addSCs (addToFM givens ct False) ct
Just False -> -- Already done
givens
-
+
\end{code}
now?
\begin{code}
+groupInsts :: [Inst] -> [[Inst]]
+-- Group together insts with the same origin
+-- We want to report them together in error messages
+groupInsts [] = []
+groupInsts (inst:insts) = (inst:friends) : groupInsts others
+ where
+ -- (It may seem a bit crude to compare the error messages,
+ -- but it makes sure that we combine just what the user sees,
+ -- and it avoids need equality on InstLocs.)
+ (friends, others) = partition is_friend insts
+ loc_msg = showSDoc (pprInstLoc (instLoc inst))
+ is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
+
+
addTopAmbigErrs dicts
- = mapNF_Tc complain tidy_dicts
+ = mapNF_Tc (addTopInstanceErrs tidy_env) (groupInsts no_insts) `thenNF_Tc_`
+ mapNF_Tc (addTopIPErrs tidy_env) (groupInsts bad_ips) `thenNF_Tc_`
+ mapNF_Tc (addAmbigErr tidy_env) ambigs `thenNF_Tc_`
+ returnNF_Tc ()
where
fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet
- (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts
- complain d | not (null (getIPs d)) = addTopIPErr tidy_env d
- | tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d
- | otherwise = addAmbigErr tidy_env d
+ (tidy_env, tidy_dicts) = tidyInsts dicts
+ (bad_ips, non_ips) = partition is_ip tidy_dicts
+ (no_insts, ambigs) = partition no_inst non_ips
+ is_ip d = any isIPPred (predsOfInst d)
+ no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs
-addTopIPErr tidy_env tidy_dict
- = addInstErrTcM (instLoc tidy_dict)
- (tidy_env,
- ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
+plural [x] = empty
+plural xs = char 's'
+
+addTopIPErrs tidy_env tidy_dicts
+ = addInstErrTcM (instLoc (head tidy_dicts))
+ (tidy_env,
+ ptext SLIT("Unbound implicit parameter") <> plural tidy_dicts <+> pprInsts tidy_dicts)
-- Used for top-level irreducibles
-addTopInstanceErr tidy_env tidy_dict
- = addInstErrTcM (instLoc tidy_dict)
- (tidy_env,
- ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
+addTopInstanceErrs tidy_env tidy_dicts
+ = addInstErrTcM (instLoc (head tidy_dicts))
+ (tidy_env,
+ ptext SLIT("No instance") <> plural tidy_dicts <+>
+ ptext SLIT("for") <+> pprInsts tidy_dicts)
addAmbigErrs dicts
= mapNF_Tc (addAmbigErr tidy_env) tidy_dicts
where
- (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts
+ (tidy_env, tidy_dicts) = tidyInsts dicts
addAmbigErr tidy_env tidy_dict
= addInstErrTcM (instLoc tidy_dict)
warnDefault dicts default_ty
= doptsTc Opt_WarnTypeDefaults `thenTc` \ warn_flag ->
- if warn_flag
- then mapNF_Tc warn groups `thenNF_Tc_` returnNF_Tc ()
- else returnNF_Tc ()
-
+ tcAddSrcLoc (get_loc (head dicts)) (warnTc warn_flag warn_msg)
where
-- Tidy them first
- (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
-
- -- Group the dictionaries by source location
- groups = equivClasses cmp tidy_dicts
- i1 `cmp` i2 = get_loc i1 `compare` get_loc i2
- get_loc i = case instLoc i of { (_,loc,_) -> loc }
-
- warn [dict] = tcAddSrcLoc (get_loc dict) $
- warnTc True (ptext SLIT("Defaulting") <+> quotes (pprInst dict) <+>
- ptext SLIT("to type") <+> quotes (ppr default_ty))
-
- warn dicts = tcAddSrcLoc (get_loc (head dicts)) $
- warnTc True (vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty),
- pprInstsInFull dicts])
-
--- The error message when we don't find a suitable instance
--- is complicated by the fact that sometimes this is because
--- there is no instance, and sometimes it's because there are
--- too many instances (overlap). See the comments in TcEnv.lhs
--- with the InstEnv stuff.
-addNoInstanceErr what_doc givens dict
+ (_, tidy_dicts) = tidyInsts dicts
+ get_loc i = case instLoc i of { (_,loc,_) -> loc }
+ warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
+ quotes (ppr default_ty),
+ pprInstsInFull tidy_dicts]
+
+complainCheck doc givens irreds
+ = mapNF_Tc zonkInst given_dicts `thenNF_Tc` \ givens' ->
+ mapNF_Tc (addNoInstanceErrs doc givens') (groupInsts irreds) `thenNF_Tc_`
+ returnNF_Tc ()
+ where
+ given_dicts = filter isDict givens
+ -- Filter out methods, which are only added to
+ -- the given set as an optimisation
+
+addNoInstanceErrs what_doc givens dicts
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
let
- doc = vcat [sep [herald <+> quotes (pprInst tidy_dict),
+ (tidy_env1, tidy_givens) = tidyInsts givens
+ (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts
+
+ doc = vcat [sep [herald <+> pprInsts tidy_dicts,
nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens],
ambig_doc,
ptext SLIT("Probable fix:"),
nest 4 fix1,
nest 4 fix2]
-
+
herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
- unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
+ unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
| otherwise = empty
-
- ambig_doc
+
+ -- The error message when we don't find a suitable instance
+ -- is complicated by the fact that sometimes this is because
+ -- there is no instance, and sometimes it's because there are
+ -- too many instances (overlap). See the comments in TcEnv.lhs
+ -- with the InstEnv stuff.
+
+ ambig_doc
| not ambig_overlap = empty
- | otherwise
+ | otherwise
= vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
- nest 4 (ptext SLIT("depends on the instantiation of") <+>
- quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
-
- fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
+ nest 4 (ptext SLIT("depends on the instantiation of") <+>
+ quotes (pprWithCommas ppr (varSetElems (tyVarsOfInsts tidy_dicts))))]
+
+ fix1 = sep [ptext SLIT("Add") <+> pprInsts tidy_dicts,
ptext SLIT("to the") <+> what_doc]
-
- fix2 | isTyVarDict dict || ambig_overlap
+
+ fix2 | null instance_dicts
= empty
| otherwise
- = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
-
- (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
-
+ = ptext SLIT("Or add an instance declaration for") <+> pprInsts instance_dicts
+
+ instance_dicts = [d | d <- tidy_dicts, isClassDict d, not (isTyVarDict d)]
+ -- Insts for which it is worth suggesting an adding an instance declaration
+ -- Exclude implicit parameters, and tyvar dicts
+
-- Checks for the ambiguous case when we have overlapping instances
- ambig_overlap | isClassDict dict
- = case lookupInstEnv inst_env clas tys of
+ ambig_overlap = any ambig_overlap1 dicts
+ ambig_overlap1 dict
+ | isClassDict dict
+ = case lookupInstEnv inst_env clas tys of
NoMatch ambig -> ambig
other -> False
- | otherwise = False
- where
- (clas,tys) = getDictClassTys dict
+ | otherwise = False
+ where
+ (clas,tys) = getDictClassTys dict
in
- addInstErrTcM (instLoc dict) (tidy_env, doc)
+ addInstErrTcM (instLoc (head dicts)) (tidy_env2, doc)
-- Used for the ...Thetas variants; all top level
-addNoInstErr (c,ts)
- = addErrTc (ptext SLIT("No instance for") <+> quotes (pprClassPred c ts))
+addNoInstErr pred
+ = addErrTc (ptext SLIT("No instance for") <+> quotes (ppr pred))
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
-----------------------------------------------
addCantGenErr inst
- = addErrTc (sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
+ = addErrTc (sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
nest 4 (ppr inst <+> pprInstLoc (instLoc inst))])
\end{code}