X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=e7a5a37edb9c793863fe6e09842344ae3849bdb8;hb=8099fc7e9c54b24dc50c2cd1b9bfdc59e2d218b1;hp=9e05c87a9d7693a4dd27e609415dfcda226a726d;hpb=366e8db02ab7a5bb5316699bff397d06e47891b2;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 9e05c87..e7a5a37 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -71,7 +71,6 @@ import System.Console.Readline as Readline --import SystemExts import Control.Exception as Exception -import Data.Dynamic -- import Control.Concurrent import Numeric @@ -79,7 +78,6 @@ import Data.List 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 @@ -168,7 +166,7 @@ helpText = " :set args ... set the arguments returned by System.getArgs\n" ++ " :set prog set the value returned by System.getProgName\n" ++ " :set prompt set the prompt used in GHCi\n" ++ - " :set editor set the comand used for :edit\n" ++ + " :set editor 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" ++ @@ -557,32 +555,6 @@ runCommandEval c = ghciHandle handleEval (doCommand c) -- 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 []) @@ -617,12 +589,6 @@ showTypeOfName session n 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 @@ -644,43 +610,6 @@ lookupCommand 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 () @@ -1465,133 +1394,6 @@ completeFilename = completeNone 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