--import SystemExts
import Control.Exception as Exception
-import Data.Dynamic
-- import Control.Concurrent
import Numeric
import Data.Int ( Int64 )
import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes )
import System.Cmd
-import System.CPUTime
import System.Environment
import System.Exit ( exitWith, ExitCode(..) )
import System.Directory
" :set args <arg> ... set the arguments returned by System.getArgs\n" ++
" :set prog <progname> set the value returned by System.getProgName\n" ++
" :set prompt <prompt> set the prompt used in GHCi\n" ++
- " :set editor <cmd> set the comand used for :edit\n" ++
+ " :set editor <cmd> set the command used for :edit\n" ++
"\n" ++
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
"\n" ++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
- " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
+ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
" :type <expr> show the type of <expr>\n" ++
" :kind <type> show the kind of <type>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
-- failure to run the command causes exit(1) for ghc -e.
_ -> finishEvalExpr nms
--- This is the exception handler for exceptions generated by the
--- user's code; 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 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))
-
runStmt :: String -> GHCi (Maybe [Name])
runStmt stmt
| null (filter (not.isSpace) stmt) = return (Just [])
Nothing -> return ()
Just thing -> showTyThing thing
-showForUser :: SDoc -> GHCi String
-showForUser doc = do
- session <- getSession
- unqual <- io (GHC.getPrintUnqual session)
- return $! showSDocForUser unqual doc
-
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
c:_ -> return (Just c)
-----------------------------------------------------------------------------
--- To flush buffers for the *interpreted* computation we need
--- to refer to *its* stdout/stderr handles
-
-GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
-GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
-
-no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
- " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
-flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
-
-initInterpBuffering :: Session -> IO ()
-initInterpBuffering session
- = do maybe_hval <- GHC.compileExpr session no_buf_cmd
-
- case maybe_hval of
- Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
- other -> panic "interactiveUI:setBuffering"
-
- maybe_hval <- GHC.compileExpr session flush_cmd
- case maybe_hval of
- Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
- _ -> panic "interactiveUI:flush"
-
- return ()
-
-
-flushInterpBuffers :: GHCi ()
-flushInterpBuffers
- = io $ do Monad.join (readIORef flush_interp)
- return ()
-
-turnOffBuffering :: IO ()
-turnOffBuffering
- = do Monad.join (readIORef turn_off_buffering)
- return ()
-
------------------------------------------------------------------------------
-- Commands
help :: String -> GHCi ()
completeHomeModuleOrFile=completeNone
#endif
------------------------------------------------------------------------------
--- GHCi monad
-
-data GHCiState = GHCiState
- {
- progname :: String,
- args :: [String],
- prompt :: String,
- editor :: String,
- session :: GHC.Session,
- options :: [GHCiOption],
- prelude :: Module
- }
-
-data GHCiOption
- = ShowTiming -- show time/allocs after evaluation
- | ShowType -- show the type of expressions
- | RevertCAFs -- revert CAFs after every evaluation
- deriving Eq
-
-newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
-
-startGHCi :: GHCi a -> GHCiState -> IO a
-startGHCi g state = do ref <- newIORef state; unGHCi g ref
-
-instance Monad GHCi where
- (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
- return a = GHCi $ \s -> return a
-
-ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
-ghciHandleDyn h (GHCi m) = GHCi $ \s ->
- Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
-
-getGHCiState = GHCi $ \r -> readIORef r
-setGHCiState s = GHCi $ \r -> writeIORef r s
-
--- for convenience...
-getSession = getGHCiState >>= return . session
-getPrelude = getGHCiState >>= return . prelude
-
-GLOBAL_VAR(saved_sess, no_saved_sess, Session)
-no_saved_sess = error "no saved_ses"
-saveSession = getSession >>= io . writeIORef saved_sess
-splatSavedSession = io (writeIORef saved_sess no_saved_sess)
-restoreSession = readIORef saved_sess
-
-getDynFlags = do
- s <- getSession
- io (GHC.getSessionDynFlags s)
-setDynFlags dflags = do
- s <- getSession
- io (GHC.setSessionDynFlags s dflags)
-
-isOptionSet :: GHCiOption -> GHCi Bool
-isOptionSet opt
- = do st <- getGHCiState
- return (opt `elem` options st)
-
-setOption :: GHCiOption -> GHCi ()
-setOption opt
- = do st <- getGHCiState
- setGHCiState (st{ options = opt : filter (/= opt) (options st) })
-
-unsetOption :: GHCiOption -> GHCi ()
-unsetOption opt
- = do st <- getGHCiState
- setGHCiState (st{ options = filter (/= opt) (options st) })
-
-io :: IO a -> GHCi a
-io m = GHCi { unGHCi = \s -> m >>= return }
-
------------------------------------------------------------------------------
--- 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)
-
------------------------------------------------------------------------------
--- timing & statistics
-
-timeIt :: GHCi a -> GHCi a
-timeIt action
- = do b <- isOptionSet ShowTiming
- if not b
- then action
- else do allocs1 <- io $ getAllocations
- time1 <- io $ getCPUTime
- a <- action
- allocs2 <- io $ getAllocations
- time2 <- io $ getCPUTime
- io $ printTimes (fromIntegral (allocs2 - allocs1))
- (time2 - time1)
- return a
-
-foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
- -- defined in ghc/rts/Stats.c
-
-printTimes :: Integer -> Integer -> IO ()
-printTimes allocs psecs
- = do let secs = (fromIntegral psecs / (10^12)) :: Float
- secs_str = showFFloat (Just 2) secs
- putStrLn (showSDoc (
- parens (text (secs_str "") <+> text "secs" <> comma <+>
- text (show allocs) <+> text "bytes")))
-
------------------------------------------------------------------------------
--- reverting CAFs
-
-revertCAFs :: IO ()
-revertCAFs = do
- rts_revertCAFs
- turnOffBuffering
- -- Have to turn off buffering again, because we just
- -- reverted stdout, stderr & stdin to their defaults.
-
-foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
- -- Make it "safe", just in case
-
-- ----------------------------------------------------------------------------
-- Utils
projects / ghc-hetmet.git / blobdiff