[commit: ghc] master: Don't report instance constraints with fundeps as redundant (10fab31)
git at git.haskell.org
git at git.haskell.org
Fri Feb 20 08:48:04 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/10fab31211961c9200d230556ec7742e07a6c831/ghc
>---------------------------------------------------------------
commit 10fab31211961c9200d230556ec7742e07a6c831
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu Feb 19 23:14:17 2015 +0000
Don't report instance constraints with fundeps as redundant
More subtlety due to functional dependencies.
Note [Redundant constraints in instance decls] in TcErrors.
Fixes Trac #10100.
>---------------------------------------------------------------
10fab31211961c9200d230556ec7742e07a6c831
compiler/typecheck/TcCanonical.hs | 12 +--------
compiler/typecheck/TcErrors.hs | 30 ++++++++++++++++++---
compiler/typecheck/TcType.hs | 31 +++++++++++++++-------
compiler/types/Class.hs | 5 +++-
testsuite/tests/typecheck/should_compile/T10100.hs | 13 +++++++++
testsuite/tests/typecheck/should_compile/all.T | 1 +
6 files changed, 68 insertions(+), 24 deletions(-)
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index b87e257..0b88200 100644
--- a/compiler/typecheck/TcCanonical.hs
+++ b/compiler/typecheck/TcCanonical.hs
@@ -364,21 +364,11 @@ newSCWorkFromFlavored flavor cls xis
| otherwise -- Wanted case, just add those SC that can lead to improvement.
= do { let sc_rec_theta = transSuperClasses cls xis
- impr_theta = filter is_improvement_pty sc_rec_theta
+ impr_theta = filter isImprovementPred sc_rec_theta
loc = ctEvLoc flavor
; traceTcS "newSCWork/Derived" $ text "impr_theta =" <+> ppr impr_theta
; mapM_ (emitNewDerived loc) impr_theta }
-is_improvement_pty :: PredType -> Bool
--- Either it's an equality, or has some functional dependency
-is_improvement_pty ty = go (classifyPredType ty)
- where
- go (EqPred NomEq t1 t2) = not (t1 `tcEqType` t2)
- go (EqPred ReprEq _ _) = False
- go (ClassPred cls _tys) = not $ null fundeps
- where (_,fundeps) = classTvsFds cls
- go (TuplePred ts) = any is_improvement_pty ts
- go (IrredPred {}) = True -- Might have equalities after reduction?
{-
************************************************************************
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 6b9be01..7a61e19 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -240,7 +240,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
warnRedundantConstraints ctxt env info ev_vars
- | null ev_vars
+ | null redundant_evs
= return ()
| SigSkol {} <- info
@@ -257,8 +257,32 @@ warnRedundantConstraints ctxt env info ev_vars
= do { msg <- mkErrorMsg ctxt env doc
; reportWarning msg }
where
- doc = ptext (sLit "Redundant constraint") <> plural ev_vars <> colon
- <+> pprEvVarTheta ev_vars
+ doc = ptext (sLit "Redundant constraint") <> plural redundant_evs <> colon
+ <+> pprEvVarTheta redundant_evs
+
+ redundant_evs = case info of -- See Note [Redundant constraints in instance decls]
+ InstSkol -> filterOut improving ev_vars
+ _ -> ev_vars
+
+ improving ev_var = any isImprovementPred $
+ transSuperClassesPred (idType ev_var)
+
+{- Note [Redundant constraints in instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For instance declarations, we don't report unused givens if
+they can give rise to improvement. Example (Trac #10100):
+ class Add a b ab | a b -> ab, a ab -> b
+ instance Add Zero b b
+ instance Add a b ab => Add (Succ a) b (Succ ab)
+The context (Add a b ab) for the instance is clearly unused in terms
+of evidence, since the dictionary has no feilds. But it is still
+needed! With the context, a wanted constraint
+ Add (Succ Zero) beta (Succ Zero)
+we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.
+But without the context we won't find beta := Zero.
+
+This only matters in instance declarations..
+-}
reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
reportWanteds ctxt (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index d6fadc7..cf6836b 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -80,7 +80,9 @@ module TcType (
---------------------------------
-- Predicate types
- mkMinimalBySCs, transSuperClasses, immSuperClasses,
+ mkMinimalBySCs, transSuperClasses, transSuperClassesPred,
+ immSuperClasses,
+ isImprovementPred,
-- * Finding type instances
tcTyFamInsts,
@@ -1346,14 +1348,15 @@ mkMinimalBySCs ptys = [ ploc | ploc <- ptys
transSuperClasses :: Class -> [Type] -> [PredType]
transSuperClasses cls tys -- Superclasses of (cls tys),
-- excluding (cls tys) itself
- = concatMap trans_sc (immSuperClasses cls tys)
- where
- trans_sc :: PredType -> [PredType]
- -- (trans_sc p) returns (p : p's superclasses)
- trans_sc p = case classifyPredType p of
- ClassPred cls tys -> p : transSuperClasses cls tys
- TuplePred ps -> concatMap trans_sc ps
- _ -> [p]
+ = concatMap transSuperClassesPred (immSuperClasses cls tys)
+
+transSuperClassesPred :: PredType -> [PredType]
+-- (transSuperClassesPred p) returns (p : p's superclasses)
+transSuperClassesPred p
+ = case classifyPredType p of
+ ClassPred cls tys -> p : transSuperClasses cls tys
+ TuplePred ps -> concatMap transSuperClassesPred ps
+ _ -> [p]
immSuperClasses :: Class -> [Type] -> [PredType]
immSuperClasses cls tys
@@ -1361,6 +1364,16 @@ immSuperClasses cls tys
where
(tyvars,sc_theta,_,_) = classBigSig cls
+isImprovementPred :: PredType -> Bool
+-- Either it's an equality, or has some functional dependency
+isImprovementPred ty
+ = case classifyPredType ty of
+ EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2)
+ EqPred ReprEq _ _ -> False
+ ClassPred cls _ -> classHasFds cls
+ TuplePred ts -> any isImprovementPred ts
+ IrredPred {} -> True -- Might have equalities after reduction?
+
{-
************************************************************************
* *
diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs
index d51da7e..787ab6d 100644
--- a/compiler/types/Class.hs
+++ b/compiler/types/Class.hs
@@ -17,7 +17,7 @@ module Class (
mkClass, classTyVars, classArity,
classKey, className, classATs, classATItems, classTyCon, classMethods,
classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
- classAllSelIds, classSCSelId, classMinimalDef
+ classAllSelIds, classSCSelId, classMinimalDef, classHasFds
) where
#include "HsVersions.h"
@@ -235,6 +235,9 @@ classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
classTvsFds c
= (classTyVars c, classFunDeps c)
+classHasFds :: Class -> Bool
+classHasFds (Class { classFunDeps = fds }) = not (null fds)
+
classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
classSCSels = sc_sels, classOpStuff = op_stuff})
diff --git a/testsuite/tests/typecheck/should_compile/T10100.hs b/testsuite/tests/typecheck/should_compile/T10100.hs
new file mode 100644
index 0000000..b88803c
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T10100.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T10100 where
+
+data Zero
+data Succ a
+
+class Add a b ab | a b -> ab, a ab -> b
+instance Add Zero b b
+instance (Add a b ab) => Add (Succ a) b (Succ ab)
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index b792629..c1ed579 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -443,3 +443,4 @@ test('T9971', normal, compile, [''])
test('T9999', normal, compile, [''])
test('T10031', normal, compile, [''])
test('T10072', normal, compile_fail, [''])
+test('T10100', normal, compile, [''])
More information about the ghc-commits
mailing list