%
+% (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}
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}
]
\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 rough_fd_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs
+ , ispec@(Instance { is_tvs = qtvs, is_tys = tys_inst,
+ is_tcs = mb_tcs_inst }) <- instances
+ , not (instanceCantMatch mb_tcs_inst rough_fd_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]
\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