diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,3 +1,17 @@ +Changed in version 8.4.5.0: + + * System.Console.Haskeline.Internal now exposes far more internals of + Haskeline. + + * Added `useTermHandles` and `useTermHandlesWith` Behaviors for driving + Haskeline against caller-supplied input/output handles (e.g. a serial + console or a PTY pair other than the controlling terminal). POSIX only. + + * On POSIX, fixed escape sequences breaking when their bytes arrive in + separate reads (e.g. on slow serial links). Added `keyseqTimeoutMs` + to `Prefs` to configure the wait, mirroring GNU Readline's + `keyseq-timeout`. + Changed in version 0.8.4.1: * Implemented ; and , movements and enabled them for d, c, and y actions. diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs --- a/System/Console/Haskeline.hs +++ b/System/Console/Haskeline.hs @@ -39,6 +39,10 @@ defaultBehavior, useFileHandle, useFile, +#ifndef MINGW + useTermHandles, + useTermHandlesWith, +#endif preferTerm, -- * User interaction functions -- ** Reading user input @@ -60,6 +64,7 @@ setComplete, -- ** User preferences Prefs(), + keyseqTimeoutMs, readPrefs, defaultPrefs, runInputTWithPrefs, diff --git a/System/Console/Haskeline/Backend.hs b/System/Console/Haskeline/Backend.hs --- a/System/Console/Haskeline/Backend.hs +++ b/System/Console/Haskeline/Backend.hs @@ -23,27 +23,39 @@ terminalRunTerm :: IO RunTerm terminalRunTerm = directTTY `orElse` fileHandleRunTerm stdin +#ifndef MINGW +useTermHandlesRunTerm :: Maybe String -> Handle -> Handle -> IO RunTerm +useTermHandlesRunTerm termtype input output = + explicitTTY termtype input output `orElse` fileHandleRunTerm input +#endif + stdinTTY :: MaybeT IO RunTerm #ifdef MINGW stdinTTY = win32TermStdin #else -stdinTTY = stdinTTYHandles >>= runDraw +stdinTTY = stdinTTYHandles >>= runDraw Nothing #endif directTTY :: MaybeT IO RunTerm #ifdef MINGW directTTY = win32Term #else -directTTY = ttyHandles >>= runDraw +directTTY = ttyHandles >>= runDraw Nothing #endif +#ifndef MINGW +explicitTTY :: Maybe String -> Handle -> Handle -> MaybeT IO RunTerm +explicitTTY termtype input output = + explicitTTYHandles input output >>= runDraw termtype +#endif + #ifndef MINGW -runDraw :: Handles -> MaybeT IO RunTerm +runDraw :: Maybe String -> Handles -> MaybeT IO RunTerm #ifndef TERMINFO -runDraw = runDumbTerm +runDraw _termtype = runDumbTerm #else -runDraw h = runTerminfoDraw h `mplus` runDumbTerm h +runDraw termtype h = runTerminfoDraw termtype h `mplus` runDumbTerm h #endif #endif diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc --- a/System/Console/Haskeline/Backend/Posix.hsc +++ b/System/Console/Haskeline/Backend/Posix.hsc @@ -11,6 +11,7 @@ mapLines, stdinTTYHandles, ttyHandles, + explicitTTYHandles, posixRunTerm, fileRunTerm ) where @@ -201,16 +202,55 @@ = metaKey k : ks lexKeys baseMap (c:cs) = simpleChar c : lexKeys baseMap cs -lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key,[Char]) -lookupChars _ [] = Nothing -lookupChars (TreeMap tm) (c:cs) = case Map.lookup c tm of - Nothing -> Nothing - Just (Nothing,t) -> lookupChars t cs - Just (Just k, t@(TreeMap tm2)) - | not (null cs) && not (Map.null tm2) -- ?? lookup d tm2? - -> lookupChars t cs - | otherwise -> Just (k, cs) +-- | Walk @cs@ through the tree, returning the /longest/ key found along +-- the path together with whatever bytes follow it. +-- +-- If a longer match is attempted but doesn't pan out (the next byte +-- isn't in the deeper subtree), we fall back to the most recent shorter +-- key we passed. This avoids the well-known sharp edge where input +-- like @\\ESC[AC@ — with @\\ESC[A@ registered (up-arrow) and the @A@ +-- node having children that don't include @C@ — would previously be +-- reported as no match at all, instead of @up-arrow + 'C'@. +-- +-- 'Nothing' is returned only when no key is reached anywhere along the +-- walk. +lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key, [Char]) +lookupChars _ [] = Nothing +lookupChars tree cs = go Nothing tree cs + where + -- 'best' holds the longest committed match so far (or Nothing if + -- we haven't passed a key node yet). When the next byte doesn't + -- extend the path we return 'best'. + go best (TreeMap m) (c:cs') = case Map.lookup c m of + Nothing -> best + Just (mKey, sub) -> + let best' = maybe best (\k -> Just (k, cs')) mKey + in case cs' of + _:_ -> go best' sub cs' + [] -> best' + go best _ [] = best -- unreachable: top-level [] handled above +-- | Greedily peel complete keys off the front of @cs@. Returns the +-- decoded keys (in forward order) and the leftover bytes that didn't +-- (yet) form a complete tree match. +peelCompleteKeys :: TreeMap Char Key -> [Char] -> ([Key], [Char]) +peelCompleteKeys tree = go id + where + go acc cs = case lookupChars tree cs of + Just (k, rest) -> go (acc . (k:)) rest + Nothing -> (acc [], cs) + +-- | True if @cs@ matches a /strict/ (non-terminal) prefix of some path +-- in the @TreeMap@ — i.e. it could still be extended into a complete +-- key sequence if more bytes arrive. +isStrictTreePrefix :: TreeMap Char b -> [Char] -> Bool +isStrictTreePrefix _ [] = False +isStrictTreePrefix (TreeMap m) (c:cs) = case Map.lookup c m of + Nothing -> False + Just (_, sub@(TreeMap sm)) -> case cs of + [] -> not (Map.null sm) + _ -> isStrictTreePrefix sub cs + ----------------------------- withPosixGetEvent :: (MonadIO m, MonadMask m, MonadReader Prefs m) @@ -218,8 +258,9 @@ -> (m Event -> m a) -> m a withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do baseMap <- getKeySequences (ehIn h) termKeys + timeoutMs <- asks (fromIntegral . keyseqTimeoutMs :: Prefs -> Int) withWindowHandler eventChan - $ f $ liftIO $ getEvent (ehIn h) baseMap eventChan + $ f $ liftIO $ getEvent (ehIn h) timeoutMs baseMap eventChan withWindowHandler :: (MonadIO m, MonadMask m) => TChan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ @@ -237,27 +278,62 @@ old_handler <- liftIO $ installHandler signal handler Nothing f `finally` liftIO (installHandler signal old_handler Nothing) -getEvent :: Handle -> TreeMap Char Key -> TChan Event -> IO Event -getEvent h baseMap = keyEventLoop $ do - cs <- getBlockOfChars h - return [KeyInput $ lexKeys baseMap cs] +getEvent :: Handle -> Int -> TreeMap Char Key -> TChan Event -> IO Event +getEvent h timeoutMs baseMap = keyEventLoop $ do + ks <- getBlockOfKeys h baseMap timeoutMs + return [KeyInput ks] --- 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 -> IO String -getBlockOfChars h = do +-- | Read at least one key of input, and more if available. +-- +-- A multi-byte control sequence (e.g. @\\ESC[A@ for arrow-up) may not +-- arrive in a single read on a slow link such as a low-bandwidth serial +-- port: the @\\ESC@ can land before the @[A@. When the buffer ends in +-- bytes that are a strict prefix of some known key sequence, we wait up +-- to @timeoutMs@ for the rest before returning. Otherwise we return as +-- soon as nothing more is buffered. This mirrors GNU Readline's +-- @keyseq-timeout@. +-- +-- The loop tracks bytes and decoded keys side by side: every time we +-- run out of immediately-available input we peel complete keys from the +-- front of the byte buffer and shrink it down to just its trailing +-- (possibly partial) prefix. That keeps the per-decision work bounded +-- by the size of the in-flight sequence rather than the whole accrued +-- buffer, which matters when bytes trickle in slowly. +-- +-- Win32 is unaffected: that backend reads structured @INPUT_RECORD@ +-- key events rather than raw bytes, so escape sequences are never +-- fragmented in the first place. +getBlockOfKeys :: Handle -> TreeMap Char Key -> Int -> IO [Key] +getBlockOfKeys h baseMap timeoutMs = do c <- hGetChar h - loop [c] + loop [c] [] where - loop cs = do - isReady <- hReady h - if not isReady - then return $ reverse cs - else do - c <- hGetChar h - loop (c:cs) + -- Both lists hold values in reverse (newest first) so that consing a + -- new element is O(1). We reverse only at decision points or on + -- return. + loop bytesRev keysRev = do + ready <- hWaitForInput h 0 + if ready + then do + c <- hGetChar h + loop (c:bytesRev) keysRev + else + -- Drain whatever complete keys are sitting at the head of + -- the byte buffer; what's left is either empty (done) or a + -- still-in-flight partial sequence. + let (peeled, partial) = peelCompleteKeys baseMap (reverse bytesRev) + keysRev' = reverse peeled ++ keysRev + in if null partial + then pure (reverse keysRev') + else if isStrictTreePrefix baseMap partial + then do + arrived <- hWaitForInput h timeoutMs + if arrived + then do + c <- hGetChar h + loop (c : reverse partial) keysRev' + else pure (reverse keysRev' ++ lexKeys baseMap partial) + else pure (reverse keysRev' ++ lexKeys baseMap partial) stdinTTYHandles, ttyHandles :: MaybeT IO Handles stdinTTYHandles = do @@ -286,6 +362,15 @@ openTerm mode = handle (\(_::IOException) -> mzero) $ liftIO $ openInCodingMode "/dev/tty" mode +explicitTTYHandles :: Handle -> Handle -> MaybeT IO Handles +explicitTTYHandles h_in h_out = do + isInTerm <- liftIO $ hIsTerminalDevice h_in + guard isInTerm + return Handles + { hIn = externalHandle h_in + , hOut = externalHandle h_out + , closeHandles = return () + } posixRunTerm :: Handles diff --git a/System/Console/Haskeline/Backend/Terminfo.hs b/System/Console/Haskeline/Backend/Terminfo.hs --- a/System/Console/Haskeline/Backend/Terminfo.hs +++ b/System/Console/Haskeline/Backend/Terminfo.hs @@ -125,9 +125,9 @@ . unDraw -runTerminfoDraw :: Handles -> MaybeT IO RunTerm -runTerminfoDraw h = do - mterm <- liftIO $ Exception.try setupTermFromEnv +runTerminfoDraw :: Maybe String -> Handles -> MaybeT IO RunTerm +runTerminfoDraw termtype h = do + mterm <- liftIO $ Exception.try $ maybe setupTermFromEnv setupTerm termtype case mterm of Left (_::SetupTermError) -> mzero Right term -> do diff --git a/System/Console/Haskeline/InputT.hs b/System/Console/Haskeline/InputT.hs --- a/System/Console/Haskeline/InputT.hs +++ b/System/Console/Haskeline/InputT.hs @@ -216,6 +216,70 @@ preferTerm :: Behavior preferTerm = Behavior terminalRunTerm +#ifndef MINGW +-- | Use terminal-style interaction on the given input and output handles, +-- taking the terminal type from the @TERM@ environment variable. +-- +-- This behavior is for driving Haskeline against a terminal that is not the +-- process's controlling terminal — for example, a serial console, a PTY pair +-- you opened yourself, or a socket-backed TTY. The caller is responsible for +-- closing @input@ and @output@ after use. Not available on Windows. +-- +-- See 'useTermHandlesWith' to override the terminal type. +useTermHandles :: Handle -> Handle -> Behavior +useTermHandles input output = + Behavior $ useTermHandlesRunTerm Nothing input output + +-- | Like 'useTermHandles', but with the terminal type given explicitly +-- (e.g. @\"xterm-256color\"@ or @\"vt100\"@) instead of read from the @TERM@ +-- environment variable. +-- +-- The terminal type is only consulted when haskeline is built with terminfo +-- support; in non-terminfo builds it is ignored and a dumb terminal is used. +-- +-- ==== __Example: a Haskeline session over a WebSocket__ +-- +-- Bridge a WebSocket to the master end of a PTY pair and run Haskeline +-- against the slave end. Uses the @websockets@ and @unix@ packages. +-- Pair this with a browser-side terminal emulator such as +-- for an in-browser shell. +-- +-- > import qualified Network.WebSockets as WS +-- > import System.Posix.Terminal (openPseudoTerminal) +-- > import System.Posix.IO (dup, fdToHandle) +-- > import Control.Applicative ((<|>)) +-- > import Control.Concurrent.Async (Concurrently(..), runConcurrently) +-- > import Control.Monad (forever) +-- > import qualified Data.ByteString as BS +-- > import System.IO (hSetBuffering, BufferMode(..)) +-- > import System.Console.Haskeline +-- > +-- > websocketUI :: WS.Connection -> IO () +-- > websocketUI conn = do +-- > (master, slave) <- openPseudoTerminal +-- > slaveDup <- dup slave +-- > masterH <- fdToHandle master +-- > slaveIn <- fdToHandle slave +-- > slaveOut <- fdToHandle slaveDup +-- > hSetBuffering masterH NoBuffering +-- > -- Whichever of the three actions finishes first cancels the others. +-- > runConcurrently +-- > $ Concurrently (forever $ WS.receiveData conn >>= BS.hPut masterH) +-- > <|> Concurrently (forever $ BS.hGetSome masterH 4096 >>= WS.sendBinaryData conn) +-- > <|> Concurrently (runInputTBehavior +-- > (useTermHandlesWith "vt100" slaveIn slaveOut) +-- > defaultSettings loop) +-- > where +-- > loop = do +-- > minput <- getInputLine "% " +-- > case minput of +-- > Nothing -> return () +-- > Just "quit" -> return () +-- > Just s -> outputStrLn ("got: " ++ s) >> loop +useTermHandlesWith :: String -> Handle -> Handle -> Behavior +useTermHandlesWith termtype input output = + Behavior $ useTermHandlesRunTerm (Just termtype) input output +#endif -- | Read 'Prefs' from @$XDG_CONFIG_HOME/haskeline/haskeline@ if present -- ortherwise @~/.haskeline.@ If there is an error reading the file, diff --git a/System/Console/Haskeline/Internal.hs b/System/Console/Haskeline/Internal.hs --- a/System/Console/Haskeline/Internal.hs +++ b/System/Console/Haskeline/Internal.hs @@ -1,5 +1,12 @@ +-- | A module containing semi-public internals. The functions here are not +-- stable. module System.Console.Haskeline.Internal - ( debugTerminalKeys ) where + ( module System.Console.Haskeline.Monads + , module System.Console.Haskeline.Term + , module System.Console.Haskeline.Key + , module System.Console.Haskeline.LineState + , Behavior (..) + , debugTerminalKeys ) where import System.Console.Haskeline (defaultSettings, outputStrLn) import System.Console.Haskeline.Command @@ -8,6 +15,7 @@ import System.Console.Haskeline.Monads import System.Console.Haskeline.RunCommand import System.Console.Haskeline.Term +import System.Console.Haskeline.Key import Control.Monad ((>=>)) diff --git a/System/Console/Haskeline/Key.hs b/System/Console/Haskeline/Key.hs --- a/System/Console/Haskeline/Key.hs +++ b/System/Console/Haskeline/Key.hs @@ -8,7 +8,8 @@ ctrlChar, metaKey, ctrlKey, - parseKey + parseKey, + setControlBits ) where import Data.Bits diff --git a/System/Console/Haskeline/Prefs.hs b/System/Console/Haskeline/Prefs.hs --- a/System/Console/Haskeline/Prefs.hs +++ b/System/Console/Haskeline/Prefs.hs @@ -14,6 +14,7 @@ import Data.Char(isSpace,toLower) import Data.List(foldl') import qualified Data.Map as Map +import Data.Word (Word) import System.Console.Haskeline.Key {- | @@ -48,7 +49,16 @@ -- presses @TAB@ again. customBindings :: Map.Map Key [Key], -- (termName, keysequence, key) - customKeySequences :: [(Maybe String, String,Key)] + customKeySequences :: [(Maybe String, String,Key)], + keyseqTimeoutMs :: !Word + -- ^ After an @ESC@ byte is read, how long to wait + -- (in milliseconds) for the rest of an escape + -- sequence before treating the @ESC@ as a + -- standalone keypress. Matters on slow links + -- (e.g. low-bandwidth serial), where the bytes of + -- a sequence such as @\\ESC[A@ may not arrive in + -- a single read. Mirrors GNU Readline's + -- @keyseq-timeout@. } deriving Show @@ -77,7 +87,8 @@ listCompletionsImmediately = True, historyDuplicates = AlwaysAdd, customBindings = Map.empty, - customKeySequences = [] + customKeySequences = [], + keyseqTimeoutMs = 50 } mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs @@ -98,6 +109,7 @@ ,("completionpromptlimit", mkSettor $ \x p -> p {completionPromptLimit = x}) ,("listcompletionsimmediately", mkSettor $ \x p -> p {listCompletionsImmediately = x}) ,("historyduplicates", mkSettor $ \x p -> p {historyDuplicates = x}) + ,("keyseqtimeoutms", mkSettor $ \x p -> p {keyseqTimeoutMs = x}) ,("bind", addCustomBinding) ,("keyseq", addCustomKeySequence) ] diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -1,41 +1,138 @@ +{-# LANGUAGE CPP #-} module Main where import System.Console.Haskeline -import System.Environment +import Options.Applicative +import Data.Monoid ((<>)) +#ifndef MINGW +import System.IO (openFile, hClose, IOMode(..)) +#endif {-- Testing the line-input functions and their interaction with ctrl-c signals. Usage: -./Test (line input) -./Test chars (character input) -./Test password (no masking characters) -./Test password \* -./Test initial (use initial text in the prompt) + ./Test (line input, default Behavior) + ./Test chars (character input) + ./Test password (no masking) + ./Test password \* (masking with '*') + ./Test initial (initial text in the prompt) + + ./Test --mode useTermHandles (POSIX only) + ./Test --mode useTermHandlesWith --term-type vt100 + (POSIX only) + +The --mode flag selects the haskeline Behavior; positional INPUT_ARG +selects which prompt function to use, and works with any --mode. --} +data Mode + = UseTerm -- ^ defaultBehavior + | UseTermHandles -- ^ useTermHandles on /dev/tty + | UseTermHandlesWith String -- ^ useTermHandlesWith TERM on /dev/tty + +data InputMode + = LineInput + | CharInput + | PasswordInput (Maybe Char) + | InitialInput + +data Opts = Opts { optMode :: Mode, optInput :: InputMode } + mySettings :: Settings IO mySettings = defaultSettings {historyFile = Just "myhist"} main :: IO () main = do - args <- getArgs - let inputFunc = case args of - ["chars"] -> fmap (fmap (\c -> [c])) . getInputChar - ["password"] -> getPassword Nothing - ["password", [c]] -> getPassword (Just c) - ["initial"] -> flip getInputLineWithInitial ("left ", "right") - _ -> getInputLine - runInputT mySettings $ withInterrupt $ loop inputFunc 0 - where - loop :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO () - loop inputFunc n = do - minput <- handleInterrupt (return (Just "Caught interrupted")) - $ inputFunc (show n ++ ":") - case minput of - Nothing -> return () - Just "quit" -> return () - Just "q" -> return () - Just s -> do - outputStrLn ("line " ++ show n ++ ":" ++ s) - loop inputFunc (n+1) + Opts {optMode = m, optInput = im} <- execParser optsInfo + case m of + UseTerm -> + runInputT mySettings (runAction im) +#ifndef MINGW + UseTermHandles -> + runWithHandles Nothing im + UseTermHandlesWith t -> + runWithHandles (Just t) im +#else + _ -> error "useTermHandles[With] is not available on Windows" +#endif + +runAction :: InputMode -> InputT IO () +runAction im = withInterrupt $ loop (inputFunc im) 0 + +inputFunc :: InputMode -> String -> InputT IO (Maybe String) +inputFunc LineInput = getInputLine +inputFunc CharInput = fmap (fmap (\c -> [c])) . getInputChar +inputFunc (PasswordInput mc) = getPassword mc +inputFunc InitialInput = flip getInputLineWithInitial ("left ", "right") + +loop :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO () +loop f n = do + minput <- handleInterrupt (return (Just "Caught interrupted")) + $ f (show n ++ ":") + case minput of + Nothing -> return () + Just "quit" -> return () + Just "q" -> return () + Just s -> do + outputStrLn ("line " ++ show n ++ ":" ++ s) + loop f (n+1) + +#ifndef MINGW +-- Drive Haskeline against /dev/tty (the controlling terminal) via the +-- useTermHandles[With] Behaviors. This still happens to be the controlling +-- tty in our test setup, but it goes through the new code path. +runWithHandles :: Maybe String -> InputMode -> IO () +runWithHandles mTerm im = do + input <- openFile "/dev/tty" ReadMode + output <- openFile "/dev/tty" WriteMode + let beh = case mTerm of + Nothing -> useTermHandles input output + Just t -> useTermHandlesWith t input output + runInputTBehavior beh mySettings (runAction im) + hClose input + hClose output +#endif + +---------------------------------------------------------------- +-- Command-line parsing + +optsInfo :: ParserInfo Opts +optsInfo = info (optsP <**> helper) + (fullDesc <> progDesc "Haskeline test program") + +optsP :: Parser Opts +optsP = Opts <$> modeP <*> inputModeP + +modeP :: Parser Mode +modeP = mkMode + <$> strOption + ( long "mode" + <> value "useTerm" + <> showDefault + <> metavar "MODE" + <> help "useTerm | useTermHandles | useTermHandlesWith" ) + <*> optional + (strOption + ( long "term-type" + <> metavar "TERM" + <> help "term type for --mode useTermHandlesWith" )) + where + mkMode "useTerm" _ = UseTerm + mkMode "useTermHandles" _ = UseTermHandles + mkMode "useTermHandlesWith" (Just t) = UseTermHandlesWith t + mkMode "useTermHandlesWith" Nothing = + error "--mode useTermHandlesWith requires --term-type" + mkMode other _ = + error ("unknown --mode: " ++ other) + +inputModeP :: Parser InputMode +inputModeP = mkInput <$> many (argument str (metavar "INPUT_ARG")) + where + mkInput [] = LineInput + mkInput ["chars"] = CharInput + mkInput ["password"] = PasswordInput Nothing + mkInput ["password", [c]] = PasswordInput (Just c) + mkInput ["initial"] = InitialInput + mkInput xs = + error ("unrecognized positional args: " ++ show xs) diff --git a/haskeline.cabal b/haskeline.cabal --- a/haskeline.cabal +++ b/haskeline.cabal @@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.10 -Version: 0.8.4.1 +Version: 0.8.5.0 Category: User Interfaces License: BSD3 License-File: LICENSE @@ -169,7 +169,7 @@ if !flag(examples) { buildable: False } - Build-depends: base, containers, haskeline + Build-depends: base, containers, haskeline, optparse-applicative Default-Language: Haskell2010 hs-source-dirs: examples Main-Is: Test.hs diff --git a/tests/RunTTY.hs b/tests/RunTTY.hs --- a/tests/RunTTY.hs +++ b/tests/RunTTY.hs @@ -23,11 +23,18 @@ data Invocation = Invocation { prog :: FilePath - , progArgs :: [String] + -- | Mode-selection flags passed before any positional args + -- (e.g. @[\"--mode\", \"useTermHandles\"]@). + , progModeArgs :: [String] + -- | Positional input-mode args (e.g. @[\"chars\"]@). + , progInputArgs :: [String] , runInTTY :: Bool , environment :: [(String,String)] } +progArgs :: Invocation -> [String] +progArgs Invocation{..} = progModeArgs ++ progInputArgs + setEnv :: String -> String -> Invocation -> Invocation setEnv var val Invocation {..} = Invocation{ environment = (var,val) : Prelude.filter ((/=var).fst) environment @@ -51,11 +58,11 @@ -- simulate real user input and prevent Haskeline -- from coalescing the changes.) -> IO [B.ByteString] -runInvocation Invocation {..} inputs - | runInTTY = runCommandInPty prog progArgs (Just environment) inputs +runInvocation inv@Invocation {..} inputs + | runInTTY = runCommandInPty prog (progArgs inv) (Just environment) inputs | otherwise = do (Just inH, Just outH, Nothing, ph) - <- createProcess (proc prog progArgs) + <- createProcess (proc prog (progArgs inv)) { env = Just environment , std_in = CreatePipe , std_out = CreatePipe diff --git a/tests/Unit.hs b/tests/Unit.hs --- a/tests/Unit.hs +++ b/tests/Unit.hs @@ -49,24 +49,55 @@ let i = setTerm "xterm" Invocation { prog = p, - progArgs = [], + progModeArgs = [], + progInputArgs = [], runInTTY = True, environment = [] } makeTestFiles - result <- runTestTT $ test [interactionTests i, fileStyleTests i] + result <- runTestTT $ test + [ interactionTests UseTerm i + , interactionTests UseTermHandles i + , interactionTests (UseTermHandlesWith "xterm") i + -- dumbTests sets TERM=dumb in env to drive Haskeline into the dumb + -- backend. That works for UseTerm and UseTermHandles (both consult + -- env), but not for UseTermHandlesWith — it ignores env and uses its + -- explicit term type — so we skip it for that mode. + , dumbTests UseTerm i + , dumbTests UseTermHandles i + , fileStyleTests i + ] when (errors result > 0 || failures result > 0) exitFailure -interactionTests :: Invocation -> Test -interactionTests i = "interaction" ~: test - [ unicodeEncoding i - , unicodeMovement i - , tabCompletion i - , incorrectInput i - , historyTests i - , inputChar $ setCharInput i - , dumbTests $ setTerm "dumb" i +-- | Which haskeline Behavior the test program should run under. +data Mode + = UseTerm -- ^ runInputT (defaultBehavior) + | UseTermHandles -- ^ useTermHandles on /dev/tty + | UseTermHandlesWith String -- ^ useTermHandlesWith TERM on /dev/tty + +modeName :: Mode -> String +modeName UseTerm = "useTerm" +modeName UseTermHandles = "useTermHandles" +modeName (UseTermHandlesWith t) = "useTermHandlesWith=" ++ t + +setMode :: Mode -> Invocation -> Invocation +setMode m i = i { progModeArgs = modeArgs m } + where + modeArgs UseTerm = [] + modeArgs UseTermHandles = ["--mode", "useTermHandles"] + modeArgs (UseTermHandlesWith t) = ["--mode", "useTermHandlesWith", "--term-type", t] + +interactionTests :: Mode -> Invocation -> Test +interactionTests m i = ("interaction (" ++ modeName m ++ ")") ~: test + [ unicodeEncoding ii + , unicodeMovement ii + , tabCompletion ii + , incorrectInput ii + , historyTests ii + , inputChar $ setCharInput ii ] + where + ii = setMode m i unicodeEncoding :: Invocation -> Test unicodeEncoding i = "Unicode encoding (valid)" ~: @@ -195,7 +226,7 @@ ] setCharInput :: Invocation -> Invocation -setCharInput i = i { progArgs = ["chars"] } +setCharInput i = i { progInputArgs = ["chars"] } fileStyleTests :: Invocation -> Test @@ -255,18 +286,18 @@ -- If all the above tests work for the terminfo backend, -- then we just need to make sure the dumb term plugs into everything -- correctly, i.e., encodes the input/output and doesn't double-encode. -dumbTests :: Invocation -> Test -dumbTests i = "dumb term" ~: - [ "line input" ~: utf8Test i +dumbTests :: Mode -> Invocation -> Test +dumbTests m i = ("dumb term (" ++ modeName m ++ ")") ~: + [ "line input" ~: utf8Test ii [ utf8 "xαβγy" ] [ prompt' 0, utf8 "xαβγy" ] - , "line input wide movement" ~: utf8Test i + , "line input wide movement" ~: utf8Test ii [ utf8 wideChar, raw [1], raw [5] ] [ prompt' 0, utf8 wideChar , utf8 (T.replicate 60 "\b") , utf8 wideChar ] - , "line char input" ~: utf8Test (setCharInput i) + , "line char input" ~: utf8Test (setCharInput ii) [utf8 "xαβ"] [ prompt' 0, utf8 "x" <> dumbnl <> output 0 (utf8 "x") <> prompt' 1 <> utf8 "α" <> dumbnl <> output 1 (utf8 "α") @@ -275,6 +306,7 @@ ] ] where + ii = setMode m $ setTerm "dumb" i dumbnl = raw [13,10] wideChar = T.concat $ replicate 10 $ "안기영"