A new :stepover command for the debugger

[ghc-hetmet.git] / compiler / ghci / InteractiveUI.hs

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 169168f..f0a8fb4 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -23,10 +23,12 @@ import DynFlags
 import Packages
 import PackageConfig
 import UniqFM
 import Packages
 import PackageConfig
 import UniqFM

+import HscTypes                ( implicitTyThings )

 import PprTyThing
 import Outputable       hiding (printForUser)
 import Module           -- for ModuleEnv
 import Name
 import PprTyThing
 import Outputable       hiding (printForUser)
 import Module           -- for ModuleEnv
 import Name

+import SrcLoc

 
 -- Other random utilities
 import Digraph
 
 -- Other random utilities
 import Digraph

@@ -36,6 +38,8 @@ import Config
 import StaticFlags
 import Linker
 import Util
 import StaticFlags
 import Linker
 import Util

+import NameSet
+import Maybes          ( orElse )

 import FastString
 
 #ifndef mingw32_HOST_OS
 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), 
   ("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),
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("trace",     keepGoing traceCmd,             False, completeIdentifier), 
   ("undef",     keepGoing undefineMacro,       False, completeMacro),

@@ -157,8 +162,8 @@ helpText =
  "   :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" ++
  "   :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" ++
  "   :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" ++
  "   :quit                       exit GHCi\n" ++
  "   :reload                     reload the current module set\n" ++
  "   :type <expr>                show the type of <expr>\n" ++

@@ -554,28 +559,32 @@ runStmt stmt step
       session <- getSession
       result <- io $ withProgName (progname st) $ withArgs (args st) $
                     GHC.runStmt session 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
                                  -- 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
   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
      _ -> return ()
 
   flushInterpBuffers

@@ -648,6 +657,20 @@ getCurrentBreakSpan = do
                 span <- io $ GHC.getHistorySpan session hist
                 return (Just span)
 
                 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
 
 -----------------------------------------------------------------------------
 -- Commands
 

@@ -667,23 +690,22 @@ info s  = do { let names = words s
             ; mapM_ (infoThing pefas session) names }
   where
     infoThing pefas session str = io $ do
             ; 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 "") $
        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
 
   -- 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)
 
 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
     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 (
 
         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:
           )))
        -- 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 ()
   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 ()
 
 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 :: String -> GHCi ()

-traceCmd []         = doContinue GHC.RunAndLogSteps
+traceCmd []         = doContinue (const True) GHC.RunAndLogSteps

 traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
 
 continueCmd :: String -> GHCi ()
 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
   session <- getSession
   runResult <- io $ GHC.resume session step

-  afterRunStmt runResult
+  afterRunStmt pred runResult

   return ()
 
 abandonCmd :: String -> GHCi ()
   return ()
 
 abandonCmd :: String -> GHCi ()