workingDirectoryChanged,
checkModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
+ compileToCore,
-- * Parsing Haddock comments
parseHaddockComment,
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
- modInfoPrintUnqualified,
- modInfoExports,
+ modInfoExports,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
lookupGlobalName,
+ mkPrintUnqualifiedForModule,
-- * Printing
PrintUnqualified, alwaysQualify,
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
- History(historyBreakInfo), getHistorySpan,
+ History(historyBreakInfo, historyEnclosingDecl),
+ GHC.getHistorySpan, getHistoryModule,
getResumeContext,
abandon, abandonAll,
InteractiveEval.back,
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
- obtainTerm, obtainTerm1,
+ GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType,
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
-- ** Names
Name,
- nameModule, pprParenSymName, nameSrcSpan,
+ isExternalName, nameModule, pprParenSymName, nameSrcSpan,
NamedThing(..),
RdrName(Qual,Unqual),
-- ** Source locations
SrcLoc, pprDefnLoc,
- mkSrcLoc, isGoodSrcLoc,
+ mkSrcLoc, isGoodSrcLoc, noSrcLoc,
srcLocFile, srcLocLine, srcLocCol,
SrcSpan,
- mkSrcSpan, srcLocSpan, isGoodSrcSpan,
+ mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcSpanStart, srcSpanEnd,
srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
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 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
-- 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
-- (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
-- 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
-- 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
-- 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
-- -----------------------------------------------------------------------------
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,
-- | 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 $
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 ()
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
= 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
upsweep hsc_env old_hpt stable_mods cleanup mods
= upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
+ where
-upsweep' hsc_env old_hpt stable_mods cleanup
+ upsweep' hsc_env _old_hpt _stable_mods _cleanup
[] _ _
= return (Succeeded, hsc_env, [])
-upsweep' hsc_env old_hpt stable_mods cleanup
+ upsweep' hsc_env _old_hpt _stable_mods _cleanup
(CyclicSCC ms:_) _ _
= do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
return (Failed, hsc_env, [])
-upsweep' hsc_env old_hpt stable_mods cleanup
+ 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)
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
-- 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
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))
= 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
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)
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
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) <+>
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 {
-- 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
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
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
}))
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
(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
-- 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
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
projects / ghc-hetmet.git / blobdiff