X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=82a5adc3a03fd06bf405e65d3229655e0a439d09;hb=28879d9b3afe1812810d42f14eda6dfa4aa6dc73;hp=8ac38ae4e38b742897fb1c208cd0578232e5763e;hpb=41fd413684f4dba0259fefffa41c9c9eac2f629a;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 8ac38ae..82a5adc 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -17,7 +17,8 @@ module GHC ( gcatch, gbracket, gfinally, clearWarnings, getWarnings, hasWarnings, printExceptionAndWarnings, printWarnings, - handleSourceError, + handleSourceError, defaultCallbacks, GhcApiCallbacks(..), + needsTemplateHaskell, -- * Flags and settings DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, @@ -43,11 +44,12 @@ module GHC ( -- * Loading\/compiling the program depanal, - load, loadWithLogger, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + load, loadWithLogger, LoadHowMuch(..), + SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, parseModule, typecheckModule, desugarModule, loadModule, - ParsedModule, TypecheckedModule, DesugaredModule, -- all abstract + ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), TypecheckedSource, ParsedSource, RenamedSource, -- ditto TypecheckedMod, ParsedMod, moduleInfo, renamedSource, typecheckedSource, @@ -56,9 +58,6 @@ module GHC ( compileCoreToObj, getModSummary, - -- * Parsing Haddock comments - parseHaddockComment, - -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModuleGraph, @@ -87,6 +86,7 @@ module GHC ( -- * Interactive evaluation getBindings, getPrintUnqual, findModule, + lookupModule, #ifdef GHCI setContext, getContext, getNamesInScope, @@ -98,7 +98,7 @@ module GHC ( typeKind, parseName, RunResult(..), - runStmt, SingleStep(..), + runStmt, parseImportDecl, SingleStep(..), resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), @@ -111,13 +111,13 @@ module GHC ( showModule, isModuleInterpreted, InteractiveEval.compileExpr, HValue, dynCompileExpr, - lookupName, GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), BreakArray, setBreakOn, setBreakOff, getBreak, #endif + lookupName, -- * Abstract syntax elements @@ -148,7 +148,7 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - isOpenTyCon, + isFamilyTyCon, synTyConDefn, synTyConType, synTyConResKind, -- ** Type variables @@ -158,7 +158,7 @@ module GHC ( -- ** Data constructors DataCon, dataConSig, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, + dataConIsInfix, isVanillaDataCon, dataConUserType, dataConStrictMarks, StrictnessMark(..), isMarkedStrict, @@ -176,7 +176,7 @@ module GHC ( pprParendType, pprTypeApp, Kind, PredType, - ThetaType, pprThetaArrow, + ThetaType, pprForAll, pprThetaArrow, -- ** Entities TyThing(..), @@ -242,30 +242,30 @@ import qualified Linker import Linker ( HValue ) import ByteCodeInstr import BreakArray -import NameSet import InteractiveEval -import TcRnDriver #endif +import TcRnDriver import TcIface -import TcRnTypes hiding (LIE) +import TcRnTypes import TcRnMonad ( initIfaceCheck ) import Packages import NameSet import RdrName import qualified HsSyn -- hack as we want to reexport the whole module import HsSyn hiding ((<.>)) -import Type hiding (typeKind) -import TcType hiding (typeKind) +import Type +import Coercion ( synTyConResKind ) +import TcType hiding( typeKind ) import Id import Var import TysPrim ( alphaTyVars ) import TyCon import Class -import FunDeps +-- import FunDeps import DataCon import Name hiding ( varName ) -import OccName ( parenSymOcc ) +-- import OccName ( parenSymOcc ) import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, emptyInstEnv ) import FamInstEnv ( emptyFamInstEnv ) @@ -273,7 +273,7 @@ import SrcLoc --import CoreSyn import TidyPgm import DriverPipeline -import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) +import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo import Finder import HscMain @@ -285,11 +285,7 @@ import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Annotations import Module -import LazyUniqFM -import qualified UniqFM as UFM -import UniqSet -import Unique -import FiniteMap +import UniqFM import Panic import Digraph import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) @@ -300,15 +296,15 @@ import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar ) import Outputable import BasicTypes import Maybes ( expectJust, mapCatMaybes ) -import HaddockParse -import HaddockLex ( tokenise ) import FastString import Lexer -import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist, getCurrentDirectory ) import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import qualified FiniteMap as Map import Data.List import qualified Data.List as List import Data.Typeable ( Typeable ) @@ -341,6 +337,7 @@ defaultErrorHandler dflags inner = Just (ioe :: IOException) -> fatalErrorMsg dflags (text (show ioe)) _ -> case fromException exception of + Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") _ -> case fromException exception of @@ -357,7 +354,7 @@ defaultErrorHandler dflags inner = hFlush stdout case ge of PhaseFailed _ code -> exitWith code - Interrupted -> exitWith (ExitFailure 1) + Signal _ -> exitWith (ExitFailure 1) _ -> do fatalErrorMsg dflags (text (show ge)) exitWith (ExitFailure 1) ) $ @@ -371,7 +368,7 @@ defaultCleanupHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a defaultCleanupHandler dflags inner = -- make sure we clean up after ourselves - inner `gonException` + inner `gfinally` (liftIO $ do cleanTempFiles dflags cleanTempDirs dflags @@ -459,18 +456,23 @@ runGhcT mb_top_dir ghct = do initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir = do -- catch ^C - main_thread <- liftIO $ myThreadId - liftIO $ modifyMVar_ interruptTargetThread (return . (main_thread :)) liftIO $ installSignalHandlers liftIO $ StaticFlags.initStaticOpts dflags0 <- liftIO $ initDynFlags defaultDynFlags dflags <- liftIO $ initSysTools mb_top_dir dflags0 - env <- liftIO $ newHscEnv dflags + env <- liftIO $ newHscEnv defaultCallbacks dflags setSession env clearWarnings +defaultCallbacks :: GhcApiCallbacks +defaultCallbacks = + GhcApiCallbacks { + reportModuleCompilationResult = + \_ mb_err -> defaultWarnErrLogger mb_err + } + -- ----------------------------------------------------------------------------- -- Flags & settings @@ -619,19 +621,20 @@ setGlobalTypeScope ids hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids } -- ----------------------------------------------------------------------------- --- Parsing Haddock comments - -parseHaddockComment :: String -> Either String (HsDoc RdrName) -parseHaddockComment string = - case parseHaddockParagraphs (tokenise string) of - MyLeft x -> Left x - MyRight x -> Right x - --- ----------------------------------------------------------------------------- -- Loading the program -- | Perform a dependency analysis starting from the current targets -- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- depanal :: GhcMonad m => [ModuleName] -- ^ excluded modules -> Bool -- ^ allow duplicate roots @@ -652,20 +655,34 @@ depanal excluded_mods allow_dup_roots = do modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } return mod_graph +-- | Describes which modules of the module graph need to be loaded. data LoadHowMuch = LoadAllTargets + -- ^ Load all targets and its dependencies. | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. --- | Try to load the program. Calls 'loadWithLogger' with the default --- compiler that just immediately logs all warnings and errors. +-- | Try to load the program. See 'LoadHowMuch' for the different modes. -- --- This function may throw a 'SourceError' if errors are encountered before --- the actual compilation starts (e.g., during dependency analysis). +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating +-- and loading may result in files being created on disk. +-- +-- Calls the 'reportModuleCompilationResult' callback after each compiling +-- each module, whether successful or not. +-- +-- Throw a 'SourceError' if errors are encountered before the actual +-- compilation starts (e.g., during dependency analysis). All other errors +-- are reported using the callback. -- load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = - loadWithLogger defaultWarnErrLogger how_much +load how_much = do + mod_graph <- depanal [] False + load2 how_much mod_graph -- | A function called to log warnings and errors. type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () @@ -691,12 +708,13 @@ loadWithLogger logger how_much = do -- 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. - mod_graph <- depanal [] False - load2 how_much mod_graph logger + withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult = + \_ -> logger }) $ + load how_much -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> WarnErrLogger +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] -> m SuccessFlag -load2 how_much mod_graph logger = do +load2 how_much mod_graph = do guessOutputFile hsc_env <- getSession @@ -751,7 +769,7 @@ load2 how_much mod_graph logger = do (flattenSCCs mg2_with_srcimps) stable_mods - liftIO $ evaluate pruned_hpt + _ <- liftIO $ evaluate pruned_hpt -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, @@ -823,8 +841,7 @@ load2 how_much mod_graph logger = do liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) (upsweep_ok, hsc_env1, modsUpswept) - <- upsweep logger - (hsc_env { hsc_HPT = emptyHomePackageTable }) + <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) pruned_hpt stable_mods cleanup mg -- Make modsDone be the summaries for each home module now @@ -856,7 +873,7 @@ load2 how_much mod_graph logger = do let main_mod = mainModIs dflags a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib when (ghcLink dflags == LinkBinary && isJust ofile && not do_linking) $ @@ -1004,7 +1021,7 @@ instance DesugaredMod DesugaredModule where type ParsedSource = Located (HsModule RdrName) type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], - Maybe (HsDoc Name), HaddockModInfo Name) + Maybe LHsDocString) type TypecheckedSource = LHsBinds Id -- NOTE: @@ -1087,26 +1104,46 @@ desugarModule tcm = do -- | Load a module. Input doesn't need to be desugared. -- --- XXX: Describe usage. +-- A module must be loaded before dependent modules can be typechecked. This +-- always includes generating a 'ModIface' and, depending on the +-- 'DynFlags.hscTarget', may also include code generation. +-- +-- This function will always cause recompilation and will always overwrite +-- previous compilation results (potentially files on disk). +-- loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod loadModule tcm = do let ms = modSummary tcm let mod = ms_mod_name ms - let (tcg, details) = tm_internals tcm + let loc = ms_location ms + let (tcg, _details) = tm_internals tcm hpt_new <- withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do - (iface, _) <- makeSimpleIface Nothing tcg details - let mod_info = HomeModInfo { - hm_iface = iface, - hm_details = details, - hm_linkable = Just (LM (ms_hs_date ms) - (ms_mod ms) - []) } + + let compilerBackend comp env ms' _ _mb_old_iface _ = + withTempSession (\_ -> env) $ + hscBackend comp tcg ms' Nothing + hsc_env <- getSession + mod_info <- do + mb_linkable <- + case ms_obj_date ms of + Just t | t > ms_hs_date ms -> do + l <- liftIO $ findObjectLinkable (ms_mod ms) + (ml_obj_file loc) t + return (Just l) + _otherwise -> return Nothing + + compile' (compilerBackend hscNothingCompiler + ,compilerBackend hscInteractiveCompiler + ,hscCheckRecompBackend hscBatchCompiler tcg) + hsc_env ms 1 1 Nothing mb_linkable + -- compile' shouldn't change the environment return $ addToUFM (hsc_HPT hsc_env) mod mod_info modifySession $ \e -> e{ hsc_HPT = hpt_new } return tcm + -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' parses, typechecks, and -- desugars the module, then returns the resulting Core module (consisting of @@ -1166,7 +1203,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing hscWriteIface iface changed modSummary - hscGenHardCode cgguts modSummary + _ <- hscGenHardCode cgguts modSummary return () -- Makes a "vanilla" ModGuts. @@ -1200,7 +1237,7 @@ compileCore simplify fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget target - load LoadAllTargets + _ <- load LoadAllTargets -- Then find dependencies modGraph <- depanal [] True case find ((== fn) . msHsFilePath) modGraph of @@ -1321,7 +1358,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs scc_mods = map ms_mod_name scc home_module m = m `elem` all_home_mods && m `notElem` scc_mods - scc_allimps = nub (filter home_module (concatMap ms_allimps scc)) + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) -- all imports outside the current SCC, but in the home pkg stable_obj_imps = map (`elem` stable_obj) scc_allimps @@ -1358,9 +1395,6 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs linkableTime l >= ms_hs_date ms _other -> False -ms_allimps :: ModSummary -> [ModuleName] -ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) - -- ----------------------------------------------------------------------------- -- | Prune the HomePackageTable @@ -1433,17 +1467,21 @@ findPartiallyCompletedCycles modsDone theGraph upsweep :: GhcMonad m => - WarnErrLogger -- ^ Called to print warnings and errors. - -> HscEnv -- ^ Includes initially-empty HPT + HscEnv -- ^ Includes initially-empty HPT -> HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> IO () -- ^ How to clean up unwanted tmp files -> [SCC ModSummary] -- ^ Mods to do (the worklist) -> m (SuccessFlag, - HscEnv, -- With an updated HPT - [ModSummary]) -- Mods which succeeded - -upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do + HscEnv, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' with an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep hsc_env old_hpt stable_mods cleanup sccs = do (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs) return (res, hsc_env, reverse done) where @@ -1462,13 +1500,14 @@ upsweep logger hsc_env old_hpt stable_mods cleanup sccs = do = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger = reportModuleCompilationResult (hsc_callbacks hsc_env) mb_mod_info <- handleSourceError - (\err -> do logger (Just err); return Nothing) $ do + (\err -> do logger mod (Just err); return Nothing) $ do mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod mod_index nmods - logger Nothing -- log warnings + logger mod Nothing -- log warnings return (Just mod_info) liftIO cleanup -- Remove unwanted tmp files between compilations @@ -1744,6 +1783,7 @@ topSortModuleGraph -- ^ Drop hi-boot nodes? (see below) -> [ModSummary] -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. -> [SCC ModSummary] -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes -- The resulting list of strongly-connected-components is in topologically @@ -1789,14 +1829,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l numbered_summaries = zip summaries [1..] lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = lookupFM node_map (mod, hs_src) + lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map lookup_key :: HscSource -> ModuleName -> Maybe Int lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) node_map :: NodeMap SummaryNode - node_map = listToFM [ ((moduleName (ms_mod s), ms_hsc_src s), node) - | node@(s, _, _) <- nodes ] + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] -- We use integers as the keys for the SCC algorithm nodes :: [SummaryNode] @@ -1804,8 +1844,8 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l | (s, key) <- numbered_summaries -- Drop the hi-boot ones if told to do so , not (isBootSummary s && drop_hs_boot_nodes) - , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++ + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ (-- see [boot-edges] below if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile then [] @@ -1832,16 +1872,16 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs +type NodeMap a = Map NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] -nodeMapElts = eltsFM +nodeMapElts = Map.elems -- | If there are {-# SOURCE #-} imports between strongly connected -- components in the topological sort, then those imports can @@ -1852,8 +1892,8 @@ warnUnnecessarySourceImports sccs = logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) where check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] warn :: Located ModuleName -> WarnMsg warn (L loc mod) = @@ -1946,7 +1986,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- for those mentioned in the visited set loop [] done = return (concat (nodeMapElts done)) loop ((wanted_mod, is_boot) : ss) done - | Just summs <- lookupFM done key + | Just summs <- Map.lookup key done = if isSingleton summs then loop ss done else @@ -1957,13 +1997,15 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots Nothing excl_mods case mb_s of Nothing -> loop ss done - Just s -> loop (msDeps s ++ ss) (addToFM done key [s]) + Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) where key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) +-- XXX Does the (++) here need to be flipped? mkRootMap :: [ModSummary] -> NodeMap [ModSummary] -mkRootMap summaries = addListToFM_C (++) emptyFM - [ (msKey s, [s]) | s <- summaries ] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [s]) | s <- summaries ] + Map.empty msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] -- (msDeps s) returns the dependencies of the ModSummary s. @@ -1975,8 +2017,23 @@ msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] -- Remember, this pass isn't doing the topological sort. It's -- just gathering the list of all relevant ModSummaries msDeps s = - concat [ [(m,True), (m,False)] | m <- ms_srcimps s ] - ++ [ (m,False) | m <- ms_imps s ] + concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] + ++ [ (m,False) | m <- ms_home_imps s ] + +home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] +home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps ----------------------------------------------------------------------------- -- Summarising modules @@ -2093,7 +2150,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | wanted_mod `elem` excl_mods = return Nothing - | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src) + | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map = do -- Find its new timestamp; all the -- ModSummaries in the old map have valid ml_hs_files let location = ms_location old_summary @@ -2232,7 +2289,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) | 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 + | xopt Opt_Cpp dflags' = True | dopt Opt_Pp dflags' = True | otherwise = False @@ -2276,18 +2333,28 @@ cyclicModuleErr ms = hang (ptext (sLit "Module imports form a cycle for modules:")) 2 (vcat (map show_one ms)) where - show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms), - nest 2 $ ptext (sLit "imports:") <+> - (pp_imps HsBootFile (ms_srcimps ms) - $$ pp_imps HsSrcFile (ms_imps ms))] + mods_in_cycle = map ms_mod_name ms + imp_modname = unLoc . ideclName . unLoc + just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) + + show_one ms = + vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> + maybe empty (parens . text) (ml_hs_file (ms_location ms)), + nest 2 $ ptext (sLit "imports:") <+> vcat [ + pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), + pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] + ] show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) - pp_imps src mods = fsep (map (show_mod src) mods) + pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) -- | Inform GHC that the working directory has changed. GHC will flush -- its cache of module locations, since it may no longer be valid. --- Note: if you change the working directory, you should also unload --- the current program (set targets to empty, followed by load). +-- +-- Note: Before changing the working directory make sure all threads running +-- in the same session have stopped. If you change the working directory, +-- you should also unload the current program (set targets to empty, +-- followed by load). workingDirectoryChanged :: GhcMonad m => m () workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) @@ -2298,6 +2365,15 @@ workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary getModuleGraph = liftM hsc_mod_graph getSession +-- | Determines whether a set of modules requires Template Haskell. +-- +-- Note that if the session's 'DynFlags' enabled Template Haskell when +-- 'depanal' was called, then each module in the returned module graph will +-- have Template Haskell enabled whether it is actually needed or not. +needsTemplateHaskell :: ModuleGraph -> Bool +needsTemplateHaskell ms = + any (xopt Opt_TemplateHaskell . ms_hspp_opts) ms + -- | Return @True@ <==> module is loaded. isLoaded :: GhcMonad m => ModuleName -> m Bool isLoaded m = withSession $ \hsc_env -> @@ -2309,14 +2385,10 @@ getBindings = withSession $ \hsc_env -> -- we have to implement the shadowing behaviour of ic_tmp_ids here -- (see InteractiveContext) and the quickest way is to use an OccEnv. let - tmp_ids = ic_tmp_ids (hsc_IC hsc_env) - filtered = foldr f (const []) tmp_ids emptyUniqSet - f id rest set - | uniq `elementOfUniqSet` set = rest set - | otherwise = AnId id : rest (addOneToUniqSet set uniq) - where uniq = getUnique (nameOccName (idName id)) + occ_env = mkOccEnv [ (nameOccName (idName id), AnId id) + | id <- ic_tmp_ids (hsc_IC hsc_env) ] in - return filtered + return (occEnvElts occ_env) getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> @@ -2368,7 +2440,7 @@ getPackageModuleInfo hsc_env mdl = do return (Just (ModuleInfo { minf_type_env = mkTypeEnv tys, minf_exports = names, - minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl), + minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_modBreaks = emptyModBreaks })) @@ -2468,11 +2540,11 @@ packageDbModules :: GhcMonad m => -> m [Module] packageDbModules only_exposed = do dflags <- getSessionDynFlags - let pkgs = UFM.eltsUFM (pkgIdMap (pkgState dflags)) + let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) return $ [ mkModule pid modname | p <- pkgs , not only_exposed || exposed p - , pid <- [mkPackageId (package p)] + , let pid = packageConfigId p , modname <- exposedModules p ] -- ----------------------------------------------------------------------------- @@ -2523,7 +2595,7 @@ getModuleSourceAndFlags mod = do getTokenStream :: GhcMonad m => Module -> m [Located Token] getTokenStream mod = do (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return ts PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) @@ -2534,7 +2606,7 @@ getTokenStream mod = do getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] getRichTokenStream mod = do (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 0 0 + let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return $ addSourceToTokens startLoc source ts PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) @@ -2565,7 +2637,7 @@ addSourceToTokens loc buf (t@(L span _) : ts) showRichTokenStream :: [(Located Token, String)] -> String showRichTokenStream ts = go startLoc ts "" where sourceFile = srcSpanFile (getLoc . fst . head $ ts) - startLoc = mkSrcLoc sourceFile 0 0 + startLoc = mkSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) | not (isGoodSrcSpan span) = go loc ts @@ -2587,23 +2659,58 @@ showRichTokenStream ts = go startLoc ts "" -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX - let - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - this_pkg = thisPackage dflags - in - case lookupUFM hpt mod_name of - Just mod_info -> return (mi_module (hm_iface mod_info)) - _not_a_home_module -> do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found _ m | modulePackageId m /= this_pkg -> return m - | otherwise -> ghcError (CmdLineError (showSDoc $ - text "module" <+> quotes (ppr (moduleName m)) <+> - text "is not loaded")) - err -> let msg = cannotFindModule dflags mod_name err in - ghcError (CmdLineError (showSDoc msg)) +findModule mod_name maybe_pkg = withSession $ \hsc_env -> do + let + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + -- + case maybe_pkg of + Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found _ m -> return m + err -> noModError dflags noSrcSpan mod_name err + _otherwise -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found loc m | modulePackageId m /= this_pkg -> return m + | otherwise -> modNotLoadedError m loc + err -> noModError dflags noSrcSpan mod_name err + +modNotLoadedError :: Module -> ModLocation -> IO a +modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $ + text "module is not loaded:" <+> + quotes (ppr (moduleName m)) <+> + parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) + +-- | Like 'findModule', but differs slightly when the module refers to +-- a source file, and the file has not been loaded via 'load'. In +-- this case, 'findModule' will throw an error (module not loaded), +-- but 'lookupModule' will check to see whether the module can also be +-- found in a package, and if so, that package 'Module' will be +-- returned. If not, the usual module-not-found error will be thrown. +-- +lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) +lookupModule mod_name Nothing = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findExposedPackageModule hsc_env mod_name Nothing + case res of + Found _ m -> return m + err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err + +lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> + case lookupUFM (hsc_HPT hsc_env) mod_name of + Just mod_info -> return (Just (mi_module (hm_iface mod_info))) + _not_a_home_module -> return Nothing #ifdef GHCI getHistorySpan :: GhcMonad m => History -> m SrcSpan @@ -2621,3 +2728,12 @@ obtainTermFromId bound force id = liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id #endif + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: GhcMonad m => Name -> m (Maybe TyThing) +lookupName name = withSession $ \hsc_env -> do + mb_tything <- ioMsg $ tcRnLookupName hsc_env name + return mb_tything + -- XXX: calls panic in some circumstances; is that ok? +