Deferred type errors now throw TypeError (#10284)

Depends on D864.

Previous behaviour was ErrorCall, which might mask issues in tests 
using -fdefer-type-errors

Signed-off-by: David Kraeutmann <kane@kane.cx>

Test Plan: Test whether the error thrown is indeed TypeError and not 
ErrorCall.

Reviewers: hvr, nomeata, austin

Reviewed By: nomeata, austin

Subscribers: nomeata, simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D866

GHC Trac Issues: #10284

10 files changed, 64 insertions, 12 deletions

diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 3b76aef36d..4d310c9552 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -48,7 +48,7 @@ module MkCore (
         rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
         nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
         pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
-        uNDEFINED_ID, undefinedName
+        uNDEFINED_ID, tYPE_ERROR_ID, undefinedName
     ) where
 
 #include "HsVersions.h"
@@ -666,11 +666,14 @@ errorIds
       pAT_ERROR_ID,
       rEC_CON_ERROR_ID,
       rEC_SEL_ERROR_ID,
-      aBSENT_ERROR_ID ]
+      aBSENT_ERROR_ID,
+      tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
+      ]
 
 recSelErrorName, runtimeErrorName, absentErrorName :: Name
 irrefutPatErrorName, recConErrorName, patErrorName :: Name
 nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
+typeErrorName :: Name
 
 recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
 absentErrorName     = err_nm "absentError"     absentErrorIdKey     aBSENT_ERROR_ID
@@ -678,6 +681,7 @@ runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERRO
 irrefutPatErrorName = err_nm "irrefutPatError" irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
 recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID
 patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID
+typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID
 
 noMethodBindingErrorName     = err_nm "noMethodBindingError"
                                   noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
@@ -689,6 +693,7 @@ err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id
 
 rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
 pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
+tYPE_ERROR_ID :: Id
 aBSENT_ERROR_ID :: Id
 rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
 rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
@@ -698,6 +703,7 @@ pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
 nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
 nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
 aBSENT_ERROR_ID                 = mkRuntimeErrorId absentErrorName
+tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName
 
 mkRuntimeErrorId :: Name -> Id
 mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 2ab9f24bd7..e5c787a478 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -854,7 +854,7 @@ dsEvTerm (EvSuperClass d n)
 
 dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
   where
-    errorId = rUNTIME_ERROR_ID
+    errorId = tYPE_ERROR_ID
     litMsg  = Lit (MachStr (fastStringToByteString msg))
 
 dsEvTerm (EvLit l) =
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 7a6c87e755..570ec071b0 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -1634,7 +1634,9 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
     runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,
     realWorldPrimIdKey, recConErrorIdKey,
     unpackCStringUtf8IdKey, unpackCStringAppendIdKey,
-    unpackCStringFoldrIdKey, unpackCStringIdKey :: Unique
+    unpackCStringFoldrIdKey, unpackCStringIdKey,
+    typeErrorIdKey :: Unique
+
 wildCardKey                   = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]
 absentErrorIdKey              = mkPreludeMiscIdUnique  1
 augmentIdKey                  = mkPreludeMiscIdUnique  2
@@ -1657,6 +1659,7 @@ unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 18
 unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 19
 unpackCStringIdKey            = mkPreludeMiscIdUnique 20
 voidPrimIdKey                 = mkPreludeMiscIdUnique 21
+typeErrorIdKey                = mkPreludeMiscIdUnique 22
 
 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey,
     returnIOIdKey, newStablePtrIdKey,
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 95f814f0d0..6d69c75faf 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -9196,11 +9196,11 @@ main = print "b"
   </para>
   <para>
     At runtime, whenever a term containing a type error would need to be
-    evaluated, the error is converted into a runtime exception.
-    Note that type errors are deferred as much as possible during runtime, but
-    invalid coercions are never performed, even when they would ultimately
-    result in a value of the correct type. For example, given the following
-    code:
+    evaluated, the error is converted into a runtime exception of type
+    <literal>TypeError</literal>. Note that type errors are deferred as much
+    as possible during runtime, but invalid coercions are never performed,
+    even when they would ultimately result in a value of the correct type.
+    For example, given the following code:
 <programlisting>
 x :: Int
 x = 0
@@ -9211,7 +9211,7 @@ y = x
 z :: Int
 z = y
 </programlisting>
-    evaluating <literal>z</literal> will result in a runtime type error.
+    evaluating <literal>z</literal> will result in a runtime <literal>TypeError</literal>.
   </para>
 </sect2>
 <sect2><title>Deferred type errors in GHCi</title>
diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
index 18c0e42914..61ebf2961c 100644
--- a/libraries/base/Control/Exception.hs
+++ b/libraries/base/Control/Exception.hs
@@ -56,6 +56,7 @@ module Control.Exception (
         RecSelError(..),
         RecUpdError(..),
         ErrorCall(..),
+        TypeError(..),
 
         -- * Throwing exceptions
         throw,
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index 4608c2dd20..4318773d35 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -39,6 +39,7 @@ module Control.Exception.Base (
         RecSelError(..),
         RecUpdError(..),
         ErrorCall(..),
+        TypeError(..), -- #10284, custom error type for deferred type errors
 
         -- * Throwing exceptions
         throwIO,
@@ -92,7 +93,7 @@ module Control.Exception.Base (
         -- * Calls for GHC runtime
         recSelError, recConError, irrefutPatError, runtimeError,
         nonExhaustiveGuardsError, patError, noMethodBindingError,
-        absentError,
+        absentError, typeError,
         nonTermination, nestedAtomically,
   ) where
 
@@ -357,6 +358,18 @@ instance Exception NoMethodError
 
 -----
 
+-- |An expression that didn't typecheck during compile time was called.
+-- This is only possible with -fdefer-type-errors. The @String@ gives
+-- details about the failed type check.
+data TypeError = TypeError String
+
+instance Show TypeError where
+    showsPrec _ (TypeError err) = showString err
+
+instance Exception TypeError
+
+-----
+
 -- |Thrown when the runtime system detects that the computation is
 -- guaranteed not to terminate. Note that there is no guarantee that
 -- the runtime system will notice whether any given computation is
@@ -383,7 +396,7 @@ instance Exception NestedAtomically
 
 recSelError, recConError, irrefutPatError, runtimeError,
   nonExhaustiveGuardsError, patError, noMethodBindingError,
-  absentError
+  absentError, typeError
         :: Addr# -> a   -- All take a UTF8-encoded C string
 
 recSelError              s = throw (RecSelError ("No match in record selector "
@@ -396,6 +409,7 @@ irrefutPatError          s = throw (PatternMatchFail (untangle s "Irrefutable pa
 recConError              s = throw (RecConError      (untangle s "Missing field in record construction"))
 noMethodBindingError     s = throw (NoMethodError    (untangle s "No instance nor default method for class operation"))
 patError                 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+typeError                s = throw (TypeError        (unpackCStringUtf8# s))
 
 -- GHC's RTS calls this
 nonTermination :: SomeException
diff --git a/testsuite/tests/typecheck/should_run/T10284.hs b/testsuite/tests/typecheck/should_run/T10284.hs
new file mode 100644
index 0000000000..8fc86351a0
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T10284.hs
@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-}
+
+import Control.Exception
+
+a :: Int
+a = 'a'
+
+main :: IO ()
+main = do
+  catch (evaluate a)
+        (\e -> do let err = show (e :: TypeError)
+                  putStrLn ("As expected, TypeError: " ++ err)
+                  return "")
+  catch (evaluate a)
+        (\e -> do let err = show (e :: ErrorCall)
+                  putStrLn ("Something went horribly wrong: " ++ err)
+                  return "")
diff --git a/testsuite/tests/typecheck/should_run/T10284.stderr b/testsuite/tests/typecheck/should_run/T10284.stderr
new file mode 100644
index 0000000000..c7133f0172
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T10284.stderr
@@ -0,0 +1,5 @@
+T10284: T10284.hs:14:19: error:
+    Couldn't match expected type ‘()’ with actual type ‘Int’
+    In the first argument of ‘evaluate’, namely ‘a’
+    In the first argument of ‘catch’, namely ‘(evaluate a)’
+(deferred type error)
diff --git a/testsuite/tests/typecheck/should_run/T10284.stdout b/testsuite/tests/typecheck/should_run/T10284.stdout
new file mode 100644
index 0000000000..ea03ec8a1a
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T10284.stdout
@@ -0,0 +1,5 @@
+As expected, TypeError: T10284.hs:6:5: error:
+    Couldn't match expected type ‘Int’ with actual type ‘Char’
+    In the expression: 'a'
+    In an equation for ‘a’: a = 'a'
+(deferred type error)
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index 4195ca8715..b1525bdc00 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -119,3 +119,4 @@ test('T9497b-run', [exit_code(1)], compile_and_run, ['-fdefer-typed-holes -fno-w
 test('T9497c-run', [exit_code(1)], compile_and_run, ['-fdefer-type-errors -fno-warn-typed-holes'])
 test('T9858c', normal, compile_and_run, [''])
 test('T9858d', normal, compile_and_run, [''])
+test('T10284', exit_code(1), compile_and_run, [''])