diff --git a/Setup.hs b/Setup.hs index 3f0fd4e3cf1e6b38bc656a74afc19ac3fb2e4c11..0e148c9019d1e899271fbf0250e91161f6332711 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,4 @@ +{-# 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 + diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs index 91ca817b1ba5d0835b4a397fbba3440843e8a39c..058ad8bce86d87cd2620870f563c040c784dac94 100644 --- a/System/Console/Haskeline.hs +++ b/System/Console/Haskeline.hs @@ -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 diff --git a/System/Console/Haskeline/Backend/DumbTerm.hs b/System/Console/Haskeline/Backend/DumbTerm.hs index 302e395842d0719cf023a1f60bbe8dbe3287ee8f..b035d6500ce209767a3bdb5fc12d61c4a0fb5b4c 100644 --- a/System/Console/Haskeline/Backend/DumbTerm.hs +++ b/System/Console/Haskeline/Backend/DumbTerm.hs @@ -1,6 +1,7 @@ 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 diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc index 4ffbf5395e3a5d5566608d798d38009d2f0a92e4..db9c66e142db4fdda98d118b745bd29661e3f5d5 100644 --- a/System/Console/Haskeline/Backend/Posix.hsc +++ b/System/Console/Haskeline/Backend/Posix.hsc @@ -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 diff --git a/System/Console/Haskeline/Backend/Posix/Encoder.hs b/System/Console/Haskeline/Backend/Posix/Encoder.hs new file mode 100644 index 0000000000000000000000000000000000000000..b6cbb61a6bdf7bd06db3de40723550c8dd8f34c0 --- /dev/null +++ b/System/Console/Haskeline/Backend/Posix/Encoder.hs @@ -0,0 +1,211 @@ +{- | 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 + + diff --git a/System/Console/Haskeline/Backend/IConv.hsc b/System/Console/Haskeline/Backend/Posix/IConv.hsc similarity index 82% rename from System/Console/Haskeline/Backend/IConv.hsc rename to System/Console/Haskeline/Backend/Posix/IConv.hsc index b6f3585e938de80737615c1ff2a7533f54d9259b..56691cb952c106d59df14425826e17b7d07c1258 100644 --- a/System/Console/Haskeline/Backend/IConv.hsc +++ b/System/Console/Haskeline/Backend/Posix/IConv.hsc @@ -1,20 +1,25 @@ -module System.Console.Haskeline.Backend.IConv( +{- | This module exports iconv-based encoding/decoding, for use on +older versions of GHC. +-} +module System.Console.Haskeline.Backend.Posix.IConv( setLocale, getCodeset, openEncoder, openDecoder, openPartialDecoder, - Result(..) + PartialDecoder, + decodeAndMore, ) where import Foreign.C import Foreign -import Data.ByteString (ByteString, useAsCStringLen, append) +import Data.ByteString (ByteString, useAsCStringLen, append ) -- TODO: Base or Internal, depending on whether base>=3. import Data.ByteString.Internal (createAndTrim') import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 import Data.Maybe (fromMaybe) +import System.IO (Handle) #include <locale.h> #include <langinfo.h> @@ -48,7 +53,9 @@ simpleIConv dropper t bs = do continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`)) $ simpleIConv dropper t (dropper rest) -openPartialDecoder :: String -> IO (ByteString -> IO (String, Result)) +type PartialDecoder = ByteString -> IO (String,Result) + +openPartialDecoder :: String -> IO PartialDecoder openPartialDecoder codeset = do decodeT <- iconvOpen "UTF-8" codeset return $ \bs -> do @@ -150,3 +157,21 @@ partialIconv cd outSize inBuff inBytesLeft = else return Nothing return (0,outSize - outLeft,errno) +------------- +-- Decode the given ByteString. If necessary, finish decoding it +-- by reading more bytes one at a time from the given handle. +-- (This assumes that the handle is in BinaryMode.) +decodeAndMore:: PartialDecoder + -> Handle -> B.ByteString -> IO String +decodeAndMore decoder h 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++) + $ decodeAndMore decoder h (rest `B.append` extra) + Invalid rest -> fmap ((cs ++) . ('?':)) + $ decodeAndMore decoder h (B.drop 1 rest) + Successful -> return cs diff --git a/System/Console/Haskeline/Backend/Posix/Recover.hs b/System/Console/Haskeline/Backend/Posix/Recover.hs new file mode 100644 index 0000000000000000000000000000000000000000..720346195c7657531e84c8bda9a58f79155dd3ae --- /dev/null +++ b/System/Console/Haskeline/Backend/Posix/Recover.hs @@ -0,0 +1,22 @@ +module System.Console.Haskeline.Backend.Posix.Recover where + +import GHC.IO.Encoding +import GHC.IO.Encoding.Failure + +transliterateFailure :: TextEncoding -> TextEncoding +transliterateFailure + TextEncoding + { mkTextEncoder = mkEncoder + , mkTextDecoder = mkDecoder + , textEncodingName = name + } = TextEncoding + { mkTextDecoder = fmap (setRecover + $ recoverDecode TransliterateCodingFailure) + mkDecoder + , mkTextEncoder = fmap (setRecover + $ recoverEncode TransliterateCodingFailure) + mkEncoder + , textEncodingName = name + } + where + setRecover r x = x { recover = r } diff --git a/System/Console/Haskeline/Backend/Terminfo.hs b/System/Console/Haskeline/Backend/Terminfo.hs index d759392b3b3312542092788d6bb7d0d00d21d385..7c7fad22c47f2e93f1580ee50332c01e964d1096 100644 --- a/System/Console/Haskeline/Backend/Terminfo.hs +++ b/System/Console/Haskeline/Backend/Terminfo.hs @@ -16,6 +16,7 @@ import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.LineState import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.Posix +import System.Console.Haskeline.Backend.Posix.Encoder (getTermText) import System.Console.Haskeline.Backend.WCWidth import System.Console.Haskeline.Key @@ -105,7 +106,7 @@ newtype Draw m a = Draw {unDraw :: (ReaderT Actions deriving (Monad, MonadIO, MonadException, MonadReader Actions, MonadReader Terminal, MonadState TermPos, MonadState TermRows, - MonadReader Handles, MonadReader Encoders) + MonadReader Handles, MonadReader Encoder) instance MonadTrans Draw where lift = Draw . lift . lift . lift . lift . lift . lift @@ -130,7 +131,7 @@ runTerminfoDraw h = do actions <- MaybeT $ return $ getCapability term getActions liftIO $ posixRunTerm h (posixLayouts h ++ [tinfoLayout term]) (terminfoKeys term) - (wrapKeypad (hOut h) term) + (wrapKeypad (ehOut h) term) (evalDraw term actions) -- If the keypad on/off capabilities are defined, wrap the computation with them. @@ -188,7 +189,7 @@ runActionT m = do (x,action) <- Writer.runWriterT m toutput <- asks action term <- ask - ttyh <- liftM hOut ask + ttyh <- liftM ehOut ask liftIO $ hRunTermOutput ttyh term toutput return x @@ -196,8 +197,10 @@ output :: TermAction -> ActionM () output = Writer.tell outputText :: String -> ActionM () -outputText str = (lift $ Draw $ lift $ lift $ lift $ lift $ posixEncode str) - >>= output . const . termText +outputText str = do + encode <- lift ask + liftIO (getTermText encode str) + >>= output . const left,right,up :: Int -> TermAction left = flip leftA diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc index 87b51a650b78ca4e4ecc06f6d66185b7bcee35b2..35c5c77bc3ad6ac9997d479e6bc22201a5aadfc4 100644 --- a/System/Console/Haskeline/Backend/Win32.hsc +++ b/System/Console/Haskeline/Backend/Win32.hsc @@ -19,7 +19,7 @@ import Control.Monad import System.Console.Haskeline.Key import System.Console.Haskeline.Monads import System.Console.Haskeline.LineState -import System.Console.Haskeline.Term as Term +import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.WCWidth import Data.ByteString.Internal (createAndTrim) @@ -402,13 +402,14 @@ fileRunTerm h_in = do closeTerm = return (), putStrOut = putter, wrapInterrupt = withCtrlCHandler, - termOps = Right FileOps { - inputHandle = h_in, - getLocaleChar = getMultiByteChar cp h_in, - maybeReadNewline = hMaybeReadNewline h_in, - getLocaleLine = Term.hGetLine h_in + termOps = Right FileOps + { inputHandle = h_in + , wrapFileInput = hWithBinaryMode h_in + , getLocaleChar = getMultiByteChar cp h_in + , maybeReadNewline = hMaybeReadNewline h_in + , getLocaleLine = hGetLocaleLine h_in >>= liftIO . codePageToUnicode cp - } + } } @@ -493,16 +494,14 @@ foreign import WINDOWS_CCONV "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx :: CodePage -> BYTE -> BOOL getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char -getMultiByteChar cp h = hWithBinaryMode h loop - where - loop = do +getMultiByteChar cp h = do b1 <- hGetByte h bs <- if c_IsDBCSLeadByteEx cp b1 then hGetByte h >>= \b2 -> return [b1,b2] else return [b1] cs <- liftIO $ codePageToUnicode cp (B.pack bs) case cs of - [] -> loop + [] -> getMultiByteChar cp h (c:_) -> return c ---------------------------------- diff --git a/System/Console/Haskeline/Directory.hsc b/System/Console/Haskeline/Directory.hsc index 292849c376143fcca7b2eda2b3f66c323664b0e2..b2deb223bf3deb15ad04ab1bf0b23c21cb43c3c9 100644 --- a/System/Console/Haskeline/Directory.hsc +++ b/System/Console/Haskeline/Directory.hsc @@ -92,7 +92,7 @@ import System.Directory import Data.ByteString.Char8 (pack, unpack) import qualified System.Directory as D import Control.Exception -import System.Console.Haskeline.Backend.IConv +import System.Console.Haskeline.Backend.Posix.IConv getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = do diff --git a/System/Console/Haskeline/History.hs b/System/Console/Haskeline/History.hs index f09e702fb0e09dbf09c3124189a5a45fd98eca0c..4b820441e22c7138354362c3813f6f2e4dfd2557 100644 --- a/System/Console/Haskeline/History.hs +++ b/System/Console/Haskeline/History.hs @@ -34,6 +34,7 @@ import System.Directory(doesFileExist) #ifdef USE_GHC_ENCODINGS import qualified System.IO as IO +import System.Console.Haskeline.Backend.Posix.Recover #else import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 @@ -119,7 +120,7 @@ readUTF8File :: FilePath -> IO String #ifdef USE_GHC_ENCODINGS readUTF8File file = do h <- IO.openFile file IO.ReadMode - IO.hSetEncoding h IO.utf8 + IO.hSetEncoding h $ transliterateFailure IO.utf8 IO.hSetNewlineMode h IO.noNewlineTranslation contents <- IO.hGetContents h _ <- evaluate (length contents) diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs index a65204eb8984fd80267c27fb6018a3334b199a66..a4b26385a128e922c6461b949a24c30e2faefc31 100644 --- a/System/Console/Haskeline/Term.hs +++ b/System/Console/Haskeline/Term.hs @@ -7,14 +7,14 @@ import System.Console.Haskeline.Prefs(Prefs) import System.Console.Haskeline.Completion(Completion) import Control.Concurrent -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B import Data.Word import Control.Exception (fromException, AsyncException(..),bracket_) import Data.Typeable import System.IO import Control.Monad(liftM,when,guard) import System.IO.Error (isEOFError) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC class (MonadReader Layout m, MonadException m) => Term m where reposition :: Layout -> LineChars -> m () @@ -46,8 +46,12 @@ data TermOps = TermOps { } -- | Operations needed for file-style interaction. +-- +-- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline +-- are "wrapped" by wrapFileInput. data FileOps = FileOps { inputHandle :: Handle, -- ^ e.g. for turning off echoing. + wrapFileInput :: forall a . IO a -> IO a, getLocaleLine :: MaybeT IO String, getLocaleChar :: MaybeT IO Char, maybeReadNewline :: IO () @@ -149,39 +153,27 @@ bracketSet getState set newState f = bracket (liftIO getState) (liftIO . set) (\_ -> liftIO (set newState) >> f) - -- | Returns one 8-bit word. Needs to be wrapped by hWithBinaryMode. hGetByte :: Handle -> MaybeT IO Word8 -hGetByte h = do - eof <- liftIO $ hIsEOF h - guard (not eof) - liftIO $ liftM (toEnum . fromEnum) $ hGetChar h +hGetByte = guardedEOF $ liftM (toEnum . fromEnum) . hGetChar - --- | Utility function to correctly get a ByteString line of input. -hGetLine :: Handle -> MaybeT IO ByteString -hGetLine h = do - atEOF <- liftIO $ hIsEOF h - guard (not atEOF) - -- It's more efficient to use B.getLine, but that function throws an - -- error if the Handle (e.g., stdin) is set to NoBuffering. - buff <- liftIO $ hGetBuffering h - liftIO $ if buff == NoBuffering - then hWithBinaryMode h $ fmap B.pack $ System.IO.hGetLine h - else B.hGetLine h +guardedEOF :: (Handle -> IO a) -> Handle -> MaybeT IO a +guardedEOF f h = do + eof <- lift $ hIsEOF h + guard (not eof) + lift $ f h -- If another character is immediately available, and it is a newline, consume it. -- -- Two portability fixes: +-- +-- 1) By itself, this (by using hReady) might crash on invalid characters. +-- The handle should be set to binary mode or a TextEncoder that +-- transliterates or ignores invalid input. -- -- 1) Note that in ghc-6.8.3 and earlier, hReady returns False at an EOF, -- whereas in ghc-6.10.1 and later it throws an exception. (GHC trac #1063). -- This code handles both of those cases. --- --- 2) Also note that on Windows with ghc<6.10, hReady may not behave correctly (#1198) --- The net result is that this might cause --- But this function will generally only be used when reading buffered input --- (since stdin isn't a terminal), so it should probably be OK. hMaybeReadNewline :: Handle -> IO () hMaybeReadNewline h = returnOnEOF () $ do ready <- hReady h @@ -193,3 +185,14 @@ returnOnEOF :: MonadException m => a -> m a -> m a returnOnEOF x = handle $ \e -> if isEOFError e then return x else throwIO e + +-- | Utility function to correctly get a line of input as an undecoded ByteString. +hGetLocaleLine :: Handle -> MaybeT IO ByteString +hGetLocaleLine = guardedEOF $ \h -> do + -- It's more efficient to use B.getLine, but that function throws an + -- error if the Handle (e.g., stdin) is set to NoBuffering. + buff <- liftIO $ hGetBuffering h + liftIO $ if buff == NoBuffering + then fmap BC.pack $ System.IO.hGetLine h + else BC.hGetLine h + diff --git a/haskeline.cabal b/haskeline.cabal index 0a35c8e1626480f295db48ffeeeabd715b049e08..148540b7342898ebc624c65e392175627077d874 100644 --- a/haskeline.cabal +++ b/haskeline.cabal @@ -44,6 +44,11 @@ flag libiconv Description: Explicitly link against the libiconv library. Default: False +flag legacy-encoding + Description: Use the legacy iconv encoding for POSIX, even on ghc>=7.4.1. + (Intended for testing only.) + Default: False + Library if impl(ghc>=6.11) { Build-depends: base >=4.1 && < 4.7, containers>=0.1 && < 0.6, directory>=1.0 && < 1.2, @@ -89,7 +94,10 @@ Library include-dirs: includes c-sources: cbits/h_wcwidth.c - if impl(ghc>=7.4) { + -- We require ghc>=7.4.1 to use the base library encodings, + -- even though it was implemented in earlier releases, + -- due to GHC bug #5436 which wasn't fixed until 7.4.1 + if !flag(legacy-encoding) && impl(ghc>=7.4) { cpp-options: -DUSE_GHC_ENCODINGS } else { Build-depends: utf8-string==0.3.* && >=0.3.6 @@ -104,13 +112,18 @@ Library } else { Build-depends: unix>=2.0 && < 2.7 -- unix-2.3 doesn't build on ghc-6.8.1 or earlier - Build-depends: utf8-string==0.3.* && >=0.3.6 - c-sources: cbits/h_iconv.c - includes: h_iconv.h - install-includes: h_iconv.h + -- Use manual encoding/decoding on ghc<7.4 + if flag (legacy-encoding) || impl(ghc<7.4) { + c-sources: cbits/h_iconv.c + includes: h_iconv.h + install-includes: h_iconv.h + Other-modules: System.Console.Haskeline.Backend.Posix.IConv + } else { + Other-modules: System.Console.Haskeline.Backend.Posix.Recover + } Other-modules: System.Console.Haskeline.Backend.Posix - System.Console.Haskeline.Backend.IConv + System.Console.Haskeline.Backend.Posix.Encoder System.Console.Haskeline.Backend.DumbTerm if flag(terminfo) { Build-depends: terminfo>=0.3.1.3 && <0.4