-- * Flags and settings
DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
parseDynamicFlags,
+ initPackages,
getSessionDynFlags,
setSessionDynFlags,
setMsgHandler,
-- * Loading\/compiling the program
depanal,
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
+ loadMsgs,
workingDirectoryChanged,
checkModule, CheckedModule(..),
isLoaded,
topSortModuleGraph,
+ -- * Inspecting modules
+ ModuleInfo,
+ getModuleInfo,
+ modInfoTyThings,
+ modInfoTopLevelScope,
+ lookupName,
+
-- * Interactive evaluation
getBindings, getPrintUnqual,
#ifdef GHCI
setContext, getContext,
+ getNamesInScope,
moduleIsInterpreted,
getInfo, GetInfoResult,
exprType,
typeKind,
- lookupName,
+ parseName,
RunResult(..),
runStmt,
browseModule,
#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
import qualified Linker
import Linker ( HValue, extendLinkEnv )
import NameEnv ( lookupNameEnv )
-import TcRnDriver ( mkExportEnv, getModuleContents )
+import TcRnDriver ( mkExportEnv, getModuleContents, tcRnLookupRdrName )
import RdrName ( plusGlobalRdrEnv )
-import HscMain ( hscGetInfo, GetInfoResult,
+import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier,
hscStmt, hscTcExpr, hscKcType )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
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 RdrName ( RdrName )
+import Name ( Name, getName, nameModule_maybe )
+import RdrName ( RdrName, gre_name, globalRdrEnvElts )
import NameEnv ( nameEnvElts )
-import SrcLoc ( Located )
+import SrcLoc ( Located(..) )
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
import GetImports ( getImports )
import FiniteMap
import Panic
import Digraph
-import ErrUtils ( showPass, Messages, putMsg )
+import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import SysTools ( cleanTempFilesExcept )
import BasicTypes ( SuccessFlag(..), succeeded, failed )
import Maybes ( orElse, expectJust, mapCatMaybes )
+import TcType ( tcSplitSigmaTy, isDictTy )
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
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<size> to increase it"
- _other -> hPutStr stderr (show (Panic (show exception)))
+ putMsg "stack overflow: use +RTS -K<size> to increase it"
+ _other -> putMsg (show (Panic (show exception)))
exitWith (ExitFailure 1)
) $
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
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))]))
-- attempt to load up to this target. If no Module is supplied,
-- then try to load all targets.
load :: Session -> LoadHowMuch -> IO SuccessFlag
-load s@(Session ref) how_much
+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
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.
List.init partial_mg0
| otherwise
= partial_mg0
-
+
stable_mg =
[ AcyclicSCC ms
| AcyclicSCC ms <- full_mg,
(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.
then
-- Easy; just relink it all.
- do when (verb >= 2) $ putMsg "Upsweep completely successful."
+ do debugTraceMsg dflags 2 "Upsweep completely successful."
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
mod_graph
do_linking = a_root_is_Main || no_hs_main
- when (ghci_mode == BatchCompile && isJust ofile && not do_linking
- && verb > 0) $
- putMsg ("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.")
-- 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) $ putMsg "Upsweep partially successful."
+ do debugTraceMsg dflags 2 "Upsweep partially successful."
let modsDone_names
= map ms_mod modsDone
data CheckedModule =
CheckedModule { parsedSource :: ParsedSource,
- typecheckedSource :: Maybe TypecheckedSource
+ -- ToDo: renamedSource
+ typecheckedSource :: Maybe TypecheckedSource,
+ checkedModuleInfo :: Maybe ModuleInfo
}
type ParsedSource = Located (HsModule RdrName)
-type TypecheckedSource = (LHsBinds Id, GlobalRdrEnv)
+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
-> IO (Maybe CheckedModule)
checkModule session@(Session ref) mod msg_act = do
-- load up the dependencies first
- r <- load session (LoadDependenciesOf mod)
+ r <- loadMsgs session (LoadDependenciesOf mod) msg_act
if (failed r) then return Nothing else do
-- now parse & typecheck the module
case r of
HscFail ->
return Nothing
- HscChecked parsed tcd ->
- return (Just (CheckedModule parsed tcd) )
+ 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 ()
-> 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
[]
= return (Succeeded, hsc_env, [])
-upsweep hsc_env old_hpt stable_mods cleanup
+upsweep hsc_env old_hpt stable_mods cleanup msg_act
(CyclicSCC ms:_)
- = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms))
+ = do putMsg (showSDoc (cyclicModuleErr ms))
return (Failed, hsc_env, [])
-upsweep hsc_env old_hpt stable_mods cleanup
+upsweep hsc_env old_hpt stable_mods cleanup msg_act
(AcyclicSCC mod:mods)
= 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
cleanup -- Remove unwanted tmp files between compilations
| 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
; return (restOK, hsc_env2, mod:modOKs)
}
upsweep_mod :: HscEnv
-> HomePackageTable
-> ([Module],[Module])
+ -> (Messages -> IO ())
-> ModSummary
-> 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
= do
let
this_mod = ms_mod 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
case ghcMode (hsc_dflags hsc_env) of
BatchCompile ->
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 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
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
case compresult of
-- Compilation failed. Compile may still have updated the PCS, tho.
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)
+
+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]
_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
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)
-- ---------------------------------------------------------------------------
-- 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
projects / ghc-hetmet.git / blobdiff