X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=8f22af887b411b9d1949b15652d654a2f099890a;hb=7ac266d097639620e4fea22c40450c8d7822f5fb;hp=1ab604c6cdf76d3e7c39b322032ba7a9a6b60f94;hpb=ed1f16f4bde6ffcbb953ebeea0db1bc3802d3af3;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 1ab604c..8f22af8 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 ) import DynFlags import Packages import PackageConfig @@ -29,11 +30,6 @@ 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) @@ -43,6 +39,7 @@ import Config import StaticFlags import Linker import Util +import FastString #ifndef mingw32_HOST_OS import System.Posix @@ -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,6 +103,7 @@ 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), ("browse", keepGoing browseCmd, False, completeModule), ("cd", keepGoing changeDirectory, False, completeFilename), @@ -117,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), @@ -125,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), @@ -150,6 +148,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" ++ @@ -418,7 +417,7 @@ fileLoop hdl show_prompt = do session <- getSession (mod,imports) <- io (GHC.getContext session) st <- getGHCiState - when show_prompt (io (putStr (mkPrompt mod imports (prompt st)))) + when show_prompt (io (putStr (mkPrompt mod imports (resume st) (prompt st)))) l <- io (IO.try (hGetLine hdl)) case l of Left e | isEOFError e -> return () @@ -443,7 +442,7 @@ stringLoop (s:ss) = do l -> do quit <- runCommand l if quit then return True else stringLoop ss -mkPrompt toplevs exports prompt +mkPrompt toplevs exports resumes prompt = showSDoc $ f prompt where f ('%':'s':xs) = perc_s <> f xs @@ -451,8 +450,17 @@ mkPrompt toplevs exports prompt f (x:xs) = char x <> f xs f [] = empty - perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> - hsep (map (ppr . GHC.moduleName) exports) + perc_s + | eval:rest <- resumes + = (if not (null rest) then text "... " else empty) + <> brackets (ppr (evalSpan eval)) <+> modules_prompt + | otherwise + = modules_prompt + + modules_prompt = + hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> + hsep (map (ppr . GHC.moduleName) exports) + #ifdef USE_READLINE @@ -463,7 +471,7 @@ readlineLoop = do io yield saveSession -- for use by completion st <- getGHCiState - l <- io (readline (mkPrompt mod imports (prompt st)) + l <- io (readline (mkPrompt mod imports (resume st) (prompt st)) `finally` setNonBlockingFD 0) -- readline sometimes puts stdin into blocking mode, -- so we need to put it back for the IO library @@ -513,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 @@ -529,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 @@ -621,9 +632,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)) @@ -859,118 +867,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 () @@ -1257,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 @@ -1464,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 @@ -1485,14 +1391,24 @@ 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 +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 @@ -1535,16 +1451,18 @@ breakSwitch session args@(arg1:rest) 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 @@ -1570,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 () @@ -1609,20 +1527,21 @@ findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) findBreakByLine line arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy leftmost complete) `mplus` - listToMaybe (sortBy leftmost incomplete) `mplus` + listToMaybe (sortBy leftmost_largest complete) `mplus` + listToMaybe (sortBy leftmost_smallest incomplete) `mplus` listToMaybe (sortBy rightmost ticks) where 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) @@ -1630,14 +1549,23 @@ 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 ] -leftmost (_,a) (_,b) = a `compare` b + 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) + `thenCmp` + (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" @@ -1647,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 @@ -1656,9 +1584,9 @@ listAround span do_highlight = do contents <- BS.readFile (unpackFS file) let lines = BS.split '\n' contents - these_lines = take (line2 - line1 + 1 + 2*padding) $ - drop (line1 - 1 - padding) $ lines - fst_line = max 1 (line1 - padding) + these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ + drop (line1 - 1 - pad_before) $ lines + fst_line = max 1 (line1 - pad_before) line_nos = [ fst_line .. ] highlighted | do_highlight = zipWith highlight line_nos these_lines @@ -1669,12 +1597,15 @@ 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 - padding = 1 + 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 + pad_after = 1 highlight no line | no == line1 && no == line2 @@ -1716,8 +1647,9 @@ 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 ] getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak mod = do