import PackageConfig
import UniqFM
import PprTyThing
-import Outputable
+import Outputable hiding (printForUser)
import Module -- for ModuleEnv
-- for createtags
import Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
-import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) )
+import GHC.IOBase ( IOErrorType(InvalidArgument) )
import Data.IORef ( IORef, readIORef, writeIORef )
-- 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, completeNone),
+ ("break", breakCmd, False, completeIdentifier),
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
- ("continue", continueCmd, False, completeNone),
+ ("continue", continueCmd, False, completeNone),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
- ("delete", deleteCmd, False, completeNone),
+ ("delete", deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
("edit", keepGoing editFile, False, completeFilename),
("etags", keepGoing createETagsFileCmd, False, completeFilename),
("help", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
("kind", keepGoing kindOfType, False, completeIdentifier),
- ("load", keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
+ ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
("module", keepGoing setContext, False, completeModule),
("main", keepGoing runMain, False, completeIdentifier),
("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
("set", keepGoing setCmd, True, completeSetOptions),
("show", keepGoing showCmd, False, completeNone),
("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
- ("step", stepCmd, False, completeNone),
+ ("step", stepCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
("unset", keepGoing unsetOptions, True, completeSetOptions)
-- display information about the breakpoint
let location = ticks ! breakInfo_number info
- unqual <- io $ GHC.getPrintUnqual session
- io $ printForUser stdout unqual $
- ptext SLIT("Stopped at") <+> ppr location
+ printForUser $ ptext SLIT("Stopped at") <+> ppr location
pushResume location threadId resume
return (Just (True,names))
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
["bindings"] -> showBindings
["linker"] -> io showLinkerState
["breaks"] -> showBkptTable
- _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
+ ["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
activeBreaks <- getActiveBreakPoints
- str <- showForUser $ ppr activeBreaks
- io $ putStrLn str
+ 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
breakCmd argLine = do
session <- getSession
breakSwitch session $ words argLine
+ return False
-breakSwitch :: Session -> [String] -> GHCi Bool
+breakSwitch :: Session -> [String] -> GHCi ()
breakSwitch _session [] = do
io $ putStrLn "The break command requires at least one argument."
- return False
breakSwitch session args@(arg1:rest)
- | looksLikeModule arg1 = do
+ | looksLikeModuleName arg1 = do
mod <- wantInterpretedModule session arg1
- breakByModule mod rest
- return False
- | otherwise = do
+ breakByModule session mod rest
+ | all isDigit arg1 = do
(toplevel, _) <- io $ GHC.getContext session
case toplevel of
- (mod : _) -> breakByModule mod args
+ (mod : _) -> breakByModuleLine mod (read arg1) rest
[] -> do
io $ putStrLn "Cannot find default module for breakpoint."
io $ putStrLn "Perhaps no modules are loaded for debugging?"
- return False
- where
- -- Todo there may be a nicer way to test this
- looksLikeModule :: String -> Bool
- looksLikeModule [] = False
- looksLikeModule (x:_) = isUpper x
+ | 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
throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
return modl
-breakByModule :: Module -> [String] -> GHCi ()
-breakByModule mod args@(arg1:rest)
+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
- | looksLikeVar arg1 = do
- -- break by a function definition
- io $ putStrLn "Break by function definition not implemented."
- | otherwise = io $ putStrLn "Invalid arguments to break command."
- where
- -- Todo there may be a nicer way to test this
- looksLikeVar :: String -> Bool
- looksLikeVar [] = False
- looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
+ | 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 command."
+ | otherwise = io $ putStrLn "Invalid arguments to :break"
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
findBreakAndSet mod lookupTickTree = do
Just (tick, span) -> do
success <- io $ setBreakFlag True breakArray tick
session <- getSession
- unqual <- io $ GHC.getPrintUnqual session
if success
then do
(alreadySet, nm) <-
, breakLoc = span
, breakTick = tick
}
- io $ printForUser stdout unqual $
+ printForUser $
text "Breakpoint " <> ppr nm <>
if alreadySet
then text " was already set at " <> ppr span
else text " activated at " <> ppr span
else do
- str <- showForUser $ text "Breakpoint could not be activated at"
+ printForUser $ text "Breakpoint could not be activated at"
<+> ppr span
- io $ putStrLn str
-- When a line number is specified, the current policy for choosing
-- the best breakpoint is this:
-- - the rightmost subexpression enclosing the specified line
--
findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
-findBreakByLine line arr =
- listToMaybe (sortBy leftmost complete) `mplus`
- listToMaybe (sortBy leftmost incomplete) `mplus`
- listToMaybe (sortBy rightmost ticks)
+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
where ends_here (nm,span) = srcSpanEndLine span == line
findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
-findBreakByCoord (line, col) arr =
- listToMaybe (sortBy rightmost contains)
+findBreakByCoord (line, col) arr
+ | not (inRange (bounds arr) line) = Nothing
+ | otherwise =
+ listToMaybe (sortBy rightmost contains)
where
ticks = arr ! line
projects / ghc-hetmet.git / blobdiff