Typos in a comment. Whitespace at eols.
\begin{code}
module TcSimplify (
\begin{code}
module TcSimplify (
- tcSimplifyInfer, tcSimplifyInferCheck,
+ tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyCheck, tcSimplifyRestricted,
tcSimplifyCheck, tcSimplifyRestricted,
- tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
+ tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
tcSimplifyThetas, tcSimplifyCheckThetas,
bindInstsOfLocalFuns
tcSimplifyThetas, tcSimplifyCheckThetas,
bindInstsOfLocalFuns
#include "HsVersions.h"
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
#include "HsVersions.h"
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
-import TcHsSyn ( TcExpr, TcId,
+import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
)
TcMonoBinds, TcDictBinds
)
getDictClassTys, isTyVarDict,
instLoc, pprInst, zonkInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
getDictClassTys, isTyVarDict,
instLoc, pprInst, zonkInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
%* *
%************************************************************************
%* *
%************************************************************************
- --------------------------------------
+ --------------------------------------
- --------------------------------------
+ --------------------------------------
Suppose we are about to do a generalisation step.
We have in our hand
Suppose we are about to do a generalisation step.
We have in our hand
-and float the constraints Ct further outwards.
+and float the constraints Ct further outwards.
Here are the things that *must* be true:
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 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}
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.
Note that grow(vs,C) `superset` grow(vs,simplify(C))
That is, simplfication can only shrink the result of grow.
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)
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 ...
Why grow( fv(T), C ) rather than fv(T)? Consider
class H x y | x->y where ...
forall c. H c d => c -> b
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.
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
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
(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:
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,
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.
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
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?
certainly ambiguous. UNLESS it is a constant (sigh). And what about
the nasty example?
(which squashes out the constants, like Eq (T a) above)
(which squashes out the constants, like Eq (T a) above)
- --------------------------------------
+ --------------------------------------
- --------------------------------------
+ --------------------------------------
class C a where
op :: a -> a
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 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
f :: forall a. C Int => a -> a
- --------------------------------------
+ --------------------------------------
Notes on implicit parameters
Notes on implicit parameters
- --------------------------------------
+ --------------------------------------
Question 1: can we "inherit" implicit parameters
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Question 1: can we "inherit" implicit parameters
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Question 2: type signatures
~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
f :: Int -> Int
f x = (x::Int) + ?y
over the ?y parameter, to get
z :: (?y::Int) => Int,
but the monomorphism restriction says that we *must not*, giving
over the ?y parameter, to get
z :: (?y::Int) => Int,
but the monomorphism restriction says that we *must not*, giving
Why does the momomorphism restriction say this? Because if you have
let z = x + ?y in z+z
Why does the momomorphism restriction say this? Because if you have
let z = x + ?y in z+z
be generalised
Consequences:
be generalised
Consequences:
- * Inlning remains valid
+ * Inlining remains valid
* No unexpected loss of sharing
* But simple bindings like
z = ?y + 1
* No unexpected loss of sharing
* But simple bindings like
z = ?y + 1
BOTTOM LINE: we choose (B) at present. See tcSimplifyRestricted
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 )
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
predicates will end up in Ct; we deal with them at the top level
3. Try improvement, using functional dependencies
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
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.
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 ...
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
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
\begin{code}
tcSimplifyInfer
\begin{code}
tcSimplifyInfer
- :: SDoc
- -> TcTyVarSet -- fv(T); type vars
+ :: SDoc
+ -> TcTyVarSet -- fv(T); type vars
-> LIE -- Wanted
-> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
LIE, -- Free
-> LIE -- Wanted
-> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
LIE, -- Free
\begin{code}
tcSimplifyInfer doc tau_tvs wanted_lie
\begin{code}
tcSimplifyInfer doc tau_tvs wanted_lie
- = inferLoop doc (varSetElems tau_tvs)
+ = inferLoop doc (varSetElems tau_tvs)
(lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
-- Check for non-generalisable insts
(lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
-- Check for non-generalisable insts
let
preds = predsOfInsts wanteds'
qtvs = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
let
preds = predsOfInsts wanteds'
qtvs = grow preds tau_tvs' `minusVarSet` oclose preds gbl_tvs
| 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) ->
| 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)
-- Step 3
if no_improvement then
returnTc (varSetElems qtvs, frees, binds, irreds)
inferLoop doc tau_tvs (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
inferLoop doc tau_tvs (irreds ++ frees) `thenTc` \ (qtvs1, frees1, binds1, irreds1) ->
returnTc (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1)
Then we'll reduce using the Max instance to:
(Lte Z (S x) l, If l (S x) Z 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
+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)!
on both the Lte and If constraints. What we *can't* do is start again
with (Max Z (S x) y)!
&& all inheritablePred (predsOfInst inst) -- And no implicit parameter involved
-- (see "Notes on implicit parameters")
&& all inheritablePred (predsOfInst inst) -- And no implicit parameter involved
-- (see "Notes on implicit parameters")
= not (tyVarsOfInst inst `intersectsVarSet` qtvs)
\end{code}
= not (tyVarsOfInst inst `intersectsVarSet` qtvs)
\end{code}
\begin{code}
tcSimplifyCheck
\begin{code}
tcSimplifyCheck
-> [TcTyVar] -- Quantify over these
-> [Inst] -- Given
-> LIE -- Wanted
-> TcM (LIE, -- Free
TcDictBinds) -- Bindings
-> [TcTyVar] -- Quantify over these
-> [Inst] -- Given
-> LIE -- Wanted
-> TcM (LIE, -- Free
TcDictBinds) -- Bindings
--- tcSimplifyCheck is used when checking exprssion type signatures,
+-- 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
-- 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
-- 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
-- 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
-> TcTyVarSet -- fv(T)
-> [Inst] -- Given
-> LIE -- Wanted
-> TcTyVarSet -- fv(T)
-> [Inst] -- Given
-> LIE -- Wanted
let
qtvs = all_tvs' `minusVarSet` gbl_tvs
-- We could close gbl_tvs, but its not necessary for
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
-- dictionaries, we quantify over
in
returnNF_Tc qtvs
Here is the workhorse function for all three wrappers.
Here is the workhorse function for all three wrappers.
tcSimplCheck doc is_free get_qtvs givens wanted_lie
= check_loop givens (lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
tcSimplCheck doc is_free get_qtvs givens wanted_lie
= check_loop givens (lieToList wanted_lie) `thenTc` \ (qtvs, frees, binds, irreds) ->
= -- Step 1
mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
= -- Step 1
mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' ->
mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
- get_qtvs `thenNF_Tc` \ qtvs' ->
-
+ 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
-- 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
in
reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
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)
-- Step 3
if no_improvement then
returnTc (varSetElems qtvs', frees, binds, irreds)
returnTc ()
where
given_dicts = filter isDict givens
returnTc ()
where
given_dicts = filter isDict givens
- -- Filter out methods, which are only added to
+ -- Filter out methods, which are only added to
-- the given set as an optimisation
\end{code}
-- the given set as an optimisation
\end{code}
\begin{code}
tcSimplifyRestricted -- Used for restricted binding groups
-- i.e. ones subject to the monomorphism restriction
\begin{code}
tcSimplifyRestricted -- Used for restricted binding groups
-- i.e. ones subject to the monomorphism restriction
-> TcTyVarSet -- Free in the type of the RHSs
-> LIE -- Free in the RHSs
-> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
-> TcTyVarSet -- Free in the type of the RHSs
-> LIE -- Free in the RHSs
-> TcM ([TcTyVar], -- Tyvars to quantify (zonked)
tcSimplifyRestricted doc tau_tvs wanted_lie
= -- First squash out all methods, to find the constrained tyvars
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
-- 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
-- necessary, so try again, this time knowing the exact
-- set of type variables to quantify over.
--
-- 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
-- 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
-- (B) under "implicit parameter and monomorphism" above.
mapNF_Tc zonkInst (lieToList wanted_lie) `thenNF_Tc` \ wanteds' ->
let
as the available stuff for the RHS of the rule.
The same thing is used for specialise pragmas. Consider
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 :: Num a => a -> a
{-# SPECIALISE f :: Int -> Int #-}
f = ...
f_spec = _inline_me_ (f Int dNumInt)
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
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 #-}
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.
want to get
forall dIntegralInt.
tcSimplifyToDicts :: LIE -> TcM ([Inst], TcDictBinds)
tcSimplifyToDicts wanted_lie
= simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) ->
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)
-- 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
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'
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}
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
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
-- 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' ->
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
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
bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM (LIE, TcMonoBinds)
bindInstsOfLocalFuns init_lie local_ids
-- Common case
= returnTc (init_lie, EmptyMonoBinds)
| otherwise
-- 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
ASSERT( null irreds )
returnTc (mkLIE frees, binds)
where
is_overloaded id = isOverloadedTy (idType id)
overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
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
-- lookup (in isMethodFor) is faster
try_me inst | isMethodFor overloaded_set inst = ReduceMe
The main control over context reduction is here
\begin{code}
The main control over context reduction is here
\begin{code}
= ReduceMe -- Try to reduce this
-- If there's no instance, behave exactly like
= 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)!
-- 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
| 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.
| 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
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)
else
simpleReduceLoop doc try_me (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
doc,
text "given" <+> ppr givens,
text "wanted" <+> ppr wanteds,
doc,
text "given" <+> ppr givens,
text "wanted" <+> ppr wanteds,
text "avails" <+> pprAvails avails,
text "frees" <+> ppr frees,
text "no_improvement =" <+> ppr no_improvement,
text "avails" <+> pprAvails avails,
text "frees" <+> ppr frees,
text "no_improvement =" <+> ppr no_improvement,
Free return this in "frees"
wanteds: The list of insts to reduce
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
that contains the state of the algorithm
-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.
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
; 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 []
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
-- 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
isAvailable :: RedState -> Inst -> Bool
isAvailable (avails, _) wanted = wanted `elemFM` avails
-- NB: the Ord instance of Inst compares by the class/type info
-- d1::C Int == d2::C Int
-------------------------
-- d1::C Int == d2::C Int
-------------------------
-- NB1: do *not* add superclasses. If we have
-- df::Floating a
-- dn::Num a
-- 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
-- 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
-- t2 = t1 at i
-- If we have also have a second occurrence of truncate, we get
-- t3 = 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
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)
-- 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)
-- 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)
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
avail | instBindingRequired wanted = Rhs rhs_expr wanteds
| otherwise = ASSERT( null wanteds ) NoRhs
class Ord a => C a where
instance Ord a => C [a] where ...
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
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
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.
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
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
-- 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)
-- 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
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
-- e.g. Num (IO a) and Eq (Int -> Int)
-- and ambiguous dictionaries
-- e.g. Num a
disambigGroup dicts
| any isNumericClass classes -- Guaranteed all standard classes
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)
-- 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
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 EmptyMonoBinds) $
try_default default_tys `thenTc` \ chosen_default_ty ->
returnTc binds
| all isCreturnableClass classes
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
-- instance of CReturnable, because we know it is.
unifyTauTy (mkTyVarTy tyvar) unitTy `thenTc_`
returnTc EmptyMonoBinds
| otherwise -- No defaults
= addAmbigErrs dicts `thenNF_Tc_`
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.)
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,
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
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
To try to minimise the potential for surprises here, the
defaulting mechanism is turned off in the presence of
To try to minimise the potential for surprises here, the
defaulting mechanism is turned off in the presence of
-- 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
-- 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)]
isEmptyVarSet (tyVarsOfPred pred)]
- | otherwise = [pred | pred <- irreds,
+ | otherwise = [pred | pred <- irreds,
not (isTyVarClassPred pred)]
in
if null bad_guys then
not (isTyVarClassPred pred)]
in
if null bad_guys then
\begin{code}
type AvailsSimple = FiniteMap PredType Bool
\begin{code}
type AvailsSimple = FiniteMap PredType Bool
-- False => given, or can be derived from a given or from an irreducible
reduceSimple :: ThetaType -- Given
-- False => given, or can be derived from a given or from an irreducible
reduceSimple :: ThetaType -- Given
Just False -> -- Already done
givens
Just False -> -- Already done
givens
| otherwise = addAmbigErr tidy_env d
addTopIPErr tidy_env tidy_dict
| otherwise = addAmbigErr tidy_env d
addTopIPErr tidy_env tidy_dict
- = addInstErrTcM (instLoc tidy_dict)
- (tidy_env,
+ = addInstErrTcM (instLoc tidy_dict)
+ (tidy_env,
ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
-- Used for top-level irreducibles
addTopInstanceErr tidy_env tidy_dict
ptext SLIT("Unbound implicit parameter") <+> quotes (pprInst tidy_dict))
-- Used for top-level irreducibles
addTopInstanceErr tidy_env tidy_dict
- = addInstErrTcM (instLoc tidy_dict)
- (tidy_env,
+ = addInstErrTcM (instLoc tidy_dict)
+ (tidy_env,
ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
addAmbigErrs dicts
ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
addAmbigErrs dicts
-- Tidy them first
(_, tidy_dicts) = tidyInsts dicts
get_loc i = case instLoc i of { (_,loc,_) -> loc }
-- 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]
quotes (ppr default_ty),
pprInstsInFull tidy_dicts]
ptext SLIT("Probable fix:"),
nest 4 fix1,
nest 4 fix2]
ptext SLIT("Probable fix:"),
nest 4 fix1,
nest 4 fix2]
herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
- unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
+ unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
| not ambig_overlap = empty
| not ambig_overlap = empty
= vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
= vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
- nest 4 (ptext SLIT("depends on the instantiation of") <+>
+ nest 4 (ptext SLIT("depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
ptext SLIT("to the") <+> what_doc]
fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
ptext SLIT("to the") <+> what_doc]
-
- fix2 | isTyVarDict dict
+
+ fix2 | isTyVarDict dict
|| not (isClassDict dict) -- Don't suggest adding instance declarations for implicit parameters
|| not (isClassDict dict) -- Don't suggest adding instance declarations for implicit parameters
= empty
| otherwise
= ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
= empty
| otherwise
= ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
(tidy_env, tidy_dict:tidy_givens) = tidyInsts (dict:givens)
(tidy_env, tidy_dict:tidy_givens) = tidyInsts (dict:givens)
-- Checks for the ambiguous case when we have overlapping instances
ambig_overlap | isClassDict dict
= case lookupInstEnv inst_env clas tys of
-- Checks for the ambiguous case when we have overlapping instances
ambig_overlap | isClassDict dict
= case lookupInstEnv inst_env clas tys of
-----------------------------------------------
addCantGenErr inst
-----------------------------------------------
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}
nest 4 (ppr inst <+> pprInstLoc (instLoc inst))])
\end{code}