diff options
47 files changed, 520 insertions, 399 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 diff --git a/testsuite/tests/module/T11970B.hs b/testsuite/tests/module/T11970B.hs index 70a091f141..c3a502f5f2 100644 --- a/testsuite/tests/module/T11970B.hs +++ b/testsuite/tests/module/T11970B.hs @@ -1,5 +1,5 @@ module T11970B ( A(f) ) where -data A = A +data A = MkA -f = A +f = MkA diff --git a/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr b/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr index 7928c74258..866d1468cd 100644 --- a/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr +++ b/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr @@ -1,17 +1,14 @@ -records-mixing-fields.hs:1:1: error: - The IO action ‘main’ is not defined in module ‘Main’ - records-mixing-fields.hs:10:14: error: - Cannot use a mixture of pattern synonym and record selectors - Record selectors defined by ‘MyRec’: qux - Pattern synonym selectors defined by ‘HisRec’: f1 - In the expression: a {f1 = 1, qux = "two"} - In an equation for ‘updater1’: updater1 a = a {f1 = 1, qux = "two"} + • Cannot use a mixture of pattern synonym and record selectors + Record selectors defined by ‘MyRec’: qux + Pattern synonym selectors defined by ‘HisRec’: f1 + • In the expression: a {f1 = 1, qux = "two"} + In an equation for ‘updater1’: updater1 a = a {f1 = 1, qux = "two"} records-mixing-fields.hs:12:14: error: - Cannot use a mixture of pattern synonym and record selectors - Record selectors defined by ‘MyRec’: foo - Pattern synonym selectors defined by ‘HisRec’: f1 - In the expression: a {f1 = 1, foo = 2} - In an equation for ‘updater2’: updater2 a = a {f1 = 1, foo = 2} + • Cannot use a mixture of pattern synonym and record selectors + Record selectors defined by ‘MyRec’: foo + Pattern synonym selectors defined by ‘HisRec’: f1 + • In the expression: a {f1 = 1, foo = 2} + In an equation for ‘updater2’: updater2 a = a {f1 = 1, foo = 2} diff --git a/testsuite/tests/quantified-constraints/T17267e.stderr b/testsuite/tests/quantified-constraints/T17267e.stderr index b497fa1009..f94ba1e872 100644 --- a/testsuite/tests/quantified-constraints/T17267e.stderr +++ b/testsuite/tests/quantified-constraints/T17267e.stderr @@ -1,7 +1,4 @@ -T17267e.hs:1:1: error: - The IO action ‘main’ is not defined in module ‘Main’ - T17267e.hs:16:14: error: • Reduction stack overflow; size = 201 When simplifying the following type: Show a diff --git a/testsuite/tests/quotes/T18263.hs b/testsuite/tests/quotes/T18263.hs index 10e923480b..57f20fbf49 100644 --- a/testsuite/tests/quotes/T18263.hs +++ b/testsuite/tests/quotes/T18263.hs @@ -13,14 +13,21 @@ When looking up something with 'lookupGlobalOccRn_maybe', which is called by This should still fail to compile though, as reify should complain that "x" isn't in the type environment, albeit with one less error. + +Later (March 2021): actually this should really compile fine: + * The [d| ... |] splices in a top-level binding for x + * The reify looks for that binding +It was really a bug that it didn't work, now fixed. + -} module T18263 where import Language.Haskell.TH import Language.Haskell.TH.Syntax +import System.IO do n <- newName "x" - addModFinalizer $ reify n >>= runIO . print + addModFinalizer $ reify n >>= runIO . hPrint stderr [d| $(varP n) = 42 |] diff --git a/testsuite/tests/quotes/T18263.stderr b/testsuite/tests/quotes/T18263.stderr index 023432c85b..f8a7aab415 100644 --- a/testsuite/tests/quotes/T18263.stderr +++ b/testsuite/tests/quotes/T18263.stderr @@ -1,3 +1 @@ - -T18263.hs:1:1: - ‘x’ is not in the type environment at a reify +VarI T18263.x (ConT GHC.Num.Integer.Integer) Nothing diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T index b0e5274761..68a13ca5ab 100644 --- a/testsuite/tests/quotes/all.T +++ b/testsuite/tests/quotes/all.T @@ -18,7 +18,7 @@ test('T10384', normal, compile_fail, ['']) test('T16384', req_th, compile, ['']) test('T17857', normal, compile, ['']) test('T18103', normal, compile, ['']) -test('T18263', normal, compile_fail, ['']) +test('T18263', normal, compile, ['']) test('T18521', normal, compile, ['']) test('TH_tf2', normal, compile, ['-v0']) diff --git a/testsuite/tests/th/TH_finalizer2M.hs b/testsuite/tests/th/TH_finalizer2M.hs index 7eea2d8f46..037c648d2a 100644 --- a/testsuite/tests/th/TH_finalizer2M.hs +++ b/testsuite/tests/th/TH_finalizer2M.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -module TH_finalizer2M where +module TH_finalizer2M( f, g) where import Language.Haskell.TH.Syntax diff --git a/testsuite/tests/typecheck/should_fail/T12906.stderr b/testsuite/tests/typecheck/should_fail/T12906.stderr index f1f245c912..0de9794533 100644 --- a/testsuite/tests/typecheck/should_fail/T12906.stderr +++ b/testsuite/tests/typecheck/should_fail/T12906.stderr @@ -1,7 +1,4 @@ -T12906.hs:1:1: error: - The IO action ‘main’ is not defined in module ‘Main’ - T12906.hs:2:7: error: • Couldn't match type: IO () with: [Char] diff --git a/testsuite/tests/typecheck/should_fail/T13292.hs b/testsuite/tests/typecheck/should_fail/T13292.hs index efc71b6539..c727812a2c 100644 --- a/testsuite/tests/typecheck/should_fail/T13292.hs +++ b/testsuite/tests/typecheck/should_fail/T13292.hs @@ -4,3 +4,8 @@ import T13292a -- main :: IO () main = someFunc + +-- This one is compiled with -fdefer-type-errors, and +-- annoyingly reports the ill-typed twice. It is awkward +-- to prevent this, and it's very much a corner case, +-- so I'm accepting it. See Note [Dealing with main] diff --git a/testsuite/tests/typecheck/should_fail/T13292.stderr b/testsuite/tests/typecheck/should_fail/T13292.stderr index 7607505d0e..a3a7ba3bae 100644 --- a/testsuite/tests/typecheck/should_fail/T13292.stderr +++ b/testsuite/tests/typecheck/should_fail/T13292.stderr @@ -19,5 +19,11 @@ T13292.hs:6:1: warning: [-Wdeferred-type-errors (in -Wdefault)] • Couldn't match type ‘GHC.Types.Any’ with ‘IO’ Expected: IO () Actual: GHC.Types.Any () + • When checking the type of the IO action ‘main’ + +T13292.hs:6:1: warning: [-Wdeferred-type-errors (in -Wdefault)] + • Couldn't match type ‘GHC.Types.Any’ with ‘IO’ + Expected: IO () + Actual: GHC.Types.Any () • In the expression: main When checking the type of the IO action ‘main’ diff --git a/testsuite/tests/typecheck/should_fail/T16453E2.stderr b/testsuite/tests/typecheck/should_fail/T16453E2.stderr index 4999d60cc7..b7beedb511 100644 --- a/testsuite/tests/typecheck/should_fail/T16453E2.stderr +++ b/testsuite/tests/typecheck/should_fail/T16453E2.stderr @@ -1,9 +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) + +T16453E2.hs:1:28: error: + Conflicting exports for ‘main’: + ‘T16453T.main’ exports ‘T16453T.main’ + imported from ‘T16453T’ at T16453E2.hs:2:1-14 + (and originally defined at T16453T.hs:2:1-4) + ‘T16453S.main’ exports ‘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/T19397E1.hs b/testsuite/tests/typecheck/should_fail/T19397E1.hs new file mode 100644 index 0000000000..e4b02ceb30 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397E1.hs @@ -0,0 +1,5 @@ +module Main (main) where +import T19397S + +main :: IO () +main = putStrLn "T19397E1" diff --git a/testsuite/tests/typecheck/should_fail/T19397E1.stderr b/testsuite/tests/typecheck/should_fail/T19397E1.stderr new file mode 100644 index 0000000000..00c13f2eca --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397E1.stderr @@ -0,0 +1,8 @@ + +T19397E1.hs:1:14: error: + Ambiguous occurrence ‘main’ + It could refer to + either ‘T19397S.main’, + imported from ‘T19397S’ at T19397E1.hs:2:1-14 + (and originally defined at T19397S.hs:4:1-4) + or ‘Main.main’, defined at T19397E1.hs:5:1 diff --git a/testsuite/tests/typecheck/should_fail/T19397E2.hs b/testsuite/tests/typecheck/should_fail/T19397E2.hs new file mode 100644 index 0000000000..3fb2b9dfca --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397E2.hs @@ -0,0 +1,5 @@ + +import T19397S + +main :: IO () +main = putStrLn "T19397E2" diff --git a/testsuite/tests/typecheck/should_fail/T19397E2.stderr b/testsuite/tests/typecheck/should_fail/T19397E2.stderr new file mode 100644 index 0000000000..4fc5073310 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397E2.stderr @@ -0,0 +1,8 @@ + +T19397E2.hs:1:1: error: + Ambiguous occurrence ‘main’ + It could refer to + either ‘T19397S.main’, + imported from ‘T19397S’ at T19397E2.hs:2:1-14 + (and originally defined at T19397S.hs:4:1-4) + or ‘Main.main’, defined at T19397E2.hs:5:1 diff --git a/testsuite/tests/typecheck/should_fail/T19397E3.hs b/testsuite/tests/typecheck/should_fail/T19397E3.hs new file mode 100644 index 0000000000..7836ea0f6a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397E3.hs @@ -0,0 +1,2 @@ +module Main where +import T19397S (foo) diff --git a/testsuite/tests/typecheck/should_fail/T19397E3.stderr b/testsuite/tests/typecheck/should_fail/T19397E3.stderr new file mode 100644 index 0000000000..2359ec171a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397E3.stderr @@ -0,0 +1,3 @@ + +T19397E3.hs:1:1: error: + The main IO action ‘foo’ is not defined in module ‘Main’ diff --git a/testsuite/tests/typecheck/should_fail/T19397E4.hs b/testsuite/tests/typecheck/should_fail/T19397E4.hs new file mode 100644 index 0000000000..1b4b9cf2b1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397E4.hs @@ -0,0 +1,5 @@ +module Main () where +import T19397S + +main :: IO () +main = putStrLn "T19397E4" diff --git a/testsuite/tests/typecheck/should_fail/T19397E4.stderr b/testsuite/tests/typecheck/should_fail/T19397E4.stderr new file mode 100644 index 0000000000..3f9eec7bf0 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397E4.stderr @@ -0,0 +1,3 @@ + +T19397E4.hs:1:1: error: + The main IO action ‘foo’ is not exported by module ‘Main’ diff --git a/testsuite/tests/typecheck/should_fail/T19397S.hs b/testsuite/tests/typecheck/should_fail/T19397S.hs new file mode 100644 index 0000000000..9316d7d99a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T19397S.hs @@ -0,0 +1,7 @@ +module T19397S where + +main :: IO () +main = putStrLn "T19379S-main" + +foo :: IO () +foo = putStrLn "T19379S-foo" diff --git a/testsuite/tests/typecheck/should_fail/T2354.stderr b/testsuite/tests/typecheck/should_fail/T2354.stderr index 5c5fcfcf0e..e21eca081e 100644 --- a/testsuite/tests/typecheck/should_fail/T2354.stderr +++ b/testsuite/tests/typecheck/should_fail/T2354.stderr @@ -1,6 +1,6 @@ -T2354.hs:4:3: +T2354.hs:4:3: error: The NOINLINE pragma for default method ‘toInt’ lacks an accompanying binding -T2354.hs:6:3: +T2354.hs:6:3: error: The NOINLINE pragma for default method ‘fromInt’ lacks an accompanying binding diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 0bd86e9288..cdf26c15be 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -618,3 +618,11 @@ test('T18869', normal, compile_fail, ['']) test('T19142', normal, compile_fail, ['']) test('T19346', normal, compile_fail, ['-fprint-typechecker-elaboration']) test('T19364', normal, compile_fail, ['']) +test('T19397E1', extra_files(['T19397S.hs']), multimod_compile_fail, + ['T19397E1.hs', '-v0']) +test('T19397E2', extra_files(['T19397S.hs']), multimod_compile_fail, + ['T19397E2.hs', '-v0']) +test('T19397E3', extra_files(['T19397S.hs']), multimod_compile_fail, + ['T19397E3.hs', '-v0 -main-is foo']) +test('T19397E4', extra_files(['T19397S.hs']), multimod_compile_fail, + ['T19397E4.hs', '-v0 -main-is foo']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail199.stderr b/testsuite/tests/typecheck/should_fail/tcfail199.stderr index 50fc8e5f44..5ef1ebab33 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail199.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail199.stderr @@ -4,5 +4,4 @@ tcfail199.hs:5:1: error: with: IO t0 Expected: IO t0 Actual: String - • In the expression: main - When checking the type of the IO action ‘main’ + • When checking the type of the IO action ‘main’ diff --git a/testsuite/tests/typecheck/should_run/T16453M1.stdout b/testsuite/tests/typecheck/should_run/T16453M1.stdout index e4dfbcd44f..3c86130b45 100644 --- a/testsuite/tests/typecheck/should_run/T16453M1.stdout +++ b/testsuite/tests/typecheck/should_run/T16453M1.stdout @@ -1 +1 @@ -T16453T +T16453T.main diff --git a/testsuite/tests/typecheck/should_run/T16453M4.stdout b/testsuite/tests/typecheck/should_run/T16453M4.stdout index e4dfbcd44f..3c86130b45 100644 --- a/testsuite/tests/typecheck/should_run/T16453M4.stdout +++ b/testsuite/tests/typecheck/should_run/T16453M4.stdout @@ -1 +1 @@ -T16453T +T16453T.main diff --git a/testsuite/tests/typecheck/should_run/T16453M5.hs b/testsuite/tests/typecheck/should_run/T16453M5.hs new file mode 100644 index 0000000000..a79a33003d --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M5.hs @@ -0,0 +1,2 @@ +module Main (T16453T.main) where +import T16453T diff --git a/testsuite/tests/typecheck/should_run/T16453M5.stdout b/testsuite/tests/typecheck/should_run/T16453M5.stdout new file mode 100644 index 0000000000..3c86130b45 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M5.stdout @@ -0,0 +1 @@ +T16453T.main diff --git a/testsuite/tests/typecheck/should_run/T16453M6.hs b/testsuite/tests/typecheck/should_run/T16453M6.hs new file mode 100644 index 0000000000..b013e857cd --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M6.hs @@ -0,0 +1,2 @@ +module Main (T16453T.foo) where +import T16453T diff --git a/testsuite/tests/typecheck/should_run/T16453M6.stdout b/testsuite/tests/typecheck/should_run/T16453M6.stdout new file mode 100644 index 0000000000..72252ffbd0 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T16453M6.stdout @@ -0,0 +1 @@ +T16453T.foo diff --git a/testsuite/tests/typecheck/should_run/T16453T.hs b/testsuite/tests/typecheck/should_run/T16453T.hs index 98ea6255f7..b8dd8923c4 100644 --- a/testsuite/tests/typecheck/should_run/T16453T.hs +++ b/testsuite/tests/typecheck/should_run/T16453T.hs @@ -1,2 +1,4 @@ module T16453T where -main = putStrLn "T16453T" +main = putStrLn "T16453T.main" +foo = putStrLn "T16453T.foo" + diff --git a/testsuite/tests/typecheck/should_run/T19397M0.hs b/testsuite/tests/typecheck/should_run/T19397M0.hs new file mode 100644 index 0000000000..fcc08716d5 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M0.hs @@ -0,0 +1,2 @@ +module Main (main) where +import T19397S diff --git a/testsuite/tests/typecheck/should_run/T19397M0.stdout b/testsuite/tests/typecheck/should_run/T19397M0.stdout new file mode 100644 index 0000000000..4ff016fc0e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M0.stdout @@ -0,0 +1 @@ +T19379S-main diff --git a/testsuite/tests/typecheck/should_run/T19397M1.hs b/testsuite/tests/typecheck/should_run/T19397M1.hs new file mode 100644 index 0000000000..75413537c8 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M1.hs @@ -0,0 +1 @@ +import T19397S diff --git a/testsuite/tests/typecheck/should_run/T19397M1.stdout b/testsuite/tests/typecheck/should_run/T19397M1.stdout new file mode 100644 index 0000000000..4ff016fc0e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M1.stdout @@ -0,0 +1 @@ +T19379S-main diff --git a/testsuite/tests/typecheck/should_run/T19397M2.hs b/testsuite/tests/typecheck/should_run/T19397M2.hs new file mode 100644 index 0000000000..71a75a102b --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M2.hs @@ -0,0 +1,2 @@ +module Main(foo) where +import T19397S (foo) diff --git a/testsuite/tests/typecheck/should_run/T19397M2.stdout b/testsuite/tests/typecheck/should_run/T19397M2.stdout new file mode 100644 index 0000000000..3fe3b9aac6 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M2.stdout @@ -0,0 +1 @@ +T19379S-foo diff --git a/testsuite/tests/typecheck/should_run/T19397M3.hs b/testsuite/tests/typecheck/should_run/T19397M3.hs new file mode 100644 index 0000000000..fd817a8176 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M3.hs @@ -0,0 +1 @@ +import T19397S (foo) diff --git a/testsuite/tests/typecheck/should_run/T19397M3.stdout b/testsuite/tests/typecheck/should_run/T19397M3.stdout new file mode 100644 index 0000000000..3fe3b9aac6 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M3.stdout @@ -0,0 +1 @@ +T19379S-foo diff --git a/testsuite/tests/typecheck/should_run/T19397M4.hs b/testsuite/tests/typecheck/should_run/T19397M4.hs new file mode 100644 index 0000000000..544242c2f5 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M4.hs @@ -0,0 +1,2 @@ +module Main(module T19397S) where +import T19397S (foo) diff --git a/testsuite/tests/typecheck/should_run/T19397M4.stdout b/testsuite/tests/typecheck/should_run/T19397M4.stdout new file mode 100644 index 0000000000..3fe3b9aac6 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397M4.stdout @@ -0,0 +1 @@ +T19379S-foo diff --git a/testsuite/tests/typecheck/should_run/T19397S.hs b/testsuite/tests/typecheck/should_run/T19397S.hs new file mode 100644 index 0000000000..9316d7d99a --- /dev/null +++ b/testsuite/tests/typecheck/should_run/T19397S.hs @@ -0,0 +1,7 @@ +module T19397S where + +main :: IO () +main = putStrLn "T19379S-main" + +foo :: IO () +foo = putStrLn "T19379S-foo" diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index ef7bedb354..c4005e402e 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/testsuite/tests/typecheck/should_run/all.T @@ -140,6 +140,8 @@ 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('T16453M5', extra_files(['T16453T.hs']), compile_and_run, ['']) +test('T16453M6', extra_files(['T16453T.hs']), compile_and_run, ['-main-is foo']) test('UnliftedNewtypesRun', normal, compile_and_run, ['']) test('UnliftedNewtypesFamilyRun', normal, compile_and_run, ['']) test('UnliftedNewtypesDependentFamilyRun', normal, compile_and_run, ['']) @@ -148,3 +150,8 @@ test('UnliftedNewtypesCoerceRun', normal, compile_and_run, ['']) test('LevPolyResultInst', normal, compile_and_run, ['']) test('T17104', normal, compile_and_run, ['']) test('T18627', normal, compile_and_run, ['-O']) # Optimisation shows up the bug +test('T19397M0', extra_files(['T19397S.hs']), compile_and_run, ['']) +test('T19397M1', extra_files(['T19397S.hs']), compile_and_run, ['']) +test('T19397M2', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo']) +test('T19397M3', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo']) +test('T19397M4', extra_files(['T19397S.hs']), compile_and_run, ['-main-is foo']) |