projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Comments only
[ghc-hetmet.git] / ghc / GhciMonad.hs
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index 94bd9c2..fd63497 100644 (file)
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -14,12 +14,13 @@ module GhciMonad where
 #include "HsVersions.h"
 
 import qualified GHC
 #include "HsVersions.h"
 
 import qualified GHC
+import GhcMonad         hiding (liftIO)
 import Outputable       hiding (printForUser, printForUserPartWay)
 import qualified Outputable
 import Panic            hiding (showException)
 import Util
 import DynFlags
 import Outputable       hiding (printForUser, printForUserPartWay)
 import qualified Outputable
 import Panic            hiding (showException)
 import Util
 import DynFlags
-import HscTypes hiding (liftIO)
+import HscTypes
 import SrcLoc
 import Module
 import ObjLink
 import SrcLoc
 import Module
 import ObjLink
@@ -28,13 +29,10 @@ import StaticFlags
 import qualified MonadUtils
 
 import Exception
 import qualified MonadUtils
 
 import Exception
--- import Data.Maybe
 import Numeric
 import Data.Array
 import Numeric
 import Data.Array
--- import Data.Char
 import Data.Int         ( Int64 )
 import Data.IORef
 import Data.Int         ( Int64 )
 import Data.IORef
--- import Data.List
 import System.CPUTime
 import System.Environment
 import System.IO
 import System.CPUTime
 import System.Environment
 import System.IO
@@ -69,7 +67,7 @@ data GHCiState = GHCiState
         -- remember is here:
         last_command   :: Maybe Command,
         cmdqueue       :: [String],
         -- 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
              -- 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
@@ -79,10 +77,12 @@ data GHCiState = GHCiState
         ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
      }
 
         ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
      }
 
-data CtxtCmd
-  = SetContext
-  | AddModules
-  | RemModules
+data CtxtCmd   -- In each case, the first [String] are the starred modules
+               -- and the second are the unstarred ones
+  = SetContext [String] [String]
+  | AddModules [String] [String]
+  | RemModules [String] [String]
+  | Import     String
 
 type TickArray = Array Int [(BreakIndex,SrcSpan)]
 
 
 type TickArray = Array Int [(BreakIndex,SrcSpan)]
 
@@ -180,31 +180,32 @@ instance GhcMonad (InputT GHCi) where
 instance MonadUtils.MonadIO (InputT GHCi) where
   liftIO = Trans.liftIO
 
 instance MonadUtils.MonadIO (InputT GHCi) where
   liftIO = Trans.liftIO
 
-instance WarnLogMonad (InputT GHCi) where
-  setWarnings = lift . setWarnings
-  getWarnings = lift getWarnings
-
 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)
 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)
-
-instance WarnLogMonad GHCi where
-  setWarnings warns = liftGhc $ setWarnings warns
-  getWarnings = liftGhc $ getWarnings
+  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 MonadIO GHCi where
 
 instance MonadIO GHCi where
-  liftIO = io
+  liftIO = MonadUtils.liftIO
 
 instance Haskeline.MonadException GHCi where
   catch = gcatch
   block = gblock
   unblock = gunblock
 
 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
 
 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
 
 -- for convenience...
 getPrelude :: GHCi Module
@@ -233,9 +234,6 @@ unsetOption opt
  = do st <- getGHCiState
       setGHCiState (st{ options = filter (/= opt) (options st) })
 
  = do st <- getGHCiState
       setGHCiState (st{ options = filter (/= opt) (options st) })
 
-io :: IO a -> GHCi a
-io = MonadUtils.liftIO
-
 printForUser :: GhcMonad m => SDoc -> m ()
 printForUser doc = do
   unqual <- GHC.getPrintUnqual
 printForUser :: GhcMonad m => SDoc -> m ()
 printForUser doc = do
   unqual <- GHC.getPrintUnqual
@@ -244,7 +242,7 @@ printForUser doc = do
 printForUserPartWay :: SDoc -> GHCi ()
 printForUserPartWay doc = do
   unqual <- GHC.getPrintUnqual
 printForUserPartWay :: SDoc -> GHCi ()
 printForUserPartWay doc = do
   unqual <- GHC.getPrintUnqual
-  io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
+  liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
 
 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
 runStmt expr step = do
 
 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
 runStmt expr step = do
@@ -253,7 +251,7 @@ runStmt expr step = do
     withProgName (progname st) $
     withArgs (args st) $
       reflectGHCi x $ do
     withProgName (progname st) $
     withArgs (args st) $
       reflectGHCi x $ do
-        GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
+        GHC.handleSourceError (\e -> do GHC.printException e
                                         return GHC.RunFailed) $ do
           GHC.runStmt expr step
 
                                         return GHC.RunFailed) $ do
           GHC.runStmt expr step
 
@@ -299,9 +297,9 @@ printTimes allocs psecs
        
 revertCAFs :: GHCi ()
 revertCAFs = do
        
 revertCAFs :: GHCi ()
 revertCAFs = do
-  io $ rts_revertCAFs
+  liftIO rts_revertCAFs
   s <- getGHCiState
   s <- getGHCiState
-  when (not (ghc_e s)) $ io turnOffBuffering
+  when (not (ghc_e s)) $ liftIO turnOffBuffering
        -- Have to turn off buffering again, because we just 
        -- reverted stdout, stderr & stdin to their defaults.
 
        -- Have to turn off buffering again, because we just 
        -- reverted stdout, stderr & stdin to their defaults.
 
@@ -350,8 +348,8 @@ initInterpBuffering = do -- make sure these are linked
 
 flushInterpBuffers :: GHCi ()
 flushInterpBuffers
 
 flushInterpBuffers :: GHCi ()
 flushInterpBuffers
- = io $ do getHandle stdout_ptr >>= hFlush
-           getHandle stderr_ptr >>= hFlush
+ = liftIO $ do getHandle stdout_ptr >>= hFlush
+               getHandle stderr_ptr >>= hFlush
 
 turnOffBuffering :: IO ()
 turnOffBuffering
 
 turnOffBuffering :: IO ()
 turnOffBuffering
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)