X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FGHC.hs;h=29e2c66a357895d28b19384d65bffb424988def6;hb=0f800dc9f3dc695cd06d0fdd7799a52c37241752;hp=67dd723908cd6e3fb6bf127318b1d9663f18c563;hpb=0ac48591aba492239104c2d510f5b57bfc4d3530;p=ghc-hetmet.git diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 67dd723..29e2c66 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -11,19 +11,18 @@ 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(..), + Target(..), TargetId(..), Phase, setTargets, getTargets, addTarget, @@ -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, @@ -51,21 +49,27 @@ module GHC ( modInfoTopLevelScope, modInfoPrintUnqualified, modInfoExports, + modInfoInstances, + modInfoIsExportedName, + modInfoLookupName, lookupGlobalName, + -- * Printing + PrintUnqualified, alwaysQualify, + -- * Interactive evaluation getBindings, getPrintUnqual, #ifdef GHCI setContext, getContext, getNamesInScope, + getRdrNamesInScope, moduleIsInterpreted, - getInfo, GetInfoResult, + getInfo, exprType, typeKind, parseName, RunResult(..), runStmt, - browseModule, showModule, compileExpr, HValue, lookupName, @@ -77,31 +81,52 @@ module GHC ( Module, mkModule, pprModule, -- ** Names - Name, + 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, + isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, isBottomingId, isDictonaryId, + recordSelectorFieldLabel, -- ** Type constructors TyCon, - isClassTyCon, isSynTyCon, isNewTyCon, + tyConTyVars, tyConDataCons, tyConArity, + isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, + synTyConDefn, synTyConRhs, + + -- ** Type variables + TyVar, + alphaTyVars, -- ** Data constructors DataCon, + dataConSig, dataConType, dataConTyCon, dataConFieldLabels, + dataConIsInfix, isVanillaDataCon, + dataConStrictMarks, + StrictnessMark(..), isMarkedStrict, -- ** Classes Class, - classSCTheta, classTvsFds, + classMethods, classSCTheta, classTvsFds, + pprFundeps, + + -- ** Instances + Instance, + instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, + Type, dropForAlls, splitForAllTys, funResultTy, pprParendType, Kind, + PredType, + ThetaType, pprThetaArrow, -- ** Entities TyThing(..), @@ -109,6 +134,15 @@ module GHC ( -- ** Syntax module HsSyn, -- ToDo: remove extraneous bits + -- ** Fixities + FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, + compareFixity, + + -- ** Source locations + SrcLoc, pprDefnLoc, + -- * Exceptions GhcException(..), showGhcException, @@ -120,8 +154,7 @@ module GHC ( {- ToDo: - * inline bits of HscMain here to simplify layering: hscGetInfo, - hscTcExpr, hscStmt. + * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. * we need to expose DynFlags, so should parseDynamicFlags really be part of this interface? * what StaticFlags should we expose, if any? @@ -132,40 +165,47 @@ module GHC ( #ifdef GHCI import qualified Linker import Linker ( HValue, extendLinkEnv ) -import NameEnv ( lookupNameEnv ) -import TcRnDriver ( getModuleContents, tcRnLookupRdrName, - getModuleExports ) -import RdrName ( plusGlobalRdrEnv, Provenance(..), ImportSpec(..), +import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, + tcRnLookupName, getModuleExports ) +import RdrName ( plusGlobalRdrEnv, Provenance(..), + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), emptyGlobalRdrEnv, mkGlobalRdrEnv ) -import HscMain ( hscGetInfo, GetInfoResult, hscParseIdentifier, - hscStmt, hscTcExpr, hscKcType ) +import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce# ) -import IfaceSyn ( IfaceDecl ) -import Name ( getName, nameModule_maybe ) -import SrcLoc ( mkSrcLoc, srcLocSpan, interactiveSrcLoc ) -import Bag ( unitBag, emptyBag ) #endif import Packages ( initPackages ) -import NameSet ( NameSet, nameSetToList ) -import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName, gre_name, +import NameSet ( NameSet, nameSetToList, elemNameSet ) +import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), globalRdrEnvElts ) import HsSyn -import Type ( Kind, Type, dropForAlls ) +import Type ( Kind, Type, dropForAlls, PredType, ThetaType, + pprThetaArrow, pprParendType, splitForAllTys, + funResultTy ) import Id ( Id, idType, isImplicitId, isDeadBinder, - isSpecPragmaId, isExportedId, isLocalId, isGlobalId, - isRecordSelector, - isPrimOpId, isFCallId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, recordSelectorFieldLabel, + isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, isBottomingId ) -import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon ) -import Class ( Class, classSCTheta, classTvsFds ) -import DataCon ( DataCon ) -import Name ( Name ) +import Var ( TyVar ) +import TysPrim ( alphaTyVars ) +import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, + 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, nameOccName ) +import OccName ( parenSymOcc ) import NameEnv ( nameEnvElts ) -import SrcLoc ( Located(..) ) +import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) +import SrcLoc import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import GetImports ( getImports ) @@ -180,30 +220,39 @@ import Module import FiniteMap import Panic import Digraph -import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg ) +import Bag ( unitBag ) +import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, + mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings ) import qualified ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) import Outputable import SysTools ( cleanTempFilesExcept ) -import BasicTypes ( SuccessFlag(..), succeeded, failed ) -import Maybes ( orElse, expectJust, mapCatMaybes ) +import BasicTypes import TcType ( tcSplitSigmaTy, isDictTy ) -import FastString ( mkFastString ) - -import Directory ( getModificationTime, doesFileExist ) -import Maybe ( isJust, isNothing, fromJust, fromMaybe, catMaybes ) -import Maybes ( expectJust ) -import List ( partition, nub ) -import qualified List -import Monad ( unless, when, foldM ) -import System ( exitWith, ExitCode(..) ) -import Time ( ClockTime ) -import EXCEPTION as Exception hiding (handle) -import 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 System.IO.Unsafe ( unsafePerformIO ) 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 @@ -211,27 +260,34 @@ 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) ) $ - -- all error messages are propagated as exceptions + -- program errors: messages with locations attached. Sometimes it is + -- convenient to just throw these as exceptions. + handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn) + exitWith (ExitFailure 1)) $ + + -- error messages propagated as exceptions handleDyn (\dyn -> do hFlush stdout 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 @@ -252,22 +308,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 @@ -307,11 +373,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 @@ -351,27 +428,33 @@ removeTarget s target_id -- then use that -- - otherwise interpret the string as a module name -- -guessTarget :: String -> IO Target -guessTarget file +guessTarget :: String -> Maybe Phase -> IO Target +guessTarget file (Just phase) + = return (Target (TargetFile file (Just phase)) Nothing) +guessTarget file Nothing | isHaskellSrcFilename file - = return (Target (TargetFile file) Nothing) + = return (Target (TargetFile file Nothing) Nothing) | otherwise = do exists <- doesFileExist hs_file - if exists then return (Target (TargetFile hs_file) Nothing) else do + if exists + then return (Target (TargetFile hs_file Nothing) Nothing) + else do exists <- doesFileExist lhs_file - if exists then return (Target (TargetFile lhs_file) Nothing) else do + if exists + then return (Target (TargetFile lhs_file Nothing) Nothing) + else do return (Target (TargetModule (mkModule file)) Nothing) where - hs_file = file ++ ".hs" - lhs_file = file ++ ".lhs" + hs_file = file `joinFileExt` "hs" + lhs_file = file `joinFileExt` "lhs" -- ----------------------------------------------------------------------------- -- Loading the program -- Perform a dependency analysis starting from the current targets -- and update the session with the new module graph. -depanal :: Session -> [Module] -> IO () -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 @@ -381,12 +464,15 @@ 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))]) - graph <- downsweep hsc_env old_graph excluded_mods - writeIORef ref hsc_env{ hsc_mod_graph=graph } + r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots + case r of + Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph } + _ -> return () + return r {- -- | The result of load. @@ -413,36 +499,34 @@ 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. - depanal s [] + mb_graph <- depanal s [] False + case mb_graph of + Just mod_graph -> load2 s how_much mod_graph + Nothing -> return Failed +load2 s@(Session ref) how_much mod_graph = do + guessOutputFile s hsc_env <- readIORef ref let hpt1 = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env - let mod_graph = hsc_mod_graph hsc_env - - let ghci_mode = ghcMode (hsc_dflags hsc_env) -- this never changes - let verb = verbosity dflags + let ghci_mode = ghcMode dflags -- this never changes -- The "bad" boot modules are the ones for which we have -- B.hs-boot in the module graph, but no B.hs -- The downsweep should have ensured this does not happen -- (see msDeps) let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)] +#ifdef DEBUG bad_boot_mods = [s | s <- mod_graph, isBootSummary s, not (ms_mod s `elem` all_home_mods)] +#endif ASSERT( null bad_boot_mods ) return () -- mg2_with_srcimps drops the hi-boot nodes, returning a @@ -466,8 +550,8 @@ loadMsgs s@(Session ref) how_much msg_act 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 @@ -529,7 +613,7 @@ loadMsgs s@(Session ref) how_much msg_act (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. @@ -544,7 +628,7 @@ loadMsgs s@(Session ref) how_much msg_act 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) @@ -557,18 +641,15 @@ loadMsgs s@(Session ref) how_much msg_act -- 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) @@ -579,7 +660,7 @@ loadMsgs s@(Session ref) how_much msg_act -- 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 @@ -642,20 +723,37 @@ data CheckedModule = typecheckedSource :: Maybe TypecheckedSource, checkedModuleInfo :: Maybe ModuleInfo } + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- 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 typechecker right now: +-- - the export list +-- - the imports +-- - type signatures +-- - type/data/newtype declarations +-- - class declarations +-- - instances +-- - extra things in the typechecker's output: +-- - default methods are turned into top-level decls. +-- - dictionary bindings + + -- | 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 +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 @@ -670,15 +768,15 @@ checkModule session@(Session ref) mod msg_act = do -- ml_hspp_file field, say let dflags0 = hsc_dflags hsc_env hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) - opts = getOptionsFromStringBuffer hspp_buf + filename = expectJust "checkModule" (ml_hs_file (ms_location ms)) + opts = getOptionsFromStringBuffer hspp_buf filename (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) + then do printErrorsAndWarnings dflags1 (optionsErrorMsgs leftovers opts filename) return Nothing else do - r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms + r <- hscFileCheck hsc_env{hsc_dflags=dflags1} ms case r of HscFail -> return Nothing @@ -691,15 +789,18 @@ checkModule session@(Session ref) mod msg_act = do 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 + minf_type_env = md_types details, + minf_exports = md_exports details, + minf_rdr_env = Just rdr_env, + minf_instances = md_insts details } return (Just (CheckedModule { parsedSource = parsed, renamedSource = renamed, typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf })) + _other -> + panic "checkModule" -- --------------------------------------------------------------------------- -- Unloading @@ -806,9 +907,9 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs | otherwise = False where same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of - Nothing -> True Just hmi | Just l <- hm_linkable hmi -> isObjectLinkable l && t == linkableTime l + _other -> True -- why '>=' rather than '>' above? If the filesystem stores -- times to the nearset second, we may occasionally find that -- the object & source have the same modification time, @@ -818,13 +919,13 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs bco_ok ms = case lookupModuleEnv hpt (ms_mod ms) of - Nothing -> False Just hmi | Just l <- hm_linkable hmi -> not (isObjectLinkable l) && linkableTime l >= ms_hs_date ms + _other -> False ms_allimps :: ModSummary -> [Module] -ms_allimps ms = ms_srcimps ms ++ ms_imps ms +ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) -- ----------------------------------------------------------------------------- -- Prune the HomePackageTable @@ -899,31 +1000,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 @@ -949,7 +1049,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) } @@ -959,13 +1059,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 @@ -975,7 +1074,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 -> @@ -1028,7 +1127,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 @@ -1050,7 +1149,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 @@ -1124,8 +1223,8 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) -- We use integers as the keys for the SCC algorithm nodes :: [(ModSummary, Int, [Int])] nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)), - out_edge_keys hs_boot_key (ms_srcimps s) ++ - out_edge_keys HsSrcFile (ms_imps s) ) + out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ) | s <- summaries , not (isBootSummary s && drop_hs_boot_nodes) ] -- Drop the hi-boot ones if told to do so @@ -1149,35 +1248,12 @@ type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot) -emptyNodeMap :: NodeMap a -emptyNodeMap = emptyFM - mkNodeMap :: [ModSummary] -> NodeMap ModSummary mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] nodeMapElts = eltsFM --- ----------------------------------------------------------------- --- The unlinked image --- --- The compilation manager keeps a list of compiled, but as-yet unlinked --- binaries (byte code or object code). Even when it links bytecode --- it keeps the unlinked version so it can re-link it later without --- recompiling. - -type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) - -findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable -findModuleLinkable_maybe lis mod - = case [LM time nm us | LM time nm us <- lis, nm == mod] of - [] -> Nothing - [li] -> Just li - many -> pprPanic "findModuleLinkable" (ppr mod) - -delModuleLinkable :: [Linkable] -> Module -> [Linkable] -delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ] - ----------------------------------------------------------------------------- -- Downsweep (dependency analysis) @@ -1195,14 +1271,23 @@ delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ] downsweep :: HscEnv -> [ModSummary] -- Old summaries - -> [Module] -- Ignore dependencies on these; treat them as - -- if they were package modules - -> IO [ModSummary] -downsweep hsc_env old_summaries excl_mods - = do rootSummaries <- mapM getRootSummary roots - checkDuplicates rootSummaries - loop (concatMap msDeps rootSummaries) - (mkNodeMap rootSummaries) + -> [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 -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do + rootSummaries <- mapM getRootSummary roots + let root_map = mkRootMap rootSummaries + checkDuplicates root_map + summs <- loop (concatMap msDeps rootSummaries) root_map + return (Just summs) where roots = hsc_targets hsc_env @@ -1210,56 +1295,64 @@ downsweep hsc_env old_summaries excl_mods old_summary_map = mkNodeMap old_summaries getRootSummary :: Target -> IO ModSummary - getRootSummary (Target (TargetFile file) maybe_buf) + getRootSummary (Target (TargetFile file mb_phase) maybe_buf) = do exists <- doesFileExist file - if exists then summariseFile hsc_env file maybe_buf else do - throwDyn (CmdLineError ("can't find file: " ++ file)) + if exists + then summariseFile hsc_env old_summaries file mb_phase maybe_buf + else throwDyn $ mkPlainErrMsg noSrcSpan $ + text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) maybe_buf) - = do maybe_summary <- summarise hsc_env emptyNodeMap Nothing False - modl maybe_buf excl_mods + = do maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) maybe_buf excl_mods case maybe_summary of Nothing -> packageModErr modl Just s -> return s + rootLoc = mkGeneralSrcSpan FSLIT("") + -- In a root module, the filename is allowed to diverge from the module -- 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 ] - - loop :: [(FilePath,Module,IsBootInterface)] + 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 ((cur_path, wanted_mod, is_boot) : ss) done - | key `elemFM` done = loop ss done - | otherwise = do { mb_s <- summarise hsc_env old_summary_map - (Just cur_path) is_boot - wanted_mod Nothing excl_mods + loop [] done = return (concat (nodeMapElts done)) + loop ((wanted_mod, is_boot) : 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 = (wanted_mod, if is_boot then HsBootFile else HsSrcFile) + key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) -msDeps :: ModSummary -> [(FilePath, -- Importing module - Module, -- Imported module - IsBootInterface)] -- {-# SOURCE #-} import or not +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 -- *both* the hs-boot file @@ -1268,11 +1361,9 @@ msDeps :: ModSummary -> [(FilePath, -- Importing module -- modules always contains B.hs if it contains B.hs-boot. -- Remember, this pass isn't doing the topological sort. It's -- just gathering the list of all relevant ModSummaries -msDeps s = concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s] - ++ [(f,m,False) | m <- ms_imps s] - where - f = msHsFilePath s -- Keep the importing module for error reporting - +msDeps s = + concat [ [(m,True), (m,False)] | m <- ms_srcimps s ] + ++ [ (m,False) | m <- ms_imps s ] ----------------------------------------------------------------------------- -- Summarising modules @@ -1287,19 +1378,48 @@ msDeps s = concat [ [(f, m, True), (f,m,False)] | m <- ms_srcimps s] -- a summary. The finder is used to locate the file in which the module -- resides. -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 maybe_buf - = do let dflags = hsc_dflags hsc_env +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Maybe (StringBuffer,ClockTime) + -> IO ModSummary + +summariseFile hsc_env old_summaries file mb_phase maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries file + = do + let location = ms_location old_summary + + -- return the cached summary if the source didn't change + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> getModificationTime file + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationTime may fail, but that's the right + -- behaviour. + + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- getObjTimestamp location False + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary + + | otherwise + = new_summary + where + new_summary = do + let dflags = hsc_dflags hsc_env (dflags', hspp_fn, buf) - <- preprocessFile dflags file maybe_buf + <- preprocessFile dflags file mb_phase maybe_buf - (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn + (srcimps,the_imps, L _ mod) <- getImports dflags' buf hspp_fn -- Make a ModLocation for this file location <- mkHomeModLocation dflags mod file @@ -1311,6 +1431,7 @@ summariseFile hsc_env file maybe_buf src_timestamp <- case maybe_buf of Just (_,t) -> return t Nothing -> getModificationTime file + -- getMofificationTime may fail obj_timestamp <- modificationTimeIfExists (ml_obj_file location) @@ -1322,17 +1443,24 @@ summariseFile hsc_env file maybe_buf ms_hs_date = src_timestamp, ms_obj_date = obj_timestamp }) +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:xs) -> Just x + -- Summarise a module, and pick up source and timestamp. -summarise :: HscEnv +summariseModule + :: HscEnv -> NodeMap ModSummary -- Map of old summaries - -> Maybe FilePath -- Importing module (for error messages) -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Module -- Imported module to be summarised + -> Located 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 maybe_buf excl_mods +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods | wanted_mod `elem` excl_mods = return Nothing @@ -1340,35 +1468,51 @@ summarise hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files let location = ms_location old_summary - src_fn = expectJust "summarise" (ml_hs_file location) - - -- return the cached summary if the source didn't change - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> getModificationTime src_fn + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + 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 + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env - 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 maybe_buf src_timestamp + hsc_src = if is_boot then HsBootFile else HsSrcFile - | otherwise - = do found <- findModule hsc_env wanted_mod True {-explicit-} + check_timestamp old_summary location src_fn src_timestamp + | ms_hs_date old_summary == src_timestamp = do + -- update the object-file timestamp + obj_timestamp <- getObjTimestamp location is_boot + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: find and re-summarise. We call the finder + -- again, because the user may have moved the source file. + new_summary location src_fn src_timestamp + + find_it = do + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findModule hsc_env wanted_mod True {-explicit-} case found of Found location pkg | not (isHomePackage pkg) -> return Nothing -- Drop external-pkg | isJust (ml_hs_file location) -> just_found location -- Home package - err -> noModError dflags cur_mod wanted_mod err + err -> noModError dflags loc wanted_mod err -- Not found - where - dflags = hsc_dflags hsc_env - - hsc_src = if is_boot then HsBootFile else HsSrcFile just_found location = do -- Adjust location to point to the hs-boot source file, @@ -1381,22 +1525,21 @@ summarise hsc_env old_summary_map cur_mod is_boot wanted_mod maybe_buf excl_mods -- It might have been deleted since the Finder last found it maybe_t <- modificationTimeIfExists src_fn case maybe_t of - Nothing -> noHsFileErr cur_mod src_fn - Just t -> new_summary location' src_fn Nothing t + Nothing -> noHsFileErr loc src_fn + Just t -> new_summary location' src_fn t - new_summary location src_fn maybe_bug src_timestamp + new_summary location src_fn src_timestamp = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn maybe_buf - (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn + (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn when (mod_name /= wanted_mod) $ - throwDyn (ProgramError - (showSDoc (text src_fn - <> text ": file name does not match module name" - <+> quotes (ppr mod_name)))) + throwDyn $ mkPlainErrMsg mod_loc $ + text "file name does not match module name" + <+> quotes (ppr mod_name) -- Find the object timestamp, and return the summary obj_timestamp <- getObjTimestamp location is_boot @@ -1417,25 +1560,26 @@ getObjTimestamp location is_boot else modificationTimeIfExists (ml_obj_file location) -preprocessFile :: DynFlags -> FilePath -> Maybe (StringBuffer,ClockTime) +preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime) -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile dflags src_fn Nothing +preprocessFile dflags src_fn mb_phase Nothing = do - (dflags', hspp_fn) <- preprocess dflags src_fn + (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase) buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) -preprocessFile dflags src_fn (Just (buf, time)) +preprocessFile dflags src_fn mb_phase (Just (buf, time)) = do -- case we bypass the preprocessing stage? let - local_opts = getOptionsFromStringBuffer buf + local_opts = getOptionsFromStringBuffer buf src_fn -- (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts) let needs_preprocessing - | Unlit _ <- startPhase src_fn = True + | Just (Unlit _) <- mb_phase = True + | Nothing <- mb_phase, 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 @@ -1451,31 +1595,27 @@ preprocessFile dflags src_fn (Just (buf, time)) -- Error messages ----------------------------------------------------------------------------- -noModError :: DynFlags -> Maybe FilePath -> Module -> FindResult -> IO ab +noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error -noModError dflags cur_mod wanted_mod err - = throwDyn $ ProgramError $ showSDoc $ - vcat [cantFindError dflags wanted_mod err, - nest 2 (parens (pp_where cur_mod))] +noModError dflags loc wanted_mod err + = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err -noHsFileErr cur_mod path - = throwDyn $ CmdLineError $ showSDoc $ - vcat [text "Can't find" <+> text path, - nest 2 (parens (pp_where cur_mod))] +noHsFileErr loc path + = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path -pp_where Nothing = text "one of the roots of the dependency analysis" -pp_where (Just p) = text "imported from" <+> text p - packageModErr mod - = throwDyn (CmdLineError (showSDoc (text "module" <+> - quotes (ppr mod) <+> - text "is a package module"))) + = throwDyn $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" -multiRootsErr mod files - = throwDyn (ProgramError (showSDoc ( +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr summs@(summ1:_) + = throwDyn $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> - sep (map text 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 @@ -1517,50 +1657,66 @@ 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 - } + minf_type_env :: TypeEnv, + minf_exports :: NameSet, + minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_instances :: [Instance] -- 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 + let mg = hsc_mod_graph hsc_env + if mdl `elem` map ms_mod mg + then getHomeModuleInfo hsc_env mdl + else do + {- if isHomeModule (hsc_dflags hsc_env) mdl + then return Nothing + else -} getPackageModuleInfo hsc_env mdl + -- getPackageModuleInfo will attempt to find the interface, so + -- we don't want to call it for a home module, just in case there + -- was a problem loading the module and the interface doesn't + -- exist... hence the isHomeModule test here. (ToDo: reinstate) + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getPackageModuleInfo hsc_env mdl = 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 - n_list = nameSetToList names - tys = [ ty | name <- n_list, - Just ty <- [lookupTypeEnv pte name] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = names, - minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl - })) + (_msgs, 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 + n_list = nameSetToList names + tys = [ ty | name <- n_list, + Just ty <- [lookupTypeEnv pte name] ] + -- + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = names, + minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl, + minf_instances = error "getModuleInfo: instances for package module unimplemented" + })) #else - -- bogusly different for non-GHCI (ToDo) - return Nothing + -- 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. +getHomeModuleInfo hsc_env mdl = + case lookupModuleEnv (hsc_HPT hsc_env) mdl of + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + minf_rdr_env = mi_globals $! hm_iface hmi, + minf_instances = md_insts details + })) -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] @@ -1573,9 +1729,25 @@ modInfoTopLevelScope minf modInfoExports :: ModuleInfo -> [Name] modInfoExports minf = nameSetToList $! minf_exports minf +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [Instance] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) + modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) +modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing) +modInfoLookupName s minf name = withSession s $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + isDictonaryId :: Id -> Bool isDictonaryId id = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } @@ -1589,36 +1761,22 @@ 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 +-- ----------------------------------------------------------------------------- +-- Misc exported utils -data ObjectCode - = ByteCode - | BinaryCode FilePath +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) --- 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. +-- | print a 'NamedThing', adding parentheses if the name is an operator. +pprParenSymName :: NamedThing a => a -> SDoc +pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) --- ToDo: --- - Data and Typeable instances for HsSyn. +-- ---------------------------------------------------------------------------- --- ToDo: --- - things that aren't in the output of the renamer: --- - the export list --- - the imports +#if 0 -- ToDo: --- - things that aren't in the output of the typechecker right now: --- - the export list --- - the imports --- - type signatures --- - type/data/newtype declarations --- - class declarations --- - instances --- - extra things in the typechecker's output: --- - default methods are turned into top-level decls. --- - dictionary bindings +-- - Data and Typeable instances for HsSyn. -- ToDo: check for small transformations that happen to the syntax in -- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) @@ -1660,13 +1818,15 @@ setContext (Session ref) toplevs exports = do let all_env = foldr plusGlobalRdrEnv export_env toplev_envs writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs, ic_exports = exports, - ic_rn_gbl_env = all_env } } + ic_rn_gbl_env = all_env }} + -- Make a GlobalRdrEnv based on the exports of the modules only. mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv mkExportEnv hsc_env mods = do - mb_name_sets <- mapM (getModuleExports hsc_env) mods + stuff <- mapM (getModuleExports hsc_env) mods let + (_msgs, mb_name_sets) = unzip stuff gres = [ nameSetToGlobalRdrEnv name_set mod | (Just name_set, mod) <- zip mb_name_sets mods ] -- @@ -1680,9 +1840,11 @@ nameSetToGlobalRdrEnv names mod = vanillaProv :: Module -> Provenance -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module -vanillaProv mod = Imported [ImportSpec { is_mod = mod, is_as = mod, - is_qual = False, is_explicit = False, - is_loc = srcLocSpan interactiveSrcLoc }] +vanillaProv mod = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] + where + decl = ImpDeclSpec { is_mod = mod, is_as = mod, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO () checkModuleExists hsc_env hpt mod = @@ -1724,15 +1886,33 @@ moduleIsInterpreted s modl = withSession s $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) -{-# DEPRECATED getInfo "we should be using parseName/lookupName instead" #-} -getInfo :: Session -> String -> IO [GetInfoResult] -getInfo s id = withSession s $ \hsc_env -> hscGetInfo hsc_env id +getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) +getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name -- | 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)))) +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] @@ -1750,12 +1930,7 @@ parseName s str = withSession s $ \hsc_env -> do -- | 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 +lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -1769,7 +1944,6 @@ exprType s expr = withSession s $ \hsc_env -> do Just ty -> return (Just tidy_ty) where tidy_ty = tidyType emptyTidyEnv ty - dflags = hsc_dflags hsc_env -- ----------------------------------------------------------------------------- -- Getting the kind of a type @@ -1843,14 +2017,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 @@ -1879,18 +2056,6 @@ foreign import "rts_evalStableIO" {- safe -} -- more informative than the C type! -} --- --------------------------------------------------------------------------- --- 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 - case mb_decls of - Nothing -> return [] -- An error of some kind - Just ds -> return ds - - ----------------------------------------------------------------------------- -- show a module and it's source/object filenames @@ -1900,6 +2065,6 @@ showModule s mod_summary = withSession s $ \hsc_env -> do 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 */