X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FGHC.hs;h=6ce921de3f27e98c8a59ab7c5975da80217d79c5;hb=e7da484086a7be73dbd0747b945fe63e7cd53ed0;hp=18ba708081437c270d3c7d132350356888b91d63;hpb=6720aae478aeffab9d93b33b76e8718130cd4a7b;p=ghc-hetmet.git diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 18ba708..6ce921d 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -17,21 +17,26 @@ module GHC ( -- * Flags and settings DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt, parseDynamicFlags, + initPackages, getSessionDynFlags, setSessionDynFlags, setMsgHandler, -- * Targets - Target(..), + Target(..), TargetId(..), setTargets, getTargets, addTarget, + removeTarget, guessTarget, - -- * Loading/compiling the program + -- * Loading\/compiling the program depanal, - load, SuccessFlag(..), -- also does depanal + load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + loadMsgs, workingDirectoryChanged, + checkModule, CheckedModule(..), + TypecheckedSource, ParsedSource, -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), @@ -39,15 +44,25 @@ module GHC ( isLoaded, topSortModuleGraph, + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, + modInfoPrintUnqualified, + modInfoExports, + lookupName, + -- * Interactive evaluation getBindings, getPrintUnqual, #ifdef GHCI setContext, getContext, + getNamesInScope, moduleIsInterpreted, getInfo, GetInfoResult, exprType, typeKind, - lookupName, + parseName, RunResult(..), runStmt, browseModule, @@ -56,14 +71,44 @@ module GHC ( #endif -- * Abstract syntax elements + + -- ** Modules Module, mkModule, pprModule, + + -- ** Names + Name, + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, + isDataConWorkId, idDataCon, + isBottomingId, isDictonaryId, + + -- ** Type constructors + TyCon, + isClassTyCon, isSynTyCon, isNewTyCon, + + -- ** Data constructors + DataCon, + + -- ** Classes + Class, + classSCTheta, classTvsFds, + + -- ** Types and Kinds Type, dropForAlls, Kind, - Name, Id, TyCon, Class, DataCon, + + -- ** Entities TyThing(..), - idType, - -- used by DriverMkDepend: + -- * Exceptions + GhcException(..), showGhcException, + + -- * Miscellaneous sessionHscEnv, cyclicModuleErr, ) where @@ -86,9 +131,9 @@ module GHC ( import qualified Linker import Linker ( HValue, extendLinkEnv ) import NameEnv ( lookupNameEnv ) -import TcRnDriver ( mkExportEnv, getModuleContents ) -import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) -import HscMain ( hscGetInfo, GetInfoResult, +import TcRnDriver ( mkExportEnv, getModuleContents, tcRnLookupRdrName ) +import RdrName ( plusGlobalRdrEnv ) +import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) @@ -96,19 +141,30 @@ import GHC.Exts ( unsafeCoerce# ) import IfaceSyn ( IfaceDecl ) #endif +import Packages ( initPackages ) +import NameSet ( NameSet, nameSetToList ) +import RdrName ( GlobalRdrEnv ) +import HsSyn ( HsModule, LHsBinds ) import Type ( Kind, Type, dropForAlls ) -import Id ( Id, idType ) -import TyCon ( TyCon ) -import Class ( Class ) +import Id ( Id, idType, isImplicitId, isDeadBinder, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, + isDataConWorkId, idDataCon, + isBottomingId ) +import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon ) +import Class ( Class, classSCTheta, classTvsFds ) import DataCon ( DataCon ) -import Name ( Name ) +import Name ( Name, getName, nameModule_maybe ) +import RdrName ( RdrName, gre_name, globalRdrEnvElts ) import NameEnv ( nameEnvElts ) +import SrcLoc ( Located(..), mkSrcLoc, srcLocSpan ) import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import GetImports ( getImports ) import Packages ( isHomePackage ) import Finder -import HscMain ( newHscEnv ) +import HscMain ( newHscEnv, hscFileCheck, HscResult(..) ) import HscTypes import DynFlags import StaticFlags @@ -117,24 +173,27 @@ import Module import FiniteMap import Panic import Digraph -import ErrUtils ( showPass ) +import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg ) import qualified ErrUtils import Util -import StringBuffer ( StringBuffer(..), hGetStringBuffer, lexemeToString ) +import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable import SysTools ( cleanTempFilesExcept ) -import BasicTypes ( SuccessFlag(..), succeeded ) +import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Maybes ( orElse, expectJust, mapCatMaybes ) +import TcType ( tcSplitSigmaTy, isDictTy ) +import Bag ( unitBag, emptyBag ) +import FastString ( mkFastString ) import Directory ( getModificationTime, doesFileExist ) -import Maybe ( isJust, isNothing, fromJust ) +import Maybe ( isJust, isNothing, fromJust, fromMaybe, catMaybes ) import Maybes ( expectJust ) import List ( partition, nub ) +import qualified List import Monad ( unless, when, foldM ) import System ( exitWith, ExitCode(..) ) import Time ( ClockTime ) import EXCEPTION as Exception hiding (handle) -import GLAEXTS ( Int(..) ) import DATA_IOREF import IO import Prelude hiding (init) @@ -153,10 +212,10 @@ defaultErrorHandler inner = hFlush stdout case exception of -- an IO exception probably isn't our fault, so don't panic - IOException _ -> hPutStrLn stderr (show exception) + IOException _ -> putMsg (show exception) AsyncException StackOverflow -> - hPutStrLn stderr "stack overflow: use +RTS -K to increase it" - _other -> hPutStr stderr (show (Panic (show exception))) + putMsg "stack overflow: use +RTS -K to increase it" + _other -> putMsg (show (Panic (show exception))) exitWith (ExitFailure 1) ) $ @@ -166,7 +225,7 @@ defaultErrorHandler inner = case dyn of PhaseFailed _ code -> exitWith code Interrupted -> exitWith (ExitFailure 1) - _ -> do hPutStrLn stderr (show (dyn :: GhcException)) + _ -> do putMsg (show (dyn :: GhcException)) exitWith (ExitFailure 1) ) $ inner @@ -210,7 +269,7 @@ GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags) -- | Starts a new session. A session consists of a set of loaded -- modules, a set of options (DynFlags), and an interactive context. --- ToDo: GhcMode should say "keep typechecked code" and/or "keep renamed +-- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed -- code". newSession :: GhcMode -> IO Session newSession mode = do @@ -256,7 +315,7 @@ setMsgHandler = ErrUtils.setMsgHandler -- | Sets the targets for this session. Each target may be a module name -- or a filename. The targets correspond to the set of root modules for --- the program/library. Unloading the current program is achieved by +-- the program\/library. Unloading the current program is achieved by -- setting the current set of targets to be empty, followed by load. setTargets :: Session -> [Target] -> IO () setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets }) @@ -265,13 +324,17 @@ setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets }) getTargets :: Session -> IO [Target] getTargets s = withSession s (return . hsc_targets) --- Add another target, or update an existing target with new content. +-- | Add another target addTarget :: Session -> Target -> IO () addTarget s target = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h }) --- Remove a target --- removeTarget :: Session -> Module -> IO () +-- | Remove a target +removeTarget :: Session -> TargetId -> IO () +removeTarget s target_id + = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) }) + where + filter targets = [ t | t@(Target id _) <- targets, id /= target_id ] -- Attempts to guess what Target a string refers to. This function implements -- the --make/GHCi command-line syntax for filenames: @@ -299,22 +362,6 @@ guessTarget file -- ----------------------------------------------------------------------------- -- Loading the program --- | The result of load. -data LoadResult - = LoadOk Errors -- ^ all specified targets were loaded successfully. - | LoadFailed Errors -- ^ not all modules were loaded. - -type Errors = [String] - -{- -data ErrMsg = ErrMsg { - errMsgSeverity :: Severity, -- warning, error, etc. - errMsgSpans :: [SrcSpan], - errMsgShortDoc :: Doc, - errMsgExtraInfo :: Doc - } --} - -- Perform a dependency analysis starting from the current targets -- and update the session with the new module graph. depanal :: Session -> [Module] -> IO () @@ -327,20 +374,46 @@ depanal (Session ref) excluded_mods = do old_graph = hsc_mod_graph hsc_env showPass dflags "Chasing dependencies" - when (verbosity dflags >= 1 && gmode == BatchCompile) $ - hPutStrLn stderr (showSDoc (hcat [ + when (gmode == BatchCompile) $ + debugTraceMsg dflags 1 (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))])) graph <- downsweep hsc_env old_graph excluded_mods writeIORef ref hsc_env{ hsc_mod_graph=graph } +{- +-- | The result of load. +data LoadResult + = LoadOk Errors -- ^ all specified targets were loaded successfully. + | LoadFailed Errors -- ^ not all modules were loaded. + +type Errors = [String] + +data ErrMsg = ErrMsg { + errMsgSeverity :: Severity, -- warning, error, etc. + errMsgSpans :: [SrcSpan], + errMsgShortDoc :: Doc, + errMsgExtraInfo :: Doc + } +-} + +data LoadHowMuch + = LoadAllTargets + | LoadUpTo Module + | LoadDependenciesOf Module -- | Try to load the program. If a Module is supplied, then just -- attempt to load up to this target. If no Module is supplied, -- then try to load all targets. -load :: Session -> Maybe Module -> IO SuccessFlag -load s@(Session ref) maybe_mod +load :: Session -> LoadHowMuch -> IO SuccessFlag +load session how_much = + loadMsgs session how_much ErrUtils.printErrorsAndWarnings + +-- | Version of 'load' that takes a callback function to be invoked +-- on compiler errors and warnings as they occur during compilation. +loadMsgs :: Session -> LoadHowMuch -> (Messages-> IO ()) -> IO SuccessFlag +loadMsgs s@(Session ref) how_much msg_act = do -- Dependency analysis first. Note that this fixes the module graph: -- even if we don't get a fully successful upsweep, the full module @@ -387,8 +460,7 @@ load s@(Session ref) maybe_mod evaluate pruned_hpt - when (verb >= 2) $ - putStrLn (showSDoc (text "Stable obj:" <+> ppr stable_obj $$ + debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco)) -- Unload any modules which are going to be re-linked this time around. @@ -414,10 +486,28 @@ load s@(Session ref) maybe_mod -- This graph should be cycle-free. -- If we're restricting the upsweep to a portion of the graph, we -- also want to retain everything that is still stable. - let full_mg, partial_mg :: [SCC ModSummary] + let full_mg :: [SCC ModSummary] full_mg = topSortModuleGraph False mod_graph Nothing - partial_mg = topSortModuleGraph False mod_graph maybe_mod + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod ms == mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + stable_mg = [ AcyclicSCC ms | AcyclicSCC ms <- full_mg, @@ -433,7 +523,7 @@ load s@(Session ref) maybe_mod (upsweep_ok, hsc_env1, modsUpswept) <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) - pruned_hpt stable_mods cleanup mg + pruned_hpt stable_mods cleanup msg_act mg -- Make modsDone be the summaries for each home module now -- available; this should equal the domain of hpt3. @@ -448,8 +538,7 @@ load s@(Session ref) maybe_mod then -- Easy; just relink it all. - do when (verb >= 2) $ - hPutStrLn stderr "Upsweep completely successful." + do debugTraceMsg dflags 2 "Upsweep completely successful." -- Clean up after ourselves cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) @@ -470,9 +559,8 @@ load s@(Session ref) maybe_mod mod_graph do_linking = a_root_is_Main || no_hs_main - when (ghci_mode == BatchCompile && isJust ofile && not do_linking - && verb > 0) $ - hPutStrLn stderr ("Warning: output was redirected with -o, " ++ + when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ + debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ main_mod ++ " module.") @@ -485,8 +573,7 @@ load s@(Session ref) maybe_mod -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do when (verb >= 2) $ - hPutStrLn stderr "Upsweep partially successful." + do debugTraceMsg dflags 2 "Upsweep partially successful." let modsDone_names = map ms_mod modsDone @@ -540,13 +627,74 @@ discardProg hsc_env -- source file, but that doesn't do any harm. ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ] ------------------------------------------------------------------------------ +-- ----------------------------------------------------------------------------- +-- Check module + +data CheckedModule = + CheckedModule { parsedSource :: ParsedSource, + -- ToDo: renamedSource + typecheckedSource :: Maybe TypecheckedSource, + checkedModuleInfo :: Maybe ModuleInfo + } + +type ParsedSource = Located (HsModule RdrName) +type TypecheckedSource = LHsBinds Id + +-- | This is the way to get access to parsed and typechecked source code +-- for a module. 'checkModule' loads all the dependencies of the specified +-- module in the Session, and then attempts to typecheck the module. If +-- successful, it returns the abstract syntax for the module. +checkModule :: Session -> Module -> (Messages -> IO ()) + -> IO (Maybe CheckedModule) +checkModule session@(Session ref) mod msg_act = do + -- load up the dependencies first + r <- loadMsgs session (LoadDependenciesOf mod) msg_act + if (failed r) then return Nothing else do + + -- now parse & typecheck the module + hsc_env <- readIORef ref + let mg = hsc_mod_graph hsc_env + case [ ms | ms <- mg, ms_mod ms == mod ] of + [] -> return Nothing + (ms:_) -> do + -- Add in the OPTIONS from the source file This is nasty: + -- we've done this once already, in the compilation manager + -- It might be better to cache the flags in the + -- ml_hspp_file field, say + let dflags0 = hsc_dflags hsc_env + hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) + opts = getOptionsFromStringBuffer hspp_buf + (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts) + if (not (null leftovers)) + then do let filename = fromJust (ml_hs_file (ms_location ms)) + msg_act (optionsErrorMsgs leftovers opts filename) + return Nothing + else do + + r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms + case r of + HscFail -> + return Nothing + HscChecked parsed Nothing -> + return (Just (CheckedModule parsed Nothing Nothing)) + HscChecked parsed (Just (tc_binds, rdr_env, details)) -> do + let minf = ModuleInfo { + minf_details = details, + minf_rdr_env = Just rdr_env + } + return (Just (CheckedModule { + parsedSource = parsed, + typecheckedSource = Just tc_binds, + checkedModuleInfo = Just minf })) + +-- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' = case ghcMode (hsc_dflags hsc_env) of - BatchCompile -> return () + BatchCompile -> return () + JustTypecheck -> return () #ifdef GHCI Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else @@ -737,27 +885,32 @@ upsweep -> HomePackageTable -- HPT from last time round (pruned) -> ([Module],[Module]) -- stable modules (see checkStability) -> IO () -- How to clean up unwanted tmp files + -> (Messages -> IO ()) -- Compiler error message callback -> [SCC ModSummary] -- Mods to do (the worklist) -> IO (SuccessFlag, HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep hsc_env old_hpt stable_mods cleanup - [] +upsweep hsc_env old_hpt stable_mods cleanup msg_act mods + = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods) + +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + [] _ _ = return (Succeeded, hsc_env, []) -upsweep hsc_env old_hpt stable_mods cleanup - (CyclicSCC ms:_) - = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms)) +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + (CyclicSCC ms:_) _ _ + = do putMsg (showSDoc (cyclicModuleErr ms)) return (Failed, hsc_env, []) -upsweep hsc_env old_hpt stable_mods cleanup - (AcyclicSCC mod:mods) +upsweep' hsc_env old_hpt stable_mods cleanup msg_act + (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) - mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod + mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod + mod_index nmods cleanup -- Remove unwanted tmp files between compilations @@ -781,7 +934,8 @@ upsweep hsc_env old_hpt stable_mods cleanup | otherwise = delModuleEnv old_hpt this_mod ; (restOK, hsc_env2, modOKs) - <- upsweep hsc_env1 old_hpt1 stable_mods cleanup mods + <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup + msg_act mods (mod_index+1) nmods ; return (restOK, hsc_env2, mod:modOKs) } @@ -791,10 +945,13 @@ upsweep hsc_env old_hpt stable_mods cleanup upsweep_mod :: HscEnv -> HomePackageTable -> ([Module],[Module]) + -> (Messages -> IO ()) -> ModSummary + -> Int -- index of module + -> Int -- total number of modules -> IO (Maybe HomeModInfo) -- Nothing => Failed -upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods = do let this_mod = ms_mod summary @@ -803,7 +960,8 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary hs_date = ms_hs_date summary compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) - compile_it = upsweep_compile hsc_env old_hpt this_mod summary + compile_it = upsweep_compile hsc_env old_hpt this_mod + msg_act summary mod_index nmods case ghcMode (hsc_dflags hsc_env) of BatchCompile -> @@ -856,7 +1014,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary old_hmi = lookupModuleEnv old_hpt this_mod -- Run hsc to compile a module -upsweep_compile hsc_env old_hpt this_mod summary mb_old_linkable = do +upsweep_compile hsc_env old_hpt this_mod msg_act summary + mod_index nmods + mb_old_linkable = do let -- The old interface is ok if it's in the old HPT -- a) we're compiling a source file, and the old HPT @@ -876,7 +1036,8 @@ upsweep_compile hsc_env old_hpt this_mod summary mb_old_linkable = do where iface = hm_iface hm_info - compresult <- compile hsc_env summary mb_old_linkable mb_old_iface + compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface + mod_index nmods case compresult of -- Compilation failed. Compile may still have updated the PCS, tho. @@ -909,6 +1070,10 @@ topSortModuleGraph -> Maybe Module -> [SCC ModSummary] -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. -- -- Drop hi-boot nodes (first boolean arg)? -- @@ -1252,7 +1417,7 @@ preprocessFile dflags src_fn (Just (buf, time)) let local_opts = getOptionsFromStringBuffer buf -- - (dflags', errs) <- parseDynamicFlags dflags local_opts + (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts) let needs_preprocessing @@ -1265,27 +1430,8 @@ preprocessFile dflags src_fn (Just (buf, time)) when needs_preprocessing $ ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") - return (dflags', "", buf) - + return (dflags', src_fn, buf) --- code adapted from the file-based version in DriverUtil -getOptionsFromStringBuffer :: StringBuffer -> [String] -getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) = - let - ls = lines (lexemeToString buffer (I# len#)) -- lazy, so it's ok - in - look ls - where - look [] = [] - look (l':ls) = do - let l = removeSpaces l' - case () of - () | null l -> look ls - | prefixMatch "#" l -> look ls - | prefixMatch "{-# LINE" l -> look ls -- -} - | Just opts <- matchOptions l - -> opts ++ look ls - | otherwise -> [] ----------------------------------------------------------------------------- -- Error messages @@ -1355,22 +1501,79 @@ getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) getPrintUnqual :: Session -> IO PrintUnqualified getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) +#ifdef GHCI +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: Session -> String -> IO [Name] +parseName s str = withSession s $ \hsc_env -> do + maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str + case maybe_rdr_name of + Nothing -> return [] + Just (L _ rdr_name) -> do + mb_names <- tcRnLookupRdrName hsc_env rdr_name + case mb_names of + Nothing -> return [] + Just ns -> return ns + -- ToDo: should return error messages +#endif + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: Session -> Name -> IO (Maybe TyThing) +lookupName s name = withSession s $ \hsc_env -> do + case lookupTypeEnv (ic_type_env (hsc_IC hsc_env)) name of + Just tt -> return (Just tt) + Nothing -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_details :: ModDetails, + minf_rdr_env :: Maybe GlobalRdrEnv + } + -- ToDo: this should really contain the ModIface too + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo) +getModuleInfo s mdl = withSession s $ \hsc_env -> do + case lookupModuleEnv (hsc_HPT hsc_env) mdl of + Nothing -> return Nothing + Just hmi -> + return (Just (ModuleInfo { + minf_details = hm_details hmi, + minf_rdr_env = mi_globals $! hm_iface hmi + })) + + -- ToDo: we should be able to call getModuleInfo on a package module, + -- even one that isn't loaded yet. + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (md_types (minf_details minf)) + +modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] +modInfoTopLevelScope minf + = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = nameSetToList $! (md_exports $! minf_details minf) + +modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified +modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) + +isDictonaryId :: Id -> Bool +isDictonaryId id + = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } + #if 0 -getModuleInfo :: Session -> Module -> IO ModuleInfo data ObjectCode = ByteCode | BinaryCode FilePath -data ModuleInfo = ModuleInfo { - lm_modulename :: Module, - lm_summary :: ModSummary, - lm_interface :: ModIface, - lm_tc_code :: Maybe TypecheckedCode, - lm_rn_code :: Maybe RenamedCode, - lm_obj :: Maybe ObjectCode - } - type TypecheckedCode = HsTypecheckedGroup type RenamedCode = [HsGroup Name] @@ -1488,9 +1691,15 @@ moduleIsInterpreted s modl = withSession s $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) +{-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-} getInfo :: Session -> String -> IO [GetInfoResult] getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id +-- | Returns all names in scope in the current interactive context +getNamesInScope :: Session -> IO [Name] +getNamesInScope s = withSession s $ \hsc_env -> do + return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -1517,14 +1726,6 @@ typeKind s str = withSession s $ \hsc_env -> do Just kind -> return (Just kind) ----------------------------------------------------------------------------- --- lookupName: returns the TyThing for a Name in the interactive context. --- ToDo: should look it up in the full environment - -lookupName :: Session -> Name -> IO (Maybe TyThing) -lookupName s name = withSession s $ \hsc_env -> do - return $! lookupNameEnv (ic_type_env (hsc_IC hsc_env)) name - ------------------------------------------------------------------------------ -- cmCompileExpr: compile an expression and deliver an HValue compileExpr :: Session -> String -> IO (Maybe HValue) @@ -1624,6 +1825,7 @@ foreign import "rts_evalStableIO" {- safe -} -- --------------------------------------------------------------------------- -- cmBrowseModule: get all the TyThings defined in a module +{-# DEPRECATED browseModule "we should be using getModuleInfo instead" #-} browseModule :: Session -> Module -> Bool -> IO [IfaceDecl] browseModule s modl exports_only = withSession s $ \hsc_env -> do mb_decls <- getModuleContents hsc_env modl exports_only