--
-----------------------------------------------------------------------------
-{-# 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"
import SrcLoc
import Module
import ObjLink
+import Linker
import StaticFlags
import Data.Maybe
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
-----------------------------------------------------------------------------
-- GHCi monad
-type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
+type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String])
data GHCiState = GHCiState
{
-- remember is here:
last_command :: Maybe Command,
cmdqueue :: [String],
- remembered_ctx :: Maybe ([Module],[Module])
- -- modules we want to add to the context, but can't
- -- because they currently have errors. Set by :reload.
+ 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
+ = SetContext
+ | AddModules
+ | RemModules
+
type TickArray = Array Int [(BreakIndex,SrcSpan)]
data GHCiOption
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
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)
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
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
-----------------------------------------------------------------------------
-- 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.
initInterpBuffering :: GHC.Session -> IO ()
initInterpBuffering session
= do -- make sure these are linked
- mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
- mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
- mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
- when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
- panic "interactiveUI:setBuffering"
+ dflags <- GHC.getSessionDynFlags session
+ initDynLinker dflags
-- ToDo: we should really look up these names properly, but
-- it's a fiddle and not all the bits are exposed via the GHC
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 ()
projects / ghc-hetmet.git / blobdiff