From 5f3528244ad3ec004bb67a8a2ec086fe90318ce7 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 22 Jun 2000 14:45:41 +0000
Subject: [PATCH] [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).
---
ghc/compiler/typecheck/Inst.lhs | 16 ++++----
ghc/compiler/typecheck/TcMatches.lhs | 2 +-
ghc/compiler/typecheck/TcSimplify.lhs | 53 +++++++++++++++++++--------
ghc/compiler/types/InstEnv.lhs | 49 ++++++++++++++++++-------
4 files changed, 83 insertions(+), 37 deletions(-)
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index d4565d01d1ff..c73497e33a92 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -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}
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 0fb4aba6b646..ebd6ba56e2bd 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -1,4 +1,4 @@
-\%
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMatches]{Typecheck some @Matches@}
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 8c4de82dac7b..288ecf82c6eb 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -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))
diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs
index 231fe203392d..d0fc445d7fb6 100644
--- a/ghc/compiler/types/InstEnv.lhs
+++ b/ghc/compiler/types/InstEnv.lhs
@@ -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.
--
GitLab