projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Substantial improvements in RtClosureInspect
[ghc-hetmet.git]
/
ghc
/
GhciMonad.hs
diff --git
a/ghc/GhciMonad.hs
b/ghc/GhciMonad.hs
index
94bd9c2
..
2aff483
100644
(file)
--- a/
ghc/GhciMonad.hs
+++ b/
ghc/GhciMonad.hs
@@
-14,12
+14,13
@@
module GhciMonad where
#include "HsVersions.h"
import qualified GHC
#include "HsVersions.h"
import qualified GHC
+import GhcMonad hiding (liftIO)
import Outputable hiding (printForUser, printForUserPartWay)
import qualified Outputable
import Panic hiding (showException)
import Util
import DynFlags
import Outputable hiding (printForUser, printForUserPartWay)
import qualified Outputable
import Panic hiding (showException)
import Util
import DynFlags
-import HscTypes hiding (liftIO)
+import HscTypes
import SrcLoc
import Module
import ObjLink
import SrcLoc
import Module
import ObjLink
@@
-28,13
+29,10
@@
import StaticFlags
import qualified MonadUtils
import Exception
import qualified MonadUtils
import Exception
--- import Data.Maybe
import Numeric
import Data.Array
import Numeric
import Data.Array
--- import Data.Char
import Data.Int ( Int64 )
import Data.IORef
import Data.Int ( Int64 )
import Data.IORef
--- import Data.List
import System.CPUTime
import System.Environment
import System.IO
import System.CPUTime
import System.Environment
import System.IO
@@
-59,6
+57,7
@@
data GHCiState = GHCiState
stop :: String,
options :: [GHCiOption],
prelude :: GHC.Module,
stop :: String,
options :: [GHCiOption],
prelude :: GHC.Module,
+ line_number :: !Int, -- input line
break_ctr :: !Int,
breaks :: ![(Int, BreakLocation)],
tickarrays :: ModuleEnv TickArray,
break_ctr :: !Int,
breaks :: ![(Int, BreakLocation)],
tickarrays :: ModuleEnv TickArray,
@@
-69,7
+68,7
@@
data GHCiState = GHCiState
-- remember is here:
last_command :: Maybe Command,
cmdqueue :: [String],
-- 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
-- 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
@@
-79,10
+78,12
@@
data GHCiState = GHCiState
ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
}
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)]
type TickArray = Array Int [(BreakIndex,SrcSpan)]
@@
-90,6
+91,7
@@
data GHCiOption
= ShowTiming -- show time/allocs after evaluation
| ShowType -- show the type of expressions
| RevertCAFs -- revert CAFs after every evaluation
= 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
deriving Eq
data BreakLocation
@@
-180,31
+182,32
@@
instance GhcMonad (InputT GHCi) where
instance MonadUtils.MonadIO (InputT GHCi) where
liftIO = Trans.liftIO
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 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
instance MonadIO GHCi where
- liftIO = io
+ liftIO = MonadUtils.liftIO
instance Haskeline.MonadException GHCi where
catch = gcatch
block = gblock
unblock = gunblock
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
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
-- for convenience...
getPrelude :: GHCi Module
@@
-233,9
+236,6
@@
unsetOption opt
= do st <- getGHCiState
setGHCiState (st{ options = filter (/= opt) (options st) })
= do st <- getGHCiState
setGHCiState (st{ options = filter (/= opt) (options st) })
-io :: IO a -> GHCi a
-io = MonadUtils.liftIO
-
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
unqual <- GHC.getPrintUnqual
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
unqual <- GHC.getPrintUnqual
@@
-244,7
+244,7
@@
printForUser doc = do
printForUserPartWay :: SDoc -> GHCi ()
printForUserPartWay doc = do
unqual <- GHC.getPrintUnqual
printForUserPartWay :: SDoc -> GHCi ()
printForUserPartWay doc = do
unqual <- GHC.getPrintUnqual
- io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
+ liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
runStmt expr step = do
runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
runStmt expr step = do
@@
-253,9
+253,9
@@
runStmt expr step = do
withProgName (progname st) $
withArgs (args st) $
reflectGHCi x $ 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
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 = do
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
resume canLogSpan step = do
@@
-299,9
+299,9
@@
printTimes allocs psecs
revertCAFs :: GHCi ()
revertCAFs = do
revertCAFs :: GHCi ()
revertCAFs = do
- io $ rts_revertCAFs
+ liftIO rts_revertCAFs
s <- getGHCiState
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.
-- Have to turn off buffering again, because we just
-- reverted stdout, stderr & stdin to their defaults.
@@
-350,8
+350,8
@@
initInterpBuffering = do -- make sure these are linked
flushInterpBuffers :: GHCi ()
flushInterpBuffers
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
turnOffBuffering :: IO ()
turnOffBuffering