-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
-
- withBreakAction (isStep step) dflags' breakMVar statusMVar $ do
-
- let thing_to_run = unsafeCoerce# hval :: IO [HValue]
- status <- sandboxIO statusMVar thing_to_run
-
- 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
-
-
+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 <-
+ withVirtualCWD $
+ 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)
+
+ case step of
+ RunAndLogSteps ->
+ traceRunStatus expr bindings ids
+ breakMVar statusMVar status emptyHistory
+ _other ->
+ handleRunStatus expr bindings ids
+ breakMVar statusMVar status emptyHistory
+
+withVirtualCWD :: GhcMonad m => m a -> m a
+withVirtualCWD m = do
+ hsc_env <- getSession
+ let ic = hsc_IC hsc_env
+
+ let set_cwd = do
+ dir <- liftIO $ getCurrentDirectory
+ case ic_cwd ic of
+ Just dir -> liftIO $ setCurrentDirectory dir
+ Nothing -> return ()
+ return dir
+
+ reset_cwd orig_dir = do
+ virt_dir <- liftIO $ getCurrentDirectory
+ hsc_env <- getSession
+ let old_IC = hsc_IC hsc_env
+ setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
+ liftIO $ setCurrentDirectory orig_dir
+
+ gbracket set_cwd reset_cwd $ \_ -> m
+
+
+emptyHistory :: BoundedList History