-- * 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, RenamedSource,
-- * Inspecting the module structure of the program
ModuleGraph, ModSummary(..),
getModuleGraph,
+ isLoaded,
topSortModuleGraph,
+ -- * Inspecting modules
+ ModuleInfo,
+ getModuleInfo,
+ modInfoTyThings,
+ modInfoTopLevelScope,
+ modInfoPrintUnqualified,
+ modInfoExports,
+ lookupGlobalName,
+
-- * Interactive evaluation
getBindings, getPrintUnqual,
#ifdef GHCI
setContext, getContext,
+ getNamesInScope,
moduleIsInterpreted,
getInfo, GetInfoResult,
exprType,
typeKind,
- lookupName,
+ parseName,
RunResult(..),
runStmt,
browseModule,
showModule,
compileExpr, HValue,
+ lookupName,
#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:
+ -- ** Syntax
+ module HsSyn, -- ToDo: remove extraneous bits
+
+ -- * Exceptions
+ GhcException(..), showGhcException,
+
+ -- * Miscellaneous
sessionHscEnv,
cyclicModuleErr,
) where
{-
ToDo:
- * return error messages rather than printing them.
* inline bits of HscMain here to simplify layering: hscGetInfo,
hscTcExpr, hscStmt.
- * implement second argument to load.
* we need to expose DynFlags, so should parseDynamicFlags really be
part of this interface?
* what StaticFlags should we expose, if any?
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,
+ getModuleExports )
+import RdrName ( plusGlobalRdrEnv )
+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
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 InstEnv ( Instance )
+import Name ( Name, getName, nameModule_maybe )
+import RdrName ( RdrName, gre_name, globalRdrEnvElts )
import NameEnv ( nameEnvElts )
-import DriverPipeline ( preprocess, compile, CompResult(..), link )
-import DriverPhases ( isHaskellSrcFilename )
+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
import Module
import FiniteMap
import Panic
-import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
-import ErrUtils ( showPass )
+import Digraph
+import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg )
import qualified ErrUtils
import Util
-import StringBuffer ( hGetStringBuffer )
+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 )
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
-- | 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
-- | 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 })
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:
-- -----------------------------------------------------------------------------
-- 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 ()
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{-ToDo-}
+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
+ -- Dependency analysis first. Note that this fixes the module graph:
+ -- even if we don't get a fully successful upsweep, the full module
+ -- graph is still retained in the Session. We can tell which modules
+ -- were successfully loaded by inspecting the Session's HPT.
depanal s []
hsc_env <- readIORef ref
not (ms_mod s `elem` all_home_mods)]
ASSERT( null bad_boot_mods ) return ()
- -- Topologically sort the module graph
- -- mg2 should be cycle free; but it includes hi-boot ModSummary nodes
- let mg2 :: [SCC ModSummary]
- mg2 = topSortModuleGraph False mod_graph
-
-- mg2_with_srcimps drops the hi-boot nodes, returning a
-- graph with cycles. Among other things, it is used for
-- backing out partially complete cycles following a failed
-- upsweep, and for removing from hpt all the modules
-- not in strict downwards closure, during calls to compile.
let mg2_with_srcimps :: [SCC ModSummary]
- mg2_with_srcimps = topSortModuleGraph True mod_graph
+ mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
-- check the stability property for each module.
stable_mods@(stable_obj,stable_bco)
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.
-- Now do the upsweep, calling compile for each module in
-- turn. Final result is version 3 of everything.
+ -- Topologically sort the module graph, this time including hi-boot
+ -- nodes, and possibly just including the portion of the graph
+ -- reachable from the module specified in the 2nd argument to load.
+ -- 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 :: [SCC ModSummary]
+ full_mg = topSortModuleGraph False mod_graph Nothing
+
+ 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,
+ ms_mod ms `elem` stable_obj++stable_bco,
+ ms_mod ms `notElem` [ ms_mod ms' |
+ AcyclicSCC ms' <- partial_mg ] ]
+
+ mg = stable_mg ++ partial_mg
+
-- clean up between compilations
let cleanup = cleanTempFilesExcept dflags
- (ppFilesFromSummaries (flattenSCCs mg2))
+ (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))
(upsweep_ok, hsc_env1, modsUpswept)
<- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
- pruned_hpt stable_mods cleanup mg2
+ 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) $
- hPutStrLn stderr "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) $
- 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.")
-- link everything together
linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
- let hsc_env4 = hsc_env1{ hsc_mod_graph = modsDone }
- loadFinish Succeeded linkresult ref hsc_env4
+ loadFinish Succeeded linkresult ref hsc_env1
else
-- 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
-- Link everything together
linkresult <- link ghci_mode dflags False hpt4
- let hsc_env4 = hsc_env1{ hsc_mod_graph = mods_to_keep,
- hsc_HPT = hpt4 }
+ let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
loadFinish Failed linkresult ref hsc_env4
-- Finish up after a load.
-- 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,
+ renamedSource :: Maybe RenamedSource,
+ typecheckedSource :: Maybe TypecheckedSource,
+ checkedModuleInfo :: Maybe ModuleInfo
+ }
+
+type ParsedSource = Located (HsModule RdrName)
+type RenamedSource = HsGroup Name
+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 renamed Nothing ->
+ return (Just (CheckedModule {
+ parsedSource = parsed,
+ renamedSource = renamed,
+ typecheckedSource = Nothing,
+ checkedModuleInfo = Nothing }))
+ HscChecked parsed renamed
+ (Just (tc_binds, rdr_env, details)) -> do
+ let minf = ModuleInfo {
+ minf_type_env = md_types details,
+ minf_exports = md_exports details,
+ minf_rdr_env = Just rdr_env
+ }
+ return (Just (CheckedModule {
+ parsedSource = parsed,
+ renamedSource = renamed,
+ 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
-> 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
| 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)
}
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
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 ->
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
- -- entry is for a source file
+ -- entry is for a source file
-- b) we're compiling a hs-boot file
-- Case (b) allows an hs-boot file to get the interface of its
-- real source file on the second iteration of the compilation
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.
topSortModuleGraph
:: Bool -- Drop hi-boot nodes? (see below)
-> [ModSummary]
+ -> 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)?
--
-- the a source-import of Foo is an import of Foo
-- The resulting graph has no hi-boot nodes, but can by cyclic
-topSortModuleGraph drop_hs_boot_nodes summaries
- = stronglyConnComp nodes
+topSortModuleGraph drop_hs_boot_nodes summaries Nothing
+ = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries))
+topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
+ = stronglyConnComp (map vertex_fn (reachable graph root))
+ where
+ -- restrict the graph to just those modules reachable from
+ -- the specified module. We do this by building a graph with
+ -- the full set of nodes, and determining the reachable set from
+ -- the specified node.
+ (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries
+ (graph, vertex_fn, key_fn) = graphFromEdges' nodes
+ root
+ | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
+ | otherwise = throwDyn (ProgramError "module does not exist")
+
+moduleGraphNodes :: Bool -> [ModSummary]
+ -> ([(ModSummary, Int, [Int])], HscSource -> Module -> Maybe Int)
+moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key)
where
-- Drop hs-boot nodes by using HsSrcFile as the key
hs_boot_key | drop_hs_boot_nodes = HsSrcFile
getRootSummary :: Target -> IO ModSummary
getRootSummary (Target (TargetFile file) maybe_buf)
= do exists <- doesFileExist file
- if exists then summariseFile hsc_env file else do
+ if exists then summariseFile hsc_env file maybe_buf else do
throwDyn (CmdLineError ("can't find file: " ++ file))
getRootSummary (Target (TargetModule modl) maybe_buf)
= do maybe_summary <- summarise hsc_env emptyNodeMap Nothing False
- modl excl_mods
+ modl maybe_buf excl_mods
case maybe_summary of
Nothing -> packageModErr modl
Just s -> return s
| key `elemFM` done = loop ss done
| otherwise = do { mb_s <- summarise hsc_env old_summary_map
(Just cur_path) is_boot
- wanted_mod excl_mods
+ wanted_mod Nothing excl_mods
; case mb_s of
Nothing -> loop ss done
Just s -> loop (msDeps s ++ ss)
-- a summary. The finder is used to locate the file in which the module
-- resides.
-summariseFile :: HscEnv -> FilePath -> IO ModSummary
+summariseFile :: HscEnv -> FilePath
+ -> Maybe (StringBuffer,ClockTime)
+ -> IO ModSummary
-- Used for Haskell source only, I think
-- We know the file name, and we know it exists,
-- but we don't necessarily know the module name (might differ)
-summariseFile hsc_env file
+summariseFile hsc_env file maybe_buf
= do let dflags = hsc_dflags hsc_env
- (dflags', hspp_fn) <- preprocess dflags file
- -- The dflags' contains the OPTIONS pragmas
+ (dflags', hspp_fn, buf)
+ <- preprocessFile dflags file maybe_buf
- -- Read the file into a buffer. We're going to cache
- -- this buffer in the ModLocation (ml_hspp_buf) so that it
- -- doesn't have to be slurped again when hscMain parses the
- -- file later.
- buf <- hGetStringBuffer hspp_fn
(srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn
-- Make a ModLocation for this file
-- to findModule will find it, even if it's not on any search path
addHomeModuleToFinder hsc_env mod location
- src_timestamp <- getModificationTime file
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> getModificationTime file
+
obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
-> Maybe FilePath -- Importing module (for error messages)
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Module -- Imported module to be summarised
+ -> Maybe (StringBuffer, ClockTime)
-> [Module] -- Modules to exclude
-> IO (Maybe ModSummary) -- Its new summary
-summarise hsc_env old_summary_map cur_mod is_boot wanted_mod excl_mods
+summarise hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods
| wanted_mod `elem` excl_mods
= return Nothing
src_fn = expectJust "summarise" (ml_hs_file location)
-- return the cached summary if the source didn't change
- src_timestamp <- getModificationTime src_fn
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> getModificationTime src_fn
+
if ms_hs_date old_summary == src_timestamp
then do -- update the object-file timestamp
obj_timestamp <- getObjTimestamp location is_boot
return (Just old_summary{ ms_obj_date = obj_timestamp })
else
-- source changed: re-summarise
- new_summary location src_fn src_timestamp
+ new_summary location src_fn maybe_buf src_timestamp
| otherwise
= do found <- findModule hsc_env wanted_mod True {-explicit-}
maybe_t <- modificationTimeIfExists src_fn
case maybe_t of
Nothing -> noHsFileErr cur_mod src_fn
- Just t -> new_summary location' src_fn t
+ Just t -> new_summary location' src_fn Nothing t
- new_summary location src_fn src_timestamp
+ new_summary location src_fn maybe_bug src_timestamp
= do
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
- (dflags', hspp_fn) <- preprocess dflags src_fn
- buf <- hGetStringBuffer hspp_fn
+ (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn maybe_buf
(srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn
when (mod_name /= wanted_mod) $
= if is_boot then return Nothing
else modificationTimeIfExists (ml_obj_file location)
+
+preprocessFile :: DynFlags -> FilePath -> Maybe (StringBuffer,ClockTime)
+ -> IO (DynFlags, FilePath, StringBuffer)
+preprocessFile dflags src_fn Nothing
+ = do
+ (dflags', hspp_fn) <- preprocess dflags src_fn
+ buf <- hGetStringBuffer hspp_fn
+ return (dflags', hspp_fn, buf)
+
+preprocessFile dflags src_fn (Just (buf, time))
+ = do
+ -- case we bypass the preprocessing stage?
+ let
+ local_opts = getOptionsFromStringBuffer buf
+ --
+ (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
+
+ let
+ needs_preprocessing
+ | Unlit _ <- startPhase src_fn = True
+ -- note: local_opts is only required if there's no Unlit phase
+ | dopt Opt_Cpp dflags' = True
+ | dopt Opt_Pp dflags' = True
+ | otherwise = False
+
+ when needs_preprocessing $
+ ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
+
+ return (dflags', src_fn, buf)
+
+
-----------------------------------------------------------------------------
-- Error messages
-----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
-- inspecting the session
--- | Get the module dependency graph. After a 'load', this will contain
--- only the modules that were successfully loaded.
+-- | Get the module dependency graph.
getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph s = withSession s (return . hsc_mod_graph)
+isLoaded :: Session -> Module -> IO Bool
+isLoaded s m = withSession s $ \hsc_env ->
+ return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m)
+
getBindings :: Session -> IO [TyThing]
getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
getPrintUnqual :: Session -> IO PrintUnqualified
getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
+-- | Container for information about a 'Module'.
+data ModuleInfo = ModuleInfo {
+ minf_type_env :: TypeEnv,
+ minf_exports :: NameSet,
+ 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 -> do
+#ifdef GHCI
+ mb_names <- getModuleExports hsc_env mdl
+ case mb_names of
+ Nothing -> return Nothing
+ Just names -> do
+ eps <- readIORef (hsc_EPS hsc_env)
+ let pte = eps_PTE eps
+ tys = [ ty | name <- nameSetToList names,
+ Just ty <- [lookupTypeEnv pte name] ]
+ return (Just (ModuleInfo {
+ minf_type_env = mkTypeEnv tys,
+ minf_exports = names,
+ minf_rdr_env = Nothing
+ }))
+#else
+ -- bogusly different for non-GHCI (ToDo)
+ return Nothing
+#endif
+ Just hmi ->
+ let details = hm_details hmi in
+ return (Just (ModuleInfo {
+ minf_type_env = md_types details,
+ minf_exports = md_exports details,
+ 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 (minf_type_env minf)
+
+modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
+modInfoTopLevelScope minf
+ = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
+
+modInfoExports :: ModuleInfo -> [Name]
+modInfoExports minf = nameSetToList $! minf_exports 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 }
+
+-- | Looks up a global name: that is, any top-level name in any
+-- visible module. Unlike 'lookupName', lookupGlobalName does not use
+-- the interactive context, and therefore does not require a preceding
+-- 'setContext'.
+lookupGlobalName :: Session -> Name -> IO (Maybe TyThing)
+lookupGlobalName s name = withSession s $ \hsc_env -> do
+ eps <- readIORef (hsc_EPS hsc_env)
+ return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name
+
#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]
-
-- ToDo: typechecks abstract syntax or renamed abstract syntax. Issues:
-- - typechecked syntax includes extra dictionary translation and
-- AbsBinds which need to be translated back into something closer to
-- the original source.
--- - renamed syntax currently doesn't exist in a single blob, since
--- renaming and typechecking are interleaved at splice points. We'd
--- need a restriction that there are no splices in the source module.
-- ToDo:
-- - Data and Typeable instances for HsSyn.
-- :browse will use either lm_toplev or inspect lm_interface, depending
-- on whether the module is interpreted or not.
--- various abstract syntax types (perhaps IfaceBlah)
-data Type = ...
-data Kind = ...
-
-- This is for reconstructing refactored source code
-- Calls the lexer repeatedly.
-- ToDo: add comment tokens to token stream
_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))))
+
+-- | 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
+
+-- | 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
+
-- -----------------------------------------------------------------------------
-- 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