X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FInstEnv.lhs;h=d4a7b771b7de4b9c7d46c968929e30a4236b319b;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=d660fc6b721aeb34c2138782dd5fe0b70fdf786f;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index d660fc6..d4a7b77 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -7,33 +7,38 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - DFunId, ClsInstEnv, InstEnv, - - emptyInstEnv, extendInstEnv, pprInstEnv, - lookupInstEnv, InstLookupResult(..), - classInstEnv, simpleDFunClassTyCon + DFunId, OverlapFlag(..), + Instance(..), pprInstance, pprInstanceHdr, pprInstances, + instanceHead, mkLocalInstance, mkImportedInstance, + instanceDFunId, setInstanceDFunId, instanceRoughTcs, + + InstEnv, emptyInstEnv, extendInstEnv, + extendInstEnvList, lookupInstEnv, instEnvElts, + classInstances, + instanceCantMatch, roughMatchTcs ) where #include "HsVersions.h" -import Class ( Class, classTvsFds ) -import Var ( TyVar, Id ) +import Class ( Class ) +import Var ( Id, TyVar, isTcTyVar ) import VarSet -import VarEnv -import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) -import Name ( getSrcLoc ) -import TcType ( Type, tcTyConAppTyCon, mkTyVarTy, - tcSplitDFunTy, tyVarsOfTypes, - matchTys, unifyTyListsX, allDistinctTyVars +import Name ( Name, NamedThing(..), getSrcLoc, nameIsLocalOrFrom, nameModule ) +import OccName ( OccName ) +import NameSet ( unionNameSets, unitNameSet, nameSetToList ) +import Type ( TvSubst ) +import TcType ( Type, PredType, tcEqType, + tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar, + pprThetaArrow, pprClassPred, + tyClsNamesOfType, tcSplitTyConApp_maybe ) -import PprType ( pprClassPred ) -import FunDeps ( checkClsFD ) -import TyCon ( TyCon ) +import TyCon ( tyConName ) +import Unify ( tcMatchTys, tcUnifyTys, BindFlag(..) ) import Outputable -import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM ) -import Id ( idType ) -import ErrUtils ( Message ) -import CmdLineOpts +import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM ) +import Id ( idType, idName ) +import SrcLoc ( pprDefnLoc ) +import Maybe ( isJust, isNothing ) \end{code} @@ -44,75 +49,208 @@ import CmdLineOpts %************************************************************************ \begin{code} -type DFunId = Id - -type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class - -simpleDFunClassTyCon :: DFunId -> (Class, TyCon) -simpleDFunClassTyCon dfun - = (clas, tycon) - where - (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun) - tycon = tcTyConAppTyCon ty - -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 - ] -\end{code} - -%************************************************************************ -%* * -\subsection{Instance environments: InstEnv and ClsInstEnv} -%* * -%************************************************************************ +type DFunId = Id +data Instance + = Instance { is_cls :: Name -- Class name + + -- Used for "rough matching"; see note below + , is_tcs :: [Maybe Name] -- Top of type args + + -- Used for "proper matching"; see note + , is_tvs :: TyVarSet -- Template tyvars for full match + , is_tys :: [Type] -- Full arg types + + , is_dfun :: DFunId + , is_flag :: OverlapFlag + + , is_orph :: Maybe OccName } + +-- The "rough-match" fields +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The is_cls, is_args fields allow a "rough match" to be done +-- without poking inside the DFunId. Poking the DFunId forces +-- us to suck in all the type constructors etc it involves, +-- which is a total waste of time if it has no chance of matching +-- So the Name, [Maybe Name] fields allow us to say "definitely +-- does not match", based only on the Name. +-- +-- In is_tcs, +-- Nothing means that this type arg is a type variable +-- +-- (Just n) means that this type arg is a +-- TyConApp with a type constructor of n. +-- This is always a real tycon, never a synonym! +-- (Two different synonyms might match, but two +-- different real tycons can't.) +-- NB: newtypes are not transparent, though! +-- +-- The "proper-match" fields +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The is_tvs, is_tys fields are simply cahced values, pulled +-- out (lazily) from the dfun id. They are cached here simply so +-- that we don't need to decompose the DFunId each time we want +-- to match it. The hope is that the fast-match fields mean +-- that we often never poke th proper-match fields +-- +-- However, note that: +-- * is_tvs must be a superset of the free vars of is_tys +-- +-- * The is_dfun must itself be quantified over exactly is_tvs +-- (This is so that we can use the matching substitution to +-- instantiate the dfun's context.) +-- +-- The "orphan" field +-- ~~~~~~~~~~~~~~~~~~ +-- An instance is an orphan if its head (after the =>) mentions +-- nothing defined in this module. +-- +-- Just n The head mentions n, which is defined in this module +-- This is used for versioning; the instance decl is +-- considered part of the defn of n when computing versions +-- +-- Nothing The head mentions nothing defined in this modle +-- +-- If a module contains any orphans, then its interface file is read +-- regardless, so that its instances are not missed. +-- +-- Functional dependencies worsen the situation a bit. Consider +-- class C a b | a -> b +-- In some other module we might have +-- module M where +-- data T = ... +-- instance C Int T where ... +-- This isn't considered an orphan, so we will only read M's interface +-- if something from M is used (e.g. T). So there's a risk we'll +-- miss the improvement from the instance. Workaround: import M. + +instanceDFunId :: Instance -> DFunId +instanceDFunId = is_dfun + +setInstanceDFunId :: Instance -> DFunId -> Instance +setInstanceDFunId ispec dfun + = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) ) + -- We need to create the cached fields afresh from + -- the new dfun id. In particular, the is_tvs in + -- the Instance must match those in the dfun! + -- We assume that the only thing that changes is + -- the quantified type variables, so the other fields + -- are ok; hence the assert + ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys } + where + (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) + +instanceRoughTcs :: Instance -> [Maybe Name] +instanceRoughTcs = is_tcs +\end{code} \begin{code} -type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class - -- INVARIANTs: see notes below - -emptyInstEnv :: InstEnv -emptyInstEnv = emptyUFM +instance NamedThing Instance where + getName ispec = getName (is_dfun ispec) + +instance Outputable Instance where + ppr = pprInstance + +pprInstance :: Instance -> SDoc +-- Prints the Instance as an instance declaration +pprInstance ispec@(Instance { is_flag = flag }) + = hang (pprInstanceHdr ispec) + 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc 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 + <+> sep [pprThetaArrow theta, pprClassPred clas tys] + where + (_, theta, clas, tys) = instanceHead ispec + -- Print without the for-all, which the programmer doesn't write + +pprInstances :: [Instance] -> SDoc +pprInstances ispecs = vcat (map pprInstance ispecs) + +instanceHead :: Instance -> ([TyVar], [PredType], Class, [Type]) +instanceHead ispec = tcSplitDFunTy (idType (is_dfun ispec)) + +mkLocalInstance :: DFunId -> OverlapFlag -> Instance +-- Used for local instances, where we can safely pull on the DFunId +mkLocalInstance dfun oflag + = Instance { is_flag = oflag, is_dfun = dfun, + is_tvs = mkVarSet tvs, is_tys = tys, + is_cls = cls_name, is_tcs = roughMatchTcs tys, + is_orph = orph } + where + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + mod = nameModule (idName dfun) + cls_name = getName cls + tycl_names = foldr (unionNameSets . tyClsNamesOfType) + (unitNameSet cls_name) tys + orph = case filter (nameIsLocalOrFrom mod) (nameSetToList tycl_names) of + [] -> Nothing + (n:ns) -> Just (getOccName n) + +mkImportedInstance :: Name -> [Maybe Name] -> Maybe OccName + -> DFunId -> OverlapFlag -> Instance +-- Used for imported instances, where we get the rough-match stuff +-- from the interface file +mkImportedInstance cls mb_tcs orph dfun oflag + = Instance { is_flag = oflag, is_dfun = dfun, + is_tvs = mkVarSet tvs, is_tys = tys, + is_cls = cls, is_tcs = mb_tcs, is_orph = orph } + where + (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) -classInstEnv :: InstEnv -> Class -> ClsInstEnv -classInstEnv env cls = lookupWithDefaultUFM env [] cls +roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs tys = map rough tys + where + rough ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (tyConName tc) + Nothing -> Nothing + +instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- 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 + +--------------------------------------------------- +data OverlapFlag + = NoOverlap -- This instance must not overlap another + + | OverlapOk -- Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instances (Foo [Int]) + -- (Foo [a]) OverlapOk + -- Since the second instance has the OverlapOk flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + | Incoherent -- Like OverlapOk, but also ignore this instance + -- if it doesn't match the constraint you are + -- trying to resolve, but could match if the type variables + -- in the constraint were instantiated + -- + -- Example: constraint (Foo [b]) + -- instances (Foo [Int]) Incoherent + -- (Foo [a]) + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen + +instance Outputable OverlapFlag where + ppr NoOverlap = empty + ppr OverlapOk = ptext SLIT("[overlap ok]") + ppr Incoherent = ptext SLIT("[incoherent]") \end{code} -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 +Note [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 +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 one template matches the other, or vice versa. So this is ok: @@ -220,212 +358,209 @@ exists. --Jeff +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. -%************************************************************************ -%* * -\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 - -> Class -> [Type] -- Key - -> InstLookupResult - -data InstLookupResult - = 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 - -- 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_cls key_tys - = find (classInstEnv env key_cls) - where - key_vars = tyVarsOfTypes key_tys - - find [] = NoMatch False - find ((tpl_tyvars, tpl, dfun_id) : rest) - = case matchTys tpl_tyvars tpl key_tys of - Nothing -> - -- Check for reverse match, so that - -- we bale out if a later instantiation of this - -- predicate might match this instance - -- [see notes about overlapping instances above] - case matchTys key_vars key_tys tpl of - Nothing -> find rest - Just (_, _) -> NoMatch (any_match rest) - Just (subst, leftovers) -> ASSERT( null leftovers ) - FoundInst subst dfun_id - - any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys) - | (tvs,tpl,_) <- rest - ] -\end{code} +Simple story: unify, don't match. %************************************************************************ %* * -\subsection{Extending an instance environment} + InstEnv, ClsInstEnv %* * %************************************************************************ -@extendInstEnv@ extends a @ClsInstEnv@, checking for overlaps. - -A boolean flag controls overlap reporting. - -True => overlap is permitted, but only if one template matches the other; - not if they unify but neither is +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. -\begin{code} -extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [Message]) - -- Similar, but all we have is the DFuns -extendInstEnv dflags env dfun_ids = foldl (addToInstEnv dflags) (env, []) dfun_ids +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 -addToInstEnv :: DynFlags - -> (InstEnv, [Message]) - -> DFunId - -> (InstEnv, [Message]) -- Resulting InstEnv and augmented error messages +or, to put it another way, we have -addToInstEnv dflags (inst_env, errs) dfun_id - -- Check first that the new instance doesn't - -- conflict with another. See notes below about fundeps. - | not (null bad_fundeps) - = (inst_env, fundep_err : errs) -- Bad fundeps; report the first only + instance (...) => C t1 t2 t3, witnessed by dfun - | otherwise - = case insert_into cls_inst_env of - Failed err -> (inst_env, err : errs) - Succeeded new_env -> (addToUFM inst_env clas new_env, errs) +\begin{code} +--------------------------------------------------- +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class - where - cls_inst_env = classInstEnv inst_env clas - (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) - bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys - fundep_err = fundepErr dfun_id (head bad_fundeps) - - ins_tv_set = mkVarSet ins_tvs - ins_item = (ins_tv_set, ins_tys, dfun_id) - - insert_into [] = returnMaB [ins_item] - insert_into env@(cur_item@(tpl_tvs, tpl_tys, tpl_dfun_id) : rest) - = case unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys of - Just subst -> insert_unifiable env subst - Nothing -> carry_on cur_item rest - - carry_on cur_item rest = insert_into rest `thenMaB` \ rest' -> - returnMaB (cur_item : rest') - - -- The two templates unify. This is acceptable iff - -- (a) -fallow-overlapping-instances is on - -- (b) one is strictly more specific than the other - -- [It's bad if they are identical or incomparable] - insert_unifiable env@(cur_item@(tpl_tvs, tpl_tys, tpl_dfun_id) : rest) subst - | ins_item_more_specific && cur_item_more_specific - = -- Duplicates - failMaB (dupInstErr dfun_id tpl_dfun_id) - - | not (dopt Opt_AllowOverlappingInstances dflags) - || not (ins_item_more_specific || cur_item_more_specific) - = -- Overlap illegal, or the two are incomparable - failMaB (overlapErr dfun_id tpl_dfun_id) - - | otherwise - = -- OK, it's acceptable. Remaining question is whether - -- we drop it here or compare it with others - if ins_item_more_specific then - -- New item is an instance of current item, so drop it here - returnMaB (ins_item : env) - else - carry_on cur_item rest - - where - ins_item_more_specific = allVars subst ins_tvs - cur_item_more_specific = allVars subst (varSetElems tpl_tvs) - -allVars :: TyVarSubstEnv -> [TyVar] -> Bool --- True iff all the type vars are mapped to distinct type vars -allVars subst tvs - = allDistinctTyVars (map lookup tvs) emptyVarSet - where - lookup tv = case lookupSubstEnv subst tv of - Just (DoneTy ty) -> ty - Nothing -> mkTyVarTy tv -\end{code} +data ClsInstEnv + = ClsIE [Instance] -- 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 -Functional dependencies -~~~~~~~~~~~~~~~~~~~~~~~ -Here is the bad case: - class C a b | a->b where ... - instance C Int Bool where ... - instance C Int Char where ... +-- INVARIANTS: +-- * The is_tvs are distinct in each Instance +-- of a ClsInstEnv (so we can safely unify them) -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 +-- 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. - instance C s1 s2 where ... - instance C t1 t2 where ... +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUFM -Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). +instEnvElts :: InstEnv -> [Instance] +instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts] -Matters are a little more complicated if there are free variables in -the s2/t2. +classInstances :: (InstEnv,InstEnv) -> Class -> [Instance] +classInstances (pkg_ie, home_ie) cls + = get home_ie ++ get pkg_ie + where + get env = case lookupUFM env cls of + Just (ClsIE insts _) -> insts + Nothing -> [] - class D a b c | a -> b - instance D a b => D [(a,a)] [b] Int - instance D a b => D [a] [b] Bool +extendInstEnvList :: InstEnv -> [Instance] -> InstEnv +extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs -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 +extendInstEnv :: InstEnv -> Instance -> InstEnv +extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs }) + = addToUFM_C add inst_env cls_nm (ClsIE [ins_item] ins_tyvar) + where + add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts) + (ins_tyvar || cur_tyvar) + ins_tyvar = not (any isJust mb_tcs) +\end{code} +%************************************************************************ +%* * +\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} -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, - not (null (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys)) - ] - where - (clas_tvs, fds) = classTvsFds clas -\end{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 -\begin{code} -dupInstErr dfun1 dfun2 = addInstErr (ptext SLIT("Duplicate instance declarations:")) dfun1 dfun2 -overlapErr dfun1 dfun2 = addInstErr (ptext SLIT("Overlapping instance declarations:")) dfun1 dfun2 -fundepErr dfun1 dfun2 = addInstErr (ptext SLIT("Functional dependencies conflict between instance declarations:")) - dfun1 dfun2 +lookupInstEnv (pkg_ie, home_ie) cls tys + = (pruned_matches, all_unifs) + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + (home_matches, home_unifs) = lookup home_ie + (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 + + -------------- + lookup env = case lookupUFM env cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts has_tv_insts) + | 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 + + -------------- + 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, + is_dfun = dfun }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find ms us rest + + | Just subst <- tcMatchTys tpl_tvs tpl_tys tys + = find ((subst,item):ms) us rest + + -- Does not match, so next check whether the things unify + -- See Note [overlapping instances] above + | Incoherent <- oflag + = find ms us rest -addInstErr what dfun1 dfun2 - = hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2) + | otherwise + = ASSERT2( not (tyVarsOfTypes tys `intersectsVarSet` tpl_tvs), + (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr dfun <+> ppr tpl_tvs <+> ppr tpl_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 + Just _ -> find ms (item: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 :: (TvSubst, Instance) -> [(TvSubst, Instance)] + -> [(TvSubst, Instance)] +-- 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 - ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> pprClassPred clas tys - where - (_,_,clas,tys) = tcSplitDFunTy (idType dfun) + new_beats_old = new_item `beats` item + old_beats_new = item `beats` new_item + + (_, 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 + -- I.e. if B can be instantiated to match A + where + overlap_ok = case is_flag instB of + NoOverlap -> False + other -> True \end{code} +