X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=a1d803cf8a03cae4e6b9e6f5bdf0e7a7e2df2525;hb=3ee0e7596f55ebbe5eb99e2ba49dc4e2d7414262;hp=133ee55b119bfb949ea02c9285f61ef4cd516b37;hpb=6237bd983d0a1b903bb533bb66fe717b0f69fac4;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 133ee55..a1d803c 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -14,13 +14,14 @@ module InteractiveUI ( #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, Resume, SingleStep ) import DynFlags import Packages import PackageConfig @@ -29,20 +30,15 @@ import PprTyThing 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 Panic hiding (showException) -import FastString ( unpackFS ) import Config import StaticFlags import Linker import Util +import FastString #ifndef mingw32_HOST_OS import System.Posix @@ -78,6 +74,7 @@ import Data.Char import Data.Dynamic import Data.Array import Control.Monad as Monad +import Text.Printf import Foreign.StablePtr ( newStablePtr ) import GHC.Exts ( unsafeCoerce# ) @@ -92,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 @@ -106,7 +103,9 @@ builtin_commands = [ -- 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), + ("back", keepGoing backCmd, False, completeNone), ("browse", keepGoing browseCmd, False, completeModule), ("cd", keepGoing changeDirectory, False, completeFilename), ("check", keepGoing checkModule, False, completeHomeModule), @@ -117,22 +116,25 @@ 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), + ("forward", keepGoing forwardCmd, False, completeNone), ("help", keepGoing help, False, completeNone), + ("history", keepGoing historyCmd, False, completeNone), ("info", keepGoing info, False, completeIdentifier), ("kind", keepGoing kindOfType, False, completeIdentifier), ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile), ("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), + ("trace", traceCmd, False, completeIdentifier), ("undef", keepGoing undefineMacro, False, completeMacro), ("unset", keepGoing unsetOptions, True, completeSetOptions) ] @@ -150,6 +152,7 @@ helpText = "\n" ++ " evaluate/run \n" ++ " :add ... add module(s) to the current target set\n" ++ + " :abandon at a breakpoint, abandon current computation\n" ++ " :break [] [] set a breakpoint at the specified location\n" ++ " :break set a breakpoint on the specified function\n" ++ " :browse [*] display the names defined by \n" ++ @@ -270,8 +273,8 @@ interactiveUI session srcs maybe_expr = do session = session, options = [], prelude = prel_mod, - resume = [], - breaks = emptyActiveBreakPoints, + break_ctr = 0, + breaks = [], tickarrays = emptyModuleEnv } @@ -415,10 +418,9 @@ checkPerms name = fileLoop :: Handle -> Bool -> GHCi () fileLoop hdl show_prompt = do - session <- getSession - (mod,imports) <- io (GHC.getContext session) - st <- getGHCiState - when show_prompt (io (putStr (mkPrompt mod imports (resume st) (prompt st)))) + when show_prompt $ do + prompt <- mkPrompt + (io (putStr prompt)) l <- io (IO.try (hGetLine hdl)) case l of Left e | isEOFError e -> return () @@ -443,25 +445,40 @@ stringLoop (s:ss) = do l -> do quit <- runCommand l if quit then return True else stringLoop ss -mkPrompt toplevs exports resumes prompt - = showSDoc $ f prompt - where - f ('%':'s':xs) = perc_s <> f xs - f ('%':'%':xs) = char '%' <> f xs - f (x:xs) = char x <> f xs - f [] = empty - - perc_s - | (span,_,_):rest <- resumes - = (if not (null rest) then text "... " else empty) - <> brackets (ppr span) <+> modules_prompt - | otherwise - = modules_prompt - - modules_prompt = +mkPrompt = do + session <- getSession + (toplevs,exports) <- io (GHC.getContext session) + resumes <- io $ GHC.getResumeContext session + + context_bit <- + case resumes of + [] -> return empty + r:rs -> do + let ix = GHC.resumeHistoryIx r + if ix == 0 + then return (brackets (ppr (GHC.resumeSpan r)) <> space) + else do + let hist = GHC.resumeHistory r !! (ix-1) + span <- io $ GHC.getHistorySpan session hist + return (brackets (ppr (negate ix) <> char ':' + <+> ppr span) <> space) + let + dots | r:rs <- resumes, not (null rs) = text "... " + | otherwise = empty + + modules_bit = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> hsep (map (ppr . GHC.moduleName) exports) + deflt_prompt = dots <> context_bit <> modules_bit + + f ('%':'s':xs) = deflt_prompt <> f xs + f ('%':'%':xs) = char '%' <> f xs + f (x:xs) = char x <> f xs + f [] = empty + -- + st <- getGHCiState + return (showSDoc (f (prompt st))) #ifdef USE_READLINE @@ -472,8 +489,9 @@ readlineLoop = do io yield saveSession -- for use by completion st <- getGHCiState - l <- io (readline (mkPrompt mod imports (resume st) (prompt st)) - `finally` setNonBlockingFD 0) + mb_span <- getCurrentBreakSpan + prompt <- mkPrompt + l <- io (readline prompt `finally` setNonBlockingFD 0) -- readline sometimes puts stdin into blocking mode, -- so we need to put it back for the IO library splatSavedSession @@ -493,7 +511,7 @@ runCommand c = ghciHandle handler (doCommand c) where doCommand (':' : command) = specialCommand command doCommand stmt - = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms) + = do timeIt $ runStmt stmt GHC.RunToCompletion return False -- This version is for the GHC command-line option -e. The only difference @@ -507,28 +525,49 @@ runCommandEval c = ghciHandle handleEval (doCommand c) doCommand (':' : command) = specialCommand command doCommand stmt - = do nms <- runStmt stmt - case nms of - Nothing -> io (exitWith (ExitFailure 1)) + = do r <- runStmt stmt GHC.RunToCompletion + case r of + False -> io (exitWith (ExitFailure 1)) -- failure to run the command causes exit(1) for ghc -e. - _ -> do finishEvalExpr nms - return True + _ -> return True -runStmt :: String -> GHCi (Maybe (Bool,[Name])) -runStmt stmt - | null (filter (not.isSpace) stmt) = return (Just (False,[])) +runStmt :: String -> SingleStep -> GHCi Bool +runStmt stmt step + | null (filter (not.isSpace) stmt) = return False | otherwise = do st <- getGHCiState session <- getSession result <- io $ withProgName (progname st) $ withArgs (args st) $ - GHC.runStmt session stmt - switchOnRunResult result + GHC.runStmt session stmt step + afterRunStmt result + return (isRunResultOk result) + + +afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name])) +afterRunStmt run_result = do + mb_result <- switchOnRunResult run_result + -- possibly print the type and revert CAFs after evaluating an expression + show_types <- isOptionSet ShowType + session <- getSession + case mb_result of + Nothing -> return () + Just (is_break,names) -> + when (is_break || show_types) $ + mapM_ (showTypeOfName session) names + + flushInterpBuffers + io installSignalHandlers + b <- isOptionSet RevertCAFs + io (when b revertCAFs) + + return mb_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 (GHC.RunBreak threadId names info) = do session <- getSession Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info) let modBreaks = GHC.modInfoModBreaks mod_info @@ -538,28 +577,17 @@ 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 - -- run the command set with ":set stop " st <- getGHCiState runCommand (stop st) return (Just (True,names)) --- possibly print the type and revert CAFs after evaluating an expression -finishEvalExpr mb_names - = do show_types <- isOptionSet ShowType - session <- getSession - case mb_names of - Nothing -> return () - Just (is_break,names) -> - when (is_break || show_types) $ - mapM_ (showTypeOfName session) names - flushInterpBuffers - io installSignalHandlers - b <- isOptionSet RevertCAFs - io (when b revertCAFs) +isRunResultOk :: GHC.RunResult -> Bool +isRunResultOk (GHC.RunOk _) = True +isRunResultOk _ = False + showTypeOfName :: Session -> Name -> GHCi () showTypeOfName session n @@ -588,9 +616,29 @@ lookupCommand str = do [] -> return Nothing c:_ -> return (Just c) + +getCurrentBreakSpan :: GHCi (Maybe SrcSpan) +getCurrentBreakSpan = 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 (Just (GHC.resumeSpan r)) + else do + let hist = GHC.resumeHistory r !! (ix-1) + span <- io $ GHC.getHistorySpan session hist + return (Just span) + ----------------------------------------------------------------------------- -- Commands +noArgs :: GHCi () -> String -> GHCi () +noArgs m "" = m +noArgs m _ = io $ putStrLn "This command takes no arguments" + help :: String -> GHCi () help _ = io (putStr helpText) @@ -630,9 +678,6 @@ pprInfo exts (thing, fixity, insts) | 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)) @@ -788,7 +833,6 @@ reloadModule m = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. - discardResumeContext discardTickArrays discardActiveBreakPoints graph <- io (GHC.getModuleGraph session) @@ -868,118 +912,6 @@ shellEscape :: String -> GHCi Bool 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 () @@ -991,8 +923,8 @@ browseCmd m = browseModule m exports_only = do s <- getSession - modl <- if exports_only then lookupModule s m - else wantInterpretedModule s m + modl <- if exports_only then lookupModule m + else wantInterpretedModule m -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified @@ -1260,15 +1192,19 @@ cleanType ty = do showBkptTable :: GHCi () showBkptTable = do - activeBreaks <- getActiveBreakPoints - printForUser $ ppr activeBreaks + st <- getGHCiState + printForUser $ prettyLocations (breaks st) showContext :: GHCi () showContext = do - st <- getGHCiState - printForUser $ vcat (map pp_resume (resume st)) + session <- getSession + resumes <- io $ GHC.getResumeContext session + printForUser $ vcat (map pp_resume (reverse resumes)) where - pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span + pp_resume resume = + ptext SLIT("--> ") <> text (GHC.resumeStmt resume) + $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume)) + -- ----------------------------------------------------------------------------- -- Completion @@ -1446,6 +1382,28 @@ expandPath path = other -> return other +wantInterpretedModule :: String -> GHCi Module +wantInterpretedModule str = do + session <- getSession + modl <- lookupModule str + is_interpreted <- io (GHC.moduleIsInterpreted session modl) + when (not is_interpreted) $ + throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) + return modl + +wantNameFromInterpretedModule noCanDo str and_then = do + session <- getSession + names <- io $ GHC.parseName session str + case names of + [] -> return () + (n:_) -> do + let modl = GHC.nameModule n + is_interpreted <- io (GHC.moduleIsInterpreted session modl) + if not is_interpreted + then noCanDo n $ text "module " <> ppr modl <> + text " is not interpreted" + else and_then n + -- ---------------------------------------------------------------------------- -- Windows console setup @@ -1473,34 +1431,41 @@ setUpConsole = do -- ----------------------------------------------------------------------------- -- commands for debugger -foreign import ccall "rts_setStepFlag" setStepFlag :: IO () +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 stepCmd :: String -> GHCi Bool -stepCmd [] = doContinue setStepFlag -stepCmd expression = do - io $ setStepFlag - runCommand expression +stepCmd [] = doContinue GHC.SingleStep +stepCmd expression = runStmt expression GHC.SingleStep + +traceCmd :: String -> GHCi Bool +traceCmd [] = doContinue GHC.RunAndLogSteps +traceCmd expression = runStmt expression GHC.RunAndLogSteps continueCmd :: String -> GHCi Bool -continueCmd [] = doContinue $ return () +continueCmd [] = doContinue GHC.RunToCompletion 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 +doContinue :: SingleStep -> GHCi Bool +doContinue step = do + session <- getSession + runResult <- io $ GHC.resume session step + afterRunStmt runResult + return False + +abandonCmd :: String -> GHCi () +abandonCmd = noArgs $ do + s <- getSession + b <- io $ GHC.abandon s -- the prompt will change to indicate the new context + when (not b) $ io $ putStrLn "There is no computation running." + return () deleteCmd :: String -> GHCi () deleteCmd argLine = do @@ -1519,6 +1484,49 @@ deleteCmd argLine = do | all isDigit str = deleteBreak (read str) | otherwise = return () +historyCmd :: String -> GHCi () +historyCmd arg + | null arg = history 20 + | all isDigit arg = history (read arg) + | otherwise = io $ putStrLn "Syntax: :history [num]" + where + history num = do + s <- getSession + resumes <- io $ GHC.getResumeContext s + case resumes of + [] -> io $ putStrLn "Not stopped at a breakpoint" + (r:rs) -> do + 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))) + io $ putStrLn $ if null rest then "" else "..." + +backCmd :: String -> GHCi () +backCmd = noArgs $ do + s <- getSession + (names, ix, span) <- io $ GHC.back s + printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span + mapM_ (showTypeOfName s) names + -- run the command set with ":set stop " + st <- getGHCiState + runCommand (stop st) + return () + +forwardCmd :: String -> GHCi () +forwardCmd = noArgs $ do + s <- getSession + (names, ix, span) <- io $ GHC.forward s + printForUser $ (if (ix == 0) + then ptext SLIT("Stopped at") + else ptext SLIT("Logged breakpoint at")) <+> ppr span + mapM_ (showTypeOfName s) names + -- run the command set with ":set stop " + st <- getGHCiState + runCommand (stop st) + return () + -- handle the "break" command breakCmd :: String -> GHCi () breakCmd argLine = do @@ -1530,7 +1538,7 @@ 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 + mod <- wantInterpretedModule arg1 breakByModule session mod rest | all isDigit arg1 = do (toplevel, _) <- io $ GHC.getContext session @@ -1539,36 +1547,19 @@ breakSwitch session args@(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 $ + | otherwise = do -- try parsing it as an identifier + wantNameFromInterpretedModule noCanDo arg1 $ \name -> do + let loc = GHC.nameSrcLoc name + if GHC.isGoodSrcLoc loc + then findBreakAndSet (GHC.nameModule name) $ + findBreakByCoord (Just (GHC.srcLocFile loc)) + (GHC.srcLocLine loc, + GHC.srcLocCol loc) + else noCanDo name $ text "can't find its location: " <> ppr loc + where + noCanDo n 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 @@ -1579,7 +1570,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 () @@ -1625,13 +1616,14 @@ findBreakByLine line arr 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) @@ -1639,27 +1631,76 @@ 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) = (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" listCmd :: String -> GHCi () -listCmd str = do - st <- getGHCiState - case resume st of - [] -> printForUser $ text "not stopped at a breakpoint; nothing to list" - (span,_,_):_ -> io $ listAround span True +listCmd "" = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list" + Just span -> io $ listAround span True +listCmd str = list2 (words str) + +list2 [arg] | all isDigit arg = do + session <- getSession + (toplevel, _) <- io $ GHC.getContext session + case toplevel of + [] -> io $ putStrLn "No module to list" + (mod : _) -> listModuleLine mod (read arg) +list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do + mod <- wantInterpretedModule arg1 + listModuleLine mod (read arg2) +list2 [arg] = do + wantNameFromInterpretedModule noCanDo arg $ \name -> do + let loc = GHC.nameSrcLoc name + if GHC.isGoodSrcLoc loc + then do + tickArray <- getTickArray (GHC.nameModule name) + let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc)) + (GHC.srcLocLine loc, GHC.srcLocCol loc) + tickArray + case mb_span of + Nothing -> io $ listAround (GHC.srcLocSpan loc) False + Just (_,span) -> io $ listAround span False + else + noCanDo name $ text "can't find its location: " <> + ppr loc + where + noCanDo n why = printForUser $ + text "cannot list source code for " <> ppr n <> text ": " <> why +list2 _other = + io $ putStrLn "syntax: :list [ | | ]" + +listModuleLine :: Module -> Int -> GHCi () +listModuleLine modl line = do + session <- getSession + graph <- io (GHC.getModuleGraph session) + let this = filter ((== modl) . GHC.ms_mod) graph + case this of + [] -> panic "listModuleLine" + summ:_ -> do + let filename = fromJust (ml_hs_file (GHC.ms_location summ)) + loc = GHC.mkSrcLoc (mkFastString (filename)) line 0 + io $ listAround (GHC.srcLocSpan loc) False -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using @@ -1681,11 +1722,11 @@ listAround span do_highlight = do -- 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 @@ -1731,8 +1772,37 @@ mkTickArray ticks [ (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 ] + +lookupModule :: String -> GHCi Module +lookupModule modName + = do session <- getSession + io (GHC.findModule session (GHC.mkModuleName modName) Nothing) + +-- don't reset the counter back to zero? +discardActiveBreakPoints :: GHCi () +discardActiveBreakPoints = do + st <- getGHCiState + mapM (turnOffBreak.snd) (breaks st) + setGHCiState $ st { breaks = [] } + +deleteBreak :: Int -> GHCi () +deleteBreak identity = do + st <- getGHCiState + let oldLocations = breaks st + (this,rest) = partition (\loc -> fst loc == identity) oldLocations + if null this + then printForUser (text "Breakpoint" <+> ppr identity <+> + text "does not exist") + else do + mapM (turnOffBreak.snd) this + setGHCiState $ st { breaks = rest } + +turnOffBreak loc = do + (arr, _) <- getModBreak (breakModule loc) + io $ setBreakFlag False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak mod = do @@ -1743,28 +1813,8 @@ getModBreak mod = do 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 ()