Fix #11230.
authorRichard Eisenberg <eir@cis.upenn.edu>
Tue, 15 Dec 2015 22:36:32 +0000 (17:36 -0500)
committerRichard Eisenberg <eir@cis.upenn.edu>
Thu, 17 Dec 2015 17:58:29 +0000 (12:58 -0500)
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

compiler/coreSyn/CoreSubst.hs
testsuite/tests/indexed-types/should_compile/T7837.stderr
testsuite/tests/typecheck/should_run/T11230.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_run/T11230.stdout [new file with mode: 0644]
testsuite/tests/typecheck/should_run/all.T

index 0668816..e77886b 100644 (file)
@@ -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
index 838a8fb..a4d96b1 100644 (file)
@@ -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 (file)
index 0000000..769b6ba
--- /dev/null
@@ -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 (file)
index 0000000..b0ccf01
--- /dev/null
@@ -0,0 +1,2 @@
+representational(Success): exception found
+phantom(Success): exception found
index def9ede..1c4f234 100755 (executable)
@@ -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, [''])