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 ) ...@@ -36,7 +36,6 @@ import Data.Int ( Int64 )
import Data.IORef import Data.IORef
import Data.List import Data.List
import System.CPUTime import System.CPUTime
import System.Directory
import System.Environment import System.Environment
import System.IO import System.IO
import Control.Monad as Monad import Control.Monad as Monad
...@@ -73,7 +72,6 @@ data GHCiState = GHCiState ...@@ -73,7 +72,6 @@ data GHCiState = GHCiState
-- were supposed to be in the context but currently had errors, -- were supposed to be in the context but currently had errors,
-- but this was complicated. Just replaying the :module commands -- but this was complicated. Just replaying the :module commands
-- seems to be the right thing. -- seems to be the right thing.
virtual_path :: FilePath,
ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
} }
...@@ -239,19 +237,8 @@ printForUserPartWay doc = do ...@@ -239,19 +237,8 @@ printForUserPartWay doc = do
unqual <- GHC.getPrintUnqual unqual <- GHC.getPrintUnqual
io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc 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 :: String -> GHC.SingleStep -> GHCi GHC.RunResult
runStmt expr step = withVirtualPath$ do runStmt expr step = do
st <- getGHCiState st <- getGHCiState
reifyGHCi $ \x -> reifyGHCi $ \x ->
withProgName (progname st) $ withProgName (progname st) $
...@@ -262,9 +249,7 @@ runStmt expr step = withVirtualPath$ do ...@@ -262,9 +249,7 @@ runStmt expr step = withVirtualPath$ do
GHC.runStmt expr step GHC.runStmt expr step
resume :: GHC.SingleStep -> GHCi GHC.RunResult resume :: GHC.SingleStep -> GHCi GHC.RunResult
resume step = withVirtualPath$ do resume step = GHC.resume step
GHC.resume step
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
-- timing & statistics -- timing & statistics
......
...@@ -340,8 +340,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do ...@@ -340,8 +340,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do
default_editor <- liftIO $ findEditor default_editor <- liftIO $ findEditor
cwd <- liftIO $ getCurrentDirectory
startGHCi (runGHCi srcs maybe_exprs) startGHCi (runGHCi srcs maybe_exprs)
GHCiState{ progname = "<interactive>", GHCiState{ progname = "<interactive>",
args = [], args = [],
...@@ -357,7 +355,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do ...@@ -357,7 +355,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do
last_command = Nothing, last_command = Nothing,
cmdqueue = [], cmdqueue = [],
remembered_ctx = [], remembered_ctx = [],
virtual_path = cwd,
ghc_e = isJust maybe_exprs ghc_e = isJust maybe_exprs
} }
......
...@@ -1149,6 +1149,8 @@ data InteractiveContext ...@@ -1149,6 +1149,8 @@ data InteractiveContext
#ifdef GHCI #ifdef GHCI
, ic_resume :: [Resume] -- ^ The stack of breakpoint contexts , ic_resume :: [Resume] -- ^ The stack of breakpoint contexts
#endif #endif
, ic_cwd :: Maybe FilePath -- virtual CWD of the program
} }
...@@ -1162,6 +1164,7 @@ emptyInteractiveContext ...@@ -1162,6 +1164,7 @@ emptyInteractiveContext
#ifdef GHCI #ifdef GHCI
, ic_resume = [] , ic_resume = []
#endif #endif
, ic_cwd = Nothing
} }
icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
......
...@@ -71,6 +71,7 @@ import Outputable ...@@ -71,6 +71,7 @@ import Outputable
import FastString import FastString
import MonadUtils import MonadUtils
import System.Directory
import Data.Dynamic import Data.Dynamic
import Data.List (find) import Data.List (find)
import Control.Monad import Control.Monad
...@@ -212,6 +213,7 @@ runStmt expr step = ...@@ -212,6 +213,7 @@ runStmt expr step =
clearWarnings clearWarnings
status <- status <-
withVirtualCWD $
withBreakAction (isStep step) dflags' breakMVar statusMVar $ do withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
let thing_to_run = unsafeCoerce# hval :: IO [HValue] let thing_to_run = unsafeCoerce# hval :: IO [HValue]
liftIO $ sandboxIO dflags' statusMVar thing_to_run liftIO $ sandboxIO dflags' statusMVar thing_to_run
...@@ -227,6 +229,28 @@ runStmt expr step = ...@@ -227,6 +229,28 @@ runStmt expr step =
handleRunStatus expr bindings ids handleRunStatus expr bindings ids
breakMVar statusMVar status emptyHistory 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 :: BoundedList History
emptyHistory = nilBL 50 -- keep a log of length 50 emptyHistory = nilBL 50 -- keep a log of length 50
...@@ -436,6 +460,7 @@ resume step ...@@ -436,6 +460,7 @@ resume step
case r of case r of
Resume expr tid breakMVar statusMVar bindings Resume expr tid breakMVar statusMVar bindings
final_ids apStack info _ hist _ -> do final_ids apStack info _ hist _ -> do
withVirtualCWD $ do
withBreakAction (isStep step) (hsc_dflags hsc_env) withBreakAction (isStep step) (hsc_dflags hsc_env)
breakMVar statusMVar $ do breakMVar statusMVar $ do
status <- liftIO $ withInterruptsSentTo tid $ 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