X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=b5af439d640173a3ae49fc437883ac9ee10c059a;hb=a6156829d4e671c5385769ccc7675e644591525d;hp=298d697702e9c4d7a68f212be0db9f8f36285bd7;hpb=8bc615fdb45b8e3f2f3ef2167bbb379bf619aab2;p=ghc-hetmet.git

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 298d697..b5af439 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -85,6 +85,7 @@ import System.Directory
 import System.IO
 import System.IO.Error as IO
 import Data.Char
+import Data.Dynamic
 import Control.Monad as Monad
 import Foreign.StablePtr	( newStablePtr )
 
@@ -113,7 +114,12 @@ builtin_commands :: [Command]
 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
@@ -131,8 +137,11 @@ builtin_commands = [
   ("etags",	keepGoing createETagsFileCmd,	False, completeFilename),
   ("ctags",	keepGoing createCTagsFileCmd, 	False, completeFilename),
   ("type",	keepGoing typeOfExpr,		False, completeIdentifier),
-#if defined(GHCI)
-  ("breakpoint",keepGoing bkptOptions,          False, completeBkpt),
+#if defined(DEBUGGER)
+  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+  ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
+  ("breakpoint",bkptOptions,                    False, completeBkpt),
 #endif
   ("kind",	keepGoing kindOfType,		False, completeIdentifier),
   ("unset",	keepGoing unsetOptions,		True,  completeSetOptions),
@@ -143,7 +152,7 @@ builtin_commands = [
 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
@@ -165,11 +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" ++
+ "   :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" ++
+ "   :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" ++
@@ -203,8 +215,9 @@ helpText =
  "\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" ++
+ "   continue                                 continue execution\n"  ++
  "   stop                   Stop a computation and return to the top level\n" ++
  "   step [count]           Step by step execution (DISABLED)\n"
 
@@ -766,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'
-  refreshBkptTable graph'
+  do 
+     bt  <- getBkptTable
+     bt' <- io$ refreshBkptTable session bt graph'
+     setBkptTable bt'
   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 
 setContextAfterLoad session [] = do
@@ -837,7 +853,11 @@ kindOfType str
 		           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)
@@ -1338,7 +1358,7 @@ wrapCompleter fun w =  do
 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
@@ -1361,6 +1381,65 @@ completeHomeModuleOrFile=completeNone
 completeBkpt       = completeNone
 #endif
 
+-- ---------------------------------------------------------------------------
+-- User code exception handling
+
+-- This is the exception handler for exceptions generated by the
+-- user's code and exceptions coming from children sessions; 
+-- it normally just prints out the exception.  The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception.  We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: Exception -> GHCi Bool
+handler (DynException dyn) 
+  | Just StopChildSession <- fromDynamic dyn 
+     -- propagate to the parent session
+  = do ASSERTM (liftM not isTopLevel) 
+       throwDyn StopChildSession
+
+  | 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
+  io installSignalHandlers
+  ghciHandle handler (showException exception >> return False)
+
+showException (DynException dyn) =
+  case fromDynamic dyn of
+    Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
+    Just Interrupted      -> io (putStrLn "Interrupted.")
+    Just (CmdLineError s) -> io (putStrLn s)	 -- omit the location for CmdLineError
+    Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
+    Just other_ghc_ex     -> io (print other_ghc_ex)
+
+showException other_exception
+  = io (putStrLn ("*** Exception: " ++ show other_exception))
+
+-----------------------------------------------------------------------------
+-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- in an exception loop (eg. let a = error a in a) the ^C exception
+-- may never be delivered.  Thanks to Marcin for pointing out the bug.
+
+ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
+ghciHandle h (GHCi m) = GHCi $ \s -> 
+   Exception.catch (m s) 
+	(\e -> unGHCi (ghciUnblock (h e)) s)
+
+ghciUnblock :: GHCi a -> GHCi a
+ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
+
+
 -- ----------------------------------------------------------------------------
 -- Utils
 
@@ -1444,9 +1523,10 @@ doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
                               bkptTable= ref_bkptTable,
                               prelude  = prel_mod,
 			      topLevel = False }
-             `catchDyn` (
-                 \StopChildSession -> evaluate$ 
-                     throwDyn (ChildSessionStopped "You may need to reload your modules")
+             `catchDyn` (\e -> case e of 
+                           StopChildSession -> evaluate$
+                                               throwDyn (ChildSessionStopped "")
+                           StopParentSession -> throwDyn StopParentSession
            ) `finally` do
              writeIORef ref hsc_env
              putStrLn $ "Returning to normal execution..."
@@ -1456,11 +1536,13 @@ doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
      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) 
+           stripColumn = reverse . tail . dropWhile (/= ':') . reverse
 
 -- | Give the Id a Global Name, and tidy its type
      globaliseAndTidy :: Id -> Id