Fix some text in the GHCi help message that was going over 80 columns

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 980dcd9..3fbdcbe 100644 (file)
--- 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 System.IO
 import System.IO.Error as IO
 import Data.Char

+import Data.Dynamic

 import Control.Monad as Monad
 import Foreign.StablePtr       ( newStablePtr )
 
 import Control.Monad as Monad
 import Foreign.StablePtr       ( newStablePtr )
 

@@ -131,7 +132,7 @@ builtin_commands = [
   ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),
   ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),
   ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),

-#if defined(GHCI)
+#if defined(DEBUGGER)

   ("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),

@@ -174,7 +175,7 @@ helpText =
  "   :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" ++
  "   :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" ++

@@ -1366,6 +1367,63 @@ completeHomeModuleOrFile=completeNone
 completeBkpt       = completeNone
 #endif
 
 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 (ChildSessionStopped msg) <- fromDynamic dyn 
+     -- Reload modules and display some message
+  = do ASSERTM (isTopLevel) 
+       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
 
 -- ----------------------------------------------------------------------------
 -- Utils
 

@@ -1450,8 +1508,8 @@ doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
                               prelude  = prel_mod,
                              topLevel = False }
              `catchDyn` (
                               prelude  = prel_mod,
                              topLevel = False }
              `catchDyn` (

-                 \StopChildSession -> evaluate$ 
-                     throwDyn (ChildSessionStopped "You may need to reload your modules")
+                 \StopChildSession -> evaluate$
+                        throwDyn (ChildSessionStopped "")

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

@@ -1461,11 +1519,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