From 2c8701fbebc0a6a49248392b53d977f0afdea4ec Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 9 May 2007 11:25:30 +0000 Subject: [PATCH] Tidy up the interface to lookupInstEnv This patch changes the interface to lookupInstEnv, so that it returns a pair (Instance, [Either TyVar Type]) rather than (Inst, TvSubst) There is no functionality change, but the interface is tidier, and closer to lookupFamInstEnv (when Manuel has changed that too). The [Either TyVar Type] gives the type(s) at which the dfun should be instantiated. We need an Either because it might be instantiated freely: see Note [InstTypes: instantiating types] in InstEnv. (This might be a pattern we want to use elsewhere too.) --- compiler/typecheck/Inst.lhs | 41 ++++++++--------------- compiler/typecheck/TcSimplify.lhs | 2 +- compiler/types/InstEnv.lhs | 66 +++++++++++++++++++++++++++---------- compiler/utils/Outputable.lhs | 4 +++ 4 files changed, 66 insertions(+), 47 deletions(-) diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 377c082..a6d92a9 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -26,7 +26,7 @@ module Inst ( ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, getDictClassTys, dictPred, - lookupSimpleInst, LookupInstResult(..), lookupPred, + lookupSimpleInst, LookupInstResult(..), tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, isDict, isClassDict, isMethod, isImplicInst, @@ -623,7 +623,7 @@ addLocalInst home_ie ispec -- Check for duplicate instance decls ; let { (matches, _) = lookupInstEnv inst_envs cls tys' ; dup_ispecs = [ dup_ispec - | (_, dup_ispec) <- matches + | (dup_ispec, _) <- matches , let (_,_,_,dup_tys) = instanceHead dup_ispec , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] } -- Find memebers of the match list which ispec itself matches. @@ -745,19 +745,8 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) = do { mb_result <- lookupPred pred ; case mb_result of { Nothing -> return NoInstance ; - Just (tenv, dfun_id) -> do - - -- tenv is a substitution that instantiates the dfun_id - -- to match the requested result type. - -- - -- We ASSUME that the dfun is quantified over the very same tyvars - -- that are bound by the tenv. - -- - -- However, the dfun - -- might have some tyvars that *only* appear in arguments - -- dfun :: forall a b. C a b, Ord b => D [a] - -- We instantiate b to a flexi type variable -- it'll presumably - -- become fixed later via functional dependencies + Just (dfun_id, mb_inst_tys) -> do + { use_stage <- getStage ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) (topIdLvl dfun_id) use_stage @@ -766,19 +755,15 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) -- the substitution, tenv. For example: -- instance C X a => D X where ... -- (presumably there's a functional dependency in class C) - -- Hence the open_tvs to instantiate any un-substituted tyvars. - ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id) - open_tvs = filter (`notElemTvSubst` tenv) tyvars - ; open_tvs' <- mappM tcInstTyVar open_tvs + -- Hence mb_inst_tys :: Either TyVar TcType + + ; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') } + inst_tv (Right ty) = return ty + ; tys <- mappM inst_tv mb_inst_tys ; let - tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs') - -- Since the open_tvs' are freshly made, they cannot possibly be captured by - -- any nested for-alls in rho. So the in-scope set is unchanged - dfun_rho = substTy tenv' rho - (theta, _) = tcSplitPhiTy dfun_rho + (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys) src_loc = instLocSpan loc dfun = HsVar dfun_id - tys = substTyVars tenv' tyvars ; if null theta then returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) else do @@ -788,14 +773,14 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) }}}} --------------- -lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId)) +lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType])) -- Look up a class constraint in the instance environment lookupPred pred@(ClassP clas tys) = do { eps <- getEps ; tcg_env <- getGblEnv ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env) ; case lookupInstEnv inst_envs clas tys of { - ([(tenv, ispec)], []) + ([(ispec, inst_tys)], []) -> do { let dfun_id = is_dfun ispec ; traceTc (text "lookupInst success" <+> vcat [text "dict" <+> ppr pred, @@ -803,7 +788,7 @@ lookupPred pred@(ClassP clas tys) <+> ppr (idType dfun_id) ]) -- Record that this dfun is needed ; record_dfun_usage dfun_id - ; return (Just (tenv, dfun_id)) } ; + ; return (Just (dfun_id, inst_tys)) } ; (matches, unifs) -> do { traceTc (text "lookupInst fail" <+> diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 1f690bc..7deb852 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -2577,7 +2577,7 @@ report_no_instances tidy_env mb_what insts quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))), ptext SLIT("Use -fallow-incoherent-instances to use the first choice above")])] where - ispecs = [ispec | (_, ispec) <- matches] + ispecs = [ispec | (ispec, _) <- matches] mk_no_inst_err insts | null insts = empty diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 9cb68c8..cc0c2dd 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -385,20 +385,41 @@ the env is kept ordered, the first match must be the only one. The thing we are looking up can have an arbitrary "flexi" part. \begin{code} -lookupInstEnv :: (InstEnv -- External package inst-env - ,InstEnv) -- Home-package inst-env - -> Class -> [Type] -- What we are looking for - -> ([(TvSubst, Instance)], -- Successful matches - [Instance]) -- These don't match but do unify - -- The second component of the tuple happens when we look up - -- Foo [a] - -- in an InstEnv that has entries for - -- Foo [Int] - -- Foo [b] - -- Then which we choose would depend on the way in which 'a' - -- is instantiated. So we report that Foo [b] is a match (mapping b->a) - -- but Foo [Int] is a unifier. This gives the caller a better chance of - -- giving a suitable error messagen +type InstTypes = [Either TyVar Type] + -- Right ty => Instantiate with this type + -- Left tv => Instantiate with any type of this tyvar's kind + +type InstMatch = (Instance, InstTypes) +\end{code} + +Note [InstTypes: instantiating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A successful match is an Instance, together with the types at which + the dfun_id in the Instance should be instantiated +The instantiating types are (Mabye Type)s because the dfun +might have some tyvars that *only* appear in arguments + dfun :: forall a b. C a b, Ord b => D [a] +When we match this against D [ty], we return the instantiating types + [Right ty, Left b] +where the Nothing indicates that 'b' can be freely instantiated. +(The caller instantiates it to a flexi type variable, which will presumably + presumably later become fixed via functional dependencies.) + +\begin{code} +lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [Instance]) -- These don't match but do unify + +-- The second component of the result pair happens when we look up +-- Foo [a] +-- in an InstEnv that has entries for +-- Foo [Int] +-- Foo [b] +-- Then which we choose would depend on the way in which 'a' +-- is instantiated. So we report that Foo [b] is a match (mapping b->a) +-- but Foo [Int] is a unifier. This gives the caller a better chance of +-- giving a suitable error messagen lookupInstEnv (pkg_ie, home_ie) cls tys = (pruned_matches, all_unifs) @@ -427,6 +448,12 @@ lookupInstEnv (pkg_ie, home_ie) cls tys -> find [] [] insts -------------- + lookup_tv :: TvSubst -> TyVar -> Either TyVar Type + -- See Note [InstTypes: instantiating types] + lookup_tv subst tv = case lookupTyVar subst tv of + Just ty -> Right ty + Nothing -> Left tv + find ms us [] = (ms, us) find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, is_tys = tpl_tys, is_flag = oflag, @@ -436,7 +463,11 @@ lookupInstEnv (pkg_ie, home_ie) cls tys = find ms us rest | Just subst <- tcMatchTys tpl_tvs tpl_tys tys - = find ((subst,item):ms) us rest + = let + (dfun_tvs, _) = tcSplitForAllTys (idType dfun) + in + ASSERT( all (`elemVarSet` tpl_tvs) dfun_tvs ) -- Check invariant + find ((item, map (lookup_tv subst) dfun_tvs) : ms) us rest -- Does not match, so next check whether the things unify -- See Note [overlapping instances] above @@ -476,8 +507,7 @@ bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem -- on the grounds that the correct instance depends on the instantiation of 'a' --------------- -insert_overlapping :: (TvSubst, Instance) -> [(TvSubst, Instance)] - -> [(TvSubst, Instance)] +insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] -- Add a new solution, knocking out strictly less specific ones insert_overlapping new_item [] = [new_item] insert_overlapping new_item (item:items) @@ -493,7 +523,7 @@ insert_overlapping new_item (item:items) new_beats_old = new_item `beats` item old_beats_new = item `beats` new_item - (_, instA) `beats` (_, instB) + (instA, _) `beats` (instB, _) = overlap_ok && isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA)) -- A beats B if A is more specific than B, and B admits overlap diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 4f8d320..6d9132e 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -409,6 +409,10 @@ instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext SLIT("Nothing") ppr (Just x) = ptext SLIT("Just") <+> ppr x +instance (Outputable a, Outputable b) => Outputable (Either a b) where + ppr (Left x) = ptext SLIT("Left") <+> ppr x + ppr (Right y) = ptext SLIT("Right") <+> ppr y + -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where ppr (x,y,z) = -- 1.7.10.4