#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).

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index ef1879d..8374491 100644 (file)
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index d62b370..70a602f 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -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
                  }
 

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index a6ff043..6b59a59 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -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

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 510d876..36e6f7c 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -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