[commit: ghc] master: Don't report fundep wanted/wanted errors (48daaaf)
git at git.haskell.org
git at git.haskell.org
Thu Apr 6 11:34:22 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/48daaaf0bba279b6e362ee5c632de69ed31ab65d/ghc
>---------------------------------------------------------------
commit 48daaaf0bba279b6e362ee5c632de69ed31ab65d
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Apr 5 13:37:28 2017 +0100
Don't report fundep wanted/wanted errors
This makes GHC drop derived FunDep errors when they
are come from wanted/wanted interactions. Much along
the lines of "don't rewrite wanteds with wanteds".
See TcRnTypes Note [Dropping derived constraints]
and the new code in isDroppableDerivedLoc.
Fixes Trac #13506.
>---------------------------------------------------------------
48daaaf0bba279b6e362ee5c632de69ed31ab65d
compiler/typecheck/TcRnTypes.hs | 53 ++++++++++++----------
testsuite/tests/typecheck/should_fail/T13506.hs | 26 +++++++++++
.../tests/typecheck/should_fail/T13506.stderr | 8 ++++
testsuite/tests/typecheck/should_fail/all.T | 1 +
4 files changed, 64 insertions(+), 24 deletions(-)
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 90423e4..c004052 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -1822,25 +1822,30 @@ isDroppableDerivedLoc loc
HoleOrigin {} -> False
KindEqOrigin {} -> False
GivenOrigin {} -> False
- FunDepOrigin1 {} -> False
+
+ -- See Note [Dropping derived constraints
+ -- For fundeps, drop wanted/warnted interactions
FunDepOrigin2 {} -> False
- _ -> True
+ FunDepOrigin1 _ loc1 _ loc2
+ | isGivenLoc loc1 || isGivenLoc loc2 -> False
+ | otherwise -> True
+ _ -> True
arisesFromGivens :: Ct -> Bool
arisesFromGivens ct
= case ctEvidence ct of
- CtGiven {} -> True
- CtWanted {} -> False
- CtDerived { ctev_loc = loc } -> from_given loc
- where
- from_given :: CtLoc -> Bool
- from_given loc = from_given_origin (ctLocOrigin loc)
+ CtGiven {} -> True
+ CtWanted {} -> False
+ CtDerived { ctev_loc = loc } -> isGivenLoc loc
- from_given_origin :: CtOrigin -> Bool
- from_given_origin (GivenOrigin {}) = True
- from_given_origin (FunDepOrigin1 _ l1 _ l2) = from_given l1 && from_given l2
- from_given_origin (FunDepOrigin2 _ o1 _ _) = from_given_origin o1
- from_given_origin _ = False
+isGivenLoc :: CtLoc -> Bool
+isGivenLoc loc = isGivenOrigin (ctLocOrigin loc)
+
+isGivenOrigin :: CtOrigin -> Bool
+isGivenOrigin (GivenOrigin {}) = True
+isGivenOrigin (FunDepOrigin1 _ l1 _ l2) = isGivenLoc l1 && isGivenLoc l2
+isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1
+isGivenOrigin _ = False
{- Note [Dropping derived constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1856,19 +1861,19 @@ see dropDerivedWC. For example
But (tiresomely) we do keep *some* Derived insolubles:
- * Insoluble kind equalities (e.g. [D] * ~ (* -> *)) may arise from
- a type equality a ~ Int#, say. In future they'll be Wanted, not Derived,
- but at the moment they are Derived.
+ * Type holes are derived constraints because they have no evidence
+ and we want to keep them so we get the error report
* Insoluble derived equalities (e.g. [D] Int ~ Bool) may arise from
- functional dependency interactions, either between Givens or
- Wanteds. It seems sensible to retain these:
- - For Givens they reflect unreachable code
- - For Wanteds it is arguably better to get a fundep error than
- a no-instance error (Trac #9612)
+ functional dependency interactions:
+ - Given or Wanted interacting with an instance declaration (FunDepOrigin2)
+ - Given/Given interactions (FunDepOrigin1); this reflects unreachable code
+ - Given/Wanted interactions (FunDepOrigin1); see Trac #9612
- * Type holes are derived constraints because they have no evidence
- and we want to keep them so we get the error report
+ But for Wanted/Wanted interactions we do /not/ want to report an
+ error (Trac #13506). Consider [W] C Int Int, [W] C Int Bool, with
+ a fundep on class C. We don't want to report an insoluble Int~Bool;
+ c.f. "wanteds do not rewrite wanteds".
Moreover, we keep *all* derived insolubles under some circumstances:
@@ -1876,7 +1881,7 @@ Moreover, we keep *all* derived insolubles under some circumstances:
generalise. Example: [W] a ~ Int, [W] a ~ Bool
We get [D] Int ~ Bool, and indeed the constraints are insoluble,
and we want simplifyInfer to see that, even though we don't
- ultimately want to generate an (inexplicable) error message from
+ ultimately want to generate an (inexplicable) error message from it
To distinguish these cases we use the CtOrigin.
diff --git a/testsuite/tests/typecheck/should_fail/T13506.hs b/testsuite/tests/typecheck/should_fail/T13506.hs
new file mode 100644
index 0000000..84e8fa9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13506.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses #-}
+module Bug where
+
+class FunDep lista a | lista -> a
+instance FunDep [a] a
+
+singleton :: FunDep lista a => a -> lista
+singleton _ = undefined
+
+-- this error is expected:
+-- Couldn't match type 'Char' with '()'
+-- arising from a functional dependency between
+-- constraint 'FunDep [Char] ()' arising from a use of 'singleton'
+-- instance 'FunDep [a] a'
+illTyped :: [Char]
+illTyped = singleton ()
+ {- [W] FunDep [Char] () -}
+
+-- but this one is not:
+-- Couldn't match type '()' with 'Char'
+-- arising from a functional dependency between constraints:
+-- 'FunDep [Char] Char' arising from a use of 'singleton' (in 'wellTyped')
+-- 'FunDep [Char] ()' arising from a use of 'singleton' (in 'illTyped')
+wellTyped :: [Char]
+wellTyped = singleton 'a'
+ {- [W] FunDep [Char] Char -}
diff --git a/testsuite/tests/typecheck/should_fail/T13506.stderr b/testsuite/tests/typecheck/should_fail/T13506.stderr
new file mode 100644
index 0000000..50ea1b2
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13506.stderr
@@ -0,0 +1,8 @@
+
+T13506.hs:16:12: error:
+ • Couldn't match type ‘Char’ with ‘()’
+ arising from a functional dependency between:
+ constraint ‘FunDep [Char] ()’ arising from a use of ‘singleton’
+ instance ‘FunDep [a] a’ at T13506.hs:5:10-21
+ • In the expression: singleton ()
+ In an equation for ‘illTyped’: illTyped = singleton ()
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 8fbe141..41c379e 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -431,3 +431,4 @@ test('T13292', normal, multimod_compile, ['T13292', '-v0 -fdefer-type-errors'])
test('T13300', normal, compile_fail, [''])
test('T12709', normal, compile_fail, [''])
test('T13446', normal, compile_fail, [''])
+test('T13506', normal, compile_fail, [''])
More information about the ghc-commits
mailing list