X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FInstEnv.lhs;h=a6ddc3c3ed01a85fcdc8960d11951ace5ceace7e;hb=35fb5c6ff0861be5ab72df799df536982d3966b8;hp=560c4fc24be1464a8e0c1835138cc92fbd0b0a7b;hpb=940524aec90652b5ef81789c9a453c57c0e42cc9;p=ghc-hetmet.git diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 560c4fc..a6ddc3c 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -15,7 +15,7 @@ module InstEnv ( InstEnv, emptyInstEnv, extendInstEnv, extendInstEnvList, lookupInstEnv, instEnvElts, - classInstances, + classInstances, instanceBindFun, instanceCantMatch, roughMatchTcs ) where @@ -27,13 +27,12 @@ import VarSet import Name import TcType import TyCon -import TcGadt import Unify import Outputable import BasicTypes import UniqFM import Id -import SrcLoc +import FastString import Data.Maybe ( isJust, isNothing ) \end{code} @@ -132,15 +131,15 @@ instance Outputable Instance where pprInstance :: Instance -> SDoc -- Prints the Instance as an instance declaration -pprInstance ispec@(Instance { is_flag = flag }) +pprInstance ispec = hang (pprInstanceHdr ispec) - 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan ispec))) + 2 (ptext (sLit "--") <+> pprNameLoc (getName ispec)) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: Instance -> SDoc -- Prints the Instance as an instance declaration pprInstanceHdr ispec@(Instance { is_flag = flag }) - = ptext SLIT("instance") <+> ppr flag + = ptext (sLit "instance") <+> ppr flag <+> sep [pprThetaArrow theta, pprClassPred clas tys] where (_, theta, clas, tys) = instanceHead ispec @@ -184,7 +183,7 @@ instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool -- possibly be instantiated to actual, nor vice versa; -- False is non-committal instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as -instanceCantMatch ts as = False -- Safe +instanceCantMatch _ _ = False -- Safe \end{code} @@ -371,12 +370,12 @@ extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs }) add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts) (ins_tyvar || cur_tyvar) ins_tyvar = not (any isJust mb_tcs) -\end{code} +\end{code} %************************************************************************ %* * -\subsection{Looking up an instance} + Looking up an instance %* * %************************************************************************ @@ -430,10 +429,11 @@ lookupInstEnv (pkg_ie, home_ie) cls tys (pkg_matches, pkg_unifs) = lookup pkg_ie all_matches = home_matches ++ pkg_matches all_unifs = home_unifs ++ pkg_unifs - pruned_matches - | null all_unifs = foldr insert_overlapping [] all_matches - | otherwise = all_matches -- Non-empty unifs is always an error situation, - -- so don't attempt to pune the matches + pruned_matches = foldr insert_overlapping [] all_matches + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) -------------- lookup env = case lookupUFM env cls of @@ -481,31 +481,11 @@ lookupInstEnv (pkg_ie, home_ie) cls tys ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them - case tcUnifyTys bind_fn tpl_tys tys of + case tcUnifyTys instanceBindFun tpl_tys tys of Just _ -> find ms (item:us) rest - Nothing -> find ms us rest + Nothing -> find ms us rest --------------- -bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem - | otherwise = BindMe - -- 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. - -- - -- We do this only for pattern-bound skolems. For example we reject - -- g :: forall a => [a] -> Int - -- g x = op x - -- on the grounds that the correct instance depends on the instantiation of 'a' - --------------- insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] -- Add a new solution, knocking out strictly less specific ones @@ -531,6 +511,43 @@ insert_overlapping new_item (item:items) where overlap_ok = case is_flag instB of NoOverlap -> False - other -> True + _ -> True \end{code} + +%************************************************************************ +%* * + Binding decisions +%* * +%************************************************************************ + +\begin{code} +instanceBindFun :: TyVar -> BindFlag +instanceBindFun tv | isTcTyVar tv && isExistentialTyVar tv = Skolem + | otherwise = BindMe + -- Note [Binding when looking up instances] +\end{code} + +Note [Binding when looking up instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When looking up in the instance environment, or family-instance environment, +we are careful about multiple matches, as described above in +Note [Overlapping instances] + +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. + +We do this only for pattern-bound skolems. For example we reject + g :: forall a => [a] -> Int + g x = op x +on the grounds that the correct instance depends on the instantiation of 'a'