X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=f5bf84c3e3e4786b1c66221fe785b8a0ef14c831;hb=1159c0c06db593588cfae24e47a80e71c51c6129;hp=84c8ec4c9d44631c19706c30a0b53ebd5f8d86e6;hpb=36a3f8f330caa40380a78ff4a218199130c81ec3;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 84c8ec4..f5bf84c 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -9,6 +9,7 @@ module TcRnDriver ( mkExportEnv, getModuleContents, tcRnStmt, tcRnGetInfo, GetInfoResult, tcRnExpr, tcRnType, + tcRnLookupRdrName, #endif tcRnModule, tcTopSrcDecls, @@ -22,11 +23,13 @@ import IO 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(..), +import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, + SpliceDecl(..), HsBind(..), + emptyGroup, appendGroups, nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) @@ -42,14 +45,14 @@ import Inst ( showLIE ) import InstEnv ( extendInstEnvList ) 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 LoadIface ( loadOrphanModules ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) @@ -60,20 +63,21 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import VarEnv ( varEnvElts ) import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName ) +import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, + getOccName, isWiredInName ) import NameSet import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) -import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), - GhciMode(..), IsBootInterface, noDependencies, +import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, + HscEnv(..), ExternalPackageState(..), + IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), - TypeEnv, lookupTypeEnv, hptInstances, lookupType, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, + TypeEnv, lookupTypeEnv, hptInstances, + extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, emptyFixityEnv ) import Outputable @@ -81,35 +85,32 @@ import Outputable #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), LStmt, LHsExpr, LHsType, mkMatchGroup, - collectStmtsBinders, mkSimpleMatch, - nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat ) + collectLStmtsBinders, mkSimpleMatch, nlVarPat, + placeHolderType, noSyntaxExpr ) 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, ifaceInstGates ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), IfaceConDecls(..), IfaceInst(..), tyThingToIfaceDecl, dfunToIfaceInst ) import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType, interactiveExtNameFun, isLocalIfaceExtName ) -import IfaceEnv ( lookupOrig ) +import IfaceEnv ( lookupOrig, ifaceExportNames ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( Id, isImplicitId, setIdType, globalIdDetails ) import MkId ( unsafeCoerceId ) @@ -123,7 +124,8 @@ import Var ( globaliseId ) import Name ( nameOccName ) import OccName ( occNameUserString ) import NameEnv ( delListFromNameEnv ) -import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) +import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, + bindIOName, thenIOName, returnIOName ) import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses, availNames, availName, ModIface(..), icPrintUnqual, ModDetails(..), Dependencies(..) ) @@ -153,11 +155,13 @@ import Maybe ( isJust ) \begin{code} tcRnModule :: HscEnv -> HscSource + -> Bool -- True <=> save renamed syntax -> Located (HsModule RdrName) -> IO (Messages, Maybe TcGblEnv) -tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies - 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 @@ -191,7 +195,11 @@ tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies 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_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_decls = if save_rn_decls then + Just emptyGroup + else + Nothing }) $ do { traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ; @@ -298,7 +306,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- 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 { @@ -360,10 +368,11 @@ tcRnSrcDecls decls -- 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 ; + 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 @@ -387,27 +396,29 @@ tcRnSrcDecls decls (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) rules fords ; - let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; + 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' } } ; - -- Compre the hi-boot iface (if any) with the real thing - checkHiBootIface final_type_env boot_names ; + -- Compare the hi-boot iface (if any) with the real thing + checkHiBootIface tcg_env' boot_iface ; -- 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' }) + return tcg_env' } -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 @@ -438,7 +449,7 @@ tc_rn_src_decls boot_names ds -- 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} @@ -468,7 +479,7 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc (text "Tc2") ; let tycl_decls = hs_tyclds rn_group - ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls) + ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls) ; setGblEnv tcg_env $ do { -- Typecheck instance decls @@ -478,15 +489,21 @@ tcRnHsBootDecls decls -- Typecheck value declarations ; traceTc (text "Tc5") - ; new_ids <- tcHsBootSigs (hs_valds rn_group) + ; val_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 }) + -- 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 _), _) @@ -500,33 +517,38 @@ 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 () +checkHiBootIface :: TcGblEnv -> ModDetails -> 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 - } } +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_inst boot_insts + ; mapM_ check_one (typeEnvElts boot_type_env) } + 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 inst + | null [i | i <- local_insts, idType i `tcEqType` idType inst] + = addErrTc (instMisMatch inst) + | otherwise + = return () ---------------- check_thing (ATyCon boot_tc) (ATyCon real_tc) @@ -559,6 +581,9 @@ 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") +instMisMatch inst + = hang (ptext SLIT("instance") <+> ppr (idType inst)) + 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) \end{code} @@ -580,15 +605,15 @@ declarations. It expects there to be an incoming TcGblEnv in the 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 }} ------------------------------------------------ @@ -607,15 +632,22 @@ rnTopSrcDecls group (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, @@ -626,7 +658,7 @@ tcTopSrcDecls boot_names -- 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 @@ -699,13 +731,11 @@ tcTopSrcDecls boot_names 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 } } ; @@ -762,7 +792,6 @@ check_main ghci_mode tcg_env main_mod main_fn <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) \end{code} - %********************************************************* %* * GHCi stuff @@ -807,7 +836,7 @@ tcRnStmt hsc_env ictxt rdr_stmt 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 ; @@ -885,7 +914,7 @@ Here is the grand plan, implemented in tcUserStmt \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 @@ -894,35 +923,27 @@ tcUserStmt (L _ (ExprStmt 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)) - ] }) + tc_stmts (map (L loc) [ + LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], + ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + (HsVar thenIOName) placeHolderType + ]) }) (do { -- Try this first traceTc (text "tcs 1a") ; - tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] }) + tc_stmts [L loc (BindStmt (nlVarPat fresh_it) expr + (HsVar bindIOName) noSyntaxExpr) ] }) 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] @@ -946,16 +967,15 @@ tc_stmts stmts -- 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 @@ -979,7 +999,6 @@ tc_stmts stmts 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} @@ -1065,7 +1084,7 @@ getModuleExports mod ; loadOrphanModules (dep_orphs (mi_deps iface)) -- Load any orphan-module interfaces, -- so their instances are visible - ; names <- exportsToAvails (mi_exports iface) + ; names <- ifaceExportNames (mi_exports iface) ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod } | name <- nameSetToList names ] } ; returnM (mkGlobalRdrEnv gres) } @@ -1080,12 +1099,11 @@ vanillaProv mod = Imported [ImportSpec mod mod False \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 @@ -1112,7 +1130,7 @@ getModuleContents hsc_env ictxt mod exports_only ; thing <- tcLookupGlobal main_name ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) } - ext_nm = interactiveExtNameFun (icPrintUnqual ictxt) + ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env)) --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) @@ -1147,22 +1165,15 @@ type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc, [(IfaceType,SrcLoc)] -- Instances ) -tcRnGetInfo :: HscEnv - -> InteractiveContext - -> RdrName - -> IO (Maybe [GetInfoResult]) +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) --- 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 hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env 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. @@ -1187,7 +1198,29 @@ tcRnGetInfo hsc_env ictxt rdr_name do { addMessages (head errs_s) ; failM } else -- Add deprecation warnings mapM_ addMessages warns_s ; - + + return good_names + } + + +tcRnGetInfo :: HscEnv + -> InteractiveContext + -> RdrName + -> 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; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env ictxt rdr_name + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do { + + good_names <- lookup_rdr_name rdr_name ; + -- And lookup up the entities, avoiding duplicates, which arise -- because constructors and record selectors are represented by -- their parent declaration