X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=e5368416ebe0c760350d8761ad297bad18de62aa;hb=8a400d0b37b94e4189257a2824e03f8fb6cfa333;hp=df588aab0aa615eee084a90b7181e6a18f963021;hpb=989cfb23660ecefe7e414a1ca1f3004e820ef50b;p=ghc-hetmet.git

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index df588aa..e536841 100644
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -15,6 +15,7 @@ import Data.Char
 import Data.Dynamic
 import Data.Int         ( Int64 )
 import Data.IORef
+import Data.List
 import Data.Typeable
 import System.CPUTime
 import System.IO
@@ -118,69 +119,16 @@ showForUser doc = do
   unqual <- io (GHC.getPrintUnqual session)
   return $! showSDocForUser unqual doc
 
------------------------------------------------------------------------------
--- User code exception handling
+-- --------------------------------------------------------------------------
+-- Inferior Sessions Exceptions (used by the debugger)
 
--- This hierarchy of exceptions is used to signal interruption of a child session
-data BkptException = StopChildSession -- A child debugging session requests to be stopped
-                   | ChildSessionStopped String  
+data InfSessionException = 
+             StopChildSession -- A child session requests to be stopped
+           | ChildSessionStopped String  -- A child session has stopped
   deriving Typeable
 
--- 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 
- -- Revert CAFs and display some message
-  = do ASSERTM (isTopLevel) 
-       io (revertCAFs >> 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)
 
------------------------------------------------------------------------------
+-- --------------------------------------------------------------------------
 -- timing & statistics
 
 timeIt :: GHCi a -> GHCi a
@@ -228,9 +176,22 @@ foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 
-no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
-	     " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
-flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr"
+command_sequence :: [String] -> String
+command_sequence = unwords . intersperse "Prelude.>>"
+
+no_buffer :: String -> String
+no_buffer h = unwords ["System.IO.hSetBuffering",
+                       "System.IO." ++ h,
+                       "System.IO.NoBuffering"]
+
+no_buf_cmd :: String
+no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
+
+flush_buffer :: String -> String
+flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
+
+flush_cmd :: String
+flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
 
 initInterpBuffering :: GHC.Session -> IO ()
 initInterpBuffering session