import StaticFlags
import HsSyn
import RdrHsSyn
-
import PrelNames
import RdrName
import TcHsSyn
import FamInst
import InstEnv
import FamInstEnv
+import TcAnnotations
import TcBinds
import TcDefaults
import TcEnv
import DataCon
import Type
import Class
+import Data.List ( sortBy )
#ifdef GHCI
import Linker
import {- Kind parts of -} Type
import BasicTypes
import Foreign.Ptr( Ptr )
+import TidyPgm ( globaliseAndTidyId )
#endif
import FastString
-- thing (especially via 'module Foo' export item)
-- That is, only uses in the *body* of the module are complained about
traceRn (text "rn3") ;
- failIfErrsM ; -- finishDeprecations crashes sometimes
+ failIfErrsM ; -- finishWarnings crashes sometimes
-- as a result of typechecker repairs (e.g. unboundNames)
- tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ;
+ tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ;
-- Process the export list
traceRn (text "rn4a: before exports");
-- Must be done after processing the exports
tcg_env <- checkHiBootIface tcg_env boot_iface ;
- -- Make the new type env available to stuff slurped from interface files
- -- Must do this after checkHiBootIface, because the latter might add new
- -- bindings for boot_dfuns, which may be mentioned in imported unfoldings
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
+ -- The new type env is already available to stuff slurped from
+ -- interface files, via TcEnv.updateGlobalTypeEnv
+ -- It's important that this includes the stuff in checkHiBootIface,
+ -- because the latter might add new bindings for boot_dfuns,
+ -- which may be mentioned in imported unfoldings
-- Rename the Haddock documentation
tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
-- (in fact, it might not even need to be in the scope of
-- this tcg_env at all)
avails <- getLocalNonValBinders (mkFakeGroup ldecls) ;
- tc_envs <- extendGlobalRdrEnvRn False avails
- emptyFsEnv {- no fixity decls -} ;
+ tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ;
setEnvs tc_envs $ do {
-- Typecheck them all together so that
-- any mutually recursive types are done right
- tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ;
- -- Make the new type env available to stuff slurped from interface files
+ -- Just discard the auxiliary bindings; they are generated
+ -- only for Haskell source code, and should already be in Core
+ (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
+ -- Make the new type env available to stuff slurped from interface files
-- Now the core bindings
core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
my_exports = map (Avail . idName) bndrs ;
-- ToDo: export the data types also?
- final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
+ final_type_env =
+ extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
mg_boot = False,
-- Stubs
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
- mg_deprecs = NoDeprecs,
+ mg_warns = NoWarnings,
mg_foreign = NoStubs,
mg_hpc_info = emptyHpcInfo False,
mg_modBreaks = emptyModBreaks,
-- Even tcSimplifyTop may do some unification.
traceTc (text "Tc9") ;
let { (tcg_env, _) = tc_envs
- ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
- tcg_rules = rules, tcg_fords = fords } = tcg_env
+ ; TcGblEnv { tcg_type_env = type_env,
+ tcg_binds = binds,
+ tcg_rules = rules,
+ tcg_fords = fords } = tcg_env
; all_binds = binds `unionBags` inst_binds } ;
failIfErrsM ; -- Don't zonk if there have been errors
(bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
+
let { final_type_env = extendTypeEnvWithIds type_env bind_ids
- ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
- tcg_binds = binds',
+ ; tcg_env' = tcg_env { tcg_binds = binds',
tcg_rules = rules',
tcg_fords = fords' } } ;
- return (tcg_env' { tcg_binds = tcg_binds tcg_env' })
+ setGlobalTypeEnv tcg_env' final_type_env
}
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
Nothing -> return ()
-- Rename the declarations
- ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
+ ; (tcg_env, HsGroup {
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fords = _,
+ hs_defds = _, -- Todo: check no foreign decls, no rules,
+ hs_ruleds = _, -- no default decls and no annotation decls
+ hs_annds = _,
+ hs_valds = val_binds }) <- rnTopSrcDecls first_group
; setGblEnv tcg_env $ do {
- -- Todo: check no foreign decls, no rules, no default decls
-- Typecheck type/class decls
; traceTc (text "Tc2")
- ; let tycl_decls = hs_tyclds rn_group
- ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
+ ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
; traceTc (text "Tc3")
; (tcg_env, inst_infos, _deriv_binds)
- <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
+ <- tcInstDecls1 tycl_decls inst_decls deriv_decls
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
; traceTc (text "Tc5")
- ; val_ids <- tcHsBootSigs (hs_valds rn_group)
+ ; val_ids <- tcHsBootSigs val_binds
-- Wrap up
-- No simplification or zonking to do
-- Make the final type-env
-- Include the dfun_ids so that their type sigs
- -- are written into the interface file
+ -- are written into the interface file.
+ -- And similarly the aux_ids from aux_binds
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
- ; dfun_ids = map iDFunId inst_infos }
- ; return (gbl_env { tcg_type_env = type_env2 })
+ ; type_env3 = extendTypeEnvWithIds type_env1 aux_ids
+ ; dfun_ids = map iDFunId inst_infos
+ ; aux_ids = case aux_binds of
+ ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs]
+ _ -> panic "tcRnHsBoodDecls"
+ }
+
+ ; setGlobalTypeEnv gbl_env type_env2
}}}}
spliceInHsBootErr (SpliceDecl (L loc _), _)
-- Check the exports of the boot module, one by one
; mapM_ check_export boot_exports
- -- Check instance declarations
- ; mb_dfun_prs <- mapM check_inst boot_insts
- ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds,
- tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
- dfun_prs = catMaybes mb_dfun_prs
- boot_dfuns = map fst dfun_prs
- dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
- | (boot_dfun, dfun) <- dfun_prs ]
-
-- Check for no family instances
; unless (null boot_fam_insts) $
panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
-- be the equivalent to the dfun bindings returned for class
-- instances? We can't easily equate tycons...
+ -- Check instance declarations
+ ; mb_dfun_prs <- mapM check_inst boot_insts
+ ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
+ final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
+ dfun_prs = catMaybes mb_dfun_prs
+ boot_dfuns = map fst dfun_prs
+ dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+ | (boot_dfun, dfun) <- dfun_prs ]
+
; failIfErrsM
- ; return tcg_env' }
+ ; setGlobalTypeEnv tcg_env' final_type_env }
where
check_export boot_avail -- boot_avail is exported by the boot iface
| name `elem` dfun_names = return ()
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-- Fails if there are any errors
rnTopSrcDecls group
- = do { -- Rename the source decls (with no shadowing; error on duplicates)
- (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ;
+ = do { -- Rename the source decls
+ (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
-- save the renamed syntax, if we want it
let { tcg_env'
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
+ hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
- tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
+ (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
- -- Make these type and class decls available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
-
-
setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
<- tcInstDecls1 tycl_decls inst_decls deriv_decls;
setGblEnv tcg_env $ do {
- -- Foreign import declarations next. No zonking necessary
- -- here; we can tuck them straight into the global environment.
+ -- Foreign import declarations next.
traceTc (text "Tc4") ;
(fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
default_tys <- tcDefaults default_decls ;
updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
+ -- Now GHC-generated derived bindings, generics, and selectors
+ -- Do not generate warnings from compiler-generated code;
+ -- hence the use of discardWarnings
+ (tc_aux_binds, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
+ (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $
+ discardWarnings (tcTopBinds deriv_binds) ;
+
-- Value declarations next
- -- We also typecheck any extra binds that came out
- -- of the "deriving" process (deriv_binds)
traceTc (text "Tc5") ;
- (tc_val_binds, tcl_env) <- tcTopBinds val_binds ;
- setLclTypeEnv tcl_env $ do {
-
- -- Now GHC-generated derived bindings and generics.
- -- Do not generate warnings from compiler-generated code.
- (tc_deriv_binds, tcl_env) <- discardWarnings $
- tcTopBinds deriv_binds ;
+ (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $
+ tcTopBinds val_binds;
-- Second pass over class and instance declarations,
traceTc (text "Tc6") ;
- (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ;
- showLIE (text "after instDecls2") ;
+ (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $
+ tcInstDecls2 tycl_decls inst_infos ;
+ showLIE (text "after instDecls2") ;
+
+ setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
-- Foreign exports
- -- They need to be zonked, so we return them
traceTc (text "Tc7") ;
(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+ -- Annotations
+ annotations <- tcAnnotations annotation_decls ;
+
-- Rules
rules <- tcRules rule_decls ;
tcg_env <- getGblEnv ;
let { all_binds = tc_val_binds `unionBags`
tc_deriv_binds `unionBags`
+ tc_aux_binds `unionBags`
inst_binds `unionBags`
- foe_binds ;
+ foe_binds;
-- Extend the GblEnv with the (as yet un-zonked)
-- bindings, rules, foreign decls
tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
tcg_rules = tcg_rules tcg_env ++ rules,
+ tcg_anns = tcg_anns tcg_env ++ annotations,
tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
return (tcg_env', tcl_env)
}}}}}}
return tcg_env
| otherwise
- = do { mb_main <- lookupSrcOcc_maybe main_fn
+ = do { mb_main <- lookupGlobalOccRn_maybe main_fn
-- Check that 'main' is in scope
-- It might be imported from another module!
; case mb_main of {
where
mod = tcg_mod tcg_env
main_mod = mainModIs dflags
- main_is_flag = mainFunIs dflags
-
- main_fn = case main_is_flag of
- Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
- Nothing -> main_RDR_Unqual
+ main_fn = getMainFun dflags
complain_no_main | ghcLink dflags == LinkInMemory = return ()
| otherwise = failWithTc noMainMsg
mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn
noMainMsg = ptext (sLit "The") <+> pp_main_fn
<+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
- pp_main_fn | isJust main_is_flag = ptext (sLit "main function") <+> quotes (ppr main_fn)
- | otherwise = ptext (sLit "function") <+> quotes (ppr main_fn)
+ pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn)
+ | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn)
+
+-- | 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
\end{code}
Note [Root-main Id]
tcRnStmt :: HscEnv
-> InteractiveContext
-> LStmt RdrName
- -> IO (Maybe ([Id], LHsExpr Id))
+ -> IO (Messages, Maybe ([Id], LHsExpr Id))
-- The returned [Id] is the list of new Ids bound by
-- this statement. It can be used to extend the
-- InteractiveContext via extendInteractiveContext.
mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
traceTc (text "tcs 1") ;
- let { global_ids = map globaliseAndTidy zonked_ids } ;
-
+ let { global_ids = map globaliseAndTidyId zonked_ids } ;
+ -- Note [Interactively-bound Ids in GHCi]
+
{- ---------------------------------------------
At one stage I removed any shadowed bindings from the type_env;
they are inaccessible but might, I suppose, cause a space leak if we leave them there.
where
bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
-
-globaliseAndTidy :: Id -> Id
-globaliseAndTidy id -- Note [Interactively-bound Ids in GHCi]
- = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
- where
- tidy_type = tidyTopType (idType id)
\end{code}
Note [Interactively-bound Ids in GHCi]
tcRnExpr :: HscEnv
-> InteractiveContext
-> LHsExpr RdrName
- -> IO (Maybe Type)
+ -> IO (Messages, Maybe Type)
tcRnExpr hsc_env ictxt rdr_expr
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
tcRnType :: HscEnv
-> InteractiveContext
-> LHsType RdrName
- -> IO (Maybe Kind)
+ -> IO (Messages, Maybe Kind)
tcRnType hsc_env ictxt rdr_type
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
failIfErrsM ;
-- Now kind-check the type
- (ty', kind) <- kcHsType rn_type ;
+ (ty', kind) <- kcLHsType rn_type ;
return kind
}
where
\begin{code}
#ifdef GHCI
--- ASSUMES that the module is either in the HomePackageTable or is
+-- | ASSUMES that the module is either in the 'HomePackageTable' or is
-- a package module with an interface on disk. If neither of these is
-- true, then the result will be an error indicating the interface
-- could not be found.
; ifaceExportNames (mi_exports iface)
}
-tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
+tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
return good_names
}
-tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
tcRnGetInfo :: HscEnv
-> Name
- -> IO (Maybe (TyThing, Fixity, [Instance]))
+ -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
-- Used to implemnent :info in GHCi
--
, ppr_fam_insts fam_insts
, vcat (map ppr rules)
, ppr_gen_tycons (typeEnvTyCons type_env)
- , ptext (sLit "Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
- , ptext (sLit "Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
+ , ptext (sLit "Dependent modules:") <+>
+ ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
+ , ptext (sLit "Dependent packages:") <+>
+ ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
+ where -- The two uses of sortBy are just to reduce unnecessary
+ -- wobbling in testsuite output
+ cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
+ = (mod_name1 `stableModuleNameCmp` mod_name2)
+ `thenCmp`
+ (is_boot1 `compare` is_boot2)
pprModGuts :: ModGuts -> SDoc
pprModGuts (ModGuts { mg_types = type_env,