Commit 46aed8a4 authored by Ian Lynagh's avatar Ian Lynagh

Use haskeline, rather than editline, for line editing in ghci

parent e213baf0
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
{-# 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
......
......@@ -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