#include "HsVersions.h"
-import HscMain hiding (compileExpr)
+import GhcMonad
+import HscMain
import HsSyn (ImportDecl)
import HscTypes
import TcRnDriver
-import TcRnMonad (initTc)
-import RnNames (gresFromAvails, rnImports)
+import RnNames (gresFromAvails)
import InstEnv
import Type
import TcType hiding( typeKind )
import UniqFM
import Maybes
import ErrUtils
-import Util
import SrcLoc
import BreakArray
import RtClosureInspect
import Data.Array
import Exception
import Control.Concurrent
-import Data.List (sortBy)
-- import Foreign.StablePtr
import System.IO
import System.IO.Unsafe
= History {
historyApStack :: HValue,
historyBreakInfo :: BreakInfo,
- historyEnclosingDecl :: Id
- -- ^^ A cache of the enclosing top level declaration, for convenience
+ historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint
}
mkHistory :: HscEnv -> HValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
- h = History hval bi decl
- decl = findEnclosingDecl hsc_env (getHistoryModule h)
- (getHistorySpan hsc_env h)
- in h
+ decls = findEnclosingDecls hsc_env bi
+ in History hval bi decls
+
getHistoryModule :: History -> Module
getHistoryModule = breakInfo_module . historyBreakInfo
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
- | Just linkable <- hm_linkable hmi,
+ | Just linkable <- hm_linkable hmi,
[BCOs _ modBreaks] <- linkableUnlinked linkable
= modBreaks
| otherwise
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
-- by the coverage pass, which gives the list of lexically-enclosing bindings
-- for each tick.
-findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
-findEnclosingDecl hsc_env mod span =
- case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
- Nothing -> panic "findEnclosingDecl"
- Just hmi -> let
- globals = typeEnvIds (md_types (hm_details hmi))
- Just decl =
- find (\id -> let n = idName id in
- nameSrcSpan n < span && isExternalName n)
- (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
- globals)
- in decl
+findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
+findEnclosingDecls hsc_env inf =
+ let hmi = expectJust "findEnclosingDecls" $
+ lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf)
+ mb = getModBreaks hmi
+ in modBreaks_decls mb ! breakInfo_number inf
+
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
hsc_env' = hsc_env{ hsc_dflags = dflags' }
- r <- hscStmt hsc_env' expr
+ r <- liftIO $ hscStmt hsc_env' expr
case r of
Nothing -> return RunFailed -- empty statement / comment
Just (ids, hval) -> do
- -- XXX: This is the only place we can print warnings before the
- -- result. Is this really the right thing to do? It's fine for
- -- GHCi, but what's correct for other GHC API clients? We could
- -- introduce a callback argument.
- warns <- getWarnings
- liftIO $ printBagOfWarnings dflags' warns
- clearWarnings
-
status <-
withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
gbracket set_cwd reset_cwd $ \_ -> m
parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName)
-parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr
+parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
emptyHistory :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50
export_env <- liftIO $ mkExportEnv hsc_env export_mods
import_env <-
if null imprt_decls then return emptyGlobalRdrEnv else do
- let imports = rnImports imprt_decls
- this_mod = if null toplev_mods then pRELUDE else head toplev_mods
- (_, env, _,_) <-
- ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports
- return env
+ let this_mod | null toplev_mods = pRELUDE
+ | otherwise = head toplev_mods
+ liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls
toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods
let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs
modifySession $ \_ ->
getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
getInfo name
= withSession $ \hsc_env ->
- do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
+ do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
case mb_stuff of
Nothing -> return Nothing
Just (thing, fixity, ispecs) -> do
-- the identifier can refer to in the current interactive context.
parseName :: GhcMonad m => String -> m [Name]
parseName str = withSession $ \hsc_env -> do
- (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
- ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
+ (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str
+ liftIO $ hscTcRnLookupRdrName hsc_env rdr_name
-- -----------------------------------------------------------------------------
-- Getting the type of an expression
-- | Get the type of an expression
exprType :: GhcMonad m => String -> m Type
exprType expr = withSession $ \hsc_env -> do
- ty <- hscTcExpr hsc_env expr
+ ty <- liftIO $ hscTcExpr hsc_env expr
return $ tidyType emptyTidyEnv ty
-- -----------------------------------------------------------------------------
-- | Get the kind of a type
typeKind :: GhcMonad m => String -> m Kind
typeKind str = withSession $ \hsc_env -> do
- hscKcType hsc_env str
+ liftIO $ hscKcType hsc_env str
-----------------------------------------------------------------------------
-- cmCompileExpr: compile an expression and deliver an HValue
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
- Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
+ Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
-- Run it!
hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])
(stringToPackageId "base") (mkModuleName "Data.Dynamic")
,Nothing):exports
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
- Just (ids, hvals) <- withSession (flip hscStmt stmt)
+ Just (ids, hvals) <- withSession $ \hsc_env ->
+ liftIO $ hscStmt hsc_env stmt
setContext full exports
vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
case (ids,vals) of
projects / ghc-hetmet.git / blobdiff