Put the `ev_binds` of main function inside `runMainIO`
authorHE, Tao <sighingnow@gmail.com>
Sun, 27 May 2018 15:48:20 +0000 (11:48 -0400)
committerBen Gamari <ben@smart-cactus.org>
Wed, 30 May 2018 14:02:10 +0000 (10:02 -0400)
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
testsuite/tests/typecheck/should_run/T13838.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_run/T13838.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_run/all.T

index 63fe36d..d20d43a 100644 (file)
@@ -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 (file)
index 0000000..265fdb0
--- /dev/null
@@ -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 (file)
index 0000000..b2129f7
--- /dev/null
@@ -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)
index 3cf70b6..b7f37b7 100755 (executable)
@@ -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, [''])