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 {- Kind parts of -} Type
import BasicTypes
import Foreign.Ptr( Ptr )
+import TidyPgm ( globaliseAndTidyId )
#endif
import FastString
gbl {
tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env,
tcg_imports = tcg_imports gbl `plusImportAvails` imports,
- tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl),
+ tcg_rn_imports = rn_imports,
tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
home_fam_insts,
-- (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,
-- 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
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 }
+ ; 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
}}}}
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
setGblEnv tcg_env $ do {
<- 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 {
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
--
projects / ghc-hetmet.git / blobdiff