#ifdef GHCI
mkGlobalContext, getModuleContents,
#endif
- tcRnModule, checkOldIface, importSupportingDecls,
+ tcRnModule, checkOldIface,
+ importSupportingDecls, tcTopSrcDecls,
tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
) where
#include "HsVersions.h"
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
+import DsMeta ( templateHaskellNames )
+#endif
+
import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
-import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
- Stmt(..), Pat(VarPat), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
+import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
+ Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
+ HsGroup(..), SpliceDecl(..),
mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
- isSrcRule
+ isSrcRule, collectStmtsBinders
)
-import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr )
+import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
+ emptyGroup, mkGroup, findSplice, addImpDecls )
import PrelNames ( iNTERACTIVE, ioTyConName, printName,
returnIOName, bindIOName, failIOName, thenIOName, runIOName,
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,
- zonkTopExpr, zonkIdBndr
+ zonkTopDecls, mkHsLet,
+ zonkTopExpr, zonkTopBndrs
)
import TcExpr ( tcExpr_id )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
-import TcEnv ( RecTcGblEnv,
- tcExtendGlobalValEnv,
- tcExtendGlobalEnv,
+import TcEnv ( tcExtendGlobalValEnv,
tcExtendInstEnv, tcExtendRules,
tcLookupTyCon, tcLookupGlobal,
tcLookupId
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 RnSource ( rnSrcDecls, rnExtCoreDecls, checkModDeprec, rnStats )
+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
-import Maybe ( catMaybes )
import Panic ( showException )
import List ( partition )
import Util ( sortLt )
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
traceRn (text "rn1a") ;
-- Rename and type check the declarations
- (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ;
- setGblEnv tcg_env $ do {
- traceRn (text "rn2") ;
-
- -- Check for 'main'
- (tcg_env, main_fvs) <- checkMain ;
+ (tcg_env, src_dus) <- tcRnSrcDecls local_decls ;
setGblEnv tcg_env $ do {
traceRn (text "rn3") ;
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
setGblEnv tcg_env $ do {
-- Report unused names
- let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ;
- reportUnusedNames tcg_env used_fvs ;
+ let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
+ reportUnusedNames tcg_env all_dus ;
-- Dump output and return
tcDump tcg_env ;
return tcg_env
- }}}}}}}}
+ }}}}}}}
\end{code}
-- Get the supporting decls, and typecheck them all together
-- so that any mutually recursive types are done right
extra_decls <- slurpImpDecls needed ;
- env <- typecheckIfaceDecls (decls ++ extra_decls) ;
+ env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
returnM (ModDetails { md_types = tcg_type_env env,
md_insts = tcg_insts env,
rule_decls = dcl_rules iface_decls
inst_decls = dcl_insts iface_decls
tycl_decls = dcl_tycl iface_decls
- decls = map RuleD rule_decls ++
- map InstD inst_decls ++
- map TyClD tycl_decls
+ group = emptyGroup { hs_ruleds = rule_decls,
+ hs_instds = inst_decls,
+ hs_tyclds = tycl_decls }
needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
-> 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 $
setInteractiveContext ictxt $ do {
-- Rename; use CmdLineMode because tcRnStmt is only used interactively
- ((bound_names, [rn_stmt]), fvs) <- initRnInteractive ictxt
- (rnStmts [rdr_stmt]) ;
+ ([rn_stmt], fvs) <- initRnInteractive ictxt
+ (rnStmts DoExpr [rdr_stmt]) ;
traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
failIfErrsM ;
setGblEnv tcg_env $ do {
-- The real work is done here
- ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt bound_names rn_stmt) ;
+ ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
traceTc (text "tcs 1") ;
let { -- Make all the bound ids "global" ids, now that
\begin{code}
---------------------------
-tcUserStmt :: [Name] -> RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
-tcUserStmt names (ExprStmt expr _ loc)
- = ASSERT( null names )
- newUnique `thenM` \ uniq ->
+tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
+tcUserStmt (ExprStmt expr _ loc)
+ = newUnique `thenM` \ uniq ->
let
fresh_it = itName uniq
the_bind = FunMonoBind fresh_it False
[ mkSimpleMatch [] expr placeHolderType loc ] loc
in
- tryTc_ (do { -- Try this if the other fails
+ tryTcLIE_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
- tc_stmts [fresh_it] [
+ tc_stmts [
LetStmt (MonoBind the_bind [] NonRecursive),
ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
placeHolderType loc] })
(do { -- Try this first
traceTc (text "tcs 1a") ;
- tc_stmts [fresh_it] [BindStmt (VarPat fresh_it) expr loc] })
+ tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
-tcUserStmt names stmt
- = tc_stmts names [stmt]
+tcUserStmt stmt = tc_stmts [stmt]
---------------------------
-tc_stmts names stmts
+tc_stmts stmts
= do { io_ids <- mappM tcLookupId
[returnIOName, failIOName, bindIOName, thenIOName] ;
ioTyCon <- tcLookupTyCon ioTyConName ;
res_ty <- newTyVarTy liftedTypeKind ;
let {
+ names = collectStmtsBinders stmts ;
return_id = head io_ids ; -- Rather gruesome
io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
((ids, tc_stmts), lie) <-
- getLIE $ tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts $
+ getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $
do {
-- Look up the names right in the middle,
-- where they will all be in scope
-- Simplify the context right here, so that we fail
-- if there aren't enough instances. Notably, when we see
-- e
- -- we use tryTc_ to try it <- e
+ -- we use recoverTc_ to try it <- e
-- and then let it = e
-- It's the simplify step that rejects the first.
traceTc (text "tcs 3") ;
HsDo DoExpr tc_stmts io_ids
(mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
zonked_expr <- zonkTopExpr expr ;
- zonked_ids <- mappM zonkIdBndr ids ;
+ zonked_ids <- zonkTopBndrs ids ;
return (zonked_ids, zonked_expr)
}
-- constructor and type class identifiers.
let { rdr_names = dataTcOccs rdr_name } ;
- (msgs_s, mb_names) <- initRnInteractive ictxt
- (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ;
- let { names = catMaybes mb_names } ;
+ -- results :: [(Messages, Maybe Name)]
+ results <- initRnInteractive ictxt
+ (mapM (tryTc . lookupOccRn) rdr_names) ;
- if null names then
- do { addMessages (head msgs_s) ; failM }
- else do {
+ -- The successful lookups will be (Just name)
+ let { (warns_s, good_names) = unzip [ (msgs, name)
+ | (msgs, Just name) <- results] ;
+ errs_s = [msgs | (msgs, Nothing) <- results] } ;
- mapM_ addMessages msgs_s ; -- Add deprecation warnings
- mapM tcLookupGlobal names -- and lookup up the entities
+ -- Fail if nothing good happened, else add warnings
+ if null good_names then -- Fail
+ do { addMessages (head errs_s) ; failM }
+ else -- Add deprecation warnings
+ mapM_ addMessages warns_s ;
+
+ -- Slurp in the supporting declarations
+ tcg_env <- importSupportingDecls (mkFVs good_names) ;
+ setGblEnv tcg_env $ do {
+
+ -- And lookup up the entities
+ mapM tcLookupGlobal good_names
}}
\end{code}
-- Rename the source, only in interface mode.
-- rnSrcDecls handles fixity decls etc too, which won't occur
-- but that doesn't matter
- (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
- (rnExtCoreDecls local_decls) ;
+ let { local_group = mkGroup local_decls } ;
+ (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod)
+ (rnSrcDecls local_group) ;
failIfErrsM ;
- -- Get the supporting decls, and typecheck them all together
- -- so that any mutually recursive types are done right
- extra_decls <- slurpImpDecls fvs ;
- tcg_env <- typecheckIfaceDecls (rn_local_decls ++ extra_decls) ;
+ -- Get the supporting decls
+ rn_imp_decls <- slurpImpDecls (duUses dus) ;
+ let { rn_decls = rn_local_decls `addImpDecls` rn_imp_decls } ;
+
+ -- Dump trace of renaming part
+ rnDump (ppr rn_decls) ;
+ rnStats rn_imp_decls ;
+
+ -- Typecheck them all together so that
+ -- any mutually recursive types are done right
+ tcg_env <- typecheckIfaceDecls rn_decls ;
setGblEnv tcg_env $ do {
-- Now the core bindings
- core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ;
+ core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ;
tcExtendGlobalValEnv (map fst core_prs) $ do {
-- Wrap up
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,
%* *
%************************************************************************
-tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
+\begin{code}
+tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
-- Returns the variables free in the decls
-tcRnSrcDecls [] = getGblEnv
-tcRnSrcDecls ds
+ -- Reason: solely to report unused imports and bindings
+tcRnSrcDecls decls
+ = do { -- Do all the declarations
+ ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
+
+ -- tcSimplifyTop deals with constant or ambiguous InstIds.
+ -- How could there be ambiguous ones? They can only arise if a
+ -- top-level decl falls under the monomorphism
+ -- restriction, and no subsequent decl instantiates its
+ -- type. (Usually, ambiguous type variables are resolved
+ -- during the generalisation step.)
+ traceTc (text "Tc8") ;
+ setEnvs tc_envs $ do {
+ -- Setting the global env exposes the instances to tcSimplifyTop
+ -- Setting the local env exposes the local Ids, so that
+ -- we get better error messages (monomorphism restriction)
+ inst_binds <- tcSimplifyTop lie ;
+
+ -- Backsubstitution. This must be done last.
+ -- 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 } ;
+
+ (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
+ rules fords ;
+
+ return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
+ tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
+ dus)
+ }}
+
+tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
+
+tc_rn_src_decls ds
= do { let { (first_group, group_tail) = findSplice ds } ;
+ -- If ds is [] we get ([], Nothing)
- tcg_env <- tcRnGroup first_group ;
+ -- Type check the decls up to, but not including, the first splice
+ (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
- case group_tail of
- Nothing -> return gbl_env
- 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 ;
+
+ setEnvs tc_envs $
+
+ -- If there is no splice, we're nearlydone
+ case group_tail of {
+ Nothing -> do { -- Last thing: check for `main'
+ (tcg_env, main_fvs) <- checkMain ;
+ return ((tcg_env, tcl_env),
+ src_dus1 `plusDU` usesOnly main_fvs)
+ } ;
+
+ -- If there's a splice, we must carry on
+ Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
+#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, splice_fvs) <- initRn SourceMode $
+ addSrcLoc splice_loc $
+ rnExpr splice_expr ;
+ tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
setGblEnv tcg_env $ do {
-- Execute the splice
spliced_decls <- tcSpliceDecls rn_splice_expr ;
-- Glue them on the front of the remaining decls and loop
- tcRnSrcDeclsDecls (splice_decls ++ rest_ds)
- }}}}
+ (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
-findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a]))
-findSplice [] = ([], Nothing)
-findSplice (SpliceD e : ds) = ([], Just (e, ds))
-findSplice (d : ds) = (d:gs, rest)
- where
- (gs, rest) = findSplice ds
+ return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
+ }
+#endif /* GHCI */
+ }}}
+\end{code}
%************************************************************************
%* *
%************************************************************************
-tcRnSrcDecls takes a bunch of top-level source-code declarations, and
+tcRnGroup takes a bunch of top-level source-code declarations, and
* renames them
* gets supporting declarations from interface files
* typechecks them
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
- -- Returns the variables free in the decls
-tcRnSrcDecls decls
- = do { -- Rename the declarations
- (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
+tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
+ -- Returns the variables free in the decls, for unused-binding reporting
+tcRnGroup decls
+ = do { showLIE (text "LIE at start of tcRnGroup" <+> ppr decls) ;
+
+ -- Rename the declarations
+ (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
- tcg_env <- tcTopSrcDecls rn_decls ;
- return (tcg_env, src_fvs)
+ tc_envs <- tcTopSrcDecls rn_decls ;
+
+ showLIE (text "LIE at end of tcRnGroup" <+> ppr decls) ;
+ return (tc_envs, src_dus)
}}
------------------------------------------------
-rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars)
-rnTopSrcDecls decls
- = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ;
+rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
+rnTopSrcDecls group
+ = do { -- Bring top level binders into scope
+ (rdr_env, imports) <- importsFromLocalDecls group ;
+ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
+ tcg_rdr_env gbl,
+ tcg_imports = imports `plusImportAvails`
+ tcg_imports gbl })
+ $ do {
+
+ failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
+
+ -- Rename the source decls
+ (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
setGblEnv tcg_env $ do {
failIfErrsM ;
-- Import consquential imports
+ let { src_fvs = duUses src_dus } ;
rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
- let { rn_decls = rn_src_decls ++ rn_imp_decls } ;
+ let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
-- Dump trace of renaming part
- rnDump (vcat (map ppr rn_decls)) ;
+ rnDump (ppr rn_decls) ;
rnStats rn_imp_decls ;
- return (tcg_env, rn_decls, src_fvs)
- }}
+ return (tcg_env, rn_decls, src_dus)
+ }}}
------------------------------------------------
-tcTopSrcDecls :: [RenamedHsDecl] -> 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
- ) ;
-
- -- tcSimplifyTop deals with constant or ambiguous InstIds.
- -- How could there be ambiguous ones? They can only arise if a
- -- top-level decl falls under the monomorphism
- -- restriction, and no subsequent decl instantiates its
- -- type. (Usually, ambiguous type variables are resolved
- -- during the generalisation step.)
- traceTc (text "Tc8") ;
- inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ;
- -- The setGblEnv exposes the instances to tcSimplifyTop
-
- -- 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 ;
-
- let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) 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 decls
+tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls
+ (HsGroup { hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_fords = foreign_decls,
+ hs_defds = default_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,
-- Foreign import declarations next. No zonking necessary
-- here; we can tuck them straight into the global environment.
traceTc (text "Tc4") ;
- (fi_ids, fi_decls) <- tcForeignImports decls ;
+ (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $
updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
$ do {
-- Default declarations
traceTc (text "Tc4a") ;
- default_tys <- tcDefaults decls ;
+ default_tys <- tcDefaults default_decls ;
updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
-- Value declarations next
(cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
tcExtendGlobalValEnv dm_ids $ do {
inst_binds <- tcInstDecls2 inst_infos ;
- showLIE "after instDecls2" ;
+ showLIE (text "after instDecls2") ;
-- Foreign exports
-- They need to be zonked, so we return them
traceTc (text "Tc7") ;
- (foe_binds, foe_decls) <- tcForeignExports decls ;
+ (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
-- Rules
-- Need to partition them because the source rules
let { all_binds = tc_val_binds `AndMonoBinds`
inst_binds `AndMonoBinds`
cls_dm_binds `AndMonoBinds`
- foe_binds } ;
+ foe_binds ;
- return (tcg_env, all_binds, src_rules, foe_decls)
+ -- Extend the GblEnv with the (as yet un-zonked)
+ -- bindings, rules, foreign decls
+ tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds,
+ tcg_rules = tcg_rules tcg_env ++ src_rules,
+ tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
+
+ return (tcg_env', lcl_env)
}}}}}}}}}
- where
- tycl_decls = [d | TyClD d <- decls]
- rule_decls = [d | RuleD d <- decls]
- inst_decls = [d | InstD d <- decls]
- val_decls = [d | ValD d <- decls]
- val_binds = foldr ThenBinds EmptyBinds val_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}
= do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
decls <- slurpImpDecls fvs ;
traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
- typecheckIfaceDecls decls }
+ typecheckIfaceDecls (mkGroup decls) }
-typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv
+typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
-- The decls are all interface-file declarations
-- Usually they are all from other modules, but when we are reading
-- this module's interface from a file, it's possible that some of
-- 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.
-typecheckIfaceDecls decls
- = do { let { tycl_decls = [d | TyClD d <- decls] ;
- inst_decls = [d | InstD d <- decls] ;
- rule_decls = [d | RuleD d <- decls] } ;
-
- -- Typecheck the type, class, and interface-sig decls
- tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
+ -- 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 <- 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 {
+
+ addSrcLoc (getSrcLoc main_name) $
+ addErrCtxt mainCtxt $
+ setGblEnv tcg_env $ do {
-- $main :: IO () = runIO main
let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
+ (main_expr, ty) <- tcExpr_id rhs ;
- (main_bind, top_lie) <- getLIE (
- addSrcLoc (getSrcLoc main_name) $
- addErrCtxt mainCtxt $ do {
- (main_expr, ty) <- tcExpr_id rhs ;
- let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
- return (VarMonoBind dollar_main_id main_expr)
- }) ;
-
- inst_binds <- tcSimplifyTop top_lie ;
-
- (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
-
- let { tcg_env' = tcg_env {
- tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
- tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
+ let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
+ main_bind = VarMonoBind dollar_main_id main_expr ;
+ tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
+ `andMonoBinds` main_bind } } ;
return (tcg_env', unitFV main_name)
}}
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,