X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FInstEnv.lhs;h=1abcc183849cae9bb20323b1ff56bd99b29fb9b1;hp=7d131d41b4672249a5b9088c688370f7e0e48693;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=899fd7fb59cedf25b3939f951016f0c8b5d1541a diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 7d131d4..1abcc18 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -7,6 +7,13 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- for details + module InstEnv ( DFunId, OverlapFlag(..), Instance(..), pprInstance, pprInstanceHdr, pprInstances, @@ -25,9 +32,6 @@ import Class import Var import VarSet import Name -import OccName -import NameSet -import Type import TcType import TyCon import TcGadt @@ -53,11 +57,11 @@ type DFunId = Id data Instance = Instance { is_cls :: Name -- Class name - -- Used for "rough matching"; see note below + -- Used for "rough matching"; see Note [Rough-match field] -- INVARIANT: is_tcs = roughMatchTcs is_tys , is_tcs :: [Maybe Name] -- Top of type args - -- Used for "proper matching"; see note + -- Used for "proper matching"; see Note [Proper-match fields] , is_tvs :: TyVarSet -- Template tyvars for full match , is_tys :: [Type] -- Full arg types -- INVARIANT: is_dfun Id has type @@ -66,13 +70,12 @@ data Instance , is_dfun :: DFunId , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag - - , is_orph :: Maybe OccName } + } \end{code} -The "rough-match" fields -~~~~~~~~~~~~~~~~~~~~~~~~~ -The is_cls, is_args fields allow a "rough match" to be done +Note [Rough-match field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_cls, is_tcs 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 @@ -89,7 +92,7 @@ In is_tcs, different real tycons can't.) NB: newtypes are not transparent, though! -The "proper-match" fields +Note [Proper-match fields] ~~~~~~~~~~~~~~~~~~~~~~~~~ The is_tvs, is_tys fields are simply cached values, pulled out (lazily) from the dfun id. They are cached here simply so @@ -105,31 +108,6 @@ However, note that: instantiate the dfun's context.) -Note [Orphans]: the "is_orph" 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 module - -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. - -Rules are orphans and versioned in much the same way. \begin{code} instanceDFunId :: Instance -> DFunId @@ -163,7 +141,7 @@ 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))) + 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan ispec))) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: Instance -> SDoc @@ -186,26 +164,18 @@ mkLocalInstance :: DFunId -> OverlapFlag -> Instance 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 } + is_cls = className cls, is_tcs = roughMatchTcs tys } 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 + +mkImportedInstance :: Name -> [Maybe Name] -> 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 +mkImportedInstance cls mb_tcs 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 } + is_cls = cls, is_tcs = mb_tcs } where (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) @@ -422,20 +392,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) @@ -446,10 +437,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 @@ -464,6 +456,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, @@ -473,7 +471,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 @@ -513,8 +515,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) @@ -530,7 +531,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