X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=f0a8fb4a1483bd5c6b1e38d23d99e54e5656ea3f;hb=fcd7ba21a64c12b6e0f1053892d2698ae7d29f81;hp=169168f8f25ddcc461a1c29434bcc7f0cdfc6f8b;hpb=a6b396baed89129d9b68080dc03072d77da0aa49;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 169168f..f0a8fb4 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -23,10 +23,12 @@ import DynFlags 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 @@ -36,6 +38,8 @@ import Config import StaticFlags import Linker import Util +import NameSet +import Maybes ( orElse ) import FastString #ifndef mingw32_HOST_OS @@ -126,6 +130,7 @@ builtin_commands = [ ("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), @@ -157,8 +162,8 @@ helpText = " :info [ ...] display information about the given names\n" ++ " :kind show the kind of \n" ++ " :load ... load module(s) and their dependents\n" ++ - " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :main [ ...] run the main function with the given arguments\n" ++ + " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :quit exit GHCi\n" ++ " :reload reload the current module set\n" ++ " :type show the type of \n" ++ @@ -554,28 +559,32 @@ runStmt stmt step 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 " - 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 " + st <- getGHCiState + enqueueCommands [stop st] + return () + | otherwise -> io(GHC.resume session GHC.SingleStep) >>= + afterRunStmt pred >> return () _ -> return () flushInterpBuffers @@ -648,6 +657,20 @@ getCurrentBreakSpan = do 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 @@ -667,23 +690,22 @@ info s = do { let names = words s ; mapM_ (infoThing pefas session) names } where infoThing pefas session str = io $ do - names <- GHC.parseName session str - let filtered = filterOutChildren names - mb_stuffs <- mapM (GHC.getInfo session) filtered + 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 pefas 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 +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) @@ -994,16 +1016,16 @@ browseModule m exports_only = do 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 pefas = dopt Opt_PrintExplicitForalls dflags io (putStrLn (showSDocForUser unqual ( - vcat (map (pprTyThingInContext pefas) (catMaybes things)) + vcat (map (pprTyThingInContext pefas) filtered_things) ))) -- ToDo: modInfoInstances currently throws an exception for -- package modules. When it works, we can do this: @@ -1523,21 +1545,73 @@ pprintCommand bind force str = do 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 ()