[Git][ghc/ghc][master] Use export list of Main module in function TcRnDriver.hs:check_main (Fix #16453)
Marge Bot
gitlab at gitlab.haskell.org
Wed Mar 25 18:45:15 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
703221f4 by Roland Senn at 2020-03-25T14:45:04-04:00
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.
- - - - -
21 changed files:
- compiler/typecheck/TcExpr.hs
- compiler/typecheck/TcRnDriver.hs
- + testsuite/tests/typecheck/should_fail/T16453E1.hs
- + testsuite/tests/typecheck/should_fail/T16453E1.stderr
- + testsuite/tests/typecheck/should_fail/T16453E2.hs
- + testsuite/tests/typecheck/should_fail/T16453E2.stderr
- + testsuite/tests/typecheck/should_fail/T16453S.hs
- + testsuite/tests/typecheck/should_fail/T16453T.hs
- testsuite/tests/typecheck/should_fail/all.T
- + testsuite/tests/typecheck/should_run/T16453M0.hs
- + testsuite/tests/typecheck/should_run/T16453M0.stdout
- + testsuite/tests/typecheck/should_run/T16453M1.hs
- + testsuite/tests/typecheck/should_run/T16453M1.stdout
- + testsuite/tests/typecheck/should_run/T16453M2.hs
- + testsuite/tests/typecheck/should_run/T16453M2.stdout
- + testsuite/tests/typecheck/should_run/T16453M3.hs
- + testsuite/tests/typecheck/should_run/T16453M3.stdout
- + testsuite/tests/typecheck/should_run/T16453M4.hs
- + testsuite/tests/typecheck/should_run/T16453M4.stdout
- + testsuite/tests/typecheck/should_run/T16453T.hs
- testsuite/tests/typecheck/should_run/all.T
Changes:
=====================================
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
=====================================
@@ -0,0 +1,2 @@
+module Main where
+import T16453T
=====================================
testsuite/tests/typecheck/should_fail/T16453E1.stderr
=====================================
@@ -0,0 +1,2 @@
+T16453E1.hs:1:1: error:
+ The IO action ‘main’ is not defined in module ‘Main’
=====================================
testsuite/tests/typecheck/should_fail/T16453E2.hs
=====================================
@@ -0,0 +1,3 @@
+module Main (T16453T.main, T16453S.main) where
+import T16453T
+import T16453S
=====================================
testsuite/tests/typecheck/should_fail/T16453E2.stderr
=====================================
@@ -0,0 +1,9 @@
+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
=====================================
@@ -0,0 +1,2 @@
+module T16453S where
+main = putStrLn "T16453S"
=====================================
testsuite/tests/typecheck/should_fail/T16453T.hs
=====================================
@@ -0,0 +1,2 @@
+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
=====================================
@@ -0,0 +1,3 @@
+module Main where
+import T16453T
+main = putStrLn "T16453M0"
=====================================
testsuite/tests/typecheck/should_run/T16453M0.stdout
=====================================
@@ -0,0 +1 @@
+T16453M0
=====================================
testsuite/tests/typecheck/should_run/T16453M1.hs
=====================================
@@ -0,0 +1,3 @@
+module Main (T16453T.main) where
+import T16453T
+main = putStrLn "T16453M1"
=====================================
testsuite/tests/typecheck/should_run/T16453M1.stdout
=====================================
@@ -0,0 +1 @@
+T16453T
=====================================
testsuite/tests/typecheck/should_run/T16453M2.hs
=====================================
@@ -0,0 +1,3 @@
+module Main (Main.main) where
+import T16453T
+main = putStrLn "T16453M2"
=====================================
testsuite/tests/typecheck/should_run/T16453M2.stdout
=====================================
@@ -0,0 +1 @@
+T16453M2
=====================================
testsuite/tests/typecheck/should_run/T16453M3.hs
=====================================
@@ -0,0 +1,3 @@
+module Main (module Main) where
+import T16453T
+main = putStrLn "T16453M3"
=====================================
testsuite/tests/typecheck/should_run/T16453M3.stdout
=====================================
@@ -0,0 +1 @@
+T16453M3
=====================================
testsuite/tests/typecheck/should_run/T16453M4.hs
=====================================
@@ -0,0 +1,3 @@
+module Main (module T16453T) where
+import T16453T
+main = putStrLn "T16453M4"
=====================================
testsuite/tests/typecheck/should_run/T16453M4.stdout
=====================================
@@ -0,0 +1 @@
+T16453T
=====================================
testsuite/tests/typecheck/should_run/T16453T.hs
=====================================
@@ -0,0 +1,2 @@
+module T16453T where
+main = putStrLn "T16453T"
=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -135,6 +135,11 @@ test('T14218', normal, compile_and_run, [''])
test('T14236', normal, compile_and_run, [''])
test('T14925', normal, compile_and_run, [''])
test('T14341', normal, compile_and_run, [''])
+test('T16453M0', extra_files(['T16453T.hs']), compile_and_run, [''])
+test('T16453M1', extra_files(['T16453T.hs']), compile_and_run, [''])
+test('T16453M2', extra_files(['T16453T.hs']), compile_and_run, [''])
+test('T16453M3', extra_files(['T16453T.hs']), compile_and_run, [''])
+test('T16453M4', extra_files(['T16453T.hs']), compile_and_run, [''])
test('UnliftedNewtypesRun', normal, compile_and_run, [''])
test('UnliftedNewtypesFamilyRun', normal, compile_and_run, [''])
test('UnliftedNewtypesDependentFamilyRun', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/703221f408b023a1b3433938572e7b5c24b4af60
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/703221f408b023a1b3433938572e7b5c24b4af60
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200325/18d4c44f/attachment-0001.html>
More information about the ghc-commits
mailing list