-%
+s%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}
nlHsApp, nlHsVar, pprLHsBinds )
import RdrHsSyn ( findSplice )
-import PrelNames ( runIOName, rootMainName, mAIN,
+import PrelNames ( runMainIOName, rootMainName, mAIN,
main_RDR_Unqual )
import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
plusGlobalRdrEnv )
import TcRnMonad
import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
import Inst ( showLIE )
+import InstEnv ( extendInstEnvList )
import TcBinds ( tcTopBinds )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules, loadHiBootInterface )
-import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
+import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import Module ( mkModule, moduleEnvElts )
+import Module ( Module, ModuleEnv, mkModule, moduleEnvElts )
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, getOccName )
import NameSet
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import Outputable
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
- GhciMode(..), noDependencies, isOneShot,
- Deprecs( NoDeprecs ), ModIface(..), plusDeprecs,
+ GhciMode(..), IsBootInterface, noDependencies,
+ Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
- TypeEnv, lookupTypeEnv,
+ TypeEnv, lookupTypeEnv, hptInstances,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
- emptyFixityEnv, availName
+ emptyFixityEnv
)
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
LStmt, LHsExpr, LHsType, mkMatchGroup,
- collectStmtsBinders, mkSimpleMatch, placeHolderType,
+ collectStmtsBinders, mkSimpleMatch,
nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
Provenance(..), ImportSpec(..),
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
tyThingToIfaceDecl, dfunToIfaceInst )
+import IfaceEnv ( lookupOrig )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
-import Id ( Id, isImplicitId, globalIdDetails )
+import Id ( Id, isImplicitId, setIdType, globalIdDetails )
import MkId ( unsafeCoerceId )
import DataCon ( dataConTyCon )
import TyCon ( tyConName )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
import Module ( Module, lookupModuleEnv )
-import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
- HomeModInfo(..), typeEnvElts, typeEnvClasses,
- availNames, icPrintUnqual,
+import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
+ availNames, availName, ModIface(..),
ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
-> Located (HsModule RdrName)
-> IO (Messages, Maybe TcGblEnv)
-tcRnModule hsc_env (L loc (HsModule maybe_mod exports
+tcRnModule hsc_env (L loc (HsModule maybe_mod export_ies
import_decls local_decls mod_deprec))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
-- Record boot-file info in the EPS, so that it's
-- visible to loadHiBootInterface in tcRnSrcDecls,
-- and any other incrementally-performed imports
- updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
+ let { dep_mods :: ModuleEnv (Module, IsBootInterface)
+ ; dep_mods = imp_dep_mods imports } ;
+
+ updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
-- Update the gbl env
- updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
- tcg_imports = tcg_imports gbl `plusImportAvails` imports })
- $ do {
+ let { home_insts = hptInstances hsc_env (moduleEnvElts dep_mods) } ;
+ updGblEnv ( \ gbl ->
+ gbl { tcg_rdr_env = rdr_env,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
+ tcg_imports = tcg_imports gbl `plusImportAvails` imports })
+ $ do {
+
traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
-- Fail if there are any errors so far
-- The error printing (if needed) takes advantage
reportDeprecations tcg_env ;
-- Process the export list
- exports <- exportsFromAvail (isJust maybe_mod) exports ;
+ exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
-- Check whether the entire module is deprecated
-- This happens only once per module
setGblEnv tcg_env $ do {
-- Now the core bindings
- core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
+ core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
-- Wrap up
let {
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls decls
- = do { boot_names <- loadHiBootInterface ;
+ = do { -- Load the hi-boot interface for this module, if any
+ -- We do this now so that the boot_names can be passed
+ -- to tcTyAndClassDecls, because the boot_names are
+ -- automatically considered to be loop breakers
+ boot_names <- loadHiBootInterface ;
-- Do all the declarations
(tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
Nothing -> do { complain_no_main
; return tcg_env } ;
Just main_name -> do
- { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
- -- :Main.main :: IO () = runIO main
+ { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
+ -- :Main.main :: IO () = runMainIO main
; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
tcInferRho rhs
(bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
traceTc (text "tcs 1") ;
- let { -- Make all the bound ids "global" ids, now that
- -- they're notionally top-level bindings. This is
- -- important: otherwise when we come to compile an expression
- -- using these ids later, the byte code generator will consider
- -- the occurrences to be free rather than global.
- global_ids = map (globaliseId VanillaGlobal) bound_ids ;
+ let { -- (a) Make all the bound ids "global" ids, now that
+ -- they're notionally top-level bindings. This is
+ -- important: otherwise when we come to compile an expression
+ -- using these ids later, the byte code generator will consider
+ -- the occurrences to be free rather than global.
+ --
+ -- (b) Tidy their types; this is important, because :info may
+ -- ask to look at them, and :info expects the things it looks
+ -- up to have tidy types
+ global_ids = map globaliseAndTidy bound_ids ;
-- Update the interactive context
rn_env = ic_rn_local_env ictxt ;
returnM (new_ic, bound_names, tc_expr)
}
-\end{code}
+globaliseAndTidy :: Id -> Id
+globaliseAndTidy id
+-- Give the Id a Global Name, and tidy its type
+ = setIdType (globaliseId VanillaGlobal id) tidy_type
+ where
+ tidy_type = tidyTopType (idType id)
+\end{code}
Here is the grand plan, implemented in tcUserStmt
; loadOrphanModules (dep_orphs (mi_deps iface))
-- Load any orphan-module interfaces,
-- so their instances are visible
- ; avails <- exportsToAvails (mi_exports iface)
+ ; names <- exportsToAvails (mi_exports iface)
; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
- | avail <- avails, name <- availNames avail ] }
+ | name <- nameSetToList names ] }
; returnM (mkGlobalRdrEnv gres) }
vanillaProv :: Module -> Provenance
| otherwise -- Want the exports only
= do { iface <- load_iface mod
- ; avails <- exportsToAvails (mi_exports iface)
- ; mappM get_decl avails
+ ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
+ , avail <- avails ]
}
- get_decl avail
- = do { thing <- tcLookupGlobal (availName avail)
- ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) }
+ get_decl (mod, avail)
+ = do { main_name <- lookupOrig mod (availName avail)
+ ; thing <- tcLookupGlobal main_name
+ ; return (filter_decl (availNames avail) (toIfaceDecl thing)) }
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
keep_con occs con = ifConOcc con `elem` occs
-availOccs avail = map nameOccName (availNames avail)
-
wantToSee (AnId id) = not (isImplicitId id)
wantToSee (ADataCon _) = False -- They'll come via their TyCon
wantToSee _ = True
projects / ghc-hetmet.git / blobdiff