Use export list of Main module in function TcRnDriver.hs:check_main (Fix #16453)

- Provide the export list of the `Main` module as parameter to the
  `compiler/typecheck/TcRnDriver.hs:check_main` function.
- Instead of `lookupOccRn_maybe` call the function `lookupInfoOccRn`.
  It returns the list `mains_all` of all the main functions in scope.
- Select from this list `mains_all` all `main` functions that are in
  the export list of the `Main` module.
- If this new list contains exactly one single `main` function, then
  typechecking continues.
- Otherwise issue an appropriate error message.

compiler/typecheck/TcExpr.hs

@@ -17,6 +17,7 @@ module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
                 tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
                 tcCheckId,
                 addExprErrCtxt,
+                addAmbiguousNameErr,
                 getFixedTyVars ) where
 
 #include "HsVersions.h"
@@ -2193,10 +2194,16 @@ disambiguateSelector lr@(L _ rdr) parent_type
 -- occurrence" error, then give up.
 ambiguousSelector :: Located RdrName -> TcM a
 ambiguousSelector (L _ rdr)
+  = do { addAmbiguousNameErr rdr
+       ; failM }
+
+-- | This name really is ambiguous, so add a suitable "ambiguous
+-- occurrence" error, then continue
+addAmbiguousNameErr :: RdrName -> TcM ()
+addAmbiguousNameErr rdr
   = do { env <- getGlobalRdrEnv
        ; let gres = lookupGRE_RdrName rdr env
-       ; setErrCtxt [] $ addNameClashErrRn rdr gres
-       ; failM }
+       ; setErrCtxt [] $ addNameClashErrRn rdr gres}
 
 -- Disambiguate the fields in a record update.
 -- See Note [Disambiguating record fields]

compiler/typecheck/TcRnDriver.hs

@@ -129,7 +129,7 @@ import GHC.Core.Class
 import BasicTypes hiding( SuccessFlag(..) )
 import GHC.Core.Coercion.Axiom
 import Annotations
-import Data.List ( sortBy, sort )
+import Data.List ( find, sortBy, sort )
 import Data.Ord
 import FastString
 import Maybes
@@ -268,17 +268,13 @@ tcRnModuleTcRnM hsc_env mod_sum
                ; tcg_env <- if isHsBootOrSig hsc_src
                             then tcRnHsBootDecls hsc_src local_decls
                             else {-# SCC "tcRnSrcDecls" #-}
-                                 tcRnSrcDecls explicit_mod_hdr local_decls
+                                 tcRnSrcDecls explicit_mod_hdr local_decls export_ies
                ; 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
-                      ; -- When a module header is specified,
-                        -- check that the main module exports a main function.
-                        -- (must be after tcRnExports)
-                        when explicit_mod_hdr $ checkMainExported tcg_env
                       ; -- Compare hi-boot iface (if any) with the real thing
                         -- Must be done after processing the exports
                         tcg_env <- checkHiBootIface tcg_env boot_info
@@ -400,8 +396,9 @@ tcRnImports hsc_env import_decls
 
 tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
              -> [LHsDecl GhcPs]               -- Declarations
+             -> Maybe (Located [LIE GhcPs])
              -> TcM TcGblEnv
-tcRnSrcDecls explicit_mod_hdr decls
+tcRnSrcDecls explicit_mod_hdr decls export_ies
  = do { -- Do all the declarations
       ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
 
@@ -410,7 +407,7 @@ tcRnSrcDecls explicit_mod_hdr decls
         -- NB: always set envs *before* captureTopConstraints
       ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $
                                captureTopConstraints $
-                               checkMain explicit_mod_hdr
+                               checkMain explicit_mod_hdr export_ies
 
       ; setEnvs (tcg_env, tcl_env) $ do {
 
@@ -1719,29 +1716,69 @@ tcTyClsInstDecls tycl_decls deriv_decls binds
 -}
 
 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.
-checkMain explicit_mod_hdr
+-- If we are in module Main, check that 'main' is defined and exported.
+checkMain explicit_mod_hdr export_ies
  = do   { dflags  <- getDynFlags
         ; tcg_env <- getGblEnv
-        ; check_main dflags tcg_env explicit_mod_hdr }
+        ; check_main dflags tcg_env explicit_mod_hdr export_ies }
 
-check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
-check_main dflags tcg_env explicit_mod_hdr
+check_main :: DynFlags -> TcGblEnv -> Bool -> Maybe (Located [LIE GhcPs])
+           -> TcM TcGblEnv
+check_main dflags tcg_env explicit_mod_hdr export_ies
  | mod /= main_mod
  = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
    return tcg_env
 
  | otherwise
- = do   { mb_main <- lookupGlobalOccRn_maybe main_fn
-                -- Check that 'main' is in scope
-                -- It might be imported from another module!
-        ; case mb_main of {
-             Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
-                           ; complain_no_main
-                           ; return tcg_env } ;
-             Just main_name -> do
+   -- 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
+              return tcg_env
+  where
+    mod         = tcg_mod tcg_env
+    main_mod    = mainModIs dflags
+    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
@@ -1779,13 +1816,7 @@ check_main dflags tcg_env explicit_mod_hdr
                                         `plusDU` usesOnly (unitFV main_name)
                         -- Record the use of 'main', so that we don't
                         -- complain about it being defined but not used
-                 })
-    }}}
-  where
-    mod         = tcg_mod tcg_env
-    main_mod    = mainModIs dflags
-    main_fn     = getMainFun dflags
-    interactive = ghcLink dflags == LinkInMemory
+        })}
 
     complain_no_main = unless (interactive && not explicit_mod_hdr)
                               (addErrTc noMainMsg)                  -- #12906
@@ -1795,9 +1826,56 @@ check_main dflags tcg_env explicit_mod_hdr
 
     mainCtxt  = text "When checking the type of the" <+> pp_main_fn
     noMainMsg = text "The" <+> pp_main_fn
-                <+> text "is not defined in module" <+> quotes (ppr main_mod)
+                <+> 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
+      where
+        mbMainOfMain = find (\n -> (moduleName . nameModule) n == main_mod_nm )
+                          all_mains         -- the main function of the Main module
+
 -- | 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
@@ -1805,19 +1883,6 @@ getMainFun dflags = case mainFunIs dflags of
                       Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
                       Nothing -> main_RDR_Unqual
 
--- If we are in module Main, check that 'main' is exported.
-checkMainExported :: TcGblEnv -> TcM ()
-checkMainExported tcg_env
-  = case tcg_main tcg_env of
-      Nothing -> return () -- not the main module
-      Just main_name ->
-         do { dflags <- getDynFlags
-            ; let main_mod = mainModIs dflags
-            ; checkTc (main_name `elem`
-                           concatMap availNames (tcg_exports tcg_env)) $
-                text "The" <+> ppMainFn (nameRdrName main_name) <+>
-                text "is not exported by module" <+> quotes (ppr main_mod) }
-
 ppMainFn :: RdrName -> SDoc
 ppMainFn main_fn
   | rdrNameOcc main_fn == mainOcc
@@ -1842,6 +1907,53 @@ 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
@@ -2574,7 +2686,7 @@ tcRnDeclsi :: HscEnv
            -> IO (Messages, Maybe TcGblEnv)
 tcRnDeclsi hsc_env local_decls
   = runTcInteractive hsc_env $
-    tcRnSrcDecls False local_decls
+    tcRnSrcDecls False local_decls Nothing
 
 externaliseAndTidyId :: Module -> Id -> TcM Id
 externaliseAndTidyId this_mod id

testsuite/tests/typecheck/should_fail/T16453E1.hs

+module Main where
+import T16453T

testsuite/tests/typecheck/should_fail/T16453E1.stderr

+T16453E1.hs:1:1: error:
+    The IO action ‘main’ is not defined in module ‘Main’

testsuite/tests/typecheck/should_fail/T16453E2.hs

+module Main (T16453T.main, T16453S.main) where
+import T16453T
+import T16453S

testsuite/tests/typecheck/should_fail/T16453E2.stderr

+T16453E2.hs:1:1:
+    Ambiguous occurrence ‘main’
+    It could refer to
+       either ‘T16453T.main’,
+              imported from ‘T16453T’ at T16453E2.hs:2:1-14
+              (and originally defined at T16453T.hs:2:1-4)
+           or ‘T16453S.main’,
+              imported from ‘T16453S’ at T16453E2.hs:3:1-14
+              (and originally defined at T16453S.hs:2:1-4)

testsuite/tests/typecheck/should_fail/T16453S.hs

+module T16453S where
+main = putStrLn "T16453S"

testsuite/tests/typecheck/should_fail/T16453T.hs

+module T16453T where
+main = putStrLn "T16453T"

testsuite/tests/typecheck/should_fail/all.T

@@ -516,6 +516,10 @@ test('T16255', normal, compile_fail, [''])
 test('T16204c', normal, compile_fail, [''])
 test('T16394', normal, compile_fail, [''])
 test('T16414', normal, compile_fail, [''])
+test('T16453E1', extra_files(['T16453T.hs', 'T16453S.hs']), multimod_compile_fail,
+    ['T16453E1.hs', '-v0'])
+test('T16453E2', extra_files(['T16453T.hs', 'T16453S.hs']),
+    multimod_compile_fail, ['T16453E2.hs', '-v0'])
 test('T16456', normal, compile_fail, ['-fprint-explicit-foralls'])
 test('T16627', normal, compile_fail, [''])
 test('T502', normal, compile_fail, [''])

testsuite/tests/typecheck/should_run/T16453M0.hs

+module Main where
+import T16453T
+main = putStrLn "T16453M0"

testsuite/tests/typecheck/should_run/T16453M0.stdout

+T16453M0

testsuite/tests/typecheck/should_run/T16453M1.hs

+module Main (T16453T.main)  where
+import T16453T
+main = putStrLn "T16453M1"

testsuite/tests/typecheck/should_run/T16453M1.stdout

+T16453T

testsuite/tests/typecheck/should_run/T16453M2.hs

+module Main (Main.main)  where
+import T16453T
+main = putStrLn "T16453M2"

testsuite/tests/typecheck/should_run/T16453M2.stdout

+T16453M2

testsuite/tests/typecheck/should_run/T16453M3.hs

+module Main (module Main)  where
+import T16453T
+main = putStrLn "T16453M3"

testsuite/tests/typecheck/should_run/T16453M3.stdout

+T16453M3

testsuite/tests/typecheck/should_run/T16453M4.hs

+module Main (module T16453T)  where
+import T16453T
+main = putStrLn "T16453M4"

testsuite/tests/typecheck/should_run/T16453M4.stdout

+T16453T

testsuite/tests/typecheck/should_run/T16453T.hs

+module T16453T where
+main = putStrLn "T16453T"