Commit 1722fa10 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

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
parent ae86eb9f
......@@ -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
......
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
{-# 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
representational(Success): exception found
phantom(Success): exception found
......@@ -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, [''])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment