diff options
21 files changed, 215 insertions, 45 deletions
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index df08106286..4ddcd3d532 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/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] diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 8c7658c1d6..92df16b9c5 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/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 diff --git a/testsuite/tests/typecheck/should_fail/T16453E1.hs b/testsuite/tests/typecheck/should_fail/T16453E1.hs new file mode 100644 index 0000000000..3e910dd453 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T16453E1.hs @@ -0,0 +1,2 @@ +module Main where +import T16453T diff --git a/testsuite/tests/typecheck/should_fail/T16453E1.stderr b/testsuite/tests/typecheck/should_fail/T16453E1.stderr new file mode 100644 index 0000000000..d435ab8e1e --- /dev/null +++ b/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’ diff --git a/testsuite/tests/typecheck/should_fail/T16453E2.hs b/testsuite/tests/typecheck/should_fail/T16453E2.hs new file mode 100644 index 0000000000..d27e2e6c41 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T16453E2.hs @@ -0,0 +1,3 @@ +module Main (T16453T.main, T16453S.main) where +import T16453T +import T16453S diff --git a/testsuite/tests/typecheck/should_fail/T16453E2.stderr b/testsuite/tests/typecheck/should_fail/T16453E2.stderr new file mode 100644 index 0000000000..4999d60cc7 --- /dev/null +++ b/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) diff --git a/testsuite/tests/typecheck/should_fail/T16453S.hs b/testsuite/tests/typecheck/should_fail/T16453S.hs new file mode 100644 index 0000000000..c9e966dca9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T16453S.hs @@ -0,0 +1,2 @@ +module T16453S where +main = putStrLn "T16453S" diff --git a/testsuite/tests/typecheck/should_fail/T16453T.hs b/testsuite/tests/typecheck/should_fail/T16453T.hs new file mode 100644 index 0000000000..98ea6255f7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T16453T.hs @@ -0,0 +1,2 @@ +module T16453T where +main = putStrLn "T16453T" diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 60e50ca241..4f8f08ed85 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/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, ['']) diff --git a/testsuite/tests/typecheck/should_run/T16453M0.hs b/testsuite/tests/typecheck/should_run/T16453M0.hs new file mode 100644 index 0000000000..08ace5d99e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M0.hs @@ -0,0 +1,3 @@ +module Main where +import T16453T +main = putStrLn "T16453M0" diff --git a/testsuite/tests/typecheck/should_run/T16453M0.stdout b/testsuite/tests/typecheck/should_run/T16453M0.stdout new file mode 100644 index 0000000000..e61283f99c --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M0.stdout @@ -0,0 +1 @@ +T16453M0 diff --git a/testsuite/tests/typecheck/should_run/T16453M1.hs b/testsuite/tests/typecheck/should_run/T16453M1.hs new file mode 100644 index 0000000000..aa240f2c75 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M1.hs @@ -0,0 +1,3 @@ +module Main (T16453T.main) where +import T16453T +main = putStrLn "T16453M1" diff --git a/testsuite/tests/typecheck/should_run/T16453M1.stdout b/testsuite/tests/typecheck/should_run/T16453M1.stdout new file mode 100644 index 0000000000..e4dfbcd44f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M1.stdout @@ -0,0 +1 @@ +T16453T diff --git a/testsuite/tests/typecheck/should_run/T16453M2.hs b/testsuite/tests/typecheck/should_run/T16453M2.hs new file mode 100644 index 0000000000..acf4e6791b --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M2.hs @@ -0,0 +1,3 @@ +module Main (Main.main) where +import T16453T +main = putStrLn "T16453M2" diff --git a/testsuite/tests/typecheck/should_run/T16453M2.stdout b/testsuite/tests/typecheck/should_run/T16453M2.stdout new file mode 100644 index 0000000000..ab13919690 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M2.stdout @@ -0,0 +1 @@ +T16453M2 diff --git a/testsuite/tests/typecheck/should_run/T16453M3.hs b/testsuite/tests/typecheck/should_run/T16453M3.hs new file mode 100644 index 0000000000..167d8fde7c --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M3.hs @@ -0,0 +1,3 @@ +module Main (module Main) where +import T16453T +main = putStrLn "T16453M3" diff --git a/testsuite/tests/typecheck/should_run/T16453M3.stdout b/testsuite/tests/typecheck/should_run/T16453M3.stdout new file mode 100644 index 0000000000..f0c95103e7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M3.stdout @@ -0,0 +1 @@ +T16453M3 diff --git a/testsuite/tests/typecheck/should_run/T16453M4.hs b/testsuite/tests/typecheck/should_run/T16453M4.hs new file mode 100644 index 0000000000..a1ec32bda6 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M4.hs @@ -0,0 +1,3 @@ +module Main (module T16453T) where +import T16453T +main = putStrLn "T16453M4" diff --git a/testsuite/tests/typecheck/should_run/T16453M4.stdout b/testsuite/tests/typecheck/should_run/T16453M4.stdout new file mode 100644 index 0000000000..e4dfbcd44f --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M4.stdout @@ -0,0 +1 @@ +T16453T diff --git a/testsuite/tests/typecheck/should_run/T16453T.hs b/testsuite/tests/typecheck/should_run/T16453T.hs new file mode 100644 index 0000000000..98ea6255f7 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453T.hs @@ -0,0 +1,2 @@ +module T16453T where +main = putStrLn "T16453T" diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index 512362f1bb..4cd7a1b73c 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/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, ['']) |