[commit: ghc] master: Fix Trac #9973 (buglet in -fwarn-redundant-constraints) (dd3e1dd)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/dd3e1dd7f8d81e2585a7d63c06c1a1501810fcaa/ghc

>---------------------------------------------------------------

commit dd3e1dd7f8d81e2585a7d63c06c1a1501810fcaa
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jan 9 16:45:03 2015 +0000

    Fix Trac #9973 (buglet in -fwarn-redundant-constraints)


>---------------------------------------------------------------

dd3e1dd7f8d81e2585a7d63c06c1a1501810fcaa
 compiler/typecheck/TcSimplify.hs                  | 35 ++++++++++++++---------
 testsuite/tests/typecheck/should_compile/T9973.hs | 22 ++++++++++++++
 testsuite/tests/typecheck/should_compile/all.T    |  1 +
 3 files changed, 44 insertions(+), 14 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index b226fde..75abf0a 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -906,16 +906,17 @@ setImplicationStatus :: Implication -> TcS (Maybe Implication)
 -- Return Nothing if we can discard the implication altogether
 setImplicationStatus implic@(Implic { ic_binds = EvBindsVar ev_binds_var _
                                     , ic_info = info
-                                    , ic_wanted = wc, ic_given = givens })
+                                    , ic_wanted = wc
+                                    , ic_given = givens })
  | some_insoluble
  = return $ Just $
    implic { ic_status = IC_Insoluble
-          , ic_wanted = trimmed_wc }
+          , ic_wanted = wc { wc_simple = pruned_simples } }
 
  | some_unsolved
  = return $ Just $
    implic { ic_status = IC_Unsolved
-          , ic_wanted = trimmed_wc }
+          , ic_wanted = wc { wc_simple = pruned_simples } }
 
  | otherwise  -- Everything is solved; look at the implications
               -- See Note [Tracking redundant constraints]
@@ -928,27 +929,33 @@ setImplicationStatus implic@(Implic { ic_binds = EvBindsVar ev_binds_var _
 
             final_needs = all_needs `delVarSetList` givens
 
-            discard_implic  -- Can we discard the entire implication?
+            discard_entire_implication  -- Can we discard the entire implication?
               =  null dead_givens           -- No warning from this implication
-              && isEmptyBag keep_implics    -- No live children
+              && isEmptyBag pruned_implics  -- No live children
               && isEmptyVarSet final_needs  -- No needed vars to pass up to parent
 
-            final_implic = implic { ic_status = IC_Solved { ics_need = final_needs
-                                                          , ics_dead = dead_givens }
-                                  , ic_wanted = trimmed_wc }
-
-      ; return $ if discard_implic then Nothing else Just final_implic }
+            final_status = IC_Solved { ics_need = final_needs
+                                     , ics_dead = dead_givens }
+            final_implic = implic { ic_status = final_status
+                                  , ic_wanted = wc { wc_simple = pruned_simples
+                                                   , wc_impl   = pruned_implics } }
+               -- We can only prune the child implications (pruned_implics)
+               -- in the IC_Solved status case, because only then we can
+               -- accumulate their needed evidence variales into the
+               -- IC_Solved final_status field of the parent implication.
+
+      ; return $ if discard_entire_implication
+                 then Nothing
+                 else Just final_implic }
  where
    WC { wc_simple = simples, wc_impl = implics, wc_insol = insols } = wc
-   trimmed_wc = wc { wc_simple = drop_der_simples
-                   , wc_impl   = keep_implics }
 
    some_insoluble = insolubleWC wc
    some_unsolved = not (isEmptyBag simples && isEmptyBag insols)
                  || isNothing mb_implic_needs
 
-   drop_der_simples = filterBag isWantedCt simples
-   keep_implics     = filterBag need_to_keep_implic implics
+   pruned_simples = filterBag isWantedCt simples  -- Drop Derived constraints
+   pruned_implics = filterBag need_to_keep_implic implics
 
    mb_implic_needs :: Maybe VarSet
         -- Just vs => all implics are IC_Solved, with 'vs' needed
diff --git a/testsuite/tests/typecheck/should_compile/T9973.hs b/testsuite/tests/typecheck/should_compile/T9973.hs
new file mode 100644
index 0000000..1a2148f
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T9973.hs
@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fwarn-redundant-constraints #-}
+
+module T9973 where
+
+duplicateDecl :: (Eq t) => t -> IO ()
+-- Trac #9973 was a bogus "redundant constraint" here
+duplicateDecl sigs
+ = do { newSpan <- return typeSig
+
+         -- **** commenting out the next three lines causes the original warning to disappear
+       ; let rowOffset = case typeSig of {  _  -> 1 }
+
+       ; undefined }
+   where
+     typeSig = definingSigsNames sigs
+
+
+definingSigsNames :: (Eq t) => t -> ()
+definingSigsNames x = undefined
+  where
+    _ = x == x   -- Suppress the complaint on this
+
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 0860a35..2cf1755 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -438,4 +438,5 @@ test('T7643', normal, compile, [''])
 test('T9834', normal, compile, [''])
 test('T9892', normal, compile, [''])
 test('T9939', normal, compile, [''])
+test('T9973', normal, compile, [''])