-- The GHC interface
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
- Type, Module, ModuleName, TyThing(..), Phase )
+ Type, Module, ModuleName, TyThing(..), Phase,
+ BreakIndex )
+import Debugger
import DynFlags
import Packages
import PackageConfig
import UniqFM
import PprTyThing
-import Outputable
+import Outputable hiding (printForUser)
+import Module -- for ModuleEnv
-- for createtags
import Name
import Linker
import Util
--- The debugger
-import Breakpoints
-import Debugger hiding ( addModule )
-import HscTypes
-import Id
-import Var ( globaliseId )
-import IdInfo
-import NameEnv
-import RdrName
-import Module
-import Type
-import TcType
-
#ifndef mingw32_HOST_OS
import System.Posix
#if __GLASGOW_HASKELL__ > 504
import Control.Exception as Exception
-- import Control.Concurrent
-import Numeric
import Data.List
-import Data.Int ( Int64 )
-import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
+import Data.Maybe
import System.Cmd
import System.Environment
import System.Exit ( exitWith, ExitCode(..) )
import System.IO
import System.IO.Error as IO
import Data.Char
+import Data.Dynamic
+import Data.Array
import Control.Monad as Monad
-import Foreign.StablePtr ( newStablePtr )
+import Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
import GHC.IOBase ( IOErrorType(InvalidArgument) )
-import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Data.IORef ( IORef, readIORef, writeIORef )
import System.Posix.Internals ( setNonBlockingFD )
builtin_commands :: [Command]
builtin_commands = [
- ("add", tlC$ keepGoingPaths addModule, False, completeFilename),
+ -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+ ("?", keepGoing help, False, completeNone),
+ ("add", keepGoingPaths addModule, False, completeFilename),
+ ("break", breakCmd, False, completeIdentifier),
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
+ ("check", keepGoing checkModule, False, completeHomeModule),
+ ("continue", continueCmd, False, completeNone),
+ ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
+ ("delete", deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
- -- Hugs users are accustomed to :e, so make sure it doesn't overlap
("edit", keepGoing editFile, False, completeFilename),
+ ("etags", keepGoing createETagsFileCmd, False, completeFilename),
+ ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
("help", keepGoing help, False, completeNone),
- ("?", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
- ("load", tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
+ ("kind", keepGoing kindOfType, False, completeIdentifier),
+ ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
("module", keepGoing setContext, False, completeModule),
- ("main", tlC$ keepGoing runMain, False, completeIdentifier),
- ("reload", tlC$ keepGoing reloadModule, False, completeNone),
- ("check", keepGoing checkModule, False, completeHomeModule),
+ ("main", keepGoing runMain, False, completeIdentifier),
+ ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+ ("quit", quit, False, completeNone),
+ ("reload", keepGoing reloadModule, False, completeNone),
("set", keepGoing setCmd, True, completeSetOptions),
("show", keepGoing showCmd, False, completeNone),
- ("etags", keepGoing createETagsFileCmd, False, completeFilename),
- ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
+ ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+ ("step", stepCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
-#if defined(GHCI)
- ("breakpoint",keepGoing bkptOptions, False, completeBkpt),
-#endif
- ("kind", keepGoing kindOfType, False, completeIdentifier),
- ("unset", keepGoing unsetOptions, True, completeSetOptions),
("undef", keepGoing undefineMacro, False, completeMacro),
- ("quit", quit, False, completeNone)
+ ("unset", keepGoing unsetOptions, True, completeSetOptions)
]
keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
keepGoing a str = a str >> return False
--- tlC: Top Level Command
-tlC :: (String -> GHCi Bool) -> (String -> GHCi Bool)
-tlC a str = do
- top_level <- isTopLevel
- if not top_level
- then throwDyn (CmdLineError "Command only allowed at Top Level")
- else a str
-
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False
shortHelpText = "use :? for help.\n"
--- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
helpText =
" Commands available from the prompt:\n" ++
"\n" ++
" <stmt> evaluate/run <stmt>\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :breakpoint <option> commands for the GHCi debugger\n" ++
+ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
+ " :break <name> set a breakpoint on the specified function\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
+ " :continue resume after a breakpoint\n" ++
+ " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
+ " :delete <number> delete the specified breakpoint\n" ++
+ " :delete * delete all breakpoints\n" ++
" :edit <file> edit file\n" ++
" :edit edit last module\n" ++
+ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
+-- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
" :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++
+ " :kind <type> show the kind of <type>\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
" :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++
+ " :print [<name> ...] prints a value without forcing its computation\n" ++
+ " :quit exit GHCi\n" ++
" :reload reload the current module set\n" ++
"\n" ++
" :set <option> ... set options\n" ++
" :set prompt <prompt> set the prompt used in GHCi\n" ++
" :set editor <cmd> set the command used for :edit\n" ++
"\n" ++
+ " :show breaks show active breakpoints\n" ++
+ " :show context show the breakpoint context\n" ++
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
"\n" ++
- " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
- " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
+ " :sprint [<name> ...] simplifed version of :print\n" ++
+ " :step single-step after stopping at a breakpoint\n"++
+ " :step <expr> single-step into <expr>\n"++
" :type <expr> show the type of <expr>\n" ++
- " :kind <type> show the kind of <type>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
" :unset <option> ... unset options\n" ++
- " :quit exit GHCi\n" ++
" :!<command> run the shell command <command>\n" ++
"\n" ++
" Options for ':set' and ':unset':\n" ++
" +t print type after evaluation\n" ++
" -<flags> most GHC command line flags can also be set here\n" ++
" (eg. -v2, -fglasgow-exts, etc.)\n" ++
- "\n" ++
- " Options for ':breakpoint':\n" ++
- " list list the current breakpoints\n" ++
- " add Module line [col] add a new breakpoint\n" ++
- " del (breakpoint# | Module line [col]) delete a breakpoint\n" ++
- " stop Stop a computation and return to the top level\n" ++
- " step [count] Step by step execution (DISABLED)\n"
+ "\n"
+-- Todo: add help for breakpoint commands here
findEditor = do
getEnv "EDITOR"
hSetBuffering stdin NoBuffering
-- initial context is just the Prelude
- prel_mod <- GHC.findModule session prel_name Nothing
+ prel_mod <- GHC.findModule session prel_name (Just basePackageId)
GHC.setContext session [] [prel_mod]
#ifdef USE_READLINE
Readline.setCompleterWordBreakCharacters word_break_chars
#endif
- bkptTable <- newIORef emptyBkptTable
- GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
default_editor <- findEditor
startGHCi (runGHCi srcs maybe_expr)
session = session,
options = [],
prelude = prel_mod,
- bkptTable = bkptTable,
- topLevel = True
+ resume = [],
+ breaks = emptyActiveBreakPoints,
+ tickarrays = emptyModuleEnv
}
#ifdef USE_READLINE
perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
hsep (map (ppr . GHC.moduleName) exports)
-
+
#ifdef USE_READLINE
readlineLoop :: GHCi ()
-- failure to run the command causes exit(1) for ghc -e.
_ -> finishEvalExpr nms
-runStmt :: String -> GHCi (Maybe [Name])
+runStmt :: String -> GHCi (Maybe (Bool,[Name]))
runStmt stmt
- | null (filter (not.isSpace) stmt) = return (Just [])
+ | null (filter (not.isSpace) stmt) = return (Just (False,[]))
| otherwise
= do st <- getGHCiState
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt
- case result of
- GHC.RunFailed -> return Nothing
- GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
- GHC.RunOk names -> return (Just names)
+ switchOnRunResult result
+
+switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
+switchOnRunResult GHC.RunFailed = return Nothing
+switchOnRunResult (GHC.RunException e) = throw e
+switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
+switchOnRunResult (GHC.RunBreak threadId names info resume) = do
+ session <- getSession
+ Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let ticks = GHC.modBreaks_locs modBreaks
+
+ -- display information about the breakpoint
+ let location = ticks ! breakInfo_number info
+ printForUser $ ptext SLIT("Stopped at") <+> ppr location
+
+ pushResume location threadId resume
+ return (Just (True,names))
-- possibly print the type and revert CAFs after evaluating an expression
finishEvalExpr mb_names
- = do b <- isOptionSet ShowType
+ = do show_types <- isOptionSet ShowType
session <- getSession
case mb_names of
Nothing -> return ()
- Just names -> when b (mapM_ (showTypeOfName session) names)
+ Just (is_break,names) ->
+ when (is_break || show_types) $
+ mapM_ (showTypeOfName session) names
flushInterpBuffers
io installSignalHandlers
afterLoad ok session = do
io (revertCAFs) -- always revert CAFs on load.
+ discardResumeContext
+ discardTickArrays
+ discardActiveBreakPoints
graph <- io (GHC.getModuleGraph session)
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
setContextAfterLoad session graph'
- refreshBkptTable graph'
modulesLoadedMsg ok (map GHC.ms_mod_name graph')
setContextAfterLoad session [] = do
case maybe_ty of
Nothing -> return ()
Just ty -> do ty' <- cleanType ty
- tystr <- showForUser (ppr ty')
- io (putStrLn (str ++ " :: " ++ tystr))
+ printForUser $ text str <> text " :: " <> ppr ty'
kindOfType :: String -> GHCi ()
kindOfType str
maybe_ty <- io (GHC.typeKind cms str)
case maybe_ty of
Nothing -> return ()
- Just ty -> do tystr <- showForUser (ppr ty)
- io (putStrLn (str ++ " :: " ++ tystr))
-
+ Just ty -> printForUser $ text str <> text " :: " <> ppr ty
+
quit :: String -> GHCi Bool
quit _ = return True
browseModule m exports_only = do
s <- getSession
- modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
- is_interpreted <- io (GHC.moduleIsInterpreted s modl)
- when (not is_interpreted && not exports_only) $
- throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
+ modl <- if exports_only then lookupModule s m
+ else wantInterpretedModule s m
-- Temporarily set the context to the module we're interested in,
-- just so we can get an appropriate PrintUnqualified
["modules" ] -> showModules
["bindings"] -> showBindings
["linker"] -> io showLinkerState
- ["breakpoints"] -> showBkptTable
- _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
+ ["breaks"] -> showBkptTable
+ ["context"] -> showContext
+ _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]")
showModules = do
session <- getSession
showTyThing (AnId id) = do
ty' <- cleanType (GHC.idType id)
- str <- showForUser (ppr id <> text " :: " <> ppr ty')
- io (putStrLn str)
+ printForUser $ ppr id <> text " :: " <> ppr ty'
showTyThing _ = return ()
-- if -fglasgow-exts is on we show the foralls, otherwise we don't.
showBkptTable :: GHCi ()
showBkptTable = do
- bt <- getBkptTable
- msg <- showForUser . vcat $
- [ ppr mod <> colon <+> fcat
- [ parens(int row <> comma <> int col) | (row,col) <- sites]
- | (mod, sites) <- sitesList bt ]
- io (putStrLn msg)
+ activeBreaks <- getActiveBreakPoints
+ printForUser $ ppr activeBreaks
+
+showContext :: GHCi ()
+showContext = do
+ st <- getGHCiState
+ printForUser $ vcat (map pp_resume (resume st))
+ where
+ pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
+
-- -----------------------------------------------------------------------------
-- Completion
return (filter (w `isPrefixOf`) options)
where options = "args":"prog":allFlags
-completeBkpt = unionComplete completeModule completeBkptCmds
-
-completeBkptCmds w = do
- return (filter (w `isPrefixOf`) options)
- where options = ["add","del","list","stop"]
-
completeFilename = Readline.filenameCompletionFunction
completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
getCommonPrefix :: [String] -> String
getCommonPrefix [] = ""
getCommonPrefix (s:ss) = foldl common s ss
- where common s "" = s
+ where common s "" = ""
common "" s = ""
common (c:cs) (d:ds)
| c == d = c : common cs ds
completeBkpt = completeNone
#endif
+-- ---------------------------------------------------------------------------
+-- User code exception handling
+
+-- This is the exception handler for exceptions generated by the
+-- user's code and exceptions coming from children sessions;
+-- it normally just prints out the exception. The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception. We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: Exception -> GHCi Bool
+
+handler exception = do
+ flushInterpBuffers
+ io installSignalHandlers
+ ghciHandle handler (showException exception >> return False)
+
+showException (DynException dyn) =
+ case fromDynamic dyn of
+ Nothing -> io (putStrLn ("*** Exception: (unknown)"))
+ Just Interrupted -> io (putStrLn "Interrupted.")
+ Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
+ Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
+ Just other_ghc_ex -> io (print other_ghc_ex)
+
+showException other_exception
+ = io (putStrLn ("*** Exception: " ++ show other_exception))
+
+-----------------------------------------------------------------------------
+-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- in an exception loop (eg. let a = error a in a) the ^C exception
+-- may never be delivered. Thanks to Marcin for pointing out the bug.
+
+ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
+ghciHandle h (GHCi m) = GHCi $ \s ->
+ Exception.catch (m s)
+ (\e -> unGHCi (ghciUnblock (h e)) s)
+
+ghciUnblock :: GHCi a -> GHCi a
+ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
+
+
-- ----------------------------------------------------------------------------
-- Utils
#endif
return ()
+-- commands for debugger
+foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
+
+stepCmd :: String -> GHCi Bool
+stepCmd [] = doContinue setStepFlag
+stepCmd expression = do
+ io $ setStepFlag
+ runCommand expression
+
+continueCmd :: String -> GHCi Bool
+continueCmd [] = doContinue $ return ()
+continueCmd other = do
+ io $ putStrLn "The continue command accepts no arguments."
+ return False
+
+doContinue :: IO () -> GHCi Bool
+doContinue actionBeforeCont = do
+ resumeAction <- popResume
+ case resumeAction of
+ Nothing -> do
+ io $ putStrLn "There is no computation running."
+ return False
+ Just (_,_,handle) -> do
+ io $ actionBeforeCont
+ session <- getSession
+ runResult <- io $ GHC.resume session handle
+ names <- switchOnRunResult runResult
+ finishEvalExpr names
+ return False
+
+deleteCmd :: String -> GHCi Bool
+deleteCmd argLine = do
+ deleteSwitch $ words argLine
+ return False
+ where
+ deleteSwitch :: [String] -> GHCi ()
+ deleteSwitch [] =
+ io $ putStrLn "The delete command requires at least one argument."
+ -- delete all break points
+ deleteSwitch ("*":_rest) = discardActiveBreakPoints
+ deleteSwitch idents = do
+ mapM_ deleteOneBreak idents
+ where
+ deleteOneBreak :: String -> GHCi ()
+ deleteOneBreak str
+ | all isDigit str = deleteBreak (read str)
+ | otherwise = return ()
+
+-- handle the "break" command
+breakCmd :: String -> GHCi Bool
+breakCmd argLine = do
+ session <- getSession
+ breakSwitch session $ words argLine
+ return False
+
+breakSwitch :: Session -> [String] -> GHCi ()
+breakSwitch _session [] = do
+ io $ putStrLn "The break command requires at least one argument."
+breakSwitch session args@(arg1:rest)
+ | looksLikeModuleName arg1 = do
+ mod <- wantInterpretedModule session arg1
+ breakByModule session mod rest
+ | all isDigit arg1 = do
+ (toplevel, _) <- io $ GHC.getContext session
+ case toplevel of
+ (mod : _) -> breakByModuleLine mod (read arg1) rest
+ [] -> do
+ io $ putStrLn "Cannot find default module for breakpoint."
+ io $ putStrLn "Perhaps no modules are loaded for debugging?"
+ | otherwise = do -- assume it's a name
+ names <- io $ GHC.parseName session arg1
+ case names of
+ [] -> return ()
+ (n:_) -> do
+ let loc = nameSrcLoc n
+ modl = nameModule n
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ if not is_interpreted
+ then noCanDo $ text "module " <> ppr modl <>
+ text " is not interpreted"
+ else do
+ if isGoodSrcLoc loc
+ then findBreakAndSet (nameModule n) $
+ findBreakByCoord (srcLocLine loc, srcLocCol loc)
+ else noCanDo $ text "can't find its location: " <>
+ ppr loc
+ where
+ noCanDo why = printForUser $
+ text "cannot set breakpoint on " <> ppr n <> text ": " <> why
+
+
+wantInterpretedModule :: Session -> String -> GHCi Module
+wantInterpretedModule session str = do
+ modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ when (not is_interpreted) $
+ throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
+ return modl
+
+breakByModule :: Session -> Module -> [String] -> GHCi ()
+breakByModule session mod args@(arg1:rest)
+ | all isDigit arg1 = do -- looks like a line number
+ breakByModuleLine mod (read arg1) rest
+ | otherwise = io $ putStrLn "Invalid arguments to :break"
+
+breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine mod line args
+ | [] <- args = findBreakAndSet mod $ findBreakByLine line
+ | [col] <- args, all isDigit col =
+ findBreakAndSet mod $ findBreakByCoord (line, read col)
+ | otherwise = io $ putStrLn "Invalid arguments to :break"
+
+findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet mod lookupTickTree = do
+ tickArray <- getTickArray mod
+ (breakArray, _) <- getModBreak mod
+ case lookupTickTree tickArray of
+ Nothing -> io $ putStrLn $ "No breakpoints found at that location."
+ Just (tick, span) -> do
+ success <- io $ setBreakFlag True breakArray tick
+ session <- getSession
+ if success
+ then do
+ (alreadySet, nm) <-
+ recordBreak $ BreakLocation
+ { breakModule = mod
+ , breakLoc = span
+ , breakTick = tick
+ }
+ printForUser $
+ text "Breakpoint " <> ppr nm <>
+ if alreadySet
+ then text " was already set at " <> ppr span
+ else text " activated at " <> ppr span
+ else do
+ printForUser $ text "Breakpoint could not be activated at"
+ <+> ppr span
+
+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+-- - the leftmost complete subexpression on the specified line, or
+-- - the leftmost subexpression starting on the specified line, or
+-- - the rightmost subexpression enclosing the specified line
+--
+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByLine line arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy leftmost complete) `mplus`
+ listToMaybe (sortBy leftmost incomplete) `mplus`
+ listToMaybe (sortBy rightmost ticks)
+ where
+ ticks = arr ! line
+
+ starts_here = [ tick | tick@(nm,span) <- ticks,
+ srcSpanStartLine span == line ]
+
+ (complete,incomplete) = partition ends_here starts_here
+ where ends_here (nm,span) = srcSpanEndLine span == line
-instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
-instrumentationBkptHandler ref_bkptTable = BkptHandler {
- isAutoBkptEnabled = \sess bkptLoc -> do
- bktpTable <- readIORef ref_bkptTable
- return$ isBkptEnabled bktpTable bkptLoc
-
- , handleBreakpoint = doBreakpoint ref_bkptTable
- }
-
-doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
-doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
- let (ids, hValues) = unzip values
- names = map idName ids
- ASSERT (length names == length hValues) return ()
- let global_ids = map globaliseAndTidy ids
- printScopeMsg locMsg global_ids
- typed_ids <- mapM instantiateIdType global_ids
- hsc_env <- readIORef ref
- let ictxt = hsc_IC hsc_env
- rn_env = ic_rn_local_env ictxt
- type_env = ic_type_env ictxt
- bound_names = map idName typed_ids
- new_rn_env = extendLocalRdrEnv rn_env bound_names
- -- Remove any shadowed bindings from the type_env;
- -- they are inaccessible but might, I suppose, cause
- -- a space leak if we leave them there
- shadowed = [ n | name <- bound_names,
- let rdr_name = mkRdrUnqual (nameOccName name),
- Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
- filtered_type_env = delListFromNameEnv type_env shadowed
- new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids)
- new_ic = ictxt { ic_rn_local_env = new_rn_env,
- ic_type_env = new_type_env }
- writeIORef ref (hsc_env { hsc_IC = new_ic })
- is_tty <- hIsTerminalDevice stdin
- prel_mod <- GHC.findModule s prel_name Nothing
- withExtendedLinkEnv (zip names hValues) $
- startGHCi (interactiveLoop is_tty True) GHCiState{
- progname = "<interactive>",
- args = [],
- prompt = locMsg ++ "> ",
- session = s,
- options = [],
- bkptTable= ref_bkptTable,
- prelude = prel_mod,
- topLevel = False }
- `catchDyn` (
- \StopChildSession -> evaluate$
- throwDyn (ChildSessionStopped "You may need to reload your modules")
- ) `finally` do
- writeIORef ref hsc_env
- putStrLn $ "Returning to normal execution..."
- return b
+findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord (line, col) arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy rightmost contains)
where
- printScopeMsg :: String -> [Id] -> IO ()
- printScopeMsg location ids = do
- unqual <- GHC.getPrintUnqual s
- printForUser stdout unqual $
- text "Local bindings in scope:" $$
- nest 2 (pprWithCommas showId ids)
- where
- showId id =
- ppr (idName id) <+> dcolon <+> ppr (idType id)
-
--- | Give the Id a Global Name, and tidy its type
- globaliseAndTidy :: Id -> Id
- globaliseAndTidy id
- = let tidied_type = tidyTopType$ idType id
- in setIdType (globaliseId VanillaGlobal id) tidied_type
-
--- | Instantiate the tyVars with GHC.Base.Unknown
- instantiateIdType :: Id -> IO Id
- instantiateIdType id = do
- instantiatedType <- instantiateTyVarsToUnknown s (idType id)
- return$ setIdType id instantiatedType
+ ticks = arr ! line
+
+ -- the ticks that span this coordinate
+ contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
+
+leftmost (_,a) (_,b) = a `compare` b
+rightmost (_,a) (_,b) = b `compare` a
+
+spans :: SrcSpan -> (Int,Int) -> Bool
+spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
+ where loc = mkSrcLoc (srcSpanFile span) l c
+
+
+-- --------------------------------------------------------------------------
+-- Tick arrays
+
+getTickArray :: Module -> GHCi TickArray
+getTickArray modl = do
+ st <- getGHCiState
+ let arrmap = tickarrays st
+ case lookupModuleEnv arrmap modl of
+ Just arr -> return arr
+ Nothing -> do
+ (breakArray, ticks) <- getModBreak modl
+ let arr = mkTickArray (assocs ticks)
+ setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
+ return arr
+
+discardTickArrays :: GHCi ()
+discardTickArrays = do
+ st <- getGHCiState
+ setGHCiState st{tickarrays = emptyModuleEnv}
+
+mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
+mkTickArray ticks
+ = accumArray (flip (:)) [] (1, max_line)
+ [ (line, (nm,span)) | (nm,span) <- ticks,
+ line <- srcSpanLines span ]
+ where
+ max_line = maximum (map srcSpanEndLine (map snd ticks))
+ srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
+
+getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
+getModBreak mod = do
+ session <- getSession
+ Just mod_info <- io $ GHC.getModuleInfo session mod
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let array = GHC.modBreaks_flags modBreaks
+ let ticks = GHC.modBreaks_locs modBreaks
+ return (array, ticks)
+
+lookupModule :: Session -> String -> GHCi Module
+lookupModule session modName
+ = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
+setBreakFlag toggle array index
+ | toggle = GHC.setBreakOn array index
+ | otherwise = GHC.setBreakOff array index
+
+
+{- these should probably go to the GHC API at some point -}
+enableBreakPoint :: Session -> Module -> Int -> IO ()
+enableBreakPoint session mod index = return ()
+
+disableBreakPoint :: Session -> Module -> Int -> IO ()
+disableBreakPoint session mod index = return ()
+
+activeBreakPoints :: Session -> IO [(Module,Int)]
+activeBreakPoints session = return []
+enableSingleStep :: Session -> IO ()
+enableSingleStep session = return ()
+disableSingleStep :: Session -> IO ()
+disableSingleStep session = return ()
projects / ghc-hetmet.git / blobdiff