X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2FGhciMonad.hs;h=2aff48385e3d5962cb00282ea11d3f6415e3f13f;hb=fdf8656855d26105ff36bdd24d41827b05037b91;hp=ff34963b6347c06e48a84abd551947a9603cd4d5;hpb=1c83695b5b9ae3175c18908c1d58aeadb1f225ae;p=ghc-hetmet.git diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index ff34963..2aff483 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -14,29 +14,25 @@ module GhciMonad where #include "HsVersions.h" import qualified GHC +import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay) -import qualified Pretty import qualified Outputable import Panic hiding (showException) import Util import DynFlags -import HscTypes hiding (liftIO) +import HscTypes import SrcLoc import Module import ObjLink import Linker import StaticFlags import qualified MonadUtils -import qualified ErrUtils import Exception -import Data.Maybe import Numeric import Data.Array -import Data.Char import Data.Int ( Int64 ) import Data.IORef -import Data.List import System.CPUTime import System.Environment import System.IO @@ -45,9 +41,7 @@ import GHC.Exts import System.Console.Haskeline (CompletionFunc, InputT) import qualified System.Console.Haskeline as Haskeline -import System.Console.Haskeline.Encoding import Control.Monad.Trans as Trans -import qualified Data.ByteString as B ----------------------------------------------------------------------------- -- GHCi monad @@ -63,6 +57,7 @@ data GHCiState = GHCiState stop :: String, options :: [GHCiOption], prelude :: GHC.Module, + line_number :: !Int, -- input line break_ctr :: !Int, breaks :: ![(Int, BreakLocation)], tickarrays :: ModuleEnv TickArray, @@ -73,7 +68,7 @@ data GHCiState = GHCiState -- remember is here: last_command :: Maybe Command, cmdqueue :: [String], - remembered_ctx :: [(CtxtCmd, [String], [String])], + remembered_ctx :: [CtxtCmd], -- 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 @@ -83,10 +78,12 @@ data GHCiState = GHCiState ghc_e :: Bool -- True if this is 'ghc -e' (or runghc) } -data CtxtCmd - = SetContext - | AddModules - | RemModules +data CtxtCmd -- In each case, the first [String] are the starred modules + -- and the second are the unstarred ones + = SetContext [String] [String] + | AddModules [String] [String] + | RemModules [String] [String] + | Import String type TickArray = Array Int [(BreakIndex,SrcSpan)] @@ -94,6 +91,7 @@ data GHCiOption = ShowTiming -- show time/allocs after evaluation | ShowType -- show the type of expressions | RevertCAFs -- revert CAFs after every evaluation + | Multiline -- use multiline commands deriving Eq data BreakLocation @@ -184,31 +182,32 @@ instance GhcMonad (InputT GHCi) where instance MonadUtils.MonadIO (InputT GHCi) where liftIO = Trans.liftIO -instance WarnLogMonad (InputT GHCi) where - setWarnings = lift . setWarnings - getWarnings = lift getWarnings - instance ExceptionMonad GHCi where gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) gblock (GHCi m) = GHCi $ \r -> gblock (m r) gunblock (GHCi m) = GHCi $ \r -> gunblock (m r) - -instance WarnLogMonad GHCi where - setWarnings warns = liftGhc $ setWarnings warns - getWarnings = liftGhc $ getWarnings + gmask f = + GHCi $ \s -> gmask $ \io_restore -> + let + g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s') + in + unGHCi (f g_restore) s instance MonadIO GHCi where - liftIO = io + liftIO = MonadUtils.liftIO 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 instance ExceptionMonad (InputT GHCi) where - gcatch = Haskeline.catch - gblock = Haskeline.block - gunblock = Haskeline.unblock + gcatch = Haskeline.catch + gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong + gblock = Haskeline.block + gunblock = Haskeline.unblock -- for convenience... getPrelude :: GHCi Module @@ -237,44 +236,15 @@ unsetOption opt = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) -io :: IO a -> GHCi a -io = MonadUtils.liftIO - -printForUser :: SDoc -> GHCi () +printForUser :: GhcMonad m => SDoc -> m () printForUser doc = do unqual <- GHC.getPrintUnqual - io $ Outputable.printForUser stdout unqual doc - -printForUser' :: SDoc -> InputT GHCi () -printForUser' doc = do - unqual <- GHC.getPrintUnqual - Haskeline.outputStrLn $ showSDocForUser unqual doc + MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc printForUserPartWay :: SDoc -> GHCi () printForUserPartWay doc = do unqual <- GHC.getPrintUnqual - io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc - --- We set log_action to write encoded output. --- This fails whenever GHC tries to mention an (already encoded) filename, --- but I don't know how to work around that. -setLogAction :: InputT GHCi () -setLogAction = do - encoder <- getEncoder - dflags <- GHC.getSessionDynFlags - GHC.setSessionDynFlags dflags {log_action = logAction encoder} - return () - where - logAction encoder severity srcSpan style msg = case severity of - GHC.SevInfo -> printEncErrs encoder (msg style) - GHC.SevFatal -> printEncErrs encoder (msg style) - _ -> do - hPutChar stderr '\n' - printEncErrs encoder (ErrUtils.mkLocMessage srcSpan msg style) - printEncErrs encoder doc = do - str <- encoder (Pretty.showDocWith Pretty.PageMode doc) - B.hPutStrLn stderr str - hFlush stderr + liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult runStmt expr step = do @@ -283,12 +253,18 @@ runStmt expr step = do withProgName (progname st) $ withArgs (args st) $ reflectGHCi x $ do - GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e + GHC.handleSourceError (\e -> do GHC.printException e return GHC.RunFailed) $ do - GHC.runStmt expr step + GHC.runStmtWithLocation (progname st) (line_number st) expr step resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult -resume canLogSpan step = GHC.resume canLogSpan step +resume canLogSpan step = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.resume canLogSpan step -- -------------------------------------------------------------------------- -- timing & statistics @@ -323,9 +299,9 @@ printTimes allocs psecs revertCAFs :: GHCi () revertCAFs = do - io $ rts_revertCAFs + liftIO rts_revertCAFs s <- getGHCiState - when (not (ghc_e s)) $ io turnOffBuffering + when (not (ghc_e s)) $ liftIO turnOffBuffering -- Have to turn off buffering again, because we just -- reverted stdout, stderr & stdin to their defaults. @@ -369,14 +345,13 @@ initInterpBuffering = do -- make sure these are linked let f ref (Just ptr) = writeIORef ref ptr f _ Nothing = panic "interactiveUI:setBuffering2" - zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr] - [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] - return () + zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr] + [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr] flushInterpBuffers :: GHCi () flushInterpBuffers - = io $ do getHandle stdout_ptr >>= hFlush - getHandle stderr_ptr >>= hFlush + = liftIO $ do getHandle stdout_ptr >>= hFlush + getHandle stderr_ptr >>= hFlush turnOffBuffering :: IO () turnOffBuffering