From: simonpj Date: Fri, 2 Apr 2004 13:16:09 +0000 (+0000) Subject: [project @ 2004-04-02 13:16:07 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~1925 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2a0ee8e52378ff3d9b90afdeae24df376e299a1c;p=ghc-hetmet.git [project @ 2004-04-02 13:16:07 by simonpj] * Improve error message for overlapping instances * Improve handling of type-variable-only constraints like (Foo a). Previously we never looked them up in the instance envt, *except* if -fallow-undecideable-instances was on, because that allows instance (...) => Foo a But -fallow-undecideable-instances might be on in the module with the instance decl, but off in the importing module. Also it's really a per-class thing. So now we just record in the instance env whether there are any such strange instances, a kind of short-cut for the lookup. * Arrange that we are a bit more eager about resolving overloading in the case of existential pattern matching [George Russel suggestion] Here's the example (see comments in InstEnv) -- The key_tys can contain skolem constants, and we can guarantee that those -- are never going to be instantiated to anything, so we should not involve -- them in the unification test. Example: -- class Foo a where { op :: a -> Int } -- instance Foo a => Foo [a] -- NB overlap -- instance Foo [Int] -- NB overlap -- data T = forall a. Foo a => MkT a -- f :: T -> Int -- f (MkT x) = op [x,x] -- The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd -- complain, saying that the choice of instance depended on the instantiation -- of 'a'; but of course it isn't *going* to be instantiated. --- diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 5e82933..f296e1b 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -695,28 +695,17 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) -- Dictionaries lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) - = do { dflags <- getDOpts - ; if all tcIsTyVarTy tys && - not (dopt Opt_AllowUndecidableInstances dflags) - -- Common special case; no lookup - -- NB: tcIsTyVarTy... don't look through newtypes! - -- Don't take this short cut if we allow undecidable instances - -- because we might have "instance T a where ...". - -- [That means we need -fallow-undecidable-instances in the - -- client module, as well as the module with the instance decl.] - then return NoInstance - - else do - { pkg_ie <- loadImportedInsts clas tys + = do { pkg_ie <- loadImportedInsts clas tys -- Suck in any instance decls that may be relevant ; tcg_env <- getGblEnv + ; dflags <- getDOpts ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of { ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ; (matches, unifs) -> do { traceTc (text "lookupInst fail" <+> vcat [text "dict" <+> ppr pred, text "matches" <+> ppr matches, text "unifs" <+> ppr unifs]) - ; return NoInstance } } } } + ; return NoInstance } } } -- In the case of overlap (multiple matches) we report -- NoInstance here. That has the effect of making the -- context-simplifier return the dict as an irreducible one. diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index a3e9352..350e2af 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -39,7 +39,7 @@ import Inst ( lookupInst, LookupInstResult(..), isIPDict, isInheritableInst, pprDFuns, pprDictsTheta ) import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals ) -import InstEnv ( lookupInstEnv, classInstEnv ) +import InstEnv ( lookupInstEnv, classInstances ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv), mkClassPred, isOverloadedTy, mkTyConApp, @@ -1473,7 +1473,7 @@ tcImprove avails -- NB that (?x::t1) and (?x::t2) will be held separately in avails -- so that improve will see them separate eqns = improve get_insts preds - get_insts clas = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas + get_insts clas = classInstances home_ie clas ++ classInstances pkg_ie clas in if null eqns then returnM True @@ -2180,18 +2180,18 @@ addNoInstanceErrs mb_what givens dicts | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts) | otherwise = case lookupInstEnv dflags inst_envs clas tys of - res@(ms, _) - | length ms > 1 -> (mk_overlap_msg dict res $$ overlap_doc, no_inst_dicts) - | otherwise -> (overlap_doc, dict : no_inst_dicts) -- No match - -- NB: there can be exactly one match, in the case where we have - -- instance C a where ... - -- (In this case, lookupInst doesn't bother to look up, - -- unless -fallow-undecidable-instances is set.) - -- So we report this as "no instance" rather than "overlap"; the fix is - -- to specify -fallow-undecidable-instances, but we leave that to the programmer! + -- The case of exactly one match and no unifiers means + -- a successful lookup. That can't happen here. +#ifdef DEBUG + ([m],[]) -> pprPanic "addNoInstanceErrs" (ppr dict) +#endif + ([], _) -> (overlap_doc, dict : no_inst_dicts) -- No match + res -> (mk_overlap_msg dict res $$ overlap_doc, no_inst_dicts) where (clas,tys) = getDictClassTys dict in + + -- Now generate a good message for the no-instance bunch mk_probable_fix tidy_env2 mb_what no_inst_dicts `thenM` \ (tidy_env3, probable_fix) -> let no_inst_doc | null no_inst_dicts = empty @@ -2201,18 +2201,23 @@ addNoInstanceErrs mb_what givens dicts | otherwise = sep [ptext SLIT("Could not deduce") <+> pprDictsTheta no_inst_dicts, nest 2 $ ptext SLIT("from the context") <+> pprDictsTheta tidy_givens] in + -- And emit both the non-instance and overlap messages addErrTcM (tidy_env3, no_inst_doc $$ overlap_doc) - where mk_overlap_msg dict (matches, unifiers) = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") <+> pprPred (dictPred dict))), sep [ptext SLIT("Matching instances") <> colon, nest 2 (pprDFuns (dfuns ++ unifiers))], - if null unifiers - then empty - else parens (ptext SLIT("The choice depends on the instantiation of") <+> - quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))))] + ASSERT( not (null matches) ) + if not (isSingleton matches) + then -- Two or more matches + empty + else -- One match, plus some unifiers + ASSERT( not (null unifiers) ) + parens (vcat [ptext SLIT("The choice depends on the instantiation of") <+> + quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))), + ptext SLIT("Use -fallow-incoherent-instances to use the first choice above")])] where dfuns = [df | (_, (_,_,df)) <- matches] diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index 905cde2..7b6e93a 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -11,23 +11,23 @@ module InstEnv ( emptyInstEnv, extendInstEnv, lookupInstEnv, - classInstEnv, simpleDFunClassTyCon, checkFunDeps + classInstances, simpleDFunClassTyCon, checkFunDeps ) where #include "HsVersions.h" import Class ( Class, classTvsFds ) -import Var ( Id ) +import Var ( Id, isTcTyVar ) import VarSet import VarEnv -import TcType ( Type, tcTyConAppTyCon, - tcSplitDFunTy, tyVarsOfTypes, +import TcType ( Type, tcTyConAppTyCon, tcIsTyVarTy, + tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar, matchTys, unifyTyListsX ) import FunDeps ( checkClsFD ) import TyCon ( TyCon ) import Outputable -import UniqFM ( UniqFM, lookupWithDefaultUFM, emptyUFM, addToUFM_C ) +import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C ) import Id ( idType ) import CmdLineOpts import Util ( notNull ) @@ -44,31 +44,42 @@ import Maybe ( isJust ) \begin{code} type DFunId = Id type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class -type ClsInstEnv = [InstEnvElt] -- The instances for a particular class + +data ClsInstEnv + = ClsIE [InstEnvElt] -- The instances for a particular class, in any order + Bool -- True <=> there is an instance of form C a b c + -- If *not* then the common case of looking up + -- (C a b c) can fail immediately + -- NB: use tcIsTyVarTy: don't look through newtypes!! + type InstEnvElt = (TyVarSet, [Type], DFunId) -- INVARIANTs: see notes below emptyInstEnv :: InstEnv emptyInstEnv = emptyUFM -classInstEnv :: InstEnv -> Class -> ClsInstEnv -classInstEnv env cls = lookupWithDefaultUFM env [] cls +classInstances :: InstEnv -> Class -> [InstEnvElt] +classInstances env cls = case lookupUFM env cls of + Just (ClsIE insts _) -> insts + Nothing -> [] extendInstEnv :: InstEnv -> DFunId -> InstEnv extendInstEnv inst_env dfun_id - = addToUFM_C add inst_env clas [ins_item] + = addToUFM_C add inst_env clas (ClsIE [ins_item] ins_tyvar) where - add old _ = ins_item : old + add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts) + (ins_tyvar || cur_tyvar) (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) ins_tv_set = mkVarSet ins_tvs ins_item = (ins_tv_set, ins_tys, dfun_id) + ins_tyvar = all tcIsTyVarTy ins_tys #ifdef UNUSED pprInstEnv :: InstEnv -> SDoc pprInstEnv env = vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+> brackets (pprWithCommas ppr tys) <+> ppr dfun - | cls_inst_env <- eltsUFM env + | ClsIE cls_inst_env _ <- eltsUFM env , (tyvars, tys, dfun) <- cls_inst_env ] #endif @@ -271,10 +282,11 @@ lookupInstEnv dflags (pkg_ie, home_ie) cls tys -- so don't attempt to pune the matches | otherwise = (pruned_matches, []) where + all_tvs = all tcIsTyVarTy tys incoherent_ok = dopt Opt_AllowIncoherentInstances dflags overlap_ok = dopt Opt_AllowOverlappingInstances dflags - (home_matches, home_unifs) = lookup_inst_env home_ie cls tys - (pkg_matches, pkg_unifs) = lookup_inst_env pkg_ie cls tys + (home_matches, home_unifs) = lookup_inst_env home_ie cls tys all_tvs + (pkg_matches, pkg_unifs) = lookup_inst_env pkg_ie cls tys all_tvs all_matches = home_matches ++ pkg_matches all_unifs | incoherent_ok = [] -- Don't worry about these if incoherent is ok! | otherwise = home_unifs ++ pkg_unifs @@ -284,12 +296,32 @@ lookupInstEnv dflags (pkg_ie, home_ie) cls tys lookup_inst_env :: InstEnv -- The envt -> Class -> [Type] -- What we are looking for + -> Bool -- All the [Type] are tyvars -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches [Id]) -- These don't match but do unify -lookup_inst_env env key_cls key_tys - = find (classInstEnv env key_cls) [] [] +lookup_inst_env env key_cls key_tys key_all_tvs + = case lookupUFM env key_cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts has_tv_insts) + | key_all_tvs && not has_tv_insts -> ([],[]) -- Short cut for common case + -- The thing we are looking up is of form (C a b c), and + -- the ClsIE has no instances of that form, so don't bother to search + | otherwise -> find insts [] [] where - key_vars = tyVarsOfTypes key_tys + key_vars = filterVarSet not_existential (tyVarsOfTypes key_tys) + not_existential tv = not (isTcTyVar tv && isExistentialTyVar tv) + -- The key_tys can contain skolem constants, and we can guarantee that those + -- are never going to be instantiated to anything, so we should not involve + -- them in the unification test. Example: + -- class Foo a where { op :: a -> Int } + -- instance Foo a => Foo [a] -- NB overlap + -- instance Foo [Int] -- NB overlap + -- data T = forall a. Foo a => MkT a + -- f :: T -> Int + -- f (MkT x) = op [x,x] + -- The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd + -- complain, saying that the choice of instance depended on the instantiation + -- of 'a'; but of course it isn't *going* to be instantiated. find [] ms us = (ms, us) find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us @@ -372,10 +404,10 @@ checkFunDeps (pkg_ie, home_ie) dfun where (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun) ins_tv_set = mkVarSet ins_tvs - cls_inst_env = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas + cls_inst_env = classInstances home_ie clas ++ classInstances pkg_ie clas bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys -badFunDeps :: ClsInstEnv -> Class +badFunDeps :: [InstEnvElt] -> Class -> TyVarSet -> [Type] -- Proposed new instance type -> [DFunId] badFunDeps cls_inst_env clas ins_tv_set ins_tys