X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2FGhciMonad.hs;h=52b28efdffc3d60078fa9b0167452deb8a3681c3;hp=88c8caa06d0a1d3a2f325d049e46a6b6b7a6901b;hb=HEAD;hpb=de1a1f9f882cf1a5c81c4a152edc001aafd3f8a3

diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index 88c8caa..52b28ef 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -14,12 +14,13 @@ module GhciMonad where
 #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 HscTypes hiding (liftIO)
+import HscTypes
 import SrcLoc
 import Module
 import ObjLink
@@ -28,13 +29,10 @@ import StaticFlags
 import qualified MonadUtils
 
 import Exception
--- import Data.Maybe
 import Numeric
 import Data.Array
--- import Data.Char
 import Data.Int         ( Int64 )
 import Data.IORef
--- import Data.List
 import System.CPUTime
 import System.Environment
 import System.IO
@@ -58,7 +56,8 @@ data GHCiState = GHCiState
 	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,
@@ -69,7 +68,7 @@ data GHCiState = GHCiState
         -- remember is here:
         last_command   :: Maybe Command,
         cmdqueue       :: [String],
-        remembered_ctx :: [Either (CtxtCmd, [String], [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
@@ -79,10 +78,12 @@ data GHCiState = GHCiState
         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)]
 
@@ -90,6 +91,7 @@ data GHCiOption
 	= 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
@@ -180,34 +182,35 @@ instance GhcMonad (InputT GHCi) where
 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 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
-  liftIO = io
+  liftIO = MonadUtils.liftIO
 
 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
+getPrelude :: GHCi ModuleName
 getPrelude = getGHCiState >>= return . prelude
 
 getDynFlags :: GhcMonad m => m DynFlags
@@ -233,9 +236,6 @@ unsetOption opt
  = 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
@@ -244,7 +244,7 @@ printForUser doc = do
 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
@@ -253,13 +253,9 @@ runStmt expr step = 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
-
-parseImportDecl :: GhcMonad m => String -> m (Maybe (GHC.ImportDecl GHC.RdrName))
-parseImportDecl expr
-  = GHC.handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return Nothing) (Monad.liftM Just (GHC.parseImportDecl expr))
+          GHC.runStmtWithLocation (progname st) (line_number st) expr step 
 
 resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
 resume canLogSpan step = do
@@ -303,9 +299,9 @@ printTimes allocs psecs
 	
 revertCAFs :: GHCi ()
 revertCAFs = do
-  io $ rts_revertCAFs
+  liftIO rts_revertCAFs
   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.
 
@@ -354,8 +350,8 @@ initInterpBuffering = do -- make sure these are linked
 
 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