#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(..),
nlHsApp, nlHsVar, pprLHsBinds )
import RdrHsSyn ( findSplice )
-import PrelNames ( runIOName, rootMainName, mAIN_Name,
+import PrelNames ( runMainIOName, rootMainName, mAIN,
main_RDR_Unqual )
import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
plusGlobalRdrEnv )
import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
-import TcType ( tidyTopType, isUnLiftedType )
+import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
import Inst ( showLIE )
-import TcBinds ( tcTopBinds )
+import InstEnv ( extendInstEnvList )
+import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv )
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( tcExtCoreBindings, loadImportedInsts )
+import TcIface ( tcExtCoreBindings )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
-import LoadIface ( loadOrphanModules )
-import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
+import LoadIface ( loadOrphanModules, loadHiBootInterface )
+import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
import PprCore ( pprIdRules, pprCoreBindings )
import CoreSyn ( IdCoreRule, bindersOfBinds )
+import DataCon ( dataConWrapId )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
+import VarEnv ( varEnvElts )
+import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
import OccName ( mkVarOcc )
-import Name ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc )
+import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
import NameSet
-import TyCon ( tyConHasGenerics )
-import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc )
-import Outputable
-import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ),
- GhciMode(..), isOneShot, Dependencies(..), noDependencies,
+import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
+import SrcLoc ( srcLocSpan, Located(..), noLoc )
+import DriverPhases ( HscSource(..), isHsBoot )
+import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
+ GhciMode(..), IsBootInterface, noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
- ForeignStubs(NoStubs), TypeEnv,
+ ForeignStubs(NoStubs), TyThing(..),
+ TypeEnv, lookupTypeEnv, hptInstances, lookupType,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
)
+import Outputable
+
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
- LStmt, LHsExpr, LHsType,
- collectStmtsBinders, mkSimpleMatch, placeHolderType,
+ LStmt, LHsExpr, LHsType, mkMatchGroup,
+ collectStmtsBinders, mkSimpleMatch,
nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
Provenance(..), ImportSpec(..),
import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
import TcHsType ( kcHsType )
import TcExpr ( tcCheckRho )
-import TcMType ( zonkTcType )
+import TcIface ( loadImportedInsts )
+import TcMType ( zonkTcType, zonkQuantifiedTyVar )
+import TcUnify ( unifyTyConApp )
import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
-import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead )
+import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
+ isUnLiftedType, tyClsNamesOfDFunHead )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcStdSyntaxName, tcGetInstEnvs )
-import InstEnv ( DFunId, classInstances, instEnvElts )
+import InstEnv ( classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
-import LoadIface ( loadSrcInterface )
+import LoadIface ( loadSrcInterface, ifaceInstGates )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
tyThingToIfaceDecl, dfunToIfaceInst )
+import IfaceType ( IfaceTyCon(..), interactiveExtNameFun, isLocalIfaceExtName )
+import IfaceEnv ( lookupOrig )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
-import Id ( Id, isImplicitId, globalIdDetails )
-import FieldLabel ( fieldLabelTyCon )
+import Id ( Id, isImplicitId, setIdType, globalIdDetails )
import MkId ( unsafeCoerceId )
import DataCon ( dataConTyCon )
import TyCon ( tyConName )
import SrcLoc ( interactiveSrcLoc, unLoc )
import Kind ( Kind )
import Var ( globaliseId )
-import Name ( nameOccName, nameModuleName )
+import Name ( nameOccName )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
-import Module ( ModuleName, lookupModuleEnvByName )
-import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
- HomeModInfo(..), typeEnvElts, typeEnvClasses,
- TyThing(..), availName, availNames, icPrintUnqual,
- ModIface(..), ModDetails(..) )
+import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
+ availNames, availName, ModIface(..), icPrintUnqual,
+ ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
import ListSetOps ( removeDups )
import Panic ( ghcError, GhcException(..) )
+import SrcLoc ( SrcLoc )
#endif
import FastString ( mkFastString )
\begin{code}
tcRnModule :: HscEnv
+ -> HscSource
-> Located (HsModule RdrName)
-> IO (Messages, Maybe TcGblEnv)
-tcRnModule hsc_env (L loc (HsModule maybe_mod exports
+tcRnModule hsc_env hsc_src (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 -> mkHomeModule mAIN_Name
- -- '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 $
- addSrcSpan loc $
- do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
+ 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 ;
- -- In one-shot mode, record boot-file info in the EPS
- ifM (isOneShot (hsc_mode hsc_env)) $
- updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
+ let { dep_mods :: ModuleEnv (Module, IsBootInterface)
+ ; dep_mods = imp_dep_mods imports
+
+ ; is_dep_mod :: Module -> Bool
+ ; is_dep_mod mod = case lookupModuleEnv dep_mods mod of
+ Nothing -> False
+ Just (_, is_boot) -> not is_boot
+ ; home_insts = hptInstances hsc_env is_dep_mod
+ } ;
+
+ -- 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 = dep_mods }) ;
-- 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 })
+ $ 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 ;
-
-{- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus
- -- 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)
- -- We don't need the results, but sucking them in may side-effect
- -- the ExternalPackageState, apart from recording usage
- mappM (tcLookupGlobal . availName) export_avails ;
--}
+ exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
-- Check whether the entire module is deprecated
-- This happens only once per module
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 ()
\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 } ;
-- Typecheck them all together so that
-- any mutually recursive types are done right
- tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
+ tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] 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, -- ??
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls decls
- = do { -- Do all the declarations
- (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
+ = 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) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
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 ;
+
-- Make the new type env available to stuff slurped from interface files
writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
}
-tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
+tc_rn_src_decls :: [Name] -> [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 ds
+tc_rn_src_decls boot_names 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 first_group ;
+ tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names 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 (spliced_decls ++ rest_ds)
+ tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
#endif /* GHCI */
}}}
\end{code}
+%************************************************************************
+%* *
+ Compiling hs-boot source files, and
+ comparing the hi-boot interface with the real thing
+%* *
+%************************************************************************
+
+\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 [{- no boot_names -}] 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")
+ ; (tc_val_binds, lcl_env) <- tcHsBootSigs (hs_valds rn_group)
+
+ -- Wrap up
+ -- No simplification or zonking to do
+ ; traceTc (text "Tc7a")
+ ; gbl_env <- getGblEnv
+
+ ; let { new_ids = [ id | ATcId id _ _ <- varEnvElts (tcl_env lcl_env) ]
+ ; final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
+
+ ; return (gbl_env { tcg_type_env = final_type_env })
+ }}}}
+
+spliceInHsBootErr (SpliceDecl (L loc _), _)
+ = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
+\end{code}
+
+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}
+checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
+-- 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
+ | isWiredInName name -- No checking for wired-in names. In particular, 'error'
+ = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
+ | otherwise
+ = do { (eps,hpt) <- getEpsAndHpt
+
+ -- Look up the hi-boot one;
+ -- it should jolly well be there (else GHC bug)
+ ; case lookupType hpt (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
+ } }
+
+----------------
+check_thing (ATyCon boot_tc) (ATyCon real_tc)
+ | isSynTyCon boot_tc && isSynTyCon real_tc,
+ defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
+ = return ()
+
+ | tyConKind boot_tc == tyConKind real_tc
+ = return ()
+ where
+ (tvs1, defn1) = getSynTyConDefn boot_tc
+ (tvs2, defn2) = getSynTyConDefn boot_tc
+
+check_thing (AnId boot_id) (AnId real_id)
+ | idType boot_id `tcEqType` idType real_id
+ = return ()
+
+check_thing (ADataCon dc1) (ADataCon dc2)
+ | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
+ = return ()
+
+ -- Can't declare a class in a hi-boot file
+
+check_thing boot_thing real_thing -- Default case; failure
+ = addErrAt (srcLocSpan (getSrcLoc real_thing))
+ (bootMisMatch real_thing)
+
+----------------
+missingBootThing thing
+ = 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 hs-boot file")
+\end{code}
+
%************************************************************************
%* *
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
+tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
-- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup decls
+tcRnGroup boot_names decls
= do { -- Rename the declarations
(tcg_env, rn_decls) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
- tcTopSrcDecls rn_decls
+ tcTopSrcDecls boot_names rn_decls
}}
------------------------------------------------
}}
------------------------------------------------
-tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls
+tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls boot_names
(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 tycl_decls) ;
+ tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
-- tcTyAndClassDecls recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
mb_main_mod <- readMutVar v_MainModIs ;
mb_main_fn <- readMutVar v_MainFunIs ;
let { main_mod = case mb_main_mod of {
- Just mod -> mkModuleName mod ;
- Nothing -> mAIN_Name } ;
+ Just mod -> mkModule mod ;
+ Nothing -> mAIN } ;
main_fn = case mb_main_fn of {
Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
Nothing -> main_RDR_Unqual } } ;
-- If we are in module Main, check that 'main' is defined.
-- It may be imported from another module!
--
- -- ToDo: We have to return the main_name separately, because it's a
- -- bona fide 'use', and should be recorded as such, but the others
- -- aren't
--
-- Blimey: a whole page of code to do this...
- | mod_name /= main_mod
+ | mod /= main_mod
= return tcg_env
| otherwise
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) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
+ ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
tcInferRho rhs
; let { root_main_id = mkExportedLocalId rootMainName ty ;
`snocBag` main_bind,
tcg_dus = tcg_dus tcg_env
`plusDU` usesOnly (unitFV main_name)
+ -- Record the use of 'main', so that we don't
+ -- complain about it being defined but not used
})
}}}
where
- mod_name = moduleName (tcg_mod tcg_env)
+ mod = tcg_mod tcg_env
complain_no_main | ghci_mode == Interactive = return ()
| otherwise = failWithTc noMainMsg
\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] ;
(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
let
fresh_it = itName uniq
the_bind = noLoc $ FunBind (noLoc fresh_it) False
- [ mkSimpleMatch [] expr placeHolderType ]
+ (mkMatchGroup [mkSimpleMatch [] expr])
in
tryTcLIE_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
names = map unLoc (collectStmtsBinders stmts) ;
stmt_ctxt = SC { sc_what = DoExpr,
- sc_rhs = check_rhs,
+ sc_rhs = infer_rhs,
sc_body = check_body,
sc_ty = ret_ty } ;
- check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
- check_body body = tcCheckRho body io_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 ;
-- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
-> 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 ;
((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
tcSimplifyInteractive lie_top ;
+ qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
- let { all_expr_ty = mkForAllTys qtvs $
+ let { all_expr_ty = mkForAllTys qtvs' $
mkFunTys (map idType dict_ids) $
res_ty } ;
zonkTcType all_expr_ty
-> 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 -> [ModuleName] -- Expose these modules' exports only
+mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only
-> IO GlobalRdrEnv
mkExportEnv hsc_env exports
= do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
-- Some error; initTc will have printed it
}
-getModuleExports :: ModuleName -> TcM GlobalRdrEnv
+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)
+ ; 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 :: ModuleName -> Provenance
+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
getModuleContents
:: HscEnv
-> InteractiveContext
- -> ModuleName -- Module to inspect
+ -> Module -- Module to inspect
-> Bool -- Grab just the exports, or the whole toplev
-> IO (Maybe [IfaceDecl])
| not exports_only -- We want the whole top-level type env
-- so it had better be a home module
= do { hpt <- getHpt
- ; case lookupModuleEnvByName hpt mod of
- Just mod_info -> return (map toIfaceDecl $
+ ; case lookupModuleEnv hpt mod of
+ Just mod_info -> return (map (toIfaceDecl ext_nm) $
filter wantToSee $
typeEnvElts $
md_types (hm_details mod_info))
| 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 ext_nm thing)) }
+
+ ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
= decl { ifSigs = filter (keep_sig occs) sigs }
-filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
- = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
+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 (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
-
-availOccs avail = map nameOccName (availNames avail)
+keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
+keep_con occs con = ifConOcc con `elem` occs
wantToSee (AnId id) = not (isImplicitId id)
wantToSee (ADataCon _) = False -- They'll come via their TyCon
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env ictxt rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
- setInteractiveContext ictxt $ do {
+ setInteractiveContext hsc_env ictxt $ do {
-- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
-- 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
+ let { do_one name = do { thing <- tcLookupGlobal name
; fixity <- lookupFixityRn name
- ; insts <- lookupInsts thing
- ; return (decl, fixity, getSrcLoc thing,
- map mk_inst insts) } ;
+ ; insts <- lookupInsts ext_nm thing
+ ; return (toIfaceDecl ext_nm thing, fixity,
+ getSrcLoc thing, 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))
}
+ where
+ cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
+ ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
-lookupInsts :: TyThing -> TcM [DFunId]
-lookupInsts (AClass cls)
+
+lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [(IfaceInst, SrcLoc)]
+-- Filter the instances by the ones whose tycons (or clases resp)
+-- are in scope unqualified. Otherwise we list a whole lot too many!
+lookupInsts ext_nm (AClass cls)
= do { loadImportedInsts cls [] -- [] means load all instances for cls
; inst_envs <- tcGetInstEnvs
- ; return [df | (_,_,df) <- classInstances inst_envs cls] }
+ ; return [ (inst, getSrcLoc dfun)
+ | (_,_,dfun) <- classInstances inst_envs cls
+ , let inst = dfunToIfaceInst ext_nm dfun
+ (_, tycons) = ifaceInstGates (ifInstHead inst)
+ , all print_tycon_unqual tycons ] }
+ where
+ print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
+ print_tycon_unqual other = True -- Int etc
+
-lookupInsts (ATyCon tc)
+lookupInsts ext_nm (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
+ -- we've seen in any interface file so far)
; mapM_ (\c -> loadImportedInsts c [])
(typeEnvClasses (eps_PTE eps))
; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
- ; return (get home_ie ++ get pkg_ie) }
+ ; return [ (inst, getSrcLoc dfun)
+ | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
+ , relevant dfun
+ , let inst = dfunToIfaceInst ext_nm dfun
+ (cls, _) = ifaceInstGates (ifInstHead inst)
+ , isLocalIfaceExtName cls ] }
where
- get ie = [df | (_,_,df) <- instEnvElts ie, relevant df]
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
- tc_name = tyConName tc
+ tc_name = tyConName tc
-lookupInsts other = return []
+lookupInsts ext_nm other = return []
-toIfaceDecl :: TyThing -> IfaceDecl
-toIfaceDecl thing
+toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
+toIfaceDecl ext_nm thing
= tyThingToIfaceDecl True -- Discard IdInfo
emptyNameSet -- Show data cons
ext_nm (munge thing)
where
- ext_nm n = ExtPkg (nameModuleName n) (nameOccName n)
-
- -- munge transforms a thing to it's "parent" thing
+ -- munge transforms a thing to its "parent" thing
munge (ADataCon dc) = ATyCon (dataConTyCon dc)
munge (AnId id) = case globalIdDetails id of
- RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
- ClassOpId cls -> AClass cls
- other -> AnId id
+ RecordSelId tc lbl -> ATyCon tc
+ ClassOpId cls -> AClass cls
+ other -> AnId id
munge other_thing = other_thing
-
#endif /* GHCI */
\end{code}