Commit d69b5857 authored by judah's avatar judah
Browse files

Use the base package's IO encoding/decoding on ghc>=7.4.1.

This removes the dependency on the utf8-string package (except for ghc<7.4.1).
A few minor encoding/decoding corner cases were also fixed.
parent 13855621
{-# LANGUAGE CPP #-}
import Distribution.System
import Distribution.Verbosity
import Distribution.PackageDescription
......@@ -35,8 +36,27 @@ myHooks
libBuildInfo = bi'}}}
}
warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo")))
$ mapM_ putStrLn
[ "*** Warning: running on POSIX but not building the terminfo backend. ***"
, "You may need to install the terminfo package manually, e.g. with"
, "\"cabal install terminfo\"; or, use \"-fterminfo\" when configuring or"
, "installing this package."
,""
]
hasFlagSet :: ConfigFlags -> FlagName -> Bool
hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags)
-- Test whether compiling a c program that links against libiconv needs -liconv.
-- (Not needed for ghc>=7.4.1, even for the legacy POSIX backend, since
-- the base library always links against iconv .)
maybeSetLibiconv :: ConfigFlags -> BuildInfo -> LocalBuildInfo -> IO BuildInfo
#if __GLASGOW_HASKELL__ >= 704
maybeSetLibiconv _ bi _ = return bi
#else
maybeSetLibiconv flags bi lbi = do
let biWithIconv = addIconv bi
let verb = fromFlag (configVerbosity flags)
......@@ -60,9 +80,6 @@ maybeSetLibiconv flags bi lbi = do
return biWithIconv
else error "Unable to link against the iconv library."
hasFlagSet :: ConfigFlags -> FlagName -> Bool
hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags)
tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool
tryCompile program bi lbi verb = handle processExit $ handle processException $ do
tempDir <- getTemporaryDirectory
......@@ -105,12 +122,5 @@ iconv_prog = unlines $
, " return 0;"
, "}"
]
warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo")))
$ mapM_ putStrLn
[ "*** Warning: running on POSIX but not building the terminfo backend. ***"
, "You may need to install the terminfo package manually, e.g. with"
, "\"cabal install terminfo\"; or, use \"-fterminfo\" when configuring or"
, "installing this package."
,""
]
#endif
......@@ -268,6 +268,8 @@ and 'historyFile' flags.
-------
-- | Wrapper for input functions.
-- This is the function that calls "wrapFileInput" around file backend input
-- functions (see Term.hs).
promptedInput :: MonadIO m => (TermOps -> String -> InputT m a)
-> (FileOps -> IO a)
-> String -> InputT m a
......@@ -279,7 +281,7 @@ promptedInput doTerm doFile prompt = do
case termOps rterm of
Right fops -> liftIO $ do
putStrOut rterm prompt
doFile fops
wrapFileInput fops $ doFile fops
Left tops -> do
-- If the prompt contains newlines, print all but the last line.
let (lastLine,rest) = break (`elem` "\r\n") $ reverse prompt
......
module System.Console.Haskeline.Backend.DumbTerm where
import System.Console.Haskeline.Backend.Posix
import System.Console.Haskeline.Backend.Posix.Encoder (putEncodedStr)
import System.Console.Haskeline.Backend.WCWidth
import System.Console.Haskeline.Term
import System.Console.Haskeline.LineState
......@@ -22,7 +23,7 @@ initWindow = Window {pos=0}
newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a}
deriving (Monad, MonadIO, MonadException,
MonadState Window,
MonadReader Handles, MonadReader Encoders)
MonadReader Handles, MonadReader Encoder)
type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a
......@@ -47,8 +48,9 @@ instance (MonadException m, MonadReader Layout m) => Term (DumbTerm m) where
printText :: MonadIO m => String -> DumbTerm m ()
printText str = do
h <- liftM hOut ask
DumbTerm (lift $ posixEncode str) >>= liftIO . hPutStr h
h <- liftM ehOut ask
encode <- ask
liftIO $ putEncodedStr encode h str
liftIO $ hFlush h
-- Things we can assume a dumb terminal knows how to do
......
......@@ -3,10 +3,11 @@ module System.Console.Haskeline.Backend.Posix (
posixLayouts,
tryGetLayouts,
PosixT,
runPosixT,
Handles(..),
Encoders(),
posixEncode,
Handles(),
ehIn,
ehOut,
Encoder,
Decoder,
mapLines,
stdinTTYHandles,
ttyHandles,
......@@ -25,8 +26,6 @@ import System.Posix.Signals.Exts
import System.Posix.Types(Fd(..))
import Data.List
import System.IO
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import System.Environment
import System.Console.Haskeline.Monads
......@@ -34,7 +33,7 @@ import System.Console.Haskeline.Key
import System.Console.Haskeline.Term as Term
import System.Console.Haskeline.Prefs
import System.Console.Haskeline.Backend.IConv
import System.Console.Haskeline.Backend.Posix.Encoder
#if __GLASGOW_HASKELL__ >= 611
import GHC.IO.FD (fdFD)
......@@ -56,8 +55,12 @@ import GHC.Handle (withHandle_)
-----------------------------------------------
-- Input/output handles
data Handles = Handles {hIn, hOut :: Handle,
closeHandles :: IO ()}
data Handles = Handles {hIn, hOut :: ExternalHandle
, closeHandles :: IO ()}
ehIn, ehOut :: Handles -> Handle
ehIn = eH . hIn
ehOut = eH . hOut
-------------------
-- Window size
......@@ -65,7 +68,7 @@ data Handles = Handles {hIn, hOut :: Handle,
foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt
posixLayouts :: Handles -> [IO (Maybe Layout)]
posixLayouts h = [ioctlLayout $ hOut h, envLayout]
posixLayouts h = [ioctlLayout $ ehOut h, envLayout]
ioctlLayout :: Handle -> IO (Maybe Layout)
ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do
......@@ -110,7 +113,7 @@ tryGetLayouts (f:fs) = do
-- Key sequences
getKeySequences :: (MonadIO m, MonadReader Prefs m)
=> Handles -> [(String,Key)] -> m (TreeMap Char Key)
=> Handle -> [(String,Key)] -> m (TreeMap Char Key)
getKeySequences h tinfos = do
sttys <- liftIO $ sttyKeys h
customKeySeqs <- getCustomKeySeqs
......@@ -151,9 +154,9 @@ ansiKeys = [("\ESC[D", simpleKey LeftKey)
]
sttyKeys :: Handles -> IO [(String, Key)]
sttyKeys :: Handle -> IO [(String, Key)]
sttyKeys h = do
fd <- unsafeHandleToFD $ hIn h
fd <- unsafeHandleToFD h
attrs <- getTerminalAttributes (Fd fd)
let getStty (k,c) = do {str <- controlChar attrs k; return ([str],c)}
return $ catMaybes $ map getStty [(Erase,simpleKey Backspace),(Kill,simpleKey KillLine)]
......@@ -209,12 +212,12 @@ lookupChars (TreeMap tm) (c:cs) = case Map.lookup c tm of
-----------------------------
withPosixGetEvent :: (MonadException m, MonadReader Prefs m)
=> Chan Event -> Handles -> Encoders -> [(String,Key)]
=> Chan Event -> Handles -> Decoder -> [(String,Key)]
-> (m Event -> m a) -> m a
withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do
baseMap <- getKeySequences h termKeys
baseMap <- getKeySequences (ehIn h) termKeys
withWindowHandler eventChan
$ f $ liftIO $ getEvent h enc baseMap eventChan
$ f $ liftIO $ getEvent (ehIn h) enc baseMap eventChan
withWindowHandler :: MonadException m => Chan Event -> m a -> m a
withWindowHandler eventChan = withHandler windowChange $
......@@ -232,57 +235,11 @@ withHandler signal handler f = do
old_handler <- liftIO $ installHandler signal handler Nothing
f `finally` liftIO (installHandler signal old_handler Nothing)
getEvent :: Handles -> Encoders -> TreeMap Char Key -> Chan Event -> IO Event
getEvent Handles {hIn=h} enc baseMap = keyEventLoop readKeyEvents
where
bufferSize = 32
readKeyEvents = do
-- Read at least one character of input, and more if available.
-- In particular, the characters making up a control sequence will all
-- be available at once, so we can process them together with lexKeys.
blockUntilInput h
bs <- B.hGetNonBlocking h bufferSize
cs <- convert h (localeToUnicode enc) bs
getEvent :: Handle -> Decoder -> TreeMap Char Key -> Chan Event -> IO Event
getEvent h dec baseMap = keyEventLoop $ do
cs <- getBlockOfChars h dec
return [KeyInput $ lexKeys baseMap cs]
-- Different versions of ghc work better using different functions.
blockUntilInput :: Handle -> IO ()
#if __GLASGOW_HASKELL__ >= 611
-- threadWaitRead doesn't work with the new ghc IO library,
-- because it keeps a buffer even when NoBuffering is set.
blockUntilInput h = hWaitForInput h (-1) >> return ()
#else
-- hWaitForInput doesn't work with -threaded on ghc < 6.10
-- (#2363 in ghc's trac)
blockUntilInput h = unsafeHandleToFD h >>= threadWaitRead . Fd
#endif
-- try to convert to the locale encoding using iconv.
-- if the buffer has an incomplete shift sequence,
-- read another byte of input and try again.
convert :: Handle -> (B.ByteString -> IO (String,Result))
-> B.ByteString -> IO String
convert h decoder bs = do
(cs,result) <- decoder bs
case result of
Incomplete rest -> do
extra <- B.hGetNonBlocking h 1
if B.null extra
then return (cs ++ "?")
else fmap (cs ++)
$ convert h decoder (rest `B.append` extra)
Invalid rest -> fmap ((cs ++) . ('?':)) $ convert h decoder (B.drop 1 rest)
_ -> return cs
getMultiByteChar :: Handle -> (B.ByteString -> IO (String,Result))
-> MaybeT IO Char
getMultiByteChar h decoder = hWithBinaryMode h $ do
b <- hGetByte h
cs <- liftIO $ convert h decoder (B.pack [b])
case cs of
[] -> return '?' -- shouldn't happen, but doesn't hurt to be careful.
(c:_) -> return c
stdinTTYHandles, ttyHandles :: MaybeT IO Handles
stdinTTYHandles = do
......@@ -290,22 +247,28 @@ stdinTTYHandles = do
guard isInTerm
h <- openTerm WriteMode
-- Don't close stdin, since a different part of the program may use it later.
return Handles { hIn = stdin, hOut = h, closeHandles = hClose h }
return Handles
{ hIn = externalHandle stdin
, hOut = h
, closeHandles = hClose $ eH h
}
ttyHandles = do
-- Open the input and output separately, since they need different buffering.
-- Open the input and output as two separate Handles, since they need
-- different buffering.
h_in <- openTerm ReadMode
h_out <- openTerm WriteMode
return Handles { hIn = h_in, hOut = h_out,
closeHandles = hClose h_in >> hClose h_out }
return Handles
{ hIn = h_in
, hOut = h_out
, closeHandles = hClose (eH h_in) >> hClose (eH h_out)
}
openTerm :: IOMode -> MaybeT IO Handle
openTerm :: IOMode -> MaybeT IO ExternalHandle
openTerm mode = handle (\(_::IOException) -> mzero)
-- NB: we open the tty as a binary file since otherwise the terminfo
-- backend, which writes output as Chars, would double-encode on ghc-6.12.
$ liftIO $ openBinaryFile "/dev/tty" mode
$ liftIO $ openInCodingMode "/dev/tty" mode
-- To do the output, they can just call down to PosixT. Yeah!
posixRunTerm ::
Handles
-> [IO (Maybe Layout)]
......@@ -315,71 +278,66 @@ posixRunTerm ::
-> IO RunTerm
posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
ch <- newChan
codeset <- getCodeset
encoders <- liftM2 Encoders (openEncoder codeset)
(openPartialDecoder codeset)
fileRT <- fileRunTerm $ hIn hs
return fileRT {
closeTerm = closeTerm fileRT >> closeHandles hs,
-- NOTE: could also alloc Encoders once for each call to wrapRunTerm
termOps = Left TermOps {
getLayout = tryGetLayouts layoutGetters,
withGetEvent = wrapGetEvent
. withPosixGetEvent ch hs encoders
keys,
saveUnusedKeys = saveKeys ch,
evalTerm = mapEvalTerm
(runPosixT encoders hs) (lift . lift)
fileRT <- posixFileRunTerm hs
(enc,dec) <- newEncoders
return fileRT
{ closeTerm = closeTerm fileRT
, termOps = Left TermOps
{ getLayout = tryGetLayouts layoutGetters
, withGetEvent = wrapGetEvent
. withPosixGetEvent ch hs dec
keys
, saveUnusedKeys = saveKeys ch
, evalTerm = mapEvalTerm
(runPosixT enc hs)
(lift . lift)
evalBackend
}
}
}
type PosixT m = ReaderT Encoders (ReaderT Handles m)
data Encoders = Encoders {unicodeToLocale :: String -> IO B.ByteString,
localeToUnicode :: B.ByteString -> IO (String, Result)}
type PosixT m = ReaderT Encoder (ReaderT Handles m)
posixEncode :: MonadIO m => String -> PosixT m String
posixEncode str = do
encoder <- asks unicodeToLocale
liftM BC.unpack $ liftIO $ encoder str
runPosixT :: Monad m => Encoders -> Handles -> PosixT m a -> m a
runPosixT :: Monad m => Encoder -> Handles -> PosixT m a -> m a
runPosixT enc h = runReaderT' h . runReaderT' enc
putTerm :: Handle -> B.ByteString -> IO ()
putTerm h str = B.hPutStr h str >> hFlush h
fileRunTerm :: Handle -> IO RunTerm
fileRunTerm h_in = do
let h_out = stdout
oldLocale <- setLocale (Just "")
codeset <- getCodeset
let encoder str = join $ fmap ($ str) $ openEncoder codeset
let decoder str = join $ fmap ($ str) $ openDecoder codeset
decoder' <- openPartialDecoder codeset
return RunTerm {putStrOut = encoder >=> putTerm h_out,
closeTerm = setLocale oldLocale >> return (),
wrapInterrupt = withSigIntHandler,
termOps = Right FileOps {
inputHandle = h_in,
getLocaleChar = getMultiByteChar h_in decoder',
maybeReadNewline = hMaybeReadNewline h_in,
getLocaleLine = Term.hGetLine h_in
>>= liftIO . decoder
fileRunTerm h_in = posixFileRunTerm Handles
{ hIn = externalHandle h_in
, hOut = externalHandle stdout
, closeHandles = return ()
}
posixFileRunTerm :: Handles -> IO RunTerm
posixFileRunTerm hs = do
(enc,dec) <- newEncoders
return RunTerm
{ putStrOut = \str -> withCodingMode (hOut hs) $ do
putEncodedStr enc (ehOut hs) str
hFlush (ehOut hs)
, closeTerm = closeHandles hs
, wrapInterrupt = withSigIntHandler
, termOps = Right FileOps
{ inputHandle = ehIn hs
, wrapFileInput = withCodingMode (hIn hs)
, getLocaleChar = getDecodedChar (ehIn hs) dec
, maybeReadNewline = hMaybeReadNewline (ehIn hs)
, getLocaleLine = getDecodedLine (ehIn hs) dec
}
}
-- NOTE: If we set stdout to NoBuffering, there can be a flicker effect when many
-- characters are printed at once. We'll keep it buffered here, and let the Draw
-- monad manually flush outputs that don't print a newline.
wrapTerminalOps :: MonadException m => Handles -> m a -> m a
wrapTerminalOps Handles {hIn = h_in, hOut = h_out} =
wrapTerminalOps hs =
bracketSet (hGetBuffering h_in) (hSetBuffering h_in) NoBuffering
-- TODO: block buffering? Certain \r and \n's are causing flicker...
-- - moving to the right
-- - breaking line after offset widechar?
. bracketSet (hGetBuffering h_out) (hSetBuffering h_out) LineBuffering
. bracketSet (hGetEcho h_in) (hSetEcho h_in) False
. hWithBinaryMode h_in
. liftIOOp_ (withCodingMode $ hIn hs)
. liftIOOp_ (withCodingMode $ hOut hs)
where
h_in = ehIn hs
h_out = ehOut hs
{- | This module provides a wrapper for I/O encoding for the "old" and "new" ways.
The "old" way uses iconv+utf8-string.
The "new" way uses the base library's built-in encoding functionality.
For the "new" way, we require ghc>=7.4.1 due to GHC bug #5436.
This module exports opaque Encoder/Decoder datatypes, along with several helper
functions that wrap the old/new ways.
-}
module System.Console.Haskeline.Backend.Posix.Encoder (
Encoder,
Decoder,
newEncoders,
ExternalHandle(eH),
externalHandle,
withCodingMode,
openInCodingMode,
putEncodedStr,
#ifdef TERMINFO
getTermText,
#endif
getBlockOfChars,
getDecodedChar,
getDecodedLine,
) where
import System.IO
import System.Console.Haskeline.Monads
import System.Console.Haskeline.Term
#ifdef TERMINFO
import qualified System.Console.Terminfo.Base as Terminfo
#endif
-- Way-dependent imports
#ifdef USE_GHC_ENCODINGS
import GHC.IO.Encoding (initLocaleEncoding)
import System.Console.Haskeline.Backend.Posix.Recover
#else
import System.Console.Haskeline.Backend.Posix.IConv
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
#ifdef TERMINFO
import qualified Data.ByteString.Char8 as BC
#endif
import Control.Monad (liftM2)
#endif
#ifdef USE_GHC_ENCODINGS
data Encoder = Encoder
data Decoder = Decoder
#else
type Decoder = PartialDecoder
type Encoder = String -> IO ByteString
#endif
newEncoders :: IO (Encoder,Decoder)
#ifdef USE_GHC_ENCODINGS
newEncoders = return (Encoder,Decoder)
#else
newEncoders = do
codeset <- bracket (setLocale (Just "")) setLocale $ const $ getCodeset
liftM2 (,) (openEncoder codeset)
(openPartialDecoder codeset)
#endif
-- | An 'ExternalHandle' is a handle which may or may not be in the correct
-- mode for Unicode input/output. When the POSIX backend opens a file
-- (or /dev/tty) it sets it permanently to the correct mode.
-- However, when it uses an existing handle like stdin, it only temporarily
-- sets it to the correct mode (e.g., for the duration of getInputLine);
-- otherwise, we might interfere with the rest of the Haskell program.
--
-- For the legacy backend, the correct mode is BinaryMode.
-- For the new backend, the correct mode is the locale encoding, set to
-- transliterate errors (rather than crashing, as is the base library's
-- default.) (See Posix/Recover.hs)
data ExternalHandle = ExternalHandle
{ externalMode :: ExternalMode
, eH :: Handle
}
data ExternalMode = CodingMode | OtherMode
externalHandle :: Handle -> ExternalHandle
externalHandle = ExternalHandle OtherMode
-- | Use to ensure that an external handle is in the correct mode
-- for the duration of the given action.
withCodingMode :: ExternalHandle -> IO a -> IO a
withCodingMode ExternalHandle {externalMode=CodingMode} act = act
#ifdef USE_GHC_ENCODINGS
withCodingMode (ExternalHandle OtherMode h) act = do
bracket (liftIO $ hGetEncoding h)
(liftIO . hSetBinOrEncoding h)
$ const $ do
hSetEncoding h haskelineEncoding
act
hSetBinOrEncoding :: Handle -> Maybe TextEncoding -> IO ()
hSetBinOrEncoding h Nothing = hSetBinaryMode h True
hSetBinOrEncoding h (Just enc) = hSetEncoding h enc
#else
withCodingMode (ExternalHandle OtherMode h) act = hWithBinaryMode h act
#endif
#ifdef USE_GHC_ENCODINGS
haskelineEncoding :: TextEncoding
haskelineEncoding = transliterateFailure initLocaleEncoding
#endif
-- Open a file and permanently set it to the correct mode.
openInCodingMode :: FilePath -> IOMode -> IO ExternalHandle
#ifdef USE_GHC_ENCODINGS
openInCodingMode path iomode = do
h <- openFile path iomode
hSetEncoding h haskelineEncoding
return $ ExternalHandle CodingMode h
#else
openInCodingMode path iomode
= fmap (ExternalHandle CodingMode) $ openBinaryFile path iomode
#endif
-----------------------
-- Output
putEncodedStr :: Encoder -> Handle -> String -> IO ()
#ifdef USE_GHC_ENCODINGS
putEncodedStr _ h = hPutStr h
#else
putEncodedStr enc h s = enc s >>= B.hPutStr h
#endif
#ifdef TERMINFO
getTermText :: Encoder -> String -> IO Terminfo.TermOutput
#ifdef USE_GHC_ENCODINGS
getTermText _ = return . Terminfo.termText
#else
getTermText enc s = enc s >>= return . Terminfo.termText . BC.unpack
#endif
#endif
-- Read at least one character of input, and more if immediately
-- available. In particular the characters making up a control sequence
-- will all be available at once, so they can be processed together
-- (with Posix.lexKeys).
getBlockOfChars :: Handle -> Decoder -> IO String
#ifdef USE_GHC_ENCODINGS
getBlockOfChars h _ = do
c <- hGetChar h
loop [c]
where
loop cs = do
isReady <- hReady h
if not isReady
then return $ reverse cs
else do
c <- hGetChar h
loop (c:cs)
#else
getBlockOfChars h decode = do
let bufferSize = 32
blockUntilInput h
bs <- B.hGetNonBlocking h bufferSize
decodeAndMore decode h bs
#endif
-- Read in a single character, or Nothing if eof.
-- Assumes the handle is "prepared".
getDecodedChar :: Handle -> Decoder -> MaybeT IO Char
#ifdef USE_GHC_ENCODINGS
getDecodedChar h _ = guardedEOF hGetChar h
#else
getDecodedChar h decode = do
b <- hGetByte h
cs <- liftIO $ decodeAndMore decode h (B.pack [b])
case cs of
[] -> return '?' -- shouldn't happen, but doesn't hurt to be careful.
(c:_) -> return c
#endif
-- Read in a single line, or Nothing if eof.
getDecodedLine :: Handle -> Decoder -> MaybeT IO String
#ifdef USE_GHC_ENCODINGS
getDecodedLine h _ = guardedEOF hGetLine h
#else
getDecodedLine h decode
= hGetLocaleLine h >>= liftIO . decodeAndMore decode h
#endif
-- Helper functions for iconv encoding
#ifndef USE_GHC_ENCODINGS
blockUntilInput :: Handle -> IO ()
#if __GLASGOW_HASKELL__ >= 611
-- threadWaitRead doesn't work with the new (ghc-6.12) IO library,
-- because it keeps a buffer even when NoBuffering is set.
blockUntilInput h = hWaitForInput h (-1) >> return ()
#else
-- hWaitForInput doesn't work with -threaded on ghc < 6.10
-- (#2363 in ghc's trac)
blockUntilInput h = unsafeHandleToFD h >>= threadWaitRead . Fd
#endif
#endif -- USE_GHC_ENCODINGS
module System.Console.Haskeline.Backend.IConv(
{- | This module exports iconv-based encoding/decoding, for use on
older versions of GHC.