+-----------------------------------------------------------------------------
+--
+-- Monadery code used in InteractiveUI
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
module GhciMonad where
#include "HsVersions.h"
import qualified GHC
-import {-#SOURCE#-} Debugger
-import Breakpoints
import Outputable
import Panic hiding (showException)
import Util
+import DynFlags
+import HscTypes
+import SrcLoc
import Numeric
import Control.Exception as Exception
import Data.Dynamic
import Data.Int ( Int64 )
import Data.IORef
+import Data.List
import Data.Typeable
import System.CPUTime
import System.IO
session :: GHC.Session,
options :: [GHCiOption],
prelude :: GHC.Module,
- bkptTable :: IORef (BkptTable GHC.Module),
- topLevel :: Bool
+ topLevel :: Bool,
+ resume :: [IO GHC.RunResult],
+ breaks :: !ActiveBreakPoints
}
data GHCiOption
| RevertCAFs -- revert CAFs after every evaluation
deriving Eq
+data ActiveBreakPoints
+ = ActiveBreakPoints
+ { breakCounter :: !Int
+ , breakLocations :: ![(Int, BreakLocation)] -- break location uniquely numbered
+ }
+
+instance Outputable ActiveBreakPoints where
+ ppr activeBrks = prettyLocations $ breakLocations activeBrks
+
+emptyActiveBreakPoints :: ActiveBreakPoints
+emptyActiveBreakPoints
+ = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
+
+data BreakLocation
+ = BreakLocation
+ { breakModule :: !GHC.Module
+ , breakLoc :: !SrcSpan
+ , breakTick :: {-# UNPACK #-} !Int
+ }
+ deriving Eq
+
+prettyLocations :: [(Int, BreakLocation)] -> SDoc
+prettyLocations [] = text "No active breakpoints."
+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
+
+instance Outputable BreakLocation where
+ ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
+
+getActiveBreakPoints :: GHCi ActiveBreakPoints
+getActiveBreakPoints = liftM breaks getGHCiState
+
+-- don't reset the counter back to zero?
+clearActiveBreakPoints :: GHCi ()
+clearActiveBreakPoints = do
+ st <- getGHCiState
+ let oldActiveBreaks = breaks st
+ newActiveBreaks = oldActiveBreaks { breakLocations = [] }
+ setGHCiState $ st { breaks = newActiveBreaks }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+ st <- getGHCiState
+ let oldActiveBreaks = breaks st
+ oldLocations = breakLocations oldActiveBreaks
+ newLocations = filter (\loc -> fst loc /= identity) oldLocations
+ newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }
+ setGHCiState $ st { breaks = newActiveBreaks }
+
+recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+ st <- getGHCiState
+ let oldActiveBreaks = breaks st
+ let oldLocations = breakLocations oldActiveBreaks
+ -- don't store the same break point twice
+ case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
+ (nm:_) -> return (True, nm)
+ [] -> do
+ let oldCounter = breakCounter oldActiveBreaks
+ newCounter = oldCounter + 1
+ newActiveBreaks =
+ oldActiveBreaks
+ { breakCounter = newCounter
+ , breakLocations = (oldCounter, brkLoc) : oldLocations
+ }
+ setGHCiState $ st { breaks = newActiveBreaks }
+ return (False, oldCounter)
+
newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
startGHCi :: GHCi a -> GHCiState -> IO a
isTopLevel :: GHCi Bool
isTopLevel = getGHCiState >>= return . topLevel
-getBkptTable :: GHCi (BkptTable GHC.Module)
-getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
- io$ readIORef table_ref
-
-setBkptTable :: BkptTable GHC.Module -> GHCi ()
-setBkptTable new_table = do
- table_ref <- getGHCiState >>= return . bkptTable
- io$ writeIORef table_ref new_table
-
-modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
-modifyBkptTable f = do
- bt <- getBkptTable
- new_bt <- io . evaluate$ f bt
- setBkptTable new_bt
+getResume :: GHCi (Maybe (IO GHC.RunResult))
+getResume = do
+ st <- getGHCiState
+ case (resume st) of
+ [] -> return Nothing
+ (x:_) -> return $ Just x
+
+popResume :: GHCi ()
+popResume = do
+ st <- getGHCiState
+ case (resume st) of
+ [] -> return ()
+ (_:xs) -> setGHCiState $ st { resume = xs }
+
+pushResume :: IO GHC.RunResult -> GHCi ()
+pushResume resumeAction = do
+ st <- getGHCiState
+ let oldResume = resume st
+ setGHCiState $ st { resume = resumeAction : oldResume }
showForUser :: SDoc -> GHCi String
showForUser doc = do
return $! showSDocForUser unqual doc
-- --------------------------------------------------------------------------
--- Inferior Sessions Exceptions (used by the debugger)
-
-data InfSessionException =
- StopChildSession -- A child session requests to be stopped
- | ChildSessionStopped String -- A child session has stopped
- deriving Typeable
-
-
--- --------------------------------------------------------------------------
-- timing & statistics
timeIt :: GHCi a -> GHCi a
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"
+command_sequence :: [String] -> String
+command_sequence = unwords . intersperse "Prelude.>>"
+
+no_buffer :: String -> String
+no_buffer h = unwords ["System.IO.hSetBuffering",
+ "System.IO." ++ h,
+ "System.IO.NoBuffering"]
+
+no_buf_cmd :: String
+no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
+
+flush_buffer :: String -> String
+flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
+
+flush_cmd :: String
+flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
initInterpBuffering :: GHC.Session -> IO ()
initInterpBuffering session
- = do maybe_hval <- GHC.compileExpr session no_buf_cmd
-
+ = do -- we don't want to be fooled by any modules lying around in the current
+ -- directory when we compile these code fragments, so set the import
+ -- path to be empty while we compile them.
+ dflags <- GHC.getSessionDynFlags session
+ GHC.setSessionDynFlags session dflags{importPaths=[]}
+
+ 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"
Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
_ -> panic "interactiveUI:flush"
+ GHC.setSessionDynFlags session dflags
+ GHC.workingDirectoryChanged session
return ()
projects / ghc-hetmet.git / blobdiff