X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=ec1f4bf98e892080e81cd0c69650f2ea552883ab;hb=9efeaae7dd6d720b0f44b0a73ed4881d7eb41034;hp=bea11bf646e208dbb540f6725a415718c7b25ec7;hpb=a27d12f02b8ab3a3222c351dcf7e9168dfe05fb0;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index bea11bf..ec1f4bf 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,6 +6,13 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -19,12 +26,12 @@ import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, BreakIndex, SrcSpan, Resume, SingleStep ) +import PprTyThing import DynFlags import Packages import PackageConfig import UniqFM import HscTypes ( implicitTyThings ) -import PprTyThing import Outputable hiding (printForUser) import Module -- for ModuleEnv import Name @@ -69,6 +76,7 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO +import System.IO.Unsafe import Data.Char import Data.Dynamic import Data.Array @@ -130,7 +138,8 @@ builtin_commands = [ ("show", keepGoing showCmd, False, completeNone), ("sprint", keepGoing sprintCmd, False, completeIdentifier), ("step", keepGoing stepCmd, False, completeIdentifier), - ("stepover", keepGoing stepOverCmd, False, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier), ("type", keepGoing typeOfExpr, False, completeIdentifier), ("trace", keepGoing traceCmd, False, completeIdentifier), ("undef", keepGoing undefineMacro, False, completeMacro), @@ -186,7 +195,8 @@ helpText = " :sprint [ ...] simplifed version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ " :step single-step into \n"++ - " :stepover single-step without following function applications\n"++ + " :steplocal single-step restricted to the current top level decl.\n"++ + " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ " :trace trace into (remembers breakpoints for :history)\n"++ @@ -566,7 +576,7 @@ runStmt stmt step --afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile afterRunStmt _ (GHC.RunException e) = throw e -afterRunStmt pred run_result = do +afterRunStmt step_here run_result = do session <- getSession resumes <- io $ GHC.getResumeContext session case run_result of @@ -575,7 +585,7 @@ afterRunStmt pred run_result = do when show_types $ printTypeOfNames session names GHC.RunBreak _ names mb_info | isNothing mb_info || - pred (GHC.resumeSpan $ head resumes) -> do + step_here (GHC.resumeSpan $ head resumes) -> do printForUser $ ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) -- printTypeOfNames session names @@ -586,7 +596,7 @@ afterRunStmt pred run_result = do enqueueCommands [stop st] return () | otherwise -> io(GHC.resume session GHC.SingleStep) >>= - afterRunStmt pred >> return () + afterRunStmt step_here >> return () _ -> return () flushInterpBuffers @@ -599,13 +609,14 @@ afterRunStmt pred run_result = do where printTypeAndContentOfNames session names = do let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` - io (mapM (GHC.lookupName session) names) - docs_ty <- mapM showTyThing tythings - terms <- mapM (io . GHC.obtainTermB session 10 False) - [ id | (AnId id, Just _) <- zip tythings docs_ty] + io (mapM (GHC.lookupName session) namesSorted) + let ids = [id | AnId id <- tythings] + terms <- mapM (io . GHC.obtainTermB session 10 False) ids docs_terms <- mapM (io . showTerm session) terms - printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts) - (catMaybes docs_ty) + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) + (map (pprTyThing pefas . AnId) ids) docs_terms runBreakCmd :: GHC.BreakInfo -> GHCi () @@ -922,10 +933,9 @@ doLoad session howmuch = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. discardTickArrays - graph <- io (GHC.getModuleGraph session) - graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph - setContextAfterLoad session graph' - modulesLoadedMsg ok (map GHC.ms_mod_name graph') + loaded_mods <- getLoadedModules session + setContextAfterLoad session loaded_mods + modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods) setContextAfterLoad session [] = do prel_mod <- getPrelude @@ -981,8 +991,10 @@ typeOfExpr str maybe_ty <- io (GHC.exprType cms str) case maybe_ty of Nothing -> return () - Just ty -> do ty' <- cleanType ty - printForUser $ text str <> text " :: " <> ppr ty' + Just ty -> do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ text str <+> dcolon + <+> pprTypeForUser pefas ty kindOfType :: String -> GHCi () kindOfType str @@ -990,7 +1002,7 @@ kindOfType str maybe_ty <- io (GHC.typeKind cms str) case maybe_ty of Nothing -> return () - Just ty -> printForUser $ text str <> text " :: " <> ppr ty + Just ty -> printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> GHCi Bool quit _ = return True @@ -1274,10 +1286,15 @@ showCmd str = do showModules = do session <- getSession - let show_one ms = do m <- io (GHC.showModule session ms) - io (putStrLn m) + loaded_mods <- getLoadedModules session + -- we want *loaded* modules only, see #1734 + let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m) + mapM_ show_one loaded_mods + +getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary] +getLoadedModules session = do graph <- io (GHC.getModuleGraph session) - mapM_ show_one graph + filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph showBindings = do s <- getSession @@ -1289,26 +1306,10 @@ showBindings = do compareTyThings :: TyThing -> TyThing -> Ordering t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 -showTyThing :: TyThing -> GHCi (Maybe SDoc) -showTyThing (AnId id) = do - ty' <- cleanType (GHC.idType id) - return $ Just $ ppr id <> text " :: " <> ppr ty' -showTyThing _ = return Nothing - printTyThing :: TyThing -> GHCi () -printTyThing tyth = do - mb_x <- showTyThing tyth - case mb_x of - Just x -> printForUser x - Nothing -> return () - --- if -fglasgow-exts is on we show the foralls, otherwise we don't. -cleanType :: Type -> GHCi Type -cleanType ty = do - dflags <- getDynFlags - if dopt Opt_PrintExplicitForalls dflags - then return ty - else return $! GHC.dropForAlls ty +printTyThing tyth = do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser (pprTyThing pefas tyth) showBkptTable :: GHCi () showBkptTable = do @@ -1336,10 +1337,11 @@ completeNone w = return [] completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) completeWord w start end = do line <- Readline.getLineBuffer - case w of + let line_words = words (dropWhile isSpace line) + case w of ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w _other - | Just c <- is_cmd line -> do + | ((':':c) : _) <- line_words -> do maybe_cmd <- lookupCommand c let (n,w') = selectWord (words' 0 line) case maybe_cmd of @@ -1348,6 +1350,8 @@ completeWord w start end = do Just (_,_,True,complete) -> let complete' w = do rets <- complete w return (map (drop n) rets) in wrapCompleter complete' w' + | ("import" : _) <- line_words -> + wrapCompleter completeModule w | otherwise -> do --printf "complete %s, start = %d, end = %d\n" w start end wrapCompleter completeIdentifier w @@ -1363,9 +1367,6 @@ completeWord w start end = do | offset+length x >= start = (start-offset,take (end-offset) x) | otherwise = selectWord xs -is_cmd line - | ((':':w) : _) <- words (dropWhile isSpace line) = Just w - | otherwise = Nothing completeCmd w = do cmds <- readIORef commands @@ -1539,14 +1540,17 @@ setUpConsole = do -- similarly for characters we write to the console. -- -- At the moment, GHCi pretends all input is Latin-1. In the - -- future we should support UTF-8, but for now we set the code pages - -- to Latin-1. + -- future we should support UTF-8, but for now we set the code + -- pages to Latin-1. Doing it this way does lead to problems, + -- however: see bug #1649. -- -- It seems you have to set the font in the console window to -- a Unicode font in order for output to work properly, -- otherwise non-ASCII characters are mapped wrongly. sigh. -- (see MSDN for SetConsoleOutputCP()). -- + -- This call has been known to hang on some machines, see bug #1483 + -- setConsoleCP 28591 -- ISO Latin-1 setConsoleOutputCP 28591 -- ISO Latin-1 #endif @@ -1567,43 +1571,31 @@ stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep stepCmd expression = do runStmt expression GHC.SingleStep; return () -stepOverCmd [] = do +stepLocalCmd :: String -> GHCi () +stepLocalCmd [] = do mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] Just loc -> do Just mod <- getCurrentBreakModule - parent <- enclosingTickSpan mod loc - allTicksRightmost <- (sortBy rightmost . map snd) `fmap` - ticksIn mod parent - let lastTick = null allTicksRightmost || - head allTicksRightmost == loc - if not lastTick - then doContinue (`isSubspanOf` parent) GHC.SingleStep - else doContinue (const True) GHC.SingleStep - -stepOverCmd expression = stepCmd expression - -{- - So, the only tricky part 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 --} - ---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 - ] + current_toplevel_decl <- enclosingTickSpan mod loc + doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep +stepLocalCmd expression = stepCmd expression + +stepModuleCmd :: String -> GHCi () +stepModuleCmd [] = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just loc -> do + Just span <- getCurrentBreakSpan + let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span + doContinue f GHC.SingleStep + +stepModuleCmd expression = stepCmd expression + +-- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan enclosingTickSpan mod src = do ticks <- getTickArray mod @@ -1820,18 +1812,19 @@ findBreakByCoord mb_file (line, col) arr GHC.srcSpanStartLine span == line, GHC.srcSpanStartCol span >= col ] --- 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 --- (including xterm) do, so this is a reasonable guess until we have a --- proper termcap/terminfo library. -#if !defined(mingw32_TARGET_OS) -do_bold = True -#else -do_bold = False -#endif - +-- For now, use ANSI bold on terminals that we know support it. +-- Otherwise, we add a line of carets under the active expression instead. +-- In particular, on Windows and when running the testsuite (which sets +-- TERM to vt100 for other reasons) we get carets. +-- We really ought to use a proper termcap/terminfo library. +do_bold :: Bool +do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"] + where mTerm = System.Environment.getEnv "TERM" + `Exception.catch` \e -> return "TERM not set" + +start_bold :: String start_bold = "\ESC[1m" +end_bold :: String end_bold = "\ESC[0m" listCmd :: String -> GHCi () @@ -1898,10 +1891,10 @@ listAround span do_highlight = do line_nos = [ fst_line .. ] highlighted | do_highlight = zipWith highlight line_nos these_lines - | otherwise = these_lines + | otherwise = [\p -> BS.concat[p,l] | l <- these_lines] bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] - prefixed = zipWith BS.append bs_line_nos highlighted + prefixed = zipWith ($) highlighted bs_line_nos -- BS.putStrLn (BS.join (BS.pack "\n") prefixed) where @@ -1918,32 +1911,33 @@ listAround span do_highlight = do highlight | do_bold = highlight_bold | otherwise = highlight_carets - highlight_bold no line + highlight_bold no line prefix | no == line1 && no == line2 = let (a,r) = BS.splitAt col1 line (b,c) = BS.splitAt (col2-col1) r in - BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c] + BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c] | no == line1 = let (a,b) = BS.splitAt col1 line in - BS.concat [a, BS.pack start_bold, b] + BS.concat [prefix, a, BS.pack start_bold, b] | no == line2 = let (a,b) = BS.splitAt col2 line in - BS.concat [a, BS.pack end_bold, b] - | otherwise = line + BS.concat [prefix, a, BS.pack end_bold, b] + | otherwise = BS.concat [prefix, line] - highlight_carets no line + highlight_carets no line prefix | no == line1 && no == line2 - = BS.concat [line, nl, indent, BS.replicate col1 ' ', + = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ', BS.replicate (col2-col1) '^'] | no == line1 - = BS.concat [line, nl, indent, BS.replicate col1 ' ', - BS.replicate (BS.length line-col1) '^'] + = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, + prefix, line] | no == line2 - = BS.concat [line, nl, indent, BS.replicate col2 '^'] - | otherwise = line + = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ', + BS.pack "^^"] + | otherwise = BS.concat [prefix, line] where - indent = BS.pack " " + indent = BS.pack (" " ++ replicate (length (show no)) ' ') nl = BS.singleton '\n' -- --------------------------------------------------------------------------