Commit 8099fc7e authored by mnislaih's avatar mnislaih

Split the GHCi monad apart from InteractiveUI, together with some related functions

I found this convenient while I was extending ghci with the debugger. I wanted to put all the debugger stuff in a separate module, but I would need a huge hs-boot file to break the circular dependencies. This option seemed better
parent f9a0b197
module GhciMonad where
#include "HsVersions.h"
import qualified GHC
import {-#SOURCE#-} Debugger
import Breakpoints
import Outputable
import Panic hiding (showException)
import Util
import Numeric
import Control.Exception as Exception
import Data.Char
import Data.Dynamic
import Data.Int ( Int64 )
import Data.IORef
import Data.Typeable
import System.CPUTime
import System.IO
import Control.Monad as Monad
import GHC.Exts
-----------------------------------------------------------------------------
-- GHCi monad
data GHCiState = GHCiState
{
progname :: String,
args :: [String],
prompt :: String,
editor :: String,
session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module
}
data GHCiOption
= ShowTiming -- show time/allocs after evaluation
| ShowType -- show the type of expressions
| RevertCAFs -- revert CAFs after every evaluation
deriving Eq
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
startGHCi :: GHCi a -> GHCiState -> IO a
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
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 $ \r -> readIORef r
setGHCiState s = GHCi $ \r -> writeIORef r s
-- for convenience...
getSession = getGHCiState >>= return . session
getPrelude = getGHCiState >>= return . prelude
GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
no_saved_sess = error "no saved_ses"
saveSession = getSession >>= io . writeIORef saved_sess
splatSavedSession = io (writeIORef saved_sess no_saved_sess)
restoreSession = readIORef saved_sess
getDynFlags = do
s <- getSession
io (GHC.getSessionDynFlags s)
setDynFlags dflags = do
s <- getSession
io (GHC.setSessionDynFlags s dflags)
isOptionSet :: GHCiOption -> GHCi Bool
isOptionSet opt
= do st <- getGHCiState
return (opt `elem` options st)
setOption :: GHCiOption -> GHCi ()
setOption opt
= do st <- getGHCiState
setGHCiState (st{ options = opt : filter (/= opt) (options st) })
unsetOption :: GHCiOption -> GHCi ()
unsetOption opt
= do st <- getGHCiState
setGHCiState (st{ options = filter (/= opt) (options st) })
io :: IO a -> GHCi a
io m = GHCi { unGHCi = \s -> m >>= return }
showForUser :: SDoc -> GHCi String
showForUser doc = do
session <- getSession
unqual <- io (GHC.getPrintUnqual session)
return $! showSDocForUser unqual doc
-----------------------------------------------------------------------------
-- User code exception handling
-- 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))
-----------------------------------------------------------------------------
-- 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
timeIt action
= do b <- isOptionSet ShowTiming
if not b
then action
else do allocs1 <- io $ getAllocations
time1 <- io $ getCPUTime
a <- action
allocs2 <- io $ getAllocations
time2 <- io $ getCPUTime
io $ printTimes (fromIntegral (allocs2 - allocs1))
(time2 - time1)
return a
foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
-- defined in ghc/rts/Stats.c
printTimes :: Integer -> Integer -> IO ()
printTimes allocs psecs
= do let secs = (fromIntegral psecs / (10^12)) :: Float
secs_str = showFFloat (Just 2) secs
putStrLn (showSDoc (
parens (text (secs_str "") <+> text "secs" <> comma <+>
text (show allocs) <+> text "bytes")))
-----------------------------------------------------------------------------
-- reverting CAFs
revertCAFs :: IO ()
revertCAFs = do
rts_revertCAFs
turnOffBuffering
-- Have to turn off buffering again, because we just
-- reverted stdout, stderr & stdin to their defaults.
foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
-- Make it "safe", just in case
-----------------------------------------------------------------------------
-- To flush buffers for the *interpreted* computation we need
-- to refer to *its* stdout/stderr handles
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"
initInterpBuffering :: Session -> IO ()
initInterpBuffering session
= do 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"
maybe_hval <- GHC.compileExpr session flush_cmd
case maybe_hval of
Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
_ -> panic "interactiveUI:flush"
return ()
flushInterpBuffers :: GHCi ()
flushInterpBuffers
= io $ do Monad.join (readIORef flush_interp)
return ()
turnOffBuffering :: IO ()
turnOffBuffering
= do Monad.join (readIORef turn_off_buffering)
return ()
......@@ -71,7 +71,6 @@ import System.Console.Readline as Readline
--import SystemExts
import Control.Exception as Exception
import Data.Dynamic
-- import Control.Concurrent
import Numeric
......@@ -79,7 +78,6 @@ import Data.List
import Data.Int ( Int64 )
import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
import System.Cmd
import System.CPUTime
import System.Environment
import System.Exit ( exitWith, ExitCode(..) )
import System.Directory
......@@ -557,32 +555,6 @@ runCommandEval c = ghciHandle handleEval (doCommand c)
-- failure to run the command causes exit(1) for ghc -e.
_ -> finishEvalExpr nms
-- This is the exception handler for exceptions generated by the
-- user's code; 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 -> GHCi Bool
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))
runStmt :: String -> GHCi (Maybe [Name])
runStmt stmt
| null (filter (not.isSpace) stmt) = return (Just [])
......@@ -617,12 +589,6 @@ showTypeOfName session n
Nothing -> return ()
Just thing -> showTyThing thing
showForUser :: SDoc -> GHCi String
showForUser doc = do
session <- getSession
unqual <- io (GHC.getPrintUnqual session)
return $! showSDocForUser unqual doc
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
......@@ -643,43 +609,6 @@ lookupCommand str = do
[] -> return Nothing
c:_ -> return (Just c)
-----------------------------------------------------------------------------
-- To flush buffers for the *interpreted* computation we need
-- to refer to *its* stdout/stderr handles
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"
initInterpBuffering :: Session -> IO ()
initInterpBuffering session
= do 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"
maybe_hval <- GHC.compileExpr session flush_cmd
case maybe_hval of
Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
_ -> panic "interactiveUI:flush"
return ()
flushInterpBuffers :: GHCi ()
flushInterpBuffers
= io $ do Monad.join (readIORef flush_interp)
return ()
turnOffBuffering :: IO ()
turnOffBuffering
= do Monad.join (readIORef turn_off_buffering)
return ()
-----------------------------------------------------------------------------
-- Commands
......@@ -1465,133 +1394,6 @@ completeFilename = completeNone
completeHomeModuleOrFile=completeNone
#endif
-----------------------------------------------------------------------------
-- GHCi monad
data GHCiState = GHCiState
{
progname :: String,
args :: [String],
prompt :: String,
editor :: String,
session :: GHC.Session,
options :: [GHCiOption],
prelude :: Module
}
data GHCiOption
= ShowTiming -- show time/allocs after evaluation
| ShowType -- show the type of expressions
| RevertCAFs -- revert CAFs after every evaluation
deriving Eq
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
startGHCi :: GHCi a -> GHCiState -> IO a
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
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 $ \r -> readIORef r
setGHCiState s = GHCi $ \r -> writeIORef r s
-- for convenience...
getSession = getGHCiState >>= return . session
getPrelude = getGHCiState >>= return . prelude
GLOBAL_VAR(saved_sess, no_saved_sess, Session)
no_saved_sess = error "no saved_ses"
saveSession = getSession >>= io . writeIORef saved_sess
splatSavedSession = io (writeIORef saved_sess no_saved_sess)
restoreSession = readIORef saved_sess
getDynFlags = do
s <- getSession
io (GHC.getSessionDynFlags s)
setDynFlags dflags = do
s <- getSession
io (GHC.setSessionDynFlags s dflags)
isOptionSet :: GHCiOption -> GHCi Bool
isOptionSet opt
= do st <- getGHCiState
return (opt `elem` options st)
setOption :: GHCiOption -> GHCi ()
setOption opt
= do st <- getGHCiState
setGHCiState (st{ options = opt : filter (/= opt) (options st) })
unsetOption :: GHCiOption -> GHCi ()
unsetOption opt
= do st <- getGHCiState
setGHCiState (st{ options = filter (/= opt) (options st) })
io :: IO a -> GHCi a
io m = GHCi { unGHCi = \s -> m >>= return }
-----------------------------------------------------------------------------
-- 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
timeIt action
= do b <- isOptionSet ShowTiming
if not b
then action
else do allocs1 <- io $ getAllocations
time1 <- io $ getCPUTime
a <- action
allocs2 <- io $ getAllocations
time2 <- io $ getCPUTime
io $ printTimes (fromIntegral (allocs2 - allocs1))
(time2 - time1)
return a
foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
-- defined in ghc/rts/Stats.c
printTimes :: Integer -> Integer -> IO ()
printTimes allocs psecs
= do let secs = (fromIntegral psecs / (10^12)) :: Float
secs_str = showFFloat (Just 2) secs
putStrLn (showSDoc (
parens (text (secs_str "") <+> text "secs" <> comma <+>
text (show allocs) <+> text "bytes")))
-----------------------------------------------------------------------------
-- reverting CAFs
revertCAFs :: IO ()
revertCAFs = do
rts_revertCAFs
turnOffBuffering
-- Have to turn off buffering again, because we just
-- reverted stdout, stderr & stdin to their defaults.
foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
-- Make it "safe", just in case
-- ----------------------------------------------------------------------------
-- Utils
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment