summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Rename/Env.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs75
-rw-r--r--compiler/GHC/Tc/Module.hs620
-rw-r--r--compiler/GHC/Tc/Types.hs38
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs2
-rw-r--r--testsuite/tests/module/T11970B.hs4
-rw-r--r--testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr23
-rw-r--r--testsuite/tests/quantified-constraints/T17267e.stderr3
-rw-r--r--testsuite/tests/quotes/T18263.hs9
-rw-r--r--testsuite/tests/quotes/T18263.stderr4
-rw-r--r--testsuite/tests/quotes/all.T2
-rw-r--r--testsuite/tests/th/TH_finalizer2M.hs2
-rw-r--r--testsuite/tests/typecheck/should_fail/T12906.stderr3
-rw-r--r--testsuite/tests/typecheck/should_fail/T13292.hs5
-rw-r--r--testsuite/tests/typecheck/should_fail/T13292.stderr6
-rw-r--r--testsuite/tests/typecheck/should_fail/T16453E2.stderr18
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397E1.hs5
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397E1.stderr8
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397E2.hs5
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397E2.stderr8
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397E3.hs2
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397E3.stderr3
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397E4.hs5
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397E4.stderr3
-rw-r--r--testsuite/tests/typecheck/should_fail/T19397S.hs7
-rw-r--r--testsuite/tests/typecheck/should_fail/T2354.stderr4
-rw-r--r--testsuite/tests/typecheck/should_fail/all.T8
-rw-r--r--testsuite/tests/typecheck/should_fail/tcfail199.stderr3
-rw-r--r--testsuite/tests/typecheck/should_run/T16453M1.stdout2
-rw-r--r--testsuite/tests/typecheck/should_run/T16453M4.stdout2
-rw-r--r--testsuite/tests/typecheck/should_run/T16453M5.hs2
-rw-r--r--testsuite/tests/typecheck/should_run/T16453M5.stdout1
-rw-r--r--testsuite/tests/typecheck/should_run/T16453M6.hs2
-rw-r--r--testsuite/tests/typecheck/should_run/T16453M6.stdout1
-rw-r--r--testsuite/tests/typecheck/should_run/T16453T.hs4
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M0.hs2
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M0.stdout1
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M1.hs1
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M1.stdout1
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M2.hs2
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M2.stdout1
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M3.hs1
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M3.stdout1
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M4.hs2
-rw-r--r--testsuite/tests/typecheck/should_run/T19397M4.stdout1
-rw-r--r--testsuite/tests/typecheck/should_run/T19397S.hs7
-rwxr-xr-xtestsuite/tests/typecheck/should_run/all.T7
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'])