+-----------------------------------------------------------------------------
+--
+-- Monadery code used in InteractiveUI
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
module GhciMonad where
#include "HsVersions.h"
import Outputable
import Panic hiding (showException)
import Util
+import DynFlags
import Numeric
import Control.Exception as Exception
import Data.Dynamic
import Data.Int ( Int64 )
import Data.IORef
+import Data.List
import Data.Typeable
import System.CPUTime
import System.IO
editor :: String,
session :: GHC.Session,
options :: [GHCiOption],
- prelude :: GHC.Module
+ prelude :: GHC.Module,
+ bkptTable :: IORef (BkptTable GHC.Module),
+ topLevel :: Bool
}
data GHCiOption
io :: IO a -> GHCi a
io m = GHCi { unGHCi = \s -> m >>= return }
+isTopLevel :: GHCi Bool
+isTopLevel = getGHCiState >>= return . topLevel
+
+getBkptTable :: GHCi (BkptTable GHC.Module)
+getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
+ io$ readIORef table_ref
+
+setBkptTable :: BkptTable GHC.Module -> GHCi ()
+setBkptTable new_table = do
+ table_ref <- getGHCiState >>= return . bkptTable
+ io$ writeIORef table_ref new_table
+
+modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
+modifyBkptTable f = do
+ bt <- getBkptTable
+ new_bt <- io . evaluate$ f bt
+ setBkptTable new_bt
+
showForUser :: SDoc -> GHCi String
showForUser doc = do
session <- getSession
unqual <- io (GHC.getPrintUnqual session)
return $! showSDocForUser unqual doc
------------------------------------------------------------------------------
--- User code exception handling
+-- --------------------------------------------------------------------------
+-- Inferior Sessions Exceptions (used by the debugger)
--- This is the exception handler for exceptions generated by the
--- user's code and exceptions coming from children sessions;
--- it normally just prints out the exception. The
--- handler must be recursive, in case showing the exception causes
--- more exceptions to be raised.
---
--- Bugfix: if the user closed stdout or stderr, the flushing will fail,
--- raising another exception. We therefore don't put the recursive
--- handler arond the flushing operation, so if stderr is closed
--- GHCi will just die gracefully rather than going into an infinite loop.
-handler exception = do
- flushInterpBuffers
- io installSignalHandlers
- ghciHandle handler (showException exception >> return False)
-
-showException (DynException dyn) =
- case fromDynamic dyn of
- Nothing -> io (putStrLn ("*** Exception: (unknown)"))
- Just Interrupted -> io (putStrLn "Interrupted.")
- Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
- Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
- Just other_ghc_ex -> io (print other_ghc_ex)
-
-showException other_exception
- = io (putStrLn ("*** Exception: " ++ show other_exception))
+data InfSessionException =
+ StopChildSession -- A child session requests to be stopped
+ | StopParentSession -- A child session requests to be stopped
+ -- AND that the parent session quits after that
+ | ChildSessionStopped String -- A child session has stopped
+ deriving Typeable
------------------------------------------------------------------------------
--- recursive exception handlers
--- Don't forget to unblock async exceptions in the handler, or if we're
--- in an exception loop (eg. let a = error a in a) the ^C exception
--- may never be delivered. Thanks to Marcin for pointing out the bug.
-
-ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
-ghciHandle h (GHCi m) = GHCi $ \s ->
- Exception.catch (m s)
- (\e -> unGHCi (ghciUnblock (h e)) s)
-
-ghciUnblock :: GHCi a -> GHCi a
-ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
-
------------------------------------------------------------------------------
+-- --------------------------------------------------------------------------
-- timing & statistics
timeIt :: GHCi a -> GHCi a
GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
-no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
- " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
-flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr"
+command_sequence :: [String] -> String
+command_sequence = unwords . intersperse "Prelude.>>"
+
+no_buffer :: String -> String
+no_buffer h = unwords ["System.IO.hSetBuffering",
+ "System.IO." ++ h,
+ "System.IO.NoBuffering"]
+
+no_buf_cmd :: String
+no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
-initInterpBuffering :: Session -> IO ()
+flush_buffer :: String -> String
+flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
+
+flush_cmd :: String
+flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
+
+initInterpBuffering :: GHC.Session -> IO ()
initInterpBuffering session
- = do maybe_hval <- GHC.compileExpr session no_buf_cmd
-
+ = do -- we don't want to be fooled by any modules lying around in the current
+ -- directory when we compile these code fragments, so set the import
+ -- path to be empty while we compile them.
+ dflags <- GHC.getSessionDynFlags session
+ GHC.setSessionDynFlags session dflags{importPaths=[]}
+
+ maybe_hval <- GHC.compileExpr session no_buf_cmd
+
case maybe_hval of
Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
other -> panic "interactiveUI:setBuffering"
Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
_ -> panic "interactiveUI:flush"
+ GHC.setSessionDynFlags session dflags
+ GHC.workingDirectoryChanged session
return ()