From 49e423e9940a9122a4a417cfc7580b9984fb49eb Mon Sep 17 00:00:00 2001
From: "HE, Tao" <sighingnow@gmail.com>
Date: Sun, 27 May 2018 11:48:20 -0400
Subject: [PATCH] Put the `ev_binds` of main function inside `runMainIO`

This ensures that the deferred type error can be emitted correctly.

For `main` function in `Main` module, we have

    :Main.main = GHC.TopHandler.runMainIO main

When the type of `main` is not `IO t` and the
`-fdefer-type-errors` is enabled, the `ev_binds`
of `main` function will contain deferred type
errors.

Previously, the `ev_binds` are bound to `runMainIO main`,
rather than `main`, the type error exception at runtime
cannot be handled properly. See Trac #13838.

This patch fix that.

Test Plan: make test TEST="T13838"

Reviewers: bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #13838

Differential Revision: https://phabricator.haskell.org/D4708
---
 compiler/typecheck/TcRnDriver.hs                   | 8 ++++++--
 testsuite/tests/typecheck/should_run/T13838.hs     | 6 ++++++
 testsuite/tests/typecheck/should_run/T13838.stderr | 6 ++++++
 testsuite/tests/typecheck/should_run/all.T         | 1 +
 4 files changed, 19 insertions(+), 2 deletions(-)
 create mode 100644 testsuite/tests/typecheck/should_run/T13838.hs
 create mode 100644 testsuite/tests/typecheck/should_run/T13838.stderr

diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 63fe36d2c816..d20d43affb80 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1692,8 +1692,12 @@ check_main dflags tcg_env explicit_mod_hdr
               ; root_main_id = Id.mkExportedVanillaId root_main_name
                                                       (mkTyConApp ioTyCon [res_ty])
               ; co  = mkWpTyApps [res_ty]
-              ; rhs = mkHsDictLet ev_binds $
-                      nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
+              -- The ev_binds of the `main` function may contain deferred
+              -- type error when type of `main` is not `IO a`. The `ev_binds`
+              -- must be put inside `runMainIO` to ensure the deferred type
+              -- error can be emitted correctly. See Trac #13838.
+              ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $
+                        mkHsDictLet ev_binds main_expr
               ; main_bind = mkVarBind root_main_id rhs }
 
         ; return (tcg_env { tcg_main  = Just main_name,
diff --git a/testsuite/tests/typecheck/should_run/T13838.hs b/testsuite/tests/typecheck/should_run/T13838.hs
new file mode 100644
index 000000000000..265fdb098619
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T13838.hs
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -fdefer-type-errors #-}
+
+module Main where
+
+main :: () -> ()
+main = undefined
diff --git a/testsuite/tests/typecheck/should_run/T13838.stderr b/testsuite/tests/typecheck/should_run/T13838.stderr
new file mode 100644
index 000000000000..b2129f7d1366
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T13838.stderr
@@ -0,0 +1,6 @@
+T13838.exe: T13838.hs:6:1: error:
+    • Couldn't match expected type ‘IO t0’ with actual type ‘() -> ()’
+    • Probable cause: ‘main’ is applied to too few arguments
+      In the expression: main
+      When checking the type of the IO action ‘main’
+(deferred type error)
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index 3cf70b6b32e0..b7f37b7507ce 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -130,6 +130,7 @@ test('TypeableEq', normal, compile_and_run, [''])
 test('T13435', normal, compile_and_run, [''])
 test('T11715', exit_code(1), compile_and_run, [''])
 test('T13594a', normal, ghci_script, ['T13594a.script'])
+test('T13838', [exit_code(1)], compile_and_run, ['-fdefer-type-errors'])
 test('T14218', normal, compile_and_run, [''])
 test('T14236', normal, compile_and_run, [''])
 test('T14925', normal, compile_and_run, [''])
-- 
GitLab