X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=846bec16bdb161ad3c472a8609e5e1a82434c55e;hb=3b1438a9757639d7f37f10e1237e2369ca0ebe4a;hp=a850650e70160da09454ecc6e779d79480f473fe;hpb=17b7cf1a851f16ca8922a9f0061808e4f3b4bd0e;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index a850650..846bec1 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -19,6 +19,7 @@ module GHC ( parseDynamicFlags, getSessionDynFlags, setSessionDynFlags, + parseStaticFlags, -- * Targets Target(..), TargetId(..), Phase, @@ -40,6 +41,7 @@ module GHC ( workingDirectoryChanged, checkModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, + compileToCore, -- * Parsing Haddock comments parseHaddockComment, @@ -55,12 +57,12 @@ module GHC ( getModuleInfo, modInfoTyThings, modInfoTopLevelScope, - modInfoPrintUnqualified, - modInfoExports, + modInfoExports, modInfoInstances, modInfoIsExportedName, modInfoLookupName, lookupGlobalName, + mkPrintUnqualifiedForModule, -- * Printing PrintUnqualified, alwaysQualify, @@ -82,7 +84,8 @@ module GHC ( resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), - History(historyBreakInfo), getHistorySpan, + History(historyBreakInfo, historyEnclosingDecl), + GHC.getHistorySpan, getHistoryModule, getResumeContext, abandon, abandonAll, InteractiveEval.back, @@ -91,7 +94,7 @@ module GHC ( isModuleInterpreted, compileExpr, HValue, dynCompileExpr, lookupName, - obtainTerm, obtainTerm1, + GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), @@ -109,7 +112,7 @@ module GHC ( -- ** Names Name, - nameModule, pprParenSymName, nameSrcLoc, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, NamedThing(..), RdrName(Qual,Unqual), @@ -171,10 +174,10 @@ module GHC ( -- ** Source locations SrcLoc, pprDefnLoc, - mkSrcLoc, isGoodSrcLoc, + mkSrcLoc, isGoodSrcLoc, noSrcLoc, srcLocFile, srcLocLine, srcLocCol, SrcSpan, - mkSrcSpan, srcLocSpan, + mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, srcSpanStart, srcSpanEnd, srcSpanFile, srcSpanStartLine, srcSpanEndLine, @@ -203,10 +206,12 @@ import Linker ( HValue ) import ByteCodeInstr import BreakArray import NameSet -import TcRnDriver import InteractiveEval +import TcRnDriver #endif +import TcIface +import TcRnMonad ( initIfaceCheck ) import Packages import NameSet import RdrName @@ -224,13 +229,15 @@ import Name hiding ( varName ) import OccName ( parenSymOcc ) import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) import SrcLoc +import CoreSyn import DriverPipeline -import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) +import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo ( getImports, getOptions ) import Finder import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) import HscTypes import DynFlags +import StaticFlags import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Module @@ -265,14 +272,9 @@ 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.Error ( try, 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 @@ -338,6 +340,7 @@ newSession mb_top_dir = do modifyMVar_ interruptTargetThread (return . (main_thread :)) installSignalHandlers + initStaticOpts dflags0 <- initSysTools mb_top_dir defaultDynFlags dflags <- initDynFlags dflags0 env <- newHscEnv dflags @@ -536,10 +539,18 @@ load s@(Session ref) how_much -- 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 [] False - case mb_graph of - Just mod_graph -> load2 s how_much mod_graph + case mb_graph of + Just mod_graph -> catchingFailure $ load2 s how_much mod_graph Nothing -> return Failed - + where catchingFailure f = f `Exception.catch` \e -> do + hsc_env <- readIORef ref + -- trac #1565 / test ghci021: + -- let bindings may explode if we try to use them after + -- failing to reload + writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } + throw e + +load2 :: Session -> LoadHowMuch -> [ModSummary] -> IO SuccessFlag load2 s@(Session ref) how_much mod_graph = do guessOutputFile s hsc_env <- readIORef ref @@ -553,10 +564,8 @@ load2 s@(Session ref) how_much mod_graph = do -- (see msDeps) let all_home_mods = [ms_mod_name s | s <- mod_graph, not (isBootSummary s)] -#ifdef DEBUG bad_boot_mods = [s | s <- mod_graph, isBootSummary s, not (ms_mod_name s `elem` all_home_mods)] -#endif ASSERT( null bad_boot_mods ) return () -- mg2_with_srcimps drops the hi-boot nodes, returning a @@ -625,9 +634,9 @@ load2 s@(Session ref) how_much mod_graph = do -- short of the specified module (unless the specified module -- is stable). partial_mg - | LoadDependenciesOf mod <- how_much + | LoadDependenciesOf _mod <- how_much = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False ) + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) List.init partial_mg0 | otherwise = partial_mg0 @@ -729,7 +738,8 @@ load2 s@(Session ref) how_much mod_graph = do -- Finish up after a load. -- If the link failed, unload everything and return. -loadFinish all_ok Failed ref hsc_env +loadFinish :: SuccessFlag -> SuccessFlag -> IORef HscEnv -> HscEnv -> IO SuccessFlag +loadFinish _all_ok Failed ref hsc_env = do unload hsc_env [] writeIORef ref $! discardProg hsc_env return Failed @@ -751,6 +761,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 :: [ModSummary] -> [FilePath] ppFilesFromSummaries summaries = map ms_hspp_file summaries -- ----------------------------------------------------------------------------- @@ -760,7 +771,8 @@ data CheckedModule = CheckedModule { parsedSource :: ParsedSource, renamedSource :: Maybe RenamedSource, typecheckedSource :: Maybe TypecheckedSource, - checkedModuleInfo :: Maybe ModuleInfo + checkedModuleInfo :: Maybe ModuleInfo, + coreBinds :: Maybe [CoreBind] } -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, @@ -787,32 +799,33 @@ type TypecheckedSource = LHsBinds Id -- | This is the way to get access to parsed and typechecked source code --- for a module. 'checkModule' loads all the dependencies of the specified --- module in the Session, and then attempts to typecheck the module. If +-- for a module. 'checkModule' attempts to typecheck the module. If -- successful, it returns the abstract syntax for the module. -checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule) -checkModule session@(Session ref) mod = do - -- load up the dependencies first - r <- load session (LoadDependenciesOf mod) - if (failed r) then return Nothing else do - - -- now parse & typecheck the module +-- If compileToCore is true, it also desugars the module and returns the +-- resulting Core bindings as a component of the CheckedModule. +checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule) +checkModule (Session ref) mod compileToCore = do + -- parse & typecheck the module hsc_env <- readIORef ref let mg = hsc_mod_graph hsc_env case [ ms | ms <- mg, ms_mod_name ms == mod ] of [] -> return Nothing (ms:_) -> do - mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms + mbChecked <- hscFileCheck + hsc_env{hsc_dflags=ms_hspp_opts ms} + ms compileToCore case mbChecked of Nothing -> return Nothing - Just (HscChecked parsed renamed Nothing) -> + Just (HscChecked parsed renamed Nothing _) -> return (Just (CheckedModule { parsedSource = parsed, renamedSource = renamed, typecheckedSource = Nothing, - checkedModuleInfo = Nothing })) + checkedModuleInfo = Nothing, + coreBinds = Nothing })) Just (HscChecked parsed renamed - (Just (tc_binds, rdr_env, details))) -> do + (Just (tc_binds, rdr_env, details)) + maybeCoreBinds) -> do let minf = ModuleInfo { minf_type_env = md_types details, minf_exports = availsToNameSet $ @@ -827,9 +840,34 @@ checkModule session@(Session ref) mod = do parsedSource = parsed, renamedSource = renamed, typecheckedSource = Just tc_binds, - checkedModuleInfo = Just minf })) - --- --------------------------------------------------------------------------- + checkedModuleInfo = Just minf, + coreBinds = maybeCoreBinds})) + +-- | This is the way to get access to the Core bindings corresponding +-- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and +-- desugar the module, then returns the resulting list of Core bindings if +-- successful. +compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) +compileToCore session fn = do + -- First, set the target to the desired filename + target <- guessTarget fn Nothing + addTarget session target + load session LoadAllTargets + -- Then find dependencies + maybeModGraph <- depanal session [] True + case maybeModGraph of + Nothing -> return Nothing + Just modGraph -> do + let modSummary = expectJust "compileToCore" $ + find ((== fn) . msHsFilePath) modGraph + -- Now we have the module name; + -- parse, typecheck and desugar the module + let mod = ms_mod_name modSummary + maybeCheckedModule <- checkModule session mod True + case maybeCheckedModule of + Nothing -> return Nothing + Just checkedMod -> return $ coreBinds checkedMod + -- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () @@ -839,8 +877,10 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables #endif - other -> return () + _other -> return () -- ----------------------------------------------------------------------------- -- checkStability @@ -996,7 +1036,7 @@ findPartiallyCompletedCycles modsDone theGraph = chew theGraph where chew [] = [] - chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting. + chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. chew ((CyclicSCC vs):rest) = let names_in_this_cycle = nub (map ms_mod vs) mods_in_this_cycle @@ -1027,19 +1067,21 @@ upsweep HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -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 sccs = do + (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs) + return (res, hsc_env, reverse done) + where -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env _old_hpt done [] _ _ - = return (Succeeded, hsc_env, []) + = return (Succeeded, hsc_env, done) -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env _old_hpt done (CyclicSCC ms:_) _ _ = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) - return (Failed, hsc_env, []) + return (Failed, hsc_env, done) -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env old_hpt done (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) @@ -1053,26 +1095,29 @@ upsweep' hsc_env old_hpt stable_mods cleanup case mb_mod_info of Nothing -> return (Failed, hsc_env, []) Just mod_info -> do - { let this_mod = ms_mod_name mod + let this_mod = ms_mod_name mod -- Add new info to hsc_env - hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info - hsc_env1 = hsc_env { hsc_HPT = hpt1 } + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } -- Space-saving: delete the old HPT entry -- for mod BUT if mod is a hs-boot -- node, don't delete it. For the -- interface, the HPT entry is probaby for the -- main Haskell source file. Deleting it - -- would force .. (what?? --SDM) - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod + + done' = mod:done - ; (restOK, hsc_env2, modOKs) - <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup - mods (mod_index+1) nmods - ; return (restOK, hsc_env2, mod:modOKs) - } + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. See reTypecheckLoop, below. + hsc_env2 <- reTypecheckLoop hsc_env1 mod done' + + upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods -- Compile a single module. Always produce a Linkable for it if @@ -1136,11 +1181,11 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods iface = hm_iface hm_info compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) - compile_it = upsweep_compile hsc_env old_hpt this_mod_name + compile_it = upsweep_compile hsc_env summary' mod_index nmods mb_old_iface compile_it_discard_iface - = upsweep_compile hsc_env old_hpt this_mod_name + = upsweep_compile hsc_env summary' mod_index nmods Nothing in @@ -1204,10 +1249,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods -- Run hsc to compile a module -upsweep_compile hsc_env old_hpt this_mod summary - mod_index nmods - mb_old_iface - mb_old_linkable +upsweep_compile :: HscEnv -> ModSummary -> Int -> Int + -> Maybe ModIface -> Maybe Linkable -> IO (Maybe HomeModInfo) +upsweep_compile hsc_env summary mod_index nmods mb_old_iface mb_old_linkable = do compresult <- compile hsc_env summary mb_old_linkable mb_old_iface mod_index nmods @@ -1235,6 +1279,83 @@ retainInTopLevelEnvs keep_these hpt , isJust mb_mod_info ] -- --------------------------------------------------------------------------- +-- Typecheck module loops + +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | not (isBootSummary ms) && + any (\m -> ms_mod m == this_mod && isBootSummary m) graph + = do + let mss = reachableBackwards (ms_mod_name ms) graph + non_boot = filter (not.isBootSummary) mss + debugTraceMsg (hsc_dflags hsc_env) 2 $ + text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) + typecheckLoop hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + this_mod = ms_mod ms + +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- map vertex_fn nodes_we_want ] + where + -- all the nodes reachable by traversing the edges backwards + -- from the root node: + nodes_we_want = reachable (transposeG graph) root + + -- the rest just sets up the graph: + (nodes, lookup_key) = moduleGraphNodes False summaries + (graph, vertex_fn, key_fn) = graphFromEdges' nodes + root + | Just key <- lookup_key HsBootFile mod, Just v <- key_fn key = v + | otherwise = panic "reachableBackwards" + +-- --------------------------------------------------------------------------- -- Topological sort of the module graph topSortModuleGraph @@ -1340,11 +1461,11 @@ warnUnnecessarySourceImports dflags sccs = printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs))) where check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn m i | m <- ms, i <- ms_srcimps m, + [ warn i | m <- ms, i <- ms_srcimps m, unLoc i `notElem` mods_in_this_cycle ] - warn :: ModSummary -> Located ModuleName -> WarnMsg - warn ms (L loc mod) = + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = mkPlainErrMsg loc (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ") <+> quotes (ppr mod)) @@ -1544,7 +1665,7 @@ 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 + (x:_) -> Just x -- Summarise a module, and pick up source and timestamp. summariseModule @@ -1656,6 +1777,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc ms_obj_date = obj_timestamp })) +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) getObjTimestamp location is_boot = if is_boot then return Nothing else modificationTimeIfExists (ml_obj_file location) @@ -1669,13 +1791,14 @@ preprocessFile dflags src_fn mb_phase Nothing buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) -preprocessFile dflags src_fn mb_phase (Just (buf, time)) +preprocessFile dflags src_fn mb_phase (Just (buf, _time)) = do -- case we bypass the preprocessing stage? let local_opts = getOptions buf src_fn -- - (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts) + (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts) + -- XXX: shouldn't we be reporting the errors? let needs_preprocessing @@ -1701,14 +1824,17 @@ noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab noModError dflags loc wanted_mod err = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err +noHsFileErr :: SrcSpan -> String -> a noHsFileErr loc path = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path +packageModErr :: ModuleName -> a packageModErr mod = throwDyn $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) = throwDyn $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> @@ -1764,7 +1890,8 @@ getBindings s = withSession s $ \hsc_env -> return filtered getPrintUnqual :: Session -> IO PrintUnqualified -getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) +getPrintUnqual s = withSession s $ \hsc_env -> + return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1796,8 +1923,8 @@ getModuleInfo s mdl = withSession s $ \hsc_env -> do -- exist... hence the isHomeModule test here. (ToDo: reinstate) getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl = do #ifdef GHCI +getPackageModuleInfo hsc_env mdl = do (_msgs, mb_avails) <- getModuleExports hsc_env mdl case mb_avails of Nothing -> return Nothing @@ -1817,10 +1944,12 @@ getPackageModuleInfo hsc_env mdl = do minf_modBreaks = emptyModBreaks })) #else +getPackageModuleInfo _hsc_env _mdl = do -- bogusly different for non-GHCI (ToDo) return Nothing #endif +getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = case lookupUFM (hsc_HPT hsc_env) mdl of Nothing -> return Nothing @@ -1832,7 +1961,7 @@ getHomeModuleInfo hsc_env mdl = minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details #ifdef GHCI - ,minf_modBreaks = md_modBreaks details + ,minf_modBreaks = getModBreaks hmi #endif })) @@ -1855,8 +1984,9 @@ modInfoInstances = minf_instances modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) -modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified -modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf) +mkPrintUnqualifiedForModule :: Session -> ModuleInfo -> IO (Maybe PrintUnqualified) +mkPrintUnqualifiedForModule s minf = withSession s $ \hsc_env -> do + return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing) modInfoLookupName s minf name = withSession s $ \hsc_env -> do @@ -1868,12 +1998,13 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do (hsc_HPT hsc_env) (eps_PTE eps) name #ifdef GHCI +modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks #endif isDictonaryId :: Id -> Bool isDictonaryId id - = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } + = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } -- | Looks up a global name: that is, any top-level name in any -- visible module. Unlike 'lookupName', lookupGlobalName does not use @@ -1925,9 +2056,6 @@ getTokenStream :: Session -> Module -> IO [Located Token] -- using the algorithm that is used for an @import@ declaration. findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> - findModule' hsc_env mod_name maybe_pkg - -findModule' hsc_env mod_name maybe_pkg = let dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env @@ -1944,3 +2072,22 @@ findModule' hsc_env mod_name maybe_pkg = text "is not loaded")) err -> let msg = cannotFindModule dflags mod_name err in throwDyn (CmdLineError (showSDoc msg)) + +#ifdef GHCI +getHistorySpan :: Session -> History -> IO SrcSpan +getHistorySpan sess h = withSession sess $ \hsc_env -> + return$ InteractiveEval.getHistorySpan hsc_env h + +obtainTerm :: Session -> Bool -> Id -> IO Term +obtainTerm sess force id = withSession sess $ \hsc_env -> + InteractiveEval.obtainTerm hsc_env force id + +obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term +obtainTerm1 sess force mb_ty a = withSession sess $ \hsc_env -> + InteractiveEval.obtainTerm1 hsc_env force mb_ty a + +obtainTermB :: Session -> Int -> Bool -> Id -> IO Term +obtainTermB sess bound force id = withSession sess $ \hsc_env -> + InteractiveEval.obtainTermB hsc_env bound force id + +#endif