X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=8f22af887b411b9d1949b15652d654a2f099890a;hb=7ac266d097639620e4fea22c40450c8d7822f5fb;hp=821eee9a11cc93bcd2f42d8aec3e1c8c653a64fe;hpb=8c440cff43c20c3b79cd80e7f65fadd95328ff43;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 821eee9..8f22af8 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -15,13 +15,13 @@ module InteractiveUI ( import GhciMonad import GhciTags +import Debugger -- The GHC interface import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, BreakIndex, Name, SrcSpan ) -import Debugger import DynFlags import Packages import PackageConfig @@ -39,6 +39,7 @@ import Config import StaticFlags import Linker import Util +import FastString #ifndef mingw32_HOST_OS import System.Posix @@ -88,9 +89,9 @@ import System.Posix.Internals ( setNonBlockingFD ) 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 @@ -114,7 +115,7 @@ builtin_commands = [ ("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), @@ -122,12 +123,12 @@ builtin_commands = [ ("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), @@ -450,9 +451,9 @@ mkPrompt toplevs exports resumes prompt 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 @@ -520,13 +521,13 @@ runStmt stmt 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 @@ -536,7 +537,10 @@ switchOnRunResult (GHC.RunBreak threadId names info resume) = do 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 " st <- getGHCiState @@ -1149,9 +1153,11 @@ showBkptTable = do 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 @@ -1356,6 +1362,14 @@ setUpConsole = do -- ----------------------------------------------------------------------------- -- 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 @@ -1377,11 +1391,11 @@ doContinue actionBeforeCont = do 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 @@ -1391,7 +1405,7 @@ abandonCmd "" = do case mb_res of Nothing -> do io $ putStrLn "There is no computation running." - Just (span,_,_) -> + Just eval -> return () -- the prompt will change to indicate the new context @@ -1446,7 +1460,8 @@ breakSwitch session args@(arg1:rest) else do if GHC.isGoodSrcLoc loc then findBreakAndSet (GHC.nameModule n) $ - findBreakByCoord (GHC.srcLocLine loc, + findBreakByCoord (Just (GHC.srcLocFile loc)) + (GHC.srcLocLine loc, GHC.srcLocCol loc) else noCanDo $ text "can't find its location: " <> ppr loc @@ -1473,7 +1488,7 @@ 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) + findBreakAndSet mod $ findBreakByCoord Nothing (line, read col) | otherwise = io $ putStrLn "Invalid arguments to :break" findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () @@ -1524,8 +1539,9 @@ findBreakByLine line arr (complete,incomplete) = partition ends_here starts_here 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) @@ -1533,7 +1549,13 @@ findBreakByCoord (line, col) arr 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) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b) @@ -1553,7 +1575,7 @@ listCmd str = do 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