X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FInstEnv.lhs;h=73a6ce9734902275ece0dcac8df5299860bff381;hb=3087014ae03067cf0f9c9e0d8d49fb885e2cd0a8;hp=ed9797576d4b9f1c02f1d6bb1e0575b7809a5c56;hpb=4a91d102be99778efcab80211ca5de3f2cf6619a;p=ghc-hetmet.git diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index ed97975..73a6ce9 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -7,105 +7,63 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - InstInfo(..), pprInstInfo, - simpleInstInfoTy, simpleInstInfoTyCon, simpleDFunClassTyCon, + DFunId, ClsInstEnv, InstEnv, - -- Instance environment - InstEnv, emptyInstEnv, extendInstEnv, + emptyInstEnv, extendInstEnv, pprInstEnv, lookupInstEnv, InstLookupResult(..), - classInstEnv, classDataCon, - - isLocalInst + classInstEnv, simpleDFunClassTyCon ) where #include "HsVersions.h" -import RnHsSyn ( RenamedMonoBinds, RenamedSig ) - -import HscTypes ( InstEnv, ClsInstEnv, DFunId ) -import Class ( Class ) +import Class ( Class, classTvsFds ) import Var ( TyVar, Id ) -import VarSet ( unionVarSet, mkVarSet ) -import VarEnv ( TyVarSubstEnv ) +import VarSet +import VarEnv import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) -import Name ( getSrcLoc ) -import SrcLoc ( SrcLoc ) -import Type ( Type, ThetaType, splitTyConApp_maybe, - splitSigmaTy, splitDFunTy, tyVarsOfTypes +import Name ( getSrcLoc, nameModule ) +import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import TcType ( Type, tcTyConAppTyCon, mkTyVarTy, + tcSplitDFunTy, tyVarsOfTypes, + matchTys, unifyTyListsX, allDistinctTyVars ) -import PprType ( ) -import Class ( classTyCon ) -import DataCon ( DataCon ) -import TyCon ( TyCon, tyConDataCons ) +import PprType ( pprClassPred ) +import FunDeps ( checkClsFD ) +import TyCon ( TyCon ) import Outputable -import Unify ( matchTys, unifyTyListsX ) -import UniqFM ( lookupWithDefaultUFM, addToUFM, emptyUFM ) -import Id ( idType ) +import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM ) +import Id ( idType, idName ) import ErrUtils ( Message ) import CmdLineOpts +import Util ( notNull ) \end{code} - %************************************************************************ %* * -\subsection{The InstInfo type} +\subsection{The key types} %* * %************************************************************************ -The InstInfo type summarises the information in an instance declaration - - instance c => k (t tvs) where b - \begin{code} -data InstInfo - = InstInfo { - iClass :: Class, -- Class, k - iTyVars :: [TyVar], -- Type variables, tvs - iTys :: [Type], -- The types at which the class is being instantiated - iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the - -- instance declaration. It constrains (some of) - -- the TyVars above - iLocal :: Bool, -- True <=> it's defined in this module - iDFunId :: DFunId, -- The dfun id - iBinds :: RenamedMonoBinds, -- Bindings, b - iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn - iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances - } - -pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)), - nest 4 (ppr (iBinds info))] - -simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty - -simpleInstInfoTyCon :: InstInfo -> TyCon - -- Gets the type constructor for a simple instance declaration, - -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst - = case splitTyConApp_maybe (simpleInstInfoTy inst) of - Just (tycon, _) -> tycon - -isLocalInst :: InstInfo -> Bool -isLocalInst info = iLocal info -\end{code} - +type DFunId = Id -A tiny function which doesn't belong anywhere else. -It makes a nasty mutual-recursion knot if you put it in Class. +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class -\begin{code} simpleDFunClassTyCon :: DFunId -> (Class, TyCon) simpleDFunClassTyCon dfun = (clas, tycon) where - (_,_,clas,[ty]) = splitDFunTy (idType dfun) - tycon = case splitTyConApp_maybe ty of - Just (tycon,_) -> tycon - -classDataCon :: Class -> DataCon -classDataCon clas = case tyConDataCons (classTyCon clas) of - (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + (_,_,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} %************************************************************************ @@ -114,9 +72,10 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of %* * %************************************************************************ -The actual type declarations are in HscTypes. - \begin{code} +type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class + -- INVARIANTs: see notes below + emptyInstEnv :: InstEnv emptyInstEnv = emptyUFM @@ -124,9 +83,8 @@ classInstEnv :: InstEnv -> Class -> ClsInstEnv classInstEnv env cls = lookupWithDefaultUFM env [] cls \end{code} -A @ClsInstEnv@ lives inside a class, and identifies all the instances -of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for -that instance. +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 @@ -141,6 +99,9 @@ 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] @@ -261,14 +222,33 @@ 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. + +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 - -> Class -> [Type] -- Key +lookupInstEnv :: DynFlags + -> InstEnv -- The envt + -> Class -> [Type] -- What we are looking for -> InstLookupResult data InstLookupResult @@ -292,27 +272,42 @@ data InstLookupResult -- 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 +lookupInstEnv dflags env key_cls key_tys = find (classInstEnv env key_cls) where key_vars = tyVarsOfTypes key_tys find [] = NoMatch False - find ((tpl_tyvars, tpl, val) : rest) + find ((tpl_tyvars, tpl, dfun_id) : rest) = case matchTys tpl_tyvars tpl key_tys of Nothing -> - case matchTys key_vars key_tys tpl of - Nothing -> find rest - Just (_, _) -> NoMatch (any_match rest) + -- Check whether the things unify, so that + -- we bale out if a later instantiation of this + -- predicate might match this instance + -- [see notes about overlapping instances above] + case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of + Just _ | not (dopt Opt_AllowIncoherentInstances dflags) + -> NoMatch (any_match rest) + -- If we allow incoherent instances we don't worry about the + -- test and just blaze on anyhow. Requested by John Hughes. + other -> find rest + Just (subst, leftovers) -> ASSERT( null leftovers ) - FoundInst subst val + FoundInst subst dfun_id any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys) | (tvs,tpl,_) <- rest ] \end{code} -@addToClsInstEnv@ extends a @ClsInstEnv@, checking for overlaps. + +%************************************************************************ +%* * +\subsection{Extending an instance environment} +%* * +%************************************************************************ + +@extendInstEnv@ extends a @ClsInstEnv@, checking for overlaps. A boolean flag controls overlap reporting. @@ -320,67 +315,145 @@ True => overlap is permitted, but only if one template matches the other; not if they unify but neither is \begin{code} -extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [Message]) +extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [(SrcLoc,Message)]) -- Similar, but all we have is the DFuns -extendInstEnv dflags env infos - = go env [] infos - where - go env msgs [] = (env, msgs) - go env msgs (dfun:dfuns) = case addToInstEnv dflags env dfun of - Succeeded new_env -> go new_env msgs dfuns - Failed dfun' -> go env (msg:msgs) infos - where - msg = dupInstErr dfun dfun' - - -dupInstErr dfun1 dfun2 - -- Overlapping/duplicate instances for given class; msg could be more glamourous - = hang (ptext SLIT("Duplicate or overlapping instance declarations:")) - 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2) - where - ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> ppr tau - where - (_,_,tau) = splitSigmaTy (idType dfun) +extendInstEnv dflags env dfun_ids = foldl (addToInstEnv dflags) (env, []) dfun_ids + addToInstEnv :: DynFlags - -> InstEnv -> DFunId - -> MaybeErr InstEnv -- Success... - DFunId -- Failure: Offending overlap - -addToInstEnv dflags inst_env dfun_id - = case insert_into (classInstEnv inst_env clas) of - Failed stuff -> Failed stuff - Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env) - + -> (InstEnv, [(SrcLoc,Message)]) + -> DFunId + -> (InstEnv, [(SrcLoc,Message)]) -- Resulting InstEnv and augmented error messages + +addToInstEnv dflags (inst_env, errs) dfun_id + -- Check first that the new instance doesn't + -- conflict with another. See notes below about fundeps. + | notNull bad_fundeps + = (inst_env, fundep_err : errs) -- Bad fundeps; report the first only + + | otherwise + = case insert_into cls_inst_env of + Failed err -> (inst_env, err : errs) + Succeeded new_env -> (addToUFM inst_env clas new_env, errs) + where - (ins_tvs, _, clas, ins_tys) = splitDFunTy (idType dfun_id) + 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) + ins_item = (ins_tv_set, ins_tys, dfun_id) insert_into [] = returnMaB [ins_item] - insert_into 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 (dopt Opt_AllowOverlappingInstances dflags)) - || (unifiable && not (ins_item_more_specific || cur_item_more_specific)) - = failMaB 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_into rest `thenMaB` \ rest' -> - returnMaB (cur_item : rest') + 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 - 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_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} +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 + + + +\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, + notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys) + ] + where + (clas_tvs, fds) = classTvsFds clas +\end{code} + + +\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 + +addInstErr :: SDoc -> DFunId -> DFunId -> (SrcLoc, Message) +addInstErr what dfun1 dfun2 + = (getSrcLoc dfun1, hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)) + where + + ppr_dfun dfun = pp_loc <> colon <+> pprClassPred clas tys + where + (_,_,clas,tys) = tcSplitDFunTy (idType dfun) + loc = getSrcLoc dfun + mod = nameModule (idName dfun) + + -- Worth trying to print a good location... imported dfuns + -- don't have a useful SrcLoc but we can say which module they come from + pp_loc | isGoodSrcLoc loc = ppr loc + | otherwise = ptext SLIT("In module") <+> ppr mod +\end{code}