multiline commands in GHCi #4316

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

diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index 5494b4e..779fad2 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

@@ -79,7 +77,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 +90,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,10 +181,6 @@ 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)
 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)

@@ -196,12 +192,8 @@ instance ExceptionMonad GHCi where
                              in
                                 unGHCi (f g_restore) s
 
                              in
                                 unGHCi (f g_restore) s
 

-instance WarnLogMonad GHCi where
-  setWarnings warns = liftGhc $ setWarnings warns
-  getWarnings = liftGhc $ getWarnings
-

 instance MonadIO GHCi where
 instance MonadIO GHCi where

-  liftIO = io
+  liftIO = MonadUtils.liftIO

 
 instance Haskeline.MonadException GHCi where
   catch = gcatch
 
 instance Haskeline.MonadException GHCi where
   catch = gcatch

@@ -243,9 +235,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

@@ -254,7 +243,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

@@ -263,7 +252,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
 

@@ -309,9 +298,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.
 

@@ -360,8 +349,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