Fixes to dealing with the export of main

It's surprisingly tricky to deal with 'main' (#19397). This
patch does quite bit of refactoring do to it right. Well,
more-right anyway!

The moving parts are documented in GHC.Tc.Module
   Note [Dealing with main]

Some other oddments:

* Rename tcRnExports to rnExports; no typechecking here!

* rnExports now uses checkNoErrs rather than failIfErrsM;
  the former fails only if rnExports itself finds errors

* Small improvements to tcTyThingCategory, which ultimately
  weren't important to the patch, but I've retained as
  a minor improvement.

5 files changed, 382 insertions, 356 deletions

diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index b1a8ce0351..483c6145b8 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -690,7 +690,7 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name
   -- `checkPatSynParent`.
   traceRn "parent" (ppr parent)
   traceRn "lookupExportChild original_gres:" (ppr original_gres)
-  traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres)
+  traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent)
   case picked_gres original_gres of
     NoOccurrence ->
       noMatchingParentErr original_gres
@@ -720,6 +720,7 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name
         --     constructors, neither of which is the parent.
         noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult
         noMatchingParentErr original_gres = do
+          traceRn "npe" (ppr original_gres)
           dup_fields_ok <- xoptM LangExt.DuplicateRecordFields
           case original_gres of
             [] ->  return NameNotFound
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index fe6dcfd88d..ec0efc48d5 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -3,7 +3,7 @@
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE TypeFamilies      #-}
 
-module GHC.Tc.Gen.Export (tcRnExports, exports_from_avail) where
+module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where
 
 import GHC.Prelude
 
@@ -29,6 +29,7 @@ import GHC.Utils.Misc (capitalise)
 import GHC.Data.FastString (fsLit)
 import GHC.Driver.Env
 
+import GHC.Types.TyThing( tyThingCategory )
 import GHC.Types.Unique.Set
 import GHC.Types.SrcLoc as SrcLoc
 import GHC.Types.Name
@@ -38,7 +39,6 @@ import GHC.Types.Avail
 import GHC.Types.SourceFile
 import GHC.Types.Id
 import GHC.Types.Id.Info
-import GHC.Types.TyThing
 import GHC.Types.Name.Reader
 
 import Control.Monad
@@ -153,46 +153,48 @@ type ExportOccMap = OccEnv (GreName, IE GhcPs)
         --   it came from.  It's illegal to export two distinct things
         --   that have the same occurrence name
 
-tcRnExports :: Bool       -- False => no 'module M(..) where' header at all
+rnExports :: Bool       -- False => no 'module M(..) where' header at all
           -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list
-          -> TcGblEnv
           -> RnM TcGblEnv
 
         -- Complains if two distinct exports have same OccName
         -- Warns about identical exports.
         -- Complains about exports items not in scope
 
-tcRnExports explicit_mod exports
-          tcg_env@TcGblEnv { tcg_mod     = this_mod,
-                              tcg_rdr_env = rdr_env,
-                              tcg_imports = imports,
-                              tcg_src     = hsc_src }
- = unsetWOptM Opt_WarnWarningsDeprecations $
+rnExports explicit_mod exports
+ = checkNoErrs $   -- Fail if anything in rnExports finds
+                   -- an error fails, to avoid error cascade
+   unsetWOptM Opt_WarnWarningsDeprecations $
        -- Do not report deprecations arising from the export
        -- list, to avoid bleating about re-exporting a deprecated
        -- thing (especially via 'module Foo' export item)
-   do   {
-        ; dflags <- getDynFlags
-        ; hsc_env <- getTopEnv
-        ; let is_main_mod = mainModIs hsc_env == this_mod
-        ; let default_main = case mainFunIs dflags of
-                 Just main_fun
-                     | is_main_mod -> mkUnqual varName (fsLit main_fun)
-                 _                 -> main_RDR_Unqual
+   do   { hsc_env <- getTopEnv
+        ; tcg_env <- getGblEnv
+        ; let dflags = hsc_dflags hsc_env
+              TcGblEnv { tcg_mod     = this_mod
+                       , tcg_rdr_env = rdr_env
+                       , tcg_imports = imports
+                       , tcg_src     = hsc_src } = tcg_env
+              default_main | mainModIs hsc_env == this_mod
+                           , Just main_fun <- mainFunIs dflags
+                           = mkUnqual varName (fsLit main_fun)
+                           | otherwise
+                           = main_RDR_Unqual
         ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832
+
         -- If a module has no explicit header, and it has one or more main
         -- functions in scope, then add a header like
         -- "module Main(main) where ..."                               #13839
         -- See Note [Modules without a module header]
         ; let real_exports
                  | explicit_mod = exports
-                 | has_main
-                          = Just (noLoc [noLoc (IEVar noExtField
+                 | has_main = Just (noLoc [noLoc (IEVar noExtField
                                      (noLoc (IEName $ noLoc default_main)))])
-                        -- ToDo: the 'noLoc' here is unhelpful if 'main'
-                        --       turns out to be out of scope
+                              -- ToDo: the 'noLoc' here is unhelpful if 'main'
+                              --       turns out to be out of scope
                  | otherwise = Nothing
 
+        -- Rename the export list
         ; let do_it = exports_from_avail real_exports rdr_env imports this_mod
         ; (rn_exports, final_avails)
             <- if hsc_src == HsigFile
@@ -201,19 +203,18 @@ tcRnExports explicit_mod exports
                             Just r  -> return r
                             Nothing -> addMessages msgs >> failM
                 else checkNoErrs do_it
-        ; let final_ns     = availsToNameSetWithSelectors final_avails
+
+        -- Final processing
+        ; let final_ns = availsToNameSetWithSelectors final_avails
 
         ; traceRn "rnExports: Exports:" (ppr final_avails)
 
-        ; let new_tcg_env =
-                  tcg_env { tcg_exports    = final_avails,
-                             tcg_rn_exports = case tcg_rn_exports tcg_env of
+        ; return (tcg_env { tcg_exports    = final_avails
+                          , tcg_rn_exports = case tcg_rn_exports tcg_env of
                                                 Nothing -> Nothing
-                                                Just _  -> rn_exports,
-                            tcg_dus = tcg_dus tcg_env `plusDU`
-                                      usesOnly final_ns }
-        ; failIfErrsM
-        ; return new_tcg_env }
+                                                Just _  -> rn_exports
+                          , tcg_dus = tcg_dus tcg_env `plusDU`
+                                      usesOnly final_ns }) }
 
 exports_from_avail :: Maybe (Located [LIE GhcPs])
                          -- ^ 'Nothing' means no explicit export list
@@ -596,7 +597,7 @@ checkPatSynParent parent NoParent gname
   = return ()
 
   | otherwise
-  = do { parent_ty_con <- tcLookupTyCon parent
+  = do { parent_ty_con  <- tcLookupTyCon parent
        ; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname)
 
         -- 1. Check that the Id was actually from a thing associated with patsyns
@@ -793,7 +794,7 @@ dcErrMsg ty_con what_is thing parents =
                 <+> text "is not the parent of the" <+> text what_is
                 <+> quotes thing <> char '.'
                 $$ text (capitalise what_is)
-                <> text "s can only be exported with their parent type constructor."
+                   <> text "s can only be exported with their parent type constructor."
                 $$ (case parents of
                       [] -> empty
                       [_] -> text "Parent:"
@@ -802,13 +803,13 @@ dcErrMsg ty_con what_is thing parents =
 failWithDcErr :: Name -> GreName -> [Name] -> TcM a
 failWithDcErr parent child parents = do
   ty_thing <- tcLookupGlobal (greNameMangledName child)
-  failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
+  failWithTc $ dcErrMsg parent (pp_category ty_thing)
                         (ppr child) (map ppr parents)
   where
-    tyThingCategory' :: TyThing -> String
-    tyThingCategory' (AnId i)
+    pp_category :: TyThing -> String
+    pp_category (AnId i)
       | isRecordSelector i = "record selector"
-    tyThingCategory' i = tyThingCategory i
+    pp_category i = tyThingCategory i
 
 
 exportClashErr :: GlobalRdrEnv
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 08f7d0f4b1..9e9e82bca4 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
@@ -57,7 +58,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )
 import GHC.Tc.Gen.HsType
 import GHC.Tc.Validity( checkValidType )
 import GHC.Tc.Gen.Match
-import GHC.Tc.Utils.Unify( checkConstraints )
+import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma )
 import GHC.Tc.Utils.Zonk
 import GHC.Tc.Gen.Expr
 import GHC.Tc.Gen.App( tcInferSigma )
@@ -168,7 +169,7 @@ import GHC.Data.List.SetOps
 import GHC.Data.Bag
 import qualified GHC.Data.BooleanFormula as BF
 
-import Data.List ( find, sortBy, sort )
+import Data.List ( sortBy, sort )
 import Data.Ord
 import Data.Data ( Data )
 import qualified Data.Set as S
@@ -294,20 +295,22 @@ tcRnModuleTcRnM hsc_env mod_sum
           $ do { -- Rename and type check the declarations
                  traceRn "rn1a" empty
                ; tcg_env <- if isHsBootOrSig hsc_src
-                            then tcRnHsBootDecls hsc_src local_decls
+                            then do {
+                              ; tcg_env <- tcRnHsBootDecls hsc_src local_decls
+                              ; traceRn "rn4a: before exports" empty
+                              ; tcg_env <- setGblEnv tcg_env $
+                                           rnExports explicit_mod_hdr export_ies
+                              ; traceRn "rn4b: after exports" empty
+                              ; return tcg_env
+                              }
                             else {-# SCC "tcRnSrcDecls" #-}
-                                 tcRnSrcDecls explicit_mod_hdr local_decls export_ies
+                                 tcRnSrcDecls explicit_mod_hdr export_ies local_decls
 
                ; whenM (goptM Opt_DoCoreLinting) $
                  lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env
 
                ; setGblEnv tcg_env
-                 $ do { -- Process the export list
-                        traceRn "rn4a: before exports" empty
-                      ; tcg_env <- tcRnExports explicit_mod_hdr export_ies
-                                     tcg_env
-                      ; traceRn "rn4b: after exports" empty
-                      ; -- Compare hi-boot iface (if any) with the real thing
+                 $ do { -- Compare hi-boot iface (if any) with the real thing
                         -- Must be done after processing the exports
                         tcg_env <- checkHiBootIface tcg_env boot_info
                       ; -- The new type env is already available to stuff
@@ -431,105 +434,117 @@ tcRnImports hsc_env import_decls
 -}
 
 tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
-             -> [LHsDecl GhcPs]               -- Declarations
              -> Maybe (Located [LIE GhcPs])
+             -> [LHsDecl GhcPs]               -- Declarations
              -> TcM TcGblEnv
-tcRnSrcDecls explicit_mod_hdr decls export_ies
+tcRnSrcDecls explicit_mod_hdr export_ies decls
  = do { -- Do all the declarations
       ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
 
-        -- Check for the 'main' declaration
-        -- Must do this inside the captureTopConstraints
-        -- NB: always set envs *before* captureTopConstraints
-      ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $
-                               captureTopConstraints $
-                               checkMain explicit_mod_hdr export_ies
-
-      ; setEnvs (tcg_env, tcl_env) $ do {
-
-             --         Simplify constraints
-             --
-             -- We do this after checkMain, so that we use the type info
-             -- that checkMain adds
-             --
-             -- We do it with both global and local env in scope:
-             --  * the global env exposes the instances to simplifyTop
-             --  * the local env exposes the local Ids to simplifyTop,
-             --    so that we get better error messages (monomorphism restriction)
+      ------ Simplify constraints ---------
+      --
+      -- We do this after checkMainType, so that we use the type
+      -- info that checkMainType adds
+      --
+      -- We do it with both global and local env in scope:
+      --  * the global env exposes the instances to simplifyTop,
+      --    and affects how names are rendered in error messages
+      --  * the local env exposes the local Ids to simplifyTop,
+      --    so that we get better error messages (monomorphism restriction)
       ; new_ev_binds <- {-# SCC "simplifyTop" #-}
-                        simplifyTop (lie `andWC` lie_main)
+                        setEnvs (tcg_env, tcl_env) $
+                        do { lie_main <- checkMainType tcg_env
+                           ; simplifyTop (lie `andWC` lie_main) }
 
         -- Emit Typeable bindings
-      ; tcg_env <- mkTypeableBinds
-
+      ; tcg_env <- setGblEnv tcg_env $
+                   mkTypeableBinds
 
       ; traceTc "Tc9" empty
 
-      ; failIfErrsM     -- Don't zonk if there have been errors
-                        -- It's a waste of time; and we may get debug warnings
-                        -- about strangely-typed TyCons!
-      ; traceTc "Tc10" empty
-
         -- Zonk the final code.  This must be done last.
         -- Even simplifyTop may do some unification.
         -- This pass also warns about missing type signatures
-      ; (bind_env, ev_binds', binds', fords', imp_specs', rules')
+      ; (id_env, ev_binds', binds', fords', imp_specs', rules')
             <- zonkTcGblEnv new_ev_binds tcg_env
 
-        -- Finalizers must run after constraints are simplified, or some types
-        -- might not be complete when using reify (see #12777).
-        -- and also after we zonk the first time because we run typed splices
-        -- in the zonker which gives rise to the finalisers.
-      ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env)
-                                     run_th_modfinalizers
+      --------- Run finalizers --------------
+      -- Finalizers must run after constraints are simplified, lest types
+      --    might not be complete when using reify (see #12777).
+      -- and also after we zonk the first time because we run typed splices
+      --    in the zonker which gives rise to the finalisers.
+      ; let -- init_tcg_env:
+            --   * Remove accumulated bindings, rules and so on from
+            --     TcGblEnv.  They are now in ev_binds', binds', etc.
+            --   * Add the zonked Ids from the value bindings to tcg_type_env
+            --     Up to now these Ids are only in tcl_env's type-envt
+            init_tcg_env = tcg_env { tcg_binds     = emptyBag
+                                   , tcg_ev_binds  = emptyBag
+                                   , tcg_imp_specs = []
+                                   , tcg_rules     = []
+                                   , tcg_fords     = []
+                                   , tcg_type_env  = tcg_type_env tcg_env
+                                                     `plusTypeEnv` id_env }
+      ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env
+                              run_th_modfinalizers
       ; finishTH
       ; traceTc "Tc11" empty
 
-      ; -- zonk the new bindings arising from running the finalisers.
-        -- This won't give rise to any more finalisers as you can't nest
-        -- finalisers inside finalisers.
-      ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
-            <- zonkTcGblEnv emptyBag tcg_env_mf
-
-              -- Force this or we retain an old reference to the previous
-              -- tcg_env
-      ; let { !final_type_env = plusTypeEnv (tcg_type_env tcg_env)
-                                 (plusTypeEnv bind_env_mf bind_env)
-            ; tcg_env' = tcg_env_mf
-                          { tcg_binds    = binds' `unionBags` binds_mf,
-                            tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf ,
-                            tcg_imp_specs = imp_specs' ++ imp_specs_mf ,
-                            tcg_rules    = rules' ++ rules_mf ,
-                            tcg_fords    = fords' ++ fords_mf } } ;
+      --------- Deal with the exports ----------
+      -- Can't be done earlier, because the export list must "see"
+      -- the declarations created by the finalizers
+      ; tcg_env <- setEnvs (tcg_env, tcl_env) $
+                   rnExports explicit_mod_hdr export_ies
+
+      --------- Emit the ':Main.main = runMainIO main' declaration ----------
+      -- Do this /after/ rnExports, so that it can consult
+      -- the tcg_exports created by rnExports
+      ; (tcg_env, main_ev_binds)
+           <- setEnvs (tcg_env, tcl_env) $
+              do { (tcg_env, lie) <- captureTopConstraints $
+                                     checkMain explicit_mod_hdr export_ies
+                 ; ev_binds <- simplifyTop lie
+                 ; return (tcg_env, ev_binds) }
+
+      ---------- Final zonking ---------------
+      -- Zonk the new bindings arising from running the finalisers,
+      -- and main. This won't give rise to any more finalisers as you
+      -- can't nest finalisers inside finalisers.
+      ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
+            <- zonkTcGblEnv main_ev_binds tcg_env
+
+      ; let { !final_type_env = tcg_type_env tcg_env
+                                `plusTypeEnv` id_env_mf
+              -- Add the zonked Ids from the value bindings (they were in tcl_env)
+              -- Force !final_type_env, lest we retain an old reference
+              -- to the previous tcg_env
+
+            ; tcg_env' = tcg_env
+                          { tcg_binds     = binds'    `unionBags` binds_mf
+                          , tcg_ev_binds  = ev_binds' `unionBags` ev_binds_mf
+                          , tcg_imp_specs = imp_specs' ++ imp_specs_mf
+                          , tcg_rules     = rules'     ++ rules_mf
+                          , tcg_fords     = fords'     ++ fords_mf } } ;
 
       ; setGlobalTypeEnv tcg_env' final_type_env
-
-   } }
+   }
 
 zonkTcGblEnv :: Bag EvBind -> TcGblEnv
              -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
                        [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
-zonkTcGblEnv new_ev_binds tcg_env =
-  let TcGblEnv {   tcg_binds     = binds,
-                   tcg_ev_binds  = cur_ev_binds,
-                   tcg_imp_specs = imp_specs,
-                   tcg_rules     = rules,
-                   tcg_fords     = fords } = tcg_env
-
-      all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
-
-  in {-# SCC "zonkTopDecls" #-}
-      zonkTopDecls all_ev_binds binds rules imp_specs fords
-
-
--- | Remove accumulated bindings, rules and so on from TcGblEnv
-clearTcGblEnv :: TcGblEnv -> TcGblEnv
-clearTcGblEnv tcg_env
-  = tcg_env { tcg_binds    = emptyBag,
-              tcg_ev_binds = emptyBag ,
-              tcg_imp_specs = [],
-              tcg_rules    = [],
-              tcg_fords    = [] }
+zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds     = binds
+                                        , tcg_ev_binds  = cur_ev_binds
+                                        , tcg_imp_specs = imp_specs
+                                        , tcg_rules     = rules
+                                        , tcg_fords     = fords })
+  = {-# SCC "zonkTopDecls" #-}
+    setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering
+                        --   error messages during zonking (notably levity errors)
+    do { failIfErrsM    -- Don't zonk if there have been errors
+                        -- It's a waste of time; and we may get debug warnings
+                        -- about strangely-typed TyCons!
+       ; let all_ev_binds = cur_ev_binds `unionBags` ev_binds
+       ; zonkTopDecls all_ev_binds binds rules imp_specs fords }
 
 -- | Runs TH finalizers and renames and typechecks the top-level declarations
 -- that they could introduce.
@@ -633,12 +648,9 @@ tc_rn_src_decls ds
                ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice
 
                  -- Glue them on the front of the remaining decls and loop
-               ; (tcg_env, tcl_env, lie2) <-
-                   setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
-                   addTopEvBinds ev_binds1 $
-                   tc_rn_src_decls (spliced_decls ++ rest_ds)
-
-               ; return (tcg_env, tcl_env, lie2)
+               ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
+                 addTopEvBinds ev_binds1                             $
+                 tc_rn_src_decls (spliced_decls ++ rest_ds)
                }
           }
       }
@@ -1747,186 +1759,235 @@ tcTyClsInstDecls tycl_decls deriv_decls binds
 ************************************************************************
 -}
 
+checkMainType :: TcGblEnv -> TcRn WantedConstraints
+-- If this is the Main module, and it defines a function main,
+--   check that its type is of form IO tau.
+-- If not, do nothing
+-- See Note [Dealing with main]
+checkMainType tcg_env
+  = do { hsc_env <- getTopEnv
+       ; if tcg_mod tcg_env /= mainModIs hsc_env
+         then return emptyWC else
+
+    do { rdr_env <- getGlobalRdrEnv
+       ; let dflags    = hsc_dflags hsc_env
+             main_occ  = getMainOcc dflags
+             main_gres = lookupGlobalRdrEnv rdr_env main_occ
+       ; case filter isLocalGRE main_gres of {
+            []         -> return emptyWC ;
+            (_:_:_)    -> return emptyWC ;
+            [main_gre] ->
+
+    do { let main_name = greMangledName main_gre
+             ctxt      = FunSigCtxt main_name False
+       ; main_id   <- tcLookupId main_name
+       ; (io_ty,_) <- getIOType
+       ; (_, lie)  <- captureTopConstraints       $
+                      setMainCtxt main_name io_ty $
+                      tcSubTypeSigma ctxt (idType main_id) io_ty
+       ; return lie } } } }
+
 checkMain :: Bool  -- False => no 'module M(..) where' header at all
           -> Maybe (Located [LIE GhcPs])  -- Export specs of Main module
           -> TcM TcGblEnv
--- If we are in module Main, check that 'main' is defined and exported.
+-- If we are in module Main, check that 'main' is exported,
+-- and generate the runMainIO binding that calls it
+-- See Note [Dealing with main]
 checkMain explicit_mod_hdr export_ies
- = do   { hsc_env  <- getTopEnv
-        ; tcg_env <- getGblEnv
-        ; check_main hsc_env tcg_env explicit_mod_hdr export_ies }
-
-check_main :: HscEnv -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs])
-           -> TcM TcGblEnv
-check_main hsc_env tcg_env explicit_mod_hdr export_ies
- | mod /= main_mod
- = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
-   return tcg_env
-
- | otherwise
-   -- Compare the list of main functions in scope with those
-   --   specified in the export list.
- = do mains_all <- lookupInfoOccRn main_fn
-                    -- get all 'main' functions in scope
-                    -- They may also be imported from other modules!
-      case exportedMains of -- check the main(s) specified in the export list
-        [ ] -> do
-          -- The module has no main functions in the export spec, so we must give
-          -- some kind of error message. The tricky part is giving an error message
-          -- that accurately characterizes what the problem is.
-          -- See Note [Main module without a main function in the export spec]
-          traceTc "checkMain no main module exported" ppr_mod_mainfn
-          complain_no_main
-          -- In order to reduce the number of potential error messages, we check
-          -- to see if there are any main functions defined (but not exported)...
-          case getSomeMain mains_all of
-            Nothing -> return tcg_env
-              -- ...if there are no such main functions, there is nothing we can do...
-            Just some_main -> use_as_main some_main
-                -- ...if there is such a main function, then communicate this to the
-                -- typechecker. This can prevent a spurious "Ambiguous type variable"
-                -- error message in certain cases, as described in
-                -- Note [Main module without a main function in the export spec].
-        _ -> do    -- The module has one or more main functions in the export spec
-          let mains = filterInsMains exportedMains mains_all
-          case mains of
-            [] -> do  --
-              traceTc "checkMain fail" ppr_mod_mainfn
-              complain_no_main
-              return tcg_env
-            [main_name] -> use_as_main main_name
-            _ -> do           -- multiple main functions are exported
-              addAmbiguousNameErr main_fn          -- issue error msg
+ = do { hsc_env  <- getTopEnv
+      ; tcg_env <- getGblEnv
+
+      ; let dflags      = hsc_dflags hsc_env
+            main_mod    = mainModIs hsc_env
+            main_occ    = getMainOcc dflags
+
+            exported_mains :: [Name]
+            -- Exported things that are called 'main'
+            exported_mains  = [ name | avail <- tcg_exports tcg_env
+                                     , name  <- availNames avail
+                                     , nameOccName name == main_occ ]
+
+      ; if | tcg_mod tcg_env /= main_mod
+           -> -- Not the main module
               return tcg_env
+
+           | [main_name] <- exported_mains
+           -> -- The module indeed exports a function called 'main'
+              generateMainBinding tcg_env main_name
+
+           | otherwise
+           -> ASSERT( null exported_mains )
+              -- A fully-checked export list can't contain more
+              -- than one function with the same OccName
+              do { complain_no_main dflags main_mod main_occ
+                 ; return tcg_env } }
   where
-    dflags      = hsc_dflags hsc_env
-    mod         = tcg_mod tcg_env
-    main_mod    = mainModIs hsc_env
-    main_mod_nm = moduleName main_mod
-    main_fn     = getMainFun dflags
-    occ_main_fn = occName main_fn
-    interactive = ghcLink dflags == LinkInMemory
-    exportedMains = selExportMains export_ies
-    ppr_mod_mainfn = ppr main_mod <+> ppr main_fn
-
-    -- There is a single exported 'main' function.
-    use_as_main :: Name -> TcM TcGblEnv
-    use_as_main main_name = do
-        { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
-        ; let loc       = srcLocSpan (getSrcLoc main_name)
-        ; ioTyCon <- tcLookupTyCon ioTyConName
-        ; res_ty <- newFlexiTyVarTy liftedTypeKind
-        ; let io_ty = mkTyConApp ioTyCon [res_ty]
-              skol_info = SigSkol (FunSigCtxt main_name False) io_ty []
-              main_expr_rn = L loc (HsVar noExtField (L loc main_name))
-        ; (ev_binds, main_expr)
-               <- checkConstraints skol_info [] [] $
-                  addErrCtxt mainCtxt    $
-                  tcCheckMonoExpr main_expr_rn io_ty
-
-                -- See Note [Root-main Id]
-                -- Construct the binding
-                --      :Main.main :: IO res_ty = runMainIO res_ty main
-        ; run_main_id <- tcLookupId runMainIOName
-        ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
-                                   (mkVarOccFS (fsLit "main"))
-                                   (getSrcSpan main_name)
-              ; root_main_id = Id.mkExportedVanillaId root_main_name
-                                                      (mkTyConApp ioTyCon [res_ty])
-              ; co  = mkWpTyApps [res_ty]
-              -- 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 #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,
-                            tcg_binds = tcg_binds tcg_env
-                                        `snocBag` main_bind,
-                            tcg_dus   = tcg_dus tcg_env
-                                        `plusDU` usesOnly (unitFV main_name)
-                        -- Record the use of 'main', so that we don't
-                        -- complain about it being defined but not used
-        })}
-
-    complain_no_main = unless (interactive && not explicit_mod_hdr)
-                              (addErrTc noMainMsg)                  -- #12906
-        -- Without an explicit module header...
-          -- in interactive mode, don't worry about the absence of 'main'.
-          -- in other modes, add error message and go on with typechecking.
-
-    mainCtxt  = text "When checking the type of the" <+> pp_main_fn
-    noMainMsg = text "The" <+> pp_main_fn
-                <+> text "is not" <+> text defOrExp <+> text "module"
-                <+> quotes (ppr main_mod)
-    defOrExp  = if null exportedMains then "exported by" else "defined in"
-
-    pp_main_fn = ppMainFn main_fn
-
-    -- Select the main functions from the export list.
-    -- Only the module name is needed, the function name is fixed.
-    selExportMains :: Maybe (Located [LIE GhcPs]) -> [ModuleName]    -- #16453
-    selExportMains Nothing = [main_mod_nm]
-        -- no main specified, but there is a header.
-    selExportMains (Just exps) = fmap fst $
-        filter (\(_,n) -> n == occ_main_fn ) texp
-      where
-        ies = fmap unLoc $ unLoc exps
-        texp = mapMaybe transExportIE ies
-
-    -- Filter all main functions in scope that match the export specs
-    filterInsMains :: [ModuleName] -> [Name] -> [Name]               -- #16453
-    filterInsMains export_mains inscope_mains =
-      [mod | mod <- inscope_mains,
-          (moduleName . nameModule) mod `elem` export_mains]
-
-    -- Transform an export_ie to a (ModuleName, OccName) pair.
-    -- 'IEVar' constructors contain exported values (functions), eg '(Main.main)'
-    -- 'IEModuleContents' constructors contain fully exported modules, eg '(Main)'
-    -- All other 'IE...' constructors are not used and transformed to Nothing.
-    transExportIE :: IE GhcPs -> Maybe (ModuleName, OccName)         -- #16453
-    transExportIE (IEVar _  var) = isQual_maybe $
-         upqual $ ieWrappedName $ unLoc var
-       where
-         -- A module name is always needed, so qualify 'UnQual' rdr names.
-         upqual (Unqual occ) = Qual main_mod_nm occ
-         upqual rdr = rdr
-    transExportIE (IEModuleContents _ mod) = Just (unLoc mod, occ_main_fn)
-    transExportIE _ = Nothing
-
-    -- Get a main function that is in scope.
-    -- See Note [Main module without a main function in the export spec]
-    getSomeMain :: [Name] -> Maybe Name                            -- #16453
-    getSomeMain all_mains = case all_mains of
-        []  -> Nothing                -- No main function in scope
-        [m] -> Just m                 -- Just one main function in scope
-        _   -> case mbMainOfMain of
-          Nothing -> listToMaybe all_mains -- Take the first main function in scope or Nothing
-          _       -> mbMainOfMain          -- Take the Main module's main function or Nothing
+    complain_no_main dflags main_mod main_occ
+      = unless (interactive && not explicit_mod_hdr) $
+        addErrTc (noMainMsg main_mod main_occ)          -- #12906
       where
-        mbMainOfMain = find (\n -> (moduleName . nameModule) n == main_mod_nm )
-                          all_mains         -- the main function of the Main module
+        interactive = ghcLink dflags == LinkInMemory
+        -- Without an explicit module header...
+        -- in interactive mode, don't worry about the absence of 'main'.
+        -- in other modes, add error message and go on with typechecking.
+
+    noMainMsg main_mod main_occ
+      = text "The" <+> ppMainFn main_occ
+        <+> text "is not" <+> text defOrExp <+> text "module"
+        <+> quotes (ppr main_mod)
+
+    defOrExp | explicit_export_list = "exported by"
+             | otherwise            = "defined in"
+    explicit_export_list = explicit_mod_hdr && isJust export_ies
 
 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
 -- Either returns the default name or the one configured on the command line with -main-is
-getMainFun :: DynFlags -> RdrName
-getMainFun dflags = case mainFunIs dflags of
-                      Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
-                      Nothing -> main_RDR_Unqual
-
-ppMainFn :: RdrName -> SDoc
-ppMainFn main_fn
-  | rdrNameOcc main_fn == mainOcc
-  = text "IO action" <+> quotes (ppr main_fn)
+getMainOcc :: DynFlags -> OccName
+getMainOcc dflags = case mainFunIs dflags of
+                      Just fn -> mkVarOccFS (mkFastString fn)
+                      Nothing -> mainOcc
+
+ppMainFn :: OccName -> SDoc
+ppMainFn main_occ
+  | main_occ == mainOcc
+  = text "IO action" <+> quotes (ppr main_occ)
   | otherwise
-  = text "main IO action" <+> quotes (ppr main_fn)
+  = text "main IO action" <+> quotes (ppr main_occ)
 
 mainOcc :: OccName
 mainOcc = mkVarOccFS (fsLit "main")
 
-{-
+generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv
+-- There is a single exported 'main' function, called 'foo' (say),
+-- which may be locally defined or imported
+-- Define and typecheck the binding
+--     :Main.main :: IO res_ty = runMainIO res_ty foo
+-- This wraps the user's main function in the top-level stuff
+-- defined in runMainIO (eg catching otherwise un-caught exceptions)
+-- See Note [Dealing with main]
+generateMainBinding tcg_env main_name = do
+    { traceTc "checkMain found" (ppr main_name)
+    ; (io_ty, res_ty) <- getIOType
+    ; let loc = getSrcSpan main_name
+          main_expr_rn = L loc (HsVar noExtField (L loc main_name))
+    ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $
+                               tcCheckMonoExpr main_expr_rn io_ty
+
+            -- See Note [Root-main Id]
+            -- Construct the binding
+            --      :Main.main :: IO res_ty = runMainIO res_ty main
+    ; run_main_id <- tcLookupId runMainIOName
+    ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
+                               (mkVarOccFS (fsLit "main"))
+                               (getSrcSpan main_name)
+          ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty
+          ; co  = mkWpTyApps [res_ty]
+          -- The ev_binds of the `main` function may contain deferred
+          -- type errors 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 #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
+                      , tcg_binds = tcg_binds tcg_env
+                                    `snocBag` main_bind
+                      , tcg_dus   = tcg_dus tcg_env
+                                    `plusDU` usesOnly (unitFV main_name) })
+                    -- Record the use of 'main', so that we don't
+                    -- complain about it being defined but not used
+    }
+
+getIOType :: TcM (TcType, TcType)
+-- Return (IO alpha, alpha) for fresh alpha
+getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName
+               ; res_ty <- newFlexiTyVarTy liftedTypeKind
+               ; return (mkTyConApp ioTyCon [res_ty], res_ty) }
+
+setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a)
+setMainCtxt main_name io_ty thing_inside
+  = setSrcSpan (getSrcSpan main_name) $
+    addErrCtxt main_ctxt              $
+    checkConstraints skol_info [] []  $  -- Builds an implication if necessary
+    thing_inside                         -- e.g. with -fdefer-type-errors
+  where
+    skol_info = SigSkol (FunSigCtxt main_name False) io_ty []
+    main_ctxt = text "When checking the type of the"
+                <+> ppMainFn (nameOccName main_name)
+
+{- Note [Dealing with main]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Dealing with the 'main' declaration is surprisingly tricky. Here are
+the moving parts:
+
+* The flag -main-is=M.foo allows you to set the main module to 'M',
+  and the main function to 'foo'.  We access them through
+      mainModIs  :: HscEnv -> Module     -- returns M
+      getMainOcc :: DynFlags -> OccName  -- returns foo
+  Of course usually M = Main, and foo = main.
+
+* checkMainType: when typechecking module M, we add an extra check that
+    foo :: IO tau, for some type tau.
+  This avoids getting ambiguous-type errors from the monomorphism restriction
+  applying to things like
+      main = return ()
+  Note that checkMainType does not consult the export list because
+  we have not yet done rnExports (and can't do it until later).
+
+* rnExports: checks the export list.  Very annoyingly, we can only do
+  this after running any finalisers, which may add new declarations.
+  That's why checkMainType and checkMain have to be separate.
+
+* checkMain: does two things:
+  - check that the export list does indeed export something called 'foo'
+  - generateMainBinding: generate the root-main binding
+       :Main.main = runMainIO M.foo
+  See Note [Root-main id]
+
+An annoying consequence of having both checkMainType and checkMain is
+that, when (but only when) -fdefer-type-errors is on, we may report an
+ill-typed 'main' twice (as warnings): once in checkMainType and once
+in checkMain. See test typecheck/should_fail/T13292.
+
+We have the following tests to check this processing:
+----------------+----------------------------------------------------------------------------------+
+                |                                  Module Header:                                  |
+                +-------------+-------------+-------------+-------------+-------------+------------+
+                | module      | module Main | <No Header> | module Main |module       |module Main |
+                |  Main(main) |             |             |   (module X)|   Main ()   |  (Sub.main)|
+----------------+==================================================================================+
+`main` function | ERROR:      | Main.main   | ERROR:      | Main.main   | ERROR:      | Sub.main   |
+in Main module  |  Ambiguous  |             |  Ambiguous  |             |  `main` not |            |
+and in imported |             |             |             |             |  exported   |            |
+module Sub.     | T19397E1    | T16453M0    | T19397E2    | T16453M3    |             | T16453M1   |
+                |             |             |             | X = Main    | Remark 2)   |            |
+----------------+-------------+-------------+-------------+-------------+-------------+------------+
+`main`function  | Sub.main    | ERROR:      | Sub.main    | Sub.main    | ERROR:      | Sub.main   |
+only in imported|             | No `main` in|             |             |  `main` not |            |
+submodule Sub.  |             |   `Main`    |             |             |  exported   |            |
+                | T19397M0    | T16453E1    | T19397M1    | T16453M4    |             | T16453M5   |
+                |             |             |             | X = Sub     | Remark 2)   |            |
+----------------+-------------+-------------+-------------+-------------+-------------+------------+
+`foo` function  | Sub.foo     | ERROR:      | Sub.foo     | Sub.foo     | ERROR:      | Sub.foo    |
+in submodule    |             | No `foo` in |             |             |  `foo` not  |            |
+Sub.            |             |   `Main`    |             |             |  exported   |            |
+GHC option:     |             |             |             |             |             |            |
+  -main-is foo  | T19397M2    | T19397E3    | T19397M3    | T19397M4    | T19397E4    | T16453M6   |
+                | Remark 1)   |             |             | X = Sub     |             | Remark 3)  |
+----------------+-------------+-------------+-------------+-------------+-------------+------------+
+
+Remarks:
+* The first line shows the exported `main` function or the error.
+* The second line shows the coresponding test case.
+* The module `Sub` contains the following functions:
+     main :: IO ()
+     foo :: IO ()
+* Remark 1) Here the header is `Main (foo)`.
+* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`.
+* Remark 3) Here the header is `Main (Sub.foo)`.
+
+
 Note [Root-main Id]
 ~~~~~~~~~~~~~~~~~~~
 The function that the RTS invokes is always :Main.main, which we call
@@ -1940,53 +2001,6 @@ module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we
 get two defns for 'main' in the interface file!
 
 
-Note [Main module without a main function in the export spec]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Giving accurate error messages for a Main module that does not export a main
-function is surprisingly tricky. To see why, consider a module in a file
-`Foo.hs` that has no `main` function in the explicit export specs of the module
-header:
-
-    module Main () where
-    foo = return ()
-
-This does not export a main function and therefore should be rejected, per
-chapter 5 of the Haskell Report 2010:
-
-   A Haskell program is a collection of modules, one of which, by convention,
-   must be called Main and must export the value main. The value of the
-   program is the value of the identifier main in module Main, which must be
-   a computation of type IO τ for some type τ.
-
-In fact, when you compile the program above using `ghc Foo.hs`, you will
-actually get *two* errors:
-
- - The IO action ‘main’ is not defined in module ‘Main’
-
- - Ambiguous type variable ‘m0’ arising from a use of ‘return’
-   prevents the constraint ‘(Monad m0)’ from being solved.
-
-The first error is self-explanatory, while the second error message occurs
-due to the monomorphism restriction.
-
-Now consider what would happen if the program above were compiled with
-`ghc -main-is foo Foo`. The has the effect of `foo` being designated as the
-main function. The program will still be rejected since it does not export
-`foo` (and therefore does not export its main function), but there is one
-important difference: `foo` will be checked against the type `IO τ`. As a
-result, we would *not* expect the monomorphism restriction error message
-to occur, since the typechecker should have no trouble figuring out the type
-of `foo`. In other words, we should only throw the former error message,
-not the latter.
-
-The implementation uses the function `getSomeMain` to find a potential main
-function that is defined but not exported. If one is found, it is passed to
-`use_as_main` to inform the typechecker that the main function should be of
-type `IO τ`. See also the `T414` and `T17171a` test cases for similar examples
-of programs whose error messages are influenced by the situation described in
-this Note.
-
-
 *********************************************************
 *                                                       *
                 GHCi stuff
@@ -2739,7 +2753,7 @@ tcRnDeclsi :: HscEnv
            -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)
 tcRnDeclsi hsc_env local_decls
   = runTcInteractive hsc_env $
-    tcRnSrcDecls False local_decls Nothing
+    tcRnSrcDecls False Nothing local_decls
 
 externaliseAndTidyId :: Module -> Id -> TcM Id
 externaliseAndTidyId this_mod id
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index d70474393f..0003a93169 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -47,7 +47,9 @@ module GHC.Tc.Types(
         IdBindingInfo(..), ClosedTypeId, RhsNames,
         IsGroupClosed(..),
         SelfBootInfo(..),
-        pprTcTyThingCategory, pprPECategory, CompleteMatch, CompleteMatches,
+        tcTyThingCategory, pprTcTyThingCategory,
+        peCategory, pprPECategory,
+        CompleteMatch, CompleteMatches,
 
         -- Template Haskell
         ThStage(..), SpliceType(..), PendingStuff(..),
@@ -1269,22 +1271,30 @@ instance Outputable PromotionErr where
   ppr NoDataKindsTC               = text "NoDataKindsTC"
   ppr NoDataKindsDC               = text "NoDataKindsDC"
 
+--------------
 pprTcTyThingCategory :: TcTyThing -> SDoc
-pprTcTyThingCategory (AGlobal thing)    = pprTyThingCategory thing
-pprTcTyThingCategory (ATyVar {})        = text "Type variable"
-pprTcTyThingCategory (ATcId {})         = text "Local identifier"
-pprTcTyThingCategory (ATcTyCon {})     = text "Local tycon"
-pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe
+pprTcTyThingCategory = text . capitalise . tcTyThingCategory
 
+tcTyThingCategory :: TcTyThing -> String
+tcTyThingCategory (AGlobal thing)    = tyThingCategory thing
+tcTyThingCategory (ATyVar {})        = "type variable"
+tcTyThingCategory (ATcId {})         = "local identifier"
+tcTyThingCategory (ATcTyCon {})      = "local tycon"
+tcTyThingCategory (APromotionErr pe) = peCategory pe
+
+--------------
 pprPECategory :: PromotionErr -> SDoc
-pprPECategory ClassPE                = text "Class"
-pprPECategory TyConPE                = text "Type constructor"
-pprPECategory PatSynPE               = text "Pattern synonym"
-pprPECategory FamDataConPE           = text "Data constructor"
-pprPECategory ConstrainedDataConPE{} = text "Data constructor"
-pprPECategory RecDataConPE           = text "Data constructor"
-pprPECategory NoDataKindsTC          = text "Type constructor"
-pprPECategory NoDataKindsDC          = text "Data constructor"
+pprPECategory = text . capitalise . peCategory
+
+peCategory :: PromotionErr -> String
+peCategory ClassPE                = "class"
+peCategory TyConPE                = "type constructor"
+peCategory PatSynPE               = "pattern synonym"
+peCategory FamDataConPE           = "data constructor"
+peCategory ConstrainedDataConPE{} = "data constructor"
+peCategory RecDataConPE           = "data constructor"
+peCategory NoDataKindsTC          = "type constructor"
+peCategory NoDataKindsDC          = "data constructor"
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 526bb489ac..c38ad9491c 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -437,7 +437,7 @@ tcLookup name = do
     local_env <- getLclTypeEnv
     case lookupNameEnv local_env name of
         Just thing -> return thing
-        Nothing    -> AGlobal <$> tcLookupGlobal name
+        Nothing    -> (AGlobal <$> tcLookupGlobal name)
 
 tcLookupTyVar :: Name -> TcM TcTyVar
 tcLookupTyVar name