X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FGHC.hs;h=3f91af6cc465362ab0fb124e2664f941cd74a1ab;hb=d7d596d039b48dec6b71df9c4bca0d12958ecdb9;hp=d8c2975f7fb774dd73aa615515df7828712b17ff;hpb=a7ecdf96844404b7bc8273d4ff6d85759278427c;p=ghc-hetmet.git diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index d8c2975..3f91af6 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -11,16 +11,15 @@ module GHC ( 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, @@ -33,13 +32,12 @@ module GHC ( -- * 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, @@ -64,6 +62,7 @@ module GHC ( #ifdef GHCI setContext, getContext, getNamesInScope, + getRdrNamesInScope, moduleIsInterpreted, getInfo, exprType, @@ -85,6 +84,7 @@ module GHC ( Name, nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc, NamedThing(..), + RdrName(Qual,Unqual), -- ** Identifiers Id, idType, @@ -99,8 +99,8 @@ module GHC ( -- ** Type constructors TyCon, tyConTyVars, tyConDataCons, tyConArity, - isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - getSynTyConDefn, + isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, + synTyConDefn, synTyConRhs, -- ** Type variables TyVar, @@ -120,7 +120,7 @@ module GHC ( -- ** Instances Instance, - instanceDFunId, pprInstance, + instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds Type, dropForAlls, splitForAllTys, funResultTy, pprParendType, @@ -178,7 +178,7 @@ import GHC.Exts ( unsafeCoerce# ) 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, @@ -193,36 +193,35 @@ import Id ( Id, idType, isImplicitId, isDeadBinder, 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 ) @@ -230,21 +229,28 @@ import Outputable 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 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 @@ -252,23 +258,25 @@ import Prelude hiding (init) -- 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 to increase it" - _other -> putMsg (show (Panic (show exception))) + fatalErrorMsg dflags (text "stack overflow: use +RTS -K 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 @@ -277,7 +285,7 @@ defaultErrorHandler inner = 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 @@ -298,22 +306,32 @@ defaultCleanupHandler dflags 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 @@ -353,11 +371,22 @@ getSessionDynFlags s = withSession s (return . hsc_dflags) 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 @@ -422,8 +451,8 @@ guessTarget file Nothing -- 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 @@ -433,13 +462,13 @@ depanal (Session ref) excluded_mods = do 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 @@ -468,24 +497,19 @@ data LoadHowMuch -- 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 @@ -524,8 +548,8 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do 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 @@ -587,7 +611,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do (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. @@ -602,7 +626,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do 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) @@ -615,18 +639,15 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do -- 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) @@ -637,7 +658,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do -- 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 @@ -689,7 +710,7 @@ discardProg hsc_env -- 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 @@ -707,13 +728,10 @@ data CheckedModule = -- 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 @@ -730,11 +748,10 @@ type TypecheckedSource = LHsBinds Id -- 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 @@ -743,32 +760,17 @@ checkModule session@(Session ref) mod msg_act = do 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, @@ -780,8 +782,6 @@ checkModule session@(Session ref) mod msg_act = do renamedSource = renamed, typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf })) - _other -> - panic "checkModule" -- --------------------------------------------------------------------------- -- Unloading @@ -981,31 +981,30 @@ 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 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 @@ -1031,7 +1030,7 @@ upsweep' hsc_env old_hpt stable_mods cleanup msg_act ; (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) } @@ -1041,13 +1040,12 @@ upsweep' hsc_env old_hpt stable_mods cleanup msg_act 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 @@ -1057,7 +1055,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index n 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 -> @@ -1110,7 +1108,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index n 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 @@ -1132,7 +1130,7 @@ upsweep_compile hsc_env old_hpt this_mod msg_act summary 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 @@ -1254,16 +1252,23 @@ nodeMapElts = eltsFM 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 @@ -1290,37 +1295,44 @@ downsweep hsc_env old_summaries excl_mods -- 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 @@ -1406,7 +1418,8 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf 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, @@ -1415,7 +1428,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf 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 @@ -1445,7 +1458,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc 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 @@ -1516,7 +1529,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc 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, @@ -1541,9 +1555,9 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time)) = 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 @@ -1576,11 +1590,15 @@ packageModErr mod = 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 @@ -1859,6 +1877,25 @@ getNamesInScope :: Session -> IO [Name] 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] @@ -1963,14 +2000,17 @@ runStmt (Session ref) expr 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 @@ -2006,8 +2046,8 @@ showModule :: Session -> ModSummary -> IO String showModule s mod_summary = withSession s $ \hsc_env -> do case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of Nothing -> panic "missing linkable" - Just mod_info -> return (showModMsg obj_linkable mod_summary) + Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary) where - obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info)) + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) #endif /* GHCI */