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.

1 files changed, 38 insertions, 37 deletions

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