import VarSet
import VarEnv
import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
-import Name ( getSrcLoc )
+import Name ( getSrcLoc, nameModule )
+import SrcLoc ( SrcLoc, isGoodSrcLoc )
import TcType ( Type, tcTyConAppTyCon, mkTyVarTy,
tcSplitDFunTy, tyVarsOfTypes,
matchTys, unifyTyListsX, allDistinctTyVars
import TyCon ( TyCon )
import Outputable
import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM )
-import Id ( idType )
+import Id ( idType, idName )
import ErrUtils ( Message )
import CmdLineOpts
+import Util ( notNull )
\end{code}
--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.
+
%************************************************************************
%* *
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
-- 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 ((tpl_tyvars, tpl, dfun_id) : rest)
= case matchTys tpl_tyvars tpl key_tys of
Nothing ->
- -- Check for reverse match, so that
+ -- 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 matchTys key_vars key_tys tpl of
- Nothing -> find rest
- Just (_, _) -> NoMatch (any_match rest)
+ 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 dfun_id
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 dfun_ids = foldl (addToInstEnv dflags) (env, []) dfun_ids
addToInstEnv :: DynFlags
- -> (InstEnv, [Message])
+ -> (InstEnv, [(SrcLoc,Message)])
-> DFunId
- -> (InstEnv, [Message]) -- Resulting InstEnv and augmented error messages
+ -> (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.
- | not (null bad_fundeps)
+ | notNull bad_fundeps
= (inst_env, fundep_err : errs) -- Bad fundeps; report the first only
| otherwise
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))
+ notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys)
]
where
(clas_tvs, fds) = classTvsFds clas
fundepErr dfun1 dfun2 = addInstErr (ptext SLIT("Functional dependencies conflict between instance declarations:"))
dfun1 dfun2
+addInstErr :: SDoc -> DFunId -> DFunId -> (SrcLoc, Message)
addInstErr what dfun1 dfun2
- = hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
+ = (getSrcLoc dfun1, hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2))
where
- ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> pprClassPred clas tys
- where
- (_,_,clas,tys) = tcSplitDFunTy (idType dfun)
+
+ 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}