Fix the build

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

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index cf578a7..df588aa 100644 (file)
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -32,7 +32,9 @@ data GHCiState = GHCiState
        editor         :: String,
        session        :: GHC.Session,
        options        :: [GHCiOption],
-        prelude        :: GHC.Module
+        prelude        :: GHC.Module,
+        bkptTable      :: IORef (BkptTable GHC.Module),
+       topLevel       :: Bool
      }
 
 data GHCiOption 
@@ -92,6 +94,24 @@ unsetOption opt
 io :: IO a -> GHCi a
 io m = GHCi { unGHCi = \s -> m >>= return }
 
+isTopLevel :: GHCi Bool
+isTopLevel = getGHCiState >>= return . topLevel
+
+getBkptTable :: GHCi (BkptTable GHC.Module)
+getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
+                  io$ readIORef table_ref
+
+setBkptTable :: BkptTable GHC.Module -> GHCi ()
+setBkptTable new_table = do 
+    table_ref <- getGHCiState >>= return . bkptTable
+    io$ writeIORef table_ref new_table
+                  
+modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
+modifyBkptTable f = do 
+    bt <- getBkptTable
+    new_bt <- io . evaluate$ f bt 
+    setBkptTable new_bt
+
 showForUser :: SDoc -> GHCi String
 showForUser doc = do
   session <- getSession
@@ -101,6 +121,11 @@ showForUser doc = do
 -----------------------------------------------------------------------------
 -- User code exception handling
 
+-- 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  
+  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
@@ -111,6 +136,19 @@ showForUser doc = do
 -- 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
@@ -194,7 +232,7 @@ 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"
 
-initInterpBuffering :: Session -> IO ()
+initInterpBuffering :: GHC.Session -> IO ()
 initInterpBuffering session
  = do maybe_hval <- GHC.compileExpr session no_buf_cmd