X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=4c81bf4323f17fa0d275a6c947b301e3d98ebfe8;hb=bf3339dd17b16dcc13212cd016a7c44a58183336;hp=055b7164dee550f8bdb8d57041c392ea52ae07c8;hpb=f03f49b0e2de91fdec3ef8e40f2e23258076980c;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 055b716..4c81bf4 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 ) 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 @@ -41,10 +39,7 @@ import Util import FastString #ifndef mingw32_HOST_OS -import System.Posix -#if __GLASGOW_HASKELL__ > 504 - hiding (getEnv) -#endif +import System.Posix hiding (getEnv) #else import GHC.ConsoleHandler ( flushConsole ) import System.Win32 ( setConsoleCP, setConsoleOutputCP ) @@ -70,7 +65,6 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO -import System.FilePath import Data.Char import Data.Dynamic import Data.Array @@ -94,6 +88,10 @@ ghciWelcomeMsg = "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++ "\\____/\\/ /_/\\____/|_| Type :? for help.\n" +ghciShortWelcomeMsg = + "GHCi, version " ++ cProjectVersion ++ + ": http://www.haskell.org/ghc/ :? for help" + type Command = (String, String -> GHCi Bool, Bool, String -> IO [String]) cmdName (n,_,_,_) = n @@ -156,7 +154,7 @@ helpText = " :add ... add module(s) to the current target set\n" ++ " :browse [*] display the names defined by \n" ++ " :cd change directory to \n" ++ - " :cmd run the commands returned by ::IO String"++ + " :cmd run the commands returned by ::IO String\n" ++ " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ " :def define a command :\n" ++ " :edit edit file\n" ++ @@ -245,21 +243,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] @@ -351,28 +350,33 @@ 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 () + let msg = if dopt Opt_ShortGhciBanner dflags + then ghciShortWelcomeMsg + else ghciWelcomeMsg + when (verbosity dflags >= 1) $ io $ putStrLn msg + + -- 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." @@ -573,12 +577,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 @@ -605,12 +609,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) @@ -723,25 +735,47 @@ changeDirectory dir = do io (setCurrentDirectory dir) editFile :: String -> GHCi () -editFile str - | null str = do - -- find the name of the "topmost" file loaded - session <- getSession - graph0 <- io (GHC.getModuleGraph session) - graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0 - let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing) - case GHC.ml_hs_file (GHC.ms_location (last graph2)) of - Just file -> do_edit file - Nothing -> throwDyn (CmdLineError "unknown file name") - | otherwise = do_edit str - where - do_edit file = do - st <- getGHCiState - let cmd = editor st - when (null cmd) $ - throwDyn (CmdLineError "editor not set, use :set editor") - io $ system (cmd ++ ' ':file) - return () +editFile str = + do file <- if null str then chooseEditFile else return str + st <- getGHCiState + let cmd = editor st + when (null cmd) + $ throwDyn (CmdLineError "editor not set, use :set editor") + io $ system (cmd ++ ' ':file) + return () + +-- The user didn't specify a file so we pick one for them. +-- Our strategy is to pick the first module that failed to load, +-- or otherwise the first target. +-- +-- XXX: Can we figure out what happened if the depndecy analysis fails +-- (e.g., because the porgrammeer mistyped the name of a module)? +-- XXX: Can we figure out the location of an error to pass to the editor? +-- XXX: if we could figure out the list of errors that occured during the +-- last load/reaload, then we could start the editor focused on the first +-- of those. +chooseEditFile :: GHCi String +chooseEditFile = + do session <- getSession + let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x + + graph <- io (GHC.getModuleGraph session) + failed_graph <- filterM hasFailed graph + let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing + pick xs = case xs of + x : _ -> GHC.ml_hs_file (GHC.ms_location x) + _ -> Nothing + + case pick (order failed_graph) of + Just file -> return file + Nothing -> + do targets <- io (GHC.getTargets session) + case msum (map fromTarget targets) of + Just file -> return file + Nothing -> throwDyn (CmdLineError "No files to edit.") + + where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f + fromTarget _ = Nothing -- when would we get a module target? defineMacro :: String -> GHCi () defineMacro s = do @@ -846,17 +880,12 @@ checkModule m = do afterLoad (successIf (isJust result)) session reloadModule :: String -> GHCi () -reloadModule "" = do - io (revertCAFs) -- always revert CAFs on reload. - discardActiveBreakPoints - session <- getSession - doLoad session LoadAllTargets - return () reloadModule m = do io (revertCAFs) -- always revert CAFs on reload. discardActiveBreakPoints session <- getSession - doLoad session (LoadUpTo (GHC.mkModuleName m)) + doLoad session $ if null m then LoadAllTargets + else LoadUpTo (GHC.mkModuleName m) return () doLoad session howmuch = do @@ -1231,13 +1260,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 @@ -1455,6 +1488,10 @@ wantNameFromInterpretedModule noCanDo str and_then = do [] -> return () (n:_) -> do let modl = GHC.nameModule n + if not (GHC.isExternalName n) + then noCanDo n $ ppr n <> + text " is not defined in an interpreted module" + else do is_interpreted <- io (GHC.moduleIsInterpreted session modl) if not is_interpreted then noCanDo n $ text "module " <> ppr modl <> @@ -1562,7 +1599,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] @@ -1574,7 +1611,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] @@ -1777,7 +1814,7 @@ listModuleLine modl line = do -- start_bold/end_bold. listAround span do_highlight = do pwd <- getEnv "PWD" - contents <- BS.readFile (pwd unpackFS file) + contents <- BS.readFile (pwd `joinFileName` unpackFS file) let lines = BS.split '\n' contents these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $