X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=0bf37dc4005e408893fc4663c9dc5d34b22a9528;hb=8d180b0dd5b3796c96b162464b93ab1cacc3b789;hp=76a80b552af005a714ff84c511dfcb87e843d3f3;hpb=93e2d5bd8cc76fde85420c39aff50557ac62de97;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 76a80b5..0bf37dc 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -15,7 +15,8 @@ module InteractiveUI ( -- The GHC interface import qualified GHC -import GHC ( Session, verbosity, dopt, DynFlag(..), +import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..), + TargetId(..), mkModule, pprModule, Type, Module, SuccessFlag(..), TyThing(..), Name, LoadHowMuch(..), Phase, GhcException(..), showGhcException, @@ -30,6 +31,7 @@ import OccName( pprOccName ) import SrcLoc( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol ) -- Other random utilities +import Digraph ( flattenSCCs ) import BasicTypes ( failed, successIf ) import Panic ( panic, installSignalHandlers ) import Config @@ -37,7 +39,6 @@ import StaticFlags ( opt_IgnoreDotGhci ) import Linker ( showLinkerState ) import Util ( removeSpaces, handle, global, toArgs, looksLikeModuleName, prefixMatch, sortLe ) -import ErrUtils ( printErrorsAndWarnings ) #ifndef mingw32_HOST_OS import System.Posix @@ -107,7 +108,8 @@ builtin_commands = [ ("check", keepGoing checkModule), ("set", keepGoing setCmd), ("show", keepGoing showCmd), - ("tags", keepGoing createTagsFileCmd), + ("etags", keepGoing createETagsFileCmd), + ("ctags", keepGoing createCTagsFileCmd), ("type", keepGoing typeOfExpr), ("kind", keepGoing kindOfType), ("unset", keepGoing unsetOptions), @@ -145,7 +147,8 @@ helpText = " :show modules show the currently loaded modules\n" ++ " :show bindings show the current bindings made at the prompt\n" ++ "\n" ++ - " :tags -e|-c create tags file for Vi (-c) or Emacs (-e)\n" ++ + " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ + " :etags [] create tags file for Emacs (defauilt: \"TAGS\")\n" ++ " :type show the type of \n" ++ " :kind show the kind of \n" ++ " :undef undefine user-defined command :\n" ++ @@ -194,13 +197,6 @@ interactiveUI session srcs maybe_expr = do Readline.initialize #endif -#if defined(mingw32_HOST_OS) - -- 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. - -- - GHC.ConsoleHandler.flushConsole stdin -#endif startGHCi (runGHCi srcs maybe_expr) GHCiState{ progname = "", args = [], @@ -263,6 +259,18 @@ runGHCi paths maybe_expr = do case maybe_expr of Nothing -> +#if defined(mingw32_HOST_OS) + do + -- 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 () +#endif -- enter the interactive loop interactiveLoop is_tty show_prompt Just expr -> do @@ -382,6 +390,11 @@ readlineLoop = do runCommand :: String -> GHCi Bool runCommand c = ghciHandle handler (doCommand c) + where + doCommand (':' : command) = specialCommand command + doCommand stmt + = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms) + return False -- This version is for the GHC command-line option -e. The only difference -- from runCommand is that it catches the ExitException exception and @@ -392,6 +405,14 @@ runCommandEval c = ghciHandle handleEval (doCommand c) handleEval e = do showException e io (exitWith (ExitFailure 1)) + doCommand (':' : command) = specialCommand command + doCommand stmt + = do nms <- runStmt stmt + case nms of + Nothing -> io (exitWith (ExitFailure 1)) + -- 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 @@ -418,29 +439,26 @@ showException (DynException dyn) = showException other_exception = io (putStrLn ("*** Exception: " ++ show other_exception)) -doCommand (':' : command) = specialCommand command -doCommand stmt - = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms) - return False - -runStmt :: String -> GHCi [Name] +runStmt :: String -> GHCi (Maybe [Name]) runStmt stmt - | null (filter (not.isSpace) stmt) = return [] + | null (filter (not.isSpace) stmt) = return (Just []) | otherwise = do st <- getGHCiState session <- getSession result <- io $ withProgName (progname st) $ withArgs (args st) $ GHC.runStmt session stmt case result of - GHC.RunFailed -> return [] + GHC.RunFailed -> return Nothing GHC.RunException e -> throw e -- this is caught by runCommand(Eval) - GHC.RunOk names -> return names + GHC.RunOk names -> return (Just names) -- possibly print the type and revert CAFs after evaluating an expression -finishEvalExpr names +finishEvalExpr mb_names = do b <- isOptionSet ShowType session <- getSession - when b (mapM_ (showTypeOfName session) names) + case mb_names of + Nothing -> return () + Just names -> when b (mapM_ (showTypeOfName session) names) flushInterpBuffers io installSignalHandlers @@ -576,7 +594,7 @@ changeDirectory dir = do io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) - setContextAfterLoad [] + setContextAfterLoad session [] io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -658,7 +676,7 @@ checkModule :: String -> GHCi () checkModule m = do let modl = mkModule m session <- getSession - result <- io (GHC.checkModule session modl printErrorsAndWarnings) + result <- io (GHC.checkModule session modl) case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( @@ -687,19 +705,39 @@ reloadModule m = do afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. graph <- io (GHC.getModuleGraph session) - let mods = map GHC.ms_mod graph - mods' <- filterM (io . GHC.isLoaded session) mods - setContextAfterLoad mods' - modulesLoadedMsg ok mods' + graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph + setContextAfterLoad session graph' + modulesLoadedMsg ok (map GHC.ms_mod graph') -setContextAfterLoad [] = do - session <- getSession +setContextAfterLoad session [] = do io (GHC.setContext session [] [prelude_mod]) -setContextAfterLoad (m:_) = do - session <- getSession - b <- io (GHC.moduleIsInterpreted session m) - if b then io (GHC.setContext session [m] []) - else io (GHC.setContext session [] [m]) +setContextAfterLoad session ms = do + -- load a target if one is available, otherwise load the topmost module. + targets <- io (GHC.getTargets session) + case [ m | Just m <- map (findTarget ms) targets ] of + [] -> + let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in + load_this (last graph') + (m:_) -> + load_this m + where + findTarget ms t + = case filter (`matches` t) ms of + [] -> Nothing + (m:_) -> Just m + + summary `matches` Target (TargetModule m) _ + = GHC.ms_mod summary == m + summary `matches` Target (TargetFile f _) _ + | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' + summary `matches` target + = False + + load_this summary | m <- GHC.ms_mod summary = do + b <- io (GHC.moduleIsInterpreted session m) + if b then io (GHC.setContext session [m] []) + else io (GHC.setContext session [] [prelude_mod,m]) + modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi () modulesLoadedMsg ok mods = do @@ -744,10 +782,13 @@ shellEscape str = io (system str >> return False) ----------------------------------------------------------------------------- -- create tags file for currently loaded modules. -createTagsFileCmd :: String -> GHCi () -createTagsFileCmd "-c" = ghciCreateTagsFile CTags "tags" -createTagsFileCmd "-e" = ghciCreateTagsFile ETags "TAGS" -createTagsFileCmd _ = throwDyn (CmdLineError "syntax: :tags -c|-e") +createETagsFileCmd, createCTagsFileCmd :: String -> GHCi () + +createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags" +createCTagsFileCmd file = ghciCreateTagsFile CTags file + +createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS" +createETagsFileCmd file = ghciCreateTagsFile ETags file data TagsKind = ETags | CTags