X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=e1c92316653ed51022bd2caed7f6e864c79380d8;hb=46b28f7bfdd535e9fe5217a1151bedfb2cc15472;hp=02344cf561fdbd0e7663ca66ad2eaa3fa122a40b;hpb=9f589efb688f22cb0637f9c1164dd9027b4378a3;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 02344cf..e1c9231 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,10 +6,7 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- -module InteractiveUI ( - interactiveUI, - ghciWelcomeMsg - ) where +module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -21,7 +18,7 @@ import Debugger import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, - BreakIndex, Name, SrcSpan, Resume, SingleStep ) + BreakIndex, SrcSpan, Resume, SingleStep ) import DynFlags import Packages import PackageConfig @@ -29,6 +26,7 @@ import UniqFM import PprTyThing import Outputable hiding (printForUser) import Module -- for ModuleEnv +import Name -- Other random utilities import Digraph @@ -83,12 +81,9 @@ import System.Posix.Internals ( setNonBlockingFD ) ----------------------------------------------------------------------------- -ghciWelcomeMsg = - " ___ ___ _\n"++ - " / _ \\ /\\ /\\/ __(_)\n"++ - " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++ - "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++ - "\\____/\\/ /_/\\____/|_| Type :? for help.\n" +ghciWelcomeMsg :: String +ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ + ": http://www.haskell.org/ghc/ :? for help" type Command = (String, String -> GHCi Bool, Bool, String -> IO [String]) cmdName (n,_,_,_) = n @@ -241,21 +236,22 @@ interactiveUI session srcs maybe_expr = do newStablePtr stdout newStablePtr stderr - -- Initialise buffering for the *interpreted* I/O system + -- Initialise buffering for the *interpreted* I/O system initInterpBuffering session when (isNothing maybe_expr) $ do - -- Only for GHCi (not runghc and ghc -e): - -- Turn buffering off for the compiled program's stdout/stderr - turnOffBuffering - -- Turn buffering off for GHCi's stdout - hFlush stdout - hSetBuffering stdout NoBuffering - -- We don't want the cmd line to buffer any input that might be - -- intended for the program, so unbuffer stdin. - hSetBuffering stdin NoBuffering - - -- initial context is just the Prelude + -- Only for GHCi (not runghc and ghc -e): + + -- Turn buffering off for the compiled program's stdout/stderr + turnOffBuffering + -- Turn buffering off for GHCi's stdout + hFlush stdout + hSetBuffering stdout NoBuffering + -- We don't want the cmd line to buffer any input that might be + -- intended for the program, so unbuffer stdin. + hSetBuffering stdin NoBuffering + + -- initial context is just the Prelude prel_mod <- GHC.findModule session prel_name (Just basePackageId) GHC.setContext session [] [prel_mod] @@ -347,28 +343,28 @@ runGHCi paths maybe_expr = do let show_prompt = verbosity dflags > 0 || is_tty case maybe_expr of - Nothing -> + Nothing -> do #if defined(mingw32_HOST_OS) - -- The win32 Console API mutates the first character of + -- The win32 Console API mutates the first character of -- type-ahead when reading from it in a non-buffered manner. Work -- around this by flushing the input buffer of type-ahead characters, -- but only if stdin is available. flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin)) - case flushed of - Left err | isDoesNotExistError err -> return () - | otherwise -> io (ioError err) - Right () -> return () + case flushed of + Left err | isDoesNotExistError err -> return () + | otherwise -> io (ioError err) + Right () -> return () #endif - -- initialise the console if necessary - io setUpConsole + -- initialise the console if necessary + io setUpConsole - -- enter the interactive loop - interactiveLoop is_tty show_prompt - Just expr -> do - -- just evaluate the expression we were given - runCommandEval expr - return () + -- enter the interactive loop + interactiveLoop is_tty show_prompt + Just expr -> do + -- just evaluate the expression we were given + runCommandEval expr + return () -- and finally, exit io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." @@ -569,12 +565,12 @@ afterRunStmt run_result = do case run_result of GHC.RunOk names -> do show_types <- isOptionSet ShowType - when show_types $ mapM_ (showTypeOfName session) names + when show_types $ printTypeOfNames session names GHC.RunBreak _ names mb_info -> do resumes <- io $ GHC.getResumeContext session printForUser $ ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan (head resumes)) - mapM_ (showTypeOfName session) names + printTypeOfNames session names maybe (return ()) runBreakCmd mb_info -- run the command set with ":set stop " st <- getGHCiState @@ -601,12 +597,20 @@ runBreakCmd info = do | otherwise -> do enqueueCommands [cmd]; return () where cmd = onBreakCmd loc -showTypeOfName :: Session -> Name -> GHCi () -showTypeOfName session n +printTypeOfNames :: Session -> [Name] -> GHCi () +printTypeOfNames session names + = mapM_ (printTypeOfName session) $ sortBy compareNames names + +compareNames :: Name -> Name -> Ordering +n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2 + where compareWith n = (getOccString n, getSrcSpan n) + +printTypeOfName :: Session -> Name -> GHCi () +printTypeOfName session n = do maybe_tything <- io (GHC.lookupName session n) - case maybe_tything of - Nothing -> return () - Just thing -> showTyThing thing + case maybe_tything of + Nothing -> return () + Just thing -> printTyThing thing specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) @@ -849,7 +853,7 @@ checkModule :: String -> GHCi () checkModule m = do let modl = GHC.mkModuleName m session <- getSession - result <- io (GHC.checkModule session modl) + result <- io (GHC.checkModule session modl False) case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( @@ -1244,13 +1248,17 @@ showBindings = do s <- getSession unqual <- io (GHC.getPrintUnqual s) bindings <- io (GHC.getBindings s) - mapM_ showTyThing bindings + mapM_ printTyThing $ sortBy compareTyThings bindings return () -showTyThing (AnId id) = do +compareTyThings :: TyThing -> TyThing -> Ordering +t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 + +printTyThing :: TyThing -> GHCi () +printTyThing (AnId id) = do ty' <- cleanType (GHC.idType id) printForUser $ ppr id <> text " :: " <> ppr ty' -showTyThing _ = return () +printTyThing _ = return () -- if -fglasgow-exts is on we show the foralls, otherwise we don't. cleanType :: Type -> GHCi Type @@ -1579,7 +1587,7 @@ backCmd = noArgs $ do s <- getSession (names, ix, span) <- io $ GHC.back s printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span - mapM_ (showTypeOfName s) names + printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] @@ -1591,7 +1599,7 @@ forwardCmd = noArgs $ do printForUser $ (if (ix == 0) then ptext SLIT("Stopped at") else ptext SLIT("Logged breakpoint at")) <+> ppr span - mapM_ (showTypeOfName s) names + printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st]