-s%
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcModule]{Typechecking a whole module}
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 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 TcBinds ( tcTopBinds )
+import InstEnv ( extendInstEnvList )
+import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv )
import TcRules ( tcRules )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import Module ( mkModule, moduleEnvElts )
+import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
import OccName ( mkVarOcc )
-import Name ( Name, isExternalName, getSrcLoc, getOccName )
+import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
import NameSet
import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
import SrcLoc ( srcLocSpan, Located(..), noLoc )
-import Outputable
+import DriverPhases ( HscSource(..), isHsBoot )
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
- GhciMode(..), noDependencies,
+ IsBootInterface, noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
- TypeEnv, lookupTypeEnv,
+ TypeEnv, lookupTypeEnv, hptInstances, lookupType,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
)
+import Outputable
+
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
LStmt, LHsExpr, LHsType, mkMatchGroup,
- collectStmtsBinders, mkSimpleMatch,
- nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
+ collectLStmtsBinders, mkSimpleMatch,
+ mkExprStmt, mkBindStmt, nlVarPat )
import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
Provenance(..), ImportSpec(..),
lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource ( addTcgDUs )
import TcHsSyn ( mkHsLet, 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 TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
-import Inst ( tcStdSyntaxName, tcGetInstEnvs )
+import Inst ( tcGetInstEnvs )
import InstEnv ( DFunId, 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(..), 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 ( Module, lookupModuleEnv )
+import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, returnIOName )
import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
- availNames, availName, ModIface(..),
+ availNames, availName, ModIface(..), icPrintUnqual,
ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Bag ( unitBag )
\begin{code}
tcRnModule :: HscEnv
+ -> HscSource
-> Located (HsModule RdrName)
-> IO (Messages, Maybe TcGblEnv)
-tcRnModule hsc_env (L loc (HsModule maybe_mod export_ies
+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 -> 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
+
+ ; 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 = 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 {
+ 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") ;
} ;
-- Report unused names
- reportUnusedNames final_env ;
+ reportUnusedNames export_ies final_env ;
-- Dump output and return
tcDump final_env ;
-- 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 } ;
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, -- ??
%************************************************************************
%* *
- Comparing the hi-boot interface with the real thing
+ 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")
+ ; new_ids <- tcHsBootSigs (hs_valds rn_group)
+
+ -- Wrap up
+ -- No simplification or zonking to do
+ ; traceTc (text "Tc7a")
+ ; gbl_env <- getGblEnv
+
+ ; let { 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
----------------
check_one local_env name
- = do { eps <- getEps
+ | 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 lookupTypeEnv (eps_PTE eps) name of {
+ ; case lookupType hpt (eps_PTE eps) name of {
Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
Just boot_thing ->
----------------
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")
\end{code}
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 } } ;
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
\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 ;
\begin{code}
---------------------------
tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
-tcUserStmt (L _ (ExprStmt expr _))
+tcUserStmt (L loc (ExprStmt expr _ _))
= newUnique `thenM` \ uniq ->
let
fresh_it = itName uniq
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))
- ] })
+ tc_stmts (map (L loc) [
+ LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
+ mkExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
+ ]) })
(do { -- Try this first
traceTc (text "tcs 1a") ;
- tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
+ tc_stmts [L loc (mkBindStmt (nlVarPat fresh_it) expr)] })
tcUserStmt stmt = tc_stmts [stmt]
---------------------------
+tc_stmts :: [LStmt Name] -> TcM ([Id], LHsExpr Id)
tc_stmts stmts
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
let {
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]
-- 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))
+ (tc_stmts, ids) <- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
+ do {
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+ ids <- mappM tcLookupId names ;
+ return ids } ;
+
+ ret_id <- tcLookupId returnIOName ; -- return @ IO
+ return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty))
} ;
-- Simplify the context right here, so that we fail
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))])
\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}
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 $
- 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) } ;
+ ; 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
- 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 [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 ext_nm (AClass cls)
= do { loadImportedInsts cls [] -- [] means load all instances for cls
; inst_envs <- tcGetInstEnvs
- ; return [df | (_,_,df) <- classInstances inst_envs cls] }
+ ; return [ dfun
+ | (_,_,dfun) <- classInstances inst_envs cls
+ , 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 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 [ dfun
+ | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
+ , relevant dfun
+ , let (cls, _) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
+ , 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 (nameModule 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 tc lbl -> ATyCon tc
ClassOpId cls -> AClass cls
other -> AnId id
munge other_thing = other_thing
-
#endif /* GHCI */
\end{code}
projects / ghc-hetmet.git / blobdiff