#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
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
-- 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
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)]
= 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
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
= 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
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
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
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.
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
projects / ghc-hetmet.git / blobdiff