import Packages
import PackageConfig
import UniqFM
+import HscTypes ( implicitTyThings )
import PprTyThing
import Outputable hiding (printForUser)
import Module -- for ModuleEnv
import Name
+import SrcLoc
-- Other random utilities
import Digraph
import StaticFlags
import Linker
import Util
+import NameSet
+import Maybes ( orElse )
import FastString
#ifndef mingw32_HOST_OS
("show", keepGoing showCmd, False, completeNone),
("sprint", keepGoing sprintCmd, False, completeIdentifier),
("step", keepGoing stepCmd, False, completeIdentifier),
+ ("stepover", keepGoing stepOverCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("trace", keepGoing traceCmd, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
" :sprint [<name> ...] simplifed version of :print\n" ++
" :step single-step after stopping at a breakpoint\n"++
" :step <expr> single-step into <expr>\n"++
+ " :stepover (locally) single-step over function applications"++
" :trace trace after stopping at a breakpoint\n"++
" :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
then return (brackets (ppr (GHC.resumeSpan r)) <> space)
else do
let hist = GHC.resumeHistory r !! (ix-1)
- span <- io $ GHC.getHistorySpan session hist
+ span <- io$ GHC.getHistorySpan session hist
return (brackets (ppr (negate ix) <> char ':'
<+> ppr span) <> space)
let
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt step
- afterRunStmt result
+ afterRunStmt (const True) result
-afterRunStmt :: GHC.RunResult -> GHCi Bool
+--afterRunStmt :: GHC.RunResult -> GHCi Bool
-- False <=> the statement failed to compile
-afterRunStmt (GHC.RunException e) = throw e
-afterRunStmt run_result = do
- session <- getSession
+afterRunStmt _ (GHC.RunException e) = throw e
+afterRunStmt pred run_result = do
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
case run_result of
GHC.RunOk names -> do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames session names
- GHC.RunBreak _ names mb_info -> do
- resumes <- io $ GHC.getResumeContext session
- printForUser $ ptext SLIT("Stopped at") <+>
- ppr (GHC.resumeSpan (head resumes))
- printTypeOfNames session names
- maybe (return ()) runBreakCmd mb_info
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- enqueueCommands [stop st]
- return ()
+ GHC.RunBreak _ names mb_info
+ | isNothing mb_info ||
+ pred (GHC.resumeSpan $ head resumes) -> do
+ printForUser $ ptext SLIT("Stopped at") <+>
+ ppr (GHC.resumeSpan $ head resumes)
+ printTypeOfNames session names
+ maybe (return ()) runBreakCmd mb_info
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+ return ()
+ | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
+ afterRunStmt pred >> return ()
_ -> return ()
flushInterpBuffers
c:_ -> return (Just c)
+getCurrentBreakTick :: GHCi (Maybe BreakIndex)
+getCurrentBreakTick = do
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ case resumes of
+ [] -> return Nothing
+ (r:rs) -> do
+ let ix = GHC.resumeHistoryIx r
+ if ix == 0
+ then return (GHC.breakInfo_number `fmap` GHC.resumeBreakInfo r)
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ let tick = GHC.getHistoryTick hist
+ return (Just tick)
+
getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
session <- getSession
span <- io $ GHC.getHistorySpan session hist
return (Just span)
+getCurrentBreakModule :: GHCi (Maybe Module)
+getCurrentBreakModule = do
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ case resumes of
+ [] -> return Nothing
+ (r:rs) -> do
+ let ix = GHC.resumeHistoryIx r
+ if ix == 0
+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ return $ Just $ GHC.getHistoryModule hist
+
-----------------------------------------------------------------------------
-- Commands
; mapM_ (infoThing pefas session) names }
where
infoThing pefas session str = io $ do
- names <- GHC.parseName session str
- let filtered = filterOutChildren names
- mb_stuffs <- mapM (GHC.getInfo session) filtered
+ names <- GHC.parseName session str
+ mb_stuffs <- mapM (GHC.getInfo session) names
+ let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
unqual <- GHC.getPrintUnqual session
putStrLn (showSDocForUser unqual $
vcat (intersperse (text "") $
- [ pprInfo pefas stuff | Just stuff <- mb_stuffs ]))
+ map (pprInfo pefas) filtered))
-- Filter out names whose parent is also there Good
-- example is '[]', which is both a type and data
-- constructor in the same type
-filterOutChildren :: [Name] -> [Name]
-filterOutChildren names = filter (not . parent_is_there) names
- where parent_is_there n
--- | Just p <- GHC.nameParent_maybe n = p `elem` names
--- ToDo!!
- | otherwise = False
+filterOutChildren :: (a -> TyThing) -> [a] -> [a]
+filterOutChildren get_thing xs
+ = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
+ where
+ implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
pprInfo pefas (thing, fixity, insts)
reloadModule :: String -> GHCi ()
reloadModule m = do
- io (revertCAFs) -- always revert CAFs on reload.
- discardActiveBreakPoints
session <- getSession
doLoad session $ if null m then LoadAllTargets
else LoadUpTo (GHC.mkModuleName m)
Just mod_info -> do
let names
| exports_only = GHC.modInfoExports mod_info
- | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
+ | otherwise = GHC.modInfoTopLevelScope mod_info
+ `orElse` []
- filtered = filterOutChildren names
-
- things <- io $ mapM (GHC.lookupName s) filtered
+ mb_things <- io $ mapM (GHC.lookupName s) names
+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
dflags <- getDynFlags
let pefas = dopt Opt_PrintExplicitForalls dflags
io (putStrLn (showSDocForUser unqual (
- vcat (map (pprTyThingInContext pefas) (catMaybes things))
+ vcat (map (pprTyThingInContext pefas) filtered_things)
)))
-- ToDo: modInfoInstances currently throws an exception for
-- package modules. When it works, we can do this:
io $ pprintClosureCommand session bind force str
stepCmd :: String -> GHCi ()
-stepCmd [] = doContinue GHC.SingleStep
+stepCmd [] = doContinue (const True) GHC.SingleStep
stepCmd expression = do runStmt expression GHC.SingleStep; return ()
+stepOverCmd [] = do
+ mb_span <- getCurrentBreakSpan
+ session <- getSession
+ case mb_span of
+ Nothing -> stepCmd []
+ Just curr_loc -> do
+ Just tick <- getCurrentBreakTick
+ Just mod <- getCurrentBreakModule
+ parent <- io$ GHC.findEnclosingDeclSpanByTick session mod tick
+ allTicksRightmost <- (sortBy rightmost . map snd) `fmap`
+ ticksIn mod parent
+ let lastTick = null allTicksRightmost ||
+ head allTicksRightmost == curr_loc
+ if not lastTick
+ then let f t = t `isSubspanOf` parent &&
+ (curr_loc `leftmost_largest` t == LT)
+ in doContinue f GHC.SingleStep
+ else printForUser (text "Warning: no more breakpoints in this function body, switching to :step") >>
+ doContinue (const True) GHC.SingleStep
+
+stepOverCmd expression = stepCmd expression
+
+{-
+ The first tricky bit in stepOver is detecting that we have
+ arrived to the last tick in an expression, in which case we must
+ step normally to the next tick.
+ What we do is:
+ 1. Retrieve the enclosing expression block (with a tick)
+ 2. Retrieve all the ticks there and sort them out by 'rightness'
+ 3. See if the current tick turned out the first one in the list
+
+ The second tricky bit is how to step over recursive calls.
+
+-}
+
+--ticksIn :: Module -> SrcSpan -> GHCi [Tick]
+ticksIn mod src = do
+ ticks <- getTickArray mod
+ let lines = [srcSpanStartLine src .. srcSpanEndLine src]
+ return [ t | line <- lines
+ , t@(_,span) <- ticks ! line
+ , srcSpanStart src <= srcSpanStart span
+ , srcSpanEnd src >= srcSpanEnd span
+ ]
+
traceCmd :: String -> GHCi ()
-traceCmd [] = doContinue GHC.RunAndLogSteps
+traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
continueCmd :: String -> GHCi ()
-continueCmd = noArgs $ doContinue GHC.RunToCompletion
+continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
-doContinue :: SingleStep -> GHCi ()
-doContinue step = do
+-- doContinue :: SingleStep -> GHCi ()
+doContinue pred step = do
session <- getSession
runResult <- io $ GHC.resume session step
- afterRunStmt runResult
+ afterRunStmt pred runResult
return ()
abandonCmd :: String -> GHCi ()
let hist = GHC.resumeHistory r
(took,rest) = splitAt num hist
spans <- mapM (io . GHC.getHistorySpan s) took
- let nums = map (printf "-%-3d:") [(1::Int)..]
- printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
+ let nums = map (printf "-%-3d:") [(1::Int)..]
+ let names = map GHC.historyEnclosingDecl took
+ printForUser (vcat(zipWith3
+ (\x y z -> x <+> y <+> z)
+ (map text nums)
+ (map (bold . ppr) names)
+ (map (parens . ppr) spans)))
io $ putStrLn $ if null rest then "<end of history>" else "..."
+bold c | do_bold = text start_bold <> c <> text end_bold
+ | otherwise = c
+
backCmd :: String -> GHCi ()
backCmd = noArgs $ do
s <- getSession
findBreakByLine line arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
- listToMaybe (sortBy leftmost_largest complete) `mplus`
- listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
- listToMaybe (sortBy rightmost ticks)
+ listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
+ listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
+ listToMaybe (sortBy (rightmost `on` snd) ticks)
where
ticks = arr ! line
findBreakByCoord mb_file (line, col) arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
- listToMaybe (sortBy rightmost contains) `mplus`
- listToMaybe (sortBy leftmost_smallest after_here)
+ listToMaybe (sortBy (rightmost `on` snd) contains ++
+ sortBy (leftmost_smallest `on` snd) after_here)
where
ticks = arr ! line
GHC.srcSpanStartLine span == line,
GHC.srcSpanStartCol span >= col ]
-
-leftmost_smallest (_,a) (_,b) = a `compare` b
-leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
- `thenCmp`
- (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
-rightmost (_,a) (_,b) = b `compare` a
-
-spans :: SrcSpan -> (Int,Int) -> Bool
-spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
- where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
-
-- for now, use ANSI bold on Unixy systems. On Windows, we add a line
-- of carets under the active expression instead. The Windows console
-- doesn't support ANSI escape sequences, and most Unix terminals
do_bold = False
#endif
-start_bold = BS.pack "\ESC[1m"
-end_bold = BS.pack "\ESC[0m"
+start_bold = "\ESC[1m"
+end_bold = "\ESC[0m"
listCmd :: String -> GHCi ()
listCmd "" = do
= let (a,r) = BS.splitAt col1 line
(b,c) = BS.splitAt (col2-col1) r
in
- BS.concat [a,start_bold,b,end_bold,c]
+ BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c]
| no == line1
= let (a,b) = BS.splitAt col1 line in
- BS.concat [a, start_bold, b]
+ BS.concat [a, BS.pack start_bold, b]
| no == line2
= let (a,b) = BS.splitAt col2 line in
- BS.concat [a, end_bold, b]
+ BS.concat [a, BS.pack end_bold, b]
| otherwise = line
highlight_carets no line
projects / ghc-hetmet.git / blobdiff