Add ASSERTs to all calls of nameModule

[ghc-hetmet.git] / compiler / main / InteractiveEval.hs

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 96e0b34..e5d91c9 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -30,20 +30,22 @@ module InteractiveEval (
         isModuleInterpreted,
        compileExpr, dynCompileExpr,
        lookupName,
         isModuleInterpreted,
        compileExpr, dynCompileExpr,
        lookupName,

-        Term(..), obtainTerm, obtainTerm1, obtainTermB, reconstructType,
+        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType,

         skolemiseSubst, skolemiseTy
 #endif
         ) where
 
 #ifdef GHCI
 
         skolemiseSubst, skolemiseTy
 #endif
         ) where
 
 #ifdef GHCI
 

+#include "HsVersions.h"
+

 import HscMain          hiding (compileExpr)
 import HscTypes
 import TcRnDriver
 import Type             hiding (typeKind)
 import TcType           hiding (typeKind)
 import InstEnv
 import HscMain          hiding (compileExpr)
 import HscTypes
 import TcRnDriver
 import Type             hiding (typeKind)
 import TcType           hiding (typeKind)
 import InstEnv

-import Var              hiding (setIdType)
+import Var

 import Id
 import IdInfo
 import Name             hiding ( varName )
 import Id
 import IdInfo
 import Name             hiding ( varName )

@@ -68,6 +70,7 @@ import RtClosureInspect
 import BasicTypes
 import Outputable
 import FastString
 import BasicTypes
 import Outputable
 import FastString

+import MonadUtils

 
 import Data.Dynamic
 import Data.List (find)
 
 import Data.Dynamic
 import Data.List (find)

@@ -76,11 +79,11 @@ import Foreign
 import Foreign.C
 import GHC.Exts
 import Data.Array
 import Foreign.C
 import GHC.Exts
 import Data.Array

-import Control.Exception as Exception
+import Exception

 import Control.Concurrent
 import Data.List (sortBy)
 import Control.Concurrent
 import Data.List (sortBy)

-import Data.IORef

 import Foreign.StablePtr
 import Foreign.StablePtr

+import System.IO

 
 -- -----------------------------------------------------------------------------
 -- running a statement interactively
 
 -- -----------------------------------------------------------------------------
 -- running a statement interactively

@@ -88,13 +91,13 @@ import Foreign.StablePtr
 data RunResult
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation
 data RunResult
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation

-  | RunException Exception     -- ^ statement raised an exception
+  | RunException SomeException -- ^ statement raised an exception

   | RunBreak ThreadId [Name] (Maybe BreakInfo)
 
 data Status
    = Break Bool HValue BreakInfo ThreadId
           -- ^ the computation hit a breakpoint (Bool <=> was an exception)
   | RunBreak ThreadId [Name] (Maybe BreakInfo)
 
 data Status
    = Break Bool HValue BreakInfo ThreadId
           -- ^ the computation hit a breakpoint (Bool <=> was an exception)

-   | Complete (Either Exception [HValue])
+   | Complete (Either SomeException [HValue])

           -- ^ the computation completed with either an exception or a value
 
 data Resume
           -- ^ the computation completed with either an exception or a value
 
 data Resume

@@ -117,8 +120,8 @@ data Resume
        resumeHistoryIx :: Int           -- 0 <==> at the top of the history
    }
 
        resumeHistoryIx :: Int           -- 0 <==> at the top of the history
    }
 

-getResumeContext :: Session -> IO [Resume]
-getResumeContext s = withSession s (return . ic_resume . hsc_IC)
+getResumeContext :: GhcMonad m => m [Resume]
+getResumeContext = withSession (return . ic_resume . hsc_IC)

 
 data SingleStep
    = RunToCompletion
 
 data SingleStep
    = RunToCompletion

@@ -182,108 +185,119 @@ findEnclosingDecl hsc_env mod span =
 
 -- | Run a statement in the current interactive context.  Statement
 -- may bind multple values.
 
 -- | Run a statement in the current interactive context.  Statement
 -- may bind multple values.

-runStmt :: Session -> String -> SingleStep -> IO RunResult
-runStmt (Session ref) expr step
-   = do 
-       hsc_env <- readIORef ref
-
-        breakMVar  <- newEmptyMVar  -- wait on this when we hit a breakpoint
-        statusMVar <- newEmptyMVar  -- wait on this when a computation is running 
-
-       -- Turn off -fwarn-unused-bindings when running a statement, to hide
-       -- warnings about the implicit bindings we introduce.
-       let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
-           hsc_env' = hsc_env{ hsc_dflags = dflags' }
-
-        maybe_stuff <- hscStmt hsc_env' expr
-
-        case maybe_stuff of
-          Nothing -> return RunFailed
-          Just (ids, hval) -> do
-
-              status <- 
-                withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
-                      let thing_to_run = unsafeCoerce# hval :: IO [HValue]
-                      sandboxIO dflags' statusMVar thing_to_run
+runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
+runStmt expr step =
+  do
+    hsc_env <- getSession
+
+    breakMVar  <- liftIO $ newEmptyMVar  -- wait on this when we hit a breakpoint
+    statusMVar <- liftIO $ newEmptyMVar  -- wait on this when a computation is running
+
+    -- Turn off -fwarn-unused-bindings when running a statement, to hide
+    -- warnings about the implicit bindings we introduce.
+    let dflags'  = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
+        hsc_env' = hsc_env{ hsc_dflags = dflags' }
+
+    r <- hscStmt hsc_env' expr
+
+    case r of
+      Nothing -> return RunFailed -- empty statement / comment
+
+      Just (ids, hval) -> do
+          -- XXX: This is the only place we can print warnings before the
+          -- result.  Is this really the right thing to do?  It's fine for
+          -- GHCi, but what's correct for other GHC API clients?  We could
+          -- introduce a callback argument.
+        warns <- getWarnings
+        liftIO $ printBagOfWarnings dflags' warns
+        clearWarnings
+
+        status <-
+            withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
+                let thing_to_run = unsafeCoerce# hval :: IO [HValue]
+                liftIO $ sandboxIO dflags' statusMVar thing_to_run

               
               

-              let ic = hsc_IC hsc_env
-                  bindings = (ic_tmp_ids ic, ic_tyvars ic)
+        let ic = hsc_IC hsc_env
+            bindings = (ic_tmp_ids ic, ic_tyvars ic)

 
 

-              case step of
-                RunAndLogSteps -> 
-                        traceRunStatus expr ref bindings ids   
-                                       breakMVar statusMVar status emptyHistory
-                _other ->
-                        handleRunStatus expr ref bindings ids
-                                        breakMVar statusMVar status emptyHistory
+        case step of
+          RunAndLogSteps ->
+              traceRunStatus expr bindings ids
+                             breakMVar statusMVar status emptyHistory
+          _other ->
+              handleRunStatus expr bindings ids
+                               breakMVar statusMVar status emptyHistory

 
 emptyHistory :: BoundedList History
 emptyHistory = nilBL 50 -- keep a log of length 50
 
 
 emptyHistory :: BoundedList History
 emptyHistory = nilBL 50 -- keep a log of length 50
 

-handleRunStatus :: String -> IORef HscEnv -> ([Id], TyVarSet) -> [Id]
+handleRunStatus :: GhcMonad m =>
+                   String-> ([Id], TyVarSet) -> [Id]

                 -> MVar () -> MVar Status -> Status -> BoundedList History
                 -> MVar () -> MVar Status -> Status -> BoundedList History

-                -> IO RunResult
-handleRunStatus expr ref bindings final_ids breakMVar statusMVar status 
+                -> m RunResult
+handleRunStatus expr bindings final_ids breakMVar statusMVar status

                 history =
    case status of  
       -- did we hit a breakpoint or did we complete?
       (Break is_exception apStack info tid) -> do
                 history =
    case status of  
       -- did we hit a breakpoint or did we complete?
       (Break is_exception apStack info tid) -> do

-        hsc_env <- readIORef ref
+        hsc_env <- getSession

         let mb_info | is_exception = Nothing
                     | otherwise    = Just info
         let mb_info | is_exception = Nothing
                     | otherwise    = Just info

-        (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env 
-                                                          apStack mb_info
+        (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack
+                                                               mb_info

         let
             resume = Resume expr tid breakMVar statusMVar 
                               bindings final_ids apStack mb_info span 
                               (toListBL history) 0
             hsc_env2 = pushResume hsc_env1 resume
         --
         let
             resume = Resume expr tid breakMVar statusMVar 
                               bindings final_ids apStack mb_info span 
                               (toListBL history) 0
             hsc_env2 = pushResume hsc_env1 resume
         --

-        writeIORef ref hsc_env2
+        modifySession (\_ -> hsc_env2)

         return (RunBreak tid names mb_info)
       (Complete either_hvals) ->
        case either_hvals of
            Left e -> return (RunException e)
            Right hvals -> do
         return (RunBreak tid names mb_info)
       (Complete either_hvals) ->
        case either_hvals of
            Left e -> return (RunException e)
            Right hvals -> do

-                hsc_env <- readIORef ref
+                hsc_env <- getSession

                 let final_ic = extendInteractiveContext (hsc_IC hsc_env)
                                         final_ids emptyVarSet
                         -- the bound Ids never have any free TyVars
                     final_names = map idName final_ids
                 let final_ic = extendInteractiveContext (hsc_IC hsc_env)
                                         final_ids emptyVarSet
                         -- the bound Ids never have any free TyVars
                     final_names = map idName final_ids

-                Linker.extendLinkEnv (zip final_names hvals)
-                hsc_env' <- rttiEnvironment hsc_env{hsc_IC=final_ic}
-                writeIORef ref hsc_env' 
+                liftIO $ Linker.extendLinkEnv (zip final_names hvals)
+                hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
+                modifySession (\_ -> hsc_env')

                 return (RunOk final_names)
 
                 return (RunOk final_names)
 

-traceRunStatus :: String -> IORef HscEnv -> ([Id], TyVarSet) -> [Id]
+traceRunStatus :: GhcMonad m =>
+                  String -> ([Id], TyVarSet) -> [Id]

                -> MVar () -> MVar Status -> Status -> BoundedList History
                -> MVar () -> MVar Status -> Status -> BoundedList History

-               -> IO RunResult
-traceRunStatus expr ref bindings final_ids
+               -> m RunResult
+traceRunStatus expr bindings final_ids

                breakMVar statusMVar status history = do
                breakMVar statusMVar status history = do

-  hsc_env <- readIORef ref
+  hsc_env <- getSession

   case status of
      -- when tracing, if we hit a breakpoint that is not explicitly
      -- enabled, then we just log the event in the history and continue.
      (Break is_exception apStack info tid) | not is_exception -> do
   case status of
      -- when tracing, if we hit a breakpoint that is not explicitly
      -- enabled, then we just log the event in the history and continue.
      (Break is_exception apStack info tid) | not is_exception -> do

-        b <- isBreakEnabled hsc_env info
+        b <- liftIO $ isBreakEnabled hsc_env info

         if b
            then handle_normally
            else do
              let history' = mkHistory hsc_env apStack info `consBL` history
                 -- probably better make history strict here, otherwise
                 -- our BoundedList will be pointless.
         if b
            then handle_normally
            else do
              let history' = mkHistory hsc_env apStack info `consBL` history
                 -- probably better make history strict here, otherwise
                 -- our BoundedList will be pointless.

-             evaluate history'
-             status <- withBreakAction True (hsc_dflags hsc_env)
-                                 breakMVar statusMVar $ do
-                       withInterruptsSentTo tid $ do
-                           putMVar breakMVar ()  -- awaken the stopped thread
-                           takeMVar statusMVar   -- and wait for the result
-             traceRunStatus expr ref bindings final_ids 
+             liftIO $ evaluate history'
+             status <-
+                 withBreakAction True (hsc_dflags hsc_env)
+                                      breakMVar statusMVar $ do
+                   liftIO $ withInterruptsSentTo tid $ do
+                       putMVar breakMVar ()  -- awaken the stopped thread
+                       takeMVar statusMVar   -- and wait for the result
+             traceRunStatus expr bindings final_ids

                             breakMVar statusMVar status history'
      _other ->
         handle_normally
   where
                             breakMVar statusMVar status history'
      _other ->
         handle_normally
   where

-        handle_normally = handleRunStatus expr ref bindings final_ids 
+        handle_normally = handleRunStatus expr bindings final_ids

                                           breakMVar statusMVar status history
 
 
                                           breakMVar statusMVar status history
 
 

@@ -315,11 +329,10 @@ foreign import ccall "&rts_breakpoint_io_action"
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".
 -- 
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".
 -- 

--- Careful here: there may be ^C exceptions flying around, so we start
--- the new thread blocked (forkIO inherits block from the parent,
--- #1048), and unblock only while we execute the user's code.  We
--- can't afford to lose the final putMVar, otherwise deadlock
--- ensues. (#1583, #1922, #1946)
+-- Careful here: there may be ^C exceptions flying around, so we start the new
+-- thread blocked (forkIO inherits block from the parent, #1048), and unblock
+-- only while we execute the user's code.  We can't afford to lose the final
+-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)

 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
 sandboxIO dflags statusMVar thing =
    block $ do  -- fork starts blocked
 sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status
 sandboxIO dflags statusMVar thing =
    block $ do  -- fork starts blocked

@@ -337,6 +350,7 @@ sandboxIO dflags statusMVar thing =
 -- not "Interrupted", we unset the exception flag before throwing.
 --
 rethrow :: DynFlags -> IO a -> IO a
 -- not "Interrupted", we unset the exception flag before throwing.
 --
 rethrow :: DynFlags -> IO a -> IO a

+#if __GLASGOW_HASKELL__ < 609

 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                 case e of
                    -- If -fbreak-on-error, we break unconditionally,
 rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                 case e of
                    -- If -fbreak-on-error, we break unconditionally,

@@ -354,7 +368,22 @@ rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
                    _    -> poke exceptionFlag 0
 
                 Exception.throwIO e
                    _    -> poke exceptionFlag 0
 
                 Exception.throwIO e

-
+#else
+rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
+                   -- If -fbreak-on-error, we break unconditionally,
+                   --  but with care of not breaking twice 
+                if dopt Opt_BreakOnError dflags &&
+                   not (dopt Opt_BreakOnException dflags)
+                    then poke exceptionFlag 1
+                    else case cast e of
+                         -- If it is an "Interrupted" exception, we allow
+                         --  a possible break by way of -fbreak-on-exception
+                         Just Interrupted -> return ()
+                         -- In any other case, we don't want to break
+                         _ -> poke exceptionFlag 0
+
+                Exception.throwIO se
+#endif

 
 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 withInterruptsSentTo thread get_result = do
 
 withInterruptsSentTo :: ThreadId -> IO r -> IO r
 withInterruptsSentTo thread get_result = do

@@ -366,9 +395,10 @@ withInterruptsSentTo thread get_result = do
 -- resets everything when the computation has stopped running.  This
 -- is a not-very-good way to ensure that only the interactive
 -- evaluation should generate breakpoints.
 -- resets everything when the computation has stopped running.  This
 -- is a not-very-good way to ensure that only the interactive
 -- evaluation should generate breakpoints.

-withBreakAction :: Bool -> DynFlags -> MVar () -> MVar Status -> IO a -> IO a
-withBreakAction step dflags breakMVar statusMVar io
- = bracket setBreakAction resetBreakAction (\_ -> io)
+withBreakAction :: (ExceptionMonad m, MonadIO m) =>
+                   Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a
+withBreakAction step dflags breakMVar statusMVar act
+ = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act)

  where
    setBreakAction = do
      stablePtr <- newStablePtr onBreak
  where
    setBreakAction = do
      stablePtr <- newStablePtr onBreak

@@ -398,15 +428,15 @@ noBreakAction :: Bool -> BreakInfo -> HValue -> IO ()
 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
 noBreakAction True  _ _ = return () -- exception: just continue
 
 noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint"
 noBreakAction True  _ _ = return () -- exception: just continue
 

-resume :: Session -> SingleStep -> IO RunResult
-resume (Session ref) step
+resume :: GhcMonad m => SingleStep -> m RunResult
+resume step

  = do
  = do

-   hsc_env <- readIORef ref
+   hsc_env <- getSession

    let ic = hsc_IC hsc_env
        resume = ic_resume ic
 
    case resume of
    let ic = hsc_IC hsc_env
        resume = ic_resume ic
 
    case resume of

-     [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+     [] -> ghcError (ProgramError "not stopped at a breakpoint")

      (r:rs) -> do
         -- unbind the temporary locals by restoring the TypeEnv from
         -- before the breakpoint, and drop this Resume from the
      (r:rs) -> do
         -- unbind the temporary locals by restoring the TypeEnv from
         -- before the breakpoint, and drop this Resume from the

@@ -415,21 +445,21 @@ resume (Session ref) step
             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
                        ic_tyvars   = resume_tyvars,
                        ic_resume   = rs }
             ic' = ic { ic_tmp_ids  = resume_tmp_ids,
                        ic_tyvars   = resume_tyvars,
                        ic_resume   = rs }

-        writeIORef ref hsc_env{ hsc_IC = ic' }
+        modifySession (\_ -> hsc_env{ hsc_IC = ic' })

         
         -- remove any bindings created since the breakpoint from the 
         -- linker's environment
         let new_names = map idName (filter (`notElem` resume_tmp_ids)
                                            (ic_tmp_ids ic))
         
         -- remove any bindings created since the breakpoint from the 
         -- linker's environment
         let new_names = map idName (filter (`notElem` resume_tmp_ids)
                                            (ic_tmp_ids ic))

-        Linker.deleteFromLinkEnv new_names
+        liftIO $ Linker.deleteFromLinkEnv new_names

         
         

-        when (isStep step) $ setStepFlag
+        when (isStep step) $ liftIO setStepFlag

         case r of 
           Resume expr tid breakMVar statusMVar bindings 
               final_ids apStack info _ hist _ -> do
                 withBreakAction (isStep step) (hsc_dflags hsc_env) 
                                         breakMVar statusMVar $ do
         case r of 
           Resume expr tid breakMVar statusMVar bindings 
               final_ids apStack info _ hist _ -> do
                 withBreakAction (isStep step) (hsc_dflags hsc_env) 
                                         breakMVar statusMVar $ do

-                status <- withInterruptsSentTo tid $ do
+                status <- liftIO $ withInterruptsSentTo tid $ do

                              putMVar breakMVar ()
                                       -- this awakens the stopped thread...
                              takeMVar statusMVar
                              putMVar breakMVar ()
                                       -- this awakens the stopped thread...
                              takeMVar statusMVar

@@ -441,42 +471,42 @@ resume (Session ref) step
                                                         fromListBL 50 hist
                 case step of
                   RunAndLogSteps -> 
                                                         fromListBL 50 hist
                 case step of
                   RunAndLogSteps -> 

-                        traceRunStatus expr ref bindings final_ids
+                        traceRunStatus expr bindings final_ids

                                        breakMVar statusMVar status hist'
                   _other ->
                                        breakMVar statusMVar status hist'
                   _other ->

-                        handleRunStatus expr ref bindings final_ids
+                        handleRunStatus expr bindings final_ids

                                         breakMVar statusMVar status hist'
 
                                         breakMVar statusMVar status hist'
 

-back :: Session -> IO ([Name], Int, SrcSpan)
+back :: GhcMonad m => m ([Name], Int, SrcSpan)

 back  = moveHist (+1)
 
 back  = moveHist (+1)
 

-forward :: Session -> IO ([Name], Int, SrcSpan)
+forward :: GhcMonad m => m ([Name], Int, SrcSpan)

 forward  = moveHist (subtract 1)
 
 forward  = moveHist (subtract 1)
 

-moveHist :: (Int -> Int) -> Session -> IO ([Name], Int, SrcSpan)
-moveHist fn (Session ref) = do
-  hsc_env <- readIORef ref
+moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
+moveHist fn = do
+  hsc_env <- getSession

   case ic_resume (hsc_IC hsc_env) of
   case ic_resume (hsc_IC hsc_env) of

-     [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+     [] -> ghcError (ProgramError "not stopped at a breakpoint")

      (r:rs) -> do
         let ix = resumeHistoryIx r
             history = resumeHistory r
             new_ix = fn ix
         --
         when (new_ix > length history) $
      (r:rs) -> do
         let ix = resumeHistoryIx r
             history = resumeHistory r
             new_ix = fn ix
         --
         when (new_ix > length history) $

-           throwDyn (ProgramError "no more logged breakpoints")
+           ghcError (ProgramError "no more logged breakpoints")

         when (new_ix < 0) $
         when (new_ix < 0) $

-           throwDyn (ProgramError "already at the beginning of the history")
+           ghcError (ProgramError "already at the beginning of the history")

 
         let
           update_ic apStack mb_info = do
 
         let
           update_ic apStack mb_info = do

-            (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env 
+            (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env

                                                 apStack mb_info
             let ic = hsc_IC hsc_env1           
                 r' = r { resumeHistoryIx = new_ix }
                 ic' = ic { ic_resume = r':rs }
             
                                                 apStack mb_info
             let ic = hsc_IC hsc_env1           
                 r' = r { resumeHistoryIx = new_ix }
                 ic' = ic { ic_resume = r':rs }
             

-            writeIORef ref hsc_env1{ hsc_IC = ic' } 
+            modifySession (\_ -> hsc_env1{ hsc_IC = ic' })

             
             return (names, new_ix, span)
 
             
             return (names, new_ix, span)
 

@@ -511,7 +541,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
    let exn_fs    = fsLit "_exception"
        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
        e_fs      = fsLit "e"
    let exn_fs    = fsLit "_exception"
        exn_name  = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
        e_fs      = fsLit "e"

-       e_name    = mkInternalName (getUnique e_fs) (mkTyVarOcc e_fs) span
+       e_name    = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span

        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
                                 vanillaIdInfo
        e_tyvar   = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
        exn_id    = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar)
                                 vanillaIdInfo

@@ -608,26 +638,46 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
        incompletelyTypedIds = 
            [id | id <- tmp_ids
    let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
        incompletelyTypedIds = 
            [id | id <- tmp_ids

-               , not $ null [v | v <- varSetElems$ tyVarsOfType (idType id)
-                              , isSkolemTyVar v]
+               , not $ noSkolems id

                , (occNameFS.nameOccName.idName) id /= result_fs]
                , (occNameFS.nameOccName.idName) id /= result_fs]

-   tys <- reconstructType hsc_env 10 `mapM` incompletelyTypedIds
-          -- map termType `fmap` (obtainTerm hsc_env False `mapM` incompletelyTypedIds)
-   
-   improvs <- sequence [improveRTTIType hsc_env ty ty'
-                 | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys]
-   let ic' = foldr (\mb_subst ic' ->
-                        maybe (WARN(True, text ("RTTI failed to calculate the "
-                                           ++  "improvement for a type")) ic')
-                              (substInteractiveContext ic' . skolemiseSubst)
-                              mb_subst)
-                   ic
-                   improvs
-   return hsc_env{hsc_IC=ic'}
-
-skolemiseSubst :: TvSubst -> TvSubst
-skolemiseSubst subst = subst `setTvSubstEnv` 
-                        mapVarEnv (fst.skolemiseTy) (getTvSubstEnv subst)
+   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
+   return hsc_env'
+    where
+     noSkolems = null . filter isSkolemTyVar . varSetElems . tyVarsOfType . idType
+     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
+      let InteractiveContext{ic_tmp_ids=tmp_ids} = ic
+          Just id = find (\i -> idName i == name) tmp_ids
+      if noSkolems id
+         then return hsc_env
+         else do
+           mb_new_ty <- reconstructType hsc_env 10 id
+           let old_ty = idType id
+           case mb_new_ty of
+             Nothing -> return hsc_env
+             Just new_ty -> do
+              mb_subst <- improveRTTIType hsc_env old_ty new_ty
+              case mb_subst of
+               Nothing -> return $
+                        WARN(True, text (":print failed to calculate the "
+                                           ++ "improvement for a type")) hsc_env
+               Just subst -> do
+                 when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
+                      printForUser stderr alwaysQualify $
+                      fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
+
+                 let (subst', skols) = skolemiseSubst subst
+                     ic' = extendInteractiveContext
+                               (substInteractiveContext ic subst') [] skols
+                 return hsc_env{hsc_IC=ic'}
+
+skolemiseSubst :: TvSubst -> (TvSubst, TyVarSet)
+skolemiseSubst subst = let
+    varenv               = getTvSubstEnv subst
+    all_together         = mapVarEnv skolemiseTy varenv
+    (varenv', skol_vars) = ( mapVarEnv fst all_together
+                           , map snd (varEnvElts all_together))
+    in (subst `setTvSubstEnv` varenv', unionVarSets skol_vars)
+                        

 
 skolemiseTy :: Type -> (Type, TyVarSet)
 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)
 
 skolemiseTy :: Type -> (Type, TyVarSet)
 skolemiseTy ty = (substTy subst ty, mkVarSet new_tyvars)

@@ -660,28 +710,28 @@ pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
 -- -----------------------------------------------------------------------------
 -- Abandoning a resume context
 
 -- -----------------------------------------------------------------------------
 -- Abandoning a resume context
 

-abandon :: Session -> IO Bool
-abandon (Session ref) = do
-   hsc_env <- readIORef ref
+abandon :: GhcMonad m => m Bool
+abandon = do
+   hsc_env <- getSession

    let ic = hsc_IC hsc_env
        resume = ic_resume ic
    case resume of
       []    -> return False
       r:rs  -> do 
    let ic = hsc_IC hsc_env
        resume = ic_resume ic
    case resume of
       []    -> return False
       r:rs  -> do 

-         writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
-         abandon_ r
+         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } }
+         liftIO $ abandon_ r

          return True
 
          return True
 

-abandonAll :: Session -> IO Bool
-abandonAll (Session ref) = do
-   hsc_env <- readIORef ref
+abandonAll :: GhcMonad m => m Bool
+abandonAll = do
+   hsc_env <- getSession

    let ic = hsc_IC hsc_env
        resume = ic_resume ic
    case resume of
       []  -> return False
       rs  -> do 
    let ic = hsc_IC hsc_env
        resume = ic_resume ic
    case resume of
       []  -> return False
       rs  -> do 

-         writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
-         mapM_ abandon_ rs
+         modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } }
+         liftIO $ mapM_ abandon_ rs

          return True
 
 -- when abandoning a computation we have to 
          return True
 
 -- when abandoning a computation we have to 

@@ -730,21 +780,22 @@ fromListBL bound l = BL (length l) bound l []
 -- Setting the context doesn't throw away any bindings; the bindings
 -- we've built up in the InteractiveContext simply move to the new
 -- module.  They always shadow anything in scope in the current context.
 -- Setting the context doesn't throw away any bindings; the bindings
 -- we've built up in the InteractiveContext simply move to the new
 -- module.  They always shadow anything in scope in the current context.

-setContext :: Session
-          -> [Module]  -- entire top level scope of these modules
-          -> [Module]  -- exports only of these modules
-          -> IO ()
-setContext (Session ref) toplev_mods export_mods = do 
-  hsc_env <- readIORef ref
+setContext :: GhcMonad m =>
+              [Module] -- ^ entire top level scope of these modules
+          -> [Module]  -- ^ exports only of these modules
+          -> m ()
+setContext toplev_mods export_mods = do
+  hsc_env <- getSession

   let old_ic  = hsc_IC     hsc_env
       hpt     = hsc_HPT    hsc_env
   --
   let old_ic  = hsc_IC     hsc_env
       hpt     = hsc_HPT    hsc_env
   --

-  export_env  <- mkExportEnv hsc_env export_mods
-  toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods
+  export_env  <- liftIO $ mkExportEnv hsc_env export_mods
+  toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods

   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs
   let all_env = foldr plusGlobalRdrEnv export_env toplev_envs

-  writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
-                                           ic_exports      = export_mods,
-                                           ic_rn_gbl_env   = all_env }}
+  modifySession $ \_ ->
+      hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods,
+                                ic_exports      = export_mods,
+                                ic_rn_gbl_env   = all_env }}

 
 -- Make a GlobalRdrEnv based on the exports of the modules only.
 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 
 -- Make a GlobalRdrEnv based on the exports of the modules only.
 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv

@@ -774,26 +825,26 @@ vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}]
 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 mkTopLevEnv hpt modl
   = case lookupUFM hpt (moduleName modl) of
 mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv
 mkTopLevEnv hpt modl
   = case lookupUFM hpt (moduleName modl) of

-      Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ 
+      Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ 

                                                 showSDoc (ppr modl)))
       Just details ->
         case mi_globals (hm_iface details) of
                Nothing  -> 
                                                 showSDoc (ppr modl)))
       Just details ->
         case mi_globals (hm_iface details) of
                Nothing  -> 

-                  throwDyn (ProgramError ("mkTopLevEnv: not interpreted " 
+                  ghcError (ProgramError ("mkTopLevEnv: not interpreted " 

                                                ++ showSDoc (ppr modl)))
                Just env -> return env
 
 -- | Get the interactive evaluation context, consisting of a pair of the
 -- set of modules from which we take the full top-level scope, and the set
 -- of modules from which we take just the exports respectively.
                                                ++ showSDoc (ppr modl)))
                Just env -> return env
 
 -- | Get the interactive evaluation context, consisting of a pair of the
 -- set of modules from which we take the full top-level scope, and the set
 -- of modules from which we take just the exports respectively.

-getContext :: Session -> IO ([Module],[Module])
-getContext s = withSession s (\HscEnv{ hsc_IC=ic } ->
-                               return (ic_toplev_scope ic, ic_exports ic))
+getContext :: GhcMonad m => m ([Module],[Module])
+getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
+              return (ic_toplev_scope ic, ic_exports ic)

 
 

--- | Returns 'True' if the specified module is interpreted, and hence has
+-- | Returns @True@ if the specified module is interpreted, and hence has

 -- its full top-level scope available.
 -- its full top-level scope available.

-moduleIsInterpreted :: Session -> Module -> IO Bool
-moduleIsInterpreted s modl = withSession s $ \h ->
+moduleIsInterpreted :: GhcMonad m => Module -> m Bool
+moduleIsInterpreted modl = withSession $ \h ->

  if modulePackageId modl /= thisPackage (hsc_dflags h)
         then return False
         else case lookupUFM (hsc_HPT h) (moduleName modl) of
  if modulePackageId modl /= thisPackage (hsc_dflags h)
         then return False
         else case lookupUFM (hsc_HPT h) (moduleName modl) of

@@ -805,15 +856,15 @@ moduleIsInterpreted s modl = withSession s $ \h ->
 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 --     (see Trac #1581)
 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 --     (see Trac #1581)

-getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance]))
-getInfo s name 
-  = withSession s $ \hsc_env -> 
-    do { mb_stuff <- tcRnGetInfo hsc_env name
-       ; case mb_stuff of
-           Nothing -> return Nothing
-           Just (thing, fixity, ispecs) -> do
-       { let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
-       ; return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) } }
+getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
+getInfo name
+  = withSession $ \hsc_env ->
+    do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name
+       case mb_stuff of
+         Nothing -> return Nothing
+         Just (thing, fixity, ispecs) -> do
+           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
+           return (Just (thing, fixity, filter (plausible rdr_env) ispecs))

   where
     plausible rdr_env ispec    -- Dfun involving only names that are in ic_rn_glb_env
        = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec
   where
     plausible rdr_env ispec    -- Dfun involving only names that are in ic_rn_glb_env
        = all ok $ nameSetToList $ tyClsNamesOfType $ idType $ instanceDFunId ispec

@@ -826,12 +877,12 @@ getInfo s name
               | otherwise         = True
 
 -- | Returns all names in scope in the current interactive context
               | otherwise         = True
 
 -- | Returns all names in scope in the current interactive context

-getNamesInScope :: Session -> IO [Name]
-getNamesInScope s = withSession s $ \hsc_env -> do
+getNamesInScope :: GhcMonad m => m [Name]
+getNamesInScope = withSession $ \hsc_env -> do

   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 
   return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
 

-getRdrNamesInScope :: Session -> IO [RdrName]
-getRdrNamesInScope  s = withSession s $ \hsc_env -> do
+getRdrNamesInScope :: GhcMonad m => m [RdrName]
+getRdrNamesInScope = withSession $ \hsc_env -> do

   let 
       ic = hsc_IC hsc_env
       gbl_rdrenv = ic_rn_gbl_env ic
   let 
       ic = hsc_IC hsc_env
       gbl_rdrenv = ic_rn_gbl_env ic

@@ -858,94 +909,78 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov }
 
 -- | Parses a string as an identifier, and returns the list of 'Name's that
 -- the identifier can refer to in the current interactive context.
 
 -- | Parses a string as an identifier, and returns the list of 'Name's that
 -- the identifier can refer to in the current interactive context.

-parseName :: Session -> String -> IO [Name]
-parseName s str = withSession s $ \hsc_env -> do
-   maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str
-   case maybe_rdr_name of
-       Nothing -> return []
-       Just (L _ rdr_name) -> do
-           mb_names <- tcRnLookupRdrName hsc_env rdr_name
-           case mb_names of
-               Nothing -> return []
-               Just ns -> return ns
-               -- ToDo: should return error messages
+parseName :: GhcMonad m => String -> m [Name]
+parseName str = withSession $ \hsc_env -> do
+   (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str
+   ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name

 
 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 -- entity known to GHC, including 'Name's defined using 'runStmt'.
 
 -- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
 -- entity known to GHC, including 'Name's defined using 'runStmt'.

-lookupName :: Session -> Name -> IO (Maybe TyThing)
-lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name
+lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
+lookupName name = withSession $ \hsc_env -> do
+  mb_tything <- ioMsg $ tcRnLookupName hsc_env name
+  return mb_tything
+  -- XXX: calls panic in some circumstances;  is that ok?

 
 -- -----------------------------------------------------------------------------
 -- Getting the type of an expression
 
 -- | Get the type of an expression
 
 -- -----------------------------------------------------------------------------
 -- Getting the type of an expression
 
 -- | Get the type of an expression

-exprType :: Session -> String -> IO (Maybe Type)
-exprType s expr = withSession s $ \hsc_env -> do
-   maybe_stuff <- hscTcExpr hsc_env expr
-   case maybe_stuff of
-       Nothing -> return Nothing
-       Just ty -> return (Just tidy_ty)
-            where 
-               tidy_ty = tidyType emptyTidyEnv ty
+exprType :: GhcMonad m => String -> m Type
+exprType expr = withSession $ \hsc_env -> do
+   ty <- hscTcExpr hsc_env expr
+   return $ tidyType emptyTidyEnv ty

 
 -- -----------------------------------------------------------------------------
 -- Getting the kind of a type
 
 -- | Get the kind of a  type
 
 -- -----------------------------------------------------------------------------
 -- Getting the kind of a type
 
 -- | Get the kind of a  type

-typeKind  :: Session -> String -> IO (Maybe Kind)
-typeKind s str = withSession s $ \hsc_env -> do
-   maybe_stuff <- hscKcType hsc_env str
-   case maybe_stuff of
-       Nothing -> return Nothing
-       Just kind -> return (Just kind)
+typeKind  :: GhcMonad m => String -> m Kind
+typeKind str = withSession $ \hsc_env -> do
+   hscKcType hsc_env str

 
 -----------------------------------------------------------------------------
 -- cmCompileExpr: compile an expression and deliver an HValue
 
 
 -----------------------------------------------------------------------------
 -- cmCompileExpr: compile an expression and deliver an HValue
 

-compileExpr :: Session -> String -> IO (Maybe HValue)
-compileExpr s expr = withSession s $ \hsc_env -> do
-  maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
-  case maybe_stuff of
-       Nothing -> return Nothing
-       Just (ids, hval) -> do
-                       -- Run it!
-               hvals <- (unsafeCoerce# hval) :: IO [HValue]
+compileExpr :: GhcMonad m => String -> m HValue
+compileExpr expr = withSession $ \hsc_env -> do
+  Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr)
+                -- Run it!
+  hvals <- liftIO (unsafeCoerce# hval :: IO [HValue])

 
 

-               case (ids,hvals) of
-                 ([_],[hv]) -> return (Just hv)
-                 _          -> panic "compileExpr"
+  case (ids,hvals) of
+    ([_],[hv]) -> return hv
+    _       -> panic "compileExpr"

 
 -- -----------------------------------------------------------------------------
 -- Compile an expression into a dynamic
 
 
 -- -----------------------------------------------------------------------------
 -- Compile an expression into a dynamic
 

-dynCompileExpr :: Session -> String -> IO (Maybe Dynamic)
-dynCompileExpr ses expr = do
-    (full,exports) <- getContext ses
-    setContext ses full $
+dynCompileExpr :: GhcMonad m => String -> m Dynamic
+dynCompileExpr expr = do
+    (full,exports) <- getContext
+    setContext full $

         (mkModule
             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
         ):exports
     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
         (mkModule
             (stringToPackageId "base") (mkModuleName "Data.Dynamic")
         ):exports
     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"

-    res <- withSession ses (flip hscStmt stmt)
-    setContext ses full exports
-    case res of
-        Nothing -> return Nothing
-        Just (ids, hvals) -> do
-            vals <- (unsafeCoerce# hvals :: IO [Dynamic])
-            case (ids,vals) of
-                (_:[], v:[])    -> return (Just v)
-                _               -> panic "dynCompileExpr"
+    Just (ids, hvals) <- withSession (flip hscStmt stmt)
+    setContext full exports
+    vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
+    case (ids,vals) of
+        (_:[], v:[])    -> return v
+        _               -> panic "dynCompileExpr"

 
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames
 
 
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames
 

-showModule :: Session -> ModSummary -> IO String
-showModule s mod_summary = withSession s $                        \hsc_env -> 
-                           isModuleInterpreted s mod_summary >>=  \interpreted -> 
-                           return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
+showModule :: GhcMonad m => ModSummary -> m String
+showModule mod_summary =
+    withSession $ \hsc_env -> do
+        interpreted <- isModuleInterpreted mod_summary
+        return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)

 
 

-isModuleInterpreted :: Session -> ModSummary -> IO Bool
-isModuleInterpreted s mod_summary = withSession s $ \hsc_env -> 
+isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
+isModuleInterpreted mod_summary = withSession $ \hsc_env ->

   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
        Nothing       -> panic "missing linkable"
        Just mod_info -> return (not obj_linkable)
   case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
        Nothing       -> panic "missing linkable"
        Just mod_info -> return (not obj_linkable)

@@ -955,23 +990,20 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 ----------------------------------------------------------------------------
 -- RTTI primitives
 
 ----------------------------------------------------------------------------
 -- RTTI primitives
 

-obtainTerm1 :: HscEnv -> Bool -> Maybe Type -> a -> IO Term
-obtainTerm1 hsc_env force mb_ty x = 
-              cvObtainTerm hsc_env maxBound force mb_ty (unsafeCoerce# x)
+obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
+obtainTermFromVal hsc_env bound force ty x =
+              cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)

 
 

-obtainTermB :: HscEnv -> Int -> Bool -> Id -> IO Term
-obtainTermB hsc_env bound force id =  do
-              hv <- Linker.getHValue hsc_env (varName id) 
-              cvObtainTerm hsc_env bound force (Just$ idType id) hv
-
-obtainTerm :: HscEnv -> Bool -> Id -> IO Term
-obtainTerm hsc_env force id =  do
-              hv <- Linker.getHValue hsc_env (varName id) 
-              cvObtainTerm hsc_env maxBound force (Just$ idType id) hv
+obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
+obtainTermFromId hsc_env bound force id =  do
+              hv <- Linker.getHValue hsc_env (varName id)
+              cvObtainTerm hsc_env bound force (idType id) hv

 
 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 reconstructType hsc_env bound id = do
               hv <- Linker.getHValue hsc_env (varName id) 
 
 -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
 reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
 reconstructType hsc_env bound id = do
               hv <- Linker.getHValue hsc_env (varName id) 

-              cvReconstructType hsc_env bound (Just$ idType id) hv
+              cvReconstructType hsc_env bound (idType id) hv
+

 #endif /* GHCI */
 #endif /* GHCI */

+