X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=80512e7b1001c5d12c75a6d31021c5f7529f06e9;hb=f5edc6b0871a0debbc9a64f4cdb95c0dc35e5b16;hp=e56c4de2c4e08b39300d58bb55cba49d527f2e96;hpb=eea143f8588519000033279518877f85180b3e0f;p=ghc-hetmet.git

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index e56c4de..80512e7 100644
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -6,13 +6,6 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module GhciMonad where
 
 #include "HsVersions.h"
@@ -39,6 +32,8 @@ import Data.IORef
 import Data.List
 import Data.Typeable
 import System.CPUTime
+import System.Directory
+import System.Environment
 import System.IO
 import Control.Monad as Monad
 import GHC.Exts
@@ -68,13 +63,15 @@ data GHCiState = GHCiState
         -- remember is here:
         last_command   :: Maybe Command,
         cmdqueue       :: [String],
-        remembered_ctx :: [(CtxtCmd, [String], [String])]
+        remembered_ctx :: [(CtxtCmd, [String], [String])],
              -- we remember the :module commands between :loads, so that
              -- on a :reload we can replay them.  See bugs #2049,
              -- #1873, #1360. Previously we tried to remember modules that
              -- 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)
      }
 
 data CtxtCmd
@@ -134,7 +131,7 @@ startGHCi g state = do ref <- newIORef state; unGHCi g ref
 
 instance Monad GHCi where
   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
-  return a  = GHCi $ \s -> return a
+  return a  = GHCi $ \_ -> return a
 
 instance Functor GHCi where
     fmap f m = m >>= return . f
@@ -143,22 +140,36 @@ ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
 ghciHandleDyn h (GHCi m) = GHCi $ \s -> 
    Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
 
+getGHCiState :: GHCi GHCiState
 getGHCiState   = GHCi $ \r -> readIORef r
+setGHCiState :: GHCiState -> GHCi ()
 setGHCiState s = GHCi $ \r -> writeIORef r s
 
 -- for convenience...
+getSession :: GHCi Session
 getSession = getGHCiState >>= return . session
+getPrelude :: GHCi Module
 getPrelude = getGHCiState >>= return . prelude
 
 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
+
+no_saved_sess :: Session
 no_saved_sess = error "no saved_ses"
+
+saveSession :: GHCi ()
 saveSession = getSession >>= io . writeIORef saved_sess
+
+splatSavedSession :: GHCi ()
 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
+
+restoreSession :: IO Session
 restoreSession = readIORef saved_sess
 
+getDynFlags :: GHCi DynFlags
 getDynFlags = do
   s <- getSession
   io (GHC.getSessionDynFlags s)
+setDynFlags :: DynFlags -> GHCi [PackageId]
 setDynFlags dflags = do 
   s <- getSession 
   io (GHC.setSessionDynFlags s dflags)
@@ -179,7 +190,7 @@ unsetOption opt
       setGHCiState (st{ options = filter (/= opt) (options st) })
 
 io :: IO a -> GHCi a
-io m = GHCi { unGHCi = \s -> m >>= return }
+io m = GHCi (\_ -> m)
 
 printForUser :: SDoc -> GHCi ()
 printForUser doc = do
@@ -193,6 +204,30 @@ printForUserPartWay doc = do
   unqual <- io (GHC.getPrintUnqual session)
   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
+  session <- getSession
+  st      <- getGHCiState
+  io$ withProgName (progname st) $ withArgs (args st) $
+                    GHC.runStmt session expr step
+
+resume :: GHC.SingleStep -> GHCi GHC.RunResult
+resume step = withVirtualPath$ do
+  session <- getSession
+  io$ GHC.resume session step
+
+
 -- --------------------------------------------------------------------------
 -- timing & statistics
 
@@ -224,10 +259,11 @@ printTimes allocs psecs
 -----------------------------------------------------------------------------
 -- reverting CAFs
 	
-revertCAFs :: IO ()
+revertCAFs :: GHCi ()
 revertCAFs = do
-  rts_revertCAFs
-  turnOffBuffering
+  io $ rts_revertCAFs
+  s <- getGHCiState
+  when (not (ghc_e s)) $ io turnOffBuffering
 	-- Have to turn off buffering again, because we just 
 	-- reverted stdout, stderr & stdin to their defaults.
 
@@ -273,7 +309,7 @@ initInterpBuffering session
       mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
 
       let f ref (Just ptr) = writeIORef ref ptr
-          f ref Nothing    = panic "interactiveUI:setBuffering2"
+          f _   Nothing    = panic "interactiveUI:setBuffering2"
       zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
       return ()