X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FInstEnv.lhs;h=44f2db313d4b5c47918ddfffc8271ff2717bf6e0;hb=98744cef7b82e7eefbb1c6f1d8b9e28c415939c4;hp=d0fc445d7fb6628bdb2b38bff18fd903843dfe50;hpb=5f3528244ad3ec004bb67a8a2ec086fe90318ce7;p=ghc-hetmet.git diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index d0fc445..44f2db3 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -1,37 +1,122 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section{Class Instance environments} +\section[InstEnv]{Utilities for typechecking instance declarations} + +The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - InstEnv, emptyInstEnv, addToInstEnv, - lookupInstEnv, InstEnvResult(..) + DFunId, InstEnv, + + emptyInstEnv, extendInstEnv, + lookupInstEnv, + classInstEnv, simpleDFunClassTyCon, checkFunDeps ) where #include "HsVersions.h" -import Var ( TyVar, Id ) +import Class ( Class, classTvsFds ) +import Var ( Id ) import VarSet -import VarEnv ( TyVarSubstEnv ) -import Type ( Type, tyVarsOfTypes ) -import Unify ( unifyTyListsX, matchTys ) +import VarEnv +import TcType ( Type, tcTyConAppTyCon, + tcSplitDFunTy, tyVarsOfTypes, + matchTys, unifyTyListsX + ) +import FunDeps ( checkClsFD ) +import TyCon ( TyCon ) import Outputable -import Maybes +import UniqFM ( UniqFM, lookupWithDefaultUFM, emptyUFM, eltsUFM, addToUFM_C ) +import Id ( idType ) +import CmdLineOpts +import Util ( notNull ) +import Maybe ( isJust ) \end{code} %************************************************************************ %* * -\section{InstEnv} +\subsection{The key types} %* * %************************************************************************ \begin{code} -type InstEnv = [(TyVarSet, [Type], Id)] -\end{code} +type DFunId = Id +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class +type ClsInstEnv = [InstEnvElt] -- The instances for a particular class +type InstEnvElt = (TyVarSet, [Type], DFunId) + -- INVARIANTs: see notes below + +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUFM + +classInstEnv :: InstEnv -> Class -> ClsInstEnv +classInstEnv env cls = lookupWithDefaultUFM env [] cls + +extendInstEnv :: InstEnv -> DFunId -> InstEnv +extendInstEnv inst_env dfun_id + = addToUFM_C add inst_env clas [ins_item] + where + add old _ = ins_item : old + (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) + ins_tv_set = mkVarSet ins_tvs + ins_item = (ins_tv_set, ins_tys, dfun_id) + +#ifdef UNUSED +pprInstEnv :: InstEnv -> SDoc +pprInstEnv env + = vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+> + brackets (pprWithCommas ppr tys) <+> ppr dfun + | cls_inst_env <- eltsUFM env + , (tyvars, tys, dfun) <- cls_inst_env + ] +#endif + +simpleDFunClassTyCon :: DFunId -> (Class, TyCon) +simpleDFunClassTyCon dfun + = (clas, tycon) + where + (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun) + tycon = tcTyConAppTyCon ty +\end{code} -In some InstEnvs overlap is prohibited; that is, no pair of templates unify. +%************************************************************************ +%* * +\subsection{Instance environments: InstEnv and ClsInstEnv} +%* * +%************************************************************************ + +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun + +There is an important consistency constraint in the elements of a ClsInstEnv: + + * [a,b] must be a superset of the free vars of [t1,t2,t3] + + * The dfun must itself be quantified over [a,b] + + * More specific instances come before less specific ones, + where they overlap + +Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: + [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +The "a" in the pattern must be one of the forall'd variables in +the dfun type. + + + +Notes on overlapping instances +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify. In others, overlap is permitted, but only in such a way that one can make a unique choice when looking up. That is, overlap is only permitted if @@ -141,103 +226,160 @@ exists. --Jeff -\begin{code} -emptyInstEnv :: InstEnv -emptyInstEnv = [] +BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in +this test. Suppose the instance envt had + ..., forall a b. C a a b, ..., forall a b c. C a b c, ... +(still most specific first) +Now suppose we are looking for (C x y Int), where x and y are unconstrained. + C x y Int doesn't match the template {a,b} C a a b +but neither does + C a a b match the template {x,y} C x y Int +But still x and y might subsequently be unified so they *do* match. -isEmptyInstEnv env = null env -\end{code} +Simple story: unify, don't match. + + +%************************************************************************ +%* * +\subsection{Looking up an instance} +%* * +%************************************************************************ @lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since 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 -- The envt - -> [Type] -- Key - -> InstEnvResult - -data InstEnvResult - = FoundInst -- There is a (template,substitution) pair - -- that makes the template match the key, - -- and no template is an instance of the key - TyVarSubstEnv Id - - | NoMatch Bool -- Boolean is true iff there is at least one - -- template that matches the key. - -- (but there are other template(s) that are - -- instances of the key, so we don't report - -- FoundInst) - -- The NoMatch True case happens when we look up +lookupInstEnv :: DynFlags + -> (InstEnv -- External package inst-env + ,InstEnv) -- Home-package inst-env + -> Class -> [Type] -- What we are looking for + -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches + [Id]) -- 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 say there is no match, but identify - -- it as ambiguous case in the hope of giving a better error msg. - -- See the notes above from Jeff Lewis - -lookupInstEnv env key - = find env + -- 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 dflags (pkg_ie, home_ie) cls tys + | not (null all_unifs) = (all_matches, all_unifs) -- This is always an error situation, + -- so don't attempt to pune the matches + | otherwise = (pruned_matches, []) where - key_vars = tyVarsOfTypes key - find [] = NoMatch False - find ((tpl_tyvars, tpl, val) : rest) - = case matchTys tpl_tyvars tpl key of - Nothing -> - case matchTys key_vars key tpl of - Nothing -> find rest - Just (_, _) -> NoMatch (any_match rest) + 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 + all_matches = home_matches ++ pkg_matches + all_unifs | incoherent_ok = [] -- Don't worry about these if incoherent is ok! + | otherwise = home_unifs ++ pkg_unifs + + pruned_matches | overlap_ok = foldr insert_overlapping [] all_matches + | otherwise = all_matches + +lookup_inst_env :: InstEnv -- The envt + -> Class -> [Type] -- What we are looking for + -> ([(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) [] [] + where + key_vars = tyVarsOfTypes key_tys + + find [] ms us = (ms, us) + find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us + = case matchTys tpl_tyvars tpl key_tys of Just (subst, leftovers) -> ASSERT( null leftovers ) - FoundInst subst val - any_match rest = or [ maybeToBool (matchTys tvs tpl key) - | (tvs,tpl,_) <- rest - ] + find rest ((subst,item):ms) us + Nothing + -- Does not match, so next check whether the things unify + -- [see notes about overlapping instances above] + -> case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of + Just _ -> find rest ms (dfun_id:us) + Nothing -> find rest ms us + +insert_overlapping :: (TyVarSubstEnv, InstEnvElt) -> [(TyVarSubstEnv, InstEnvElt)] + -> [(TyVarSubstEnv, InstEnvElt)] +-- Add a new solution, knocking out strictly less specific ones +insert_overlapping new_item [] = [new_item] +insert_overlapping new_item (item:items) + | new_beats_old && old_beats_new = item : insert_overlapping new_item items + -- Duplicate => keep both for error report + | new_beats_old = insert_overlapping new_item items + -- Keep new one + | old_beats_new = item : items + -- Keep old one + | otherwise = item : insert_overlapping new_item items + -- Keep both + where + new_beats_old = new_item `beats` item + old_beats_new = item `beats` new_item + + (_, (tvs1, tys1, _)) `beats` (_, (tvs2, tys2, _)) + = isJust (matchTys tvs2 tys2 tys1) -- A beats B if A is more specific than B + -- I.e. if B can be instantiated to match A \end{code} -@addToInstEnv@ extends a @InstEnv@, checking for overlaps. -A boolean flag controls overlap reporting. +%************************************************************************ +%* * + Functional dependencies +%* * +%************************************************************************ + +Here is the bad case: + class C a b | a->b where ... + instance C Int Bool where ... + instance C Int Char where ... + +The point is that a->b, so Int in the first parameter must uniquely +determine the second. In general, given the same class decl, and given + + instance C s1 s2 where ... + instance C t1 t2 where ... + +Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). + +Matters are a little more complicated if there are free variables in +the s2/t2. + + class D a b c | a -> b + instance D a b => D [(a,a)] [b] Int + instance D a b => D [a] [b] Bool + +The instance decls don't overlap, because the third parameter keeps +them separate. But we want to make sure that given any constraint + D s1 s2 s3 +if s1 matches -True => overlap is permitted, but only if one template matches the other; - not if they unify but neither is \begin{code} -addToInstEnv :: Bool -- True <=> overlap permitted - -> InstEnv -- Envt - -> [TyVar] -> [Type] -> Id -- New item - -> MaybeErr InstEnv -- Success... - ([Type], Id) -- Failure: Offending overlap - -addToInstEnv overlap_ok env ins_tvs ins_tys value - = insert env +checkFunDeps :: (InstEnv, InstEnv) -> DFunId + -> Maybe [DFunId] -- Nothing <=> ok + -- Just dfs <=> conflict with dfs +-- Check wheher adding DFunId would break functional-dependency constraints +checkFunDeps (pkg_ie, home_ie) dfun + | null bad_fundeps = Nothing + | otherwise = Just bad_fundeps where - ins_tv_set = mkVarSet ins_tvs - ins_item = (ins_tv_set, ins_tys, value) - - insert [] = returnMaB [ins_item] - insert env@(cur_item@(tpl_tvs, tpl_tys, val) : rest) - - -- FAIL if: - -- (a) they are the same, or - -- (b) they unify, and any sort of overlap is prohibited, - -- (c) they unify but neither is more specific than t'other - | identical - || (unifiable && not overlap_ok) - || (unifiable && not (ins_item_more_specific || cur_item_more_specific)) - = failMaB (tpl_tys, val) - - -- New item is an instance of current item, so drop it here - | ins_item_more_specific = returnMaB (ins_item : env) - - -- Otherwise carry on - | otherwise = insert rest `thenMaB` \ rest' -> - returnMaB (cur_item : rest') - where - unifiable = maybeToBool (unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys) - ins_item_more_specific = maybeToBool (matchTys tpl_tvs tpl_tys ins_tys) - cur_item_more_specific = maybeToBool (matchTys ins_tv_set ins_tys tpl_tys) - identical = ins_item_more_specific && cur_item_more_specific + (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 + bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys + +badFunDeps :: ClsInstEnv -> Class + -> TyVarSet -> [Type] -- Proposed new instance type + -> [DFunId] +badFunDeps cls_inst_env clas ins_tv_set ins_tys + = [ dfun_id | fd <- fds, + (tvs, tys, dfun_id) <- cls_inst_env, + notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys) + ] + where + (clas_tvs, fds) = classTvsFds clas \end{code} -