#include "HsVersions.h"
import GhciMonad
+import GhciTags
+import Debugger
-- The GHC interface
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
Type, Module, ModuleName, TyThing(..), Phase,
- BreakIndex )
-import Debugger
+ BreakIndex, Name, SrcSpan )
import DynFlags
import Packages
import PackageConfig
import Outputable hiding (printForUser)
import Module -- for ModuleEnv
--- for createtags
-import Name
-import OccName
-import SrcLoc
-
-- Other random utilities
import Digraph
import BasicTypes hiding (isTopLevel)
import StaticFlags
import Linker
import Util
+import FastString
#ifndef mingw32_HOST_OS
import System.Posix
ghciWelcomeMsg =
" ___ ___ _\n"++
" / _ \\ /\\ /\\/ __(_)\n"++
- " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
- "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
- "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
+ " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
+ "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
+ "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
cmdName (n,_,_,_) = n
-- Hugs users are accustomed to :e, so make sure it doesn't overlap
("?", keepGoing help, False, completeNone),
("add", keepGoingPaths addModule, False, completeFilename),
+ ("abandon", keepGoing abandonCmd, False, completeNone),
("break", keepGoing breakCmd, False, completeIdentifier),
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("e", keepGoing editFile, False, completeFilename),
("edit", keepGoing editFile, False, completeFilename),
("etags", keepGoing createETagsFileCmd, False, completeFilename),
- ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
+ ("force", keepGoing forceCmd, False, completeIdentifier),
("help", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
("kind", keepGoing kindOfType, False, completeIdentifier),
("list", keepGoing listCmd, False, completeNone),
("module", keepGoing setContext, False, completeModule),
("main", keepGoing runMain, False, completeIdentifier),
- ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+ ("print", keepGoing printCmd, False, completeIdentifier),
("quit", quit, False, completeNone),
("reload", keepGoing reloadModule, False, completeNone),
("set", keepGoing setCmd, True, completeSetOptions),
("show", keepGoing showCmd, False, completeNone),
- ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+ ("sprint", keepGoing sprintCmd, False, completeIdentifier),
("step", stepCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
"\n" ++
" <stmt> evaluate/run <stmt>\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
+ " :abandon at a breakpoint, abandon current computation\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" ++
f [] = empty
perc_s
- | (span,_,_):rest <- resumes
+ | eval:rest <- resumes
= (if not (null rest) then text "... " else empty)
- <> brackets (ppr span) <+> modules_prompt
+ <> brackets (ppr (evalSpan eval)) <+> modules_prompt
| otherwise
= modules_prompt
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt
- switchOnRunResult result
+ switchOnRunResult stmt 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
+switchOnRunResult :: String -> GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
+switchOnRunResult stmt GHC.RunFailed = return Nothing
+switchOnRunResult stmt (GHC.RunException e) = throw e
+switchOnRunResult stmt (GHC.RunOk names) = return $ Just (False,names)
+switchOnRunResult stmt (GHC.RunBreak threadId names info resume) = do
session <- getSession
Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
let modBreaks = GHC.modInfoModBreaks mod_info
let location = ticks ! GHC.breakInfo_number info
printForUser $ ptext SLIT("Stopped at") <+> ppr location
- pushResume location threadId resume
+ pushResume EvalInProgress{ evalStmt = stmt,
+ evalSpan = location,
+ evalThreadId = threadId,
+ evalResumeHandle = resume }
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
| fix == GHC.defaultFixity = empty
| otherwise = ppr fix <+> ppr (GHC.getName thing)
------------------------------------------------------------------------------
--- Commands
-
runMain :: String -> GHCi ()
runMain args = do
let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
shellEscape str = io (system str >> return False)
-----------------------------------------------------------------------------
--- create tags file for currently loaded modules.
-
-createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
-
-createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
-createCTagsFileCmd file = ghciCreateTagsFile CTags file
-
-createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
-createETagsFileCmd file = ghciCreateTagsFile ETags file
-
-data TagsKind = ETags | CTags
-
-ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
-ghciCreateTagsFile kind file = do
- session <- getSession
- io $ createTagsFile session kind file
-
--- ToDo:
--- - remove restriction that all modules must be interpreted
--- (problem: we don't know source locations for entities unless
--- we compiled the module.
---
--- - extract createTagsFile so it can be used from the command-line
--- (probably need to fix first problem before this is useful).
---
-createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
-createTagsFile session tagskind tagFile = do
- graph <- GHC.getModuleGraph session
- let ms = map GHC.ms_mod graph
- tagModule m = do
- is_interpreted <- GHC.moduleIsInterpreted session m
- -- should we just skip these?
- when (not is_interpreted) $
- throwDyn (CmdLineError ("module '"
- ++ GHC.moduleNameString (GHC.moduleName m)
- ++ "' is not interpreted"))
- mbModInfo <- GHC.getModuleInfo session m
- let unqual
- | Just modinfo <- mbModInfo,
- Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
- | otherwise = GHC.alwaysQualify
-
- case mbModInfo of
- Just modInfo -> return $! listTags unqual modInfo
- _ -> return []
-
- mtags <- mapM tagModule ms
- either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
- case either_res of
- Left e -> hPutStrLn stderr $ ioeGetErrorString e
- Right _ -> return ()
-
-listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
-listTags unqual modInfo =
- [ tagInfo unqual name loc
- | name <- GHC.modInfoExports modInfo
- , let loc = nameSrcLoc name
- , isGoodSrcLoc loc
- ]
-
-type TagInfo = (String -- tag name
- ,String -- file name
- ,Int -- line number
- ,Int -- column number
- )
-
--- get tag info, for later translation into Vim or Emacs style
-tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
-tagInfo unqual name loc
- = ( showSDocForUser unqual $ pprOccName (nameOccName name)
- , showSDocForUser unqual $ ftext (srcLocFile loc)
- , srcLocLine loc
- , srcLocCol loc
- )
-
-collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
-collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
- let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
- IO.try (writeFile file tags)
-collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
- let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
- groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
- tagGroups <- mapM tagFileGroup groups
- IO.try (writeFile file $ concat tagGroups)
- where
- tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
- tagFileGroup group@((_,fileName,_,_):_) = do
- file <- readFile fileName -- need to get additional info from sources..
- let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
- sortedGroup = sortLe byLine group
- tags = unlines $ perFile sortedGroup 1 0 $ lines file
- return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
- perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
- perFile (tagInfo:tags) (count+1) (pos+length line) lines
- perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
- showETag tagInfo line pos : perFile tags count pos lines
- perFile tags count pos lines = []
-
--- simple ctags format, for Vim et al
-showTag :: TagInfo -> String
-showTag (tag,file,lineNo,colNo)
- = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
-
--- etags format, for Emacs/XEmacs
-showETag :: TagInfo -> String -> Int -> String
-showETag (tag,file,lineNo,colNo) line charPos
- = take colNo line ++ tag
- ++ "\x7f" ++ tag
- ++ "\x01" ++ show lineNo
- ++ "," ++ show charPos
-
------------------------------------------------------------------------------
-- Browsing a module's contents
browseCmd :: String -> GHCi ()
showContext :: GHCi ()
showContext = do
st <- getGHCiState
- printForUser $ vcat (map pp_resume (resume st))
+ printForUser $ vcat (map pp_resume (reverse (resume st)))
where
- pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
+ pp_resume eval =
+ ptext SLIT("--> ") <> text (evalStmt eval)
+ $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (evalSpan eval))
-- -----------------------------------------------------------------------------
-- Completion
-- -----------------------------------------------------------------------------
-- commands for debugger
+sprintCmd = pprintCommand False False
+printCmd = pprintCommand True False
+forceCmd = pprintCommand False True
+
+pprintCommand bind force str = do
+ session <- getSession
+ io $ pprintClosureCommand session bind force str
+
foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
stepCmd :: String -> GHCi Bool
Nothing -> do
io $ putStrLn "There is no computation running."
return False
- Just (_,_,handle) -> do
+ Just eval -> do
io $ actionBeforeCont
session <- getSession
- runResult <- io $ GHC.resume session handle
- names <- switchOnRunResult runResult
+ runResult <- io $ GHC.resume session (evalResumeHandle eval)
+ names <- switchOnRunResult (evalStmt eval) runResult
finishEvalExpr names
return False
+abandonCmd :: String -> GHCi ()
+abandonCmd "" = do
+ mb_res <- popResume
+ case mb_res of
+ Nothing -> do
+ io $ putStrLn "There is no computation running."
+ Just eval ->
+ return ()
+ -- the prompt will change to indicate the new context
+
deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
deleteSwitch $ words argLine
case names of
[] -> return ()
(n:_) -> do
- let loc = nameSrcLoc n
- modl = nameModule n
+ let loc = GHC.nameSrcLoc n
+ modl = GHC.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)
+ if GHC.isGoodSrcLoc loc
+ then findBreakAndSet (GHC.nameModule n) $
+ findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc,
+ GHC.srcLocCol loc)
else noCanDo $ text "can't find its location: " <>
ppr loc
where
breakByModuleLine mod line args
| [] <- args = findBreakAndSet mod $ findBreakByLine line
| [col] <- args, all isDigit col =
- findBreakAndSet mod $ findBreakByCoord (line, read col)
+ findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
| otherwise = io $ putStrLn "Invalid arguments to :break"
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
ticks = arr ! line
starts_here = [ tick | tick@(nm,span) <- ticks,
- srcSpanStartLine span == line ]
+ GHC.srcSpanStartLine span == line ]
(complete,incomplete) = partition ends_here starts_here
- where ends_here (nm,span) = srcSpanEndLine span == line
+ where ends_here (nm,span) = GHC.srcSpanEndLine span == line
-findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
-findBreakByCoord (line, col) arr
+findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
+ -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord mb_file (line, col) arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
listToMaybe (sortBy rightmost contains)
ticks = arr ! line
-- the ticks that span this coordinate
- contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
+ contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
+ is_correct_file span ]
+
+ is_correct_file span
+ | Just f <- mb_file = GHC.srcSpanFile span == f
+ | otherwise = True
+
leftmost_smallest (_,a) (_,b) = a `compare` b
-leftmost_largest (_,a) (_,b) = (srcSpanStart a `compare` srcSpanStart b)
+leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
`thenCmp`
- (srcSpanEnd b `compare` srcSpanEnd a)
+ (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
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
+spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
+ where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
start_bold = BS.pack "\ESC[1m"
end_bold = BS.pack "\ESC[0m"
st <- getGHCiState
case resume st of
[] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
- (span,_,_):_ -> io $ listAround span True
+ eval:_ -> io $ listAround (evalSpan eval) True
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
--
BS.putStrLn (BS.join (BS.pack "\n") prefixed)
where
- file = srcSpanFile span
- line1 = srcSpanStartLine span
- col1 = srcSpanStartCol span
- line2 = srcSpanEndLine span
- col2 = srcSpanEndCol span
+ file = GHC.srcSpanFile span
+ line1 = GHC.srcSpanStartLine span
+ col1 = GHC.srcSpanStartCol span
+ line2 = GHC.srcSpanEndLine span
+ col2 = GHC.srcSpanEndCol span
pad_before | line1 == 1 = 0
| otherwise = 1
[ (line, (nm,span)) | (nm,span) <- ticks,
line <- srcSpanLines span ]
where
- max_line = maximum (map srcSpanEndLine (map snd ticks))
- srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
+ max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
+ srcSpanLines span = [ GHC.srcSpanStartLine span ..
+ GHC.srcSpanEndLine span ]
getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
getModBreak mod = do
projects / ghc-hetmet.git / blobdiff