From 46aed8a4a084add708bbd119d19905105d5f0d72 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Wed, 29 Apr 2009 00:58:38 +0000 Subject: [PATCH] Use haskeline, rather than editline, for line editing in ghci --- aclocal.m4 | 14 - compiler/ghc.cabal.in | 12 - configure.ac | 19 - ghc.mk | 10 +- {compiler/ghci => ghc}/GhciMonad.hs | 113 +++-- {compiler/ghci => ghc}/GhciTags.hs | 0 {compiler/ghci => ghc}/InteractiveUI.hs | 689 ++++++++++++------------------- ghc/ghc-bin.cabal.in | 16 +- ghc/ghc.mk | 20 +- packages | 6 +- 10 files changed, 383 insertions(+), 516 deletions(-) rename {compiler/ghci => ghc}/GhciMonad.hs (80%) rename {compiler/ghci => ghc}/GhciTags.hs (100%) rename {compiler/ghci => ghc}/InteractiveUI.hs (80%) diff --git a/aclocal.m4 b/aclocal.m4 index 5afe2d9..013f7ff 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -943,20 +943,6 @@ else fi])# FP_PROG_GHC_PKG -# FP_GHC_HAS_EDITLINE -# ------------------- -AC_DEFUN([FP_GHC_HAS_EDITLINE], -[AC_REQUIRE([FP_PROG_GHC_PKG]) -AC_CACHE_CHECK([whether ghc has editline package], [fp_cv_ghc_has_editline], -[if "${GhcPkgCmd-ghc-pkg}" --show-package editline >/dev/null 2>&1; then - fp_cv_ghc_has_editline=yes -else - fp_cv_ghc_has_editline=no - fi]) -AC_SUBST([GhcHasEditline], [`echo $fp_cv_ghc_has_editline | sed 'y/yesno/YESNO/'`]) -])# FP_GHC_HAS_EDITLINE - - # FP_GCC_EXTRA_FLAGS # ------------------ # Determine which extra flags we need to pass gcc when we invoke it diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 55f235a..9a181f8 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -31,11 +31,6 @@ Flag dynlibs Default: False Manual: True -Flag editline - Description: Use editline - Default: False - Manual: True - Flag ghci Description: Build GHCi support. Default: False @@ -83,10 +78,6 @@ Library else Build-Depends: unix - if flag(editline) - Build-Depends: editline - CPP-Options: -DUSE_EDITLINE - GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-orphans if flag(ghci) @@ -547,9 +538,6 @@ Library ByteCodeItbls ByteCodeLink Debugger - GhciMonad - GhciTags - InteractiveUI LibFFI Linker ObjLink diff --git a/configure.ac b/configure.ac index e2626a2..0650d46 100644 --- a/configure.ac +++ b/configure.ac @@ -708,25 +708,6 @@ if test "$WithGhc" != ""; then AC_SUBST(ghc_ge_609)dnl fi -# Check whether this GHC has editline installed -FP_GHC_HAS_EDITLINE - -# Dummy arguments to print help for --with-editline-* arguments. -# Those are actually passed to the editline package's configure script -# via the CONFIGURE_ARGS variable in mk/config.mk -AC_ARG_WITH(dummy-editline-includes, - [AC_HELP_STRING([--with-editline-includes], - [directory containing editline/editline.h or editline/readline.h])], - [], - []) - -AC_ARG_WITH(dummy-editline-libraries, - [AC_HELP_STRING([--with-editline-libraries], - [directory containing the editline library])], - [], - []) - - AC_PATH_PROGS(NHC,nhc nhc98) AC_PATH_PROG(HBC,hbc) diff --git a/ghc.mk b/ghc.mk index 15d0b35..c9b2809 100644 --- a/ghc.mk +++ b/ghc.mk @@ -308,7 +308,15 @@ PACKAGES += \ syb \ template-haskell \ base3-compat \ - Cabal + Cabal \ + mtl \ + utf8-string + +ifneq "$(Windows)" "YES" +PACKAGES += terminfo +endif + +PACKAGES += haskeline BOOT_PKGS = Cabal hpc extensible-exceptions diff --git a/compiler/ghci/GhciMonad.hs b/ghc/GhciMonad.hs similarity index 80% rename from compiler/ghci/GhciMonad.hs rename to ghc/GhciMonad.hs index d5e491b..341e94a 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-cse #-} +{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- @@ -15,17 +15,19 @@ module GhciMonad where import qualified GHC import Outputable hiding (printForUser, printForUserPartWay) +import qualified Pretty import qualified Outputable import Panic hiding (showException) import Util import DynFlags -import HscTypes +import HscTypes hiding (liftIO) import SrcLoc import Module import ObjLink import Linker import StaticFlags -import MonadUtils ( MonadIO, liftIO ) +import qualified MonadUtils +import qualified ErrUtils import Exception import Data.Maybe @@ -41,10 +43,16 @@ import System.IO import Control.Monad as Monad import GHC.Exts +import System.Console.Haskeline (CompletionFunc, InputT) +import qualified System.Console.Haskeline as Haskeline +import System.Console.Haskeline.Encoding +import Control.Monad.Trans as Trans +import qualified Data.ByteString as B + ----------------------------------------------------------------------------- -- GHCi monad -type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String]) +type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) data GHCiState = GHCiState { @@ -159,13 +167,27 @@ setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s liftGhc :: Ghc a -> GHCi a liftGhc m = GHCi $ \_ -> m -instance MonadIO GHCi where - liftIO m = liftGhc $ liftIO m +instance MonadUtils.MonadIO GHCi where + liftIO = liftGhc . MonadUtils.liftIO + +instance Trans.MonadIO Ghc where + liftIO = MonadUtils.liftIO instance GhcMonad GHCi where setSession s' = liftGhc $ setSession s' getSession = liftGhc $ getSession +instance GhcMonad (InputT GHCi) where + setSession = lift . setSession + getSession = lift getSession + +instance MonadUtils.MonadIO (InputT GHCi) where + liftIO = Trans.liftIO + +instance WarnLogMonad (InputT GHCi) where + setWarnings = lift . setWarnings + getWarnings = lift getWarnings + instance ExceptionMonad GHCi where gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r) gblock (GHCi m) = GHCi $ \r -> gblock (m r) @@ -175,33 +197,24 @@ instance WarnLogMonad GHCi where setWarnings warns = liftGhc $ setWarnings warns getWarnings = liftGhc $ getWarnings --- for convenience... -getPrelude :: GHCi Module -getPrelude = getGHCiState >>= return . prelude - -GLOBAL_VAR(saved_sess, no_saved_sess, Session) - -no_saved_sess :: Session -no_saved_sess = error "no saved_ses" - -saveSession :: GHCi () -saveSession = - liftGhc $ do - reifyGhc $ \s -> - writeIORef saved_sess s +instance MonadIO GHCi where + liftIO = io -splatSavedSession :: GHCi () -splatSavedSession = io (writeIORef saved_sess no_saved_sess) +instance Haskeline.MonadException GHCi where + catch = gcatch + block = gblock + unblock = gunblock --- restoreSession :: IO Session --- restoreSession = readIORef saved_sess +instance ExceptionMonad (InputT GHCi) where + gcatch = Haskeline.catch + gblock = Haskeline.block + gunblock = Haskeline.unblock -withRestoredSession :: Ghc a -> IO a -withRestoredSession ghc = do - s <- readIORef saved_sess - reflectGhc ghc s +-- for convenience... +getPrelude :: GHCi Module +getPrelude = getGHCiState >>= return . prelude -getDynFlags :: GHCi DynFlags +getDynFlags :: GhcMonad m => m DynFlags getDynFlags = do GHC.getSessionDynFlags @@ -225,18 +238,44 @@ unsetOption opt setGHCiState (st{ options = filter (/= opt) (options st) }) io :: IO a -> GHCi a -io = liftIO +io = MonadUtils.liftIO printForUser :: SDoc -> GHCi () printForUser doc = do unqual <- GHC.getPrintUnqual io $ Outputable.printForUser stdout unqual doc +printForUser' :: SDoc -> InputT GHCi () +printForUser' doc = do + unqual <- GHC.getPrintUnqual + Haskeline.outputStrLn $ showSDocForUser unqual doc + printForUserPartWay :: SDoc -> GHCi () printForUserPartWay doc = do unqual <- GHC.getPrintUnqual io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc +-- We set log_action to write encoded output. +-- This fails whenever GHC tries to mention an (already encoded) filename, +-- but I don't know how to work around that. +setLogAction :: InputT GHCi () +setLogAction = do + encoder <- getEncoder + dflags <- GHC.getSessionDynFlags + GHC.setSessionDynFlags dflags {log_action = logAction encoder} + return () + where + logAction encoder severity srcSpan style msg = case severity of + GHC.SevInfo -> printEncErrs encoder (msg style) + GHC.SevFatal -> printEncErrs encoder (msg style) + _ -> do + hPutChar stderr '\n' + printEncErrs encoder (ErrUtils.mkLocMessage srcSpan msg style) + printEncErrs encoder doc = do + str <- encoder (Pretty.showDocWith Pretty.PageMode doc) + B.hPutStrLn stderr str + hFlush stderr + runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult runStmt expr step = do st <- getGHCiState @@ -254,17 +293,17 @@ resume canLogSpan step = GHC.resume canLogSpan step -- -------------------------------------------------------------------------- -- timing & statistics -timeIt :: GHCi a -> GHCi a +timeIt :: InputT GHCi a -> InputT GHCi a timeIt action - = do b <- isOptionSet ShowTiming + = do b <- lift $ isOptionSet ShowTiming if not b then action - else do allocs1 <- io $ getAllocations - time1 <- io $ getCPUTime + else do allocs1 <- liftIO $ getAllocations + time1 <- liftIO $ getCPUTime a <- action - allocs2 <- io $ getAllocations - time2 <- io $ getCPUTime - io $ printTimes (fromIntegral (allocs2 - allocs1)) + allocs2 <- liftIO $ getAllocations + time2 <- liftIO $ getCPUTime + liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) (time2 - time1) return a diff --git a/compiler/ghci/GhciTags.hs b/ghc/GhciTags.hs similarity index 100% rename from compiler/ghci/GhciTags.hs rename to ghc/GhciTags.hs diff --git a/compiler/ghci/InteractiveUI.hs b/ghc/InteractiveUI.hs similarity index 80% rename from compiler/ghci/InteractiveUI.hs rename to ghc/InteractiveUI.hs index e0c49ce..4aa441e 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -29,13 +29,10 @@ import PprTyThing import DynFlags import Packages -#ifdef USE_EDITLINE import PackageConfig import UniqFM -#endif -import HscTypes ( implicitTyThings, reflectGhc, reifyGhc - , handleFlagWarnings ) +import HscTypes ( implicitTyThings, handleFlagWarnings ) import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import Outputable hiding (printForUser, printForUserPartWay) import Module -- for ModuleEnv @@ -55,23 +52,22 @@ import NameSet import Maybes ( orElse, expectJust ) import FastString import Encoding -import MonadUtils ( liftIO ) #ifndef mingw32_HOST_OS import System.Posix hiding (getEnv) #else -import GHC.ConsoleHandler ( flushConsole ) import qualified System.Win32 #endif -#ifdef USE_EDITLINE -import Control.Concurrent ( yield ) -- Used in readline loop -import System.Console.Editline.Readline as Readline -#endif +import System.Console.Haskeline as Haskeline +import qualified System.Console.Haskeline.Encoding as Encoding +import Control.Monad.Trans --import SystemExts -import Exception +import Exception hiding (catch, block, unblock) +import qualified Exception + -- import Control.Concurrent import System.FilePath @@ -89,7 +85,6 @@ import Data.Array import Control.Monad as Monad import Text.Printf import Foreign -import Foreign.C import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) import GHC.TopHandler @@ -103,55 +98,55 @@ ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ ": http://www.haskell.org/ghc/ :? for help" cmdName :: Command -> String -cmdName (n,_,_,_) = n +cmdName (n,_,_) = n GLOBAL_VAR(macros_ref, [], [Command]) builtin_commands :: [Command] builtin_commands = [ - -- Hugs users are accustomed to :e, so make sure it doesn't overlap - ("?", keepGoing help, Nothing, completeNone), - ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename), - ("abandon", keepGoing abandonCmd, Nothing, completeNone), - ("break", keepGoing breakCmd, Nothing, completeIdentifier), - ("back", keepGoing backCmd, Nothing, completeNone), - ("browse", keepGoing (browseCmd False), Nothing, completeModule), - ("browse!", keepGoing (browseCmd True), Nothing, completeModule), - ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename), - ("check", keepGoing checkModule, Nothing, completeHomeModule), - ("continue", keepGoing continueCmd, Nothing, completeNone), - ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier), - ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename), - ("def", keepGoing (defineMacro False), Nothing, completeIdentifier), - ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier), - ("delete", keepGoing deleteCmd, Nothing, completeNone), - ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename), - ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename), - ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename), - ("force", keepGoing forceCmd, Nothing, completeIdentifier), - ("forward", keepGoing forwardCmd, Nothing, completeNone), - ("help", keepGoing help, Nothing, completeNone), - ("history", keepGoing historyCmd, Nothing, completeNone), - ("info", keepGoing info, Nothing, completeIdentifier), - ("kind", keepGoing kindOfType, Nothing, completeIdentifier), - ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile), - ("list", keepGoing listCmd, Nothing, completeNone), - ("module", keepGoing setContext, Nothing, completeModule), - ("main", keepGoing runMain, Nothing, completeIdentifier), - ("print", keepGoing printCmd, Nothing, completeIdentifier), - ("quit", quit, Nothing, completeNone), - ("reload", keepGoing reloadModule, Nothing, completeNone), - ("run", keepGoing runRun, Nothing, completeIdentifier), - ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions), - ("show", keepGoing showCmd, Nothing, completeShowOptions), - ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier), - ("step", keepGoing stepCmd, Nothing, completeIdentifier), - ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier), - ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier), - ("type", keepGoing typeOfExpr, Nothing, completeIdentifier), - ("trace", keepGoing traceCmd, Nothing, completeIdentifier), - ("undef", keepGoing undefineMacro, Nothing, completeMacro), - ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions) + -- Hugs users are accustomed to :e, so make sure it doesn't overlap + ("?", keepGoing help, noCompletion), + ("add", keepGoingPaths addModule, completeFilename), + ("abandon", keepGoing abandonCmd, noCompletion), + ("break", keepGoing breakCmd, completeIdentifier), + ("back", keepGoing backCmd, noCompletion), + ("browse", keepGoing' (browseCmd False), completeModule), + ("browse!", keepGoing' (browseCmd True), completeModule), + ("cd", keepGoing' changeDirectory, completeFilename), + ("check", keepGoing' checkModule, completeHomeModule), + ("continue", keepGoing continueCmd, noCompletion), + ("cmd", keepGoing cmdCmd, completeExpression), + ("ctags", keepGoing createCTagsFileCmd, completeFilename), + ("def", keepGoing (defineMacro False), completeExpression), + ("def!", keepGoing (defineMacro True), completeExpression), + ("delete", keepGoing deleteCmd, noCompletion), + ("e", keepGoing editFile, completeFilename), + ("edit", keepGoing editFile, completeFilename), + ("etags", keepGoing createETagsFileCmd, completeFilename), + ("force", keepGoing forceCmd, completeExpression), + ("forward", keepGoing forwardCmd, noCompletion), + ("help", keepGoing help, noCompletion), + ("history", keepGoing historyCmd, noCompletion), + ("info", keepGoing' info, completeIdentifier), + ("kind", keepGoing' kindOfType, completeIdentifier), + ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), + ("list", keepGoing' listCmd, noCompletion), + ("module", keepGoing setContext, completeModule), + ("main", keepGoing runMain, completeFilename), + ("print", keepGoing printCmd, completeExpression), + ("quit", quit, noCompletion), + ("reload", keepGoing' reloadModule, noCompletion), + ("run", keepGoing runRun, completeFilename), + ("set", keepGoing setCmd, completeSetOptions), + ("show", keepGoing showCmd, completeShowOptions), + ("sprint", keepGoing sprintCmd, completeExpression), + ("step", keepGoing stepCmd, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), + ("type", keepGoing' typeOfExpr, completeExpression), + ("trace", keepGoing traceCmd, completeExpression), + ("undef", keepGoing undefineMacro, completeMacro), + ("unset", keepGoing unsetOptions, completeSetOptions) ] @@ -163,26 +158,26 @@ builtin_commands = [ -- -- NOTE: in order for us to override the default correctly, any custom entry -- must be a SUBSET of word_break_chars. -#ifdef USE_EDITLINE word_break_chars :: String word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" specials = "(),;[]`{}" spaces = " \t\n" in spaces ++ specials ++ symbols -#endif -flagWordBreakChars, filenameWordBreakChars :: String +flagWordBreakChars :: String flagWordBreakChars = " \t\n" -filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults -keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) -keepGoing a str = a str >> return False +keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) +keepGoing a str = keepGoing' (lift . a) str + +keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool +keepGoing' a str = a str >> return False -keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) +keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) keepGoingPaths a str = do case toArgs str of - Left err -> io (hPutStrLn stderr err) + Left err -> Encoding.encode err >>= liftIO . BS.hPutStrLn stderr Right args -> a args return False @@ -289,7 +284,7 @@ findEditor = do interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () -interactiveUI srcs maybe_exprs = withTerminalReset $ do +interactiveUI srcs maybe_exprs = do -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block -- on a blackhole, and become unreachable during GC. The GC will @@ -317,23 +312,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering -#ifdef USE_EDITLINE - is_tty <- hIsTerminalDevice stdin - when is_tty $ withReadline $ do - Readline.initialize - - withGhcAppData - (\dir -> Readline.readHistory (dir "ghci_history")) - (return True) - - Readline.setAttemptedCompletionFunction (Just completeWord) - --Readline.parseAndBind "set show-all-if-ambiguous 1" - - Readline.setBasicWordBreakCharacters word_break_chars - Readline.setCompleterWordBreakCharacters word_break_chars - Readline.setCompletionAppendCharacter Nothing -#endif - -- initial context is just the Prelude prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing GHC.setContext [] [prel_mod] @@ -358,14 +336,6 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do ghc_e = isJust maybe_exprs } -#ifdef USE_EDITLINE - liftIO $ do - Readline.stifleHistory 100 - withGhcAppData (\dir -> Readline.writeHistory (dir "ghci_history")) - (return True) - Readline.resetTerminal Nothing -#endif - return () withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a @@ -375,22 +345,6 @@ withGhcAppData right left = do Right dir -> right dir _ -> left --- libedit doesn't always restore the terminal settings correctly (as of at --- least 07/12/2008); see trac #2691. Work around this by manually resetting --- the terminal outselves. -withTerminalReset :: Ghc () -> Ghc () -#ifdef mingw32_HOST_OS -withTerminalReset = id -#else -withTerminalReset f = do - isTTY <- liftIO $ hIsTerminalDevice stdout - if not isTTY - then f - else gbracket (liftIO $ getTerminalAttributes stdOutput) - (\attrs -> liftIO $ setTerminalAttributes stdOutput attrs Immediately) - (const f) -#endif - runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do let @@ -418,7 +372,12 @@ runGHCi paths maybe_exprs = do either_hdl <- io $ IO.try (openFile file ReadMode) case either_hdl of Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False False) + -- NOTE: this assumes that runInputT won't affect the terminal; + -- can we assume this will always be the case? + -- This would be a good place for runFileInputT. + Right hdl -> runInputTWithPrefs defaultPrefs defaultSettings $ do + setLogAction + runCommands $ fileLoop hdl where getDirectory f = case takeDirectory f of "" -> "."; d -> d @@ -434,7 +393,11 @@ runGHCi paths maybe_exprs = do -- immediately rather than going on to evaluate the expression. when (not (null paths)) $ do ok <- ghciHandle (\e -> do showException e; return Failed) $ - loadModule paths + -- TODO: this is a hack. + runInputTWithPrefs defaultPrefs defaultSettings $ do + let (filePaths, phases) = unzip paths + filePaths' <- mapM (Encoding.decode . BS.pack) filePaths + loadModule (zip filePaths' phases) when (isJust maybe_exprs && failed ok) $ io (exitWith (ExitFailure 1)) @@ -447,19 +410,8 @@ runGHCi paths maybe_exprs = do case maybe_exprs of Nothing -> do -#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, - -- 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 + runGHCiInput $ runCommands $ haskelineLoop show_prompt Just exprs -> do -- just evaluate the expression we were given enqueueCommands exprs @@ -470,33 +422,29 @@ runGHCi paths maybe_exprs = do io $ withProgName (progname st) -- this used to be topHandlerFastExit, see #2228 $ topHandler e - runCommands' handle (return Nothing) + runInputTWithPrefs defaultPrefs defaultSettings $ do + setLogAction + runCommands' handle (return Nothing) -- and finally, exit io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." -interactiveLoop :: Bool -> Bool -> GHCi () -interactiveLoop is_tty show_prompt = - -- Ignore ^C exceptions caught here - ghciHandleGhcException (\e -> case e of - Interrupted -> do -#if defined(mingw32_HOST_OS) - io (putStrLn "") -#endif - interactiveLoop is_tty show_prompt - _other -> return ()) $ - - ghciUnblock $ do -- unblock necessary if we recursed from the - -- exception handler above. +runGHCiInput :: InputT GHCi a -> GHCi a +runGHCiInput f = do + histFile <- io $ withGhcAppData (\dir -> return (Just (dir "ghci_history"))) + (return Nothing) + let settings = setComplete ghciCompleteWord + $ defaultSettings {historyFile = histFile} + runInputT settings $ do + setLogAction + f - -- read commands from stdin -#ifdef USE_EDITLINE - if (is_tty) - then runCommands readlineLoop - else runCommands (fileLoop stdin show_prompt is_tty) -#else - runCommands (fileLoop stdin show_prompt is_tty) -#endif +-- TODO really bad name +haskelineLoop :: Bool -> InputT GHCi (Maybe String) +haskelineLoop show_prompt = do + prompt <- if show_prompt then lift mkPrompt else return "" + l <- getInputLine prompt + return l -- NOTE: We only read .ghci files if they are owned by the current user, @@ -531,48 +479,19 @@ checkPerms name = else return True #endif -fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String) -fileLoop hdl show_prompt is_tty = do - when show_prompt $ do - prompt <- mkPrompt - (io (putStr prompt)) - l <- io (IO.try (hGetLine hdl)) +fileLoop :: MonadIO m => Handle -> InputT m (Maybe String) +fileLoop hdl = do + l <- liftIO $ IO.try (BS.hGetLine hdl) case l of Left e | isEOFError e -> return Nothing | InvalidArgument <- etype -> return Nothing - | otherwise -> io (ioError e) + | otherwise -> liftIO $ ioError e where etype = ioeGetErrorType e -- treat InvalidArgument in the same way as EOF: -- this can happen if the user closed stdin, or -- perhaps did getContents which closes stdin at -- EOF. - Right l -> do - str <- io $ consoleInputToUnicode is_tty l - return (Just str) - -#ifdef mingw32_HOST_OS --- Convert the console input into Unicode according to the current code page. --- The Windows console stores Unicode characters directly, so this is a --- rather roundabout way of doing things... oh well. --- See #782, #1483, #1649 -consoleInputToUnicode :: Bool -> String -> IO String -consoleInputToUnicode is_tty str - | is_tty = do - cp <- System.Win32.getConsoleCP - System.Win32.stringToUnicode cp str - | otherwise = - decodeStringAsUTF8 str -#else --- for Unix, assume the input is in UTF-8 and decode it to a Unicode String. --- See #782. -consoleInputToUnicode :: Bool -> String -> IO String -consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str -#endif - -decodeStringAsUTF8 :: String -> IO String -decodeStringAsUTF8 str = - withCStringLen str $ \(cstr,len) -> - utf8DecodeString (castPtr cstr :: Ptr Word8) len + Right l -> fmap Just (Encoding.decode l) mkPrompt :: GHCi String mkPrompt = do @@ -617,34 +536,6 @@ mkPrompt = do return (showSDoc (f (prompt st))) -#ifdef USE_EDITLINE -readlineLoop :: GHCi (Maybe String) -readlineLoop = do - io yield - saveSession -- for use by completion - prompt <- mkPrompt - l <- io $ withReadline (readline prompt) - splatSavedSession - case l of - Nothing -> return Nothing - Just "" -> return (Just "") -- Don't put empty lines in the history - Just l -> do - io (addHistory l) - str <- io $ consoleInputToUnicode True l - return (Just str) - -withReadline :: IO a -> IO a -withReadline = bracket_ stopTimer startTimer - -- editline doesn't handle some of its system calls returning - -- EINTR, so our timer signal confuses it, hence we turn off - -- the timer signal when making calls to editline. (#2277) - -- If editline is ever fixed, we can remove this. - --- These come from the RTS -foreign import ccall unsafe startTimer :: IO () -foreign import ccall unsafe stopTimer :: IO () -#endif - queryQueue :: GHCi (Maybe String) queryQueue = do st <- getGHCiState @@ -653,21 +544,28 @@ queryQueue = do c:cs -> do setGHCiState st{ cmdqueue = cs } return (Just c) -runCommands :: GHCi (Maybe String) -> GHCi () +runCommands :: InputT GHCi (Maybe String) -> InputT GHCi () runCommands = runCommands' handler runCommands' :: (SomeException -> GHCi Bool) -- Exception handler - -> GHCi (Maybe String) -> GHCi () + -> InputT GHCi (Maybe String) -> InputT GHCi () runCommands' eh getCmd = do - mb_cmd <- noSpace queryQueue + b <- handleGhcException (\e -> case e of + Interrupted -> return False + _other -> liftIO (print e) >> return True) + (runOneCommand eh getCmd) + if b then return () else runCommands' eh getCmd + +runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) + -> InputT GHCi Bool +runOneCommand eh getCmd = do + mb_cmd <- noSpace (lift queryQueue) mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd - case mb_cmd of - Nothing -> return () - Just c -> do - b <- ghciHandle eh $ + case mb_cmd of + Nothing -> return True + Just c -> ghciHandle (lift . eh) $ handleSourceError printErrorAndKeepGoing (doCommand c) - if b then return () else runCommands' eh getCmd where printErrorAndKeepGoing err = do GHC.printExceptionAndWarnings err @@ -679,11 +577,11 @@ runCommands' eh getCmd = do ":{" -> multiLineCmd q c -> return (Just c) ) multiLineCmd q = do - st <- getGHCiState + st <- lift getGHCiState let p = prompt st - setGHCiState st{ prompt = "%s| " } + lift $ setGHCiState st{ prompt = "%s| " } mb_cmd <- collectCommand q "" - getGHCiState >>= \st->setGHCiState st{ prompt = p } + lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p } return mb_cmd -- we can't use removeSpaces for the sublines here, so -- multiline commands are somewhat more brittle against @@ -694,7 +592,7 @@ runCommands' eh getCmd = do -- opposed to its String representation, "\r") inside a -- ghci command, we replace any such with ' ' (argh:-( collectCommand q c = q >>= - maybe (io (ioError collectError)) + maybe (liftIO (ioError collectError)) (\l->if removeSpaces l == ":}" then return (Just $ removeSpaces c) else collectCommand q (c++map normSpace l)) @@ -703,7 +601,7 @@ runCommands' eh getCmd = do -- QUESTION: is userError the one to use here? collectError = userError "unterminated multiline command :{ .. :}" doCommand (':' : cmd) = specialCommand cmd - doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion + doCommand stmt = do timeIt $ lift $ runStmt stmt GHC.RunToCompletion return False enqueueCommands :: [String] -> GHCi () @@ -715,7 +613,7 @@ enqueueCommands cmds = do runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step | null (filter (not.isSpace) stmt) = return False - | ["import", mod] <- words stmt = keepGoing setContext ('+':mod) + | ["import", mod] <- words stmt = keepGoing' setContext ('+':mod) | otherwise = do result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result @@ -792,19 +690,19 @@ printTypeOfName n data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand -specialCommand :: String -> GHCi Bool -specialCommand ('!':str) = shellEscape (dropWhile isSpace str) +specialCommand :: String -> InputT GHCi Bool +specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str) specialCommand str = do let (cmd,rest) = break isSpace str - maybe_cmd <- lookupCommand cmd + maybe_cmd <- lift $ lookupCommand cmd case maybe_cmd of - GotCommand (_,f,_,_) -> f (dropWhile isSpace rest) + GotCommand (_,f,_) -> f (dropWhile isSpace rest) BadCommand -> - do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" + do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" ++ shortHelpText) return False NoLastCommand -> - do io $ hPutStr stdout ("there is no last command to perform\n" + do liftIO $ hPutStr stdout ("there is no last command to perform\n" ++ shortHelpText) return False @@ -829,7 +727,7 @@ lookupCommand' str = do -- look for exact match first, then the first prefix match return $ case [ c | c <- cmds, str == cmdName c ] of c:_ -> Just c - [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of + [] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of [] -> Nothing c:_ -> Just c @@ -870,7 +768,7 @@ noArgs _ _ = io $ putStrLn "This command takes no arguments" help :: String -> GHCi () help _ = io (putStr helpText) -info :: String -> GHCi () +info :: String -> InputT GHCi () info "" = ghcError (CmdLineError "syntax: ':i '") info s = handleSourceError GHC.printExceptionAndWarnings $ do { let names = words s @@ -883,10 +781,9 @@ info s = handleSourceError GHC.printExceptionAndWarnings $ do mb_stuffs <- mapM GHC.getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) unqual <- GHC.getPrintUnqual - liftIO $ - putStrLn (showSDocForUser unqual $ + outputStrLn $ showSDocForUser unqual $ vcat (intersperse (text "") $ - map (pprInfo pefas) filtered)) + map (pprInfo pefas) filtered) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data @@ -925,9 +822,9 @@ doWithArgs :: [String] -> String -> GHCi () doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++ show args ++ " (" ++ cmd ++ ")"] -addModule :: [FilePath] -> GHCi () +addModule :: [FilePath] -> InputT GHCi () addModule files = do - revertCAFs -- always revert CAFs on load/add. + lift revertCAFs -- always revert CAFs on load/add. files <- mapM expandPath files targets <- mapM (\m -> GHC.guessTarget m Nothing) files -- remove old targets with the same id; e.g. for :add *M @@ -937,24 +834,24 @@ addModule files = do ok <- trySuccess $ GHC.load LoadAllTargets afterLoad ok False prev_context -changeDirectory :: String -> GHCi () +changeDirectory :: String -> InputT GHCi () changeDirectory "" = do -- :cd on its own changes to the user's home directory - either_dir <- io (IO.try getHomeDirectory) + either_dir <- liftIO $ IO.try getHomeDirectory case either_dir of Left _e -> return () Right dir -> changeDirectory dir changeDirectory dir = do graph <- GHC.getModuleGraph when (not (null graph)) $ - io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" + outputStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" prev_context <- GHC.getContext GHC.setTargets [] GHC.load LoadAllTargets - setContextAfterLoad prev_context False [] + lift $ setContextAfterLoad prev_context False [] GHC.workingDirectoryChanged dir <- expandPath dir - io (setCurrentDirectory dir) + liftIO $ setCurrentDirectory dir trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag trySuccess act = @@ -1030,7 +927,7 @@ defineMacro overwrite s = do handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do hv <- GHC.compileExpr new_expr io (writeIORef macros_ref -- - (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)])) + (filtered ++ [(macro_name, lift . runMacro hv, noCompletion)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do @@ -1060,23 +957,22 @@ cmdCmd str = do enqueueCommands (lines cmds) return () -loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag +loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag loadModule fs = timeIt (loadModule' fs) -loadModule_ :: [FilePath] -> GHCi () +loadModule_ :: [FilePath] -> InputT GHCi () loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () -loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag +loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag loadModule' files = do prev_context <- GHC.getContext -- unload first GHC.abandonAll - discardActiveBreakPoints + lift discardActiveBreakPoints GHC.setTargets [] GHC.load LoadAllTargets - -- expand tildes let (filenames, phases) = unzip files exp_filenames <- mapM expandPath filenames let files' = zip exp_filenames phases @@ -1090,13 +986,13 @@ loadModule' files = do GHC.setTargets targets doLoad False prev_context LoadAllTargets -checkModule :: String -> GHCi () +checkModule :: String -> InputT GHCi () checkModule m = do let modl = GHC.mkModuleName m prev_context <- GHC.getContext ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl - io $ putStrLn (showSDoc ( + outputStrLn (showSDoc ( case GHC.moduleInfo r of cm | Just scope <- GHC.modInfoTopLevelScope cm -> let @@ -1109,7 +1005,7 @@ checkModule m = do return True afterLoad (successIf ok) False prev_context -reloadModule :: String -> GHCi () +reloadModule :: String -> InputT GHCi () reloadModule m = do prev_context <- GHC.getContext doLoad True prev_context $ @@ -1117,25 +1013,25 @@ reloadModule m = do else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag +doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> InputT GHCi SuccessFlag doLoad retain_context prev_context howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. - discardActiveBreakPoints + lift discardActiveBreakPoints ok <- trySuccess $ GHC.load howmuch afterLoad ok retain_context prev_context return ok -afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> GHCi () +afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> InputT GHCi () afterLoad ok retain_context prev_context = do - revertCAFs -- always revert CAFs on load. - discardTickArrays + lift revertCAFs -- always revert CAFs on load. + lift discardTickArrays loaded_mod_summaries <- getLoadedModules let loaded_mods = map GHC.ms_mod loaded_mod_summaries loaded_mod_names = map GHC.moduleName loaded_mods modulesLoadedMsg ok loaded_mod_names - setContextAfterLoad prev_context retain_context loaded_mod_summaries + lift $ setContextAfterLoad prev_context retain_context loaded_mod_summaries setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi () @@ -1194,7 +1090,7 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId -modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi () +modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags when (verbosity dflags > 0) $ do @@ -1204,32 +1100,26 @@ modulesLoadedMsg ok mods = do punctuate comma (map ppr mods)) <> text "." case ok of Failed -> - io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) + outputStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)) Succeeded -> - io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))) + outputStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)) -typeOfExpr :: String -> GHCi () +typeOfExpr :: String -> InputT GHCi () typeOfExpr str = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do ty <- GHC.exprType str dflags <- getDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags - printForUser $ sep [utext str, nest 2 (dcolon <+> pprTypeForUser pefas ty)] + printForUser' $ sep [text str, nest 2 (dcolon <+> pprTypeForUser pefas ty)] -kindOfType :: String -> GHCi () +kindOfType :: String -> InputT GHCi () kindOfType str = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do ty <- GHC.typeKind str - printForUser $ utext str <+> dcolon <+> ppr ty - --- HACK for printing unicode text. We assume the output device --- understands UTF-8, and go via FastString which converts to UTF-8. --- ToDo: fix properly when we have encoding support in Handles. -utext :: String -> SDoc -utext str = ftext (mkFastString str) + printForUser' $ text str <+> dcolon <+> ppr ty -quit :: String -> GHCi Bool +quit :: String -> InputT GHCi Bool quit _ = return True shellEscape :: String -> GHCi Bool @@ -1238,14 +1128,14 @@ shellEscape str = io (system str >> return False) ----------------------------------------------------------------------------- -- Browsing a module's contents -browseCmd :: Bool -> String -> GHCi () +browseCmd :: Bool -> String -> InputT GHCi () browseCmd bang m = case words m of ['*':s] | looksLikeModuleName s -> do - m <- wantInterpretedModule s + m <- lift $ wantInterpretedModule s browseModule bang m False [s] | looksLikeModuleName s -> do - m <- lookupModule s + m <- lift $ lookupModule s browseModule bang m True [] -> do (as,bs) <- GHC.getContext @@ -1262,14 +1152,14 @@ browseCmd bang m = -- with bang, show class methods and data constructors separately, and -- indicate import modules, to aid qualifying unqualified names -- with sorted, sort items alphabetically -browseModule :: Bool -> Module -> Bool -> GHCi () +browseModule :: Bool -> Module -> Bool -> InputT GHCi () browseModule bang modl exports_only = do -- :browse! reports qualifiers wrt current context current_unqual <- GHC.getPrintUnqual -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified (as,bs) <- GHC.getContext - prel_mod <- getPrelude + prel_mod <- lift getPrelude if exports_only then GHC.setContext [] [prel_mod,modl] else GHC.setContext [modl] [] target_unqual <- GHC.getPrintUnqual @@ -1338,7 +1228,7 @@ browseModule bang modl exports_only = do let prettyThings = map (pretty pefas) things prettyThings' | bang = annotate $ zip modNames prettyThings | otherwise = prettyThings - io (putStrLn $ showSDocForUser unqual (vcat prettyThings')) + outputStrLn $ showSDocForUser unqual (vcat prettyThings') -- ToDo: modInfoInstances currently throws an exception for -- package modules. When it works, we can do this: -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) @@ -1622,7 +1512,7 @@ showModules = do let show_one ms = do m <- GHC.showModule ms; io (putStrLn m) mapM_ show_one loaded_mods -getLoadedModules :: GHCi [GHC.ModSummary] +getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary] getLoadedModules = do graph <- GHC.getModuleGraph filterM (GHC.isLoaded . GHC.ms_mod_name) graph @@ -1681,151 +1571,93 @@ showLanguages = do -- ----------------------------------------------------------------------------- -- Completion -completeNone :: String -> IO [String] -completeNone _w = return [] - -completeMacro, completeIdentifier, completeModule, +completeCmd, completeMacro, completeIdentifier, completeModule, completeHomeModule, completeSetOptions, completeShowOptions, - completeFilename, completeHomeModuleOrFile - :: String -> IO [String] - -#ifdef USE_EDITLINE -completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) -completeWord w start end = do - line <- Readline.getLineBuffer - let line_words = words (dropWhile isSpace line) - case w of - ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w - _other - | ((':':c) : _) <- line_words -> do - completionVars <- lookupCompletionVars c - case completionVars of - (Nothing,complete) -> wrapCompleter complete w - (Just breakChars,complete) - -> let (n,w') = selectWord - (words' (`elem` breakChars) 0 line) - complete' w = do rets <- complete w - return (map (drop n) rets) - in wrapCompleter complete' w' - | ("import" : _) <- line_words -> - wrapCompleter completeModule w - | otherwise -> do - --printf "complete %s, start = %d, end = %d\n" w start end - wrapCompleter completeIdentifier w - where words' _ _ [] = [] - words' isBreak n str = let (w,r) = break isBreak str - (s,r') = span isBreak r - in (n,w):words' isBreak (n+length w+length s) r' - -- In a Haskell expression we want to parse 'a-b' as three words - -- where a compiler flag (e.g. -ddump-simpl) should - -- only be a single word. - selectWord [] = (0,w) - selectWord ((offset,x):xs) - | offset+length x >= start = (start-offset,take (end-offset) x) - | otherwise = selectWord xs - - lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars, - completeFilename) - lookupCompletionVars c = do - maybe_cmd <- lookupCommand' c - case maybe_cmd of - Just (_,_,ws,f) -> return (ws,f) - Nothing -> return (Just filenameWordBreakChars, - completeFilename) - - -completeCmd :: String -> IO [String] -completeCmd w = do - cmds <- readIORef macros_ref + completeHomeModuleOrFile, completeExpression + :: CompletionFunc GHCi + +ghciCompleteWord :: CompletionFunc GHCi +ghciCompleteWord line@(left,_) = case firstWord of + ':':cmd | null rest -> completeCmd line + | otherwise -> do + completion <- lookupCompletion cmd + completion line + "import" -> completeModule line + _ -> completeExpression line + where + (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left + lookupCompletion ('!':_) = return completeFilename + lookupCompletion c = do + maybe_cmd <- liftIO $ lookupCommand' c + case maybe_cmd of + Just (_,_,f) -> return f + Nothing -> return completeFilename + +completeCmd = wrapCompleter " " $ \w -> do + cmds <- liftIO $ readIORef macros_ref return (filter (w `isPrefixOf`) (map (':':) (map cmdName (builtin_commands ++ cmds)))) -completeMacro w = do - cmds <- readIORef macros_ref +completeMacro = wrapIdentCompleter $ \w -> do + cmds <- liftIO $ readIORef macros_ref return (filter (w `isPrefixOf`) (map cmdName cmds)) -completeIdentifier w = do - rdrs <- withRestoredSession GHC.getRdrNamesInScope +completeIdentifier = wrapIdentCompleter $ \w -> do + rdrs <- GHC.getRdrNamesInScope return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs)) -completeModule w = do - dflags <- withRestoredSession GHC.getSessionDynFlags +completeModule = wrapIdentCompleter $ \w -> do + dflags <- GHC.getSessionDynFlags let pkg_mods = allExposedModules dflags - return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods)) + loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules + return $ filter (w `isPrefixOf`) + $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods + +completeHomeModule = wrapIdentCompleter listHomeModules -completeHomeModule w = do - g <- withRestoredSession GHC.getModuleGraph - let home_mods = map GHC.ms_mod_name g - return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods)) +listHomeModules :: String -> GHCi [String] +listHomeModules w = do + g <- GHC.getModuleGraph + let home_mods = map GHC.ms_mod_name g + return $ sort $ filter (w `isPrefixOf`) + $ map (showSDoc.ppr) home_mods -completeSetOptions w = do +completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) options) where options = "args":"prog":"prompt":"editor":"stop":flagList flagList = map head $ group $ sort allFlags -completeShowOptions w = do +completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) options) where options = ["args", "prog", "prompt", "editor", "stop", "modules", "bindings", "linker", "breaks", "context", "packages", "languages"] -completeFilename w = do - ws <- Readline.filenameCompletionFunction w - case ws of - -- If we only found one result, and it's a directory, - -- add a trailing slash. - [file] -> do - isDir <- expandPathIO file >>= doesDirectoryExist - if isDir && last file /= '/' - then return [file ++ "/"] - else return [file] - _ -> return ws - - -completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename - -unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String] -unionComplete f1 f2 w = do - s1 <- f1 w - s2 <- f2 w - return (s1 ++ s2) - -wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String])) -wrapCompleter fun w = do - strs <- fun w - case strs of - [] -> Readline.setAttemptedCompletionOver True >> return Nothing - [x] -> -- Add a trailing space, unless it already has an appended slash. - let appended = if last x == '/' then x else x ++ " " - in return (Just (appended,[])) - xs -> case getCommonPrefix xs of - "" -> return (Just ("",xs)) - pref -> return (Just (pref,xs)) - -getCommonPrefix :: [String] -> String -getCommonPrefix [] = "" -getCommonPrefix (s:ss) = foldl common s ss - where common _s "" = "" - common "" _s = "" - common (c:cs) (d:ds) - | c == d = c : common cs ds - | otherwise = "" +completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars + $ unionComplete (fmap (map simpleCompletion) . listHomeModules) + listFiles + +unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b] +unionComplete f1 f2 line = do + cs1 <- f1 line + cs2 <- f2 line + return (cs1 ++ cs2) + +wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi +wrapCompleter breakChars fun = completeWord Nothing breakChars + $ fmap (map simpleCompletion) . fmap sort . fun + +wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi +wrapIdentCompleter = wrapCompleter word_break_chars allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) where pkg_db = pkgIdMap (pkgState dflags) -#else -completeMacro = completeNone -completeIdentifier = completeNone -completeModule = completeNone -completeHomeModule = completeNone -completeSetOptions = completeNone -completeShowOptions = completeNone -completeFilename = completeNone -completeHomeModuleOrFile=completeNone -#endif + +completeExpression = completeQuotedWord (Just '\\') "\"" listFiles + completeIdentifier -- --------------------------------------------------------------------------- -- User code exception handling @@ -1865,15 +1697,8 @@ showException se = -- 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 :: (SomeException -> GHCi a) -> GHCi a -> GHCi a -ghciHandle h (GHCi m) = GHCi $ \s -> - gcatch (m s) - (\e -> unGHCi (ghciUnblock (h e)) s) - -ghciUnblock :: GHCi a -> GHCi a -ghciUnblock (GHCi a) = - GHCi $ \s -> reifyGhc $ \gs -> - Exception.unblock (reflectGhc (a s) gs) +ghciHandle :: MonadException m => (SomeException -> m a) -> m a -> m a +ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e) ghciTry :: GHCi a -> GHCi (Either SomeException a) ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) @@ -1881,8 +1706,13 @@ ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) -- ---------------------------------------------------------------------------- -- Utils -expandPath :: String -> GHCi String -expandPath path = io (expandPathIO path) +-- TODO: won't work if home dir is encoded. +-- (changeDirectory may not work either in that case.) +expandPath :: MonadIO m => String -> InputT m String +expandPath path = do + exp_path <- liftIO $ expandPathIO path + enc <- fmap BS.unpack $ Encoding.encode exp_path + return enc expandPathIO :: String -> IO String expandPathIO path = @@ -1893,7 +1723,7 @@ expandPathIO path = other -> return other -wantInterpretedModule :: String -> GHCi Module +wantInterpretedModule :: GHC.GhcMonad m => String -> m Module wantInterpretedModule str = do modl <- lookupModule str dflags <- getDynFlags @@ -1904,9 +1734,11 @@ wantInterpretedModule str = do ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) return modl -wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String - -> (Name -> GHCi ()) - -> GHCi () +wantNameFromInterpretedModule :: GHC.GhcMonad m + => (Name -> SDoc -> m ()) + -> String + -> (Name -> m ()) + -> m () wantNameFromInterpretedModule noCanDo str and_then = handleSourceError (GHC.printExceptionAndWarnings) $ do names <- GHC.parseName str @@ -2197,14 +2029,14 @@ start_bold = "\ESC[1m" end_bold :: String end_bold = "\ESC[0m" -listCmd :: String -> GHCi () +listCmd :: String -> InputT GHCi () listCmd "" = do - mb_span <- getCurrentBreakSpan + mb_span <- lift getCurrentBreakSpan case mb_span of Nothing -> - printForUser $ text "Not stopped at a breakpoint; nothing to list" + printForUser' $ text "Not stopped at a breakpoint; nothing to list" Just span - | GHC.isGoodSrcSpan span -> io $ listAround span True + | GHC.isGoodSrcSpan span -> listAround span True | otherwise -> do resumes <- GHC.getResumeContext case resumes of @@ -2214,16 +2046,16 @@ listCmd "" = do [] -> text "rerunning with :trace," _ -> empty doWhat = traceIt <+> text ":back then :list" - printForUser (text "Unable to list source for" <+> + printForUser' (text "Unable to list source for" <+> ppr span $$ text "Try" <+> doWhat) listCmd str = list2 (words str) -list2 :: [String] -> GHCi () +list2 :: [String] -> InputT GHCi () list2 [arg] | all isDigit arg = do (toplevel, _) <- GHC.getContext case toplevel of - [] -> io $ putStrLn "No module to list" + [] -> outputStrLn "No module to list" (mod : _) -> listModuleLine mod (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do mod <- wantInterpretedModule arg1 @@ -2234,23 +2066,23 @@ list2 [arg] = do if GHC.isGoodSrcLoc loc then do tickArray <- ASSERT( isExternalName name ) - getTickArray (GHC.nameModule name) + lift $ getTickArray (GHC.nameModule name) let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc)) (GHC.srcLocLine loc, GHC.srcLocCol loc) tickArray case mb_span of - Nothing -> io $ listAround (GHC.srcLocSpan loc) False - Just (_,span) -> io $ listAround span False + Nothing -> listAround (GHC.srcLocSpan loc) False + Just (_,span) -> listAround span False else noCanDo name $ text "can't find its location: " <> ppr loc where - noCanDo n why = printForUser $ + noCanDo n why = printForUser' $ text "cannot list source code for " <> ppr n <> text ": " <> why list2 _other = - io $ putStrLn "syntax: :list [ | | ]" + outputStrLn "syntax: :list [ | | ]" -listModuleLine :: Module -> Int -> GHCi () +listModuleLine :: Module -> Int -> InputT GHCi () listModuleLine modl line = do graph <- GHC.getModuleGraph let this = filter ((== modl) . GHC.ms_mod) graph @@ -2259,14 +2091,20 @@ listModuleLine modl line = do summ:_ -> do let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ)) loc = GHC.mkSrcLoc (mkFastString (filename)) line 0 - io $ listAround (GHC.srcLocSpan loc) False + listAround (GHC.srcLocSpan loc) False -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using -- start_bold\/end_bold. -listAround :: SrcSpan -> Bool -> IO () + +-- GHC files are UTF-8, so we can implement this by: +-- 1) read the file in as a BS and syntax highlight it as before +-- 2) convert the BS to String using utf-string, and write it out. +-- It would be better if we could convert directly between UTF-8 and the +-- console encoding, of course. +listAround :: MonadIO m => SrcSpan -> Bool -> InputT m () listAround span do_highlight = do - contents <- BS.readFile (unpackFS file) + contents <- liftIO $ BS.readFile (unpackFS file) let lines = BS.split '\n' contents these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ @@ -2280,7 +2118,10 @@ listAround span do_highlight = do bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] prefixed = zipWith ($) highlighted bs_line_nos -- - BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed) + let output = BS.intercalate (BS.pack "\n") prefixed + utf8Decoded <- liftIO $ BS.useAsCStringLen output + $ \(p,n) -> utf8DecodeString (castPtr p) n + outputStrLn utf8Decoded where file = GHC.srcSpanFile span line1 = GHC.srcSpanStartLine span @@ -2354,7 +2195,7 @@ mkTickArray ticks srcSpanLines span = [ GHC.srcSpanStartLine span .. GHC.srcSpanEndLine span ] -lookupModule :: String -> GHCi Module +lookupModule :: GHC.GhcMonad m => String -> m Module lookupModule modName = GHC.lookupModule (GHC.mkModuleName modName) Nothing diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 3374edf..df3b515 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -28,15 +28,29 @@ Executable ghc Main-Is: Main.hs if flag(base3) Build-Depends: base >= 3 && < 5, - directory >= 1 && < 1.1 + array >= 0.1 && < 0.3, + bytestring >= 0.9 && < 0.10, + directory >= 1 && < 1.1, + process >= 1 && < 1.1 else Build-Depends: base < 3 Build-Depends: base, ghc Build-Depends: filepath >= 1 && < 1.2 + if os(windows) + Build-Depends: Win32 + else + Build-Depends: unix GHC-Options: -Wall if flag(ghci) CPP-Options: -DGHCI + GHC-Options: -fno-warn-name-shadowing + Other-Modules: InteractiveUI, GhciMonad, GhciTags + Build-Depends: mtl, haskeline + Extensions: ForeignFunctionInterface, + UnboxedTuples, + FlexibleInstances, + MagicHash Extensions: CPP, PatternGuards diff --git a/ghc/ghc.mk b/ghc/ghc.mk index ccd4c5d..3a3edec 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -41,8 +41,8 @@ endif ghc_stage1_MODULES = Main -ghc_stage2_MODULES = $(ghc_stage1_MODULES) -ghc_stage3_MODULES = $(ghc_stage1_MODULES) +ghc_stage2_MODULES = $(ghc_stage1_MODULES) GhciMonad GhciTags InteractiveUI +ghc_stage3_MODULES = $(ghc_stage2_MODULES) ghc_stage1_PROG = ghc-stage1$(exeext) ghc_stage2_PROG = ghc-stage2$(exeext) @@ -53,10 +53,18 @@ ghc_stage1_USE_BOOT_LIBS = YES ghc_stage1_HC_OPTS += -package $(compiler_PACKAGE)-$(compiler_stage1_VERSION) ghc_stage2_HC_OPTS += -package $(compiler_PACKAGE)-$(compiler_stage2_VERSION) ghc_stage3_HC_OPTS += -package $(compiler_PACKAGE)-$(compiler_stage3_VERSION) - -ghc_stage1_HC_OPTS += -XCPP -XPatternGuards -ghc_stage2_HC_OPTS += -XCPP -XPatternGuards -ghc_stage3_HC_OPTS += -XCPP -XPatternGuards +ghc_stage2_HC_OPTS += -package haskeline +ghc_stage3_HC_OPTS += -package haskeline + +ghc_language_extension_flags = -XCPP \ + -XPatternGuards \ + -XForeignFunctionInterface \ + -XUnboxedTuples \ + -XFlexibleInstances \ + -XMagicHash +ghc_stage1_HC_OPTS += $(ghc_language_extension_flags) +ghc_stage2_HC_OPTS += $(ghc_language_extension_flags) +ghc_stage3_HC_OPTS += $(ghc_language_extension_flags) # In stage1 we might not benefit from cross-package dependencies and # recompilation checking. We must force recompilation here, otherwise diff --git a/packages b/packages index 05376cb..9bb5b9a 100644 --- a/packages +++ b/packages @@ -26,13 +26,14 @@ libraries/bytestring packages/bytestring darcs libraries/Cabal packages/Cabal darcs libraries/containers packages/containers darcs libraries/directory packages/directory darcs -libraries/editline packages/editline darcs libraries/extensible-exceptions packages/extensible-exceptions darcs libraries/filepath packages/filepath darcs libraries/ghc-prim packages/ghc-prim darcs +libraries/haskeline packages/haskeline darcs libraries/haskell98 packages/haskell98 darcs libraries/hpc packages/hpc darcs libraries/integer-gmp packages/integer-gmp darcs +libraries/mtl packages/mtl darcs libraries/old-locale packages/old-locale darcs libraries/old-time packages/old-time darcs libraries/packedstring packages/packedstring darcs @@ -41,13 +42,14 @@ libraries/process packages/process darcs libraries/random packages/random darcs libraries/syb packages/syb darcs libraries/template-haskell packages/template-haskell darcs +libraries/terminfo packages/terminfo darcs libraries/unix packages/unix darcs +libraries/utf8-string packages/utf8-string darcs libraries/Win32 packages/Win32 darcs libraries/HUnit extralibs packages/HUnit darcs libraries/QuickCheck extralibs packages/QuickCheck darcs libraries/haskell-src extralibs packages/haskell-src darcs libraries/html extralibs packages/html darcs -libraries/mtl extralibs packages/mtl darcs libraries/network extralibs packages/network darcs libraries/parsec extralibs packages/parsec darcs libraries/parallel extralibs packages/parallel darcs -- 1.7.10.4