-- (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"
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
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
("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),
" :sprint [<name> ...] simplifed version of :print\n" ++
" :step single-step after stopping at a breakpoint\n"++
" :step <expr> single-step into <expr>\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 <expr> trace into <expr> (remembers breakpoints for :history)\n"++
--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
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
+-- printTypeOfNames session names
+ printTypeAndContentOfNames 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 ()
+ afterRunStmt step_here >> return ()
_ -> return ()
flushInterpBuffers
return (case run_result of GHC.RunOk _ -> True; _ -> False)
+ where printTypeAndContentOfNames session names = do
+ let namesSorted = sortBy compareNames names
+ tythings <- catMaybes `liftM`
+ 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
+ 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 ()
runBreakCmd info = do
let mod = GHC.breakInfo_module info
(r:rs) -> do
let ix = GHC.resumeHistoryIx r
if ix == 0
- then return (GHC.breakInfo_module `fmap` GHC.resumeBreakInfo r)
+ then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
else do
let hist = GHC.resumeHistory r !! (ix-1)
return $ Just $ GHC.getHistoryModule hist
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
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
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
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
t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
printTyThing :: TyThing -> GHCi ()
-printTyThing (AnId id) = do
- ty' <- cleanType (GHC.idType id)
- printForUser $ ppr id <> text " :: " <> ppr ty'
-printTyThing _ = 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
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
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
| 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
-- 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
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
-
- where
-
-{-
- 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
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 ()
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
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'
-- --------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff