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.

6 files changed, 68 insertions, 24 deletions

diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
index b87e257628..0b8820091b 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 6b9be0112f..7a61e19892 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 d6fadc70f6..cf6836be75 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 d51da7e054..787ab6dad7 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 0000000000..b88803c633
--- /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 b792629b42..c1ed5790b4 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, [''])