\begin{code}
module TcRnDriver (
#ifdef GHCI
- mkExportEnv, getModuleContents, tcRnStmt,
- tcRnGetInfo, tcRnExpr, tcRnType,
+ tcRnStmt, tcRnExpr, tcRnType,
+ tcRnLookupRdrName,
+ tcRnLookupName,
+ tcRnGetInfo,
+ getModuleExports,
#endif
tcRnModule,
tcTopSrcDecls,
#include "HsVersions.h"
+import IO
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
-import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
-import Packages ( moduleToPackageConfig, mkPackageId, package,
- isHomeModule )
-import DriverState ( v_MainModIs, v_MainFunIs )
-import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
+import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
+import StaticFlags ( opt_PprStyle_Debug )
+import Packages ( checkForPackageConflicts, mkHomeModules )
+import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
+ SpliceDecl(..), HsBind(..), LHsBinds,
+ emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
nlHsApp, nlHsVar, pprLHsBinds )
import RdrHsSyn ( findSplice )
-import PrelNames ( runIOName, rootMainName, mAIN,
+import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
main_RDR_Unqual )
-import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
- plusGlobalRdrEnv )
+import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
import Inst ( showLIE )
-import TcBinds ( tcTopBinds )
+import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId )
+import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcDefaults ( tcDefaults )
-import TcEnv ( tcExtendGlobalValEnv )
+import TcEnv ( tcExtendGlobalValEnv, iDFunId )
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( tcExtCoreBindings )
+import TcIface ( tcExtCoreBindings, tcHiBootIface )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
-import LoadIface ( loadOrphanModules, loadHiBootInterface )
-import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
+import LoadIface ( loadOrphanModules )
+import RnNames ( importsFromLocalDecls, rnImports, rnExports,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
-import PprCore ( pprIdRules, pprCoreBindings )
-import CoreSyn ( IdCoreRule, bindersOfBinds )
+import PprCore ( pprRules, pprCoreBindings )
+import CoreSyn ( CoreRule, bindersOfBinds )
import DataCon ( dataConWrapId )
import ErrUtils ( Messages, mkDumpDoc, showPass )
-import Id ( mkExportedLocalId, isLocalId, idName, idType )
+import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import Module ( mkModule, moduleEnvElts )
-import OccName ( mkVarOcc )
-import Name ( Name, isExternalName, getSrcLoc, getOccName )
+import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv )
+import OccName ( mkVarOccFS )
+import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
+ mkExternalName )
import NameSet
-import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
+import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
-import Outputable
-import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
- GhciMode(..), noDependencies, isOneShot,
- Deprecs( NoDeprecs ), ModIface(..), plusDeprecs,
+import DriverPhases ( HscSource(..), isHsBoot )
+import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
+ HscEnv(..), ExternalPackageState(..),
+ IsBootInterface, noDependencies,
+ Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
- TypeEnv, lookupTypeEnv,
- extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
- emptyFixityEnv, availName
+ TypeEnv, lookupTypeEnv, hptInstances,
+ extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
+ emptyFixityEnv
)
+import Outputable
+
#ifdef GHCI
-import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
- LStmt, LHsExpr, LHsType, mkMatchGroup,
- collectStmtsBinders, mkSimpleMatch, placeHolderType,
- nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
-import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
- Provenance(..), ImportSpec(..),
- lookupLocalRdrEnv, extendLocalRdrEnv )
+import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
+ HsLocalBinds(..), HsValBinds(..),
+ LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
+ collectLStmtsBinders, collectLStmtBinders, nlVarPat,
+ mkFunBind, placeHolderType, noSyntaxExpr )
+import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
+ unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource ( addTcgDUs )
-import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
+import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs )
import TcHsType ( kcHsType )
-import TcExpr ( tcCheckRho )
-import TcIface ( loadImportedInsts )
import TcMType ( zonkTcType, zonkQuantifiedTyVar )
-import TcUnify ( unifyTyConApp )
-import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
+import TcMatches ( tcStmts, tcDoStmt )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
- isUnLiftedType, tyClsNamesOfDFunHead )
+import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
+ isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
-import Inst ( tcStdSyntaxName, tcGetInstEnvs )
-import InstEnv ( DFunId, classInstances, instEnvElts )
+import Inst ( tcGetInstEnvs )
+import InstEnv ( classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
-import RnNames ( exportsToAvails )
-import LoadIface ( loadSrcInterface )
-import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
- IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
- tyThingToIfaceDecl, dfunToIfaceInst )
+import LoadIface ( loadSrcInterface, loadSysInterface )
+import IfaceEnv ( ifaceExportNames )
+import Module ( moduleSetElts, mkModuleSet )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
-import Id ( Id, isImplicitId, globalIdDetails )
+import Id ( setIdType )
import MkId ( unsafeCoerceId )
-import DataCon ( dataConTyCon )
import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
-import SrcLoc ( interactiveSrcLoc, unLoc )
import Kind ( Kind )
import Var ( globaliseId )
-import Name ( nameOccName, nameModule )
+import Name ( nameOccName, nameModule, isBuiltInSyntax )
+import OccName ( isTcOcc )
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,
- ModDetails(..), Dependencies(..) )
-import BasicTypes ( RecFlag(..), Fixity )
-import Bag ( unitBag )
-import ListSetOps ( removeDups )
-import Panic ( ghcError, GhcException(..) )
-import SrcLoc ( SrcLoc )
+import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
+ bindIOName, thenIOName, returnIOName )
+import HscTypes ( InteractiveContext(..),
+ ModIface(..), icPrintUnqual,
+ Dependencies(..) )
+import BasicTypes ( Fixity, RecFlag(..) )
+import SrcLoc ( unLoc )
#endif
import FastString ( mkFastString )
+import Maybes ( MaybeErr(..) )
import Util ( sortLe )
-import Bag ( unionBags, snocBag )
+import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
import Maybe ( isJust )
\end{code}
\begin{code}
tcRnModule :: HscEnv
+ -> HscSource
+ -> Bool -- True <=> save renamed syntax
-> Located (HsModule RdrName)
-> IO (Messages, Maybe TcGblEnv)
-tcRnModule hsc_env (L loc (HsModule maybe_mod exports
- import_decls local_decls mod_deprec))
+tcRnModule hsc_env hsc_src save_rn_decls
+ (L loc (HsModule maybe_mod export_ies
+ import_decls local_decls mod_deprec))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_mod = case maybe_mod of
- Nothing -> mAIN
- -- 'module M where' is omitted
- Just (L _ mod) -> mod } ;
- -- The normal case
+ Nothing -> mAIN -- 'module M where' is omitted
+ Just (L _ mod) -> mod } ; -- The normal case
- initTc hsc_env this_mod $
+ initTc hsc_env hsc_src this_mod $
setSrcSpan loc $
do {
- checkForPackageModule (hsc_dflags hsc_env) this_mod;
-
-- Deal with imports; sets tcg_rdr_env, tcg_imports
(rdr_env, imports) <- rnImports import_decls ;
+ let { dep_mods :: ModuleEnv (Module, IsBootInterface)
+ ; dep_mods = imp_dep_mods imports
+
+ -- We want instance declarations from all home-package
+ -- modules below this one, including boot modules, except
+ -- ourselves. The 'except ourselves' is so that we don't
+ -- get the instances from this module's hs-boot file
+ ; want_instances :: Module -> Bool
+ ; want_instances mod = mod `elemModuleEnv` dep_mods
+ && mod /= this_mod
+ ; home_insts = hptInstances hsc_env want_instances
+ } ;
+
-- 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 }) ;
+ updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
+
+ checkConflicts imports this_mod $ do {
-- Update the gbl env
- updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
- tcg_imports = tcg_imports gbl `plusImportAvails` imports })
- $ do {
+ 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,
+ tcg_rn_decls = if save_rn_decls then
+ Just emptyRnGroup
+ else
+ Nothing })
+ $ do {
+
traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
-- Fail if there are any errors so far
-- The error printing (if needed) takes advantage
traceRn (text "rn1a") ;
-- Rename and type check the declarations
- tcg_env <- tcRnSrcDecls local_decls ;
+ tcg_env <- if isHsBoot hsc_src then
+ tcRnHsBootDecls local_decls
+ else
+ tcRnSrcDecls local_decls ;
setGblEnv tcg_env $ do {
traceRn (text "rn3") ;
reportDeprecations tcg_env ;
-- Process the export list
- exports <- exportsFromAvail (isJust maybe_mod) exports ;
+ exports <- rnExports (isJust maybe_mod) export_ies ;
-- Check whether the entire module is deprecated
-- This happens only once per module
} ;
-- Report unused names
- reportUnusedNames final_env ;
+ reportUnusedNames export_ies final_env ;
-- Dump output and return
tcDump final_env ;
return final_env
- }}}}
-
--- This is really a sanity check that the user has given -package-name
--- if necessary. -package-name is only necessary when the package database
--- already contains the current package, because then we can't tell
--- whether a given module is in the current package or not, without knowing
--- the name of the current package.
-checkForPackageModule dflags this_mod
- | not (isHomeModule dflags this_mod),
- Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
- let
- ppr_pkg = ppr (mkPackageId (package pkg))
- in
- addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
- ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$
- ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
- | otherwise = return ()
+ }}}}}
+
+
+-- The program is not allowed to contain two modules with the same
+-- name, and we check for that here. It could happen if the home package
+-- contains a module that is also present in an external package, for example.
+checkConflicts imports this_mod and_then = do
+ dflags <- getDOpts
+ let
+ dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports))
+ -- don't forget to include the current module!
+
+ mb_dep_pkgs = checkForPackageConflicts
+ dflags dep_mods (imp_dep_pkgs imports)
+ --
+ case mb_dep_pkgs of
+ Failed msg ->
+ do addErr msg; failM
+ Succeeded _ ->
+ updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods })
+ and_then
\end{code}
-- The decls are IfaceDecls; all names are original names
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
- initTc hsc_env this_mod $ do {
+ initTc hsc_env ExtCoreFile this_mod $ do {
let { ldecls = map noLoc decls } ;
-- Deal with the type declarations; first bring their stuff
-- into scope, then rname them, then type check them
- (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
+ tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ;
- updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
- tcg_imports = imports `plusImportAvails` tcg_imports gbl })
- $ do {
+ setGblEnv tcg_env $ do {
rn_decls <- rnTyClDecls ldecls ;
failIfErrsM ;
-- Typecheck them all together so that
-- any mutually recursive types are done right
- tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
+ tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
-- Make the new type env available to stuff slurped from interface files
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 {
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
+ mg_boot = False,
mg_usages = [], -- ToDo: compute usage
mg_dir_imps = [], -- ??
mg_deps = noDependencies, -- ??
+ mg_home_mods = mkHomeModules [], -- ?? wrong!!
mg_exports = my_exports,
mg_types = final_type_env,
mg_insts = tcg_insts tcg_env,
}}}}
mkFakeGroup decls -- Rather clumsy; lots of unused fields
- = HsGroup { hs_tyclds = decls, -- This is the one we want
- hs_valds = [], hs_fords = [],
- hs_instds = [], hs_fixds = [], hs_depds = [],
- hs_ruleds = [], hs_defds = [] }
+ = emptyRdrGroup { hs_tyclds = decls }
\end{code}
-- 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
+ mod <- getModule ;
+ boot_iface <- tcHiBootIface mod ;
-- Do all the declarations
- (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
+ (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+ tcDump tcg_env ;
(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
rules fords ;
- let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
-
- -- Compre the hi-boot iface (if any) with the real thing
- checkHiBootIface final_type_env boot_names ;
+ let { final_type_env = extendTypeEnvWithIds type_env bind_ids
+ ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
+ tcg_binds = binds',
+ tcg_rules = rules',
+ tcg_fords = fords' } } ;
-- Make the new type env available to stuff slurped from interface files
writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
- return (tcg_env { tcg_type_env = final_type_env,
- tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
+ -- Compare the hi-boot iface (if any) with the real thing
+ dfun_binds <- checkHiBootIface tcg_env' boot_iface ;
+
+ return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds })
}
-tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
+tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
-- Loops around dealing with each top level inter-splice group
-- in turn, until it's dealt with the entire module
-tc_rn_src_decls boot_names ds
+tc_rn_src_decls boot_details ds
= do { let { (first_group, group_tail) = findSplice ds } ;
-- If ds is [] we get ([], Nothing)
-- Type check the decls up to, but not including, the first splice
- tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
+ tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
-- Bale out if errors; for example, error recovery when checking
-- the RHS of 'main' can mean that 'main' is not in the envt for
-- Glue them on the front of the remaining decls and loop
setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
- tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
+ tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
#endif /* GHCI */
}}}
\end{code}
%************************************************************************
%* *
- Comparing the hi-boot interface with the real thing
+ Compiling hs-boot source files, and
+ comparing the hi-boot interface with the real thing
%* *
%************************************************************************
-In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
-into the External Package Table. Once we've typechecked the body of the
-module, we want to compare what we've found (gathered in a TypeEnv) with
-the hi-boot stuff in the EPT. We do so here, using the export list of
-the hi-boot interface as our checklist.
+\begin{code}
+tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
+tcRnHsBootDecls decls
+ = do { let { (first_group, group_tail) = findSplice decls }
+
+ ; case group_tail of
+ Just stuff -> spliceInHsBootErr stuff
+ Nothing -> return ()
+
+ -- Rename the declarations
+ ; (tcg_env, rn_group) <- 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 <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
+ ; setGblEnv tcg_env $ do {
+
+ -- Typecheck instance decls
+ ; traceTc (text "Tc3")
+ ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+ ; setGblEnv tcg_env $ do {
+
+ -- Typecheck value declarations
+ ; traceTc (text "Tc5")
+ ; val_ids <- tcHsBootSigs (hs_valds rn_group)
+
+ -- Wrap up
+ -- No simplification or zonking to do
+ ; traceTc (text "Tc7a")
+ ; gbl_env <- getGblEnv
+
+ -- Make the final type-env
+ -- Include the dfun_ids so that their type sigs get
+ -- are written into the interface file
+ ; 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 })
+ }}}}
+
+spliceInHsBootErr (SpliceDecl (L loc _), _)
+ = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
+\end{code}
+
+Once we've typechecked the body of the module, we want to compare what
+we've found (gathered in a TypeEnv) with the hi-boot details (if any).
\begin{code}
-checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
+checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
-- Compare the hi-boot file for this module (if there is one)
-- with the type environment we've just come up with
-- In the common case where there is no hi-boot file, the list
-- of boot_names is empty.
-checkHiBootIface env boot_names
- = mapM_ (check_one env) boot_names
-
-----------------
-check_one local_env name
- = do { eps <- getEps
-
- -- Look up the hi-boot one;
- -- it should jolly well be there (else GHC bug)
- ; case lookupTypeEnv (eps_PTE eps) name of {
- Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
- Just boot_thing ->
-
- -- Look it up in the local type env
- -- It should be there, but it's a programmer error if not
- case lookupTypeEnv local_env name of
- Nothing -> addErrTc (missingBootThing boot_thing)
- Just real_thing -> check_thing boot_thing real_thing
- } }
+--
+-- The bindings we return give bindings for the dfuns defined in the
+-- hs-boot file, such as $fbEqT = $fEqT
+
+checkHiBootIface
+ (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
+ (ModDetails { md_insts = boot_insts, md_types = boot_type_env })
+ = do { mapM_ check_one (typeEnvElts boot_type_env)
+ ; dfun_binds <- mapM check_inst boot_insts
+ ; return (unionManyBags dfun_binds) }
+ where
+ check_one boot_thing
+ | no_check name
+ = return ()
+ | otherwise
+ = case lookupTypeEnv local_type_env name of
+ Nothing -> addErrTc (missingBootThing boot_thing)
+ Just real_thing -> check_thing boot_thing real_thing
+ where
+ name = getName boot_thing
+
+ no_check name = isWiredInName name -- No checking for wired-in names. In particular,
+ -- 'error' is handled by a rather gross hack
+ -- (see comments in GHC.Err.hs-boot)
+ || name `elem` dfun_names
+ dfun_names = map getName boot_insts
+
+ check_inst boot_inst
+ = case [dfun | inst <- local_insts,
+ let dfun = instanceDFunId inst,
+ idType dfun `tcEqType` boot_inst_ty ] of
+ [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
+ (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
+ where
+ boot_dfun = instanceDFunId boot_inst
+ boot_inst_ty = idType boot_dfun
+ local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty
----------------
check_thing (ATyCon boot_tc) (ATyCon real_tc)
| tyConKind boot_tc == tyConKind real_tc
= return ()
where
- (tvs1, defn1) = getSynTyConDefn boot_tc
- (tvs2, defn2) = getSynTyConDefn boot_tc
+ (tvs1, defn1) = synTyConDefn boot_tc
+ (tvs2, defn2) = synTyConDefn boot_tc
check_thing (AnId boot_id) (AnId real_id)
| idType boot_id `tcEqType` idType real_id
----------------
missingBootThing thing
- = ppr thing <+> ptext SLIT("is defined in the hi-boot file, but not in the module")
+ = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
bootMisMatch thing
- = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hi-boot file")
+ = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
+instMisMatch inst
+ = hang (ppr inst)
+ 2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
\end{code}
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
+tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
-- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup boot_names decls
+tcRnGroup boot_details decls
= do { -- Rename the declarations
(tcg_env, rn_decls) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
- tcTopSrcDecls boot_names rn_decls
+ tcTopSrcDecls boot_details rn_decls
}}
------------------------------------------------
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
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 {
+ tcg_env <- importsFromLocalDecls group ;
+ setGblEnv tcg_env $ do {
- traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-- Rename the source decls
(tcg_env, rn_decls) <- rnSrcDecls group ;
failIfErrsM ;
+ -- save the renamed syntax, if we want it
+ let { tcg_env'
+ | Just grp <- tcg_rn_decls tcg_env
+ = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
+ | otherwise
+ = tcg_env };
+
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
- return (tcg_env, rn_decls)
+ return (tcg_env', rn_decls)
}}
------------------------------------------------
-tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls boot_names
+tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_fords = foreign_decls,
-- The latter come in via tycl_decls
traceTc (text "Tc2") ;
- tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
+ tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
-- tcTyAndClassDecls recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
-- We also typecheck any extra binds that came out
-- of the "deriving" process (deriv_binds)
traceTc (text "Tc5") ;
- (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
- setLclTypeEnv lcl_env $ do {
+ (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ;
+ setLclTypeEnv tcl_env $ do {
-- Second pass over class and instance declarations,
traceTc (text "Tc6") ;
- (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
+ (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ;
showLIE (text "after instDecls2") ;
-- Foreign exports
tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
tcg_rules = tcg_rules tcg_env ++ rules,
tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
- return (tcg_env', lcl_env)
+ return (tcg_env', tcl_env)
}}}}}}
\end{code}
%************************************************************************
\begin{code}
+checkMain :: TcM TcGblEnv
+-- If we are in module Main, check that 'main' is defined.
checkMain
= do { ghci_mode <- getGhciMode ;
tcg_env <- getGblEnv ;
-
- mb_main_mod <- readMutVar v_MainModIs ;
- mb_main_fn <- readMutVar v_MainFunIs ;
- let { main_mod = case mb_main_mod of {
- Just mod -> mkModule mod ;
- Nothing -> mAIN } ;
- main_fn = case mb_main_fn of {
- Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
+ dflags <- getDOpts ;
+ let { main_mod = mainModIs dflags ;
+ main_fn = case mainFunIs dflags of {
+ Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
Nothing -> main_RDR_Unqual } } ;
check_main ghci_mode tcg_env main_mod main_fn
check_main ghci_mode tcg_env main_mod main_fn
- -- If we are in module Main, check that 'main' is defined.
- -- It may be imported from another module!
- --
- --
- -- Blimey: a whole page of code to do this...
| mod /= main_mod
- = return tcg_env
+ = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
+ return tcg_env
| otherwise
= addErrCtxt mainCtxt $
-- Check that 'main' is in scope
-- It might be imported from another module!
; case mb_main of {
- Nothing -> do { complain_no_main
+ Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
+ ; complain_no_main
; return tcg_env } ;
Just main_name -> do
- { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
- -- :Main.main :: IO () = runIO main
+ { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
+ ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
+ -- :Main.main :: IO () = runMainIO main
; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
tcInferRho rhs
- ; let { root_main_id = mkExportedLocalId rootMainName ty ;
- main_bind = noLoc (VarBind root_main_id main_expr) }
+ -- The function that the RTS invokes is always :Main.main,
+ -- which we call root_main_id.
+ -- (Because GHC allows the user to have a module not called
+ -- Main as the main module, we can't rely on the main function
+ -- being called "Main.main". That's why root_main_id has a fixed
+ -- module ":Main".)
+ -- We also make root_main_id an implicit Id, by making main_name
+ -- its parent (hence (Just main_name)). That has the effect
+ -- of preventing its type and unfolding from getting out into
+ -- the interface file. Otherwise we can end up with two defns
+ -- for 'main' in the interface file!
+
+ ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
+ (mkVarOccFS FSLIT("main"))
+ (Just main_name) (getSrcLoc main_name)
+ ; root_main_id = mkExportedLocalId root_main_name ty
+ ; main_bind = noLoc (VarBind root_main_id main_expr) }
; return (tcg_env { tcg_binds = tcg_binds tcg_env
`snocBag` main_bind,
<+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
\end{code}
-
%*********************************************************
%* *
GHCi stuff
\begin{code}
#ifdef GHCI
-setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
-setInteractiveContext icxt thing_inside
- = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
- (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt,
- tcg_type_env = ic_type_env icxt}) $
- updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $
- thing_inside)
+setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext hsc_env icxt thing_inside
+ = let
+ -- Initialise the tcg_inst_env with instances
+ -- from all home modules. This mimics the more selective
+ -- call to hptInstances in tcRnModule
+ dfuns = hptInstances hsc_env (\mod -> True)
+ in
+ updGblEnv (\env -> env {
+ tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_type_env = ic_type_env icxt,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
+
+ updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
+
+ do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
+ ; thing_inside }
\end{code}
tcRnStmt hsc_env ictxt rdr_stmt
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env ictxt $ do {
-- Rename; use CmdLineMode because tcRnStmt is only used interactively
- ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
+ (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
failIfErrsM ;
-- The real work is done here
- (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
+ (bound_ids, tc_expr) <- mkPlan rn_stmt ;
+ zonked_expr <- zonkTopLExpr tc_expr ;
+ zonked_ids <- zonkTopBndrs bound_ids ;
+ -- None of the Ids should be of unboxed type, because we
+ -- cast them all to HValues in the end!
+ mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
+
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 zonked_ids ;
-- Update the interactive context
rn_env = ic_rn_local_env ictxt ;
dumpOptTcRn Opt_D_dump_tc
(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
- text "Typechecked expr" <+> ppr tc_expr]) ;
+ text "Typechecked expr" <+> ppr zonked_expr]) ;
- returnM (new_ic, bound_names, tc_expr)
+ returnM (new_ic, bound_names, zonked_expr)
}
-\end{code}
+ 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
+-- 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
\begin{code}
---------------------------
-tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
-tcUserStmt (L _ (ExprStmt expr _))
- = newUnique `thenM` \ uniq ->
- let
- fresh_it = itName uniq
- the_bind = noLoc $ FunBind (noLoc fresh_it) False
- (mkMatchGroup [mkSimpleMatch [] expr])
- in
- tryTcLIE_ (do { -- Try this if the other fails
- traceTc (text "tcs 1b") ;
- tc_stmts [
- nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
- nlExprStmt (nlHsApp (nlHsVar printName)
- (nlHsVar fresh_it))
- ] })
- (do { -- Try this first
- traceTc (text "tcs 1a") ;
- tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
-
-tcUserStmt stmt = tc_stmts [stmt]
+type PlanResult = ([Id], LHsExpr Id)
+type Plan = TcM PlanResult
+
+runPlans :: [Plan] -> TcM PlanResult
+-- Try the plans in order. If one fails (by raising an exn), try the next.
+-- If one succeeds, take it.
+runPlans [] = panic "runPlans"
+runPlans [p] = p
+runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
+
+--------------------
+mkPlan :: LStmt Name -> TcM PlanResult
+mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
+ = do { uniq <- newUnique -- is treated very specially
+ ; let fresh_it = itName uniq
+ the_bind = L loc $ mkFunBind (L loc fresh_it) matches
+ matches = [mkMatch [] expr emptyLocalBinds]
+ let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
+ bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
+ (HsVar bindIOName) noSyntaxExpr
+ print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
+ (HsVar thenIOName) placeHolderType
+
+ -- The plans are:
+ -- [it <- e; print it] but not if it::()
+ -- [it <- e]
+ -- [let it = e; print it]
+ ; runPlans [ -- Plan A
+ do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
+ ; it_ty <- zonkTcType (idType it_id)
+ ; ifM (isUnitTy it_ty) failM
+ ; return stuff },
+
+ -- Plan B; a naked bind statment
+ tcGhciStmts [bind_stmt],
+
+ -- Plan C; check that the let-binding is typeable all by itself.
+ -- If not, fail; if so, try to print it.
+ -- The two-step process avoids getting two errors: one from
+ -- the expression itself, and one from the 'print it' part
+ -- This two-step story is very clunky, alas
+ do { checkNoErrs (tcGhciStmts [let_stmt])
+ --- checkNoErrs defeats the error recovery of let-bindings
+ ; tcGhciStmts [let_stmt, print_it] }
+ ]}
+
+mkPlan stmt@(L loc (BindStmt {}))
+ | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
+ = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
+ (HsVar thenIOName) placeHolderType
+ -- The plans are:
+ -- [stmt; print v] but not if v::()
+ -- [stmt]
+ ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+ ; v_ty <- zonkTcType (idType v_id)
+ ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
+ ; return stuff },
+ tcGhciStmts [stmt]
+ ]}
+
+mkPlan stmt
+ = tcGhciStmts [stmt]
---------------------------
-tc_stmts stmts
+tcGhciStmts :: [LStmt Name] -> TcM PlanResult
+tcGhciStmts stmts
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
let {
+ io_ty = mkTyConApp ioTyCon [] ;
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
- names = map unLoc (collectStmtsBinders stmts) ;
-
- stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = infer_rhs,
- sc_body = check_body,
- sc_ty = ret_ty } ;
-
- infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
- ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
- ; return (rhs', pat_ty) } ;
- check_body body = tcCheckRho body io_ret_ty ;
+ names = map unLoc (collectLStmtsBinders stmts) ;
-- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
-- then the type checker would instantiate x..z, and we wouldn't
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
- mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
- (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+ mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
+ (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
- (nlHsVar id) ;
-
- io_ty = mkTyConApp ioTyCon []
+ (nlHsVar id)
} ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
- ((ids, tc_expr), lie) <- getLIE $ do {
- (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
- do {
- -- Look up the names right in the middle,
- -- where they will all be in scope
- ids <- mappM tcLookupId names ;
- ret_id <- tcLookupId returnIOName ; -- return @ IO
- return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
-
- io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
- return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
- } ;
-
- -- Simplify the context right here, so that we fail
- -- if there aren't enough instances. Notably, when we see
- -- 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") ;
- const_binds <- tcSimplifyInteractive lie ;
-
- -- Build result expression and zonk it
- let { expr = mkHsLet const_binds tc_expr } ;
- zonked_expr <- zonkTopLExpr expr ;
- zonked_ids <- zonkTopBndrs ids ;
-
- -- None of the Ids should be of unboxed type, because we
- -- cast them all to HValues in the end!
- mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
-
- return (zonked_ids, zonked_expr)
- }
- where
- combine stmt (ids, stmts) = (ids, stmt:stmts)
- bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
- nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+ ((tc_stmts, ids), lie) <- getLIE $
+ tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
+ mappM tcLookupId names ;
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+
+ -- Simplify the context
+ const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
+ -- checkNoErrs ensures that the plan fails if context redn fails
+
+ return (ids, mkHsDictLet const_binds $
+ noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
+ }
\end{code}
-> IO (Maybe Type)
tcRnExpr hsc_env ictxt rdr_expr
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env ictxt $ do {
(rn_expr, fvs) <- rnLExpr rdr_expr ;
failIfErrsM ;
-> IO (Maybe Kind)
tcRnType hsc_env ictxt rdr_type
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env ictxt $ do {
rn_type <- rnLHsType doc rdr_type ;
failIfErrsM ;
\begin{code}
#ifdef GHCI
-mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only
- -> IO GlobalRdrEnv
-mkExportEnv hsc_env exports
- = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
- mappM getModuleExports exports
- ; case mb_envs of
- Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
- Nothing -> return emptyGlobalRdrEnv
- -- Some error; initTc will have printed it
- }
-
-getModuleExports :: Module -> TcM GlobalRdrEnv
-getModuleExports mod
- = do { iface <- load_iface mod
- ; loadOrphanModules (dep_orphs (mi_deps iface))
- -- Load any orphan-module interfaces,
- -- so their instances are visible
- ; avails <- exportsToAvails (mi_exports iface)
- ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
- | avail <- avails, name <- availNames avail ] }
- ; returnM (mkGlobalRdrEnv gres) }
-
-vanillaProv :: Module -> Provenance
--- We're building a GlobalRdrEnv as if the user imported
--- all the specified modules into the global interactive module
-vanillaProv mod = Imported [ImportSpec mod mod False
- (srcLocSpan interactiveSrcLoc)] False
-\end{code}
+-- 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.
+getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet)
+getModuleExports hsc_env mod
+ = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
+
+tcGetModuleExports :: Module -> TcM NameSet
+tcGetModuleExports mod = do
+ iface <- load_iface mod
+ loadOrphanModules (dep_orphs (mi_deps iface))
+ -- Load any orphan-module interfaces,
+ -- so their instances are visible
+ ifaceExportNames (mi_exports iface)
-\begin{code}
-getModuleContents
- :: HscEnv
- -> InteractiveContext
- -> Module -- Module to inspect
- -> Bool -- Grab just the exports, or the whole toplev
- -> IO (Maybe [IfaceDecl])
-
-getModuleContents hsc_env ictxt mod exports_only
- = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
- where
- get_mod_contents exports_only
- | not exports_only -- We want the whole top-level type env
- -- so it had better be a home module
- = do { hpt <- getHpt
- ; case lookupModuleEnv hpt mod of
- Just mod_info -> return (map toIfaceDecl $
- filter wantToSee $
- typeEnvElts $
- md_types (hm_details mod_info))
- Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
- -- This is a system error; the module should be in the HPT
- }
-
- | otherwise -- Want the exports only
- = do { iface <- load_iface mod
- ; avails <- exportsToAvails (mi_exports iface)
- ; mappM get_decl avails
- }
-
- get_decl avail
- = do { thing <- tcLookupGlobal (availName avail)
- ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) }
-
----------------------
-filter_decl occs decl@(IfaceClass {ifSigs = sigs})
- = decl { ifSigs = filter (keep_sig occs) sigs }
-filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
- = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
-filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
- | keep_con occs con = decl
- | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
-filter_decl occs decl
- = decl
-
-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
-
----------------------
load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
where
doc = ptext SLIT("context for compiling statements")
----------------------
-noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
- <+> quotes (ppr mod)
-\end{code}
-\begin{code}
-tcRnGetInfo :: HscEnv
- -> InteractiveContext
- -> RdrName
- -> IO (Maybe [(IfaceDecl,
- Fixity, SrcLoc,
- [(IfaceInst, SrcLoc)])])
--- Used to implemnent :info in GHCi
---
--- Look up a RdrName and return all the TyThings it might be
--- A capitalised RdrName is given to us in the DataName namespace,
--- but we want to treat it as *both* a data constructor
--- *and* as a type or class constructor;
--- hence the call to dataTcOccs, and we return up to two results
-tcRnGetInfo hsc_env ictxt rdr_name
+tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
+tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ lookup_rdr_name rdr_name
+lookup_rdr_name rdr_name = do {
-- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
-- constructor and type class identifiers.
let { rdr_names = dataTcOccs rdr_name } ;
- -- results :: [(Messages, Maybe Name)]
- results <- mapM (tryTc . lookupOccRn) rdr_names ;
+ -- results :: [Either Messages Name]
+ results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
-- The successful lookups will be (Just name)
do { addMessages (head errs_s) ; failM }
else -- Add deprecation warnings
mapM_ addMessages warns_s ;
-
- -- And lookup up the entities, avoiding duplicates, which arise
- -- because constructors and record selectors are represented by
- -- their parent declaration
- let { do_one name = do { thing <- tcLookupGlobal name
- ; let decl = toIfaceDecl thing
- ; fixity <- lookupFixityRn name
- ; insts <- lookupInsts thing
- ; return (decl, fixity, getSrcLoc thing,
- map mk_inst insts) } ;
- -- For the SrcLoc, the 'thing' has better info than
- -- the 'name' because getting the former forced the
- -- declaration to be loaded into the cache
- mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ;
- cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ;
- results <- mapM do_one good_names ;
- return (fst (removeDups cmp results))
- }
+
+ return good_names
+ }
-lookupInsts :: TyThing -> TcM [DFunId]
-lookupInsts (AClass cls)
- = do { loadImportedInsts cls [] -- [] means load all instances for cls
- ; inst_envs <- tcGetInstEnvs
- ; return [df | (_,_,df) <- classInstances inst_envs cls] }
-lookupInsts (ATyCon tc)
+tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+tcRnLookupName hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ tcLookupGlobal name
+
+
+tcRnGetInfo :: HscEnv
+ -> Name
+ -> IO (Maybe (TyThing, Fixity, [Instance]))
+
+-- Used to implemnent :info in GHCi
+--
+-- Look up a RdrName and return all the TyThings it might be
+-- A capitalised RdrName is given to us in the DataName namespace,
+-- but we want to treat it as *both* a data constructor
+-- *and* as a type or class constructor;
+-- hence the call to dataTcOccs, and we return up to two results
+tcRnGetInfo hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ let ictxt = hsc_IC hsc_env in
+ setInteractiveContext hsc_env ictxt $ do
+
+ -- Load the interface for all unqualified types and classes
+ -- That way we will find all the instance declarations
+ -- (Packages have not orphan modules, and we assume that
+ -- in the home package all relevant modules are loaded.)
+ loadUnqualIfaces ictxt
+
+ thing <- tcLookupGlobal name
+ fixity <- lookupFixityRn name
+ ispecs <- lookupInsts (icPrintUnqual ictxt) thing
+ return (thing, fixity, ispecs)
+
+
+lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
+-- Filter the instances by the ones whose tycons (or clases resp)
+-- are in scope unqualified. Otherwise we list a whole lot too many!
+lookupInsts print_unqual (AClass cls)
+ = do { inst_envs <- tcGetInstEnvs
+ ; return [ ispec
+ | ispec <- classInstances inst_envs cls
+ , plausibleDFun print_unqual (instanceDFunId ispec) ] }
+
+lookupInsts print_unqual (ATyCon tc)
= do { eps <- getEps -- Load all instances for all classes that are
-- in the type environment (which are all the ones
- -- we've seen in any interface file so far
- ; mapM_ (\c -> loadImportedInsts c [])
- (typeEnvClasses (eps_PTE eps))
+ -- we've seen in any interface file so far)
; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
- ; return (get home_ie ++ get pkg_ie) }
+ ; return [ ispec
+ | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
+ , let dfun = instanceDFunId ispec
+ , relevant dfun
+ , plausibleDFun print_unqual dfun ] }
where
- get ie = [df | (_,_,df) <- instEnvElts ie, relevant df]
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
- tc_name = tyConName tc
-
-lookupInsts other = return []
+ tc_name = tyConName tc
+lookupInsts print_unqual other = return []
-toIfaceDecl :: TyThing -> IfaceDecl
-toIfaceDecl thing
- = tyThingToIfaceDecl True -- Discard IdInfo
- emptyNameSet -- Show data cons
- ext_nm (munge thing)
+plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
+ = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
where
- ext_nm n = ExtPkg (nameModule n) (nameOccName n)
-
- -- munge transforms a thing to it's "parent" thing
- munge (ADataCon dc) = ATyCon (dataConTyCon dc)
- munge (AnId id) = case globalIdDetails id of
- RecordSelId tc lbl -> ATyCon tc
- ClassOpId cls -> AClass cls
- other -> AnId id
- munge other_thing = other_thing
-
+ ok name | isBuiltInSyntax name = True
+ | isExternalName name = print_unqual (nameModule name) (nameOccName name)
+ | otherwise = True
+
+loadUnqualIfaces :: InteractiveContext -> TcM ()
+-- Load the home module for everything that is in scope unqualified
+-- This is so that we can accurately report the instances for
+-- something
+loadUnqualIfaces ictxt
+ = initIfaceTcRn $
+ mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
+ where
+ unqual_mods = [ nameModule name
+ | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
+ let name = gre_name gre,
+ isTcOcc (nameOccName name), -- Types and classes only
+ unQualOK gre ] -- In scope unqualified
+ doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
#endif /* GHCI */
\end{code}
ppr_rules rules ]
-ppr_types :: [Var] -> TypeEnv -> SDoc
-ppr_types dfun_ids type_env
+ppr_types :: [Instance] -> TypeEnv -> SDoc
+ppr_types ispecs type_env
= text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
where
+ dfun_ids = map instanceDFunId ispecs
ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id | opt_PprStyle_Debug = True
| otherwise = isLocalId id &&
-- that the type checker has invented. Top-level user-defined things
-- have External names.
-ppr_insts :: [Var] -> SDoc
-ppr_insts [] = empty
-ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
+ppr_insts :: [Instance] -> SDoc
+ppr_insts [] = empty
+ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
le_sig id1 id2 = getOccName id1 <= getOccName id2
ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
-ppr_rules :: [IdCoreRule] -> SDoc
+ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
- nest 4 (pprIdRules rs),
+ nest 4 (pprRules rs),
ptext SLIT("#-}")]
ppr_gen_tycons [] = empty
projects / ghc-hetmet.git / blobdiff