Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Split the GHCi monad apart from InteractiveUI, together with some rel…
…ated 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
- Loading branch information
1 parent
f9a0b19
commit 8099fc7
Showing
2 changed files
with
221 additions
and
198 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,221 @@ | ||
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 () |
Oops, something went wrong.