Commit 7f1db085 authored by Simon Marlow's avatar Simon Marlow

#2973: we should virtualise the CWD inside the GHC API, not in the client

The problem is that we install the client's CWD before calling
runStmt, but runStmt has to load modules before running the code.  We
need to install the CWD just before running the code instead, which
means it has to be done inside runStmt (and resume).
parent ce6ff822
......@@ -36,7 +36,6 @@ import Data.Int ( Int64 )
import Data.IORef
import Data.List
import System.CPUTime
import System.Directory
import System.Environment
import System.IO
import Control.Monad as Monad
......@@ -73,7 +72,6 @@ data GHCiState = GHCiState
-- were supposed to be in the context but currently had errors,
-- but this was complicated. Just replaying the :module commands
-- seems to be the right thing.
virtual_path :: FilePath,
ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
}
......@@ -239,19 +237,8 @@ printForUserPartWay doc = do
unqual <- GHC.getPrintUnqual
io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
withVirtualPath :: GHCi a -> GHCi a
withVirtualPath m = do
ghci_wd <- io getCurrentDirectory -- Store the cwd of GHCi
st <- getGHCiState
io$ setCurrentDirectory (virtual_path st)
result <- m -- Evaluate in the virtual wd..
vwd <- io getCurrentDirectory
setGHCiState (st{ virtual_path = vwd}) -- Update the virtual path
io$ setCurrentDirectory ghci_wd -- ..and restore GHCi wd
return result
runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
runStmt expr step = withVirtualPath$ do
runStmt expr step = do
st <- getGHCiState
reifyGHCi $ \x ->
withProgName (progname st) $
......@@ -262,9 +249,7 @@ runStmt expr step = withVirtualPath$ do
GHC.runStmt expr step
resume :: GHC.SingleStep -> GHCi GHC.RunResult
resume step = withVirtualPath$ do
GHC.resume step
resume step = GHC.resume step
-- --------------------------------------------------------------------------
-- timing & statistics
......
......@@ -340,8 +340,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do
default_editor <- liftIO $ findEditor
cwd <- liftIO $ getCurrentDirectory
startGHCi (runGHCi srcs maybe_exprs)
GHCiState{ progname = "<interactive>",
args = [],
......@@ -357,7 +355,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do
last_command = Nothing,
cmdqueue = [],
remembered_ctx = [],
virtual_path = cwd,
ghc_e = isJust maybe_exprs
}
......
......@@ -1149,6 +1149,8 @@ data InteractiveContext
#ifdef GHCI
, ic_resume :: [Resume] -- ^ The stack of breakpoint contexts
#endif
, ic_cwd :: Maybe FilePath -- virtual CWD of the program
}
......@@ -1162,6 +1164,7 @@ emptyInteractiveContext
#ifdef GHCI
, ic_resume = []
#endif
, ic_cwd = Nothing
}
icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
......
......@@ -71,6 +71,7 @@ import Outputable
import FastString
import MonadUtils
import System.Directory
import Data.Dynamic
import Data.List (find)
import Control.Monad
......@@ -212,6 +213,7 @@ runStmt expr step =
clearWarnings
status <-
withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
let thing_to_run = unsafeCoerce# hval :: IO [HValue]
liftIO $ sandboxIO dflags' statusMVar thing_to_run
......@@ -227,6 +229,28 @@ runStmt expr step =
handleRunStatus expr bindings ids
breakMVar statusMVar status emptyHistory
withVirtualCWD :: GhcMonad m => m a -> m a
withVirtualCWD m = do
hsc_env <- getSession
let ic = hsc_IC hsc_env
let set_cwd = do
dir <- liftIO $ getCurrentDirectory
case ic_cwd ic of
Just dir -> liftIO $ setCurrentDirectory dir
Nothing -> return ()
return dir
reset_cwd orig_dir = do
virt_dir <- liftIO $ getCurrentDirectory
hsc_env <- getSession
let old_IC = hsc_IC hsc_env
setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
liftIO $ setCurrentDirectory orig_dir
gbracket set_cwd reset_cwd $ \_ -> m
emptyHistory :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50
......@@ -436,6 +460,7 @@ resume step
case r of
Resume expr tid breakMVar statusMVar bindings
final_ids apStack info _ hist _ -> do
withVirtualCWD $ do
withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do
status <- liftIO $ withInterruptsSentTo tid $ do
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment