X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=f1e47cb5046130d6914eff86a24be7f8609f2362;hb=526a19e90100eadb36185f3bd2c6ac263b7d25ad;hp=8a20fb1b991d1075813b7052beb490057f48a529;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 8a20fb1..f1e47cb 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -3,7 +3,7 @@ -- -- GHC Interactive User Interface -- --- (c) The GHC Team 2005 +-- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- module InteractiveUI ( @@ -17,47 +17,40 @@ module InteractiveUI ( import GHC.Exts ( Int(..), Ptr(..), int2Addr# ) import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr ) import System.IO.Unsafe ( unsafePerformIO ) -import Var ( Id, globaliseId, idName, idType ) -import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..) - , extendTypeEnvWithIds ) -import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv ) -import NameEnv ( delListFromNameEnv ) -import TcType ( tidyTopType ) -import qualified Id ( setIdType ) -import IdInfo ( GlobalIdDetails(..) ) -import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker ) -import PrelNames ( breakpointJumpName, breakpointCondJumpName ) +import Var +import HscTypes +import RdrName +import NameEnv +import TcType +import qualified Id +import IdInfo +import PrelNames #endif -- The GHC interface import qualified GHC -import GHC ( Session, dopt, DynFlag(..), Target(..), - TargetId(..), DynFlags(..), - pprModule, Type, Module, ModuleName, SuccessFlag(..), - TyThing(..), Name, LoadHowMuch(..), Phase, - GhcException(..), showGhcException, - CheckedModule(..), SrcLoc ) -import DynFlags ( allFlags ) -import Packages ( PackageState(..) ) -import PackageConfig ( InstalledPackageInfo(..) ) -import UniqFM ( eltsUFM ) +import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), + Type, Module, ModuleName, TyThing(..), Phase ) +import DynFlags +import Packages +import PackageConfig +import UniqFM import PprTyThing import Outputable --- for createtags (should these come via GHC?) -import Name ( nameSrcLoc, nameModule, nameOccName ) -import OccName ( pprOccName ) -import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol ) +-- for createtags +import Name +import OccName +import SrcLoc -- Other random utilities -import Digraph ( flattenSCCs ) -import BasicTypes ( failed, successIf ) -import Panic ( panic, installSignalHandlers ) +import Digraph +import BasicTypes +import Panic hiding (showException) import Config -import StaticFlags ( opt_IgnoreDotGhci ) -import Linker ( showLinkerState ) -import Util ( removeSpaces, handle, global, toArgs, - looksLikeModuleName, prefixMatch, sortLe ) +import StaticFlags +import Linker +import Util #ifndef mingw32_HOST_OS import System.Posix @@ -67,6 +60,7 @@ import System.Posix #else import GHC.ConsoleHandler ( flushConsole ) import System.Win32 ( setConsoleCP, setConsoleOutputCP ) +import qualified System.Win32 #endif #ifdef USE_READLINE @@ -83,7 +77,7 @@ import Data.Dynamic import Numeric import Data.List import Data.Int ( Int64 ) -import Data.Maybe ( isJust, fromMaybe, catMaybes ) +import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes ) import System.Cmd import System.CPUTime import System.Environment @@ -122,6 +116,9 @@ builtin_commands = [ ("browse", keepGoing browseCmd, False, completeModule), ("cd", keepGoing changeDirectory, False, completeFilename), ("def", keepGoing defineMacro, False, completeIdentifier), + ("e", keepGoing editFile, False, completeFilename), + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("edit", keepGoing editFile, False, completeFilename), ("help", keepGoing help, False, completeNone), ("?", keepGoing help, False, completeNone), ("info", keepGoing info, False, completeIdentifier), @@ -158,6 +155,8 @@ helpText = " :browse [*] display the names defined by \n" ++ " :cd change directory to \n" ++ " :def define a command :\n" ++ + " :edit edit file\n" ++ + " :edit edit last module\n" ++ " :help, :? display this list of commands\n" ++ " :info [ ...] display information about the given names\n" ++ " :load ... load module(s) and their dependents\n" ++ @@ -169,12 +168,13 @@ 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 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 [] create tags file for Vi (default: \"tags\")\n" ++ - " :etags [] create tags file for Emacs (defauilt: \"TAGS\")\n" ++ + " :etags [] create tags file for Emacs (default: \"TAGS\")\n" ++ " :type show the type of \n" ++ " :kind show the kind of \n" ++ " :undef undefine user-defined command :\n" ++ @@ -241,11 +241,13 @@ jumpFunction session@(Session ref) (I# idsPtr) hValues location b writeIORef ref (hsc_env { hsc_IC = new_ic }) is_tty <- hIsTerminalDevice stdin prel_mod <- GHC.findModule session prel_name Nothing + default_editor <- findEditor withExtendedLinkEnv (zip names hValues) $ startGHCi (interactiveLoop is_tty True) GHCiState{ progname = "", args = [], prompt = location++"> ", + editor = default_editor, session = session, options = [], prelude = prel_mod } @@ -254,6 +256,16 @@ jumpFunction session@(Session ref) (I# idsPtr) hValues location b return b #endif +findEditor = do + getEnv "EDITOR" + `IO.catch` \_ -> do +#if mingw32_HOST_OS + win <- System.Win32.getWindowsDirectory + return (win `joinFileName` "notepad.exe") +#else + return "" +#endif + interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () interactiveUI session srcs maybe_expr = do #if defined(GHCI) && defined(BREAKPOINT) @@ -273,15 +285,19 @@ interactiveUI session srcs maybe_expr = do newStablePtr stdout newStablePtr stderr - hFlush stdout - hSetBuffering stdout NoBuffering - -- 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 + hSetBuffering stdin NoBuffering -- initial context is just the Prelude prel_mod <- GHC.findModule session prel_name Nothing @@ -301,10 +317,13 @@ interactiveUI session srcs maybe_expr = do Readline.setCompleterWordBreakCharacters word_break_chars #endif + default_editor <- findEditor + startGHCi (runGHCi srcs maybe_expr) GHCiState{ progname = "", args = [], prompt = "%s> ", + editor = default_editor, session = session, options = [], prelude = prel_mod } @@ -485,8 +504,8 @@ mkPrompt toplevs exports prompt f (x:xs) = char x <> f xs f [] = empty - perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+> - hsep (map pprModule exports) + perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> + hsep (map (ppr . GHC.moduleName) exports) #ifdef USE_READLINE @@ -648,8 +667,6 @@ initInterpBuffering session Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) _ -> panic "interactiveUI:flush" - turnOffBuffering -- Turn it off right now - return () @@ -692,7 +709,8 @@ info s = do { let names = words s filterOutChildren :: [Name] -> [Name] filterOutChildren names = filter (not . parent_is_there) names where parent_is_there n - | Just p <- GHC.nameParent_maybe n = p `elem` names +-- | Just p <- GHC.nameParent_maybe n = p `elem` names +-- ToDo!! | otherwise = False pprInfo exts (thing, fixity, insts) @@ -736,6 +754,27 @@ changeDirectory dir = do dir <- expandPath dir 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 () + defineMacro :: String -> GHCi () defineMacro s = do let (macro_name, definition) = break isSpace s @@ -817,7 +856,7 @@ checkModule m = do case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( - case checkedModuleInfo r of + case GHC.checkedModuleInfo r of Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> let (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope @@ -1166,11 +1205,13 @@ setCmd "" else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) setCmd str - = case words str of + = case toArgs str of ("args":args) -> setArgs args ("prog":prog) -> setProg prog - ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str) + ("prompt":prompt) -> setPrompt (after 6) + ("editor":cmd) -> setEditor (after 6) wds -> setOptions wds + where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str setArgs args = do st <- getGHCiState @@ -1182,6 +1223,10 @@ setProg [prog] = do setProg _ = do io (hPutStrLn stderr "syntax: :set prog ") +setEditor cmd = do + st <- getGHCiState + setGHCiState st{ editor = cmd } + setPrompt value = do st <- getGHCiState if null value @@ -1198,21 +1243,28 @@ setOptions wds = -- then, dynamic flags dflags <- getDynFlags + let pkg_flags = packageFlags dflags (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts - setDynFlags dflags' - - -- update things if the users wants more packages -{- TODO: - let new_packages = pkgs_after \\ pkgs_before - when (not (null new_packages)) $ - newPackages new_packages --} if (not (null leftovers)) then throwDyn (CmdLineError ("unrecognised flags: " ++ unwords leftovers)) else return () + new_pkgs <- setDynFlags dflags' + + -- if the package flags changed, we should reset the context + -- and link the new packages. + dflags <- getDynFlags + when (packageFlags dflags /= pkg_flags) $ do + io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..." + session <- getSession + io (GHC.setTargets session []) + io (GHC.load session LoadAllTargets) + io (linkPackages dflags new_pkgs) + setContextAfterLoad session [] + return () + unsetOptions :: String -> GHCi () unsetOptions str @@ -1259,16 +1311,6 @@ optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" -{- ToDo -newPackages new_pkgs = do -- The new packages are already in v_Packages - session <- getSession - io (GHC.setTargets session []) - io (GHC.load session Nothing) - dflags <- getDynFlags - io (linkPackages dflags new_pkgs) - setContextAfterLoad [] --} - -- --------------------------------------------------------------------------- -- code for `:show' @@ -1431,6 +1473,7 @@ data GHCiState = GHCiState progname :: String, args :: [String], prompt :: String, + editor :: String, session :: GHC.Session, options :: [GHCiOption], prelude :: Module