From 38777c8687a42fabafec000882a14c51149811f1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Matthias=20B=C3=B6hm?= <mboe@informatik.uni-kiel.de>
Date: Fri, 9 Aug 2013 18:48:45 +0200
Subject: [PATCH] in
checkInstanceContextImpliesAllInstanceContextsOfSuperClasses: catch the case
that there are duplicate instances in the source file
---
src/Checks/TypeClassesCheck.hs | 12 +++++++-----
test/test2.sh | 3 ++-
.../typeclasses/TCCheck/DuplicateInstances2.curry | 15 +++++++++++++++
3 files changed, 24 insertions(+), 6 deletions(-)
create mode 100644 test/typeclasses/TCCheck/DuplicateInstances2.curry
diff --git a/src/Checks/TypeClassesCheck.hs b/src/Checks/TypeClassesCheck.hs
index dd7037fc..203deb55 100644
--- a/src/Checks/TypeClassesCheck.hs
+++ b/src/Checks/TypeClassesCheck.hs
@@ -760,13 +760,13 @@ checkForInstanceDataTypeExistAlsoInstancesForSuperclasses _ _ _ _
-- |returns the instance from the class environment for the given instance
-- declaration. This function must be called only after it has been checked
-- that as well the class name and the type name are valid (i.e., in phase 3)
-getInstance' :: ModuleIdent -> ClassEnv -> TCEnv -> Decl -> Instance
+getInstance' :: ModuleIdent -> ClassEnv -> TCEnv -> Decl -> Maybe Instance
getInstance' m cEnv tcEnv (InstanceDecl _p (SContext _scon) cls ty _tyvars _) =
inst
where
tyId = fromJust $ tyConToQualIdent m tcEnv ty
cls' = getCanonClassName m cEnv cls
- inst = fromJust $ getInstance cEnv cls' tyId
+ inst = getInstanceWithOrigin cEnv m cls' tyId
getInstance' _ _ _ _ = internalError "getInstance'"
-- |Returns a Base.Types.Context for the given instance. The type
@@ -795,7 +795,8 @@ checkInstanceContextImpliesAllInstanceContextsOfSuperClasses ::
ClassEnv -> TCEnv -> ModuleIdent -> Decl -> Tcc ()
checkInstanceContextImpliesAllInstanceContextsOfSuperClasses cEnv tcEnv m
inst@(InstanceDecl p _scon cls ty _tyvars _)
- = let inst' = getInstance' m cEnv tcEnv inst
+ = let inst0 = getInstance' m cEnv tcEnv inst
+ inst' = fromJust inst0
thisContext = getContextFromInst inst'
scs = allSuperClasses cEnv (getCanonClassName m cEnv cls)
tyId = tyConToQualIdent m tcEnv ty
@@ -810,8 +811,9 @@ checkInstanceContextImpliesAllInstanceContextsOfSuperClasses cEnv tcEnv m
instCxs' = getSContextFromContext instCxs (typeVars inst')
notImplCxs = (filter (not . implies cEnv thisContext) instCxs)
notImplCxs' = getSContextFromContext notImplCxs (typeVars inst') in
- when (isJust tyId) $ unless (implies' cEnv thisContext instCxs) $ report $
- errContextNotImplied p thisContext' instCxs' notImplCxs'
+ -- catch the case that there are duplicate local instances
+ when (isJust tyId && isJust inst0) $ unless (implies' cEnv thisContext instCxs) $
+ report $ errContextNotImplied p thisContext' instCxs' notImplCxs'
checkInstanceContextImpliesAllInstanceContextsOfSuperClasses _ _ _ _
= internalError "checkInstanceContextImpliesAllInstanceContextsOfSuperClasses"
diff --git a/test/test2.sh b/test/test2.sh
index 91c57fea..752f03d9 100644
--- a/test/test2.sh
+++ b/test/test2.sh
@@ -62,7 +62,8 @@ for file in checkCorrectTypeVarsInTypeSigs CheckRulesInClass CheckRulesInInstanc
ContextImplication ContextsInClassMethodTypeSigs Cycles directCycle \
doubleClassMethods duplicateClassNames duplicateInstances InstanceConstraints \
instanceDataTypeCorrect InstanceTypeVarsDoNotAppearTwice SuperclassInstances \
- typeVarsInInstContext typeVarsInTySigContext TyVarInContext AmbiguousInstancesUse
+ typeVarsInInstContext typeVarsInTySigContext TyVarInContext AmbiguousInstancesUse \
+ DuplicateInstances2
do
echo $file >> tmp.txt
if [ ! -r typeclasses/TCCheck/$file.curry ]; then echo "*********** file doesn't exist: $file"; fi
diff --git a/test/typeclasses/TCCheck/DuplicateInstances2.curry b/test/typeclasses/TCCheck/DuplicateInstances2.curry
new file mode 100644
index 00000000..168603de
--- /dev/null
+++ b/test/typeclasses/TCCheck/DuplicateInstances2.curry
@@ -0,0 +1,15 @@
+
+class C a where
+
+class C a => D a where
+
+data T a = T a
+
+class F a where
+
+instance F a => C (T a) where
+
+instance F a => D (T a) where
+
+instance F a => D (T a) where
+
--
GitLab