diff options
| author | HE, Tao <sighingnow@gmail.com> | 2018-05-27 11:48:20 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2018-05-30 10:02:10 -0400 |
| commit | 49e423e9940a9122a4a417cfc7580b9984fb49eb (patch) | |
| tree | 8906639676278962a50695921b21758627126d0e /compiler | |
| parent | c65159dcf401d36e8920f43fec300264533642b9 (diff) | |
| download | haskell-49e423e9940a9122a4a417cfc7580b9984fb49eb.tar.gz | |
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
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 8 |
1 files changed, 6 insertions, 2 deletions
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 63fe36d2c8..d20d43affb 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, |