diff options
Diffstat (limited to 'ghc/GhciMonad.hs')
| -rw-r--r-- | ghc/GhciMonad.hs | 48 |
1 files changed, 23 insertions, 25 deletions
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index f1767c3ea5..f68d0b9a55 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -16,13 +16,12 @@ module GhciMonad ( Command, BreakLocation(..), TickArray, - setDynFlags, + getDynFlags, runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs, printForUser, printForUserPartWay, prettyLocations, initInterpBuffering, turnOffBuffering, flushInterpBuffers, - ghciHandleGhcException, ) where #include "HsVersions.h" @@ -31,7 +30,6 @@ import qualified GHC import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay) import qualified Outputable -import Panic hiding (showException) import Util import DynFlags import HscTypes @@ -39,7 +37,6 @@ import SrcLoc import Module import ObjLink import Linker -import StaticFlags import qualified MonadUtils import Exception @@ -55,7 +52,8 @@ import GHC.Exts import System.Console.Haskeline (CompletionFunc, InputT) import qualified System.Console.Haskeline as Haskeline -import Control.Monad.Trans as Trans +import Control.Monad.Trans.Class as Trans +import Control.Monad.IO.Class as Trans ----------------------------------------------------------------------------- -- GHCi monad @@ -171,9 +169,6 @@ instance Monad GHCi where instance Functor GHCi where fmap f m = m >>= return . f -ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a -ghciHandleGhcException = handleGhcException - getGHCiState :: GHCi GHCiState getGHCiState = GHCi $ \r -> liftIO $ readIORef r setGHCiState :: GHCiState -> GHCi () @@ -221,22 +216,22 @@ instance ExceptionMonad GHCi where instance MonadIO GHCi where liftIO = MonadUtils.liftIO +instance Haskeline.MonadException Ghc where + controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let + run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s) + in fmap (flip unGhc s) $ f run' + instance Haskeline.MonadException GHCi where - catch = gcatch - block = gblock - unblock = gunblock - -- XXX when Haskeline's MonadException changes, we can drop our - -- deprecated block/unblock methods + controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let + run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s) + in fmap (flip unGHCi s) $ f run' instance ExceptionMonad (InputT GHCi) where gcatch = Haskeline.catch - gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong - gblock = Haskeline.block - gunblock = Haskeline.unblock + gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_) -setDynFlags :: DynFlags -> GHCi [PackageId] -setDynFlags dflags = do - GHC.setSessionDynFlags dflags + gblock = Haskeline.liftIOOp_ gblock + gunblock = Haskeline.liftIOOp_ gunblock isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt @@ -256,12 +251,14 @@ unsetOption opt printForUser :: GhcMonad m => SDoc -> m () printForUser doc = do unqual <- GHC.getPrintUnqual - MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc + dflags <- getDynFlags + MonadUtils.liftIO $ Outputable.printForUser dflags stdout unqual doc printForUserPartWay :: SDoc -> GHCi () printForUserPartWay doc = do unqual <- GHC.getPrintUnqual - liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc + dflags <- getDynFlags + liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc -- | Run a single Haskell expression runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult) @@ -308,18 +305,19 @@ timeIt action a <- action allocs2 <- liftIO $ getAllocations time2 <- liftIO $ getCPUTime - liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) + dflags <- getDynFlags + liftIO $ printTimes dflags (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 +printTimes :: DynFlags -> Integer -> Integer -> IO () +printTimes dflags allocs psecs = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float secs_str = showFFloat (Just 2) secs - putStrLn (showSDoc ( + putStrLn (showSDoc dflags ( parens (text (secs_str "") <+> text "secs" <> comma <+> text (show allocs) <+> text "bytes"))) |