Session,
defaultErrorHandler,
defaultCleanupHandler,
- init,
+ init, initFromArgs,
newSession,
-- * Flags and settings
- DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
+ DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
parseDynamicFlags,
initPackages,
getSessionDynFlags,
setSessionDynFlags,
- setMsgHandler,
-- * Targets
Target(..), TargetId(..), Phase,
-- * Loading\/compiling the program
depanal,
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
- loadMsgs,
workingDirectoryChanged,
checkModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
-- * Inspecting the module structure of the program
- ModuleGraph, ModSummary(..),
+ ModuleGraph, ModSummary(..), ModLocation(..),
getModuleGraph,
isLoaded,
topSortModuleGraph,
#ifdef GHCI
setContext, getContext,
getNamesInScope,
+ getRdrNamesInScope,
moduleIsInterpreted,
getInfo,
exprType,
Name,
nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc,
NamedThing(..),
+ RdrName(Qual,Unqual),
-- ** Identifiers
Id, idType,
isImplicitId, isDeadBinder,
- isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
+ isExportedId, isLocalId, isGlobalId,
isRecordSelector,
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
-- ** Type constructors
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
- isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
- getSynTyConDefn,
+ isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
+ synTyConDefn, synTyConRhs,
-- ** Type variables
TyVar,
-- ** Instances
Instance,
- instanceDFunId, pprInstance,
+ instanceDFunId, pprInstance, pprInstanceHdr,
-- ** Types and Kinds
Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
import GHC.Exts ( unsafeCoerce# )
#endif
-import Packages ( PackageIdH(..), initPackages )
+import Packages ( initPackages )
import NameSet ( NameSet, nameSetToList, elemNameSet )
-import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName,
+import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
globalRdrEnvElts )
import HsSyn
import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
pprThetaArrow, pprParendType, splitForAllTys,
funResultTy )
import Id ( Id, idType, isImplicitId, isDeadBinder,
- isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
+ isExportedId, isLocalId, isGlobalId,
isRecordSelector, recordSelectorFieldLabel,
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
import Var ( TyVar )
import TysPrim ( alphaTyVars )
import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
- isPrimTyCon, tyConArity,
- tyConTyVars, tyConDataCons, getSynTyConDefn )
+ isPrimTyCon, isFunTyCon, tyConArity,
+ tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
import Class ( Class, classSCTheta, classTvsFds, classMethods )
import FunDeps ( pprFundeps )
import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
dataConFieldLabels, dataConStrictMarks,
dataConIsInfix, isVanillaDataCon )
import Name ( Name, nameModule, NamedThing(..), nameParent_maybe,
- nameSrcLoc )
+ nameSrcLoc, nameOccName )
import OccName ( parenSymOcc )
import NameEnv ( nameEnvElts )
-import InstEnv ( Instance, instanceDFunId, pprInstance )
+import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
import SrcLoc
import DriverPipeline
import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase )
-import GetImports ( getImports )
+import HeaderInfo ( getImports, getOptions )
import Packages ( isHomePackage )
import Finder
-import HscMain ( newHscEnv, hscFileCheck, HscResult(..) )
+import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
import HscTypes
import DynFlags
-import StaticFlags
import SysTools ( initSysTools, cleanTempFiles )
import Module
import FiniteMap
import Panic
import Digraph
-import Bag ( unitBag, emptyBag )
-import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg,
- mkPlainErrMsg, pprBagOfErrors )
+import Bag ( unitBag )
+import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
+ mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
import SysTools ( cleanTempFilesExcept )
import BasicTypes
import TcType ( tcSplitSigmaTy, isDictTy )
-import FastString ( mkFastString )
-
-import Directory ( getModificationTime, doesFileExist )
-import Maybe ( isJust, isNothing, fromJust )
-import Maybes ( orElse, expectJust, mapCatMaybes )
-import qualified Maybes (MaybeErr(..))
-import List ( partition, nub )
-import qualified List
-import Monad ( unless, when )
-import System ( exitWith, ExitCode(..) )
-import Time ( ClockTime )
-import EXCEPTION as Exception hiding (handle)
-import DATA_IOREF
-import IO
+import Maybes ( expectJust, mapCatMaybes )
+
+import Control.Concurrent
+import System.Directory ( getModificationTime, doesFileExist )
+import Data.Maybe ( isJust, isNothing )
+import Data.List ( partition, nub )
+import qualified Data.List as List
+import Control.Monad ( unless, when )
+import System.Exit ( exitWith, ExitCode(..) )
+import System.Time ( ClockTime )
+import Control.Exception as Exception hiding (handle)
+import Data.IORef
+import System.IO
+import System.IO.Error ( isDoesNotExistError )
import Prelude hiding (init)
+#if __GLASGOW_HASKELL__ < 600
+import System.IO as System.IO.Error ( try )
+#else
+import System.IO.Error ( try )
+#endif
+
-- -----------------------------------------------------------------------------
-- Exception handlers
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly.
-defaultErrorHandler :: IO a -> IO a
-defaultErrorHandler inner =
+defaultErrorHandler :: DynFlags -> IO a -> IO a
+defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
handle (\exception -> do
hFlush stdout
case exception of
-- an IO exception probably isn't our fault, so don't panic
- IOException _ -> putMsg (show exception)
+ IOException _ ->
+ fatalErrorMsg dflags (text (show exception))
AsyncException StackOverflow ->
- putMsg "stack overflow: use +RTS -K<size> to increase it"
- _other -> putMsg (show (Panic (show exception)))
+ fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+ _other ->
+ fatalErrorMsg dflags (text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $
-- program errors: messages with locations attached. Sometimes it is
-- convenient to just throw these as exceptions.
- handleDyn (\dyn -> do printErrs (pprBagOfErrors (unitBag dyn))
+ handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
exitWith (ExitFailure 1)) $
-- error messages propagated as exceptions
case dyn of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do putMsg (show (dyn :: GhcException))
+ _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
exitWith (ExitFailure 1)
) $
inner
-- | Initialises GHC. This must be done /once/ only. Takes the
--- command-line arguments. All command-line arguments which aren't
--- understood by GHC will be returned.
+-- TopDir path without the '-B' prefix.
-init :: [String] -> IO [String]
-init args = do
+init :: Maybe String -> IO ()
+init mbMinusB = do
-- catch ^C
+ main_thread <- myThreadId
+ putMVar interruptTargetThread [main_thread]
installSignalHandlers
- -- Grab the -B option if there is one
- let (minusB_args, argv1) = partition (prefixMatch "-B") args
- dflags0 <- initSysTools minusB_args defaultDynFlags
+ dflags0 <- initSysTools mbMinusB defaultDynFlags
writeIORef v_initDynFlags dflags0
- -- Parse the static flags
- argv2 <- parseStaticFlags argv1
- return argv2
+-- | Initialises GHC. This must be done /once/ only. Takes the
+-- command-line arguments. All command-line arguments which aren't
+-- understood by GHC will be returned.
+
+initFromArgs :: [String] -> IO [String]
+initFromArgs args
+ = do init mbMinusB
+ return argv1
+ where -- Grab the -B option if there is one
+ (minusB_args, argv1) = partition (prefixMatch "-B") args
+ mbMinusB | null minusB_args
+ = Nothing
+ | otherwise
+ = Just (drop 2 (last minusB_args))
GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags)
-- stores the DynFlags between the call to init and subsequent
setSessionDynFlags :: Session -> DynFlags -> IO ()
setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
--- | Messages during compilation (eg. warnings and progress messages)
--- are reported using this callback. By default, these messages are
--- printed to stderr.
-setMsgHandler :: (String -> IO ()) -> IO ()
-setMsgHandler = ErrUtils.setMsgHandler
+-- | If there is no -o option, guess the name of target executable
+-- by using top-level source file name as a base.
+guessOutputFile :: Session -> IO ()
+guessOutputFile s = modifySession s $ \env ->
+ let dflags = hsc_dflags env
+ mod_graph = hsc_mod_graph env
+ mainModuleSrcPath, guessedName :: Maybe String
+ mainModuleSrcPath = do
+ let isMain = (== mainModIs dflags) . ms_mod
+ [ms] <- return (filter isMain mod_graph)
+ ml_hs_file (ms_location ms)
+ guessedName = fmap basenameOf mainModuleSrcPath
+ in
+ case outputFile dflags of
+ Just _ -> env
+ Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } }
-- -----------------------------------------------------------------------------
-- Targets
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
-depanal :: Session -> [Module] -> IO (Either Messages ModuleGraph)
-depanal (Session ref) excluded_mods = do
+depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph)
+depanal (Session ref) excluded_mods allow_dup_roots = do
hsc_env <- readIORef ref
let
dflags = hsc_dflags hsc_env
showPass dflags "Chasing dependencies"
when (gmode == BatchCompile) $
- debugTraceMsg dflags 1 (showSDoc (hcat [
+ debugTraceMsg dflags 1 (hcat [
text "Chasing modules from: ",
- hcat (punctuate comma (map pprTarget targets))]))
+ hcat (punctuate comma (map pprTarget targets))])
- r <- downsweep hsc_env old_graph excluded_mods
+ r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
case r of
- Right mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
+ Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
_ -> return ()
return r
-- attempt to load up to this target. If no Module is supplied,
-- then try to load all targets.
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
+load s@(Session ref) how_much
= do
-- 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.
- mb_graph <- depanal s []
- case mb_graph of
- Left msgs -> do msg_act msgs; return Failed
- Right mod_graph -> loadMsgs2 s how_much msg_act mod_graph
+ mb_graph <- depanal s [] False
+ case mb_graph of
+ Just mod_graph -> load2 s how_much mod_graph
+ Nothing -> return Failed
-loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
+load2 s@(Session ref) how_much mod_graph = do
+ guessOutputFile s
hsc_env <- readIORef ref
let hpt1 = hsc_HPT hsc_env
evaluate pruned_hpt
- debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
- text "Stable BCO:" <+> ppr stable_bco))
+ debugTraceMsg dflags 2 (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.
let stable_linkables = [ linkable
(upsweep_ok, hsc_env1, modsUpswept)
<- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
- pruned_hpt stable_mods cleanup msg_act mg
+ pruned_hpt stable_mods cleanup 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 debugTraceMsg dflags 2 "Upsweep completely successful."
+ do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
--
let ofile = outputFile dflags
let no_hs_main = dopt Opt_NoHsMain dflags
- let mb_main_mod = mainModIs dflags
let
- main_mod = mb_main_mod `orElse` "Main"
- a_root_is_Main
- = any ((==main_mod).moduleUserString.ms_mod)
- mod_graph
+ main_mod = mainModIs dflags
+ a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
do_linking = a_root_is_Main || no_hs_main
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.")
+ debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
+ "but no output will be generated\n" ++
+ "because there is no " ++ moduleString main_mod ++ " module."))
-- link everything together
linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
-- 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 debugTraceMsg dflags 2 "Upsweep partially successful."
+ do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
let modsDone_names
= map ms_mod modsDone
-- used to fish out the preprocess output files for the purposes of
-- cleaning up. The preprocessed file *might* be the same as the
-- source file, but that doesn't do any harm.
-ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ]
+ppFilesFromSummaries summaries = map ms_hspp_file summaries
-- -----------------------------------------------------------------------------
-- Check module
-- fields within CheckedModule.
type ParsedSource = Located (HsModule RdrName)
-type RenamedSource = HsGroup Name
+type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name])
type TypecheckedSource = LHsBinds Id
-- NOTE:
--- - things that aren't in the output of the renamer:
--- - the export list
--- - the imports
-- - things that aren't in the output of the typechecker right now:
-- - the export list
-- - the imports
-- 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
+checkModule :: Session -> Module -> IO (Maybe CheckedModule)
+checkModule session@(Session ref) mod = do
-- load up the dependencies first
- r <- loadMsgs session (LoadDependenciesOf mod) msg_act
+ r <- load session (LoadDependenciesOf mod)
if (failed r) then return Nothing else do
-- now parse & typecheck the module
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 ->
+ mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms
+ case mbChecked of
+ Nothing -> return Nothing
+ Just (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
+ Just (HscChecked parsed renamed
+ (Just (tc_binds, rdr_env, details))) -> do
let minf = ModuleInfo {
minf_type_env = md_types details,
minf_exports = md_exports details,
renamedSource = renamed,
typecheckedSource = Just tc_binds,
checkedModuleInfo = Just minf }))
- _other ->
- panic "checkModule"
-- ---------------------------------------------------------------------------
-- Unloading
-> 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 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 mods
+ = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
[] _ _
= return (Succeeded, hsc_env, [])
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
(CyclicSCC ms:_) _ _
- = do putMsg (showSDoc (cyclicModuleErr ms))
+ = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
return (Failed, hsc_env, [])
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
(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 msg_act mod
+ mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
mod_index nmods
cleanup -- Remove unwanted tmp files between compilations
; (restOK, hsc_env2, modOKs)
<- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
- msg_act mods (mod_index+1) nmods
+ 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) msg_act summary mod_index nmods
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
= do
let
this_mod = ms_mod summary
compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
compile_it = upsweep_compile hsc_env old_hpt this_mod
- msg_act summary mod_index nmods
+ 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 msg_act summary
+upsweep_compile hsc_env old_hpt this_mod summary
mod_index nmods
mb_old_linkable = do
let
where
iface = hm_iface hm_info
- compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface
+ compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
mod_index nmods
case compresult of
downsweep :: HscEnv
-> [ModSummary] -- Old summaries
- -> [Module] -- Ignore dependencies on these; treat them as
- -- if they were package modules
- -> IO (Either Messages [ModSummary])
-downsweep hsc_env old_summaries excl_mods
+ -> [Module] -- Ignore dependencies on these; treat
+ -- them as if they were package modules
+ -> Bool -- True <=> allow multiple targets to have
+ -- the same module name; this is
+ -- very useful for ghc -M
+ -> IO (Maybe [ModSummary])
+ -- The elts of [ModSummary] all have distinct
+ -- (Modules, IsBoot) identifiers, unless the Bool is true
+ -- in which case there can be repeats
+downsweep hsc_env old_summaries excl_mods allow_dup_roots
= -- catch error messages and return them
- handleDyn (\err_msg -> return (Left (emptyBag, unitBag err_msg))) $ do
+ handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
rootSummaries <- mapM getRootSummary roots
- checkDuplicates rootSummaries
- summs <- loop (concatMap msDeps rootSummaries) (mkNodeMap rootSummaries)
- return (Right summs)
+ let root_map = mkRootMap rootSummaries
+ checkDuplicates root_map
+ summs <- loop (concatMap msDeps rootSummaries) root_map
+ return (Just summs)
where
roots = hsc_targets hsc_env
-- name, so we have to check that there aren't multiple root files
-- defining the same module (otherwise the duplicates will be silently
-- ignored, leading to confusing behaviour).
- checkDuplicates :: [ModSummary] -> IO ()
- checkDuplicates summaries = mapM_ check summaries
- where check summ =
- case dups of
- [] -> return ()
- [_one] -> return ()
- many -> multiRootsErr modl many
- where modl = ms_mod summ
- dups =
- [ expectJust "checkDup" (ml_hs_file (ms_location summ'))
- | summ' <- summaries, ms_mod summ' == modl ]
+ checkDuplicates :: NodeMap [ModSummary] -> IO ()
+ checkDuplicates root_map
+ | allow_dup_roots = return ()
+ | null dup_roots = return ()
+ | otherwise = multiRootsErr (head dup_roots)
+ where
+ dup_roots :: [[ModSummary]] -- Each at least of length 2
+ dup_roots = filterOut isSingleton (nodeMapElts root_map)
loop :: [(Located Module,IsBootInterface)]
-- Work list: process these modules
- -> NodeMap ModSummary
- -- Visited set
+ -> NodeMap [ModSummary]
+ -- Visited set; the range is a list because
+ -- the roots can have the same module names
+ -- if allow_dup_roots is True
-> IO [ModSummary]
-- The result includes the worklist, except
-- for those mentioned in the visited set
- loop [] done = return (nodeMapElts done)
+ loop [] done = return (concat (nodeMapElts done))
loop ((wanted_mod, is_boot) : ss) done
- | key `elemFM` done = loop ss done
+ | Just summs <- lookupFM done key
+ = if isSingleton summs then
+ loop ss done
+ else
+ do { multiRootsErr summs; return [] }
| otherwise = do { mb_s <- summariseModule hsc_env old_summary_map
is_boot wanted_mod Nothing excl_mods
; case mb_s of
Nothing -> loop ss done
Just s -> loop (msDeps s ++ ss)
- (addToFM done key s) }
+ (addToFM done key [s]) }
where
key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
+mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
+mkRootMap summaries = addListToFM_C (++) emptyFM
+ [ (msKey s, [s]) | s <- summaries ]
+
msDeps :: ModSummary -> [(Located Module, IsBootInterface)]
-- (msDeps s) returns the dependencies of the ModSummary s.
-- A wrinkle is that for a {-# SOURCE #-} import we return
return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
ms_location = location,
- ms_hspp_file = Just hspp_fn,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
ms_srcimps = srcimps, ms_imps = the_imps,
ms_hs_date = src_timestamp,
findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
findSummaryBySourceFile summaries file
= case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
- fromJust (ml_hs_file (ms_location ms)) == file ] of
+ expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
[] -> Nothing
(x:xs) -> Just x
case maybe_buf of
Just (_,t) -> check_timestamp old_summary location src_fn t
Nothing -> do
- m <- IO.try (getModificationTime src_fn)
+ m <- System.IO.Error.try (getModificationTime src_fn)
case m of
Right t -> check_timestamp old_summary location src_fn t
Left e | isDoesNotExistError e -> find_it
return (Just ( ModSummary { ms_mod = wanted_mod,
ms_hsc_src = hsc_src,
ms_location = location,
- ms_hspp_file = Just hspp_fn,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
ms_hspp_buf = Just buf,
ms_srcimps = srcimps,
ms_imps = the_imps,
= do
-- case we bypass the preprocessing stage?
let
- local_opts = getOptionsFromStringBuffer buf
+ local_opts = getOptions buf src_fn
--
- (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
+ (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts)
let
needs_preprocessing
= throwDyn $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "is a package module"
-multiRootsErr mod files
+multiRootsErr :: [ModSummary] -> IO ()
+multiRootsErr summs@(summ1:_)
= throwDyn $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files)
+ where
+ mod = ms_mod summ1
+ files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
cyclicModuleErr :: [ModSummary] -> SDoc
cyclicModuleErr ms
getNamesInScope s = withSession s $ \hsc_env -> do
return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
+getRdrNamesInScope :: Session -> IO [RdrName]
+getRdrNamesInScope s = withSession s $ \hsc_env -> do
+ let env = ic_rn_gbl_env (hsc_IC hsc_env)
+ return (concat (map greToRdrNames (globalRdrEnvElts env)))
+
+-- ToDo: move to RdrName
+greToRdrNames :: GlobalRdrElt -> [RdrName]
+greToRdrNames GRE{ gre_name = name, gre_prov = prov }
+ = case prov of
+ LocalDef -> [unqual]
+ Imported specs -> concat (map do_spec (map is_decl specs))
+ where
+ occ = nameOccName name
+ unqual = Unqual occ
+ do_spec decl_spec
+ | is_qual decl_spec = [qual]
+ | otherwise = [unqual,qual]
+ where qual = Qual (is_as decl_spec) occ
+
-- | 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]
writeIORef ref new_hsc_env
return (RunOk names)
-
--- We run the statement in a "sandbox" to protect the rest of the
--- system from anything the expression might do. For now, this
--- consists of just wrapping it in an exception handler, but see below
--- for another version.
-
+-- When running a computation, we redirect ^C exceptions to the running
+-- thread. ToDo: we might want a way to continue even if the target
+-- thread doesn't die when it receives the exception... "this thread
+-- is not responding".
sandboxIO :: IO a -> IO (Either Exception a)
-sandboxIO thing = Exception.try thing
+sandboxIO thing = do
+ m <- newEmptyMVar
+ ts <- takeMVar interruptTargetThread
+ child <- forkIO (do res <- Exception.try thing; putMVar m res)
+ putMVar interruptTargetThread (child:ts)
+ takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail)
{-
-- This version of sandboxIO runs the expression in a completely new
Nothing -> panic "missing linkable"
Just mod_info -> return (showModMsg obj_linkable mod_summary)
where
- obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info))
+ obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
#endif /* GHCI */
projects / ghc-hetmet.git / blobdiff