[commit: ghc] master: Fix #11230. (1722fa1)

[git at git.haskell.org]

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

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

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

commit 1722fa106e10e63160bb2322e2ccb830fd5b9ab3
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Tue Dec 15 17:36:32 2015 -0500

    Fix #11230.
    
    Previously, we were optimizing away all case expressions over
    coercions with dead binders. But sometimes we want to force
    the coercion expression. Like when it contains an error.
    
    Test case: typecheck/should_run/T11230


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

1722fa106e10e63160bb2322e2ccb830fd5b9ab3
 compiler/coreSyn/CoreSubst.hs                      | 11 ++++----
 .../indexed-types/should_compile/T7837.stderr      |  3 +++
 testsuite/tests/typecheck/should_run/T11230.hs     | 31 ++++++++++++++++++++++
 testsuite/tests/typecheck/should_run/T11230.stdout |  2 ++
 testsuite/tests/typecheck/should_run/all.T         |  1 +
 5 files changed, 42 insertions(+), 6 deletions(-)

diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index 0668816..e77886b 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -56,8 +56,7 @@ import Coercion hiding ( substCo, substCoVarBndr )
 
 import TyCon       ( tyConArity )
 import DataCon
-import PrelNames   ( heqDataConKey, coercibleDataConKey, unpackCStringIdKey
-                   , unpackCStringUtf8IdKey )
+import PrelNames
 import OptCoercion ( optCoercion )
 import PprCore     ( pprCoreBindings, pprRules )
 import Module      ( Module )
@@ -67,7 +66,6 @@ import Id
 import Name     ( Name )
 import Var
 import IdInfo
-import Unique
 import UniqSupply
 import Maybes
 import ErrUtils
@@ -840,9 +838,7 @@ separate actions:
      is made in maybe_substitute. Note the rather specific check for
      MkCoercible in there.
 
-  2. Stripping silly case expressions, like the Coercible_SCSel one.
-     A case expression is silly if its binder is dead, it has only one,
-     DEFAULT, alternative, and the scrutinee is a coercion.
+  2. Stripping case expressions like the Coercible_SCSel one.
      See the `Case` case of simple_opt_expr's `go` function.
 
   3. Look for case expressions that unpack something that was
@@ -952,6 +948,9 @@ simple_opt_expr subst expr
       | isDeadBinder b
       , [(DEFAULT, _, rhs)] <- as
       , isCoercionType (varType b)
+      , (Var fun, _args) <- collectArgs e
+      , fun `hasKey` coercibleSCSelIdKey
+         -- without this last check, we get #11230
       = go rhs
 
       | otherwise
diff --git a/testsuite/tests/indexed-types/should_compile/T7837.stderr b/testsuite/tests/indexed-types/should_compile/T7837.stderr
index 838a8fb..a4d96b1 100644
--- a/testsuite/tests/indexed-types/should_compile/T7837.stderr
+++ b/testsuite/tests/indexed-types/should_compile/T7837.stderr
@@ -1,3 +1,6 @@
 Rule fired: Class op signum
 Rule fired: Class op abs
 Rule fired: normalize/Double
+Rule fired: Class op HEq_sc
+Rule fired: Class op HEq_sc
+Rule fired: Class op HEq_sc
diff --git a/testsuite/tests/typecheck/should_run/T11230.hs b/testsuite/tests/typecheck/should_run/T11230.hs
new file mode 100644
index 0000000..769b6ba
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T11230.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE RoleAnnotations #-}
+{-# OPTIONS_GHC -fdefer-type-errors #-}
+
+module Main where
+
+import Control.Exception
+
+newtype Representational a = Representational ()
+type role Representational representational
+
+newtype Phantom a = Phantom ()
+type role Phantom phantom
+
+testRepresentational :: Representational Char -> Representational Bool
+testRepresentational = id
+{-# NOINLINE testRepresentational #-}
+
+testPhantom :: Phantom Char -> Phantom Bool
+testPhantom = id
+{-# NOINLINE testPhantom #-}
+
+throwsException :: String -> a -> IO ()
+throwsException c v = do
+  result <- try (evaluate v)
+  case result of
+    Right _ -> error (c ++ " (Failure): No exception!")
+    Left (TypeError _) -> putStrLn (c ++ "(Success): exception found")
+
+main = do
+  throwsException "representational" testRepresentational
+  throwsException "phantom" testPhantom
diff --git a/testsuite/tests/typecheck/should_run/T11230.stdout b/testsuite/tests/typecheck/should_run/T11230.stdout
new file mode 100644
index 0000000..b0ccf01
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T11230.stdout
@@ -0,0 +1,2 @@
+representational(Success): exception found
+phantom(Success): exception found
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index def9ede..1c4f234 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -111,3 +111,4 @@ test('T9497c-run', [exit_code(1)], compile_and_run, ['-fdefer-type-errors -fno-w
 test('T9858c', normal, compile_and_run, [''])
 test('T9858d', normal, compile_and_run, [''])
 test('T10284', exit_code(1), compile_and_run, [''])
+test('T11230', normal, compile_and_run, [''])