X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=3cab56b40ce830990d606066c5cf6590d3a1ed89;hb=cdce647711c0f46f5799b24de087622cb77e647f;hp=cf578a7f71ae6aa51dcdda9202c2054a163617e7;hpb=8099fc7e9c54b24dc50c2cd1b9bfdc59e2d218b1;p=ghc-hetmet.git

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index cf578a7..3cab56b 100644
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -1,13 +1,22 @@
+-----------------------------------------------------------------------------
+--
+-- Monadery code used in InteractiveUI
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
 module GhciMonad where
 
 #include "HsVersions.h"
 
 import qualified GHC
-import {-#SOURCE#-} Debugger
-import Breakpoints
 import Outputable
 import Panic hiding (showException)
 import Util
+import DynFlags
+import HscTypes
+import SrcLoc
 
 import Numeric
 import Control.Exception as Exception
@@ -15,6 +24,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
@@ -32,7 +42,10 @@ data GHCiState = GHCiState
 	editor         :: String,
 	session        :: GHC.Session,
 	options        :: [GHCiOption],
-        prelude        :: GHC.Module
+        prelude        :: GHC.Module,
+	topLevel       :: Bool,
+        resume         :: [IO GHC.RunResult],
+        breaks         :: !ActiveBreakPoints
      }
 
 data GHCiOption 
@@ -41,6 +54,73 @@ data GHCiOption
 	| RevertCAFs		-- revert CAFs after every evaluation
 	deriving Eq
 
+data ActiveBreakPoints
+   = ActiveBreakPoints
+   { breakCounter   :: !Int
+   , breakLocations :: ![(Int, BreakLocation)]  -- break location uniquely numbered 
+   }
+
+instance Outputable ActiveBreakPoints where
+   ppr activeBrks = prettyLocations $ breakLocations activeBrks 
+
+emptyActiveBreakPoints :: ActiveBreakPoints
+emptyActiveBreakPoints 
+   = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
+
+data BreakLocation
+   = BreakLocation
+   { breakModule :: !GHC.Module
+   , breakLoc    :: !SrcSpan
+   , breakTick   :: {-# UNPACK #-} !Int
+   } 
+   deriving Eq
+
+prettyLocations :: [(Int, BreakLocation)] -> SDoc
+prettyLocations []   = text "No active breakpoints." 
+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
+
+instance Outputable BreakLocation where
+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
+
+getActiveBreakPoints :: GHCi ActiveBreakPoints
+getActiveBreakPoints = liftM breaks getGHCiState 
+
+-- don't reset the counter back to zero?
+clearActiveBreakPoints :: GHCi ()
+clearActiveBreakPoints = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st
+       newActiveBreaks = oldActiveBreaks { breakLocations = [] } 
+   setGHCiState $ st { breaks = newActiveBreaks }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st
+       oldLocations    = breakLocations oldActiveBreaks
+       newLocations    = filter (\loc -> fst loc /= identity) oldLocations
+       newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }   
+   setGHCiState $ st { breaks = newActiveBreaks }
+
+recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st 
+   let oldLocations    = breakLocations oldActiveBreaks
+   -- don't store the same break point twice
+   case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
+     (nm:_) -> return (True, nm)
+     [] -> do
+      let oldCounter = breakCounter oldActiveBreaks 
+          newCounter = oldCounter + 1
+          newActiveBreaks = 
+             oldActiveBreaks 
+             { breakCounter   = newCounter 
+             , breakLocations = (oldCounter, brkLoc) : oldLocations 
+             }
+      setGHCiState $ st { breaks = newActiveBreaks }
+      return (False, oldCounter)
+
 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 
 startGHCi :: GHCi a -> GHCiState -> IO a
@@ -92,57 +172,36 @@ unsetOption opt
 io :: IO a -> GHCi a
 io m = GHCi { unGHCi = \s -> m >>= return }
 
+isTopLevel :: GHCi Bool
+isTopLevel = getGHCiState >>= return . topLevel
+
+getResume :: GHCi (Maybe (IO GHC.RunResult))
+getResume = do
+   st <- getGHCiState
+   case (resume st) of
+      []    -> return Nothing
+      (x:_) -> return $ Just x
+
+popResume :: GHCi ()
+popResume = do
+   st <- getGHCiState 
+   case (resume st) of
+      []     -> return () 
+      (_:xs) -> setGHCiState $ st { resume = xs } 
+         
+pushResume :: IO GHC.RunResult -> GHCi ()
+pushResume resumeAction = do
+   st <- getGHCiState
+   let oldResume = resume st
+   setGHCiState $ st { resume = resumeAction : oldResume }
+
 showForUser :: SDoc -> GHCi String
 showForUser doc = do
   session <- getSession
   unqual <- io (GHC.getPrintUnqual session)
   return $! showSDocForUser unqual doc
 
------------------------------------------------------------------------------
--- 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 = 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
@@ -190,14 +249,33 @@ 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"]
 
-initInterpBuffering :: Session -> IO ()
+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
- = do maybe_hval <- GHC.compileExpr session no_buf_cmd
-	
+ = do -- we don't want to be fooled by any modules lying around in the current
+      -- directory when we compile these code fragments, so set the import
+      -- path to be empty while we compile them.
+      dflags <- GHC.getSessionDynFlags session
+      GHC.setSessionDynFlags session dflags{importPaths=[]}
+
+      maybe_hval <- GHC.compileExpr session no_buf_cmd
+
       case maybe_hval of
 	Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 	other	  -> panic "interactiveUI:setBuffering"
@@ -207,6 +285,8 @@ initInterpBuffering session
 	Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 	_         -> panic "interactiveUI:flush"
 
+      GHC.setSessionDynFlags session dflags
+      GHC.workingDirectoryChanged session
       return ()