-io m = GHCi { unGHCi = \s -> m >>= return }
-
-isTopLevel :: GHCi Bool
-isTopLevel = getGHCiState >>= return . topLevel
-
-getBkptTable :: GHCi (BkptTable GHC.Module)
-getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
- io$ readIORef table_ref
-
-setBkptTable :: BkptTable GHC.Module -> GHCi ()
-setBkptTable new_table = do
- table_ref <- getGHCiState >>= return . bkptTable
- io$ writeIORef table_ref new_table
-
-modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
-modifyBkptTable f = do
- bt <- getBkptTable
- new_bt <- io . evaluate$ f bt
- setBkptTable new_bt
-
-showForUser :: SDoc -> GHCi String
-showForUser doc = do
- session <- getSession
- unqual <- io (GHC.getPrintUnqual session)
- return $! showSDocForUser unqual doc
-
------------------------------------------------------------------------------
--- User code exception handling
-
--- This hierarchy of exceptions is used to signal interruption of a child session
-data BkptException = StopChildSession -- A child debugging session requests to be stopped
- | ChildSessionStopped String
- deriving Typeable
-
--- This is the exception handler for exceptions generated by the
--- user's code and exceptions coming from children sessions;
--- it normally just prints out the exception. The
--- handler must be recursive, in case showing the exception causes
--- more exceptions to be raised.
---
--- Bugfix: if the user closed stdout or stderr, the flushing will fail,
--- raising another exception. We therefore don't put the recursive
--- handler arond the flushing operation, so if stderr is closed
--- GHCi will just die gracefully rather than going into an infinite loop.
-handler :: Exception -> GHCi Bool
-handler (DynException dyn)
- | Just StopChildSession <- fromDynamic dyn
- -- propagate to the parent session
- = ASSERTM (liftM not isTopLevel) >> throwDyn StopChildSession
-
- | Just (ChildSessionStopped msg) <- fromDynamic dyn
- -- Revert CAFs and display some message
- = ASSERTM (isTopLevel) >>
- io (revertCAFs >> putStrLn msg) >>
- return False
-
-handler exception = do
- flushInterpBuffers
- io installSignalHandlers
- ghciHandle handler (showException exception >> return False)
-
-showException (DynException dyn) =
- case fromDynamic dyn of
- Nothing -> io (putStrLn ("*** Exception: (unknown)"))
- Just Interrupted -> io (putStrLn "Interrupted.")
- Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
- Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
- Just other_ghc_ex -> io (print other_ghc_ex)
-
-showException other_exception
- = io (putStrLn ("*** Exception: " ++ show other_exception))
-
------------------------------------------------------------------------------
--- recursive exception handlers
-
--- Don't forget to unblock async exceptions in the handler, or if we're
--- in an exception loop (eg. let a = error a in a) the ^C exception
--- may never be delivered. Thanks to Marcin for pointing out the bug.
-
-ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
-ghciHandle h (GHCi m) = GHCi $ \s ->
- Exception.catch (m s)
- (\e -> unGHCi (ghciUnblock (h e)) s)
-
-ghciUnblock :: GHCi a -> GHCi a
-ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
-
------------------------------------------------------------------------------
+io = liftIO
+
+printForUser :: SDoc -> GHCi ()
+printForUser doc = do
+ unqual <- GHC.getPrintUnqual
+ io $ Outputable.printForUser stdout unqual doc
+
+printForUserPartWay :: SDoc -> GHCi ()
+printForUserPartWay doc = do
+ unqual <- GHC.getPrintUnqual
+ io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
+
+runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
+runStmt expr step = do
+ st <- getGHCiState
+ reifyGHCi $ \x ->
+ withProgName (progname st) $
+ withArgs (args st) $
+ reflectGHCi x $ do
+ GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
+ return GHC.RunFailed) $ do
+ GHC.runStmt expr step
+
+resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
+resume canLogSpan step = GHC.resume canLogSpan step
+
+-- --------------------------------------------------------------------------