-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------
-module InteractiveUI ( interactiveUI ) where
+module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
#include "HsVersions.h"
import Packages
import PackageConfig
import UniqFM
+import HscTypes ( implicitTyThings )
import PprTyThing
import Outputable hiding (printForUser)
import Module -- for ModuleEnv
import Name
+import SrcLoc
-- Other random utilities
import Digraph
import StaticFlags
import Linker
import Util
+import NameSet
+import Maybes ( orElse )
import FastString
#ifndef mingw32_HOST_OS
-----------------------------------------------------------------------------
-ghciWelcomeMsg =
- " ___ ___ _\n"++
- " / _ \\ /\\ /\\/ __(_)\n"++
- " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
- "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
- "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
-
-ghciShortWelcomeMsg =
- "GHCi, version " ++ cProjectVersion ++
- ": http://www.haskell.org/ghc/ :? for help"
+ghciWelcomeMsg :: String
+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
+ ": http://www.haskell.org/ghc/ :? for help"
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
cmdName (n,_,_,_) = n
("show", keepGoing showCmd, False, completeNone),
("sprint", keepGoing sprintCmd, False, completeIdentifier),
("step", keepGoing stepCmd, False, completeIdentifier),
+ ("stepover", keepGoing stepOverCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("trace", keepGoing traceCmd, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
" :info [<name> ...] display information about the given names\n" ++
" :kind <type> show the kind of <type>\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
- " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++
+ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
" :quit exit GHCi\n" ++
" :reload reload the current module set\n" ++
" :type <expr> show the type of <expr>\n" ++
-- initialise the console if necessary
io setUpConsole
- let msg = if dopt Opt_ShortGhciBanner dflags
- then ghciShortWelcomeMsg
- else ghciWelcomeMsg
- when (verbosity dflags >= 1) $ io $ putStrLn msg
-
-- enter the interactive loop
interactiveLoop is_tty show_prompt
Just expr -> do
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt step
- afterRunStmt result
+ afterRunStmt (const True) result
-afterRunStmt :: GHC.RunResult -> GHCi Bool
+--afterRunStmt :: GHC.RunResult -> GHCi Bool
-- False <=> the statement failed to compile
-afterRunStmt (GHC.RunException e) = throw e
-afterRunStmt run_result = do
- session <- getSession
+afterRunStmt _ (GHC.RunException e) = throw e
+afterRunStmt pred run_result = do
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
case run_result of
GHC.RunOk names -> do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames session names
- GHC.RunBreak _ names mb_info -> do
- resumes <- io $ GHC.getResumeContext session
- printForUser $ ptext SLIT("Stopped at") <+>
- ppr (GHC.resumeSpan (head resumes))
- printTypeOfNames session names
- maybe (return ()) runBreakCmd mb_info
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- enqueueCommands [stop st]
- return ()
+ GHC.RunBreak _ names mb_info
+ | isNothing mb_info ||
+ pred (GHC.resumeSpan $ head resumes) -> do
+ printForUser $ ptext SLIT("Stopped at") <+>
+ ppr (GHC.resumeSpan $ head resumes)
+ printTypeOfNames 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 ()
_ -> return ()
flushInterpBuffers
-- look for exact match first, then the first prefix match
case [ c | c <- cmds, str == cmdName c ] of
c:_ -> return (Just c)
- [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
+ [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
[] -> return Nothing
c:_ -> return (Just c)
span <- io $ GHC.getHistorySpan session hist
return (Just span)
+getCurrentBreakModule :: GHCi (Maybe Module)
+getCurrentBreakModule = 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 (GHC.breakInfo_module `fmap` GHC.resumeBreakInfo r)
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ return $ Just $ GHC.getHistoryModule hist
+
-----------------------------------------------------------------------------
-- Commands
info s = do { let names = words s
; session <- getSession
; dflags <- getDynFlags
- ; let exts = dopt Opt_GlasgowExts dflags
- ; mapM_ (infoThing exts session) names }
+ ; let pefas = dopt Opt_PrintExplicitForalls dflags
+ ; mapM_ (infoThing pefas session) names }
where
- infoThing exts session str = io $ do
- names <- GHC.parseName session str
- let filtered = filterOutChildren names
- mb_stuffs <- mapM (GHC.getInfo session) filtered
+ infoThing pefas session str = io $ do
+ names <- GHC.parseName session str
+ mb_stuffs <- mapM (GHC.getInfo session) names
+ let filtered = filterOutChildren (\(t,f,i) -> t) (catMaybes mb_stuffs)
unqual <- GHC.getPrintUnqual session
putStrLn (showSDocForUser unqual $
vcat (intersperse (text "") $
- [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
+ map (pprInfo pefas) filtered))
-- Filter out names whose parent is also there Good
-- example is '[]', which is both a type and data
-- constructor in the same type
-filterOutChildren :: [Name] -> [Name]
-filterOutChildren names = filter (not . parent_is_there) names
- where parent_is_there n
--- | Just p <- GHC.nameParent_maybe n = p `elem` names
--- ToDo!!
- | otherwise = False
-
-pprInfo exts (thing, fixity, insts)
- = pprTyThingInContextLoc exts thing
+filterOutChildren :: (a -> TyThing) -> [a] -> [a]
+filterOutChildren get_thing xs
+ = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
+ where
+ implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
+
+pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
+pprInfo pefas (thing, fixity, insts)
+ = pprTyThingInContextLoc pefas thing
$$ show_fixity fixity
$$ vcat (map GHC.pprInstance insts)
where
checkModule m = do
let modl = GHC.mkModuleName m
session <- getSession
- result <- io (GHC.checkModule session modl)
+ result <- io (GHC.checkModule session modl False)
case result of
Nothing -> io $ putStrLn "Nothing"
Just r -> io $ putStrLn (showSDoc (
Just mod_info -> do
let names
| exports_only = GHC.modInfoExports mod_info
- | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
+ | otherwise = GHC.modInfoTopLevelScope mod_info
+ `orElse` []
- filtered = filterOutChildren names
-
- things <- io $ mapM (GHC.lookupName s) filtered
+ mb_things <- io $ mapM (GHC.lookupName s) names
+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
dflags <- getDynFlags
- let exts = dopt Opt_GlasgowExts dflags
+ let pefas = dopt Opt_PrintExplicitForalls dflags
io (putStrLn (showSDocForUser unqual (
- vcat (map (pprTyThingInContext exts) (catMaybes things))
+ vcat (map (pprTyThingInContext pefas) filtered_things)
)))
-- ToDo: modInfoInstances currently throws an exception for
-- package modules. When it works, we can do this:
cleanType :: Type -> GHCi Type
cleanType ty = do
dflags <- getDynFlags
- if dopt Opt_GlasgowExts dflags
+ if dopt Opt_PrintExplicitForalls dflags
then return ty
else return $! GHC.dropForAlls ty
io $ pprintClosureCommand session bind force str
stepCmd :: String -> GHCi ()
-stepCmd [] = doContinue GHC.SingleStep
+stepCmd [] = doContinue (const True) GHC.SingleStep
stepCmd expression = do runStmt expression GHC.SingleStep; return ()
+stepOverCmd [] = do
+ mb_span <- getCurrentBreakSpan
+ case mb_span of
+ Nothing -> stepCmd []
+ Just loc -> do
+ Just mod <- getCurrentBreakModule
+ parent <- enclosingSubSpan mod loc
+ allTicksRightmost <- sortBy rightmost `fmap`
+ ticksIn mod parent
+ let lastTick = null allTicksRightmost ||
+ snd(head allTicksRightmost) == loc
+ if not lastTick
+ then doContinue (`lexicalSubSpanOf` 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
+ 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
+ ]
+
+enclosingSubSpan :: Module -> SrcSpan -> GHCi SrcSpan
+enclosingSubSpan mod src = do
+ ticks <- getTickArray mod
+ let line = srcSpanStartLine src
+ ASSERT (inRange (bounds arr) line) do
+ let enclosing_spans = [ t | t@(_,span) <- ticks ! line
+ , srcSpanEnd span >= srcSpanEnd src]
+ return . snd . head . sortBy leftmost_largest $ enclosing_spans
+
+lexicalSubSpanOf :: SrcSpan -> SrcSpan -> Bool
+lexicalSubSpanOf src parent
+ | GHC.srcSpanFile parent /= GHC.srcSpanFile src = False
+ | otherwise = srcSpanStart parent <= srcSpanStart src &&
+ srcSpanEnd parent >= srcSpanEnd src
+
traceCmd :: String -> GHCi ()
-traceCmd [] = doContinue GHC.RunAndLogSteps
+traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
continueCmd :: String -> GHCi ()
-continueCmd = noArgs $ doContinue GHC.RunToCompletion
+continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
-doContinue :: SingleStep -> GHCi ()
-doContinue step = do
+-- doContinue :: SingleStep -> GHCi ()
+doContinue pred step = do
session <- getSession
runResult <- io $ GHC.resume session step
- afterRunStmt runResult
+ afterRunStmt pred runResult
return ()
abandonCmd :: String -> GHCi ()
breakByModule session mod args@(arg1:rest)
| all isDigit arg1 = do -- looks like a line number
breakByModuleLine mod (read arg1) rest
- | otherwise = io $ putStrLn "Invalid arguments to :break"
+breakByModule session mod _
+ = breakSyntax
breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
breakByModuleLine mod line args
| [] <- args = findBreakAndSet mod $ findBreakByLine line
| [col] <- args, all isDigit col =
findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
- | otherwise = io $ putStrLn "Invalid arguments to :break"
+ | otherwise = breakSyntax
+
+breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
findBreakAndSet mod lookupTickTree = do
-- If the highlight flag is True, also highlight the span using
-- start_bold/end_bold.
listAround span do_highlight = do
- pwd <- getEnv "PWD"
- contents <- BS.readFile (pwd `joinFileName` unpackFS file)
+ contents <- BS.readFile (unpackFS file)
let
lines = BS.split '\n' contents
these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
projects / ghc-hetmet.git / blobdiff