import Name ( OccName, Name, mkDictOcc, mkMethodOcc, mkIPOcc,
getOccName, nameUnique )
import PprType ( pprPred )
-import InstEnv ( InstEnv, lookupInstEnv )
+import InstEnv ( InstEnv, lookupInstEnv, InstEnvResult(..) )
import SrcLoc ( SrcLoc )
import Type ( Type, PredType(..), ThetaType,
mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
-- Dictionaries
lookupInst dict@(Dict _ (Class clas tys) loc)
- = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
+ = case lookupInstEnv (classInstEnv clas) tys of
- Just (tenv, dfun_id)
+ FoundInst tenv dfun_id
-> let
subst = mkSubst (tyVarsOfTypes tys) tenv
(tyvars, rho) = splitForAllTys (idType dfun_id)
in
returnNF_Tc (GenInst dicts rhs)
- Nothing -> returnNF_Tc NoInstance
+ other -> returnNF_Tc NoInstance
lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
-- Methods
-> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
lookupSimpleInst class_inst_env clas tys
- = case lookupInstEnv (ppr clas) class_inst_env tys of
- Nothing -> returnNF_Tc Nothing
-
- Just (tenv, dfun)
+ = case lookupInstEnv class_inst_env tys of
+ FoundInst tenv dfun
-> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
where
(_, theta, _) = splitSigmaTy (idType dfun)
theta' = map (\(Class clas tys) -> (clas,tys)) theta
+
+ other -> returnNF_Tc Nothing
\end{code}
-\%
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMatches]{Typecheck some @Matches@}
isStdClassTyVarDict, isMethodFor,
instToId, instBindingRequired, instCanBeGeneralised,
newDictFromOld, newFunDepFromDict,
- getDictClassTys, getIPs,
+ getDictClassTys, getIPs, isTyVarDict,
getDictPred_maybe, getMethodTheta_maybe,
instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
mkTyVarTy, getTyVar,
isTyVarTy, splitSigmaTy, tyVarsOfTypes
)
-import InstEnv ( InstEnv )
+import InstEnv ( InstEnv, lookupInstEnv, InstEnvResult(..) )
import Subst ( mkTopTyVarSubst, substClasses )
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
(tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
addNoInstanceErr str givens dict
- = addInstErrTcM (instLoc dict)
- (tidy_env,
- sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
- nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
- $$
- ptext SLIT("Probable cause:") <+>
- vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
- ptext SLIT("in") <+> str],
- if isClassDict dict && all_tyvars then empty else
- ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
- )
+ = addInstErrTcM (instLoc dict) (tidy_env, doc)
where
- all_tyvars = all isTyVarTy tys
- (_, tys) = getDictClassTys dict
+ doc = vcat [herald <+> quotes (pprInst tidy_dict),
+ nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens,
+ ambig_doc,
+ ptext SLIT("Probable fix:"),
+ nest 4 fix1,
+ nest 4 fix2]
+
+ herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce")
+ unambig_doc | ambig_overlap = ptext SLIT("unambiguously")
+ | otherwise = empty
+
+ ambig_doc
+ | not ambig_overlap = empty
+ | otherwise
+ = vcat [ptext SLIT("The choice of (overlapping) instance declaration"),
+ nest 4 (ptext SLIT("depends on the instantiation of") <+>
+ quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst tidy_dict))))]
+
+ fix1 = sep [ptext SLIT("Add") <+> quotes (pprInst tidy_dict),
+ ptext SLIT("to the") <+> str]
+
+ fix2 | isTyVarDict dict || ambig_overlap
+ = empty
+ | otherwise
+ = ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
+
(tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
+ -- Checks for the ambiguous case when we have overlapping instances
+ ambig_overlap | isClassDict dict
+ = case lookupInstEnv (classInstEnv clas) tys of
+ NoMatch ambig -> ambig
+ other -> False
+ | otherwise = False
+ where
+ (clas,tys) = getDictClassTys dict
+
-- Used for the ...Thetas variants; all top level
addNoInstErr (c,ts)
= addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
\begin{code}
module InstEnv (
- InstEnv, emptyInstEnv, addToInstEnv, lookupInstEnv
+ InstEnv, emptyInstEnv, addToInstEnv,
+ lookupInstEnv, InstEnvResult(..)
) where
#include "HsVersions.h"
isEmptyInstEnv env = null env
\end{code}
-@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.
+@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 :: SDoc -- For error report
- -> InstEnv -- The envt
+lookupInstEnv :: InstEnv -- The envt
-> [Type] -- Key
- -> Maybe (TyVarSubstEnv, Id)
-
-lookupInstEnv doc env key
+ -> InstEnvResult
+
+data InstEnvResult
+ = 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
= find env
where
key_vars = tyVarsOfTypes key
- find [] = Nothing
+ find [] = NoMatch False
find ((tpl_tyvars, tpl, val) : rest)
= case matchTys tpl_tyvars tpl key of
Nothing ->
case matchTys key_vars key tpl of
Nothing -> find rest
- Just (_, _) -> Nothing
+ Just (_, _) -> NoMatch (any_match rest)
Just (subst, leftovers) -> ASSERT( null leftovers )
- Just (subst, val)
+ FoundInst subst val
+ any_match rest = or [ maybeToBool (matchTys tvs tpl key)
+ | (tvs,tpl,_) <- rest
+ ]
\end{code}
@addToInstEnv@ extends a @InstEnv@, checking for overlaps.
projects / ghc-hetmet.git / commitdiff