adapt to the new async exceptions API

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

diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index ff34963..5494b4e 100644 (file)
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -15,7 +15,6 @@ module GhciMonad where
 
 import qualified GHC
 import Outputable       hiding (printForUser, printForUserPartWay)
-import qualified Pretty
 import qualified Outputable
 import Panic            hiding (showException)
 import Util
@@ -27,16 +26,15 @@ import ObjLink
 import Linker
 import StaticFlags
 import qualified MonadUtils
-import qualified ErrUtils
 
 import Exception
-import Data.Maybe
+-- import Data.Maybe
 import Numeric
 import Data.Array
-import Data.Char
+-- import Data.Char
 import Data.Int         ( Int64 )
 import Data.IORef
-import Data.List
+-- import Data.List
 import System.CPUTime
 import System.Environment
 import System.IO
@@ -45,9 +43,7 @@ import GHC.Exts
 
 import System.Console.Haskeline (CompletionFunc, InputT)
 import qualified System.Console.Haskeline as Haskeline
-import System.Console.Haskeline.Encoding
 import Control.Monad.Trans as Trans
-import qualified Data.ByteString as B
 
 -----------------------------------------------------------------------------
 -- GHCi monad
@@ -73,7 +69,7 @@ data GHCiState = GHCiState
         -- remember is here:
         last_command   :: Maybe Command,
         cmdqueue       :: [String],
-        remembered_ctx :: [(CtxtCmd, [String], [String])],
+        remembered_ctx :: [CtxtCmd],
              -- we remember the :module commands between :loads, so that
              -- on a :reload we can replay them.  See bugs #2049,
              -- \#1873, #1360. Previously we tried to remember modules that
@@ -84,9 +80,10 @@ data GHCiState = GHCiState
      }
 
 data CtxtCmd
-  = SetContext
-  | AddModules
-  | RemModules
+  = SetContext [String] [String]
+  | AddModules [String] [String]
+  | RemModules [String] [String]
+  | Import     String
 
 type TickArray = Array Int [(BreakIndex,SrcSpan)]
 
@@ -192,6 +189,12 @@ instance ExceptionMonad GHCi where
   gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
   gblock (GHCi m)   = GHCi $ \r -> gblock (m r)
   gunblock (GHCi m) = GHCi $ \r -> gunblock (m r)
+  gmask f =
+      GHCi $ \s -> gmask $ \io_restore ->
+                             let
+                                g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
+                             in
+                                unGHCi (f g_restore) s
 
 instance WarnLogMonad GHCi where
   setWarnings warns = liftGhc $ setWarnings warns
@@ -204,11 +207,14 @@ instance Haskeline.MonadException GHCi where
   catch = gcatch
   block = gblock
   unblock = gunblock
+  -- XXX when Haskeline's MonadException changes, we can drop our 
+  -- deprecated block/unblock methods
 
 instance ExceptionMonad (InputT GHCi) where
-    gcatch = Haskeline.catch
-    gblock = Haskeline.block
-    gunblock = Haskeline.unblock
+  gcatch = Haskeline.catch
+  gmask f = Haskeline.block (f Haskeline.unblock) -- slightly wrong
+  gblock = Haskeline.block
+  gunblock = Haskeline.unblock
 
 -- for convenience...
 getPrelude :: GHCi Module
@@ -240,42 +246,16 @@ unsetOption opt
 io :: IO a -> GHCi a
 io = MonadUtils.liftIO
 
-printForUser :: SDoc -> GHCi ()
+printForUser :: GhcMonad m => SDoc -> m ()
 printForUser doc = do
   unqual <- GHC.getPrintUnqual
-  io $ Outputable.printForUser stdout unqual doc
-
-printForUser' :: SDoc -> InputT GHCi ()
-printForUser' doc = do
-    unqual <- GHC.getPrintUnqual
-    Haskeline.outputStrLn $ showSDocForUser unqual doc
+  MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc
 
 printForUserPartWay :: SDoc -> GHCi ()
 printForUserPartWay doc = do
   unqual <- GHC.getPrintUnqual
   io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
 
--- We set log_action to write encoded output.
--- This fails whenever GHC tries to mention an (already encoded) filename,
--- but I don't know how to work around that.
-setLogAction :: InputT GHCi ()
-setLogAction = do
-    encoder <- getEncoder
-    dflags <- GHC.getSessionDynFlags
-    GHC.setSessionDynFlags dflags {log_action = logAction encoder}
-    return ()
-  where
-    logAction encoder severity srcSpan style msg = case severity of
-        GHC.SevInfo -> printEncErrs encoder (msg style)
-        GHC.SevFatal -> printEncErrs encoder (msg style)
-        _ -> do
-            hPutChar stderr '\n'
-            printEncErrs encoder (ErrUtils.mkLocMessage srcSpan msg style)
-    printEncErrs encoder doc = do
-        str <- encoder (Pretty.showDocWith Pretty.PageMode doc)
-        B.hPutStrLn stderr str
-        hFlush stderr
-
 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
 runStmt expr step = do
   st <- getGHCiState
@@ -288,7 +268,13 @@ runStmt expr step = do
           GHC.runStmt expr step
 
 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
-resume canLogSpan step = GHC.resume canLogSpan step
+resume canLogSpan step = do
+  st <- getGHCiState
+  reifyGHCi $ \x ->
+    withProgName (progname st) $
+    withArgs (args st) $
+      reflectGHCi x $ do
+        GHC.resume canLogSpan step
 
 -- --------------------------------------------------------------------------
 -- timing & statistics
@@ -369,9 +355,8 @@ initInterpBuffering = do -- make sure these are linked
 
       let f ref (Just ptr) = writeIORef ref ptr
           f _   Nothing    = panic "interactiveUI:setBuffering2"
-      zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
-                 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
-      return ()
+      zipWithM_ f [stdin_ptr,stdout_ptr,stderr_ptr]
+                  [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
 
 flushInterpBuffers :: GHCi ()
 flushInterpBuffers