X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=36e6f7c2c82fbdcab7b262133bec2fb0f55c7a22;hb=e5a8d57c85d42007c8cc561e6d6b805c23603fc0;hp=9fe7504163ca48feee0257f4f0d06f3f503d320a;hpb=1f3a7730cd7f831344d2a3b74a0ce700c382e858;p=ghc-hetmet.git

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 9fe7504..36e6f7c 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -47,7 +47,6 @@ import TcType           hiding (typeKind)
 import InstEnv
 import Var
 import Id
-import IdInfo
 import Name             hiding ( varName )
 import NameSet
 import RdrName
@@ -72,6 +71,7 @@ import Outputable
 import FastString
 import MonadUtils
 
+import System.Directory
 import Data.Dynamic
 import Data.List (find)
 import Control.Monad
@@ -213,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
@@ -228,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
 
@@ -437,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
@@ -523,8 +547,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
        e_fs      = fsLit "e"
        e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
-       exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
-                                vanillaIdInfo
+       exn_id    = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
        new_tyvars = unitVarSet e_tyvar
 
        ictxt0 = hsc_IC hsc_env
@@ -575,8 +598,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
    -- _result in scope at any time.
    let result_name = mkInternalName (getUnique result_fs)
                           (mkVarOccFS result_fs) span
-       result_id   = Id.mkGlobalId VanillaGlobal result_name result_ty 
-                                   vanillaIdInfo
+       result_id   = Id.mkVanillaGlobal result_name result_ty 
 
    -- for each Id we're about to bind in the local envt:
    --    - skolemise the type variables in its type, so they can't
@@ -610,7 +632,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
          loc = nameSrcSpan (idName id)
          name = mkInternalName uniq occ loc
          ty = idType id
-         new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
+         new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
      return new_id
 
 rttiEnvironment :: HscEnv -> IO HscEnv