Tidy up the ic_exports field of the InteractiveContext. Previously

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

diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index f1859d7..52b28ef 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

@@ -58,7 +56,8 @@ data GHCiState = GHCiState
        editor         :: String,
         stop           :: String,
        options        :: [GHCiOption],
        editor         :: String,
         stop           :: String,
        options        :: [GHCiOption],

-        prelude        :: GHC.Module,
+        prelude        :: GHC.ModuleName,
+        line_number    :: !Int,         -- input line

         break_ctr      :: !Int,
         breaks         :: ![(Int, BreakLocation)],
         tickarrays     :: ModuleEnv TickArray,
         break_ctr      :: !Int,
         breaks         :: ![(Int, BreakLocation)],
         tickarrays     :: ModuleEnv TickArray,

@@ -79,7 +78,8 @@ 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
+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]
   = SetContext [String] [String]
   | AddModules [String] [String]
   | RemModules [String] [String]

@@ -91,6 +91,7 @@ data GHCiOption
        = ShowTiming            -- show time/allocs after evaluation
        | ShowType              -- show the type of expressions
        | RevertCAFs            -- revert CAFs after every evaluation
        = ShowTiming            -- show time/allocs after evaluation
        | ShowType              -- show the type of expressions
        | RevertCAFs            -- revert CAFs after every evaluation

+        | Multiline             -- use multiline commands

        deriving Eq
 
 data BreakLocation
        deriving Eq
 
 data BreakLocation

@@ -181,34 +182,35 @@ 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...
 
 -- for convenience...

-getPrelude :: GHCi Module
+getPrelude :: GHCi ModuleName

 getPrelude = getGHCiState >>= return . prelude
 
 getDynFlags :: GhcMonad m => m DynFlags
 getPrelude = getGHCiState >>= return . prelude
 
 getDynFlags :: GhcMonad m => m DynFlags

@@ -234,9 +236,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

@@ -245,7 +244,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

@@ -254,9 +253,9 @@ 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
                                         return GHC.RunFailed) $ do

-          GHC.runStmt expr step
+          GHC.runStmtWithLocation (progname st) (line_number st) expr step 

 
 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
 resume canLogSpan step = do
 
 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
 resume canLogSpan step = do

@@ -300,9 +299,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.
 

@@ -351,8 +350,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