-- * Flags and settings
DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
- GhcMode(..), GhcLink(..),
+ GhcMode(..), GhcLink(..), defaultObjectTarget,
parseDynamicFlags,
getSessionDynFlags,
setSessionDynFlags,
+ parseStaticFlags,
-- * Targets
Target(..), TargetId(..), Phase,
workingDirectoryChanged,
checkModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
+ compileToCore,
-- * Parsing Haddock comments
parseHaddockComment,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
-#if defined(GHCI)
- modInfoBkptSites,
-#endif
lookupGlobalName,
-- * Printing
exprType,
typeKind,
parseName,
- RunResult(..),
- runStmt,
+ RunResult(..),
+ runStmt, SingleStep(..),
+ resume,
+ Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
+ resumeHistory, resumeHistoryIx),
+ History(historyBreakInfo, historyEnclosingDecl),
+ GHC.getHistorySpan, getHistoryModule, getHistoryTick,
+ GHC.findEnclosingDeclSpanByTick,
+ getResumeContext,
+ abandon, abandonAll,
+ InteractiveEval.back,
+ InteractiveEval.forward,
showModule,
isModuleInterpreted,
compileExpr, HValue, dynCompileExpr,
lookupName,
-
- getBreakpointHandler, setBreakpointHandler,
obtainTerm, obtainTerm1,
+ modInfoModBreaks,
+ ModBreaks(..), BreakIndex,
+ BreakInfo(breakInfo_number, breakInfo_module),
+ BreakArray, setBreakOn, setBreakOff, getBreak,
#endif
-- * Abstract syntax elements
-- ** Names
Name,
- nameModule, pprParenSymName, nameSrcLoc,
+ isExternalName, nameModule, pprParenSymName, nameSrcSpan,
NamedThing(..),
RdrName(Qual,Unqual),
-- ** Source locations
SrcLoc, pprDefnLoc,
+ mkSrcLoc, isGoodSrcLoc, noSrcLoc,
+ srcLocFile, srcLocLine, srcLocCol,
+ SrcSpan,
+ mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
+ srcSpanStart, srcSpanEnd,
+ srcSpanFile,
+ srcSpanStartLine, srcSpanEndLine,
+ srcSpanStartCol, srcSpanEndCol,
-- * Exceptions
GhcException(..), showGhcException,
#include "HsVersions.h"
#ifdef GHCI
-import RtClosureInspect ( cvObtainTerm, Term )
-import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo,
- tcRnLookupName, getModuleExports )
-import RdrName ( plusGlobalRdrEnv, Provenance(..),
- ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
- mkGlobalRdrEnv )
-import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
-import Name ( nameOccName )
-import Type ( tidyType )
-import Var ( varName )
-import VarEnv ( emptyTidyEnv )
-import GHC.Exts ( unsafeCoerce# )
-
--- For breakpoints
-import Breakpoints ( SiteNumber, Coord, nullBkptHandler,
- BkptHandler(..), BkptLocation, noDbgSites )
-import Linker ( initDynLinker )
-import PrelNames ( breakpointJumpName, breakpointCondJumpName,
- breakpointAutoJumpName )
-
-import GHC.Exts ( Int(..), Ptr(..), int2Addr#, indexArray# )
-import GHC.Base ( Opaque(..) )
-import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr )
-import Foreign ( unsafePerformIO )
-import Data.Maybe ( fromMaybe)
import qualified Linker
-
-import Data.Dynamic ( Dynamic )
-import Linker ( HValue, getHValue, extendLinkEnv )
+import Linker ( HValue )
+import ByteCodeInstr
+import BreakArray
+import NameSet
+import TcRnDriver
+import InteractiveEval
#endif
-import Packages ( initPackages )
-import NameSet ( NameSet, nameSetToList, elemNameSet )
-import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
- globalRdrEnvElts, extendGlobalRdrEnv,
- emptyGlobalRdrEnv )
+import Packages
+import NameSet
+import RdrName
import HsSyn
-import Type ( Kind, Type, dropForAlls, PredType, ThetaType,
- pprThetaArrow, pprParendType, splitForAllTys,
- pprTypeApp, funResultTy )
-import Id ( Id, idType, isImplicitId, isDeadBinder,
- isExportedId, isLocalId, isGlobalId,
- isRecordSelector, recordSelectorFieldLabel,
- isPrimOpId, isFCallId, isClassOpId_maybe,
- isDataConWorkId, idDataCon,
- isBottomingId )
-import Var ( TyVar )
+import Type hiding (typeKind)
+import TcType hiding (typeKind)
+import Id
+import Var hiding (setIdType)
import TysPrim ( alphaTyVars )
-import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
- isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
- tyConTyVars, tyConDataCons, synTyConDefn,
- synTyConType, synTyConResKind )
-import Class ( Class, classSCTheta, classTvsFds, classMethods )
-import FunDeps ( pprFundeps )
-import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
- dataConFieldLabels, dataConStrictMarks,
- dataConIsInfix, isVanillaDataCon )
-import Name ( Name, nameModule, NamedThing(..), nameSrcLoc )
+import TyCon
+import Class
+import FunDeps
+import DataCon
+import Name hiding ( varName )
import OccName ( parenSymOcc )
-import NameEnv ( nameEnvElts )
import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
import SrcLoc
+import Desugar
+import CoreSyn
+import TcRnDriver ( tcRnModule )
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 HscMain ( newHscEnv, hscFileCheck, HscChecked(..) )
import HscTypes
import DynFlags
+import StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
import Module
import UniqFM
-import PackageConfig ( PackageId, stringToPackageId, mainPackageId )
+import UniqSet
+import Unique
+import PackageConfig
import FiniteMap
import Panic
import Digraph
import StringBuffer ( StringBuffer, hGetStringBuffer )
import Outputable
import BasicTypes
-import TcType ( tcSplitSigmaTy, isDictTy )
import Maybes ( expectJust, mapCatMaybes )
-import HaddockParse ( parseHaddockParagraphs, parseHaddockString )
+import HaddockParse
import HaddockLex ( tokenise )
import Control.Concurrent
import System.Directory ( getModificationTime, doesFileExist )
-import Data.Maybe ( isJust, isNothing )
-import Data.List ( partition, nub )
+import Data.Maybe
+import Data.List
import qualified Data.List as List
-import Control.Monad ( unless, when )
+import Control.Monad
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.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
inner
-#if defined(GHCI)
-GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)])
- -- stores the current breakpoint handler to help setContext to
- -- restore it after a context change
-#endif
-
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
newSession :: Maybe FilePath -> IO Session
modifyMVar_ interruptTargetThread (return . (main_thread :))
installSignalHandlers
+ initStaticOpts
dflags0 <- initSysTools mb_top_dir defaultDynFlags
dflags <- initDynFlags dflags0
env <- newHscEnv dflags
sessionHscEnv :: Session -> IO HscEnv
sessionHscEnv (Session ref) = readIORef ref
-withSession :: Session -> (HscEnv -> IO a) -> IO a
-withSession (Session ref) f = do h <- readIORef ref; f h
-
-modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
-modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
-
-- -----------------------------------------------------------------------------
-- Flags & settings
hsc_env <- readIORef ref
let
dflags = hsc_dflags hsc_env
- gmode = ghcMode (hsc_dflags hsc_env)
targets = hsc_targets hsc_env
old_graph = hsc_mod_graph hsc_env
-- 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 s@(Session ref) how_much mod_graph = do
guessOutputFile s
let hpt1 = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
- 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
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@(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 $
minf_rdr_env = Just rdr_env,
minf_instances = md_insts details
#ifdef GHCI
- ,minf_dbg_sites = noDbgSites
+ ,minf_modBreaks = emptyModBreaks
#endif
}
return (Just (CheckedModule {
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@(Session ref) fn = do
+ hsc_env <- readIORef ref
+ -- 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
+ case find ((== fn) . msHsFilePath) modGraph of
+ Just modSummary -> do
+ -- 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 ()
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
-ms_mod_name :: ModSummary -> ModuleName
-ms_mod_name = moduleName . ms_mod
-
-- If there are {-# SOURCE #-} imports between strongly connected
-- components in the topological sort, then those imports can
-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
return $! isJust (lookupUFM (hsc_HPT hsc_env) m)
getBindings :: Session -> IO [TyThing]
-getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC)
+getBindings s = withSession s $ \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))
+ in
+ return filtered
getPrintUnqual :: Session -> IO PrintUnqualified
getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC)
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [Instance]
#ifdef GHCI
- ,minf_dbg_sites :: [(SiteNumber,Coord)]
+ ,minf_modBreaks :: ModBreaks
#endif
-- ToDo: this should really contain the ModIface too
}
minf_exports = names,
minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl),
minf_instances = error "getModuleInfo: instances for package module unimplemented",
- minf_dbg_sites = noDbgSites
+ minf_modBreaks = emptyModBreaks
}))
#else
-- bogusly different for non-GHCI (ToDo)
minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details
#ifdef GHCI
- ,minf_dbg_sites = md_dbg_sites details
+ ,minf_modBreaks = md_modBreaks details
#endif
}))
(hsc_HPT hsc_env) (eps_PTE eps) name
#ifdef GHCI
-modInfoBkptSites = minf_dbg_sites
+modInfoModBreaks = minf_modBreaks
#endif
isDictonaryId :: Id -> Bool
throwDyn (CmdLineError (showSDoc msg))
#ifdef GHCI
+getHistorySpan :: Session -> History -> IO SrcSpan
+getHistorySpan sess h = withSession sess $ \hsc_env ->
+ return$ InteractiveEval.getHistorySpan hsc_env h
--- | Set the interactive evaluation context.
---
--- Setting the context doesn't throw away any bindings; the bindings
--- we've built up in the InteractiveContext simply move to the new
--- module. They always shadow anything in scope in the current context.
-setContext :: Session
- -> [Module] -- entire top level scope of these modules
- -> [Module] -- exports only of these modules
- -> IO ()
-setContext sess@(Session ref) toplev_mods export_mods = do
- hsc_env <- readIORef ref
- let old_ic = hsc_IC hsc_env
- hpt = hsc_HPT hsc_env
- --
- export_env <- mkExportEnv hsc_env export_mods
- toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
- let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
- writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
- ic_exports = export_mods,
- ic_rn_gbl_env = all_env }}
- reinstallBreakpointHandlers sess
-
--- Make a GlobalRdrEnv based on the exports of the modules only.
-mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
-mkExportEnv hsc_env mods = do
- stuff <- mapM (getModuleExports hsc_env) mods
- let
- (_msgs, mb_name_sets) = unzip stuff
- gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod)
- | (Just avails, mod) <- zip mb_name_sets mods ]
- --
- return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres
-
-nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv
-nameSetToGlobalRdrEnv names mod =
- mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod }
- | name <- nameSetToList names ]
-
-vanillaProv :: ModuleName -> Provenance
--- We're building a GlobalRdrEnv as if the user imported
--- all the specified modules into the global interactive module
-vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
- where
- decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
- is_qual = False,
- is_dloc = srcLocSpan interactiveSrcLoc }
-
-mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
-mkTopLevEnv hpt modl
- = case lookupUFM hpt (moduleName modl) of
- Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++
- showSDoc (ppr modl)))
- Just details ->
- case mi_globals (hm_iface details) of
- Nothing ->
- throwDyn (ProgramError ("mkTopLevEnv: not interpreted "
- ++ showSDoc (ppr modl)))
- Just env -> return env
-
--- | Get the interactive evaluation context, consisting of a pair of the
--- set of modules from which we take the full top-level scope, and the set
--- of modules from which we take just the exports respectively.
-getContext :: Session -> IO ([Module],[Module])
-getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
- return (ic_toplev_scope ic, ic_exports ic))
-
--- | Returns 'True' if the specified module is interpreted, and hence has
--- its full top-level scope available.
-moduleIsInterpreted :: Session -> Module -> IO Bool
-moduleIsInterpreted s modl = withSession s $ \h ->
- if modulePackageId modl /= thisPackage (hsc_dflags h)
- then return False
- else case lookupUFM (hsc_HPT h) (moduleName modl) of
- Just details -> return (isJust (mi_globals (hm_iface details)))
- _not_a_home_module -> return False
-
--- | Looks up an identifier in the current interactive context (for :info)
-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]
-parseName s str = withSession s $ \hsc_env -> do
- maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
- case maybe_rdr_name of
- Nothing -> return []
- Just (L _ rdr_name) -> do
- mb_names <- tcRnLookupRdrName hsc_env rdr_name
- case mb_names of
- Nothing -> return []
- Just ns -> return ns
- -- ToDo: should return error messages
-
--- | 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 -> tcRnLookupName hsc_env name
-
--- -----------------------------------------------------------------------------
--- Getting the type of an expression
-
--- | Get the type of an expression
-exprType :: Session -> String -> IO (Maybe Type)
-exprType s expr = withSession s $ \hsc_env -> do
- maybe_stuff <- hscTcExpr hsc_env expr
- case maybe_stuff of
- Nothing -> return Nothing
- Just ty -> return (Just tidy_ty)
- where
- tidy_ty = tidyType emptyTidyEnv ty
-
--- -----------------------------------------------------------------------------
--- Getting the kind of a type
-
--- | Get the kind of a type
-typeKind :: Session -> String -> IO (Maybe Kind)
-typeKind s str = withSession s $ \hsc_env -> do
- maybe_stuff <- hscKcType hsc_env str
- case maybe_stuff of
- Nothing -> return Nothing
- Just kind -> return (Just kind)
-
------------------------------------------------------------------------------
--- cmCompileExpr: compile an expression and deliver an HValue
-
-compileExpr :: Session -> String -> IO (Maybe HValue)
-compileExpr s expr = withSession s $ \hsc_env -> do
- maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
- case maybe_stuff of
- Nothing -> return Nothing
- Just (new_ic, names, hval) -> do
- -- Run it!
- hvals <- (unsafeCoerce# hval) :: IO [HValue]
-
- case (names,hvals) of
- ([n],[hv]) -> return (Just hv)
- _ -> panic "compileExpr"
-
--- -----------------------------------------------------------------------------
--- Compile an expression into a dynamic
-
-dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
-dynCompileExpr ses expr = do
- (full,exports) <- getContext ses
- setContext ses full $
- (mkModule
- (stringToPackageId "base") (mkModuleName "Data.Dynamic")
- ):exports
- let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
- res <- withSession ses (flip hscStmt stmt)
- setContext ses full exports
- case res of
- Nothing -> return Nothing
- Just (_, names, hvals) -> do
- vals <- (unsafeCoerce# hvals :: IO [Dynamic])
- case (names,vals) of
- (_:[], v:[]) -> return (Just v)
- _ -> panic "dynCompileExpr"
-
--- -----------------------------------------------------------------------------
--- running a statement interactively
-
-data RunResult
- = RunOk [Name] -- ^ names bound by this evaluation
- | RunFailed -- ^ statement failed compilation
- | RunException Exception -- ^ statement raised an exception
-
--- | Run a statement in the current interactive context. Statemenet
--- may bind multple values.
-runStmt :: Session -> String -> IO RunResult
-runStmt (Session ref) expr
- = do
- hsc_env <- readIORef ref
-
- -- Turn off -fwarn-unused-bindings when running a statement, to hide
- -- warnings about the implicit bindings we introduce.
- let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
- hsc_env' = hsc_env{ hsc_dflags = dflags' }
-
- maybe_stuff <- hscStmt hsc_env' expr
-
- case maybe_stuff of
- Nothing -> return RunFailed
- Just (new_hsc_env, names, hval) -> do
-
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- either_hvals <- sandboxIO thing_to_run
-
- case either_hvals of
- Left e -> do
- -- on error, keep the *old* interactive context,
- -- so that 'it' is not bound to something
- -- that doesn't exist.
- return (RunException e)
-
- Right hvals -> do
- -- Get the newly bound things, and bind them.
- -- Don't need to delete any shadowed bindings;
- -- the new ones override the old ones.
- extendLinkEnv (zip names hvals)
-
- writeIORef ref new_hsc_env
- return (RunOk names)
-
--- 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 = 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
--- RTS main thread. It is disabled for now because ^C exceptions
--- won't be delivered to the new thread, instead they'll be delivered
--- to the (blocked) GHCi main thread.
-
--- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception
-
-sandboxIO :: IO a -> IO (Either Int (Either Exception a))
-sandboxIO thing = do
- st_thing <- newStablePtr (Exception.try thing)
- alloca $ \ p_st_result -> do
- stat <- rts_evalStableIO st_thing p_st_result
- freeStablePtr st_thing
- if stat == 1
- then do st_result <- peek p_st_result
- result <- deRefStablePtr st_result
- freeStablePtr st_result
- return (Right result)
- else do
- return (Left (fromIntegral stat))
-
-foreign import "rts_evalStableIO" {- safe -}
- rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt
- -- more informative than the C type!
-
-XXX the type of rts_evalStableIO no longer matches the above
-
--}
-
-
------------------------------------------------------------------------------
--- show a module and it's source/object filenames
-
-showModule :: Session -> ModSummary -> IO String
-showModule s mod_summary = withSession s $ \hsc_env ->
- isModuleInterpreted s mod_summary >>= \interpreted ->
- return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
-
-isModuleInterpreted :: Session -> ModSummary -> IO Bool
-isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
- case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
- Nothing -> panic "missing linkable"
- Just mod_info -> return (not obj_linkable)
- where
- obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info))
-
------------------------------------------------------------------------------
--- Breakpoint handlers
-
-getBreakpointHandler :: Session -> IO (Maybe (BkptHandler Module))
-getBreakpointHandler session = getSessionDynFlags session >>= return . bkptHandler
-
-setBreakpointHandler :: Session -> BkptHandler Module -> IO ()
-setBreakpointHandler session handler = do
- dflags <- getSessionDynFlags session
- setSessionDynFlags session dflags{ bkptHandler = Just handler }
- let linkEnv = [ ( breakpointJumpName
- , unsafeCoerce# (jumpFunction session handler))
- , ( breakpointCondJumpName
- , unsafeCoerce# (jumpCondFunction session handler))
- , ( breakpointAutoJumpName
- , unsafeCoerce# (jumpAutoFunction session handler))
- ]
- writeIORef v_bkptLinkEnv linkEnv
- dflags <- getSessionDynFlags session
- reinstallBreakpointHandlers session
-
-reinstallBreakpointHandlers :: Session -> IO ()
-reinstallBreakpointHandlers session = do
- dflags <- getSessionDynFlags session
- let mode = ghcMode dflags
- when (ghcLink dflags == LinkInMemory) $ do
- linkEnv <- readIORef v_bkptLinkEnv
- initDynLinker dflags
- extendLinkEnv linkEnv
-
------------------------------------------------------------------------
--- Jump functions
-
-type SiteInfo = (String, SiteNumber)
-jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> b -> b
-jumpCondFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> Bool -> b -> b
-jumpFunctionM :: Session -> BkptHandler a -> BkptLocation a -> (Int, [Opaque], String) -> b -> IO b
-
-jumpCondFunction _ _ _ _ False b = b
-jumpCondFunction session handler site args True b
- = jumpFunction session handler site args b
-
-jumpFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ jumpFunctionM session handler site args b
-
-jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b =
- do
- ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
- let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues]
- handleBreakpoint handler session (zip ids hValues) site locmsg b
-
-jumpAutoFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ do
- break <- isAutoBkptEnabled handler session site
- if break
- then jumpFunctionM session handler site args b
- else return b
-
-jumpStepByStepFunction session handler siteInfo args b
- | site <- mkSite siteInfo
- = unsafePerformIO $ do
- jumpFunctionM session handler site args b
-
-mkSite :: SiteInfo -> BkptLocation Module
-mkSite ( modName, sitenum) =
- (mkModule mainPackageId (mkModuleName modName), sitenum)
-
-obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
-obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
-
-obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
-obtainTerm sess force id = withSession sess $ \hsc_env -> do
- mb_v <- getHValue (varName id)
- case mb_v of
- Just v -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v
- Nothing -> return Nothing
-
-#endif /* GHCI */
+findEnclosingDeclSpanByTick :: Session -> Module -> BreakIndex -> IO SrcSpan
+findEnclosingDeclSpanByTick sess m t = withSession sess $ \ hsc_env ->
+ return$ InteractiveEval.findEnclosingDeclSpanByTick hsc_env m t
+#endif