Commit 5f352824 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-06-22 14:45:41 by simonpj]

*** NO NEED TO MERGE WITH 4.07 ***
    (but it would do no harm)

* Improve an error message when overlapping instance
  declarations are present.  Carl Witty reported this
  infelicitous message.  The problem arises for this code:

	class Foo a
	class (Foo a) => Bar a
	
	data Dat a = Dat
	
	instance Foo (Dat a)
	instance Foo (Dat Integer)
	
	instance Bar (Dat a)

  The instance decl for Bar should say

	instance Foo (Dat a) => Bar (Dat a) 

  because the overlapping instance decls for Foo can't
  be resolved (or at least might vary depending on how
  a is instantiated).
parent fad3991b
......@@ -59,7 +59,7 @@ import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
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,
......@@ -659,9 +659,9 @@ lookupInst :: Inst
-- 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)
......@@ -682,7 +682,7 @@ lookupInst dict@(Dict _ (Class clas tys) loc)
in
returnNF_Tc (GenInst dicts rhs)
Nothing -> returnNF_Tc NoInstance
other -> returnNF_Tc NoInstance
lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
-- Methods
......@@ -760,12 +760,12 @@ lookupSimpleInst :: InstEnv
-> 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@}
......
......@@ -136,7 +136,7 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
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,
......@@ -154,7 +154,7 @@ import Type ( Type, ThetaType, TauType, ClassContext,
mkTyVarTy, getTyVar,
isTyVarTy, splitSigmaTy, tyVarsOfTypes
)
import InstEnv ( InstEnv )
import InstEnv ( InstEnv, lookupInstEnv, InstEnvResult(..) )
import Subst ( mkTopTyVarSubst, substClasses )
import PprType ( pprConstraint )
import TysWiredIn ( unitTy )
......@@ -1266,22 +1266,45 @@ addTopInstanceErr dict
(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))
......
......@@ -5,7 +5,8 @@
\begin{code}
module InstEnv (
InstEnv, emptyInstEnv, addToInstEnv, lookupInstEnv
InstEnv, emptyInstEnv, addToInstEnv,
lookupInstEnv, InstEnvResult(..)
) where
#include "HsVersions.h"
......@@ -147,30 +148,52 @@ emptyInstEnv = []
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.
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment