diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,3 +1,85 @@ +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. + + * Internal refactoring of f, F, t, T commands to allow implementation of ; + and , commands. + +Changed in version 0.8.4.0: + + * On Windows, when terminal-style and printing output, no longer skips + `"\ESC...\STX"` sequences. (If used with legacy ConHost directly (for + example, `conhost.exe cmd.exe`), it will require ConHost's ANSI-capability + to be enabled separately.) (#126) + + * Added `System.Console.Haskeline.ReaderT` module for `ReaderT` interface. + + * `System.Console.Haskeline.Completion.listFiles` now returns a sorted list. + +Changed in version 0.8.3.0: + + * User preferences are now read from $XDG_CONFIG_HOME/haskeline/haskeline. + +Changed in version 0.8.2.1: + * Add `configure` check for `termios.h` and fallbacks for wasi. + +Changed in version 0.8.2: + * Add versions of `completeWord{,withPrev}` that take predicates for word break chars (#164) + +Changed in version 0.8.1.3: + * Use the capi calling convention for ioctl (#163). + +Changed in version 0.8.1.2: + * Add import list to Data.List (#153) + +Changed in version 0.8.1.1: + * Allow bytestring-0.11 and base-4.16 + * Fix name conflicts with Win32-2.9 (#145) + +Changed in version 0.8.1.0: + * Use grapheme's width to align a list of completions (#143) + * Add withRunInBase to help decompose InputT (#131) + * Add support for WINIO to haskeline. (#140) + * Allow base-4.15 + * Eta expand as required by simplified subsumption rules in newer GHC + * Remove unused iconv cbits (#135) + * Support non-BMP characters (or, surrogate pairs) on Windows (#125) + +Changed in version 0.8.0.1: + * Add a Cabal flag to disable the example executable as well as + the test that uses it. + +Changed in version 0.8.0.0: + * Breaking changes: + * Add a `MonadFail` instance for `InputT`. + * Switch the LICENSE file from BSD2 to BSD3, to be consistent + with the .cabal file. + * Backwards-compatible changes + * Improve the documentation around when input functions return + `Nothing`. + * Allow binding keys to incremental search, as + `ReverseSearchHistory` and `ForwardSearchHistory`. + * Handling `STX`-wrapped control sequences on any lines of the + prompt, not just the last one. + * Add `debugTerminalKeys` to help debug input problems + * Add `waitForAnyKey` to wait for a single key press. + * Define test targest in the .cabal file + * Bump the upper bound to base-4.15. + Changed in version 0.7.5.0: * Add the new function `fallbackCompletion` to combine multiple `CompletionFunc`s @@ -47,7 +129,7 @@ * Fix build on Windows. Changed in version 0.7.2.0: - * Bump upper-bound on base and filepath libraries to accomodate GHC HEAD (7.10) + * Bump upper-bound on base and filepath libraries to accommodate GHC HEAD (7.10) * Drop Cabal dependency to 1.10 * Use explicit forall syntax to avoid warning * Support Applicative/Monad proposal in Win32/Draw backend diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,23 +1,26 @@ -Copyright 2007-2009, Judah Jacobson. -All Rights Reserved. +Copyright 2007 Judah Jacobson Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -- Redistribution of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. -- Redistribution in binary form must reproduce the above copyright notice, +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. -THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY -EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +3. Neither the name of the copyright holder nor the names of its contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE -USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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 @@ -47,6 +51,7 @@ getInputLineWithInitial, getInputChar, getPassword, + waitForAnyKey, -- ** Outputting text -- $outputfncs outputStr, @@ -59,10 +64,12 @@ setComplete, -- ** User preferences Prefs(), + keyseqTimeoutMs, readPrefs, defaultPrefs, runInputTWithPrefs, runInputTBehaviorWithPrefs, + withRunInBase, -- ** History -- $history getHistory, @@ -73,8 +80,7 @@ Interrupt(..), handleInterrupt, -- * Additional submodules - module System.Console.Haskeline.Completion, - module System.Console.Haskeline.MonadException) + module System.Console.Haskeline.Completion) where import System.Console.Haskeline.LineState @@ -84,15 +90,17 @@ import System.Console.Haskeline.Prefs import System.Console.Haskeline.History import System.Console.Haskeline.Monads -import System.Console.Haskeline.MonadException import System.Console.Haskeline.InputT import System.Console.Haskeline.Completion import System.Console.Haskeline.Term import System.Console.Haskeline.Key import System.Console.Haskeline.RunCommand -import System.IO +import Control.Monad ((>=>)) +import Control.Monad.Catch (MonadMask, handle) import Data.Char (isSpace, isPrint) +import Data.Maybe (isJust) +import System.IO -- | A useful default. In particular: @@ -128,11 +136,13 @@ {- $inputfncs The following functions read one line or character of input from the user. -When using terminal-style interaction, these functions return 'Nothing' if the user -pressed @Ctrl-D@ when the input text was empty. +They return `Nothing` if they encounter the end of input. More specifically: -When using file-style interaction, these functions return 'Nothing' if -an @EOF@ was encountered before any characters were read. +- When using terminal-style interaction, they return `Nothing` if the user + pressed @Ctrl-D@ when the input text was empty. + +- When using file-style interaction, they return `Nothing` if an @EOF@ was + encountered before any characters were read. -} @@ -140,8 +150,13 @@ If @'autoAddHistory' == 'True'@ and the line input is nonblank (i.e., is not all spaces), it will be automatically added to the history. + +To include ANSI escape sequences in the input prompt, terminate them by @\STX@. +See for +more information. -} -getInputLine :: MonadException m => String -- ^ The input prompt +getInputLine :: (MonadIO m, MonadMask m) + => String -- ^ The input prompt -> InputT m (Maybe String) getInputLine = promptedInput (getInputCmdLine emptyIM) $ runMaybeT . getLocaleLine @@ -160,7 +175,7 @@ > getInputLineWithInitial "prompt> " ("left", "") -- The cursor starts at the end of the line. > getInputLineWithInitial "prompt> " ("left ", "right") -- The cursor starts before the second word. -} -getInputLineWithInitial :: MonadException m +getInputLineWithInitial :: (MonadIO m, MonadMask m) => String -- ^ The input prompt -> (String, String) -- ^ The initial value left and right of the cursor -> InputT m (Maybe String) @@ -169,7 +184,7 @@ where initialIM = insertString left $ moveToStart $ insertString right $ emptyIM -getInputCmdLine :: MonadException m => InsertMode -> TermOps -> String -> InputT m (Maybe String) +getInputCmdLine :: (MonadIO m, MonadMask m) => InsertMode -> TermOps -> Prefix -> InputT m (Maybe String) getInputCmdLine initialIM tops prefix = do emode <- InputT $ asks editMode result <- runInputCmdT tops $ case emode of @@ -202,7 +217,7 @@ When using file-style interaction, a newline will be read if it is immediately available after the input character. -} -getInputChar :: MonadException m => String -- ^ The input prompt +getInputChar :: (MonadIO m, MonadMask m) => String -- ^ The input prompt -> InputT m (Maybe Char) getInputChar = promptedInput getInputCmdChar $ \fops -> do c <- getPrintableChar fops @@ -216,18 +231,44 @@ Just False -> getPrintableChar fops _ -> return c -getInputCmdChar :: MonadException m => TermOps -> String -> InputT m (Maybe Char) +getInputCmdChar :: (MonadIO m, MonadMask m) => TermOps -> Prefix -> InputT m (Maybe Char) getInputCmdChar tops prefix = runInputCmdT tops $ runCommandLoop tops prefix acceptOneChar emptyIM acceptOneChar :: Monad m => KeyCommand m InsertMode (Maybe Char) acceptOneChar = choiceCmd [useChar $ \c s -> change (insertChar c) s >> return (Just c) - , ctrlChar 'l' +> clearScreenCmd >|> + , ctrlChar 'l' +> clearScreenCmd >=> keyCommand acceptOneChar , ctrlChar 'd' +> failCmd] ---------- +{- | Waits for one key to be pressed, then returns. Ignores the value +of the specific key. + +Returns 'True' if it successfully accepted one key. Returns 'False' +if it encountered the end of input; i.e., an @EOF@ in file-style interaction, +or a @Ctrl-D@ in terminal-style interaction. + +When using file-style interaction, consumes a single character from the input which may +be non-printable. +-} +waitForAnyKey :: (MonadIO m, MonadMask m) + => String -- ^ The input prompt + -> InputT m Bool +waitForAnyKey = promptedInput getAnyKeyCmd + $ \fops -> fmap isJust . runMaybeT $ getLocaleChar fops + +getAnyKeyCmd :: (MonadIO m, MonadMask m) => TermOps -> Prefix -> InputT m Bool +getAnyKeyCmd tops prefix = runInputCmdT tops + $ runCommandLoop tops prefix acceptAnyChar emptyIM + where + acceptAnyChar = choiceCmd + [ ctrlChar 'd' +> const (return False) + , KeyMap $ const $ Just (Consumed $ const $ return True) + ] + +---------- -- Passwords {- | Reads one line of input, without displaying the input while it is being typed. @@ -241,7 +282,7 @@ consoles (such as Cygwin or MSYS). -} -getPassword :: MonadException m => Maybe Char -- ^ A masking character; e.g., @Just \'*\'@ +getPassword :: (MonadIO m, MonadMask m) => Maybe Char -- ^ A masking character; e.g., @Just \'*\'@ -> String -> InputT m (Maybe String) getPassword x = promptedInput (\tops prefix -> runInputCmdT tops @@ -251,12 +292,12 @@ where loop = choiceCmd [ simpleChar '\n' +> finish , simpleKey Backspace +> change deletePasswordChar - >|> loop' - , useChar $ \c -> change (addPasswordChar c) >|> loop' + >=> loop' + , useChar $ \c -> change (addPasswordChar c) >=> loop' , ctrlChar 'd' +> \p -> if null (passwordState p) then failCmd p else finish p - , ctrlChar 'l' +> clearScreenCmd >|> loop' + , ctrlChar 'l' +> clearScreenCmd >=> loop' ] loop' = keyCommand loop @@ -273,7 +314,7 @@ -- | 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) +promptedInput :: MonadIO m => (TermOps -> Prefix -> InputT m a) -> (FileOps -> IO a) -> String -> InputT m a promptedInput doTerm doFile prompt = do @@ -286,16 +327,20 @@ putStrOut rterm prompt wrapFileInput fops $ doFile fops Left tops -> do + -- Convert the full prompt to graphemes (not just the last line) + -- to account for the `\ESC...STX` appearing anywhere in it. + let prompt' = stringToGraphemes prompt -- If the prompt contains newlines, print all but the last line. - let (lastLine,rest) = break (`elem` "\r\n") $ reverse prompt - outputStr $ reverse rest + let (lastLine,rest) = break (`elem` stringToGraphemes "\r\n") + $ reverse prompt' + outputStr $ graphemesToString $ reverse rest doTerm tops $ reverse lastLine {- | If Ctrl-C is pressed during the given action, throw an exception of type 'Interrupt'. For example: > tryAction :: InputT IO () -> tryAction = handle (\Interrupt -> outputStrLn "Cancelled.") +> tryAction = handleInterrupt (outputStrLn "Cancelled.") > $ withInterrupt $ someLongAction The action can handle the interrupt itself; a new 'Interrupt' exception will be thrown @@ -303,7 +348,7 @@ > tryAction :: InputT IO () > tryAction = withInterrupt loop -> where loop = handle (\Interrupt -> outputStrLn "Cancelled; try again." >> loop) +> where loop = handleInterrupt (outputStrLn "Cancelled; try again." >> loop) > someLongAction This behavior differs from GHC's built-in Ctrl-C handling, which @@ -311,21 +356,22 @@ Ctrl-C. -} -withInterrupt :: MonadException m => InputT m a -> InputT m a +withInterrupt :: (MonadIO m, MonadMask m) => InputT m a -> InputT m a withInterrupt act = do rterm <- InputT ask - liftIOOp_ (wrapInterrupt rterm) act + wrapInterrupt rterm act --- | Catch and handle an exception of type 'Interrupt'. +-- | Catch and handle an exception of type 'Interrupt'. See 'withInterrupt' for +-- more explanation. -- --- > handleInterrupt f = handle $ \Interrupt -> f -handleInterrupt :: MonadException m => m a -> m a -> m a +-- > handleInterrupt (outputStrLn "Ctrl+C was pressed, aborting!") someLongAction +handleInterrupt :: MonadMask m => m a -> m a -> m a handleInterrupt f = handle $ \Interrupt -> f {- | Return a printing function, which in terminal-style interactions is thread-safe and may be run concurrently with user input without affecting the prompt. -} -getExternalPrint :: MonadException m => InputT m (String -> IO ()) +getExternalPrint :: MonadIO m => InputT m (String -> IO ()) getExternalPrint = do rterm <- InputT ask return $ case termOps rterm of 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/DumbTerm.hs b/System/Console/Haskeline/Backend/DumbTerm.hs --- a/System/Console/Haskeline/Backend/DumbTerm.hs +++ b/System/Console/Haskeline/Backend/DumbTerm.hs @@ -9,6 +9,7 @@ import System.IO import Control.Applicative(Applicative) import Control.Monad(liftM) +import Control.Monad.Catch -- TODO: ---- Put "<" and ">" at end of term if scrolls off. @@ -21,7 +22,8 @@ initWindow = Window {pos=0} newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a} - deriving (Functor, Applicative, Monad, MonadIO, MonadException, + deriving (Functor, Applicative, Monad, MonadIO, + MonadThrow, MonadCatch, MonadMask, MonadState Window, MonadReader Handles) type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a @@ -35,9 +37,9 @@ runDumbTerm :: Handles -> MaybeT IO RunTerm runDumbTerm h = liftIO $ posixRunTerm h (posixLayouts h) [] id evalDumb -instance (MonadException m, MonadReader Layout m) => Term (DumbTerm m) where +instance (MonadIO m, MonadMask m, MonadReader Layout m) => Term (DumbTerm m) where reposition _ s = refitLine s - drawLineDiff = drawLineDiff' + drawLineDiff x y = drawLineDiff' x y printLines = mapM_ (printText . (++ crlf)) moveToNextLine _ = printText crlf 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE CApiFFI #-} + module System.Console.Haskeline.Backend.Posix ( withPosixGetEvent, posixLayouts, @@ -9,6 +11,7 @@ mapLines, stdinTTYHandles, ttyHandles, + explicitTTYHandles, posixRunTerm, fileRunTerm ) where @@ -17,17 +20,19 @@ import Foreign.C.Types import qualified Data.Map as Map import System.Posix.Terminal hiding (Interrupt) +import Control.Exception (throwTo) import Control.Monad +import Control.Monad.Catch (MonadMask, handle, finally) import Control.Concurrent.STM import Control.Concurrent hiding (throwTo) import Data.Maybe (catMaybes) import System.Posix.Signals.Exts import System.Posix.Types(Fd(..)) -import Data.List +import Data.Foldable (foldl') import System.IO import System.Environment -import System.Console.Haskeline.Monads hiding (Handler) +import System.Console.Haskeline.Monads import System.Console.Haskeline.Key import System.Console.Haskeline.Term as Term import System.Console.Haskeline.Prefs @@ -47,6 +52,8 @@ #endif #include +#include + ----------------------------------------------- -- Input/output handles data Handles = Handles {hIn, hOut :: ExternalHandle @@ -59,7 +66,11 @@ ------------------- -- Window size -foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt +#if !defined(HAVE_TERMIOS_H) +posixLayouts :: Handles -> [IO (Maybe Layout)] +posixLayouts _ = error "System.Console.Haskeline.Backend.Posix.posixLayouts" +#else +foreign import capi "sys/ioctl.h ioctl" ioctl :: FD -> CULong -> Ptr a -> IO CInt posixLayouts :: Handles -> [IO (Maybe Layout)] posixLayouts h = [ioctlLayout $ ehOut h, envLayout] @@ -74,6 +85,8 @@ then return $ Just Layout {height=fromEnum rows,width=fromEnum cols} else return Nothing +#endif + unsafeHandleToFD :: Handle -> IO FD unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h $ \Handle__{haDevice=dev} -> do @@ -137,7 +150,7 @@ -- Terminal.app: ,("\ESC[5D", ctrlKey $ simpleKey LeftKey) ,("\ESC[5C", ctrlKey $ simpleKey RightKey) - -- rxvt: (Note: these will be superceded by e.g. xterm-color, + -- rxvt: (Note: these will be superseded by e.g. xterm-color, -- which uses them as regular arrow keys.) ,("\ESC[OD", ctrlKey $ simpleKey LeftKey) ,("\ESC[OC", ctrlKey $ simpleKey RightKey) @@ -189,63 +202,138 @@ = 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 :: (MonadException m, MonadReader Prefs m) +withPosixGetEvent :: (MonadIO m, MonadMask m, MonadReader Prefs m) => TChan Event -> Handles -> [(String,Key)] -> (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 :: MonadException m => TChan Event -> m a -> m a +withWindowHandler :: (MonadIO m, MonadMask m) => TChan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ Catch $ atomically $ writeTChan eventChan WindowResize -withSigIntHandler :: MonadException m => m a -> m a +withSigIntHandler :: (MonadIO m, MonadMask m) => m a -> m a withSigIntHandler f = do tid <- liftIO myThreadId withHandler keyboardSignal (Catch (throwTo tid Interrupt)) f -withHandler :: MonadException m => Signal -> Handler -> m a -> m a +withHandler :: (MonadIO m, MonadMask m) => Signal -> Handler -> m a -> m a withHandler signal handler f = do 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 @@ -274,13 +362,22 @@ 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 -> [IO (Maybe Layout)] -> [(String,Key)] - -> (forall m b . MonadException m => m b -> m b) - -> (forall m . (MonadException m, CommandMonad m) => EvalTerm (PosixT m)) + -> (forall m b . (MonadIO m, MonadMask m) => m b -> m b) + -> (forall m . (MonadMask m, CommandMonad m) => EvalTerm (PosixT m)) -> IO RunTerm posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do ch <- newTChanIO @@ -336,7 +433,7 @@ -- 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 :: (MonadIO m, MonadMask m) => Handles -> m a -> m a wrapTerminalOps hs = bracketSet (hGetBuffering h_in) (hSetBuffering h_in) NoBuffering -- TODO: block buffering? Certain \r and \n's are causing flicker... @@ -344,8 +441,8 @@ -- - breaking line after offset widechar? . bracketSet (hGetBuffering h_out) (hSetBuffering h_out) LineBuffering . bracketSet (hGetEcho h_in) (hSetEcho h_in) False - . liftIOOp_ (withCodingMode $ hIn hs) - . liftIOOp_ (withCodingMode $ hOut hs) + . withCodingMode (hIn hs) + . 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 --- a/System/Console/Haskeline/Backend/Posix/Encoder.hs +++ b/System/Console/Haskeline/Backend/Posix/Encoder.hs @@ -13,6 +13,7 @@ openInCodingMode, ) where +import Control.Monad.Catch (MonadMask, bracket) import System.IO import System.Console.Haskeline.Monads @@ -41,13 +42,13 @@ -- | 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 :: (MonadIO m, MonadMask m) => ExternalHandle -> m a -> m a withCodingMode ExternalHandle {externalMode=CodingMode} act = act withCodingMode (ExternalHandle OtherMode h) act = do bracket (liftIO $ hGetEncoding h) (liftIO . hSetBinOrEncoding h) $ const $ do - hSetEncoding h haskelineEncoding + liftIO $ hSetEncoding h haskelineEncoding act hSetBinOrEncoding :: Handle -> Maybe TextEncoding -> IO () 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 @@ -1,4 +1,4 @@ -#if __GLASGOW_HASKELL__ <= 802 +#if __GLASGOW_HASKELL__ < 802 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif module System.Console.Haskeline.Backend.Terminfo( @@ -9,6 +9,7 @@ import System.Console.Terminfo import Control.Monad +import Control.Monad.Catch import Data.List(foldl') import System.IO import qualified Control.Exception as Exception @@ -105,7 +106,8 @@ (StateT TermRows (StateT TermPos (PosixT m))))) a} - deriving (Functor, Applicative, Monad, MonadIO, MonadException, + deriving (Functor, Applicative, Monad, MonadIO, + MonadMask, MonadThrow, MonadCatch, MonadReader Actions, MonadReader Terminal, MonadState TermPos, MonadState TermRows, MonadReader Handles) @@ -123,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 @@ -136,7 +138,7 @@ (evalDraw term actions) -- If the keypad on/off capabilities are defined, wrap the computation with them. -wrapKeypad :: MonadException m => Handle -> Terminal -> m a -> m a +wrapKeypad :: (MonadIO m, MonadMask m) => Handle -> Terminal -> m a -> m a wrapKeypad h term f = (maybeOutput keypadOn >> f) `finally` maybeOutput keypadOff where @@ -200,7 +202,7 @@ -- see GHC ticket #1749). outputText :: String -> ActionM () -outputText = output . const . termText +outputText s = output (const (termText s)) left,right,up :: Int -> TermAction left = flip leftA @@ -236,7 +238,7 @@ moveRelative :: Int -> ActionM () moveRelative n = liftM3 (advancePos n) ask get get - >>= moveToPos + >>= \p -> moveToPos p -- Note that these move by a certain number of cells, not graphemes. changeRight, changeLeft :: Int -> ActionM () @@ -349,7 +351,7 @@ put initTermRows drawLineDiffT ([],[]) s -instance (MonadException m, MonadReader Layout m) => Term (Draw m) where +instance (MonadIO m, MonadMask m, MonadReader Layout m) => Term (Draw m) where drawLineDiff xs ys = runActionT $ drawLineDiffT xs ys reposition layout lc = runActionT $ repositionT layout lc diff --git a/System/Console/Haskeline/Backend/WCWidth.hs b/System/Console/Haskeline/Backend/WCWidth.hs --- a/System/Console/Haskeline/Backend/WCWidth.hs +++ b/System/Console/Haskeline/Backend/WCWidth.hs @@ -10,10 +10,10 @@ import System.Console.Haskeline.LineState -import Data.List +import Data.List (foldl') import Foreign.C.Types -foreign import ccall unsafe haskeline_mk_wcwidth :: CWchar -> CInt +foreign import ccall unsafe haskeline_mk_wcwidth :: CInt -> CInt wcwidth :: Char -> Int wcwidth c = case haskeline_mk_wcwidth $ toEnum $ fromEnum c of diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc --- a/System/Console/Haskeline/Backend/Win32.hsc +++ b/System/Console/Haskeline/Backend/Win32.hsc @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module System.Console.Haskeline.Backend.Win32( win32Term, win32TermStdin, @@ -8,17 +10,41 @@ import System.IO import Foreign import Foreign.C +#if MIN_VERSION_Win32(2,14,1) +import System.Win32 hiding ( + multiByteToWideChar, + setConsoleMode, + getConsoleMode, + KeyEvent, + keyDown, + virtualKeyCode, + repeatCount, + virtualScanCode, + windowSize + ) +#elif MIN_VERSION_Win32(2,9,0) +import System.Win32 hiding (multiByteToWideChar, setConsoleMode, getConsoleMode) +#else import System.Win32 hiding (multiByteToWideChar) +#endif import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE) import Data.List(intercalate) import Control.Concurrent.STM import Control.Concurrent hiding (throwTo) -import Data.Char(isPrint) +import Data.Char(isPrint, chr, ord) import Data.Maybe(mapMaybe) +import Control.Exception (IOException, throwTo) import Control.Monad +import Control.Monad.Catch + ( MonadThrow + , MonadCatch + , MonadMask + , bracket + , handle + ) import System.Console.Haskeline.Key -import System.Console.Haskeline.Monads hiding (Handler) +import System.Console.Haskeline.Monads import System.Console.Haskeline.LineState import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.WCWidth @@ -58,8 +84,16 @@ then eventReader h else do es <- readEvents h - return $ mapMaybe processEvent es + return $ combineSurrogatePairs $ mapMaybe processEvent es +combineSurrogatePairs :: [Event] -> [Event] +combineSurrogatePairs (KeyInput [Key m1 (KeyChar c1)] : KeyInput [Key _ (KeyChar c2)] : es) + | 0xD800 <= ord c1 && ord c1 < 0xDC00 && 0xDC00 <= ord c2 && ord c2 < 0xE000 + = let c = (((ord c1 .&. 0x3FF) `shiftL` 10) .|. (ord c2 .&. 0x3FF)) + 0x10000 + in KeyInput [Key m1 (KeyChar (chr c))] : combineSurrogatePairs es +combineSurrogatePairs (e:es) = e : combineSurrogatePairs es +combineSurrogatePairs [] = [] + consoleHandles :: MaybeT IO Handles consoleHandles = do h_in <- open "CONIN$" @@ -122,7 +156,7 @@ unicodeChar :: Char, controlKeyState :: DWORD} -- TODO: WINDOW_BUFFER_SIZE_RECORD - -- I cant figure out how the user generates them. + -- I can't figure out how the user generates them. | WindowEvent | OtherEvent deriving Show @@ -169,9 +203,9 @@ sizeOf _ = (#size COORD) alignment _ = (#alignment COORD) peek p = do - x :: CShort <- (#peek COORD, X) p - y :: CShort <- (#peek COORD, Y) p - return Coord {coordX = fromEnum x, coordY = fromEnum y} + cx :: CShort <- (#peek COORD, X) p + cy :: CShort <- (#peek COORD, Y) p + return Coord {coordX = fromEnum cx, coordY = fromEnum cy} poke p c = do (#poke COORD, X) p (toEnum (coordX c) :: CShort) (#poke COORD, Y) p (toEnum (coordY c) :: CShort) @@ -218,10 +252,10 @@ -- To be safe, we pick a round number we know to be less than the limit. limit = 20000 -- known to be less than WriteConsoleW's buffer limit writeConsole' - = withArray (map (toEnum . fromEnum) xs) - $ \t_arr -> alloca $ \numWritten -> do + = withCWStringLen xs + $ \(t_arr, len) -> alloca $ \numWritten -> do failIfFalse_ "WriteConsoleW" - $ c_WriteConsoleW h t_arr (toEnum $ length xs) + $ c_WriteConsoleW h t_arr (toEnum len) numWritten nullPtr foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool @@ -239,7 +273,7 @@ foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode :: HANDLE -> DWORD -> IO Bool -withWindowMode :: MonadException m => Handles -> m a -> m a +withWindowMode :: (MonadIO m, MonadMask m) => Handles -> m a -> m a withWindowMode hs f = do let h = hIn hs bracket (getConsoleMode h) (setConsoleMode h) @@ -259,7 +293,8 @@ closeHandles hs = closeHandle (hIn hs) >> closeHandle (hOut hs) newtype Draw m a = Draw {runDraw :: ReaderT Handles m a} - deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadReader Handles) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader Handles, + MonadThrow, MonadCatch, MonadMask) type DrawM a = forall m . (MonadIO m, MonadReader Layout m) => Draw m a @@ -345,10 +380,8 @@ crlf :: String crlf = "\r\n" -instance (MonadException m, MonadReader Layout m) => Term (Draw m) where - drawLineDiff (xs1,ys1) (xs2,ys2) = let - fixEsc = filter ((/= '\ESC') . baseChar) - in drawLineDiffWin (fixEsc xs1, fixEsc ys1) (fixEsc xs2, fixEsc ys2) +instance (MonadMask m, MonadIO m, MonadReader Layout m) => Term (Draw m) where + drawLineDiff = drawLineDiffWin -- TODO now that we capture resize events. -- first, looks like the cursor stays on the same line but jumps -- to the beginning if cut off. @@ -391,7 +424,7 @@ closeHandles hs } -win32WithEvent :: MonadException m => Handles -> TChan Event +win32WithEvent :: MonadIO m => Handles -> TChan Event -> (m Event -> m a) -> m a win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan @@ -437,7 +470,7 @@ :: FunPtr Handler -> BOOL -> IO BOOL -- sets the tv to True when ctrl-c is pressed. -withCtrlCHandler :: MonadException m => m a -> m a +withCtrlCHandler :: (MonadMask m, MonadIO m) => m a -> m a withCtrlCHandler f = bracket (liftIO $ do tid <- myThreadId fp <- wrapHandler (handler tid) diff --git a/System/Console/Haskeline/Backend/Win32/Echo.hs b/System/Console/Haskeline/Backend/Win32/Echo.hs --- a/System/Console/Haskeline/Backend/Win32/Echo.hs +++ b/System/Console/Haskeline/Backend/Win32/Echo.hs @@ -4,9 +4,9 @@ import Control.Exception (throw) import Control.Monad (void) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.Catch (MonadMask, bracket) +import Control.Monad.IO.Class (MonadIO(..)) -import System.Console.Haskeline.MonadException (MonadException, bracket) import System.Exit (ExitCode(..)) import System.IO (Handle, hGetContents, hGetEcho, hSetEcho) import System.Process (StdStream(..), createProcess, shell, @@ -21,6 +21,10 @@ import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import GHC.IO.FD (FD(..)) +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.Handle.Windows (handleToHANDLE) +import GHC.IO.SubSystem (()) +#endif import GHC.IO.Handle.Types (Handle(..), Handle__(..)) import System.Win32.Types (HANDLE) @@ -67,7 +71,7 @@ -- ('liftIO' . 'hSetInputEchoState' input) -- (const action) -- @ -hBracketInputEcho :: MonadException m => Handle -> m a -> m a +hBracketInputEcho :: (MonadIO m, MonadMask m) => Handle -> m a -> m a hBracketInputEcho input action = bracket (liftIO $ hGetInputEchoState input) (liftIO . hSetInputEchoState input) @@ -76,7 +80,7 @@ -- | Perform a computation with the handle's input echoing disabled. Before -- running the computation, the handle's input 'EchoState' is saved, and the -- saved 'EchoState' is restored after the computation finishes. -hWithoutInputEcho :: MonadException m => Handle -> m a -> m a +hWithoutInputEcho :: (MonadIO m, MonadMask m) => Handle -> m a -> m a hWithoutInputEcho input action = do echo_off <- liftIO $ hEchoOff input hBracketInputEcho input @@ -145,11 +149,30 @@ -- Originally authored by Max Bolingbroke in the ansi-terminal library withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a -withHandleToHANDLE haskell_handle action = +#if defined(__IO_MANAGER_WINIO__) +withHandleToHANDLE = withHandleToHANDLEPosix withHandleToHANDLENative +#else +withHandleToHANDLE = withHandleToHANDLEPosix +#endif + +#if defined(__IO_MANAGER_WINIO__) +withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLENative haskell_handle action = -- Create a stable pointer to the Handle. This prevents the garbage collector -- getting to it while we are doing horrible manipulations with it, and hence -- stops it being finalized (and closed). withStablePtr haskell_handle $ const $ do + windows_handle <- handleToHANDLE haskell_handle + -- Do what the user originally wanted + action windows_handle +#endif + +withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLEPosix haskell_handle action = + -- Create a stable pointer to the Handle. This prevents the garbage collector + -- getting to it while we are doing horrible manipulations with it, and hence + -- stops it being finalized (and closed). + withStablePtr haskell_handle $ const $ do -- Grab the write handle variable from the Handle let write_handle_mvar = case haskell_handle of FileHandle _ handle_mvar -> handle_mvar @@ -162,7 +185,6 @@ -- Finally, turn that (C-land) FD into a HANDLE using msvcrt windows_handle <- c_get_osfhandle fd - -- Do what the user originally wanted action windows_handle diff --git a/System/Console/Haskeline/Command.hs b/System/Console/Haskeline/Command.hs --- a/System/Console/Haskeline/Command.hs +++ b/System/Console/Haskeline/Command.hs @@ -1,14 +1,13 @@ module System.Console.Haskeline.Command( -- * Commands Effect(..), - KeyMap(..), + KeyMap(..), CmdM(..), Command, KeyCommand, KeyConsumed(..), withoutConsuming, keyCommand, - (>|>), (>+>), try, effect, @@ -21,31 +20,32 @@ change, changeFromChar, (+>), + useKey, useChar, choiceCmd, keyChoiceCmd, keyChoiceCmdM, + doAfter, doBefore ) where import Data.Char(isPrint) -import Control.Applicative(Applicative(..)) -import Control.Monad(ap, mplus, liftM) +import Control.Monad(ap, mplus, liftM, (>=>)) import Control.Monad.Trans.Class import System.Console.Haskeline.LineState import System.Console.Haskeline.Key data Effect = LineChange (Prefix -> LineChars) - | PrintLines [String] - | ClearScreen - | RingBell + | PrintLines [String] + | ClearScreen + | RingBell lineChange :: LineState s => s -> Effect lineChange = LineChange . flip lineChars data KeyMap a = KeyMap {lookupKM :: Key -> Maybe (KeyConsumed a)} -data KeyConsumed a = NotConsumed a | Consumed a +data KeyConsumed a = NotConsumed a | Consumed a deriving Show instance Functor KeyMap where fmap f km = KeyMap $ fmap (fmap f) . lookupKM km @@ -55,10 +55,10 @@ fmap f (Consumed x) = Consumed (f x) -data CmdM m a = GetKey (KeyMap (CmdM m a)) - | DoEffect Effect (CmdM m a) - | CmdM (m (CmdM m a)) - | Result a +data CmdM m a = GetKey (KeyMap (CmdM m a)) + | DoEffect Effect (CmdM m a) + | CmdM (m (CmdM m a)) + | Result a type Command m s t = s -> CmdM m t @@ -93,7 +93,7 @@ -- TODO: could just be a monadic action that returns a Char. useChar :: (Char -> Command m s t) -> KeyCommand m s t useChar act = KeyMap $ \k -> case k of - Key m (KeyChar c) | isPrint c && m==noModifier + Key m (KeyChar c) | isPrint c && m == noModifier -> Just $ Consumed (act c) _ -> Nothing @@ -112,20 +112,22 @@ keyChoiceCmdM :: [KeyMap (CmdM m a)] -> CmdM m a keyChoiceCmdM = GetKey . choiceCmd -infixr 6 >|> -(>|>) :: Monad m => Command m s t -> Command m t u -> Command m s u -f >|> g = \x -> f x >>= g +doBefore :: Monad m => Command m s t -> KeyCommand m t u -> KeyCommand m s u +doBefore g km = fmap (g >=>) km +doAfter :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u +doAfter km g = fmap (>=> g) km + infixr 6 >+> (>+>) :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u -km >+> g = fmap (>|> g) km +(>+>) = doAfter -- attempt to run the command (predicated on getting a valid key); but if it fails, just keep -- going. try :: Monad m => KeyCommand m s s -> Command m s s try f = keyChoiceCmd [f,withoutConsuming return] -infixr 6 +> +infixr 0 +> (+>) :: Key -> a -> KeyMap a (+>) = useKey @@ -161,6 +163,3 @@ changeFromChar :: (LineState t, Monad m) => (Char -> s -> t) -> KeyCommand m s t changeFromChar f = useChar $ change . f - -doBefore :: Monad m => Command m s t -> KeyCommand m t u -> KeyCommand m s u -doBefore cmd = fmap (cmd >|>) diff --git a/System/Console/Haskeline/Command/Completion.hs b/System/Console/Haskeline/Command/Completion.hs --- a/System/Console/Haskeline/Command/Completion.hs +++ b/System/Console/Haskeline/Command/Completion.hs @@ -5,6 +5,7 @@ completionCmd ) where +import System.Console.Haskeline.Backend.WCWidth (gsWidth) import System.Console.Haskeline.Command import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.Key @@ -14,6 +15,7 @@ import System.Console.Haskeline.Completion import System.Console.Haskeline.Monads +import Control.Monad ((>=>)) import Data.List(transpose, unfoldr) useCompletion :: InsertMode -> Completion -> InsertMode @@ -34,7 +36,7 @@ -- | Create a 'Command' for word completion. completionCmd :: (MonadState Undo m, CommandMonad m) => Key -> KeyCommand m InsertMode InsertMode -completionCmd k = k +> saveForUndo >|> \oldIM -> do +completionCmd k = k +> saveForUndo >=> \oldIM -> do (rest,cs) <- askIMCompletions oldIM case cs of [] -> effect RingBell >> return oldIM @@ -58,7 +60,7 @@ menuCompletion k = loop where loop [] = setState - loop (c:cs) = change (const c) >|> try (k +> loop cs) + loop (c:cs) = change (const c) >=> try (k +> loop cs) makePartialCompletion :: InsertMode -> [Completion] -> InsertMode makePartialCompletion im completions = insertString partial im @@ -120,27 +122,26 @@ makeLines ws layout = let minColPad = 2 printWidth = width layout - maxLength = min printWidth (maximum (map length ws) + minColPad) - numCols = printWidth `div` maxLength - ls = if maxLength >= printWidth + maxWidth = min printWidth (maximum (map (gsWidth . stringToGraphemes) ws) + minColPad) + numCols = printWidth `div` maxWidth + ls = if maxWidth >= printWidth then map (: []) ws else splitIntoGroups numCols ws - in map (padWords maxLength) ls + in map (padWords maxWidth) ls --- Add spaces to the end of each word so that it takes up the given length. --- Don't padd the word in the last column, since printing a space in the last column +-- Add spaces to the end of each word so that it takes up the given visual width. +-- Don't pad the word in the last column, since printing a space in the last column -- causes a line wrap on some terminals. padWords :: Int -> [String] -> String padWords _ [x] = x padWords _ [] = "" -padWords len (x:xs) = x ++ replicate (len - glength x) ' ' - ++ padWords len xs +padWords wid (x:xs) = x ++ replicate (wid - widthOf x) ' ' + ++ padWords wid xs where - -- kludge: compute the length in graphemes, not chars. - -- but don't use graphemes for the max length, since I'm not convinced - -- that would work correctly. (This way, the worst that can happen is - -- that columns are longer than necessary.) - glength = length . stringToGraphemes + -- kludge: compute the width in graphemes, not chars. + -- also use graphemes for the max width so that multi-width characters + -- such as CJK letters are aligned correctly. + widthOf = gsWidth . stringToGraphemes -- Split xs into rows of length n, -- such that the list increases incrementally along the columns. diff --git a/System/Console/Haskeline/Command/History.hs b/System/Console/Haskeline/Command/History.hs --- a/System/Console/Haskeline/Command/History.hs +++ b/System/Console/Haskeline/Command/History.hs @@ -5,10 +5,11 @@ import System.Console.Haskeline.Key import Control.Monad(liftM,mplus) import System.Console.Haskeline.Monads -import Data.List +import Data.List (isPrefixOf, unfoldr) import Data.Maybe(fromMaybe) import System.Console.Haskeline.History import Data.IORef +import Control.Monad.Catch data HistLog = HistLog {pastHistory, futureHistory :: [[Grapheme]]} deriving Show @@ -16,7 +17,7 @@ prevHistoryM :: [Grapheme] -> HistLog -> Maybe ([Grapheme],HistLog) prevHistoryM _ HistLog {pastHistory = []} = Nothing prevHistoryM s HistLog {pastHistory=ls:past, futureHistory=future} - = Just (ls, + = Just (ls, HistLog {pastHistory=past, futureHistory= s:future}) prevHistories :: [Grapheme] -> HistLog -> [([Grapheme],HistLog)] @@ -27,7 +28,7 @@ histLog hist = HistLog {pastHistory = map stringToGraphemes $ historyLines hist, futureHistory = []} -runHistoryFromFile :: MonadException m => Maybe FilePath -> Maybe Int +runHistoryFromFile :: (MonadIO m, MonadMask m) => Maybe FilePath -> Maybe Int -> ReaderT (IORef History) m a -> m a runHistoryFromFile Nothing _ f = do historyRef <- liftIO $ newIORef emptyHistory @@ -44,7 +45,7 @@ return x prevHistory, firstHistory :: Save s => s -> HistLog -> (s, HistLog) -prevHistory s h = let (s',h') = fromMaybe (listSave s,h) +prevHistory s h = let (s',h') = fromMaybe (listSave s,h) $ prevHistoryM (listSave s) h in (listRestore s',h') @@ -72,7 +73,7 @@ modify reverser return y where - reverser h = HistLog {futureHistory=pastHistory h, + reverser h = HistLog {futureHistory=pastHistory h, pastHistory=futureHistory h} data SearchMode = SearchMode {searchTerm :: [Grapheme], @@ -83,13 +84,17 @@ data Direction = Forward | Reverse deriving (Show,Eq) +flipDir :: Direction -> Direction +flipDir Forward = Reverse +flipDir Reverse = Forward + directionName :: Direction -> String directionName Forward = "i-search" directionName Reverse = "reverse-i-search" instance LineState SearchMode where beforeCursor _ sm = beforeCursor prefix (foundHistory sm) - where + where prefix = stringToGraphemes ("(" ++ directionName (direction sm) ++ ")`") ++ searchTerm sm ++ stringToGraphemes "': " afterCursor = afterCursor . foundHistory @@ -104,14 +109,14 @@ startSearchMode dir im = SearchMode {searchTerm = [],foundHistory=im, direction=dir} addChar :: Char -> SearchMode -> SearchMode -addChar c s = s {searchTerm = listSave $ insertChar c +addChar c s = s {searchTerm = listSave $ insertChar c $ listRestore $ searchTerm s} searchHistories :: Direction -> [Grapheme] -> [([Grapheme],HistLog)] -> Maybe (SearchMode,HistLog) searchHistories dir text = foldr mplus Nothing . map findIt where - findIt (l,h) = do + findIt (l,h) = do im <- findInLine text l return (SearchMode text im dir,h) diff --git a/System/Console/Haskeline/Command/KillRing.hs b/System/Console/Haskeline/Command/KillRing.hs --- a/System/Console/Haskeline/Command/KillRing.hs +++ b/System/Console/Haskeline/Command/KillRing.hs @@ -38,55 +38,55 @@ pasteCommand :: (Save s, MonadState KillRing m, MonadState Undo m) => ([Grapheme] -> s -> s) -> Command m (ArgMode s) s pasteCommand use = \s -> do - ms <- liftM peek get + ms <- peek <$> get case ms of Nothing -> return $ argState s Just p -> do modify $ saveToUndo $ argState s setState $ applyArg (use p) s -deleteFromDiff' :: InsertMode -> InsertMode -> ([Grapheme],InsertMode) +deleteFromDiff' :: InsertMode -> InsertMode -> ([Grapheme], InsertMode) deleteFromDiff' (IMode xs1 ys1) (IMode xs2 ys2) | posChange >= 0 = (take posChange ys1, IMode xs1 ys2) - | otherwise = (take (negate posChange) ys2 ,IMode xs2 ys1) + | otherwise = (take (negate posChange) ys2, IMode xs2 ys1) where posChange = length xs2 - length xs1 killFromHelper :: (MonadState KillRing m, MonadState Undo m, Save s, Save t) => KillHelper -> Command m s t -killFromHelper helper = saveForUndo >|> \oldS -> do - let (gs,newIM) = applyHelper helper (save oldS) +killFromHelper helper = saveForUndo >=> \oldS -> do + let (gs, newIM) = applyHelper helper (save oldS) modify (push gs) setState (restore newIM) killFromArgHelper :: (MonadState KillRing m, MonadState Undo m, Save s, Save t) => KillHelper -> Command m (ArgMode s) t -killFromArgHelper helper = saveForUndo >|> \oldS -> do - let (gs,newIM) = applyArgHelper helper (fmap save oldS) +killFromArgHelper helper = saveForUndo >=> \oldS -> do + let (gs, newIM) = applyArgHelper helper (fmap save oldS) modify (push gs) setState (restore newIM) copyFromArgHelper :: (MonadState KillRing m, Save s) => KillHelper -> Command m (ArgMode s) s copyFromArgHelper helper = \oldS -> do - let (gs,_) = applyArgHelper helper (fmap save oldS) + let (gs, _) = applyArgHelper helper (fmap save oldS) modify (push gs) setState (argState oldS) data KillHelper = SimpleMove (InsertMode -> InsertMode) - | GenericKill (InsertMode -> ([Grapheme],InsertMode)) + | GenericKill (InsertMode -> ([Grapheme], InsertMode)) -- a generic kill gives more flexibility, but isn't repeatable. - -- for example: dd,cc, % + -- for example: dd, cc, % killAll :: KillHelper killAll = GenericKill $ \(IMode xs ys) -> (reverse xs ++ ys, emptyIM) -applyHelper :: KillHelper -> InsertMode -> ([Grapheme],InsertMode) +applyHelper :: KillHelper -> InsertMode -> ([Grapheme], InsertMode) applyHelper (SimpleMove move) im = deleteFromDiff' im (move im) applyHelper (GenericKill act) im = act im -applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme],InsertMode) +applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme], InsertMode) applyArgHelper (SimpleMove move) im = deleteFromDiff' (argState im) (applyArg move im) applyArgHelper (GenericKill act) im = act (argState im) diff --git a/System/Console/Haskeline/Command/Undo.hs b/System/Console/Haskeline/Command/Undo.hs --- a/System/Console/Haskeline/Command/Undo.hs +++ b/System/Console/Haskeline/Command/Undo.hs @@ -19,7 +19,7 @@ saveToUndo :: Save s => s -> Undo -> Undo saveToUndo s undo - | not isSame = Undo {pastUndo = toSave:pastUndo undo,futureRedo=[]} + | not isSame = Undo {pastUndo = toSave:pastUndo undo, futureRedo=[]} | otherwise = undo where toSave = save s @@ -39,7 +39,7 @@ saveForUndo :: (Save s, MonadState Undo m) - => Command m s s + => Command m s s saveForUndo s = do modify (saveToUndo s) return s @@ -47,4 +47,3 @@ commandUndo, commandRedo :: (MonadState Undo m, Save s) => Command m s s commandUndo = simpleCommand $ liftM Right . update . undoPast commandRedo = simpleCommand $ liftM Right . update . redoFuture - diff --git a/System/Console/Haskeline/Completion.hs b/System/Console/Haskeline/Completion.hs --- a/System/Console/Haskeline/Completion.hs +++ b/System/Console/Haskeline/Completion.hs @@ -6,7 +6,9 @@ fallbackCompletion, -- * Word completion completeWord, + completeWord', completeWordWithPrev, + completeWordWithPrev', completeQuotedWord, -- * Filename completion completeFilename, @@ -16,7 +18,7 @@ import System.FilePath -import Data.List(isPrefixOf) +import Data.List(isPrefixOf, sort) import Control.Monad(forM) import System.Console.Haskeline.Directory @@ -59,6 +61,14 @@ -> CompletionFunc m completeWord esc ws = completeWordWithPrev esc ws . const +-- | The same as 'completeWord' but takes a predicate for the whitespace characters +completeWord' :: Monad m => Maybe Char + -- ^ An optional escape character + -> (Char -> Bool) -- ^ Characters which count as whitespace + -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions + -> CompletionFunc m +completeWord' esc ws = completeWordWithPrev' esc ws . const + -- | A custom 'CompletionFunc' which completes the word immediately to the left of the cursor, -- and takes into account the line contents to the left of the word. -- @@ -71,16 +81,27 @@ -- line contents to the left of the word, reversed. The second argument is the word -- to be completed. -> CompletionFunc m -completeWordWithPrev esc ws f (line, _) = do +completeWordWithPrev esc ws = completeWordWithPrev' esc (`elem` ws) + +-- | The same as 'completeWordWithPrev' but takes a predicate for the whitespace characters +completeWordWithPrev' :: Monad m => Maybe Char + -- ^ An optional escape character + -> (Char -> Bool) -- ^ Characters which count as whitespace + -> (String -> String -> m [Completion]) + -- ^ Function to produce a list of possible completions. The first argument is the + -- line contents to the left of the word, reversed. The second argument is the word + -- to be completed. + -> CompletionFunc m +completeWordWithPrev' esc wpred f (line, _) = do let (word,rest) = case esc of - Nothing -> break (`elem` ws) line + Nothing -> break wpred line Just e -> escapedBreak e line completions <- f rest (reverse word) - return (rest,map (escapeReplacement esc ws) completions) + return (rest,map (escapeReplacement esc wpred) completions) where - escapedBreak e (c:d:cs) | d == e && c `elem` (e:ws) + escapedBreak e (c:d:cs) | d == e && (c == e || wpred c) = let (xs,ys) = escapedBreak e cs in (c:xs,ys) - escapedBreak e (c:cs) | notElem c ws + escapedBreak e (c:cs) | not $ wpred c = let (xs,ys) = escapedBreak e cs in (c:xs,ys) escapedBreak _ cs = ("",cs) @@ -105,12 +126,12 @@ setReplacement :: (String -> String) -> Completion -> Completion setReplacement f c = c {replacement = f $ replacement c} -escapeReplacement :: Maybe Char -> String -> Completion -> Completion -escapeReplacement esc ws f = case esc of +escapeReplacement :: Maybe Char -> (Char -> Bool) -> Completion -> Completion +escapeReplacement esc wpred f = case esc of Nothing -> f Just e -> f {replacement = escape e (replacement f)} where - escape e (c:cs) | c `elem` (e:ws) = e : c : escape e cs + escape e (c:cs) | c == e || wpred c = e : c : escape e cs | otherwise = c : escape e cs escape _ "" = "" @@ -127,7 +148,7 @@ = case splitAtQuote esc qs left of Just (w,rest) | isUnquoted esc qs rest -> do cs <- completer (reverse w) - return (rest, map (addQuotes . escapeReplacement esc qs) cs) + return (rest, map (addQuotes . escapeReplacement esc (`elem` qs)) cs) _ -> alterative line addQuotes :: Completion -> Completion @@ -165,7 +186,7 @@ -- get all of the files in that directory, as basenames allFiles <- if not dirExists then return [] - else fmap (map completion . filterPrefix) + else fmap (sort . map completion . filterPrefix) $ getDirectoryContents fixedDir -- The replacement text should include the directory part, and also -- have a trailing slash if it's itself a directory. diff --git a/System/Console/Haskeline/Emacs.hs b/System/Console/Haskeline/Emacs.hs --- a/System/Console/Haskeline/Emacs.hs +++ b/System/Console/Haskeline/Emacs.hs @@ -1,3 +1,6 @@ +#if __GLASGOW_HASKELL__ < 802 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif module System.Console.Haskeline.Emacs where import System.Console.Haskeline.Command @@ -10,10 +13,12 @@ import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT +import Control.Monad ((>=>)) +import Control.Monad.Catch (MonadMask) import Data.Char -type InputCmd s t = forall m . MonadException m => Command (InputCmdT m) s t -type InputKeyCmd s t = forall m . MonadException m => KeyCommand (InputCmdT m) s t +type InputCmd s t = forall m . (MonadIO m, MonadMask m) => Command (InputCmdT m) s t +type InputKeyCmd s t = forall m . (MonadIO m, MonadMask m) => KeyCommand (InputCmdT m) s t emacsCommands :: InputKeyCmd InsertMode (Maybe String) emacsCommands = choiceCmd [ @@ -28,7 +33,7 @@ deleteCharOrEOF s | s == emptyIM = return Nothing | otherwise = change deleteNext s >>= justDelete - justDelete = keyChoiceCmd [eotKey +> change deleteNext >|> justDelete + justDelete = keyChoiceCmd [eotKey +> change deleteNext >=> justDelete , emacsCommands] @@ -42,6 +47,8 @@ , completionCmd (simpleChar '\t') , simpleKey UpKey +> historyBack , simpleKey DownKey +> historyForward + , simpleKey SearchReverse +> searchForPrefix Reverse + , simpleKey SearchForward +> searchForPrefix Forward , searchHistory ] diff --git a/System/Console/Haskeline/IO.hs b/System/Console/Haskeline/IO.hs --- a/System/Console/Haskeline/IO.hs +++ b/System/Console/Haskeline/IO.hs @@ -42,6 +42,7 @@ import System.Console.Haskeline hiding (completeFilename) import Control.Concurrent +import Control.Exception (finally) import Control.Monad.IO.Class -- Providing a non-monadic API for haskeline 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 @@ -11,11 +11,14 @@ import System.Console.Haskeline.Backend import System.Console.Haskeline.Term -import System.Directory(getHomeDirectory) -import System.FilePath +import Control.Exception (IOException) +import Control.Monad.Catch +import Control.Monad.Fail as Fail import Control.Monad.Fix -import System.IO import Data.IORef +import System.Directory(getXdgDirectory, XdgDirectory(XdgConfig), doesFileExist, getHomeDirectory) +import System.FilePath +import System.IO -- | Application-specific customizations to the user interface. data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion. @@ -46,7 +49,8 @@ (ReaderT (IORef KillRing) (ReaderT Prefs (ReaderT (Settings m) m)))) a} - deriving (Functor, Applicative, Monad, MonadIO, MonadException) + deriving (Functor, Applicative, Monad, MonadIO, + MonadThrow, MonadCatch, MonadMask) -- NOTE: we're explicitly *not* making InputT an instance of our -- internal MonadState/MonadReader classes. Otherwise haddock -- displays those instances to the user, and it makes it seem like @@ -55,9 +59,33 @@ instance MonadTrans InputT where lift = InputT . lift . lift . lift . lift . lift +instance ( Fail.MonadFail m ) => Fail.MonadFail (InputT m) where + fail = lift . Fail.fail + instance ( MonadFix m ) => MonadFix (InputT m) where mfix f = InputT (mfix (unInputT . f)) +-- | Run an action in the underlying monad, as per 'lift', passing it a runner +-- function which restores the current 'InputT' context. This can be used in +-- the event that we have some function that takes an action in the underlying +-- monad as an argument (such as 'lift', 'hoist', 'forkIO', etc) and we want +-- to compose it with actions in 'InputT'. +withRunInBase :: Monad m => + ((forall a . InputT m a -> m a) -> m b) -> InputT m b +withRunInBase inner = InputT $ do + runTerm <- ask + history <- ask + killRing <- ask + prefs <- ask + settings <- ask + lift $ lift $ lift $ lift $ lift $ inner $ + flip runReaderT settings . + flip runReaderT prefs . + flip runReaderT killRing . + flip runReaderT history . + flip runReaderT runTerm . + unInputT + -- | Get the current line input history. getHistory :: MonadIO m => InputT m History getHistory = InputT get @@ -82,14 +110,14 @@ history <- get lift $ lift $ evalStateT' (histLog history) $ runUndoT $ evalStateT' layout f -instance MonadException m => CommandMonad (InputCmdT m) where +instance (MonadIO m, MonadMask m) => CommandMonad (InputCmdT m) where runCompletion lcs = do settings <- ask lift $ lift $ lift $ lift $ lift $ lift $ complete settings lcs -- | Run a line-reading application. Uses 'defaultBehavior' to determine the -- interaction behavior. -runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a +runInputTWithPrefs :: (MonadIO m, MonadMask m) => Prefs -> Settings m -> InputT m a -> m a runInputTWithPrefs = runInputTBehaviorWithPrefs defaultBehavior -- | Run a line-reading application. This function should suffice for most applications. @@ -101,7 +129,7 @@ -- If it uses terminal-style interaction, 'Prefs' will be read from the user's @~/.haskeline@ file -- (if present). -- If it uses file-style interaction, 'Prefs' are not relevant and will not be read. -runInputT :: MonadException m => Settings m -> InputT m a -> m a +runInputT :: (MonadIO m, MonadMask m) => Settings m -> InputT m a -> m a runInputT = runInputTBehavior defaultBehavior -- | Returns 'True' if the current session uses terminal-style interaction. (See 'Behavior'.) @@ -125,7 +153,7 @@ -- | Create and use a RunTerm, ensuring that it will be closed even if -- an async exception occurs during the creation or use. -withBehavior :: MonadException m => Behavior -> (RunTerm -> m a) -> m a +withBehavior :: (MonadIO m, MonadMask m) => Behavior -> (RunTerm -> m a) -> m a withBehavior (Behavior run) f = bracket (liftIO run) (liftIO . closeTerm) f -- | Run a line-reading application according to the given behavior. @@ -133,21 +161,21 @@ -- If it uses terminal-style interaction, 'Prefs' will be read from the -- user's @~/.haskeline@ file (if present). -- If it uses file-style interaction, 'Prefs' are not relevant and will not be read. -runInputTBehavior :: MonadException m => Behavior -> Settings m -> InputT m a -> m a +runInputTBehavior :: (MonadIO m, MonadMask m) => Behavior -> Settings m -> InputT m a -> m a runInputTBehavior behavior settings f = withBehavior behavior $ \run -> do prefs <- if isTerminalStyle run - then liftIO readPrefsFromHome + then liftIO readUserPrefs else return defaultPrefs execInputT prefs settings run f -- | Run a line-reading application. -runInputTBehaviorWithPrefs :: MonadException m +runInputTBehaviorWithPrefs :: (MonadIO m, MonadMask m) => Behavior -> Prefs -> Settings m -> InputT m a -> m a runInputTBehaviorWithPrefs behavior prefs settings f = withBehavior behavior $ flip (execInputT prefs settings) f -- | Helper function to feed the parameters into an InputT. -execInputT :: MonadException m => Prefs -> Settings m -> RunTerm +execInputT :: (MonadIO m, MonadMask m) => Prefs -> Settings m -> RunTerm -> InputT m a -> m a execInputT prefs settings run (InputT f) = runReaderT' settings $ runReaderT' prefs @@ -188,11 +216,78 @@ 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 --- | Read 'Prefs' from @~/.haskeline.@ If there is an error reading the file, +-- | 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, -- the 'defaultPrefs' will be returned. -readPrefsFromHome :: IO Prefs -readPrefsFromHome = handle (\(_::IOException) -> return defaultPrefs) $ do - home <- getHomeDirectory - readPrefs (home ".haskeline") +readUserPrefs :: IO Prefs +readUserPrefs = handle (\(_::IOException) -> return defaultPrefs) $ do + xdg <- getXdgDirectory XdgConfig ("haskeline/haskeline") + exists <- doesFileExist xdg + home <- getHomeDirectory + readPrefs (if exists then xdg else (home ".haskeline")) diff --git a/System/Console/Haskeline/Internal.hs b/System/Console/Haskeline/Internal.hs new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/Internal.hs @@ -0,0 +1,47 @@ +-- | A module containing semi-public internals. The functions here are not +-- stable. +module System.Console.Haskeline.Internal + ( 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 +import System.Console.Haskeline.InputT +import System.Console.Haskeline.LineState +import System.Console.Haskeline.Monads +import System.Console.Haskeline.RunCommand +import System.Console.Haskeline.Term +import System.Console.Haskeline.Key + +import Control.Monad ((>=>)) + +-- | This function may be used to debug Haskeline's input. +-- +-- It loops indefinitely; every time a key is pressed, it will +-- print that key as it was recognized by Haskeline. +-- Pressing Ctrl-C will stop the loop. +-- +-- Haskeline's behavior may be modified by editing your @~/.haskeline@ +-- file. For details, see: +-- +debugTerminalKeys :: IO a +debugTerminalKeys = runInputT defaultSettings $ do + outputStrLn + "Press any keys to debug Haskeline's input, or ctrl-c to exit:" + rterm <- InputT ask + case termOps rterm of + Right _ -> error "debugTerminalKeys: not run in terminal mode" + Left tops -> runInputCmdT tops $ runCommandLoop tops prompt + loop emptyIM + where + loop = KeyMap $ \k -> Just $ Consumed $ + (const $ do + effect (LineChange $ const ([],[])) + effect (PrintLines [show k]) + setState emptyIM) + >=> keyCommand loop + prompt = stringToGraphemes "> " 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,22 +8,30 @@ ctrlChar, metaKey, ctrlKey, - parseKey + parseKey, + setControlBits ) where +import Data.Bits import Data.Char -import Control.Monad import Data.Maybe -import Data.Bits +import Data.List (intercalate) +import Control.Monad data Key = Key Modifier BaseKey - deriving (Show,Eq,Ord) + deriving (Eq,Ord) +instance Show Key where + show (Key modifier base) + | modifier == noModifier = show base + | otherwise = show modifier ++ "-" ++ show base + data Modifier = Modifier {hasControl, hasMeta, hasShift :: Bool} deriving (Eq,Ord) instance Show Modifier where - show m = show $ catMaybes [maybeUse hasControl "ctrl" + show m = intercalate "-" + $ catMaybes [maybeUse hasControl "ctrl" , maybeUse hasMeta "meta" , maybeUse hasShift "shift" ] @@ -33,14 +41,41 @@ noModifier :: Modifier noModifier = Modifier False False False +-- Note: a few of these aren't really keys (e.g., KillLine), +-- but they provide useful enough binding points to include. data BaseKey = KeyChar Char | FunKey Int | LeftKey | RightKey | DownKey | UpKey - -- TODO: is KillLine really a key? | KillLine | Home | End | PageDown | PageUp | Backspace | Delete - deriving (Show,Eq,Ord) + | SearchReverse | SearchForward + deriving (Eq, Ord) +instance Show BaseKey where + show (KeyChar '\n') = "Return" + show (KeyChar '\t') = "Tab" + show (KeyChar '\ESC') = "Esc" + show (KeyChar c) + | isPrint c = [c] + | isPrint unCtrld = "ctrl-" ++ [unCtrld] + | otherwise = show c + where + unCtrld = toEnum (fromEnum c .|. ctrlBits) + show (FunKey n) = 'f' : show n + show LeftKey = "Left" + show RightKey = "Right" + show DownKey = "Down" + show UpKey = "Up" + show KillLine = "KillLine" + show Home = "Home" + show End = "End" + show PageDown = "PageDown" + show PageUp = "PageUp" + show Backspace = "Backspace" + show Delete = "Delete" + show SearchReverse = "SearchReverse" + show SearchForward = "SearchForward" + simpleKey :: BaseKey -> Key simpleKey = Key noModifier @@ -58,8 +93,11 @@ setControlBits :: Char -> Char setControlBits '?' = toEnum 127 -setControlBits c = toEnum $ fromEnum c .&. complement (bit 5 .|. bit 6) +setControlBits c = toEnum $ fromEnum c .&. complement ctrlBits +ctrlBits :: Int +ctrlBits = bit 5 .|. bit 6 + specialKeys :: [(String,BaseKey)] specialKeys = [("left",LeftKey) ,("right",RightKey) @@ -77,6 +115,8 @@ ,("tab",KeyChar '\t') ,("esc",KeyChar '\ESC') ,("escape",KeyChar '\ESC') + ,("reversesearchhistory",SearchReverse) + ,("forwardsearchhistory",SearchForward) ] parseModifiers :: [String] -> BaseKey -> Key diff --git a/System/Console/Haskeline/LineState.hs b/System/Console/Haskeline/LineState.hs --- a/System/Console/Haskeline/LineState.hs +++ b/System/Console/Haskeline/LineState.hs @@ -74,7 +74,7 @@ -- can represent one grapheme; for example, an @a@ followed by the diacritic @\'\\768\'@ should -- be treated as one unit. data Grapheme = Grapheme {gBaseChar :: Char, - combiningChars :: [Char]} + combiningChars :: [Char]} deriving Eq instance Show Grapheme where @@ -163,7 +163,7 @@ class Move s where goLeft, goRight, moveToStart, moveToEnd :: s -> s - + -- | The standard line state representation; considers the cursor to be located -- between two characters. The first list is reversed. data InsertMode = IMode [Grapheme] [Grapheme] @@ -181,7 +181,7 @@ restore = id instance Move InsertMode where - goLeft im@(IMode [] _) = im + goLeft im@(IMode [] _) = im goLeft (IMode (x:xs) ys) = IMode xs (x:ys) goRight im@(IMode _ []) = im @@ -194,7 +194,7 @@ emptyIM = IMode [] [] -- | Insert one character, which may be combining, to the left of the cursor. --- +-- insertChar :: Char -> InsertMode -> InsertMode insertChar c im@(IMode xs ys) | isCombiningChar c = case xs of @@ -203,7 +203,7 @@ z:zs -> IMode (addCombiner z c : zs) ys | otherwise = IMode (baseGrapheme c : xs) ys --- | Insert a sequence of characters to the left of the cursor. +-- | Insert a sequence of characters to the left of the cursor. insertString :: String -> InsertMode -> InsertMode insertString s (IMode xs ys) = IMode (reverse (stringToGraphemes s) ++ xs) ys @@ -212,12 +212,12 @@ deleteNext (IMode xs (_:ys)) = IMode xs ys deletePrev im@(IMode [] _) = im -deletePrev (IMode (_:xs) ys) = IMode xs ys +deletePrev (IMode (_:xs) ys) = IMode xs ys skipLeft, skipRight :: (Char -> Bool) -> InsertMode -> InsertMode -skipLeft f (IMode xs ys) = let (ws,zs) = span (f . baseChar) xs +skipLeft f (IMode xs ys) = let (ws,zs) = span (f . baseChar) xs in IMode zs (reverse ws ++ ys) -skipRight f (IMode xs ys) = let (ws,zs) = span (f . baseChar) ys +skipRight f (IMode xs ys) = let (ws,zs) = span (f . baseChar) ys in IMode (reverse ws ++ xs) zs transposeChars :: InsertMode -> InsertMode @@ -326,7 +326,7 @@ instance LineState s => LineState (ArgMode s) where beforeCursor _ am = let pre = map baseGrapheme $ "(arg: " ++ show (arg am) ++ ") " - in beforeCursor pre (argState am) + in beforeCursor pre (argState am) afterCursor = afterCursor . argState instance Result s => Result (ArgMode s) where @@ -342,15 +342,15 @@ addNum :: Int -> ArgMode s -> ArgMode s addNum n am | arg am >= 1000 = am -- shouldn't ever need more than 4 digits - | otherwise = am {arg = arg am * 10 + n} + | otherwise = am {arg = arg am * 10 + n} --- todo: negatives +-- TODO: negatives applyArg :: (s -> s) -> ArgMode s -> s applyArg f am = repeatN (arg am) f (argState am) repeatN :: Int -> (a -> a) -> a -> a repeatN n f | n <= 1 = f - | otherwise = f . repeatN (n-1) f + | otherwise = f . repeatN (n-1) f applyCmdArg :: (InsertMode -> InsertMode) -> ArgMode CommandMode -> CommandMode applyCmdArg f am = withCommandMode (repeatN (arg am) f) (argState am) @@ -406,10 +406,9 @@ goRightUntil, goLeftUntil :: (InsertMode -> Bool) -> InsertMode -> InsertMode goRightUntil f = loop . goRight where - loop im@(IMode _ ys) | null ys || f im = im + loop im@(IMode _ ys) | null ys || f im = im | otherwise = loop (goRight im) goLeftUntil f = loop . goLeft where - loop im@(IMode xs _) | null xs || f im = im - | otherwise = loop (goLeft im) - + loop im@(IMode xs _) | null xs || f im = im + | otherwise = loop (goLeft im) diff --git a/System/Console/Haskeline/MonadException.hs b/System/Console/Haskeline/MonadException.hs deleted file mode 100644 --- a/System/Console/Haskeline/MonadException.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -{- | This module redefines some of the functions in "Control.Exception" to -work for more general monads built on top of 'IO'. --} - -module System.Console.Haskeline.MonadException( - -- * The MonadException class - MonadException(..), - -- * Generalizations of Control.Exception - catch, - handle, - catches, - Handler(..), - finally, - throwIO, - throwTo, - bracket, - -- * Helpers for defining \"wrapper\" functions - liftIOOp, - liftIOOp_, - -- * Internal implementation - RunIO(..), - -- * Extensible Exceptions - Exception, - SomeException(..), - E.IOException(), - ) - where - -import qualified Control.Exception as E -import Control.Exception (Exception,SomeException) -import Control.Monad(liftM, join) -import Control.Monad.IO.Class -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Error -import Control.Monad.Trans.List -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.RWS -import Control.Monad.Trans.Writer -import Control.Concurrent(ThreadId) - --- This approach is based on that of the monad-control package. --- Since we want to use haskeline to bootstrap GHC, we reimplement --- a simplified version here. --- Additionally, we avoid TypeFamilies (which are used in the latest version of --- monad-control) so that we're still compatible with older versions of GHC. - --- | A 'RunIO' function takes a monadic action @m@ as input, --- and outputs an IO action which performs the underlying impure part of @m@ --- and returns the ''pure'' part of @m@. --- --- Note that @(RunIO return)@ is an incorrect implementation, since it does not --- separate the pure and impure parts of the monadic action. This module defines --- implementations for several common monad transformers. -newtype RunIO m = RunIO (forall b . m b -> IO (m b)) --- Uses a newtype so we don't need RankNTypes. - --- | An instance of 'MonadException' is generally made up of monad transformers --- layered on top of the IO monad. --- --- The 'controlIO' method enables us to \"lift\" a function that manages IO actions (such --- as 'bracket' or 'catch') into a function that wraps arbitrary monadic actions. -class MonadIO m => MonadException m where - controlIO :: (RunIO m -> IO (m a)) -> m a - --- | Lift a IO operation --- --- > wrap :: (a -> IO b) -> IO b --- --- to a more general monadic operation --- --- > liftIOOp wrap :: MonadException m => (a -> m b) -> m b --- --- For example: --- --- @ --- 'liftIOOp' ('System.IO.withFile' f m) :: MonadException m => (Handle -> m r) -> m r --- 'liftIOOp' 'Foreign.Marshal.Alloc.alloca' :: (MonadException m, Storable a) => (Ptr a -> m b) -> m b --- 'liftIOOp' (`Foreign.ForeignPtr.withForeignPtr` fp) :: MonadException m => (Ptr a -> m b) -> m b --- @ -liftIOOp :: MonadException m => ((a -> IO (m b)) -> IO (m c)) -> (a -> m b) -> m c -liftIOOp f g = controlIO $ \(RunIO run) -> f (run . g) - --- | Lift an IO operation --- --- > wrap :: IO a -> IO a --- --- to a more general monadic operation --- --- > liftIOOp_ wrap :: MonadException m => m a -> m a -liftIOOp_ :: MonadException m => (IO (m a) -> IO (m a)) -> m a -> m a -liftIOOp_ f act = controlIO $ \(RunIO run) -> f (run act) - - -catch :: (MonadException m, E.Exception e) => m a -> (e -> m a) -> m a -catch act handler = controlIO $ \(RunIO run) -> E.catch - (run act) - (run . handler) - -handle :: (MonadException m, Exception e) => (e -> m a) -> m a -> m a -handle = flip catch - -catches :: (MonadException m) => m a -> [Handler m a] -> m a -catches act handlers = controlIO $ \(RunIO run) -> - let catchesHandler e = foldr tryHandler (E.throw e) handlers - where tryHandler (Handler handler) res = - case E.fromException e of - Just e' -> run $ handler e' - Nothing -> res - in E.catch (run act) catchesHandler - -data Handler m a = forall e . Exception e => Handler (e -> m a) - - -bracket :: MonadException m => m a -> (a -> m b) -> (a -> m c) -> m c -bracket before after thing - = controlIO $ \(RunIO run) -> E.bracket - (run before) - (\m -> run (m >>= after)) - (\m -> run (m >>= thing)) - -finally :: MonadException m => m a -> m b -> m a -finally thing ender = controlIO $ \(RunIO run) -> E.finally (run thing) (run ender) - -throwIO :: (MonadIO m, Exception e) => e -> m a -throwIO = liftIO . E.throwIO - -throwTo :: (MonadIO m, Exception e) => ThreadId -> e -> m () -throwTo tid = liftIO . E.throwTo tid - ----------- --- Instances of MonadException. --- Since implementations of this class are non-obvious to a casual user, --- we provide instances for nearly everything in the transformers package. - -instance MonadException IO where - controlIO f = join $ f (RunIO (liftM return)) - -- Note: it's crucial that we use "liftM return" instead of "return" here. - -- For example, in "finally thing end", this ensures that "end" will always run, - -- regardless of whether an mzero occurred inside of "thing". - -instance MonadException m => MonadException (ReaderT r m) where - controlIO f = ReaderT $ \r -> controlIO $ \(RunIO run) -> let - run' = RunIO (fmap (ReaderT . const) . run . flip runReaderT r) - in fmap (flip runReaderT r) $ f run' - -instance MonadException m => MonadException (StateT s m) where - controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let - run' = RunIO (fmap (StateT . const) . run . flip runStateT s) - in fmap (flip runStateT s) $ f run' - -instance MonadException m => MonadException (MaybeT m) where - controlIO f = MaybeT $ controlIO $ \(RunIO run) -> let - run' = RunIO (fmap MaybeT . run . runMaybeT) - in fmap runMaybeT $ f run' - -instance (MonadException m, Error e) => MonadException (ErrorT e m) where - controlIO f = ErrorT $ controlIO $ \(RunIO run) -> let - run' = RunIO (fmap ErrorT . run . runErrorT) - in fmap runErrorT $ f run' - -instance MonadException m => MonadException (ListT m) where - controlIO f = ListT $ controlIO $ \(RunIO run) -> let - run' = RunIO (fmap ListT . run . runListT) - in fmap runListT $ f run' - -instance (Monoid w, MonadException m) => MonadException (WriterT w m) where - controlIO f = WriterT $ controlIO $ \(RunIO run) -> let - run' = RunIO (fmap WriterT . run . runWriterT) - in fmap runWriterT $ f run' - -instance (Monoid w, MonadException m) => MonadException (RWST r w s m) where - controlIO f = RWST $ \r s -> controlIO $ \(RunIO run) -> let - run' = RunIO (fmap (\act -> RWST (\_ _ -> act)) - . run . (\m -> runRWST m r s)) - in fmap (\m -> runRWST m r s) $ f run' - -deriving instance MonadException m => MonadException (IdentityT m) diff --git a/System/Console/Haskeline/Monads.hs b/System/Console/Haskeline/Monads.hs --- a/System/Console/Haskeline/Monads.hs +++ b/System/Console/Haskeline/Monads.hs @@ -1,5 +1,4 @@ module System.Console.Haskeline.Monads( - module System.Console.Haskeline.MonadException, MonadTrans(..), MonadIO(..), ReaderT, @@ -21,16 +20,17 @@ orElse ) where -import Control.Applicative (Applicative(..)) -import Control.Monad (ap, liftM) +import Control.Monad (liftM) +import Control.Monad.Catch () import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Maybe (MaybeT(MaybeT),runMaybeT) import Control.Monad.Trans.Reader hiding (ask,asks) import qualified Control.Monad.Trans.Reader as Reader -import Data.IORef +import Control.Monad.Trans.State.Strict hiding (get, put, gets, modify) +import qualified Control.Monad.Trans.State.Strict as State -import System.Console.Haskeline.MonadException +import Data.IORef class Monad m => MonadReader r m where ask :: m r @@ -68,46 +68,9 @@ runReaderT' :: r -> ReaderT r m a -> m a runReaderT' = flip runReaderT -newtype StateT s m a = StateT { getStateTFunc - :: forall r . s -> m ((a -> s -> r) -> r)} - -instance Monad m => Functor (StateT s m) where - fmap = liftM - -instance Monad m => Applicative (StateT s m) where - pure x = StateT $ \s -> return $ \f -> f x s - (<*>) = ap - -instance Monad m => Monad (StateT s m) where - return = pure - StateT f >>= g = StateT $ \s -> do - useX <- f s - useX $ \x s' -> getStateTFunc (g x) s' - -instance MonadTrans (StateT s) where - lift m = StateT $ \s -> do - x <- m - return $ \f -> f x s - -instance MonadIO m => MonadIO (StateT s m) where - liftIO = lift . liftIO - -mapStateT :: (forall b . m b -> n b) -> StateT s m a -> StateT s n a -mapStateT f (StateT m) = StateT (\s -> f (m s)) - -runStateT :: Monad m => StateT s m a -> s -> m (a, s) -runStateT f s = do - useXS <- getStateTFunc f s - return $ useXS $ \x s' -> (x,s') - -makeStateT :: Monad m => (s -> m (a,s)) -> StateT s m a -makeStateT f = StateT $ \s -> do - (x,s') <- f s - return $ \g -> g x s' - instance Monad m => MonadState s (StateT s m) where - get = StateT $ \s -> return $ \f -> f s s - put s = s `seq` StateT $ \_ -> return $ \f -> f () s + get = State.get + put x = State.put $! x instance {-# OVERLAPPABLE #-} (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where @@ -121,15 +84,7 @@ put s = ask >>= liftIO . flip writeIORef s evalStateT' :: Monad m => s -> StateT s m a -> m a -evalStateT' s f = liftM fst $ runStateT f s - -instance MonadException m => MonadException (StateT s m) where - controlIO f = makeStateT $ \s -> controlIO $ \run -> - fmap (flip runStateT s) $ f $ stateRunIO s run - where - stateRunIO :: s -> RunIO m -> RunIO (StateT s m) - stateRunIO s (RunIO run) = RunIO (\m -> fmap (makeStateT . const) - $ run (runStateT m s)) +evalStateT' = flip evalStateT orElse :: Monad m => MaybeT m a -> m a -> m a orElse (MaybeT f) g = f >>= maybe g return 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 @@ -9,10 +9,12 @@ lookupKeyBinding ) where +import Control.Monad.Catch (handle) +import Control.Exception (IOException) import Data.Char(isSpace,toLower) import Data.List(foldl') import qualified Data.Map as Map -import System.Console.Haskeline.MonadException(handle,IOException) +import Data.Word (Word) import System.Console.Haskeline.Key {- | @@ -47,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 @@ -76,7 +87,8 @@ listCompletionsImmediately = True, historyDuplicates = AlwaysAdd, customBindings = Map.empty, - customKeySequences = [] + customKeySequences = [], + keyseqTimeoutMs = 50 } mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs @@ -97,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/System/Console/Haskeline/ReaderT.hs b/System/Console/Haskeline/ReaderT.hs new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/ReaderT.hs @@ -0,0 +1,133 @@ +-- | Provides an interface for 'ReaderT' rather than 'InputT'. +-- +-- @since 0.8.4.0 +module System.Console.Haskeline.ReaderT + ( -- * ReaderT + -- $reader + toReaderT, + fromReaderT, + InputTEnv, + mapInputTEnv, + ) where + +import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT)) +import Data.IORef (IORef) +import System.Console.Haskeline.Command.KillRing (KillRing) +import System.Console.Haskeline.History (History) +import System.Console.Haskeline.InputT( + InputT(InputT), + Settings( + Settings, + autoAddHistory, + complete, + historyFile + ) + ) +import System.Console.Haskeline.Prefs (Prefs) +import System.Console.Haskeline.Term (RunTerm) + + +-- $reader +-- +-- These functions expose the 'InputT' type in terms of ordinary 'ReaderT'. +-- This allows for easier integration with applications that do not use a +-- concrete monad transformer stack, or do not want to commit to having +-- 'InputT' in the stack. + +-- | The abstract environment used by 'InputT', for 'ReaderT' +-- usage. +-- +-- @since 0.8.4.0 +data InputTEnv m = MkInputTEnv + { runTerm :: RunTerm, + history :: IORef History, + killRing :: IORef KillRing, + prefs :: Prefs, + settings :: Settings m + } + +-- | Maps the environment. +-- +-- @since 0.8.4.0 +mapInputTEnv :: (forall x. m x -> n x) -> InputTEnv m -> InputTEnv n +mapInputTEnv f (MkInputTEnv t h k p s) = + MkInputTEnv + { runTerm = t, + history = h, + killRing = k, + prefs = p, + settings = settings' + } + where + settings' = Settings + { complete = f . complete s, + historyFile = historyFile s, + autoAddHistory = autoAddHistory s + } + +-- | Maps an 'InputT' to a 'ReaderT'. Useful for lifting 'InputT' functions +-- into some other reader-like monad. +-- +-- __Examples:__ +-- +-- @ +-- import System.Console.Haskeline qualified as H +-- +-- runApp :: ReaderT (InputTEnv IO) IO () +-- runApp = do +-- input <- toReaderT (H.getInputLine "Enter your name: ") +-- ... +-- @ +-- +-- @ +-- -- MTL-style polymorphism +-- class MonadHaskeline m where +-- getInputLine :: String -> m (Maybe String) +-- +-- -- AppT is the core type over ReaderT. +-- instance MonadHaskeline (AppT m) where +-- getInputLine = lift . toReaderT . H.getInputLine +-- +-- runApp :: (MonadHaskeline m) => m () +-- runApp = do +-- input <- getInputLine "Enter your name: " +-- ... +-- @ +-- +-- @since 0.8.4.0 +toReaderT :: InputT m a -> ReaderT (InputTEnv m) m a +toReaderT (InputT rdr) = ReaderT $ \st -> + usingReaderT (settings st) + . usingReaderT (prefs st) + . usingReaderT (killRing st) + . usingReaderT (history st) + . usingReaderT (runTerm st) + $ rdr + +-- | Maps a 'ReaderT' to an 'InputT'. Allows defining an application in terms +-- of 'ReaderT'. +-- +-- __Examples:__ +-- +-- @ +-- import System.Console.Haskeline qualified as H +-- +-- -- Could be generalized to MonadReader, effects libraries. +-- runApp :: ReaderT (InputTEnv IO) IO () +-- +-- main :: IO () +-- main = H.runInputT H.defaultSettings $ fromReaderT runApp +-- @ +-- +-- @since 0.8.4.0 +fromReaderT :: ReaderT (InputTEnv m) m a -> InputT m a +fromReaderT (ReaderT onEnv) = InputT $ ReaderT + $ \runTerm' -> ReaderT + $ \history' -> ReaderT + $ \killRing' -> ReaderT + $ \prefs' -> ReaderT + $ \settings' -> + onEnv (MkInputTEnv runTerm' history' killRing' prefs' settings') + +usingReaderT :: env -> ReaderT env m a -> m a +usingReaderT = flip runReaderT diff --git a/System/Console/Haskeline/RunCommand.hs b/System/Console/Haskeline/RunCommand.hs --- a/System/Console/Haskeline/RunCommand.hs +++ b/System/Console/Haskeline/RunCommand.hs @@ -7,16 +7,18 @@ import System.Console.Haskeline.Prefs import System.Console.Haskeline.Key +import Control.Exception (SomeException) import Control.Monad +import Control.Monad.Catch (handle, throwM) runCommandLoop :: (CommandMonad m, MonadState Layout m, LineState s) - => TermOps -> String -> KeyCommand m s a -> s -> m a + => TermOps -> Prefix -> KeyCommand m s a -> s -> m a runCommandLoop tops@TermOps{evalTerm = e} prefix cmds initState = case e of -- NB: Need to separate this case out from the above pattern -- in order to build on ghc-6.12.3 EvalTerm eval liftE -> eval $ withGetEvent tops - $ runCommandLoop' liftE tops (stringToGraphemes prefix) initState + $ runCommandLoop' liftE tops prefix initState cmds runCommandLoop' :: forall m n s a . (Term n, CommandMonad n, @@ -30,10 +32,10 @@ where readMoreKeys :: LineChars -> KeyMap (CmdM m (a,[Key])) -> n a readMoreKeys s next = do - event <- handle (\(e::SomeException) -> moveToNextLine s - >> throwIO e) getEvent + event <- handle (\(e::SomeException) -> moveToNextLine s >> throwM e) + getEvent case event of - ErrorEvent e -> moveToNextLine s >> throwIO e + ErrorEvent e -> moveToNextLine s >> throwM e WindowResize -> do drawReposition liftE tops s readMoreKeys s next diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs --- a/System/Console/Haskeline/Term.hs +++ b/System/Console/Haskeline/Term.hs @@ -8,6 +8,14 @@ import Control.Concurrent import Control.Concurrent.STM +import Control.Exception (Exception, SomeException(..)) +import Control.Monad.Catch + ( MonadMask + , bracket + , handle + , throwM + , finally + ) import Data.Word import Control.Exception (fromException, AsyncException(..)) import Data.Typeable @@ -17,7 +25,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC -class (MonadReader Layout m, MonadException m) => Term m where +class (MonadReader Layout m, MonadIO m, MonadMask m) => Term m where reposition :: Layout -> LineChars -> m () moveToNextLine :: LineChars -> m () printLines :: [String] -> m () @@ -34,7 +42,7 @@ -- | Write unicode characters to stdout. putStrOut :: String -> IO (), termOps :: Either TermOps FileOps, - wrapInterrupt :: forall a . IO a -> IO a, + wrapInterrupt :: forall a m . (MonadIO m, MonadMask m) => m a -> m a, closeTerm :: IO () } @@ -68,7 +76,7 @@ -- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline -- are "wrapped" by wrapFileInput. data FileOps = FileOps { - withoutInputEcho :: forall m a . MonadException m => m a -> m a, + withoutInputEcho :: forall m a . (MonadIO m, MonadMask m) => m a -> m a, -- ^ Perform an action without echoing input. wrapFileInput :: forall a . IO a -> IO a, getLocaleLine :: MaybeT IO String, @@ -100,12 +108,12 @@ -class (MonadReader Prefs m , MonadReader Layout m, MonadException m) +class (MonadReader Prefs m , MonadReader Layout m, MonadIO m, MonadMask m) => CommandMonad m where runCompletion :: (String,String) -> m (String,[Completion]) instance {-# OVERLAPPABLE #-} (MonadTrans t, CommandMonad m, MonadReader Prefs (t m), - MonadException (t m), + MonadIO (t m), MonadMask (t m), MonadReader Layout (t m)) => CommandMonad (t m) where runCompletion = lift . runCompletion @@ -153,14 +161,14 @@ -- Utility functions for the various backends. -- | Utility function since we're not using the new IO library yet. -hWithBinaryMode :: MonadException m => Handle -> m a -> m a +hWithBinaryMode :: (MonadIO m, MonadMask m) => Handle -> m a -> m a hWithBinaryMode h = bracket (liftIO $ hGetEncoding h) (maybe (return ()) (liftIO . hSetEncoding h)) . const . (liftIO (hSetBinaryMode h True) >>) -- | Utility function for changing a property of a terminal for the duration of -- a computation. -bracketSet :: MonadException m => IO a -> (a -> IO ()) -> a -> m b -> m b +bracketSet :: (MonadMask m, MonadIO m) => IO a -> (a -> IO ()) -> a -> m b -> m b bracketSet getState set newState f = bracket (liftIO getState) (liftIO . set) (\_ -> liftIO (set newState) >> f) @@ -193,10 +201,10 @@ c <- hLookAhead h when (c == '\n') $ getChar >> return () -returnOnEOF :: MonadException m => a -> m a -> m a +returnOnEOF :: MonadMask m => a -> m a -> m a returnOnEOF x = handle $ \e -> if isEOFError e then return x - else throwIO e + else throwM e -- | Utility function to correctly get a line of input as an undecoded ByteString. hGetLocaleLine :: Handle -> MaybeT IO ByteString diff --git a/System/Console/Haskeline/Vi.hs b/System/Console/Haskeline/Vi.hs --- a/System/Console/Haskeline/Vi.hs +++ b/System/Console/Haskeline/Vi.hs @@ -1,4 +1,8 @@ -module System.Console.Haskeline.Vi where +{-# LANGUAGE LambdaCase #-} +#if __GLASGOW_HASKELL__ < 802 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif +module System.Console.Haskeline.Vi (emptyViState, viKeyCommands) where import System.Console.Haskeline.Command import System.Console.Haskeline.Monads @@ -11,35 +15,40 @@ import System.Console.Haskeline.InputT import Data.Char -import Control.Monad(liftM) +import Control.Monad (liftM2, (>=>)) +import Control.Monad.Catch (MonadMask) type EitherMode = Either CommandMode InsertMode type SavedCommand m = Command (ViT m) (ArgMode CommandMode) EitherMode -data ViState m = ViState { +data InlineSearch = F -- f | F + | T -- t | T + +data ViState m = ViState { lastCommand :: SavedCommand m, - lastSearch :: [Grapheme] + lastSearch :: [Grapheme], + lastInlineSearch :: Maybe (Char, InlineSearch, Direction) } emptyViState :: Monad m => ViState m emptyViState = ViState { lastCommand = return . Left . argState, - lastSearch = [] + lastSearch = [], + lastInlineSearch = Nothing } type ViT m = StateT (ViState m) (InputCmdT m) -type InputCmd s t = forall m . MonadException m => Command (ViT m) s t -type InputKeyCmd s t = forall m . MonadException m => KeyCommand (ViT m) s t +type InputCmd s t = forall m . (MonadIO m, MonadMask m) => Command (ViT m) s t +type InputKeyCmd s t = forall m . (MonadIO m, MonadMask m) => KeyCommand (ViT m) s t viKeyCommands :: InputKeyCmd InsertMode (Maybe String) -viKeyCommands = choiceCmd [ - simpleChar '\n' +> finish - , ctrlChar 'd' +> eofIfEmpty +viKeyCommands = choiceCmd + [ simpleChar '\n' `useKey` finish + , ctrlChar 'd' `useKey` eofIfEmpty , simpleInsertions >+> viCommands - , simpleChar '\ESC' +> change enterCommandMode - >|> viCommandActions + , simpleChar '\ESC' `useKey` (change enterCommandMode >=> viCommandActions) ] viCommands :: InputCmd InsertMode (Maybe String) @@ -47,35 +56,38 @@ simpleInsertions :: InputKeyCmd InsertMode InsertMode simpleInsertions = choiceCmd - [ simpleKey LeftKey +> change goLeft - , simpleKey RightKey +> change goRight - , simpleKey Backspace +> change deletePrev - , simpleKey Delete +> change deleteNext - , simpleKey Home +> change moveToStart - , simpleKey End +> change moveToEnd - , insertChars - , ctrlChar 'l' +> clearScreenCmd - , simpleKey UpKey +> historyBack - , simpleKey DownKey +> historyForward - , searchHistory - , simpleKey KillLine +> killFromHelper (SimpleMove moveToStart) - , ctrlChar 'w' +> killFromHelper wordErase - , completionCmd (simpleChar '\t') - ] + [ simpleKey LeftKey `useKey` change goLeft + , simpleKey RightKey `useKey` change goRight + , simpleKey Backspace `useKey` change deletePrev + , simpleKey Delete `useKey` change deleteNext + , simpleKey Home `useKey` change moveToStart + , simpleKey End `useKey` change moveToEnd + , insertChars + , ctrlChar 'l' `useKey` clearScreenCmd + , simpleKey UpKey `useKey` historyBack + , simpleKey DownKey `useKey` historyForward + , simpleKey SearchReverse `useKey` searchForPrefix Reverse + , simpleKey SearchForward `useKey` searchForPrefix Forward + , searchHistory + , simpleKey KillLine `useKey` killFromHelper (SimpleMove moveToStart) + , ctrlChar 'w' `useKey` killFromHelper wordErase + , completionCmd (simpleChar '\t') + ] insertChars :: InputKeyCmd InsertMode InsertMode insertChars = useChar $ loop [] where - loop ds d = change (insertChar d) >|> keyChoiceCmd [ - useChar $ loop (d:ds) + loop ds d = change (insertChar d) + >=> keyChoiceCmd + [ useChar $ loop (d:ds) , withoutConsuming (storeCharInsertion (reverse ds)) ] - storeCharInsertion s = storeLastCmd $ change (applyArg - $ withCommandMode $ insertString s) - >|> return . Left + storeCharInsertion s = storeLastCmd + $ change (applyArg $ withCommandMode $ insertString s) + >=> return . Left -- If we receive a ^D and the line is empty, return Nothing --- otherwise, act like '\n' (mimicing how Readline behaves) +-- otherwise, act like '\n' (mimicking how Readline behaves) eofIfEmpty :: (Monad m, Save s, Result s) => Command m s (Maybe String) eofIfEmpty s | save s == emptyIM = return Nothing @@ -83,8 +95,8 @@ viCommandActions :: InputCmd CommandMode (Maybe String) viCommandActions = keyChoiceCmd [ - simpleChar '\n' +> finish - , ctrlChar 'd' +> eofIfEmpty + simpleChar '\n' `useKey` finish + , ctrlChar 'd' `useKey` eofIfEmpty , simpleCmdActions >+> viCommandActions , exitingCommands >+> viCommands , repeatedCommands >+> chooseEitherMode @@ -95,39 +107,73 @@ chooseEitherMode (Right im) = viCommands im exitingCommands :: InputKeyCmd CommandMode InsertMode -exitingCommands = choiceCmd [ - simpleChar 'i' +> change insertFromCommandMode - , simpleChar 'I' +> change (moveToStart . insertFromCommandMode) - , simpleKey Home +> change (moveToStart . insertFromCommandMode) - , simpleChar 'a' +> change appendFromCommandMode - , simpleChar 'A' +> change (moveToEnd . appendFromCommandMode) - , simpleKey End +> change (moveToStart . insertFromCommandMode) - , simpleChar 's' +> change (insertFromCommandMode . deleteChar) - , simpleChar 'S' +> noArg >|> killAndStoreI killAll - , simpleChar 'C' +> noArg >|> killAndStoreI (SimpleMove moveToEnd) +exitingCommands = choiceCmd [ + simpleChar 'i' `useKey` change insertFromCommandMode + , simpleChar 'I' `useKey` change (moveToStart . insertFromCommandMode) + , simpleKey Home `useKey` change (moveToStart . insertFromCommandMode) + , simpleChar 'a' `useKey` change appendFromCommandMode + , simpleChar 'A' `useKey` change (moveToEnd . appendFromCommandMode) + , simpleKey End `useKey` change (moveToStart . insertFromCommandMode) + , simpleChar 's' `useKey` change (insertFromCommandMode . deleteChar) + , simpleChar 'S' `useKey` (noArg >=> killAndStoreI killAll) + , simpleChar 'C' `useKey` (noArg >=> killAndStoreI (SimpleMove moveToEnd)) ] simpleCmdActions :: InputKeyCmd CommandMode CommandMode -simpleCmdActions = choiceCmd [ - simpleChar '\ESC' +> change id -- helps break out of loops - , simpleChar 'r' +> replaceOnce - , simpleChar 'R' +> replaceLoop - , simpleChar 'D' +> noArg >|> killAndStoreCmd (SimpleMove moveToEnd) - , ctrlChar 'l' +> clearScreenCmd - , simpleChar 'u' +> commandUndo - , ctrlChar 'r' +> commandRedo +simpleCmdActions = choiceCmd [ + simpleChar '\ESC' `useKey` change id -- helps break out of loops + , simpleChar 'r' `useKey` replaceOnce + , simpleChar 'R' `useKey` replaceLoop + , simpleChar 'D' `useKey` (noArg >=> killAndStoreC (SimpleMove moveToEnd)) + , ctrlChar 'l' `useKey` clearScreenCmd + , simpleChar 'u' `useKey` commandUndo + , ctrlChar 'r' `useKey` commandRedo -- vi-mode quirk: history is put at the start of the line. - , simpleChar 'j' +> historyForward >|> change moveToStart - , simpleChar 'k' +> historyBack >|> change moveToStart - , simpleKey DownKey +> historyForward >|> change moveToStart - , simpleKey UpKey +> historyBack >|> change moveToStart - , simpleChar '/' +> viEnterSearch '/' Reverse - , simpleChar '?' +> viEnterSearch '?' Forward - , simpleChar 'n' +> viSearchHist Reverse [] - , simpleChar 'N' +> viSearchHist Forward [] - , simpleKey KillLine +> noArg >|> killAndStoreCmd (SimpleMove moveToStart) + , simpleChar 'j' `useKey` (historyForward >=> change moveToStart) + , simpleChar 'k' `useKey` (historyBack >=> change moveToStart) + , simpleKey DownKey `useKey` (historyForward >=> change moveToStart) + , simpleKey UpKey `useKey` (historyBack >=> change moveToStart) + , simpleChar '/' `useKey` viEnterSearch '/' Reverse + , simpleChar '?' `useKey` viEnterSearch '?' Forward + , simpleChar 'n' `useKey` viSearchHist Reverse [] + , simpleChar 'N' `useKey` viSearchHist Forward [] + , simpleKey KillLine `useKey` (noArg >=> killAndStoreC (SimpleMove moveToStart)) ] +inlineSearchActions :: InputKeyCmd (ArgMode CommandMode) CommandMode +inlineSearchActions = choiceCmd + [ simpleChar 'f' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch F Forward c >>=) . viInlineSearch id) + , simpleChar 'F' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch F Reverse c >>=) . viInlineSearch id) + , simpleChar 't' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch T Forward c >>=) . viInlineSearch id) + , simpleChar 'T' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch T Reverse c >>=) . viInlineSearch id) + , simpleChar ';' `useKey` ((getLastInlineSearch >>=) . viInlineSearch id) + , simpleChar ',' `useKey` ((getLastInlineSearch >>=) . viInlineSearch flipDir) + ] + +viInlineSearch :: Monad m => (Direction -> Direction) + -> ArgMode CommandMode + -> (Maybe (Char, InlineSearch, Direction)) + -> CmdM (ViT m) CommandMode +viInlineSearch flipdir = \s -> \case + Nothing -> return $ argState s + Just (g, fOrT, dir) -> setState $ (applyArg . withCommandMode . search fOrT (flipdir dir)) (== g) s + where + search :: InlineSearch -> Direction -> (Char -> Bool) -> InsertMode -> InsertMode + search F Forward = goRightUntil . overChar + search F Reverse = goLeftUntil . overChar + search T Forward = goRightUntil . beforeChar + search T Reverse = goLeftUntil . afterChar + +getLastInlineSearch :: forall m. Monad m => CmdM (ViT m) (Maybe (Char, InlineSearch, Direction)) +getLastInlineSearch = lastInlineSearch <$> (get :: CmdM (ViT m) (ViState m)) -- TODO: ideally this is a usage of `gets` + +saveInlineSearch :: forall m. Monad m => InlineSearch -> Direction -> Char + -> CmdM (ViT m) (Maybe (Char, InlineSearch, Direction)) +saveInlineSearch fOrT dir char + = do let ret = Just (char, fOrT, dir) + modify $ \(vs :: ViState m) -> vs {lastInlineSearch = ret} + return ret + replaceOnce :: InputCmd CommandMode CommandMode replaceOnce = try $ changeFromChar replaceChar @@ -144,61 +190,63 @@ ] pureMovements :: InputKeyCmd (ArgMode CommandMode) CommandMode -pureMovements = choiceCmd $ charMovements ++ map mkSimpleCommand movements +pureMovements = choiceCmd $ map mkSimpleCommand movements where - charMovements = [ charMovement 'f' $ \c -> goRightUntil $ overChar (==c) - , charMovement 'F' $ \c -> goLeftUntil $ overChar (==c) - , charMovement 't' $ \c -> goRightUntil $ beforeChar (==c) - , charMovement 'T' $ \c -> goLeftUntil $ afterChar (==c) - ] - mkSimpleCommand (k,move) = k +> change (applyCmdArg move) - charMovement c move = simpleChar c +> keyChoiceCmd [ - useChar (change . applyCmdArg . move) - , withoutConsuming (change argState) - ] + mkSimpleCommand (k, move) = k `useKey` change (applyCmdArg move) -useMovementsForKill :: Command m s t -> (KillHelper -> Command m s t) -> KeyCommand m s t -useMovementsForKill alternate useHelper = choiceCmd $ +useMovementsForKill :: (KillHelper -> Command m s t) -> KeyCommand m s t +useMovementsForKill useHelper = choiceCmd $ specialCases - ++ map (\(k,move) -> k +> useHelper (SimpleMove move)) movements + ++ map (\(k,move) -> k `useKey` useHelper (SimpleMove move)) movements where - specialCases = [ simpleChar 'e' +> useHelper (SimpleMove goToWordDelEnd) - , simpleChar 'E' +> useHelper (SimpleMove goToBigWordDelEnd) - , simpleChar '%' +> useHelper (GenericKill deleteMatchingBrace) - -- Note 't' and 'f' behave differently than in pureMovements. - , charMovement 'f' $ \c -> goRightUntil $ afterChar (==c) - , charMovement 'F' $ \c -> goLeftUntil $ overChar (==c) - , charMovement 't' $ \c -> goRightUntil $ overChar (==c) - , charMovement 'T' $ \c -> goLeftUntil $ afterChar (==c) + specialCases = [ simpleChar 'e' `useKey` useHelper (SimpleMove goToWordDelEnd) + , simpleChar 'E' `useKey` useHelper (SimpleMove goToBigWordDelEnd) + , simpleChar '%' `useKey` useHelper (GenericKill deleteMatchingBrace) ] - charMovement c move = simpleChar c +> keyChoiceCmd [ - useChar (useHelper . SimpleMove . move) - , withoutConsuming alternate] +useInlineSearchForKill :: Monad m => Command (ViT m) s t -> (KillHelper -> Command (ViT m) s t) -> KeyMap (Command (ViT m) s t) +useInlineSearchForKill alternate killCmd = choiceCmd + [ simpleChar 'f' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch F Forward c >>=) . getSearchAndKill) + , simpleChar 'F' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch F Reverse c >>=) . getSearchAndKill) + , simpleChar 't' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch T Forward c >>=) . getSearchAndKill) + , simpleChar 'T' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch T Reverse c >>=) . getSearchAndKill) + , simpleChar ';' `useKey` ((getLastInlineSearch >>=) . getSearchAndKill) + , simpleChar ',' `useKey` ((reverseDir <$> getLastInlineSearch >>=) . getSearchAndKill) + ] + where + getSearchAndKill = \s + -> \case (Just (g, fOrT, forOrRev)) -> killCmd (SimpleMove $ moveForKill fOrT forOrRev $ (== g)) s + Nothing -> alternate s + moveForKill F Forward = goRightUntil . afterChar + moveForKill F Reverse = goLeftUntil . overChar + moveForKill T Forward = goRightUntil . overChar + moveForKill T Reverse = goLeftUntil . afterChar + repeatableCommands :: InputKeyCmd (ArgMode CommandMode) EitherMode repeatableCommands = choiceCmd [ repeatableCmdToIMode , repeatableCmdMode >+> return . Left - , simpleChar '.' +> saveForUndo >|> runLastCommand + , simpleChar '.' `useKey` (saveForUndo >=> runLastCommand) ] where - runLastCommand s = liftM lastCommand get >>= ($ s) + runLastCommand s = fmap lastCommand get >>= ($ s) repeatableCmdMode :: InputKeyCmd (ArgMode CommandMode) CommandMode repeatableCmdMode = choiceCmd - [ simpleChar 'x' +> repeatableChange deleteChar - , simpleChar 'X' +> repeatableChange (withCommandMode deletePrev) - , simpleChar '~' +> repeatableChange (goRight . flipCase) - , simpleChar 'p' +> storedCmdAction (pasteCommand pasteGraphemesAfter) - , simpleChar 'P' +> storedCmdAction (pasteCommand pasteGraphemesBefore) - , simpleChar 'd' +> deletionCmd - , simpleChar 'y' +> yankCommand - , ctrlChar 'w' +> killAndStoreCmd wordErase + [ simpleChar 'x' `useKey` repeatableChange deleteChar + , simpleChar 'X' `useKey` repeatableChange (withCommandMode deletePrev) + , simpleChar '~' `useKey` repeatableChange (goRight . flipCase) + , simpleChar 'p' `useKey` storedCmdAction (pasteCommand pasteGraphemesAfter) + , simpleChar 'P' `useKey` storedCmdAction (pasteCommand pasteGraphemesBefore) + , simpleChar 'd' `useKey` deletionCmd + , simpleChar 'y' `useKey` yankCommand + , ctrlChar 'w' `useKey` killAndStoreC wordErase + , inlineSearchActions , pureMovements ] where - repeatableChange f = storedCmdAction (saveForUndo >|> change (applyArg f)) + repeatableChange f = storedCmdAction (saveForUndo >=> change (applyArg f)) flipCase :: CommandMode -> CommandMode flipCase CEmpty = CEmpty @@ -208,38 +256,39 @@ | otherwise = toLower c repeatableCmdToIMode :: InputKeyCmd (ArgMode CommandMode) EitherMode -repeatableCmdToIMode = simpleChar 'c' +> deletionToInsertCmd +repeatableCmdToIMode = simpleChar 'c' `useKey` deletionToInsertCmd deletionCmd :: InputCmd (ArgMode CommandMode) CommandMode deletionCmd = keyChoiceCmd - [ reinputArg >+> deletionCmd - , simpleChar 'd' +> killAndStoreCmd killAll - , useMovementsForKill (change argState) killAndStoreCmd - , withoutConsuming (change argState) - ] + [ reinputArg >+> deletionCmd + , simpleChar 'd' `useKey` killAndStoreC killAll + , useMovementsForKill killAndStoreC + , useInlineSearchForKill (change argState) killAndStoreC + , withoutConsuming (change argState) + ] deletionToInsertCmd :: InputCmd (ArgMode CommandMode) EitherMode deletionToInsertCmd = keyChoiceCmd [ reinputArg >+> deletionToInsertCmd - , simpleChar 'c' +> killAndStoreIE killAll + , simpleChar 'c' `useKey` killAndStoreE killAll -- vim, for whatever reason, treats cw same as ce and cW same as cE. -- readline does this too, so we should also. - , simpleChar 'w' +> killAndStoreIE (SimpleMove goToWordDelEnd) - , simpleChar 'W' +> killAndStoreIE (SimpleMove goToBigWordDelEnd) - , useMovementsForKill (liftM Left . change argState) killAndStoreIE + , simpleChar 'w' `useKey` killAndStoreE (SimpleMove goToWordDelEnd) + , simpleChar 'W' `useKey` killAndStoreE (SimpleMove goToBigWordDelEnd) + , useMovementsForKill killAndStoreE + , useInlineSearchForKill (fmap Left . change argState) killAndStoreE , withoutConsuming (return . Left . argState) ] yankCommand :: InputCmd (ArgMode CommandMode) CommandMode yankCommand = keyChoiceCmd - [ reinputArg >+> yankCommand - , simpleChar 'y' +> copyAndStore killAll - , useMovementsForKill (change argState) copyAndStore - , withoutConsuming (change argState) - ] - where - copyAndStore = storedCmdAction . copyFromArgHelper + [ reinputArg >+> yankCommand + , simpleChar 'y' `useKey` copyAndStore killAll + , useMovementsForKill copyAndStore + , useInlineSearchForKill (change argState) copyAndStore + , withoutConsuming (change argState) + ] reinputArg :: LineState s => InputKeyCmd (ArgMode s) (ArgMode s) reinputArg = foreachDigit restartArg ['1'..'9'] >+> loop @@ -256,7 +305,7 @@ goToBigWordDelEnd = goRightUntil $ atStart (not . isBigWordChar) -movements :: [(Key,InsertMode -> InsertMode)] +movements :: [(Key, InsertMode -> InsertMode)] movements = [ (simpleChar 'h', goLeft) , (simpleChar 'l', goRight) , (simpleChar ' ', goRight) @@ -282,26 +331,26 @@ , (simpleChar 'E', goRightUntil (atEnd isBigWordChar)) ] -{- +{- From IEEE 1003.1: A "bigword" consists of: a maximal sequence of non-blanks preceded and followed by blanks A "word" consists of either: - a maximal sequence of wordChars, delimited at both ends by non-wordchars - a maximal sequence of non-blank non-wordchars, delimited at both ends by either blanks or a wordchar. --} +-} isBigWordChar, isWordChar, isOtherChar :: Char -> Bool isBigWordChar = not . isSpace isWordChar = isAlphaNum .||. (=='_') isOtherChar = not . (isSpace .||. isWordChar) (.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool -(f .||. g) x = f x || g x +(.||.) = liftM2 (||) -foreachDigit :: (Monad m, LineState t) => (Int -> s -> t) -> [Char] +foreachDigit :: (Monad m, LineState t) => (Int -> s -> t) -> [Char] -> KeyCommand m s t foreachDigit f ds = choiceCmd $ map digitCmd ds - where digitCmd d = simpleChar d +> change (f (toDigit d)) + where digitCmd d = simpleChar d `useKey` change (f (toDigit d)) toDigit d = fromEnum d - fromEnum '0' @@ -342,7 +391,7 @@ | baseChar x == d = n-1 | otherwise = n -matchingRightBrace, matchingLeftBrace :: Char -> Maybe Char +matchingRightBrace, matchingLeftBrace :: Char -> Maybe Char matchingRightBrace = flip lookup braceList matchingLeftBrace = flip lookup (map (\(c,d) -> (d,c)) braceList) @@ -352,13 +401,13 @@ --------------- -- Replace mode replaceLoop :: InputCmd CommandMode CommandMode -replaceLoop = saveForUndo >|> change insertFromCommandMode >|> loop - >|> change enterCommandModeRight +replaceLoop = saveForUndo >=> change insertFromCommandMode >=> loop + >=> change enterCommandModeRight where loop = try (oneReplaceCmd >+> loop) oneReplaceCmd = choiceCmd [ - simpleKey LeftKey +> change goLeft - , simpleKey RightKey +> change goRight + simpleKey LeftKey `useKey` change goLeft + , simpleKey RightKey `useKey` change goRight , changeFromChar replaceCharIM ] @@ -372,25 +421,28 @@ return s storedAction :: Monad m => SavedCommand m -> SavedCommand m -storedAction act = storeLastCmd act >|> act +storedAction act = storeLastCmd act >=> act storedCmdAction :: Monad m => Command (ViT m) (ArgMode CommandMode) CommandMode - -> Command (ViT m) (ArgMode CommandMode) CommandMode -storedCmdAction act = storeLastCmd (liftM Left . act) >|> act + -> Command (ViT m) (ArgMode CommandMode) CommandMode +storedCmdAction act = storeLastCmd (fmap Left . act) >=> act storedIAction :: Monad m => Command (ViT m) (ArgMode CommandMode) InsertMode - -> Command (ViT m) (ArgMode CommandMode) InsertMode -storedIAction act = storeLastCmd (liftM Right . act) >|> act + -> Command (ViT m) (ArgMode CommandMode) InsertMode +storedIAction act = storeLastCmd (fmap Right . act) >=> act -killAndStoreCmd :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode -killAndStoreCmd = storedCmdAction . killFromArgHelper +killAndStoreC :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode +killAndStoreC = storedCmdAction . killFromArgHelper killAndStoreI :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) InsertMode killAndStoreI = storedIAction . killFromArgHelper -killAndStoreIE :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) EitherMode -killAndStoreIE helper = storedAction (killFromArgHelper helper >|> return . Right) +killAndStoreE :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) EitherMode +killAndStoreE helper = storedAction (killFromArgHelper helper >=> return . Right) +copyAndStore :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode +copyAndStore = storedCmdAction . copyFromArgHelper + noArg :: Monad m => Command m s (ArgMode s) noArg = return . startArg 1 @@ -415,19 +467,18 @@ viEnterSearch c dir s = setState (SearchEntry emptyIM c) >>= loopEntry where modifySE f se = se {entryState = f (entryState se)} - loopEntry = keyChoiceCmd [ - editEntry >+> loopEntry - , simpleChar '\n' +> \se -> - viSearchHist dir (searchText se) s + loopEntry = keyChoiceCmd + [ editEntry >+> loopEntry + , simpleChar '\n' `useKey` \se -> viSearchHist dir (searchText se) s , withoutConsuming (change (const s)) ] - editEntry = choiceCmd [ - useChar (change . modifySE . insertChar) - , simpleKey LeftKey +> change (modifySE goLeft) - , simpleKey RightKey +> change (modifySE goRight) - , simpleKey Backspace +> change (modifySE deletePrev) - , simpleKey Delete +> change (modifySE deleteNext) - ] + editEntry = choiceCmd + [ useChar (change . modifySE . insertChar) + , simpleKey LeftKey `useKey` change (modifySE goLeft) + , simpleKey RightKey `useKey` change (modifySE goRight) + , simpleKey Backspace `useKey` change (modifySE deletePrev) + , simpleKey Delete `useKey` change (modifySE deleteNext) + ] viSearchHist :: forall m . Monad m => Direction -> [Grapheme] -> Command (ViT m) CommandMode CommandMode @@ -445,3 +496,8 @@ Right sm -> do put vstate {lastSearch = toSearch'} setState (restore (foundHistory sm)) + +reverseDir :: Maybe (a, b, Direction) -> Maybe (a, b, Direction) +reverseDir = (third3 flipDir <$>) + where + third3 f (a, b, c) = (a, b, f c) diff --git a/cbits/h_wcwidth.c b/cbits/h_wcwidth.c --- a/cbits/h_wcwidth.c +++ b/cbits/h_wcwidth.c @@ -67,7 +67,7 @@ }; /* auxiliary function for binary search in interval table */ -static int haskeline_bisearch(wchar_t ucs, const struct interval *table, int max) { +static int haskeline_bisearch(int ucs, const struct interval *table, int max) { int min = 0; int mid; @@ -119,7 +119,7 @@ * in ISO 10646. */ -int haskeline_mk_wcwidth(wchar_t ucs) +int haskeline_mk_wcwidth(int ucs) { /* sorted list of non-overlapping intervals of non-spacing characters */ /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */ 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 Control.Exception (AsyncException(..)) +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 inputFunc n = do - minput <- handle (\Interrupt -> 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,12 +1,12 @@ Name: haskeline Cabal-Version: >=1.10 -Version: 0.7.5.0 +Version: 0.8.5.0 Category: User Interfaces License: BSD3 License-File: LICENSE Copyright: (c) Judah Jacobson Author: Judah Jacobson -Maintainer: Judah Jacobson +Maintainer: Troels Henriksen Synopsis: A command-line interface for user input, written in Haskell. Description: Haskeline provides a user interface for line input in command-line @@ -15,15 +15,31 @@ Haskell programs. . Haskeline runs both on POSIX-compatible systems and on Windows. -Homepage: https://github.com/judah/haskeline -Bug-Reports: https://github.com/judah/haskeline/issues +Homepage: https://github.com/haskell/haskeline +Bug-Reports: https://github.com/haskell/haskeline/issues Stability: Stable Build-Type: Simple -extra-source-files: examples/Test.hs Changelog includes/*.h +tested-with: + GHC == 9.12.1 + GHC == 9.10.1 + GHC == 9.8.2 + GHC == 9.6.5 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + +extra-source-files: examples/Test.hs Changelog + source-repository head type: git - location: git://github.com/judah/haskeline.git + location: https://github.com/judah/haskeline.git -- There are three main advantages to the terminfo backend over the portable, -- "dumb" alternative. First, it enables more efficient control sequences @@ -38,14 +54,24 @@ Default: True Manual: True +-- Help the GHC build by making it possible to disable the extra binary. +-- TODO: Make GHC handle packages with both a library and an executable. +flag examples + Description: Enable executable components used for tests. + Default: True + Manual: True + Library - -- We require ghc>=7.4.1 (base>=4.5) 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 - Build-depends: base >=4.9 && < 4.13, containers>=0.4 && < 0.7, - directory>=1.1 && < 1.4, bytestring>=0.9 && < 0.11, - filepath >= 1.2 && < 1.5, transformers >= 0.4 && < 0.6, - process >= 1.0 && < 1.7, stm >= 2.4 && < 2.6 + Build-depends: + base >= 4.9 && < 4.23 + , containers >= 0.4 && < 0.9 + , directory >= 1.1 && < 1.4 + , bytestring >= 0.9 && < 0.13 + , filepath >= 1.2 && < 1.6 + , transformers >= 0.2 && < 0.7 + , process >= 1.0 && < 1.7 + , stm >= 2.4 && < 2.6 + , exceptions == 0.10.* Default-Language: Haskell98 Default-Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances, @@ -60,9 +86,10 @@ Exposed-Modules: System.Console.Haskeline System.Console.Haskeline.Completion - System.Console.Haskeline.MonadException System.Console.Haskeline.History System.Console.Haskeline.IO + System.Console.Haskeline.Internal + System.Console.Haskeline.ReaderT Other-Modules: System.Console.Haskeline.Backend System.Console.Haskeline.Backend.WCWidth @@ -85,15 +112,15 @@ include-dirs: includes c-sources: cbits/h_wcwidth.c - if os(windows) { - Build-depends: Win32>=2.0 + if os(windows) + Build-depends: Win32 >= 2.1 && < 2.10 || >= 2.12 Other-modules: System.Console.Haskeline.Backend.Win32 System.Console.Haskeline.Backend.Win32.Echo c-sources: cbits/win_console.c includes: win_console.h, windows_cconv.h install-includes: win_console.h cpp-options: -DMINGW - } else { + else Build-depends: unix>=2.0 && < 2.9 Other-modules: System.Console.Haskeline.Backend.Posix @@ -107,5 +134,42 @@ if os(solaris) { cpp-options: -DUSE_TERMIOS_H } + + ghc-options: -Wall -Wcompat + +test-suite haskeline-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + Default-Language: Haskell98 + + if os(windows) { + buildable: False } - ghc-options: -Wall + if !flag(examples) { + buildable: False + } + Main-Is: Unit.hs + Build-depends: + -- shared dependencies with library + base >= 4.9 && < 4.23 + , containers >= 0.4 && < 0.9 + , bytestring >= 0.9 && < 0.13 + , directory + , process >= 1.0 && < 1.7 + -- dependencies for test-suite + , HUnit + , text + , unix >= 2.0 && < 2.9 + + Other-Modules: RunTTY, Pty + build-tool-depends: haskeline:haskeline-examples-Test + +-- The following program is used by unit tests in `tests` executable +Executable haskeline-examples-Test + if !flag(examples) { + buildable: False + } + Build-depends: base, containers, haskeline, optparse-applicative + Default-Language: Haskell2010 + hs-source-dirs: examples + Main-Is: Test.hs diff --git a/includes/h_iconv.h b/includes/h_iconv.h deleted file mode 100644 --- a/includes/h_iconv.h +++ /dev/null @@ -1,9 +0,0 @@ -#include - -iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode); - -void haskeline_iconv_close(iconv_t cd); - -size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, - char **outbuf, size_t *outbytesleft); - diff --git a/includes/windows_cconv.h b/includes/windows_cconv.h deleted file mode 100644 --- a/includes/windows_cconv.h +++ /dev/null @@ -1,12 +0,0 @@ -#ifndef WINDOWS_CCONV_H -#define WINDOWS_CCONV_H - -#if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -#else -# error Unknown mingw32 arch -#endif - -#endif diff --git a/tests/Pty.hs b/tests/Pty.hs new file mode 100644 --- /dev/null +++ b/tests/Pty.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- This module is a quick-and-dirty way to run an executable +-- within a pseudoterminal and obtain its output. +-- +-- It is not intended for general use. In particular: +-- - It expects the output to be available quickly (<0.2s) +-- after each chunk of input. +-- - It expects each output chunk be no more than 4096 bytes. +module Pty (runCommandInPty) where + +import System.Posix.Types +import System.Posix.Terminal +import System.Posix.Process +import System.Posix.Signals +import qualified Data.ByteString as B +import System.Posix.IO.ByteString +import Foreign.Marshal.Alloc +import Foreign.C.Error +import Foreign.C.Types +import Foreign.Ptr +import Control.Concurrent + +-- Run the given command in a pseudoterminal, and return its output chunks. +-- Read the initial output, then feed the given input to it +-- one block at a time. +-- After each input, pause for 0.2s and then read as much output as possible. +runCommandInPty :: String -> [String] -> Maybe [(String,String)] + -> [B.ByteString] -> IO [B.ByteString] +runCommandInPty prog args env inputs = do + (fd,pid) <- forkCommandInPty prog args env + -- Block until the initial output from the program. + -- After that, only use non-blocking reads. Otherwise, + -- we would hang the program in cases where the program has no output + -- in between inputs. + firstOutput <- getOutput fd + setFdOption fd NonBlockingRead True + outputs <- mapM (inputOutput fd) inputs + signalProcess killProcess pid + _status <- getProcessStatus True False pid + closeFd fd + return (firstOutput : outputs) + +inputOutput :: Fd -> B.ByteString -> IO B.ByteString +inputOutput fd input = do + putInput fd input + getOutput fd + +putInput :: Fd -> B.ByteString -> IO () +putInput fd input = + B.useAsCStringLen input $ \(cstr,len) -> do + written <- fdWriteBuf fd (castPtr cstr) (fromIntegral len) + if written == 0 + then threadDelay 1000 >> putInput fd input + else return () + +getOutput :: Fd -> IO B.ByteString +getOutput fd = do + threadDelay 20000 + allocaBytes (fromIntegral numBytes) $ \buf -> do + num <- fdReadNonBlocking fd buf numBytes + B.packCStringLen (castPtr buf, fromIntegral num) + where + numBytes = 4096 + + +-- Unlike fdReadBuf, don't throw an error if nothing's immediately available. +-- Instead, just return empty output. +fdReadNonBlocking :: Fd -> Ptr CChar -> CSize -> IO CSsize +fdReadNonBlocking fd buf n = do + num_read <- c_read fd buf n + if num_read >= 0 + then return num_read + else do + e <- getErrno + if e == eAGAIN + then return 0 + else throwErrno "fdReadNonBlocking" + +foreign import ccall "read" c_read :: Fd -> Ptr CChar -> CSize -> IO CSsize + + +-- returns the master Fd, and the pid for the subprocess. +forkCommandInPty :: String -> [String] -> Maybe [(String,String)] + -> IO (Fd,ProcessID) +forkCommandInPty prog args env = do + (master,slave) <- openPseudoTerminal + pid <- forkProcess $ do + closeFd master + loginTTY slave + executeFile prog False args env + return (master,pid) + + +loginTTY :: Fd -> IO () +loginTTY = throwErrnoIfMinus1_ "loginTTY" . login_tty + +foreign import ccall login_tty :: Fd -> IO CInt + diff --git a/tests/RunTTY.hs b/tests/RunTTY.hs new file mode 100644 --- /dev/null +++ b/tests/RunTTY.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE RecordWildCards #-} +-- This module provides an interface for testing the output +-- of programs that expect to be run in a terminal. +module RunTTY (Invocation(..), + runInvocation, + assertInvocation, + testI, + setLang, + setTerm, + setLatin1, + setUTF8 + ) where + +import Control.Concurrent +import Data.ByteString as B +import System.IO +import System.Process +import Test.HUnit +import qualified Data.ByteString.Char8 as BC + +import Pty + + +data Invocation = Invocation { + prog :: FilePath + -- | 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 + ,.. + } + +setLang :: String -> Invocation -> Invocation +setLang = setEnv "LANG" +setTerm :: String -> Invocation -> Invocation +setTerm = setEnv "TERM" + + +setUTF8 :: Invocation -> Invocation +setUTF8 = setLang "C.UTF-8" +setLatin1 :: Invocation -> Invocation +setLatin1 = setLang "C.ISO8859-1" + + +runInvocation :: Invocation + -> [B.ByteString] -- Input chunks. (We pause after each chunk to + -- simulate real user input and prevent Haskeline + -- from coalescing the changes.) + -> IO [B.ByteString] +runInvocation inv@Invocation {..} inputs + | runInTTY = runCommandInPty prog (progArgs inv) (Just environment) inputs + | otherwise = do + (Just inH, Just outH, Nothing, ph) + <- createProcess (proc prog (progArgs inv)) + { env = Just environment + , std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + } + hSetBuffering inH NoBuffering + firstOutput <- getOutput outH + outputs <- mapM (inputOutput inH outH) inputs + hClose inH + lastOutput <- getOutput outH -- output triggered by EOF, if any + terminateProcess ph + _ <- waitForProcess ph + return $ firstOutput : outputs + ++ if B.null lastOutput then [] else [lastOutput] + +inputOutput :: Handle -> Handle -> B.ByteString -> IO B.ByteString +inputOutput inH outH input = do + B.hPut inH input + getOutput outH + + +getOutput :: Handle -> IO B.ByteString +getOutput h = do + threadDelay 20000 + B.hGetNonBlocking h 4096 + + +assertInvocation :: Invocation -> [B.ByteString] -> [B.ByteString] + -> Assertion +assertInvocation i input expectedOutput = do + actualOutput <- runInvocation i input + assertSameList expectedOutput $ fmap fixOutput actualOutput + +-- Remove CRLFs from output, since tty translates all LFs into CRLF. +-- (TODO: I'd like to just unset ONLCR in the slave tty, but +-- System.Posix.Terminal doesn't support that flag.) +fixOutput :: B.ByteString -> B.ByteString +fixOutput = BC.pack . loop . BC.unpack + where + loop ('\r':'\n':rest) = '\n' : loop rest + loop (c:cs) = c : loop cs + loop [] = [] + +assertSameList :: (Show a, Eq a) => [a] -> [a] -> Assertion +assertSameList [] [] = return () +assertSameList (x:xs) (y:ys) + | x == y = assertSameList xs ys +assertSameList xs ys = xs @=? ys -- cause error to be thrown + +testI :: Invocation -> [B.ByteString] -> [B.ByteString] -> Test +testI i inp outp = test $ assertInvocation i inp outp diff --git a/tests/Unit.hs b/tests/Unit.hs new file mode 100644 --- /dev/null +++ b/tests/Unit.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE OverloadedStrings #-} +-- Requirements: +-- - Empty ~/.haskeline (or set to defaults) +-- - On Mac OS X, the "dumb term" test may fail. +-- In particular, the line "* UTF-8" which makes locale_charset() +-- always return UTF-8; otherwise we can't test latin-1. +-- - NB: Window size isn't provided by screen so it's picked up from +-- terminfo or defaults (either way: 80x24), rather than the user's +-- terminal. +module Main where + +import Control.Monad (when) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.Word +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Monoid ((<>)) +import System.Directory (createDirectoryIfMissing) +import System.Exit (exitFailure) +import System.Process (readProcess) +import Test.HUnit + +import RunTTY + +legacyEncoding :: Bool +legacyEncoding = False + +-- Generally we want the legacy and new backends to perform the same. +-- The only two differences I'm aware of are: +-- 1. base decodes invalid bytes as '\65533', but legacy decodes them as '?' +-- 2. if there's an incomplete sequence and no more input immediately +-- available (but not eof), then base will pause to wait for more input, +-- whereas legacy will immediately stop. +whenLegacy :: BC.ByteString -> BC.ByteString +whenLegacy s = if legacyEncoding then s else B.empty + +-- These files are used to test tab completion. +makeTestFiles :: IO () +makeTestFiles = do + createDirectoryIfMissing True "tests/dummy-μασ" + writeFile "tests/dummy-μασ/bar" "" + writeFile "tests/dummy-μασ/ςερτ" "" + +main :: IO () +main = do + -- forkProcess needs an absolute path to the binary. + p <- head . lines <$> readProcess "which" ["haskeline-examples-Test"] "" + let i = setTerm "xterm" + Invocation { + prog = p, + progModeArgs = [], + progInputArgs = [], + runInTTY = True, + environment = [] + } + makeTestFiles + 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 + +-- | 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)" ~: + [ utf8Test i [utf8 "xαβγy"] + [prompt 0, utf8 "xαβγy"] + , utf8Test i [utf8 "a\n", "quit\n"] + [ prompt 0 + , utf8 "a" <> end + <> output 0 (utf8 "a") <> prompt 1 + , utf8 "quit" <> end + ] + , utf8Test i [utf8 "xαβyψ안기q영\n", "quit\n"] + [ prompt 0 + , utf8 "xαβyψ안기q영" <> end + <> output 0 (utf8 "xαβyψ안기q영") <> prompt 1 + , utf8 "quit" <> end + ] + -- test buffering: 32 bytes is in middle of a char encoding, + -- also test long paste + , "multipleLines" ~: utf8Test i [l1 <> "\n" <> l1] + [ prompt 0 + , l1 <> end <> output 0 l1 <> prompt 1 <> l1] + ] + where + l1 = utf8 $ T.replicate 30 "안" -- three bytes, width 60 + +unicodeMovement :: Invocation -> Test +unicodeMovement i = "Unicode movement" ~: + [ "separate" ~: utf8Test i [utf8 "α", utf8 "\ESC[Dx"] + [prompt 0, utf8 "α", utf8 "\bxα\b"] + , "coalesced" ~: utf8Test i [utf8 "α\ESC[Dx"] + [prompt 0, utf8 "xα\b"] + , "lineWrap" ~: utf8Test i + [ utf8 longWideChar + , raw [1] + , raw [5] + ] + [prompt 0, utf8 lwc1 <> wrap <> utf8 lwc2 <> wrap <> utf8 lwc3 + , cr <> "\ESC[2A\ESC[2C" + , cr <> nl <> nl <> "\ESC[22C" + ] + + ] + where + longWideChar = T.concat $ replicate 30 $ "안기영" + (lwc1,lwcs1) = T.splitAt ((80-2)`div`2) longWideChar + (lwc2,lwcs2) = T.splitAt (80`div`2) lwcs1 + (lwc3,_lwcs3) = T.splitAt (80`div`2) lwcs2 + -- lwc3 has length 90 - (80-2)/2 - 80/2 = 11, + -- so the last line as wide width 2*11=22. + +tabCompletion :: Invocation -> Test +tabCompletion i = "tab completion" ~: + [ utf8Test i [ utf8 "tests/dummy-μ\t\t" ] + [ prompt 0, utf8 "tests/dummy-μασ/" + <> nl <> utf8 "bar ςερτ" <> nl + <> prompt' 0 <> utf8 "tests/dummy-μασ/" + ] + ] + +incorrectInput :: Invocation -> Test +incorrectInput i = "incorrect input" ~: + [ utf8Test i [ utf8 "x" <> raw [206] ] -- needs one more byte + -- non-legacy encoder ignores the "206" since it's still waiting + -- for more input. + [ prompt 0, utf8 "x" <> whenLegacy err ] + , utf8Test i [ raw [206] <> utf8 "x" ] + -- 'x' is not valid after '\206', so both the legacy and + -- non-legacy encoders should handle the "x" correctly. + [ prompt 0, err <> utf8 "x"] + , utf8Test i [ raw [236,149] <> utf8 "x" ] -- needs one more byte + [prompt 0, err <> err <> utf8 "x"] + ] + +historyTests :: Invocation -> Test +historyTests i = "history encoding" ~: + [ utf8TestValidHist i [ "\ESC[A" ] + [prompt 0, utf8 "abcα" ] + , utf8TestInvalidHist i [ "\ESC[A" ] + -- NB: this is decoded by either utf8-string or base; + -- either way they produce \65533 instead of '?'. + [prompt 0, utf8 "abcα\65533x\65533x\65533" ] + -- In latin-1: read errors as utf-8 '\65533', display as '?' + , latin1TestInvalidHist i [ "\ESC[A" ] + [prompt 0, utf8 "abc??x?x?" ] + ] + +invalidHist :: BC.ByteString +invalidHist = utf8 "abcα" + `B.append` raw [149] -- invalid start of UTF-8 sequence + `B.append` utf8 "x" + `B.append` raw [206] -- incomplete start + `B.append` utf8 "x" + -- incomplete at end of file + `B.append` raw [206] + +validHist :: BC.ByteString +validHist = utf8 "abcα" + +inputChar :: Invocation -> Test +inputChar i = "getInputChar" ~: + [ utf8Test i [utf8 "xαβ"] + [ prompt 0, utf8 "x" <> end <> output 0 (utf8 "x") + <> prompt 1 <> utf8 "α" <> end <> output 1 (utf8 "α") + <> prompt 2 <> utf8 "β" <> end <> output 2 (utf8 "β") + <> prompt 3 + ] + , "bad encoding (separate)" ~: + utf8Test i [utf8 "α", raw [149], utf8 "x", raw [206]] + [ prompt 0, utf8 "α" <> end <> output 0 (utf8 "α") <> prompt 1 + , err <> end <> output 1 err <> prompt 2 + , utf8 "x" <> end <> output 2 (utf8 "x") <> prompt 3 + , whenLegacy (err <> end <> output 3 err <> prompt 4) + ] + , "bad encoding (together)" ~: + utf8Test i [utf8 "α" <> raw [149] <> utf8 "x" <> raw [206]] + [ prompt 0, utf8 "α" <> end <> output 0 (utf8 "α") + <> prompt 1 <> err <> end <> output 1 err + <> prompt 2 <> utf8 "x" <> end <> output 2 (utf8 "x") + <> prompt 3 <> whenLegacy (err <> end <> output 3 err <> prompt 4) + ] + , utf8Test i [raw [206]] -- incomplete + [ prompt 0, whenLegacy (utf8 "?" <> end <> output 0 (utf8 "?")) + <> whenLegacy (prompt 1) + ] + ] + +setCharInput :: Invocation -> Invocation +setCharInput i = i { progInputArgs = ["chars"] } + + +fileStyleTests :: Invocation -> Test +fileStyleTests i = "file style" ~: + [ "line input" ~: utf8Test iFile + [utf8 "xαβyψ안기q영\nquit\n"] + [ prompt' 0, output 0 (utf8 "xαβyψ안기q영") <> prompt' 1] + , "char input" ~: utf8Test iFileChar + [utf8 "xαβt"] + [ prompt' 0 + , output 0 (utf8 "x") + <> prompt' 1 <> output 1 (utf8 "α") + <> prompt' 2 <> output 2 (utf8 "β") + <> prompt' 3 <> output 3 (utf8 "t") + <> prompt' 4] + , "invalid line input" ~: utf8Test iFile + -- NOTE: the 206 is an incomplete byte sequence, + -- but we MUST not pause since we're at EOF, not just + -- end of term. + -- + -- Also recall GHC bug #5436 which caused a crash + -- if the last byte started an incomplete sequence. + [ utf8 "a" <> raw [149] <> utf8 "x" <> raw [206] ] + [ prompt' 0 + , B.empty + -- It only prompts after the EOF. + , output 0 (utf8 "a" <> err <> utf8 "x" <> err) <> prompt' 1 + ] + , "invalid char input (following a newline)" ~: utf8Test iFileChar + [ utf8 "a\n" <> raw [149] <> utf8 "x\n" <> raw [206] ] + $ [ prompt' 0 + , output 0 (utf8 "a") + <> prompt' 1 <> output 1 err + <> prompt' 2 <> output 2 (utf8 "x") + <> prompt' 3 + <> whenLegacy (output 3 err <> prompt' 4) + ] ++ if legacyEncoding then [] else [ output 3 err <> prompt' 4 ] + , "invalid char file input (no preceding newline)" ~: utf8Test iFileChar + [ utf8 "a" <> raw [149] <> utf8 "x" <> raw [206] ] + -- make sure it tries to read a newline + -- and instead gets the incomplete 206. + -- This should *not* cause it to crash or block. + $ [ prompt' 0 + , output 0 (utf8 "a") + <> prompt' 1 <> output 1 err + <> prompt' 2 <> output 2 (utf8 "x") + <> prompt' 3 + <> whenLegacy (output 3 err <> prompt' 4) + ] ++ if legacyEncoding then [] else [ output 3 err <> prompt' 4 ] + ] + -- also single char and buffer break and other stuff + where + iFile = i { runInTTY = False } + iFileChar = setCharInput iFile + +-- Test that the dumb terminal backend does encoding correctly. +-- 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 :: 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 ii + [ utf8 wideChar, raw [1], raw [5] ] + [ prompt' 0, utf8 wideChar + , utf8 (T.replicate 60 "\b") + , utf8 wideChar + ] + , "line char input" ~: utf8Test (setCharInput ii) + [utf8 "xαβ"] + [ prompt' 0, utf8 "x" <> dumbnl <> output 0 (utf8 "x") + <> prompt' 1 <> utf8 "α" <> dumbnl <> output 1 (utf8 "α") + <> prompt' 2 <> utf8 "β" <> dumbnl <> output 2 (utf8 "β") + <> prompt' 3 + ] + ] + where + ii = setMode m $ setTerm "dumb" i + dumbnl = raw [13,10] + wideChar = T.concat $ replicate 10 $ "안기영" + +------------- +-- Building blocks for expected input/output + +smkx,rmkx :: B.ByteString +smkx = utf8 "\ESC[?1h\ESC=" +rmkx = utf8 "\ESC[?1l\ESC>" + +prompt, prompt' :: Int -> B.ByteString +prompt k = smkx <> prompt' k + +prompt' k = utf8 (T.pack (show k ++ ":")) + +end :: B.ByteString +end = nl <> rmkx + +cr :: B.ByteString +cr = raw [13] + +nl :: B.ByteString +nl = raw [27, 69] + +output :: Int -> B.ByteString -> B.ByteString +output k s = utf8 (T.pack $ "line " ++ show k ++ ":") + <> s <> raw [10] + +wrap :: B.ByteString +wrap = utf8 " \b" + +utf8 :: T.Text -> B.ByteString +utf8 = E.encodeUtf8 + +raw :: [Word8] -> B.ByteString +raw = B.pack + +err :: B.ByteString +err = if legacyEncoding + then utf8 "?" + else utf8 "\65533" + +---------------------- + +utf8Test :: + Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test +utf8Test = testI . setUTF8 + +utf8TestInvalidHist :: + Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test +utf8TestInvalidHist i input output' = test $ do + B.writeFile "myhist" $ invalidHist + assertInvocation (setUTF8 i) input output' + +utf8TestValidHist :: + Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test +utf8TestValidHist i input output' = test $ do + B.writeFile "myhist" validHist + assertInvocation (setUTF8 i) input output' + +latin1TestInvalidHist :: + Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test +latin1TestInvalidHist i input output' = test $ do + B.writeFile "myhist" $ invalidHist + assertInvocation (setLatin1 i) input output'