%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 2000
%
-\section[FunDeps]{FunDeps - functional dependencies}
+
+FunDeps - functional dependencies
It's better to read it as: "if we know these, then we're going to know these"
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module FunDeps (
Equation, pprEquation,
- oclose, grow, improve,
+ oclose, grow, improveOne,
checkInstCoverage, checkFunDeps,
pprFundeps
) where
#include "HsVersions.h"
-import Name ( Name, getSrcLoc )
-import Var ( TyVar )
-import Class ( Class, FunDep, classTvsFds )
-import Unify ( tcUnifyTys, BindFlag(..) )
-import Type ( substTys, notElemTvSubst )
-import TcType ( Type, PredType(..), tcEqType,
- predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred )
-import InstEnv ( Instance(..), InstEnv, instanceHead, classInstances,
- instanceCantMatch, roughMatchTcs )
+import Name
+import Var
+import Class
+import TcGadt
+import TcType
+import InstEnv
import VarSet
import VarEnv
import Outputable
-import Util ( notNull )
-import List ( tails )
-import Maybe ( isJust )
-import ListSetOps ( equivClassesByUniq )
+import Util
+import Data.Maybe ( isJust )
\end{code}
%* *
%************************************************************************
+ oclose(vs,C) The result of extending 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.
+
+ 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
+ oclose is conservative v `elem` oclose(vs,C)
+ one way: => v is definitely fixed by vs
+
+ grow is conservative if v might be fixed by vs
+ the other way: => v `elem` grow(vs,C)
+
+----------------------------------------------------------
(oclose preds tvs) closes the set of type variables tvs,
wrt functional dependencies in preds. The result is a superset
of the argument set. For example, if we have
oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}
because if we know x and y then that fixes z.
-Using oclose
-~~~~~~~~~~~~
-oclose is used
-
-a) When determining ambiguity. The type
- forall a,b. C a b => a
-is not ambiguous (given the above class decl for C) because
-a determines b.
-
-b) When generalising a type T. Usually we take FV(T) \ FV(Env),
-but in fact we need
- FV(T) \ (FV(Env)+)
-where the '+' is the oclosure operation. Notice that we do not
-take FV(T)+. This puzzled me for a bit. Consider
-
- f = E
-
-and suppose e have that E :: C a b => a, and suppose that b is
-free in the environment. Then we quantify over 'a' only, giving
-the type forall a. C a b => a. Since a->b but we don't have b->a,
-we might have instance decls like
- instance C Bool Int where ...
- instance C Char Int where ...
-so knowing that b=Int doesn't fix 'a'; so we quantify over it.
-
- ---------------
- A WORRY: ToDo!
- ---------------
-If we have class C a b => D a b where ....
- class D a b | a -> b where ...
-and the preds are [C (x,y) z], then we want to see the fd in D,
-even though it is not explicit in C, giving [({x,y},{z})]
-
-Similarly for instance decls? E.g. Suppose we have
- instance C a b => Eq (T a b) where ...
-and we infer a type t with constraints Eq (T a b) for a particular
-expression, and suppose that 'a' is free in the environment.
-We could generalise to
- forall b. Eq (T a b) => t
-but if we reduced the constraint, to C a b, we'd see that 'a' determines
-b, so that a better type might be
- t (with free constraint C a b)
-Perhaps it doesn't matter, because we'll still force b to be a
-particular type at the call sites. Generalising over too many
-variables (provided we don't shadow anything by quantifying over a
-variable that is actually free in the envt) may postpone errors; it
-won't hide them altogether.
-
+oclose is used (only) when generalising a type T; see extensive
+notes in TcSimplify.
+
+Note [Important subtlety in oclose]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (oclose (C Int t) {}), where class C a b | a->b
+Then, since a->b, 't' is fully determined by Int, and the
+uniform thing is to return {t}.
+
+However, consider
+ class D a b c | b->c
+ f x = e -- 'e' generates constraint (D s Int t)
+ -- \x.e has type s->s
+Then, if (oclose (D s Int t) {}) = {t}, we'll make the function
+monomorphic in 't', thus
+ f :: forall s. D s Int t => s -> s
+
+But if this function is never called, 't' will never be instantiated;
+the functional dependencies that fix 't' may well be instance decls in
+some importing module. But the top-level defaulting of unconstrained
+type variables will fix t=GHC.Prim.Any, and that's simply a bug.
+
+Conclusion: oclose only returns a type variable as "fixed" if it
+depends on at least one type variable in the input fixed_tvs.
+
+Remember, it's always sound for oclose to return a smaller set.
+An interesting example is tcfail093, where we get this inferred type:
+ class C a b | a->b
+ dup :: forall h. (Call (IO Int) h) => () -> Int -> h
+This is perhaps a bit silly, because 'h' is fixed by the (IO Int);
+previously GHC rejected this saying 'no instance for Call (IO Int) h'.
+But it's right on the borderline. If there was an extra, otherwise
+uninvolved type variable, like 's' in the type of 'f' above, then
+we must accept the function. So, for now anyway, we accept 'dup' too.
\begin{code}
oclose :: [PredType] -> TyVarSet -> TyVarSet
oclose preds fixed_tvs
- | null tv_fds = fixed_tvs -- Fast escape hatch for common case
- | otherwise = loop fixed_tvs
+ | null tv_fds = fixed_tvs -- Fast escape hatch for common case
+ | isEmptyVarSet fixed_tvs = emptyVarSet -- Note [Important subtlety in oclose]
+ | otherwise = loop fixed_tvs
where
loop fixed_tvs
| new_fixed_tvs `subVarSet` fixed_tvs = fixed_tvs
where
new_fixed_tvs = foldl extend fixed_tvs tv_fds
- extend fixed_tvs (ls,rs) | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` rs
- | otherwise = fixed_tvs
+ extend fixed_tvs (ls,rs)
+ | not (isEmptyVarSet ls) -- Note [Important subtlety in oclose]
+ , ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` rs
+ | otherwise = fixed_tvs
tv_fds :: [(TyVarSet,TyVarSet)]
-- In our example, tv_fds will be [ ({x,y}, {z}), ({x,p},{q}) ]
]
\end{code}
+Note [Growing the tau-tvs using constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(grow preds tvs) is the result of extend the set of tyvars tvs
+ using all conceivable links from pred
+
+E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}
+Then grow precs tvs = {a,b,c}
+
+All the type variables from an implicit parameter are added, whether or
+not they are mentioned in tvs; see Note [Implicit parameters and ambiguity]
+in TcSimplify.
+
+See also Note [Ambiguity] in TcSimplify
+
\begin{code}
grow :: [PredType] -> TyVarSet -> TyVarSet
--- See Note [Ambiguity] in TcSimplify
grow preds fixed_tvs
- | null preds = fixed_tvs
- | otherwise = loop fixed_tvs
+ | null preds = real_fixed_tvs
+ | otherwise = loop real_fixed_tvs
where
+ -- Add the implicit parameters;
+ -- see Note [Implicit parameters and ambiguity] in TcSimplify
+ real_fixed_tvs = foldr unionVarSet fixed_tvs ip_tvs
+
loop fixed_tvs
| new_fixed_tvs `subVarSet` fixed_tvs = fixed_tvs
| otherwise = loop new_fixed_tvs
where
- new_fixed_tvs = foldl extend fixed_tvs pred_sets
+ new_fixed_tvs = foldl extend fixed_tvs non_ip_tvs
extend fixed_tvs pred_tvs
| fixed_tvs `intersectsVarSet` pred_tvs = fixed_tvs `unionVarSet` pred_tvs
| otherwise = fixed_tvs
- pred_sets = [tyVarsOfPred pred | pred <- preds]
+ (ip_tvs, non_ip_tvs) = partitionWith get_ip preds
+ get_ip (IParam _ ty) = Left (tyVarsOfType ty)
+ get_ip other = Right (tyVarsOfPred other)
\end{code}
%************************************************************************
\begin{code}
-----------
type Equation = (TyVarSet, [(Type, Type)])
-- These pairs of types should be equal, for some
-- substitution of the tyvars in the tyvar set
pprEquation (qtvs, pairs)
= vcat [ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)),
nest 2 (vcat [ ppr t1 <+> ptext SLIT(":=:") <+> ppr t2 | (t1,t2) <- pairs])]
-
-----------
-type Pred_Loc = (PredType, SDoc) -- SDoc says where the Pred comes from
-
-improve :: (Class -> [Instance]) -- Gives instances for given class
- -> [Pred_Loc] -- Current constraints;
- -> [(Equation,Pred_Loc,Pred_Loc)] -- Derived equalities that must also hold
- -- (NB the above INVARIANT for type Equation)
- -- The Pred_Locs explain which two predicates were
- -- combined (for error messages)
\end{code}
Given a bunch of predicates that must hold, such as
\begin{code}
-improve inst_env preds
- = [ eqn | group <- equivClassesByUniq (predTyUnique . fst) preds,
- eqn <- checkGroup inst_env group ]
-
-----------
-checkGroup :: (Class -> [Instance])
- -> [Pred_Loc]
- -> [(Equation, Pred_Loc, Pred_Loc)]
- -- The preds are all for the same class or implicit param
-
-checkGroup inst_env (p1@(IParam _ ty, _) : ips)
- = -- For implicit parameters, all the types must match
- [ ((emptyVarSet, [(ty,ty')]), p1, p2)
- | p2@(IParam _ ty', _) <- ips, not (ty `tcEqType` ty')]
-
-checkGroup inst_env clss@((ClassP cls _, _) : _)
- = -- For classes life is more complicated
- -- Suppose the class is like
- -- classs C as | (l1 -> r1), (l2 -> r2), ... where ...
- -- Then FOR EACH PAIR (ClassP c tys1, ClassP c tys2) in the list clss
- -- we check whether
- -- U l1[tys1/as] = U l2[tys2/as]
- -- (where U is a unifier)
- --
- -- If so, we return the pair
- -- U r1[tys1/as] = U l2[tys2/as]
- --
- -- We need to do something very similar comparing each predicate
- -- with relevant instance decls
-
- instance_eqns ++ pairwise_eqns
+type Pred_Loc = (PredType, SDoc) -- SDoc says where the Pred comes from
+
+improveOne :: (Class -> [Instance]) -- Gives instances for given class
+ -> Pred_Loc -- Do improvement triggered by this
+ -> [Pred_Loc] -- Current constraints
+ -> [(Equation,Pred_Loc,Pred_Loc)] -- Derived equalities that must also hold
+ -- (NB the above INVARIANT for type Equation)
+ -- The Pred_Locs explain which two predicates were
+ -- combined (for error messages)
+-- Just do improvement triggered by a single, distinguised predicate
+
+improveOne inst_env pred@(IParam ip ty, _) preds
+ = [ ((emptyVarSet, [(ty,ty2)]), pred, p2)
+ | p2@(IParam ip2 ty2, _) <- preds
+ , ip==ip2
+ , not (ty `tcEqType` ty2)]
+
+improveOne inst_env pred@(ClassP cls tys, _) preds
+ | tys `lengthAtLeast` 2
+ = instance_eqns ++ pairwise_eqns
-- NB: we put the instance equations first. This biases the
-- order so that we first improve individual constraints against the
-- instances (which are perhaps in a library and less likely to be
-- wrong; and THEN perform the pairwise checks.
-- The other way round, it's possible for the pairwise check to succeed
-- and cause a subsequent, misleading failure of one of the pair with an
- -- instance declaration. See tcfail143.hs for an exmample
-
+ -- instance declaration. See tcfail143.hs for an example
where
(cls_tvs, cls_fds) = classTvsFds cls
instances = inst_env cls
+ rough_tcs = roughMatchTcs tys
-- NOTE that we iterate over the fds first; they are typically
-- empty, which aborts the rest of the loop.
pairwise_eqns :: [(Equation,Pred_Loc,Pred_Loc)]
pairwise_eqns -- This group comes from pairwise comparison
- = [ (eqn, p1, p2)
- | fd <- cls_fds,
- p1@(ClassP _ tys1, _) : rest <- tails clss,
- p2@(ClassP _ tys2, _) <- rest,
- eqn <- checkClsFD emptyVarSet fd cls_tvs tys1 tys2
+ = [ (eqn, pred, p2)
+ | fd <- cls_fds
+ , p2@(ClassP cls2 tys2, _) <- preds
+ , cls == cls2
+ , eqn <- checkClsFD emptyVarSet fd cls_tvs tys tys2
]
instance_eqns :: [(Equation,Pred_Loc,Pred_Loc)]
instance_eqns -- This group comes from comparing with instance decls
- = [ (eqn, p1, p2)
- | fd <- cls_fds, -- Iterate through the fundeps first,
+ = [ (eqn, p_inst, pred)
+ | fd <- cls_fds -- Iterate through the fundeps first,
-- because there often are none!
- p2@(ClassP _ tys2, _) <- clss,
- let rough_tcs2 = trimRoughMatchTcs cls_tvs fd (roughMatchTcs tys2),
- ispec@(Instance { is_tvs = qtvs, is_tys = tys1,
- is_tcs = mb_tcs1 }) <- instances,
- not (instanceCantMatch mb_tcs1 rough_tcs2),
- eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2,
- let p1 = (mkClassPred cls tys1,
- ptext SLIT("arising from the instance declaration at") <+>
- ppr (getSrcLoc ispec))
+ , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs
+ -- Trim the rough_tcs based on the head of the fundep.
+ -- Remember that instanceCantMatch treats both argumnents
+ -- symmetrically, so it's ok to trim the rough_tcs,
+ -- rather than trimming each inst_tcs in turn
+ , ispec@(Instance { is_tvs = qtvs, is_tys = tys_inst,
+ is_tcs = inst_tcs }) <- instances
+ , not (instanceCantMatch inst_tcs trimmed_tcs)
+ , eqn <- checkClsFD qtvs fd cls_tvs tys_inst tys
+ , let p_inst = (mkClassPred cls tys_inst,
+ ptext SLIT("arising from the instance declaration at")
+ <+> ppr (getSrcLoc ispec))
]
-----------
+
+improveOne inst_env eq_pred preds
+ = []
+
+
checkClsFD :: TyVarSet -- Quantified type variables; see note below
-> FunDep TyVar -> [TyVar] -- One functional dependency from the class
-> [Type] -> [Type]
badFunDeps cls_insts clas ins_tv_set ins_tys
= [ ispec | fd <- fds, -- fds is often empty
let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs,
- ispec@(Instance { is_tcs = mb_tcs, is_tvs = tvs,
+ ispec@(Instance { is_tcs = inst_tcs, is_tvs = tvs,
is_tys = tys }) <- cls_insts,
-- Filter out ones that can't possibly match,
-- based on the head of the fundep
- not (instanceCantMatch trimmed_tcs mb_tcs),
+ not (instanceCantMatch inst_tcs trimmed_tcs),
notNull (checkClsFD (tvs `unionVarSet` ins_tv_set)
fd clas_tvs tys ins_tys)
]
trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
-- Computing rough_tcs for a particular fundep
--- class C a b c | a c -> b where ...
+-- class C a b c | a -> b where ...
-- For each instance .... => C ta tb tc
--- we want to match only on the types ta, tb; so our
+-- we want to match only on the types ta, tc; so our
-- rough-match thing must similarly be filtered.
-- Hence, we Nothing-ise the tb type right here
-trimRoughMatchTcs clas_tvs (ltvs,_) mb_tcs
+trimRoughMatchTcs clas_tvs (_,rtvs) mb_tcs
= zipWith select clas_tvs mb_tcs
where
- select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc
- | otherwise = Nothing
+ select clas_tv mb_tc | clas_tv `elem` rtvs = Nothing
+ | otherwise = mb_tc
\end{code}
-%************************************************************************
-%* *
-\subsection{Miscellaneous}
-%* *
-%************************************************************************
-
-\begin{code}
-pprFundeps :: Outputable a => [FunDep a] -> SDoc
-pprFundeps [] = empty
-pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
-
-ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs]
-\end{code}
projects / ghc-hetmet.git / blobdiff