#include "HsVersions.h"
#ifdef GHCI
-import {-# SOURCE #-} TcSplice( tcSpliceDecls )
+import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
+import DsMeta ( templateHaskellNames )
#endif
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
-import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
+import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
- HsGroup(..),
+ HsGroup(..), SpliceDecl(..),
mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
isSrcRule, collectStmtsBinders
)
dollarMainName, itName, mAIN_Name
)
import MkId ( unsafeCoerceId )
-import RdrName ( RdrName, getRdrName, mkUnqual, mkRdrUnqual,
+import RdrName ( RdrName, getRdrName, mkRdrUnqual,
lookupRdrEnv, elemRdrEnv )
-import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedTyClDecl,
+import RnHsSyn ( RenamedStmt, RenamedTyClDecl,
ruleDeclFVs, instDeclFVs, tyClDeclFVs )
import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
zonkTopBinds, zonkTopDecls, mkHsLet,
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
-import TcEnv ( RecTcGblEnv,
- tcExtendGlobalValEnv,
+import TcEnv ( tcExtendGlobalValEnv,
tcExtendGlobalEnv,
tcExtendInstEnv, tcExtendRules,
tcLookupTyCon, tcLookupGlobal,
import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls )
-import RnNames ( rnImports, exportsFromAvail, reportUnusedNames )
+import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
+ reportUnusedNames, main_RDR_Unqual )
import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
import RnHiFiles ( readIface, loadOldIface )
-import RnEnv ( lookupSrcName, lookupOccRn,
+import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
import RnExpr ( rnStmts, rnExpr )
-import RnNames ( importsFromLocalDecls )
import RnSource ( rnSrcDecls, checkModDeprec, rnStats )
-import OccName ( varName )
import CoreUnfold ( unfoldingTemplate )
import CoreSyn ( IdCoreRule, Bind(..) )
import PprCore ( pprIdRules, pprCoreBindings )
import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
import IdInfo ( GlobalIdDetails(..) )
import Var ( Var, setGlobalIdDetails )
-import Module ( Module, moduleName, moduleUserString )
+import Module ( Module, moduleName, moduleUserString, moduleEnvElts )
import Name ( Name, isExternalName, getSrcLoc, nameOccName )
import NameEnv ( delListFromNameEnv )
import NameSet
ModIface, ModDetails(..), ModGuts(..),
HscEnv(..),
ModIface(..), ModDetails(..), IfaceDecls(..),
- GhciMode(..),
+ GhciMode(..), noDependencies,
Deprecations(..), plusDeprecs,
emptyGlobalRdrEnv,
GenAvailInfo(Avail), availsToNameSet,
#ifdef GHCI
import RdrName ( rdrEnvElts )
import RnHiFiles ( loadInterface )
-import RnEnv ( mkGlobalRdrEnv, plusGlobalRdrEnv )
+import RnEnv ( mkGlobalRdrEnv )
import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
isLocalGRE )
#endif
do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
- tcg_imports = imports })
+ tcg_imports = tcg_imports gbl `plusImportAvails` imports })
$ do {
- traceRn (text "rn1") ;
+ traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
-- Fail if there are any errors so far
-- The error printing (if needed) takes advantage
-- of the tcg_env we have now set
updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
$ do {
- traceRn (text "rn4") ;
-- Process the export list
export_avails <- exportsFromAvail exports ;
updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
$ do {
- -- Get the supporting decls for the exports
- -- This is important *only* to gether usage information
+ -- Get any supporting decls for the exports that have not already
+ -- been sucked in for the declarations in the body of the module.
+ -- (This can happen if something is imported only to be re-exported.)
+ --
+ -- Importing these supporting declarations is required
+ -- *only* to gether usage information
-- (see comments with MkIface.mkImportInfo for why)
-- For OneShot compilation we could just throw away the decls
-- but for Batch or Interactive we must put them in the type
-> RdrNameStmt
-> IO (PersistentCompilerState,
Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
- -- The returned [Id] is the same as the input except for
+ -- The returned [Name] is the same as the input except for
-- ExprStmt, in which case the returned [Name] is [itName]
+ --
+ -- The returned TypecheckedHsExpr is of type IO [ () ],
+ -- a list of the bound values, coerced to ().
tcRnStmt hsc_env pcs ictxt rdr_stmt
= initTc hsc_env pcs iNTERACTIVE $
do { addMessages (head msgs_s) ; failM }
else do {
- mapM_ addMessages msgs_s ; -- Add deprecation warnings
- mapM tcLookupGlobal names -- and lookup up the entities
- }}
+ -- Add deprecation warnings
+ mapM_ addMessages msgs_s ;
+
+ -- Slurp in the supporting declarations
+ tcg_env <- importSupportingDecls (mkFVs names) ;
+ setGblEnv tcg_env $ do {
+
+ -- And lookup up the entities
+ mapM tcLookupGlobal names
+ }}}
\end{code}
mod_guts = ModGuts { mg_module = this_mod,
mg_usages = [], -- ToDo: compute usage
mg_dir_imps = [], -- ??
+ mg_deps = noDependencies, -- ??
mg_exports = my_exports,
mg_types = final_type_env,
mg_insts = tcg_insts tcg_env,
-- Type check the decls up to, but not including, the first splice
(tcg_env, src_fvs1) <- tcRnGroup first_group ;
- -- If there is no splice, we're done
- case group_tail of
- Nothing -> return (tcg_env, src_fvs1)
- Just (splice_expr, rest_ds) -> do {
+ -- Bale out if errors; for example, error recovery when checking
+ -- the RHS of 'main' can mean that 'main' is not in the envt for
+ -- the subsequent checkMain test
+ failIfErrsM ;
+ -- If there is no splice, we're done
+ case group_tail of {
+ Nothing -> return (tcg_env, src_fvs1) ;
+ Just (SpliceDecl splice_expr splice_loc, rest_ds) ->
+#ifndef GHCI
+ failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
+#else
setGblEnv tcg_env $ do {
-
+
-- Rename the splice expression, and get its supporting decls
- (rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ;
- tcg_env <- importSupportingDecls fvs ;
+ (rn_splice_expr, fvs) <- initRn SourceMode $
+ addSrcLoc splice_loc $
+ rnExpr splice_expr ;
+ tcg_env <- importSupportingDecls (fvs `plusFV` templateHaskellNames) ;
setGblEnv tcg_env $ do {
-- Execute the splice
(tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ;
return (tcg_env, src_fvs1 `plusFV` src_fvs2)
- }}}}
+ }}
+#endif /* GHCI */
+ }}
\end{code}
------------------------------------------------
tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv
tcTopSrcDecls rn_decls
- = fixM (\ unf_env -> do {
- -- Loop back the final environment, including the fully zonked
- -- versions of bindings from this module. In the presence of mutual
- -- recursion, interface type signatures may mention variables defined
- -- in this module, which is why the knot is so big
-
- -- Do the main work
- ((tcg_env, binds, rules, fords), lie) <- getLIE (
- tc_src_decls unf_env rn_decls
+ = do { -- Do the main work
+ ((tcg_env, lcl_env, binds, rules, fords), lie) <- getLIE (
+ tc_src_decls rn_decls
) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- type. (Usually, ambiguous type variables are resolved
-- during the generalisation step.)
traceTc (text "Tc8") ;
- inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ;
+ inst_binds <- setGblEnv tcg_env $
+ setLclTypeEnv lcl_env $
+ tcSimplifyTop lie ;
-- The setGblEnv exposes the instances to tcSimplifyTop
+ -- The setLclTypeEnv exposes the local Ids, so that
+ -- we get better error messages (monomorphism restriction)
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
traceTc (text "Tc9") ;
- (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
- rules fords ;
+ (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
+ rules fords ;
- let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
+ let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env)
+ bind_ids,
tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
tcg_rules = tcg_rules tcg_env ++ rules',
tcg_fords = tcg_fords tcg_env ++ fords' } } ;
return tcg_env'
- })
+ }
-tc_src_decls unf_env
+tc_src_decls
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_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 <- tcTyClDecls unf_env tycl_decls ;
+ tcg_env <- tcTyClDecls tycl_decls ;
setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
cls_dm_binds `AndMonoBinds`
foe_binds } ;
- return (tcg_env, all_binds, src_rules, foe_decls)
+ return (tcg_env, lcl_env, all_binds, src_rules, foe_decls)
}}}}}}}}}
\end{code}
\begin{code}
-tcTyClDecls :: RecTcGblEnv
- -> [RenamedTyClDecl]
+tcTyClDecls :: [RenamedTyClDecl]
-> TcM TcGblEnv
-- tcTyClDecls deals with
-- persistent compiler state to reflect the things imported from
-- other modules
-tcTyClDecls unf_env tycl_decls
- -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas
- -- which is done lazily [ie failure just drops the pragma
- -- without having any global-failure effect].
-
+tcTyClDecls tycl_decls
= checkNoErrs $
-- tcTyAndClassDecls recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
traceTc (text "TyCl1") `thenM_`
- tcTyAndClassDecls tycl_decls `thenM` \ tycl_things ->
- tcExtendGlobalEnv tycl_things $
-
- -- Interface type signatures
- -- We tie a knot so that the Ids read out of interfaces are in scope
- -- when we read their pragmas.
- -- What we rely on is that pragmas are typechecked lazily; if
- -- any type errors are found (ie there's an inconsistency)
- -- we silently discard the pragma
- traceTc (text "TyCl2") `thenM_`
- tcInterfaceSigs unf_env tycl_decls `thenM` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
-
- getGblEnv -- Return the TcLocals environment
+ tcTyAndClassDecls tycl_decls `thenM` \ tcg_env ->
+ -- Returns the extended environment
+ setGblEnv tcg_env $
+
+ traceTc (text "TyCl2") `thenM_`
+ tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
+ -- Returns the extended environment
+
+ returnM tcg_env
\end{code}
-- That is why the tcExtendX functions need to do partitioning.
--
-- If all the decls are from other modules, the returned TcGblEnv
- -- will have an empty tc_genv, but its tc_inst_env and tc_ist
- -- caches may have been augmented.
+ -- will have an empty tc_genv, but its tc_inst_env
+ -- cache may have been augmented.
typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_ruleds = rule_decls })
= do { -- Typecheck the type, class, and interface-sig decls
- tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
+ tcg_env <- tcTyClDecls tycl_decls ;
setGblEnv tcg_env $ do {
-- Typecheck the instance decls, and rules
| mod_name /= mAIN_Name
= return (tcg_env, emptyFVs)
+ -- Check that 'main' is in scope
+ -- It might be imported from another module!
+ --
+ -- We use a guard for this (rather than letting lookupSrcName fail)
+ -- because it's not an error in ghci)
| not (main_RDR_Unqual `elemRdrEnv` rdr_env)
= do { complain_no_main; return (tcg_env, emptyFVs) }
| otherwise
- = do { -- Check that 'main' is in scope
- -- It might be imported from another module!
- main_name <- lookupSrcName main_RDR_Unqual ;
- failIfErrsM ;
+ = do { main_name <- lookupSrcName main_RDR_Unqual ;
tcg_env <- importSupportingDecls (unitFV runIOName) ;
setGblEnv tcg_env $ do {
mod_name = moduleName (tcg_mod tcg_env)
rdr_env = tcg_rdr_env tcg_env
- main_RDR_Unqual :: RdrName
- main_RDR_Unqual = mkUnqual varName FSLIT("main")
- -- Don't get a RdrName from PrelNames.mainName, because
- -- nameRdrNamegets an Orig RdrName, and we want a Qual or Unqual one.
- -- An Unqual one will do just fine
-
complain_no_main | ghci_mode == Interactive = return ()
- | otherwise = addErr noMainMsg
+ | otherwise = failWithTc noMainMsg
-- In interactive mode, don't worry about the absence of 'main'
+ -- In other modes, fail altogether, so that we don't go on
+ -- and complain a second time when processing the export list.
mainCtxt = ptext SLIT("When checking the type of 'main'")
noMainMsg = ptext SLIT("No 'main' defined in module Main")
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
tcg_insts = dfun_ids,
- tcg_rules = rules })
+ tcg_rules = rules,
+ tcg_imports = imports })
= vcat [ ppr_types dfun_ids type_env
, ppr_insts dfun_ids
, vcat (map ppr rules)
- , ppr_gen_tycons (typeEnvTyCons type_env)]
+ , ppr_gen_tycons (typeEnvTyCons type_env)
+ , ppr (moduleEnvElts (imp_dep_mods imports))
+ , ppr (imp_dep_pkgs imports)]
pprModGuts :: ModGuts -> SDoc
pprModGuts (ModGuts { mg_types = type_env,
projects / ghc-hetmet.git / blobdiff