\begin{code}
module TcSimplify (
- tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
- tcSimplifyRestricted,
- tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
+ tcSimplifyInfer, tcSimplifyInferCheck,
+ tcSimplifyCheck, tcSimplifyRestricted,
+ tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
tcSimplifyThetas, tcSimplifyCheckThetas,
bindInstsOfLocalFuns
#include "HsVersions.h"
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
-import TcHsSyn ( TcExpr, TcId,
+import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
)
instBindingRequired, instCanBeGeneralised,
newDictsFromOld, instMentionsIPs,
getDictClassTys, isTyVarDict,
- instLoc, pprInst, zonkInst, tidyInsts,
+ 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, tcInstTyVars )
-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 NameSet ( mkNameSet )
import Class ( classBigSig )
-import FunDeps ( oclose, grow, improve )
+import FunDeps ( oclose, grow, improve, pprEquationDoc )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
-import Type ( ThetaType, PredType, mkClassPred,
- mkTyVarTy, getTyVar, isTyVarClassPred,
- splitSigmaTy, tyVarsOfPred,
- getClassPredTys_maybe, isClassPred, isIPPred,
- inheritablePred, predHasFDs
- )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy )
import VarSet
%* *
%************************************************************************
- --------------------------------------
+ --------------------------------------
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
(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?
(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)
f :: forall a. C Int => a -> a
- --------------------------------------
+ --------------------------------------
Notes on implicit parameters
- --------------------------------------
+ --------------------------------------
Question 1: can we "inherit" implicit parameters
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
+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 it it legal to give an explicit, user type signature to f, thus:
+OK, so is it legal to give an explicit, user type signature to f, thus:
f :: Int -> Int
f x = (x::Int) + ?y
At first sight this seems reasonable, but it has the nasty property
-that adding a type signature changes the dynamic semantics.=20
+that adding a type signature changes the dynamic semantics.
Consider this:
(let f x = (x::Int) + ?y
returns (3+6, 3+5)
vs
- (let f :: Int -> Int=20
+ (let f :: Int -> Int
f x = x + ?y
in (f 3, f 3 with ?y=5)) with ?y = 6
z = (x::Int) + ?y
-The argument above suggests that we *must* generalise=20
-over the ?y parameter, to get=20
+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. =20
+ z :: Int.
Why does the momomorphism restriction say this? Because if you have
let z = x + ?y in z+z
be generalised
Consequences:
- * Inlning remains valid
+ * Inlining remains valid
* No unexpected loss of sharing
* But simple bindings like
z = ?y + 1
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=20
+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=20
+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
-
+
%************************************************************************
%* *
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
+
+ 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)
--
-- 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}
+\end{code}
Example [LOOP]
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
+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}
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)
+isFree qtvs inst
+ = not (tyVarsOfInst inst `intersectsVarSet` qtvs)
\end{code}
\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) ->
+ = tcSimplCheck doc isFree get_qtvs
+ givens wanted_lie `thenTc` \ (qtvs', frees, binds) ->
+ returnTc (frees, binds)
+ where
+ get_qtvs = zonkTcTyVarsAndFV qtvs
+
+
+-- 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
+ -> TcTyVarSet -- fv(T)
+ -> [Inst] -- Given
+ -> LIE -- Wanted
+ -> TcM ([TcTyVar], -- Variables over which to quantify
+ LIE, -- Free
+ TcDictBinds) -- Bindings
+
+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
+ -- f x = fst (g (x, head [])) + 1
+ -- g a b = (b,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.
+ 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
+ -- dictionaries, we quantify over
+ in
+ returnNF_Tc qtvs
+\end{code}
+
+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 (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' ->
-
- -- 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 | isFreeAndInheritable 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 (frees, binds, irreds)
- else
- checkLoop doc qtvs givens' (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
- returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
+ returnTc (qtvs, mkLIE frees, binds)
-complainCheck doc givens irreds
- = mapNF_Tc zonkInst given_dicts `thenNF_Tc` \ givens' ->
- mapNF_Tc (addNoInstanceErr doc given_dicts) irreds `thenNF_Tc_`
- returnTc ()
where
- given_dicts = filter isDict givens
- -- Filter out methods, which are only added to
- -- the given set as an optimisation
+ 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}
\begin{code}
tcSimplifyRestricted -- Used for restricted binding groups
- :: SDoc
- -> [TcTyVar] -- Free in the type of the RHSs
+ -- 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
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
+ -- 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
- tcSimplifyToDicts wanted_lie `thenTc` \ (dicts, _) ->
let
- constrained_tvs = tyVarsOfInsts dicts
+ 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 tau_tvs `thenNF_Tc` \ tau_tvs' ->
- tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
+ zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenNF_Tc` \ tau_tvs' ->
+ tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
let
- qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts dicts) gbl_tvs)
+ constrained_tvs = tyVarsOfInsts constrained_dicts
+ qtvs = (tau_tvs' `minusVarSet` oclose (predsOfInsts constrained_dicts) gbl_tvs)
`minusVarSet` constrained_tvs
in
-- 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;
+ -- 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
+ -- 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
reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
ASSERT( no_improvement )
ASSERT( null irreds )
- -- No need to loop because tcSimplifyToDicts will have
+ -- No need to loop because simpleReduceLoop will have
-- already done any improvement necessary
returnTc (varSetElems qtvs, mkLIE frees, binds)
%************************************************************************
%* *
-\subsection{tcSimplifyAndCheck}
-%* *
-%************************************************************************
-
-@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.
-
-\begin{code}
-tcSimplifyInferCheck
- :: SDoc
- -> [TcTyVar] -- 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
- -- 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
- -- f x = fst (g (x, head [])) + 1
- -- g a b = (b,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
- -- We could close gbl_tvs, but its not necessary for
- -- soundness, and it'll only affect which tyvars, not which
- -- dictionaries, we quantify over
-
- -- When checking against a given signature we always reduce
- -- until we find a match against something given, or can't reduce
- try_me inst | isFreeAndInheritable qtvs inst = Free
- | otherwise = ReduceMe
- 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' (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
- returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{tcSimplifyToDicts}
%* *
%************************************************************************
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*
+Here, a=b=Int, and Num Int is a superclass of Integral Int. But we *dont*
want to get
forall dIntegralInt.
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)
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.
+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
+then the constraint (?x::Int) arising from the call to f will
force the binding for ?x to be of type Int.
\begin{code}
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
| 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
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
The main control over context reduction is here
\begin{code}
-data WhatToDo
+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
+ -- 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 WantSCs -- Return as irreducible
+ | DontReduce WantSCs -- Return as irreducible
| DontReduceUnlessConstant -- Return as irreducible unless it can
-- be reduced to a constant in one step
| 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
else
simpleReduceLoop doc try_me (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
-\end{code}
+\end{code}
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,
if null eqns then
returnTc True
else
- traceTc (ptext SLIT("Improve:") <+> vcat (map ppr_eqn eqns)) `thenNF_Tc_`
+ traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenNF_Tc_`
mapTc_ unify eqns `thenTc_`
returnTc False
where
= tcAddErrCtxt doc $
tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
unifyTauTy (substTy tenv t1) (substTy tenv t2)
- ppr_eqn ((qtvs, t1, t2), doc)
- = vcat [ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs))
- <+> ppr t1 <+> equals <+> ppr t2,
- doc]
\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.
; 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!
+ NoInstance -> -- No such instance!
-- Add it and its superclasses
addIrred AddSCs state wanted
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
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
+ -- This group includes both non-existent instances
-- e.g. Num (IO a) and Eq (Int -> Int)
-- and ambiguous dictionaries
-- e.g. Num a
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)
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_`
+ 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
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]
%************************************************************************
-- 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 = [pred | pred <- irreds,
+ bad_guys | glaExts = [pred | pred <- irreds,
isEmptyVarSet (tyVarsOfPred pred)]
- | otherwise = [pred | pred <- irreds,
+ | otherwise = [pred | pred <- irreds,
not (isTyVarClassPred pred)]
in
if null bad_guys then
\begin{code}
type AvailsSimple = FiniteMap PredType Bool
- -- True => irreducible
+ -- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
reduceSimple :: ThetaType -- Given
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 dicts
- complain d | any isIPPred (predsOfInst d) = addTopIPErr tidy_env d
- | not (isTyVarDict d) ||
- tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d
- | otherwise = addAmbigErr tidy_env d
+ (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
-- Tidy them first
(_, 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") <+>
+ warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+>
quotes (ppr default_ty),
pprInstsInFull tidy_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
+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
- || not (isClassDict dict) -- Don't suggest adding instance declarations for implicit parameters
- || 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 (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 pred
-----------------------------------------------
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}