[commit: ghc] master: Kill inaccessible-branch complaints in record update (3cfef76)

[git at git.haskell.org]

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

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

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

commit 3cfef763ab6ccd23f72604e5ee2f027a4b6ce043
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Feb 8 16:12:36 2017 +0000

    Kill inaccessible-branch complaints in record update
    
    Trac #12957 (the original case in the Description) showed a record
    update that yielded an "inaccessible code" warning. This should not
    happen; it's just some redundant code generated by the desugarer (later
    pruned away) and it's not the user's fault.
    
    This patch suppresses the warning.  See Check.hs
    Note [Inaccessible warnings for record updates]


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

3cfef763ab6ccd23f72604e5ee2f027a4b6ce043
 compiler/deSugar/Check.hs                         | 28 +++++++++++++++++++++--
 testsuite/tests/pmcheck/should_compile/T12957a.hs | 25 ++++++++++++++++++++
 testsuite/tests/pmcheck/should_compile/all.T      |  1 +
 3 files changed, 52 insertions(+), 2 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 3bf52ce..4a8a18d 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -51,7 +51,6 @@ import Control.Monad (forM, when, forM_)
 import Coercion
 import TcEvidence
 import IOEnv
-import Data.Monoid   ( Monoid(mappend) )
 
 import ListT (ListT(..), fold, select)
 
@@ -1606,7 +1605,7 @@ dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()
 dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
   = when (flag_i || flag_u) $ do
       let exists_r = flag_i && notNull redundant && onlyBuiltin
-          exists_i = flag_i && notNull inaccessible && onlyBuiltin
+          exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd
           exists_u = flag_u && (case uncovered of
                                   TypeOfUncovered   _ -> True
                                   UncoveredPatterns u -> notNull u)
@@ -1632,6 +1631,9 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
     flag_u = exhaustive dflags kind
     flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
 
+    is_rec_upd = case kind of { RecUpd -> True; _ -> False }
+       -- See Note [Inaccessible warnings for record updates]
+
     onlyBuiltin = prov == FromBuiltin
 
     maxPatterns = maxUncoveredPatterns dflags
@@ -1654,6 +1656,28 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
     warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ ->
       hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)
 
+{- Note [Inaccessible warnings for record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #12957)
+  data T a where
+    T1 :: { x :: Int } -> T Bool
+    T2 :: { x :: Int } -> T a
+    T3 :: T a
+
+  f :: T Char -> T a
+  f r = r { x = 3 }
+
+The desugarer will (conservatively generate a case for T1 even though
+it's impossible:
+  f r = case r of
+          T1 x -> T1 3   -- Inaccessible branch
+          T2 x -> T2 3
+          _    -> error "Missing"
+
+We don't want to warn about the inaccessible branch because the programmer
+didn't put it there!  So we filter out the warning here.
+-}
+
 -- | Issue a warning when the predefined number of iterations is exceeded
 -- for the pattern match checker
 warnPmIters :: DynFlags -> DsMatchContext -> DsM ()
diff --git a/testsuite/tests/pmcheck/should_compile/T12957a.hs b/testsuite/tests/pmcheck/should_compile/T12957a.hs
new file mode 100644
index 0000000..72330e9
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/T12957a.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+
+-- The original test case for Trac #12957
+
+module T12957a where
+
+data T = A | B
+
+data Fields (t :: T) where
+  BFields :: { list :: [()] } -> Fields 'B
+
+  AFields :: Fields 'A
+
+  EmptyFields :: Fields t
+
+emptyA :: Fields 'A
+emptyA = AFields
+
+data S t = S { sFields :: Fields t }
+
+f :: () -> S 'A
+f a = (S EmptyFields) { sFields = emptyA { list = [ a ] } }
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 7fc4fc5..8745358 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -60,6 +60,7 @@ test('pmc007', [], compile,
 test('T11245', [], compile,
      ['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
 test('T12957', [], compile, ['-fwarn-overlapping-patterns'])
+test('T12957a', [], compile, ['-fwarn-overlapping-patterns'])
 
 # EmptyCase
 test('T10746', [], compile,