module TcRnDriver (
#ifdef GHCI
mkExportEnv, getModuleContents, tcRnStmt,
- tcRnGetInfo, tcRnExpr, tcRnType,
+ tcRnGetInfo, GetInfoResult,
+ tcRnExpr, tcRnType,
#endif
tcRnModule,
tcTopSrcDecls,
#include "HsVersions.h"
+import IO
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
-import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
+import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
+import StaticFlags ( opt_PprStyle_Debug )
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 Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
import VarEnv ( varEnvElts )
-import Module ( Module, ModuleEnv, mkModule, moduleEnvElts )
+import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
import NameSet
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
- GhciMode(..), IsBootInterface, noDependencies,
+ IsBootInterface, noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
TypeEnv, lookupTypeEnv, hptInstances, lookupType,
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcStdSyntaxName, tcGetInstEnvs )
-import InstEnv ( classInstances, instEnvElts )
+import InstEnv ( DFunId, classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
import RnNames ( exportsToAvails )
import LoadIface ( loadSrcInterface, ifaceInstGates )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
tyThingToIfaceDecl, dfunToIfaceInst )
-import IfaceType ( IfaceTyCon(..), ifPrintUnqual )
+import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType,
+ interactiveExtNameFun, isLocalIfaceExtName )
import IfaceEnv ( lookupOrig )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( Id, isImplicitId, setIdType, globalIdDetails )
import SrcLoc ( interactiveSrcLoc, unLoc )
import Kind ( Kind )
import Var ( globaliseId )
-import Name ( nameOccName, nameModule )
+import Name ( nameOccName )
+import OccName ( occNameUserString )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
-import Module ( lookupModuleEnv )
import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
availNames, availName, ModIface(..), icPrintUnqual,
ModDetails(..), Dependencies(..) )
-- 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
+
+ ; 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
- let { dep_mods :: ModuleEnv (Module, IsBootInterface)
- ; dep_mods = imp_dep_mods imports } ;
-
updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
-- Update the gbl env
- 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,
} ;
-- Report unused names
- reportUnusedNames final_env ;
+ reportUnusedNames export_ies final_env ;
-- Dump output and return
tcDump final_env ;
-- Typecheck value declarations
; traceTc (text "Tc5")
- ; (tc_val_binds, lcl_env) <- tcHsBootSigs (hs_valds rn_group)
+ ; new_ids <- 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 }
-
+ ; let { final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
; return (gbl_env { tcg_type_env = final_type_env })
}}}}
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 {
+ dflags <- getDOpts ;
+ let { main_mod = case mainModIs dflags of {
Just mod -> mkModule mod ;
Nothing -> mAIN } ;
- main_fn = case mb_main_fn of {
+ main_fn = case mainFunIs dflags of {
Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
Nothing -> main_RDR_Unqual } } ;
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside
= let
- root_modules :: [(Module, IsBootInterface)]
- root_modules = [(mkModule m, False) | m <- ic_toplev_scope icxt]
- dfuns = hptInstances hsc_env root_modules
+ -- 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,
\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
+getModuleContents hsc_env mod exports_only
= initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
where
get_mod_contents exports_only
-- so it had better be a home module
= do { hpt <- getHpt
; case lookupModuleEnv hpt mod of
- Just mod_info -> return (map toIfaceDecl $
+ Just mod_info -> return (map (toIfaceDecl ext_nm) $
filter wantToSee $
typeEnvElts $
md_types (hm_details mod_info))
get_decl (mod, avail)
= do { main_name <- lookupOrig mod (availName avail)
; thing <- tcLookupGlobal main_name
- ; return (filter_decl (availNames avail) (toIfaceDecl thing)) }
+ ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
+
+ ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env))
---------------------
filter_decl occs decl@(IfaceClass {ifSigs = sigs})
\end{code}
\begin{code}
+type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc,
+ [(IfaceType,SrcLoc)] -- Instances
+ )
+
tcRnGetInfo :: HscEnv
-> InteractiveContext
-> RdrName
- -> IO (Maybe [(IfaceDecl,
- Fixity, SrcLoc,
- [(IfaceInst, SrcLoc)])])
+ -> IO (Maybe [GetInfoResult])
+
-- 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;
+-- *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
= initTcPrintErrors hsc_env iNTERACTIVE $
-- their parent declaration
let { do_one name = do { thing <- tcLookupGlobal name
; fixity <- lookupFixityRn name
- ; insts <- lookupInsts print_unqual thing
- ; return (toIfaceDecl thing, fixity,
- getSrcLoc thing, insts) } } ;
+ ; dfuns <- lookupInsts ext_nm thing
+ ; return (str, toIfaceDecl ext_nm thing, fixity,
+ getSrcLoc thing,
+ [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) | dfun <- dfuns]
+ ) }
+ where
+ -- str is the the naked occurrence name
+ -- after stripping off qualification and parens (+)
+ str = occNameUserString (nameOccName name)
+ } ;
+
-- For the SrcLoc, the 'thing' has better info than
-- the 'name' because getting the former forced the
-- declaration to be loaded into the cache
return (fst (removeDups cmp results))
}
where
- cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
+ cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2
+ ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
- print_unqual :: PrintUnqualified
- print_unqual = icPrintUnqual ictxt
-
-lookupInsts :: PrintUnqualified -> TyThing -> TcM [(IfaceInst, SrcLoc)]
+lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [DFunId]
-- 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)
+lookupInsts ext_nm (AClass cls)
= do { loadImportedInsts cls [] -- [] means load all instances for cls
; inst_envs <- tcGetInstEnvs
- ; return [ (inst, getSrcLoc dfun)
+ ; return [ dfun
| (_,_,dfun) <- classInstances inst_envs cls
- , let inst = dfunToIfaceInst dfun
- (_, tycons) = ifaceInstGates (ifInstHead inst)
+ , let (_, tycons) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
+ -- Rather an indirect/inefficient test, but there we go
, all print_tycon_unqual tycons ] }
where
- print_tycon_unqual (IfaceTc ext_nm) = ifPrintUnqual print_unqual ext_nm
+ print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
print_tycon_unqual other = True -- Int etc
-lookupInsts print_unqual (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)
; mapM_ (\c -> loadImportedInsts c [])
(typeEnvClasses (eps_PTE eps))
; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
- ; return [ (inst, getSrcLoc dfun)
+ ; return [ dfun
| (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
, relevant dfun
- , let inst = dfunToIfaceInst dfun
- (cls, _) = ifaceInstGates (ifInstHead inst)
- , ifPrintUnqual print_unqual cls ] }
+ , let (cls, _) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
+ , isLocalIfaceExtName cls ] }
where
relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
tc_name = tyConName tc
-lookupInsts print_unqual 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 (nameModule n) (nameOccName n)
-
-- munge transforms a thing to its "parent" thing
munge (ADataCon dc) = ATyCon (dataConTyCon dc)
munge (AnId id) = case globalIdDetails id of
ClassOpId cls -> AClass cls
other -> AnId id
munge other_thing = other_thing
-
#endif /* GHCI */
\end{code}
projects / ghc-hetmet.git / blobdiff