Taught :breakpoint add to guess the module name if not given

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index d6f557d..b5af439 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -114,7 +114,12 @@ builtin_commands :: [Command]
 builtin_commands = [
   ("add",      tlC$ keepGoingPaths addModule,  False, completeFilename),
   ("browse",    keepGoing browseCmd,           False, completeModule),
 builtin_commands = [
   ("add",      tlC$ keepGoingPaths addModule,  False, completeFilename),
   ("browse",    keepGoing browseCmd,           False, completeModule),

-  ("cd",       keepGoing changeDirectory,      False, completeFilename),
+#ifdef DEBUGGER
+        -- I think that :c should mean :continue rather than :cd, makes more sense
+        --  (pepe 01.11.07)
+  ("continue",  const(bkptOptions "continue"),  False, completeNone),
+#endif
+  ("cd",       tlC$ keepGoing changeDirectory, False, completeFilename),

   ("def",      keepGoing defineMacro,          False, completeIdentifier),
   ("e",        keepGoing editFile,             False, completeFilename),
        -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("def",      keepGoing defineMacro,          False, completeIdentifier),
   ("e",        keepGoing editFile,             False, completeFilename),
        -- Hugs users are accustomed to :e, so make sure it doesn't overlap

@@ -136,7 +141,7 @@ builtin_commands = [
   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
   ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
   ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),

-  ("breakpoint",keepGoing bkptOptions,          False, completeBkpt),
+  ("breakpoint",bkptOptions,                    False, completeBkpt),

 #endif
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),
   ("unset",    keepGoing unsetOptions,         True,  completeSetOptions),
 #endif
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),
   ("unset",    keepGoing unsetOptions,         True,  completeSetOptions),

@@ -147,7 +152,7 @@ builtin_commands = [
 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 
 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 

--- tlC: Top Level Command
+-- tlC: Top Level Command, not allowed in inferior sessions

 tlC ::  (String -> GHCi Bool) -> (String -> GHCi Bool)
 tlC a str = do 
     top_level <- isTopLevel
 tlC ::  (String -> GHCi Bool) -> (String -> GHCi Bool)
 tlC a str = do 
     top_level <- isTopLevel

@@ -169,13 +174,14 @@ helpText =
  "   :breakpoint <option>        commands for the GHCi debugger\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++
  "   :breakpoint <option>        commands for the GHCi debugger\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++

+ "   :continue                   equivalent to ':breakpoint continue'\n"  ++

  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
  "   :help, :?                   display this list of commands\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :print [<name> ...]         prints a value without forcing its computation\n" ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
  "   :help, :?                   display this list of commands\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :print [<name> ...]         prints a value without forcing its computation\n" ++

- "   :sprint [<name> ...]        prints a value without forcing its computation(simpler)\n" ++
+ "   :sprint [<name> ...]        simplified version of :print\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" ++
  "   :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" ++

@@ -209,8 +215,9 @@ helpText =
  "\n" ++
  " Options for ':breakpoint':\n" ++
  "   list                                     list the current breakpoints\n" ++
  "\n" ++
  " Options for ':breakpoint':\n" ++
  "   list                                     list the current breakpoints\n" ++

- "   add Module line [col]                    add a new breakpoint\n" ++
+ "   add [Module] line [col]                    add a new breakpoint\n" ++

  "   del (breakpoint# | Module line [col])    delete a breakpoint\n" ++
  "   del (breakpoint# | Module line [col])    delete a breakpoint\n" ++

+ "   continue                                 continue execution\n"  ++

  "   stop                   Stop a computation and return to the top level\n" ++
  "   step [count]           Step by step execution (DISABLED)\n"
 
  "   stop                   Stop a computation and return to the top level\n" ++
  "   step [count]           Step by step execution (DISABLED)\n"
 

@@ -772,7 +779,10 @@ afterLoad ok session = do
   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'
   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'

-  refreshBkptTable graph'
+  do 
+     bt  <- getBkptTable
+     bt' <- io$ refreshBkptTable session bt graph'
+     setBkptTable bt'

   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 
 setContextAfterLoad session [] = do
   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 
 setContextAfterLoad session [] = do

@@ -843,7 +853,11 @@ kindOfType str
                           io (putStrLn (str ++ " :: " ++ tystr))
 
 quit :: String -> GHCi Bool
                           io (putStrLn (str ++ " :: " ++ tystr))
 
 quit :: String -> GHCi Bool

-quit _ = return True
+quit _ =  do in_inferior_session <- liftM not isTopLevel 
+             if in_inferior_session 
+               then throwDyn StopParentSession
+               else return True
+          

 
 shellEscape :: String -> GHCi Bool
 shellEscape str = io (system str >> return False)
 
 shellEscape :: String -> GHCi Bool
 shellEscape str = io (system str >> return False)

@@ -1344,7 +1358,7 @@ wrapCompleter fun w =  do
 getCommonPrefix :: [String] -> String
 getCommonPrefix [] = ""
 getCommonPrefix (s:ss) = foldl common s ss
 getCommonPrefix :: [String] -> String
 getCommonPrefix [] = ""
 getCommonPrefix (s:ss) = foldl common s ss

-  where common s "" = s
+  where common s "" = ""

        common "" s = ""
        common (c:cs) (d:ds)
           | c == d = c : common cs ds
        common "" s = ""
        common (c:cs) (d:ds)
           | c == d = c : common cs ds

@@ -1384,11 +1398,15 @@ handler :: Exception -> GHCi Bool
 handler (DynException dyn) 
   | Just StopChildSession <- fromDynamic dyn 
      -- propagate to the parent session
 handler (DynException dyn) 
   | Just StopChildSession <- fromDynamic dyn 
      -- propagate to the parent session

-  = ASSERTM (liftM not isTopLevel) >> throwDyn StopChildSession
+  = do ASSERTM (liftM not isTopLevel) 
+       throwDyn StopChildSession

 
 

-  | Just (ChildSessionStopped msg) <- fromDynamic dyn 
-     -- Reload modules and display some message
-  = ASSERTM (isTopLevel) >> io(putStrLn msg) >> return False
+  | Just StopParentSession <- fromDynamic dyn 
+  = do at_topLevel <-  isTopLevel
+       if at_topLevel then return True else throwDyn StopParentSession
+  
+  | Just (ChildSessionStopped msg) <- fromDynamic dyn     
+  = io(putStrLn msg) >> return False

 
 handler exception = do
   flushInterpBuffers
 
 handler exception = do
   flushInterpBuffers

@@ -1505,9 +1523,10 @@ doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
                               bkptTable= ref_bkptTable,
                               prelude  = prel_mod,
                              topLevel = False }
                               bkptTable= ref_bkptTable,
                               prelude  = prel_mod,
                              topLevel = False }

-             `catchDyn` (
-                 \StopChildSession -> evaluate$
-                        throwDyn (ChildSessionStopped "")
+             `catchDyn` (\e -> case e of 
+                           StopChildSession -> evaluate$
+                                               throwDyn (ChildSessionStopped "")
+                           StopParentSession -> throwDyn StopParentSession

            ) `finally` do
              writeIORef ref hsc_env
              putStrLn $ "Returning to normal execution..."
            ) `finally` do
              writeIORef ref hsc_env
              putStrLn $ "Returning to normal execution..."

@@ -1517,11 +1536,13 @@ doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
      printScopeMsg location ids = do
        unqual  <- GHC.getPrintUnqual s
        printForUser stdout unqual $
      printScopeMsg location ids = do
        unqual  <- GHC.getPrintUnqual s
        printForUser stdout unqual $

-         text "Local bindings in scope:" $$
+         text "Stopped at a breakpoint in " <> text (stripColumn location) <>
+         char '.' <+> text "Local bindings in scope:" $$

          nest 2 (pprWithCommas showId ids)
       where 
            showId id = 
                 ppr (idName id) <+> dcolon <+> ppr (idType id) 
          nest 2 (pprWithCommas showId ids)
       where 
            showId id = 
                 ppr (idName id) <+> dcolon <+> ppr (idType id) 

+           stripColumn = reverse . tail . dropWhile (/= ':') . reverse

 
 -- | Give the Id a Global Name, and tidy its type
      globaliseAndTidy :: Id -> Id
 
 -- | Give the Id a Global Name, and tidy its type
      globaliseAndTidy :: Id -> Id