[GHC] #11230: No run-time exception for deferred type errors when error is in a phantom role position

[GHC]

#11230: No run-time exception for deferred type errors when error is in a phantom
role position
-------------------------------------+-------------------------------------
           Reporter:  darchon        |             Owner:
               Type:  bug            |            Status:  new
           Priority:  normal         |         Milestone:  8.0.1
          Component:  Compiler       |           Version:  7.11
           Keywords:  deferred,      |  Operating System:  Unknown/Multiple
  roles                              |
       Architecture:                 |   Type of failure:  Incorrect result
  Unknown/Multiple                   |  at runtime
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 The following code:

 {{{#!hs
 {-# LANGUAGE RoleAnnotations #-}
 {-# OPTIONS_GHC -fdefer-type-errors #-}

 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!")
 -- #if MIN_VERSION_base(4,9,0)
     Left (TypeError msg) -> putStrLn (c ++ "(Succes): exception found")
 -- #else
 --     Left (ErrorCall _) -> putStrLn "Succes: exception found"
 -- #endif

 main = do
   throwsException "representational" testRepresentational
   throwsException "phantom" testPhantom
 }}}

 Produces the following result in HEAD:

 {{{
 representational(Succes): exception found
 *** Exception: phantom (Failure): No exception!
 CallStack (from ImplicitParams):
   error, called at Main.hs:24:16 in main:Main
 }}}

 In 7.10.2 (after commenting the `TypeError` line, and uncommenting the
 `ErrorCall` line), we get the following output:

 {{{
 Succes: exception found
 Succes: exception found
 }}}

 I think the HEAD result is wrong: deferred type errors should always
 result in a run-time exception when their associated value is evaluated,
 regardless of whether the error occurred in a phantom role position or
 not.

 Looking at the core (`ghc -O0 -ddump-simpl`) in HEAD is see:

 {{{
 -- RHS size: {terms: 3, types: 15, coercions: 0}
 testRepresentational_rqP
   :: Representational Char -> Representational Bool
 [GblId, Str=DmdType b]
 testRepresentational_rqP =
   case typeError
          @ 'Unlifted
          @ (Char ~# Bool)
          "Main.hs:13:24: error:\n\
          \    \\226\\128\\162 Couldn't match type
 \\226\\128\\152Char\\226\\128\\153 with
 \\226\\128\\152Bool\\226\\128\\153\n\
          \      Expected type: Representational Char -> Representational
 Bool\n\
          \        Actual type: Representational Bool -> Representational
 Bool\n\
          \    \\226\\128\\162 In the expression: id\n\
          \      In an equation for
 \\226\\128\\152testRepresentational\\226\\128\\153:\n\
          \          testRepresentational = id\n\
          \(deferred type error)"#
   of wild0_00 {
   }

 -- RHS size: {terms: 1, types: 2, coercions: 10}
 testPhantom_rqQ :: Phantom Char -> Phantom Bool
 [GblId, Str=DmdType]
 testPhantom_rqQ =
   (id @ (Phantom Bool))
   `cast` ((Phantom <Bool, Char>_P{<*>_N})_R -> <Phantom Bool>_R
           :: (Phantom Bool -> Phantom Bool)
              ~R# (Phantom Char -> Phantom Bool))
 }}}

 while in 7.10.2 I see:

 {{{
 testRepresentational_rnc
   :: Representational Char -> Representational Bool
 [GblId, Str=DmdType b]
 testRepresentational_rnc =
   case Control.Exception.Base.runtimeError
          @ (Char ~ Bool)
          "Main.hs:13:24:\n\
          \    Couldn't match type \\226\\128\\152Char\\226\\128\\153 with
 \\226\\128\\152Bool\\226\\128\\153\n\
          \    Expected type: Representational Char -> Representational
 Bool\n\
          \      Actual type: Representational Bool -> Representational
 Bool\n\
          \    In the expression: id\n\
          \    In an equation for
 \\226\\128\\152testRepresentational\\226\\128\\153:\n\
          \        testRepresentational = id\n\
          \(deferred type error)"#
   of wild_00 {
   }

 testPhantom_rnd :: Phantom Char -> Phantom Bool
 [GblId, Str=DmdType b]
 testPhantom_rnd =
   case Control.Exception.Base.runtimeError
          @ (Char ~ Bool)
          "Main.hs:17:15:\n\
          \    Couldn't match type \\226\\128\\152Char\\226\\128\\153 with
 \\226\\128\\152Bool\\226\\128\\153\n\
          \    Expected type: Phantom Char -> Phantom Bool\n\
          \      Actual type: Phantom Bool -> Phantom Bool\n\
          \    In the expression: id\n\
          \    In an equation for
 \\226\\128\\152testPhantom\\226\\128\\153: testPhantom = id\n\
          \(deferred type error)"#
   of wild_00 {
   }
 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/11230>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler