diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -1,103 +0,0 @@ -Changed in version 0.6.4.6: - * Build with ghc-7.4.1. - -Changed in version 0.6.4.5: - * #116: Prevent hang on 64-bit systems when the prompt contains a control - character. - -Changed in version 0.6.4.4: - * #115: Fix the behavior of the 'f' and 't' commands when deleting text. - * #73: Fix regression: pasting multiple lines could drop some characters. - * Don't require NondecreasingIndentation. - -Changed in version 0.6.4.3: - * Fix a bug on ghc-7.2.1 with tab-completion of Unicode filenames. - -Changed in version 0.6.4.2: - * Various updates for ghc-7.2.1. - -Changed in version 0.6.4: - * Added new function getInputLineWithInitial. - -Changed in version 0.6.3.2: - * Allow building with mtl-2.0.* . - -Changed in version 0.6.3.1: - * Updated contraints for ghc-7.0.1. - - * Fix building on ghc-6.10. - -Changed in version 0.6.3: - * #111: Correct width calculations when the prompt contains newlines. - - * #109: Add function completeWordWithPrev. - - * #101, #44: Extend the API with Behaviors, which control the choice between - terminal-style and file-style interaction. - - * #78: Correct width calculations for escape sequences ("\ESC...\STX") - - * Better warning message when -fterminfo doesn't work. - - * Added getPassword as a new input function. - -Changed in version 0.6.2.4: - * Added back a MonadException instance for mtl's StateT. - -Changed in version 0.6.2.3: - * #110: Recognize the enter key in xterm. - - * #108: Fix behavior after a paste of long, non-ASCII text. - - * #106: Ignore input immediately following an unrecognized control sequence. - - * #104: In vi-mode, allow, e.g., "d2w" as well as "2dw" - - * #103: Fix vi-mode 'c' command with movements. - - * #81: Correctly handle characters with a width > 1. - - * Compatibility updates from the GHC folks for Solaris and for ghc-6.14. - - * Optimization: if several key presses are input all at once (e.g. from a - paste), only display the last change. This can also make Haskeline more - responsive when editing long lines. - - * Hard-code some defaults for ctrl-left and ctrl-right, and provide the - corresponding Emacs bindings to skip words. - -Changed in version 0.6.2.2: - * Raise dependency to utf8-string>=0.3.6 (fixes a bug when decoding invalid - input) - -Changed in version 0.6.2.1: - Internal/API changes: - * Make sure to always use binary mode when expecting Char-as-byte. - - * Eliminate unused import warnings on ghc>=6.11 - - * Increase upper bound on some dependencies for ghc-6.12 - -Changed in version 0.6.2: - - User interface changes: - * A multitude of new emacs and vi commands - - * New preference 'historyDuplicates' to prevent storage of duplicate lines - - * Support PageUp and PageDown keys - - * Let ctrl-L (clear-screen) work during getInputChar - - Internal/API changes: - * Compatibility with ghc-6.12 - - * Calculate the correct width for Unicode combining characters - - * Removed RankNTypes requirement; added Rank2Types and UndecidableInstances - - * Use simpleUserHooks instead of autoconfUserHooks in the Setup script - - * Internal refactoring to make command declaration more flexible - - * Read the .haskeline file completely before starting the UI (laziness issue) diff --git a/Changelog b/Changelog new file mode 100644 --- /dev/null +++ b/Changelog @@ -0,0 +1,294 @@ +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 + * Fix warnings + * Bump the lower bound to ghc-8.0 + +Changed in version 0.7.4.3: + * Bump upper bounds on base, containers, stm and unix + * Fix redundant "Category" field in haskeline.cabal + +Changed in version 0.7.4.2: + * Clean up the rest of the references to trac.haskell.org + +Changed in version 0.7.4.1: + * Bump upper bound on base to support ghc-8.4 + * Use `TChan` from `stm` rather than `Chan` + * Update the homepage since trac.haskell.org has shut down + +Changed in version 0.7.4.0: + * Properly process Unicode key events on Windows. + * Add an instance MonadExcept IdentityT. + * Remove custom Setup logic to support Cabal 2.0. + +Changed in version 0.7.3.1: + * Properly disable echoing in getPassword when running in MinTTY. + * Use `cast` from Data.Typeable instead of Data.Dynamic. + +Changed in version 0.7.3.0: + * Require ghc version of at least 7.4.1, and clean up obsolete code + * Add thread-safe (in terminal-style interaction) external print function + * Add a MonadFix instance for InputT + * Bump upper bounds on `base` and `directory` to support ghc-8.0.2 + +Changed in version 0.7.2.3: + * Fix hsc2hs-related warning on ghc-8 + * Fix the behavior of ctrl-W in the emacs bindings + * Point to github instead of trac + +Changed in version 0.7.2.2: + * Fix Linux to Windows cross-compile + * Canonicalize AMP instances to make the code more future proof + * Generalize constraints for InputT instances + * Bump upper bounds on base and transformers + * Make Haskeline `-Wtabs` clean + +Changed in version 0.7.2.1: + * Fix build on Windows. + +Changed in version 0.7.2.0: + * 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 + * Add Eq/Ord instances to Completion + * Add a "forall" quantifier before rank-n types + +Changed in version 0.7.1.3: + * Add support for transformers-0.4.0.0. + +Changed in version 0.7.1.2: + * Require ghc>=7.0.1. + * Allow building with terminfo-0.4. + +Changed in version 0.7.1.1: + * Point to github for HEAD. + +Changed in version 0.7.1.0: + * Fix build with ghc-7.8. + * Fix build with ghc-6.12.3. + * Fix build on Android. + * Fix build on Win64. + * Add 'catches' to System.Console.Haskeline.MonadException. + +Changed in version 0.7.0.3: + * Fix build with ghc>=7.6.1. + +Changed in version 0.7.0.2: + * Fix build on Windows with ghc>=7.4.1. + +Changed in version 0.7.0.1: + * Fix GHC build by removing a Haskell comment on an #endif line + +Changed in version 0.7.0.0: + API changes: + * Remove System.Console.Haskeline.Encoding + * Make the MonadException class more general (similar to monad-control) + * Don't make InputT an instance of MonadState/MonadReader + * #117: Implement mapInputT + + Internal changes: + * Bump dependencies and general compatibility for ghc-7.6.1 + * Depend on the transformers package instead of mtl + * Don't depend on the extensible-exceptions package + * Don't depend on the utf8-string package (except with ghc<7.4.1) + * Bump the minimum GHC version to 6.10.1 + * Use ScopedTypeVariables instead of PatternSignatures + + Internal fixes: + * Prevent crashes on Windows when writing too many characters at once + or ctrl-L on large window (GHC ticket #4415) + * Remember the user's history and kill ring state after ctrl-c + * Use ccall on Win64 + * Fix terminfo's guess of the window size + +Changed in version 0.6.4.7: + * Bump dependencies to allow mtl-2.1, containers-0.5 and bytestring-0.10. + * Prefix C functions with "haskeline_" so we don't clash with other packages + * Prevent cursor flicker when outputting in the terminfo backend + +Changed in version 0.6.4.6: + * Build with ghc-7.4.1. + +Changed in version 0.6.4.5: + * #116: Prevent hang on 64-bit systems when the prompt contains a control + character. + +Changed in version 0.6.4.4: + * #115: Fix the behavior of the 'f' and 't' commands when deleting text. + * #73: Fix regression: pasting multiple lines could drop some characters. + * Don't require NondecreasingIndentation. + +Changed in version 0.6.4.3: + * Fix a bug on ghc-7.2.1 with tab-completion of Unicode filenames. + +Changed in version 0.6.4.2: + * Various updates for ghc-7.2.1. + +Changed in version 0.6.4: + * Added new function getInputLineWithInitial. + +Changed in version 0.6.3.2: + * Allow building with mtl-2.0.* . + +Changed in version 0.6.3.1: + * Updated contraints for ghc-7.0.1. + + * Fix building on ghc-6.10. + +Changed in version 0.6.3: + * #111: Correct width calculations when the prompt contains newlines. + + * #109: Add function completeWordWithPrev. + + * #101, #44: Extend the API with Behaviors, which control the choice between + terminal-style and file-style interaction. + + * #78: Correct width calculations for escape sequences ("\ESC...\STX") + + * Better warning message when -fterminfo doesn't work. + + * Added getPassword as a new input function. + +Changed in version 0.6.2.4: + * Added back a MonadException instance for mtl's StateT. + +Changed in version 0.6.2.3: + * #110: Recognize the enter key in xterm. + + * #108: Fix behavior after a paste of long, non-ASCII text. + + * #106: Ignore input immediately following an unrecognized control sequence. + + * #104: In vi-mode, allow, e.g., "d2w" as well as "2dw" + + * #103: Fix vi-mode 'c' command with movements. + + * #81: Correctly handle characters with a width > 1. + + * Compatibility updates from the GHC folks for Solaris and for ghc-6.14. + + * Optimization: if several key presses are input all at once (e.g. from a + paste), only display the last change. This can also make Haskeline more + responsive when editing long lines. + + * Hard-code some defaults for ctrl-left and ctrl-right, and provide the + corresponding Emacs bindings to skip words. + +Changed in version 0.6.2.2: + * Raise dependency to utf8-string>=0.3.6 (fixes a bug when decoding invalid + input) + +Changed in version 0.6.2.1: + Internal/API changes: + * Make sure to always use binary mode when expecting Char-as-byte. + + * Eliminate unused import warnings on ghc>=6.11 + + * Increase upper bound on some dependencies for ghc-6.12 + +Changed in version 0.6.2: + + User interface changes: + * A multitude of new emacs and vi commands + + * New preference 'historyDuplicates' to prevent storage of duplicate lines + + * Support PageUp and PageDown keys + + * Let ctrl-L (clear-screen) work during getInputChar + + Internal/API changes: + * Compatibility with ghc-6.12 + + * Calculate the correct width for Unicode combining characters + + * Removed RankNTypes requirement; added Rank2Types and UndecidableInstances + + * Use simpleUserHooks instead of autoconfUserHooks in the Setup script + + * Internal refactoring to make command declaration more flexible + + * Read the .haskeline file completely before starting the UI (laziness issue) 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/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,116 +1,2 @@ -import Distribution.System -import Distribution.Verbosity -import Distribution.PackageDescription import Distribution.Simple -import Distribution.Simple.Program -import Distribution.Simple.Setup -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils - -import Distribution.Simple.PackageIndex -import qualified Distribution.InstalledPackageInfo as Installed - -import System.IO -import System.Exit -import System.Directory -import Control.Exception.Extensible -import Control.Monad(when) - -main :: IO () -main = defaultMainWithHooks myHooks - -myHooks :: UserHooks -myHooks - | buildOS == Windows = simpleUserHooks - | otherwise = simpleUserHooks { - confHook = \genericDescript flags -> do - warnIfNotTerminfo flags - lbi <- confHook simpleUserHooks genericDescript flags - let pkgDescr = localPkgDescr lbi - let Just lib = library pkgDescr - let bi = libBuildInfo lib - bi' <- maybeSetLibiconv flags bi lbi - return lbi {localPkgDescr = pkgDescr { - library = Just lib { - libBuildInfo = bi'}}} - } - --- Test whether compiling a c program that links against libiconv needs -liconv. -maybeSetLibiconv :: ConfigFlags -> BuildInfo -> LocalBuildInfo -> IO BuildInfo -maybeSetLibiconv flags bi lbi = do - let biWithIconv = addIconv bi - let verb = fromFlag (configVerbosity flags) - if hasFlagSet flags (FlagName "libiconv") - then do - putStrLn "Using -liconv." - return biWithIconv - else do - putStr "checking whether to use -liconv... " - hFlush stdout - worksWithout <- tryCompile iconv_prog bi lbi verb - if worksWithout - then do - putStrLn "not needed." - return bi - else do - worksWith <- tryCompile iconv_prog biWithIconv lbi verb - if worksWith - then do - putStrLn "using -liconv." - return biWithIconv - else error "Unable to link against the iconv library." - -hasFlagSet :: ConfigFlags -> FlagName -> Bool -hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags) - -tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool -tryCompile program bi lbi verb = handle processExit $ handle processException $ do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".c" $ \fname cH -> - withTempFile tempDir "" $ \execName oH -> do - hPutStr cH program - hClose cH - hClose oH - -- TODO take verbosity from the args. - rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) - (fname : "-o" : execName : args) - return True - where - processException :: IOException -> IO Bool - processException e = return False - processExit = return . (==ExitSuccess) - -- Mimicing Distribution.Simple.Configure - deps = topologicalOrder (installedPkgs lbi) - args = concat - [ ccOptions bi - , cppOptions bi - , ldOptions bi - -- --extra-include-dirs and --extra-lib-dirs are included - -- in the below fields. - -- Also sometimes a dependency like rts points to a nonstandard - -- include/lib directory where iconv can be found. - , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps) - , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps) - , map ("-l" ++) (extraLibs bi) - ] - -addIconv :: BuildInfo -> BuildInfo -addIconv bi = bi {extraLibs = "iconv" : extraLibs bi} - -iconv_prog :: String -iconv_prog = unlines $ - [ "#include " - , "int main(void) {" - , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");" - , " return 0;" - , "}" - ] - -warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo"))) - $ mapM_ putStrLn - [ "*** Warning: running on POSIX but not building the terminfo backend. ***" - , "You may need to install the terminfo package manually, e.g. with" - , "\"cabal install terminfo\"; or, use \"-fterminfo\" when configuring or" - , "installing this package." - ,"" - ] +main = defaultMain diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs --- a/System/Console/Haskeline.hs +++ b/System/Console/Haskeline.hs @@ -1,19 +1,19 @@ -{- | +{- | A rich user interface for line input in command-line programs. Haskeline is -Unicode-aware and runs both on POSIX-compatible systems and on Windows. +Unicode-aware and runs both on POSIX-compatible systems and on Windows. Users may customize the interface with a @~/.haskeline@ file; see - for more information. + for more information. An example use of this library for a simple read-eval-print loop (REPL) is the following: > import System.Console.Haskeline -> +> > main :: IO () > main = runInputT defaultSettings loop -> where +> where > loop :: InputT IO () > loop = do > minput <- getInputLine "% " @@ -32,12 +32,17 @@ InputT, runInputT, haveTerminalUI, + mapInputT, -- ** Behaviors Behavior, runInputTBehavior, defaultBehavior, useFileHandle, useFile, +#ifndef MINGW + useTermHandles, + useTermHandlesWith, +#endif preferTerm, -- * User interaction functions -- ** Reading user input @@ -46,10 +51,12 @@ getInputLineWithInitial, getInputChar, getPassword, + waitForAnyKey, -- ** Outputting text -- $outputfncs outputStr, outputStrLn, + getExternalPrint, -- * Customization -- ** Settings Settings(..), @@ -57,17 +64,23 @@ setComplete, -- ** User preferences Prefs(), + keyseqTimeoutMs, readPrefs, defaultPrefs, runInputTWithPrefs, runInputTBehaviorWithPrefs, + withRunInBase, + -- ** History + -- $history + getHistory, + putHistory, + modifyHistory, -- * Ctrl-C handling - -- $ctrlc - Interrupt(..), withInterrupt, + Interrupt(..), handleInterrupt, - module System.Console.Haskeline.Completion, - module System.Console.Haskeline.MonadException) + -- * Additional submodules + module System.Console.Haskeline.Completion) where import System.Console.Haskeline.LineState @@ -77,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: @@ -110,7 +125,7 @@ -- | Write a Unicode string to the user's standard output. outputStr :: MonadIO m => String -> InputT m () outputStr xs = do - putter <- asks putStrOut + putter <- InputT $ asks putStrOut liftIO $ putter xs -- | Write a string to the user's standard output, followed by a newline. @@ -121,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. -} @@ -133,10 +150,15 @@ 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) $ unMaybeT . getLocaleLine +getInputLine = promptedInput (getInputCmdLine emptyIM) $ runMaybeT . getLocaleLine {- | Reads one line of input and fills the insertion space with initial text. When using terminal-style interaction, this function provides a rich line-editing user interface with the @@ -153,18 +175,18 @@ > 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) getInputLineWithInitial prompt (left,right) = promptedInput (getInputCmdLine initialIM) - (unMaybeT . getLocaleLine) prompt + (runMaybeT . getLocaleLine) prompt 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 <- asks editMode + emode <- InputT $ asks editMode result <- runInputCmdT tops $ case emode of Emacs -> runCommandLoop tops prefix emacsCommands initialIM Vi -> evalStateT' emptyViState $ @@ -172,17 +194,17 @@ maybeAddHistory result return result -maybeAddHistory :: forall m . Monad m => Maybe String -> InputT m () +maybeAddHistory :: forall m . MonadIO m => Maybe String -> InputT m () maybeAddHistory result = do - settings :: Settings m <- ask - histDupes <- asks historyDuplicates + settings :: Settings m <- InputT ask + histDupes <- InputT $ asks historyDuplicates case result of - Just line | autoAddHistory settings && not (all isSpace line) + Just line | autoAddHistory settings && not (all isSpace line) -> let adder = case histDupes of AlwaysAdd -> addHistory IgnoreConsecutive -> addHistoryUnlessConsecutiveDupe IgnoreAll -> addHistoryRemovingAllDupes - in modify (adder line) + in modifyHistory (adder line) _ -> return () ---------- @@ -195,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 @@ -204,23 +226,49 @@ getPrintableChar :: FileOps -> IO (Maybe Char) getPrintableChar fops = do - c <- unMaybeT $ getLocaleChar fops + c <- runMaybeT $ getLocaleChar fops case fmap isPrint c of Just False -> getPrintableChar fops _ -> return c - -getInputCmdChar :: MonadException m => TermOps -> String -> InputT m (Maybe Char) -getInputCmdChar tops prefix = runInputCmdT tops + +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. @@ -228,74 +276,104 @@ When using file-style interaction, this function turns off echoing while reading the line of input. + +Note that if Haskeline is built against a version of the @Win32@ library +earlier than 2.5, 'getPassword' will incorrectly echo back input on MinTTY +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 $ runCommandLoop tops prefix loop $ Password [] x) - (\fops -> let h_in = inputHandle fops - in bracketSet (hGetEcho h_in) (hSetEcho h_in) False - $ unMaybeT $ getLocaleLine fops) + (\fops -> withoutInputEcho fops $ runMaybeT $ getLocaleLine fops) 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 - +{- $history +The 'InputT' monad transformer provides direct, low-level access to the user's line history state. +However, for most applications, it should suffice to just use the 'autoAddHistory' +and 'historyFile' flags. + +-} + + ------- -- | Wrapper for input functions. -promptedInput :: MonadIO m => (TermOps -> String -> InputT m a) +-- This is the function that calls "wrapFileInput" around file backend input +-- functions (see Term.hs). +promptedInput :: MonadIO m => (TermOps -> Prefix -> InputT m a) -> (FileOps -> IO a) -> String -> InputT m a promptedInput doTerm doFile prompt = do -- If other parts of the program have written text, make sure that it -- appears before we interact with the user on the terminal. liftIO $ hFlush stdout - rterm <- ask + rterm <- InputT ask case termOps rterm of Right fops -> liftIO $ do putStrOut rterm prompt - doFile fops + 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 ------------- --- Interrupt +{- | If Ctrl-C is pressed during the given action, throw an exception +of type 'Interrupt'. For example: -{- $ctrlc -The following functions provide portable handling of Ctrl-C events. +> tryAction :: InputT IO () +> tryAction = handleInterrupt (outputStrLn "Cancelled.") +> $ withInterrupt $ someLongAction -These functions are not necessary on GHC version 6.10 or later, which -processes Ctrl-C events as exceptions by default. --} +The action can handle the interrupt itself; a new 'Interrupt' exception will be thrown +every time Ctrl-C is pressed. --- | If Ctrl-C is pressed during the given computation, throw an exception of type --- 'Interrupt'. -withInterrupt :: MonadException m => InputT m a -> InputT m a -withInterrupt f = do - rterm <- ask - wrapInterrupt rterm f +> tryAction :: InputT IO () +> tryAction = withInterrupt loop +> where loop = handleInterrupt (outputStrLn "Cancelled; try again." >> loop) +> someLongAction --- | Catch and handle an exception of type 'Interrupt'. -handleInterrupt :: MonadException m => m a - -- ^ Handler to run if Ctrl-C is pressed - -> m a -- ^ Computation to run - -> m a -handleInterrupt f = handleDyn $ \Interrupt -> f +This behavior differs from GHC's built-in Ctrl-C handling, which +may immediately terminate the program after the second time that the user presses +Ctrl-C. +-} +withInterrupt :: (MonadIO m, MonadMask m) => InputT m a -> InputT m a +withInterrupt act = do + rterm <- InputT ask + wrapInterrupt rterm act +-- | Catch and handle an exception of type 'Interrupt'. See 'withInterrupt' for +-- more explanation. +-- +-- > 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 :: MonadIO m => InputT m (String -> IO ()) +getExternalPrint = do + rterm <- InputT ask + return $ case termOps rterm of + Right _ -> putStrOut rterm + Left tops -> externalPrint tops 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 @@ -7,9 +7,9 @@ import System.Console.Haskeline.Monads as Monads import System.IO -import qualified Data.ByteString as B -import Control.Concurrent.Chan +import Control.Applicative(Applicative) import Control.Monad(liftM) +import Control.Monad.Catch -- TODO: ---- Put "<" and ">" at end of term if scrolls off. @@ -22,32 +22,24 @@ initWindow = Window {pos=0} newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a} - deriving (Monad, MonadIO, MonadException, - MonadState Window, - MonadReader Handles, MonadReader Encoders) + 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 instance MonadTrans DumbTerm where - lift = DumbTerm . lift . lift . lift + lift = DumbTerm . lift . lift +evalDumb :: (MonadReader Layout m, CommandMonad m) => EvalTerm (PosixT m) +evalDumb = EvalTerm (evalStateT' initWindow . unDumbTerm) (DumbTerm . lift) + runDumbTerm :: Handles -> MaybeT IO RunTerm -runDumbTerm h = do - ch <- liftIO newChan - posixRunTerm h $ \enc -> - TermOps { - getLayout = tryGetLayouts (posixLayouts h) - , withGetEvent = withPosixGetEvent ch h enc [] - , saveUnusedKeys = saveKeys ch - , runTerm = \(RunTermType f) -> - runPosixT enc h - $ evalStateT' initWindow - $ unDumbTerm f - } +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 @@ -57,8 +49,8 @@ printText :: MonadIO m => String -> DumbTerm m () printText str = do - h <- liftM hOut ask - posixEncode str >>= liftIO . B.hPutStr h + h <- liftM ehOut ask + liftIO $ hPutStr h str liftIO $ hFlush h -- Things we can assume a dumb terminal knows how to do diff --git a/System/Console/Haskeline/Backend/IConv.hsc b/System/Console/Haskeline/Backend/IConv.hsc deleted file mode 100644 --- a/System/Console/Haskeline/Backend/IConv.hsc +++ /dev/null @@ -1,156 +0,0 @@ -module System.Console.Haskeline.Backend.IConv( - setLocale, - getCodeset, - openEncoder, - openDecoder, - openPartialDecoder, - Result(..) - ) where - -import Foreign.C -import Foreign -import Data.ByteString (ByteString, useAsCStringLen, append) --- TODO: Base or Internal, depending on whether base>=3. -#ifdef OLD_BASE -import Data.ByteString.Base (createAndTrim') -#else -import Data.ByteString.Internal (createAndTrim') -#endif -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as UTF8 -import Data.Maybe (fromMaybe) - -#include -#include -#include "h_iconv.h" - -openEncoder :: String -> IO (String -> IO ByteString) -openEncoder codeset = do - encodeT <- iconvOpen codeset "UTF-8" - return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString - -openDecoder :: String -> IO (ByteString -> IO String) -openDecoder codeset = do - decodeT <- iconvOpen "UTF-8" codeset - return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT - -dropUTF8Char :: ByteString -> ByteString -dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons - -replacement :: Word8 -replacement = toEnum (fromEnum '?') - --- handle errors by dropping unuseable chars. -simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString -simpleIConv dropper t bs = do - (cs,result) <- iconv t bs - case result of - Invalid rest -> continueOnError cs rest - Incomplete rest -> continueOnError cs rest - _ -> return cs - where - continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`)) - $ simpleIConv dropper t (dropper rest) - -openPartialDecoder :: String -> IO (ByteString -> IO (String, Result)) -openPartialDecoder codeset = do - decodeT <- iconvOpen "UTF-8" codeset - return $ \bs -> do - (s,result) <- iconv decodeT bs - return (UTF8.toString s,result) - ---------------------- --- Setting the locale - -foreign import ccall "setlocale" c_setlocale :: CInt -> CString -> IO CString - -setLocale :: Maybe String -> IO (Maybe String) -setLocale oldLocale = (maybeWith withCAString) oldLocale $ \loc_p -> do - c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCAString - ------------------ --- Getting the encoding - -type NLItem = #type nl_item - -foreign import ccall nl_langinfo :: NLItem -> IO CString - -getCodeset :: IO String -getCodeset = do - str <- nl_langinfo (#const CODESET) >>= peekCAString - -- check for codesets which may be returned by Solaris, but not understood - -- by GNU iconv. - if str `elem` ["","646"] - then return "ISO-8859-1" - else return str - ----------------- --- Iconv - --- TODO: This may not work on platforms where iconv_t is not a pointer. -type IConvT = ForeignPtr () -type IConvTPtr = Ptr () - -foreign import ccall "haskeline_iconv_open" iconv_open - :: CString -> CString -> IO IConvTPtr - -iconvOpen :: String -> String -> IO IConvT -iconvOpen destName srcName = withCAString destName $ \dest -> - withCAString srcName $ \src -> do - res <- iconv_open dest src - if res == nullPtr `plusPtr` (-1) - then throwErrno $ "iconvOpen " - ++ show (srcName,destName) - -- list the two it couldn't convert between? - else newForeignPtr iconv_close res - --- really this returns a CInt, but it's easiest to just ignore that, I think. -foreign import ccall "& haskeline_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ()) - -foreign import ccall "haskeline_iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize - -> Ptr CString -> Ptr CSize -> IO CSize - -data Result = Successful - | Invalid ByteString - | Incomplete ByteString - deriving Show - -iconv :: IConvT -> ByteString -> IO (ByteString,Result) -iconv cd inStr = useAsCStringLen inStr $ \(inPtr, inBuffLen) -> - with inPtr $ \inBuff -> - with (toEnum inBuffLen) $ \inBytesLeft -> do - out <- loop inBuffLen (castPtr inBuff) inBytesLeft - return out - where - -- TODO: maybe a better algorithm for increasing the buffer size? - -- and also maybe a different starting buffer size? - biggerBuffer = (+1) - loop outSize inBuff inBytesLeft = do - (bs, errno) <- partialIconv cd outSize inBuff inBytesLeft - inLeft <- fmap fromEnum $ peek inBytesLeft - let rest = B.drop (B.length inStr - inLeft) inStr - case errno of - Nothing -> return (bs,Successful) - Just err - | err == e2BIG -> do -- output buffer too small - (bs',result) <- loop (biggerBuffer outSize) inBuff inBytesLeft - -- TODO: is this efficient enough? - return (bs `append` bs', result) - | err == eINVAL -> return (bs,Incomplete rest) - | otherwise -> return (bs, Invalid rest) - -partialIconv :: IConvT -> Int -> Ptr CString -> Ptr CSize -> IO (ByteString, Maybe Errno) -partialIconv cd outSize inBuff inBytesLeft = - withForeignPtr cd $ \cd_p -> - createAndTrim' outSize $ \outPtr -> - with outPtr $ \outBuff -> - with (toEnum outSize) $ \outBytesLeft -> do - -- ignore the return value; checking the errno is more reliable. - _ <- c_iconv cd_p inBuff inBytesLeft (castPtr outBuff) outBytesLeft - outLeft <- fmap fromEnum $ peek outBytesLeft - inLeft <- peek inBytesLeft - errno <- if inLeft > 0 - then fmap Just getErrno - else return Nothing - return (0,outSize - outLeft,errno) - 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,15 +1,17 @@ +{-# LANGUAGE CApiFFI #-} + module System.Console.Haskeline.Backend.Posix ( withPosixGetEvent, posixLayouts, tryGetLayouts, PosixT, - runPosixT, - Handles(..), - Encoders(), - posixEncode, + Handles(), + ehIn, + ehOut, mapLines, stdinTTYHandles, ttyHandles, + explicitTTYHandles, posixRunTerm, fileRunTerm ) where @@ -18,14 +20,16 @@ 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 qualified Data.ByteString as B import System.Environment import System.Console.Haskeline.Monads @@ -33,38 +37,43 @@ import System.Console.Haskeline.Term as Term import System.Console.Haskeline.Prefs -import System.Console.Haskeline.Backend.IConv +import System.Console.Haskeline.Backend.Posix.Encoder -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO.FD (fdFD) -import Data.Dynamic (cast) +import Data.Typeable (cast) import System.IO.Error import GHC.IO.Exception import GHC.IO.Handle.Types hiding (getState) import GHC.IO.Handle.Internals import System.Posix.Internals (FD) -#else -import GHC.IOBase(haFD,FD) -import GHC.Handle (withHandle_) -#endif -#ifdef USE_TERMIOS_H +#if defined(USE_TERMIOS_H) || defined(__ANDROID__) #include #endif #include +#include + ----------------------------------------------- -- Input/output handles -data Handles = Handles {hIn, hOut :: Handle, - closeHandles :: IO ()} +data Handles = Handles {hIn, hOut :: ExternalHandle + , closeHandles :: IO ()} +ehIn, ehOut :: Handles -> Handle +ehIn = eH . hIn +ehOut = eH . hOut + ------------------- -- Window size -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 $ hOut h, envLayout] +posixLayouts h = [ioctlLayout $ ehOut h, envLayout] ioctlLayout :: Handle -> IO (Maybe Layout) ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do @@ -76,8 +85,9 @@ then return $ Just Layout {height=fromEnum rows,width=fromEnum cols} else return Nothing +#endif + unsafeHandleToFD :: Handle -> IO FD -#if __GLASGOW_HASKELL__ >= 611 unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h $ \Handle__{haDevice=dev} -> do case cast dev of @@ -85,9 +95,6 @@ "unsafeHandleToFd" (Just h) Nothing) "handle is not a file descriptor") Just fd -> return (fdFD fd) -#else -unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h (return . haFD) -#endif envLayout :: IO (Maybe Layout) envLayout = handle (\(_::IOException) -> return Nothing) $ do @@ -109,7 +116,7 @@ -- Key sequences getKeySequences :: (MonadIO m, MonadReader Prefs m) - => Handles -> [(String,Key)] -> m (TreeMap Char Key) + => Handle -> [(String,Key)] -> m (TreeMap Char Key) getKeySequences h tinfos = do sttys <- liftIO $ sttyKeys h customKeySeqs <- getCustomKeySeqs @@ -143,20 +150,20 @@ -- 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) ] -sttyKeys :: Handles -> IO [(String, Key)] +sttyKeys :: Handle -> IO [(String, Key)] sttyKeys h = do - fd <- unsafeHandleToFD $ hIn h + fd <- unsafeHandleToFD h attrs <- getTerminalAttributes (Fd fd) let getStty (k,c) = do {str <- controlChar attrs k; return ([str],c)} return $ catMaybes $ map getStty [(Erase,simpleKey Backspace),(Kill,simpleKey KillLine)] - + newtype TreeMap a b = TreeMap (Map.Map a (Maybe b, TreeMap a b)) deriving Show @@ -195,93 +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) - => Chan Event -> Handles -> Encoders -> [(String,Key)] +withPosixGetEvent :: (MonadIO m, MonadMask m, MonadReader Prefs m) + => TChan Event -> Handles -> [(String,Key)] -> (m Event -> m a) -> m a -withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do - baseMap <- getKeySequences h termKeys +withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do + baseMap <- getKeySequences (ehIn h) termKeys + timeoutMs <- asks (fromIntegral . keyseqTimeoutMs :: Prefs -> Int) withWindowHandler eventChan - $ f $ liftIO $ getEvent h enc baseMap eventChan + $ f $ liftIO $ getEvent (ehIn h) timeoutMs baseMap eventChan -withWindowHandler :: MonadException m => Chan Event -> m a -> m a -withWindowHandler eventChan = withHandler windowChange $ - Catch $ writeChan eventChan WindowResize +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 + 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 :: Handles -> Encoders -> TreeMap Char Key -> Chan Event -> IO Event -getEvent Handles {hIn=h} enc baseMap = keyEventLoop readKeyEvents - where - bufferSize = 32 - readKeyEvents = do - -- Read at least one character of input, and more if available. - -- In particular, the characters making up a control sequence will all - -- be available at once, so we can process them together with lexKeys. - blockUntilInput h - bs <- B.hGetNonBlocking h bufferSize - cs <- convert h (localeToUnicode enc) bs - return [KeyInput $ lexKeys baseMap cs] - --- Different versions of ghc work better using different functions. -blockUntilInput :: Handle -> IO () -#if __GLASGOW_HASKELL__ >= 611 --- threadWaitRead doesn't work with the new ghc IO library, --- because it keeps a buffer even when NoBuffering is set. -blockUntilInput h = hWaitForInput h (-1) >> return () -#else --- hWaitForInput doesn't work with -threaded on ghc < 6.10 --- (#2363 in ghc's trac) -blockUntilInput h = unsafeHandleToFD h >>= threadWaitRead . Fd -#endif - --- try to convert to the locale encoding using iconv. --- if the buffer has an incomplete shift sequence, --- read another byte of input and try again. -convert :: Handle -> (B.ByteString -> IO (String,Result)) - -> B.ByteString -> IO String -convert h decoder bs = do - (cs,result) <- decoder bs - case result of - Incomplete rest -> do - extra <- B.hGetNonBlocking h 1 - if B.null extra - then return (cs ++ "?") - else fmap (cs ++) - $ convert h decoder (rest `B.append` extra) - Invalid rest -> fmap ((cs ++) . ('?':)) $ convert h decoder (B.drop 1 rest) - _ -> return cs - -getMultiByteChar :: Handle -> (B.ByteString -> IO (String,Result)) - -> MaybeT IO Char -getMultiByteChar h decoder = hWithBinaryMode h $ do - b <- hGetByte h - cs <- liftIO $ convert h decoder (B.pack [b]) - case cs of - [] -> return '?' -- shouldn't happen, but doesn't hurt to be careful. - (c:_) -> return c +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 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] [] + where + -- 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 @@ -289,81 +341,108 @@ guard isInTerm h <- openTerm WriteMode -- Don't close stdin, since a different part of the program may use it later. - return Handles { hIn = stdin, hOut = h, closeHandles = hClose h } + return Handles + { hIn = externalHandle stdin + , hOut = h + , closeHandles = hClose $ eH h + } ttyHandles = do - -- Open the input and output separately, since they need different buffering. + -- Open the input and output as two separate Handles, since they need + -- different buffering. h_in <- openTerm ReadMode h_out <- openTerm WriteMode - return Handles { hIn = h_in, hOut = h_out, - closeHandles = hClose h_in >> hClose h_out } + return Handles + { hIn = h_in + , hOut = h_out + , closeHandles = hClose (eH h_in) >> hClose (eH h_out) + } -openTerm :: IOMode -> MaybeT IO Handle +openTerm :: IOMode -> MaybeT IO ExternalHandle openTerm mode = handle (\(_::IOException) -> mzero) - -- NB: we open the tty as a binary file since otherwise the terminfo - -- backend, which writes output as Chars, would double-encode on ghc-6.12. - $ liftIO $ openBinaryFile "/dev/tty" mode + $ liftIO $ openInCodingMode "/dev/tty" mode -posixRunTerm :: MonadIO m => Handles -> (Encoders -> TermOps) -> m RunTerm -posixRunTerm hs tOps = liftIO $ do - codeset <- getCodeset - encoders <- liftM2 Encoders (openEncoder codeset) - (openPartialDecoder codeset) - fileRT <- fileRunTerm $ hIn hs - return fileRT { - closeTerm = closeTerm fileRT >> closeHandles hs, - -- NOTE: could also alloc Encoders once for each call to wrapRunTerm - termOps = Left $ tOps encoders +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 () } -type PosixT m = ReaderT Encoders (ReaderT Handles m) - -data Encoders = Encoders {unicodeToLocale :: String -> IO B.ByteString, - localeToUnicode :: B.ByteString -> IO (String, Result)} - -posixEncode :: (MonadIO m, MonadReader Encoders m) => String -> m B.ByteString -posixEncode str = do - encoder <- asks unicodeToLocale - liftIO $ encoder str +posixRunTerm :: + Handles + -> [IO (Maybe Layout)] + -> [(String,Key)] + -> (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 + fileRT <- posixFileRunTerm hs + return fileRT + { termOps = Left TermOps + { getLayout = tryGetLayouts layoutGetters + , withGetEvent = wrapGetEvent + . withPosixGetEvent ch hs + keys + , saveUnusedKeys = saveKeys ch + , evalTerm = mapEvalTerm + (runPosixT hs) lift evalBackend + , externalPrint = atomically . writeTChan ch . ExternalPrint + } + , closeTerm = do + flushEventQueue (putStrOut fileRT) ch + closeTerm fileRT + } -runPosixT :: Monad m => Encoders -> Handles -> PosixT m a -> m a -runPosixT enc h = runReaderT' h . runReaderT' enc +type PosixT m = ReaderT Handles m -putTerm :: Handle -> B.ByteString -> IO () -putTerm h str = B.hPutStr h str >> hFlush h +runPosixT :: Handles -> PosixT m a -> m a +runPosixT h = runReaderT' h fileRunTerm :: Handle -> IO RunTerm -fileRunTerm h_in = do - let h_out = stdout - oldLocale <- setLocale (Just "") - codeset <- getCodeset - let encoder str = join $ fmap ($ str) $ openEncoder codeset - let decoder str = join $ fmap ($ str) $ openDecoder codeset - decoder' <- openPartialDecoder codeset - return RunTerm {putStrOut = encoder >=> putTerm h_out, - closeTerm = setLocale oldLocale >> return (), - wrapInterrupt = withSigIntHandler, - encodeForTerm = encoder, - decodeForTerm = decoder, - termOps = Right FileOps { - inputHandle = h_in, - getLocaleChar = getMultiByteChar h_in decoder', - maybeReadNewline = hMaybeReadNewline h_in, - getLocaleLine = Term.hGetLine h_in - >>= liftIO . decoder +fileRunTerm h_in = posixFileRunTerm Handles + { hIn = externalHandle h_in + , hOut = externalHandle stdout + , closeHandles = return () } +posixFileRunTerm :: Handles -> IO RunTerm +posixFileRunTerm hs = do + return RunTerm + { putStrOut = \str -> withCodingMode (hOut hs) $ do + hPutStr (ehOut hs) str + hFlush (ehOut hs) + , closeTerm = closeHandles hs + , wrapInterrupt = withSigIntHandler + , termOps = let h_in = ehIn hs + in Right FileOps + { withoutInputEcho = bracketSet (hGetEcho h_in) + (hSetEcho h_in) + False + , wrapFileInput = withCodingMode (hIn hs) + , getLocaleChar = guardedEOF hGetChar h_in + , maybeReadNewline = hMaybeReadNewline h_in + , getLocaleLine = guardedEOF hGetLine h_in + } } -- NOTE: If we set stdout to NoBuffering, there can be a flicker effect when many -- characters are printed at once. We'll keep it buffered here, and let the Draw -- monad manually flush outputs that don't print a newline. -wrapTerminalOps :: MonadException m => Handles -> m a -> m a -wrapTerminalOps Handles {hIn = h_in, hOut = h_out} = +wrapTerminalOps :: (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... -- - moving to the right -- - breaking line after offset widechar? . bracketSet (hGetBuffering h_out) (hSetBuffering h_out) LineBuffering . bracketSet (hGetEcho h_in) (hSetEcho h_in) False - . hWithBinaryMode h_in + . 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 new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/Backend/Posix/Encoder.hs @@ -0,0 +1,69 @@ +{- | This module provides a wrapper for I/O encoding for the "old" and "new" ways. +The "old" way uses iconv+utf8-string. +The "new" way uses the base library's built-in encoding functionality. +For the "new" way, we require ghc>=7.4.1 due to GHC bug #5436. + +This module exports opaque Encoder/Decoder datatypes, along with several helper +functions that wrap the old/new ways. +-} +module System.Console.Haskeline.Backend.Posix.Encoder ( + ExternalHandle(eH), + externalHandle, + withCodingMode, + openInCodingMode, + ) where + +import Control.Monad.Catch (MonadMask, bracket) +import System.IO +import System.Console.Haskeline.Monads + +import GHC.IO.Encoding (initLocaleEncoding) +import System.Console.Haskeline.Recover + + +-- | An 'ExternalHandle' is a handle which may or may not be in the correct +-- mode for Unicode input/output. When the POSIX backend opens a file +-- (or /dev/tty) it sets it permanently to the correct mode. +-- However, when it uses an existing handle like stdin, it only temporarily +-- sets it to the correct mode (e.g., for the duration of getInputLine); +-- otherwise, we might interfere with the rest of the Haskell program. +-- +-- The correct mode is the locale encoding, set to transliterate errors (rather +-- than crashing, as is the base library's default). See Recover.hs. +data ExternalHandle = ExternalHandle + { externalMode :: ExternalMode + , eH :: Handle + } + +data ExternalMode = CodingMode | OtherMode + +externalHandle :: Handle -> ExternalHandle +externalHandle = ExternalHandle OtherMode + +-- | Use to ensure that an external handle is in the correct mode +-- for the duration of the given action. +withCodingMode :: (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 + liftIO $ hSetEncoding h haskelineEncoding + act + +hSetBinOrEncoding :: Handle -> Maybe TextEncoding -> IO () +hSetBinOrEncoding h Nothing = hSetBinaryMode h True +hSetBinOrEncoding h (Just enc) = hSetEncoding h enc + +haskelineEncoding :: TextEncoding +haskelineEncoding = transliterateFailure initLocaleEncoding + +-- Open a file and permanently set it to the correct mode. +openInCodingMode :: FilePath -> IOMode -> IO ExternalHandle +openInCodingMode path iomode = do + h <- openFile path iomode + hSetEncoding h haskelineEncoding + return $ ExternalHandle CodingMode h + + + 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,3 +1,6 @@ +#if __GLASGOW_HASKELL__ < 802 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif module System.Console.Haskeline.Backend.Terminfo( Draw(), runTerminfoDraw @@ -6,12 +9,11 @@ import System.Console.Terminfo import Control.Monad +import Control.Monad.Catch import Data.List(foldl') import System.IO -import qualified Control.Exception.Extensible as Exception -import qualified Data.ByteString.Char8 as B +import qualified Control.Exception as Exception import Data.Maybe (fromMaybe, mapMaybe) -import Control.Concurrent.Chan import qualified Data.IntMap as Map import System.Console.Haskeline.Monads as Monads @@ -21,7 +23,7 @@ import System.Console.Haskeline.Backend.WCWidth import System.Console.Haskeline.Key -import qualified Control.Monad.Writer as Writer +import qualified Control.Monad.Trans.Writer as Writer ---------------------------------------------------------------- -- Low-level terminal output @@ -104,41 +106,39 @@ (StateT TermRows (StateT TermPos (PosixT m))))) a} - deriving (Monad, MonadIO, MonadException, + deriving (Functor, Applicative, Monad, MonadIO, + MonadMask, MonadThrow, MonadCatch, MonadReader Actions, MonadReader Terminal, MonadState TermPos, - MonadState TermRows, - MonadReader Handles, MonadReader Encoders) + MonadState TermRows, MonadReader Handles) instance MonadTrans Draw where - lift = Draw . lift . lift . lift . lift . lift . lift - -runTerminfoDraw :: Handles -> MaybeT IO RunTerm -runTerminfoDraw h = do - mterm <- liftIO $ Exception.try setupTermFromEnv - ch <- liftIO newChan + lift = Draw . lift . lift . lift . lift . lift + +evalDraw :: forall m . (MonadReader Layout m, CommandMonad m) => Terminal -> Actions -> EvalTerm (PosixT m) +evalDraw term actions = EvalTerm eval liftE + where + liftE = Draw . lift . lift . lift . lift + eval = evalStateT' initTermPos + . evalStateT' initTermRows + . runReaderT' term + . runReaderT' actions + . unDraw + + +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 actions <- MaybeT $ return $ getCapability term getActions - posixRunTerm h $ \enc -> - TermOps { - getLayout = tryGetLayouts (posixLayouts h - ++ [tinfoLayout term]) - , withGetEvent = wrapKeypad (hOut h) term - . withPosixGetEvent ch h enc - (terminfoKeys term) - , saveUnusedKeys = saveKeys ch - , runTerm = \(RunTermType f) -> - runPosixT enc h - $ evalStateT' initTermPos - $ evalStateT' initTermRows - $ runReaderT' term - $ runReaderT' actions - $ unDraw f - } + liftIO $ posixRunTerm h (posixLayouts h ++ [tinfoLayout term]) + (terminfoKeys term) + (wrapKeypad (ehOut h) term) + (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 @@ -147,8 +147,8 @@ tinfoLayout :: Terminal -> IO (Maybe Layout) tinfoLayout term = return $ getCapability term $ do - r <- termColumns - c <- termLines + c <- termColumns + r <- termLines return Layout {height=r,width=c} terminfoKeys :: Terminal -> [(String,Key)] @@ -192,15 +192,17 @@ (x,action) <- Writer.runWriterT m toutput <- asks action term <- ask - ttyh <- liftM hOut ask + ttyh <- liftM ehOut ask liftIO $ hRunTermOutput ttyh term toutput return x output :: TermAction -> ActionM () -output = Writer.tell +output t = Writer.tell t -- NB: explicit argument enables build with ghc-6.12.3 + -- (Probably related to the monomorphism restriction; + -- see GHC ticket #1749). outputText :: String -> ActionM () -outputText str = posixEncode str >>= output . const . termText . B.unpack +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,456 +1,579 @@ -module System.Console.Haskeline.Backend.Win32( - win32Term, - win32TermStdin, - fileRunTerm - )where - - -import System.IO -import Foreign -import Foreign.C -import System.Win32 hiding (multiByteToWideChar) -import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE) -import Data.List(intercalate) -import Control.Concurrent hiding (throwTo) -import Data.Char(isPrint) -import Data.Maybe(mapMaybe) -import Control.Monad - -import System.Console.Haskeline.Key -import System.Console.Haskeline.Monads -import System.Console.Haskeline.LineState -import System.Console.Haskeline.Term as Term - -import Data.ByteString.Internal (createAndTrim) -import qualified Data.ByteString as B - -#include "win_console.h" - -foreign import stdcall "windows.h ReadConsoleInputW" c_ReadConsoleInput - :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool - -foreign import stdcall "windows.h WaitForSingleObject" c_WaitForSingleObject - :: HANDLE -> DWORD -> IO DWORD - -foreign import stdcall "windows.h GetNumberOfConsoleInputEvents" - c_GetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO Bool - -getNumberOfEvents :: HANDLE -> IO Int -getNumberOfEvents h = alloca $ \numEventsPtr -> do - failIfFalse_ "GetNumberOfConsoleInputEvents" - $ c_GetNumberOfConsoleInputEvents h numEventsPtr - fmap fromEnum $ peek numEventsPtr - -getEvent :: HANDLE -> Chan Event -> IO Event -getEvent h = keyEventLoop (eventReader h) - -eventReader :: HANDLE -> IO [Event] -eventReader h = do - let waitTime = 500 -- milliseconds - ret <- c_WaitForSingleObject h waitTime - yield -- otherwise, the above foreign call causes the loop to never - -- respond to the killThread - if ret /= (#const WAIT_OBJECT_0) - then eventReader h - else do - es <- readEvents h - return $ mapMaybe processEvent es - -consoleHandles :: MaybeT IO Handles -consoleHandles = do - h_in <- open "CONIN$" - h_out <- open "CONOUT$" - return Handles { hIn = h_in, hOut = h_out } - where - open file = handle (\(_::IOException) -> mzero) $ liftIO - $ createFile file (gENERIC_READ .|. gENERIC_WRITE) - (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing - oPEN_EXISTING 0 Nothing - - -processEvent :: InputEvent -> Maybe Event -processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc, - controlKeyState = cstate} - = fmap (\e -> KeyInput [Key modifier' e]) $ keyFromCode vc `mplus` simpleKeyChar - where - simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c) - testMod ck = (cstate .&. ck) /= 0 - modifier' = if hasMeta modifier && hasControl modifier - then noModifier {hasShift = hasShift modifier} - else modifier - modifier = Modifier {hasMeta = testMod ((#const RIGHT_ALT_PRESSED) - .|. (#const LEFT_ALT_PRESSED)) - ,hasControl = testMod ((#const RIGHT_CTRL_PRESSED) - .|. (#const LEFT_CTRL_PRESSED)) - && not (c > '\NUL' && c <= '\031') - ,hasShift = testMod (#const SHIFT_PRESSED) - && not (isPrint c) - } - -processEvent WindowEvent = Just WindowResize -processEvent _ = Nothing - -keyFromCode :: WORD -> Maybe BaseKey -keyFromCode (#const VK_BACK) = Just Backspace -keyFromCode (#const VK_LEFT) = Just LeftKey -keyFromCode (#const VK_RIGHT) = Just RightKey -keyFromCode (#const VK_UP) = Just UpKey -keyFromCode (#const VK_DOWN) = Just DownKey -keyFromCode (#const VK_DELETE) = Just Delete -keyFromCode (#const VK_HOME) = Just Home -keyFromCode (#const VK_END) = Just End -keyFromCode (#const VK_PRIOR) = Just PageUp -keyFromCode (#const VK_NEXT) = Just PageDown --- The Windows console will return '\r' when return is pressed. -keyFromCode (#const VK_RETURN) = Just (KeyChar '\n') --- TODO: KillLine? --- TODO: function keys. -keyFromCode _ = Nothing - -data InputEvent = KeyEvent {keyDown :: BOOL, - repeatCount :: WORD, - virtualKeyCode :: WORD, - virtualScanCode :: WORD, - unicodeChar :: Char, - controlKeyState :: DWORD} - -- TODO: WINDOW_BUFFER_SIZE_RECORD - -- I cant figure out how the user generates them. - | WindowEvent - | OtherEvent - deriving Show - -peekEvent :: Ptr () -> IO InputEvent -peekEvent pRecord = do - eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord - let eventPtr = (#ptr INPUT_RECORD, Event) pRecord - case eventType of - (#const KEY_EVENT) -> getKeyEvent eventPtr - (#const WINDOW_BUFFER_SIZE_EVENT) -> return WindowEvent - _ -> return OtherEvent - -readEvents :: HANDLE -> IO [InputEvent] -readEvents h = do - n <- getNumberOfEvents h - alloca $ \numEventsPtr -> - allocaBytes (n * #size INPUT_RECORD) $ \pRecord -> do - failIfFalse_ "ReadConsoleInput" - $ c_ReadConsoleInput h pRecord (toEnum n) numEventsPtr - numRead <- fmap fromEnum $ peek numEventsPtr - forM [0..toEnum numRead-1] $ \i -> peekEvent - $ pRecord `plusPtr` (i * #size INPUT_RECORD) - -getKeyEvent :: Ptr () -> IO InputEvent -getKeyEvent p = do - kDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) p - repeat' <- (#peek KEY_EVENT_RECORD, wRepeatCount) p - keyCode <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) p - scanCode <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) p - char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p - state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p - return KeyEvent {keyDown = kDown', - repeatCount = repeat', - virtualKeyCode = keyCode, - virtualScanCode = scanCode, - unicodeChar = toEnum (fromEnum char), - controlKeyState = state} - -data Coord = Coord {coordX, coordY :: Int} - deriving Show - -#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) -instance Storable Coord where - 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} - poke p c = do - (#poke COORD, X) p (toEnum (coordX c) :: CShort) - (#poke COORD, Y) p (toEnum (coordY c) :: CShort) - - -foreign import ccall "haskeline_SetPosition" - c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool - -setPosition :: HANDLE -> Coord -> IO () -setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition" - . c_SetPosition h - -foreign import stdcall "windows.h GetConsoleScreenBufferInfo" - c_GetScreenBufferInfo :: HANDLE -> Ptr () -> IO Bool - -getPosition :: HANDLE -> IO Coord -getPosition = withScreenBufferInfo $ - (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) - -withScreenBufferInfo :: (Ptr () -> IO a) -> HANDLE -> IO a -withScreenBufferInfo f h = allocaBytes (#size CONSOLE_SCREEN_BUFFER_INFO) - $ \infoPtr -> do - failIfFalse_ "GetConsoleScreenBufferInfo" - $ c_GetScreenBufferInfo h infoPtr - f infoPtr - -getBufferSize :: HANDLE -> IO Layout -getBufferSize = withScreenBufferInfo $ \p -> do - c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p - return Layout {width = coordX c, height = coordY c} - -foreign import stdcall "windows.h WriteConsoleW" c_WriteConsoleW - :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool - -writeConsole :: HANDLE -> String -> IO () --- For some reason, Wine returns False when WriteConsoleW is called on an empty --- string. Easiest fix: just don't call that function. -writeConsole _ "" = return () -writeConsole h str = withArray tstr $ \t_arr -> alloca $ \numWritten -> do - failIfFalse_ "WriteConsole" - $ c_WriteConsoleW h t_arr (toEnum $ length str) numWritten nullPtr - where - tstr = map (toEnum . fromEnum) str - -foreign import stdcall "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool - -messageBeep :: IO () -messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures. - - ----------- --- Console mode -foreign import stdcall "windows.h GetConsoleMode" c_GetConsoleMode - :: HANDLE -> Ptr DWORD -> IO Bool - -foreign import stdcall "windows.h SetConsoleMode" c_SetConsoleMode - :: HANDLE -> DWORD -> IO Bool - -withWindowMode :: MonadException m => Handles -> m a -> m a -withWindowMode hs f = do - let h = hIn hs - bracket (getConsoleMode h) (setConsoleMode h) - $ \m -> setConsoleMode h (m .|. (#const ENABLE_WINDOW_INPUT)) >> f - where - getConsoleMode h = liftIO $ alloca $ \p -> do - failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h p - peek p - setConsoleMode h m = liftIO $ failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h m - ----------------------------- --- Drawing - -data Handles = Handles { hIn, hOut :: HANDLE } - -closeHandles :: Handles -> IO () -closeHandles hs = closeHandle (hIn hs) >> closeHandle (hOut hs) - -newtype Draw m a = Draw {runDraw :: ReaderT Handles m a} - deriving (Monad,MonadIO,MonadException, MonadReader Handles) - -type DrawM a = (MonadIO m, MonadReader Layout m) => Draw m () - -instance MonadTrans Draw where - lift = Draw . lift - -getPos :: MonadIO m => Draw m Coord -getPos = asks hOut >>= liftIO . getPosition - -setPos :: MonadIO m => Coord -> Draw m () -setPos c = do - h <- asks hOut - liftIO (setPosition h c) - -printText :: MonadIO m => String -> Draw m () -printText txt = do - h <- asks hOut - liftIO (writeConsole h txt) - -printAfter :: String -> DrawM () -printAfter str = do - printText str - movePos $ negate $ length str - -drawLineDiffWin :: LineChars -> LineChars -> DrawM () -drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of - ([],[]) | ys1 == ys2 -> return () - (xs1',[]) | xs1' ++ ys1 == ys2 -> movePos $ negate $ length xs1' - ([],xs2') | ys1 == xs2' ++ ys2 -> movePos $ length xs2' - (xs1',xs2') -> do - movePos (negate $ length xs1') - let m = length xs1' + length ys1 - (length xs2' + length ys2) - let deadText = replicate m ' ' - printText (graphemesToString xs2') - printAfter (graphemesToString ys2 ++ deadText) - -movePos :: Int -> DrawM () -movePos n = do - Coord {coordX = x, coordY = y} <- getPos - w <- asks width - let (h,x') = divMod (x+n) w - setPos Coord {coordX = x', coordY = y+h} - -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) - -- 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. - reposition _ _ = return () - - printLines [] = return () - printLines ls = printText $ intercalate crlf ls ++ crlf - - clearLayout = do - lay <- ask - setPos (Coord 0 0) - printText (replicate (width lay * height lay) ' ') - setPos (Coord 0 0) - - moveToNextLine s = do - movePos (lengthToEnd s) - printText "\r\n" -- make the console take care of creating a new line - - ringBell True = liftIO messageBeep - ringBell False = return () -- TODO - -win32TermStdin :: MaybeT IO RunTerm -win32TermStdin = do - liftIO (hIsTerminalDevice stdin) >>= guard - win32Term - -win32Term :: MaybeT IO RunTerm -win32Term = do - hs <- consoleHandles - ch <- liftIO newChan - fileRT <- liftIO $ fileRunTerm stdin - return fileRT { - termOps = Left TermOps { - getLayout = getBufferSize (hOut hs) - , withGetEvent = withWindowMode hs - . win32WithEvent hs ch - , saveUnusedKeys = saveKeys ch - , runTerm = \(RunTermType f) -> - runReaderT' hs $ runDraw f - }, - closeTerm = closeHandles hs - } - -win32WithEvent :: MonadException m => Handles -> Chan Event - -> (m Event -> m a) -> m a -win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan - --- stdin is not a terminal, but we still need to check the right way to output unicode to stdout. -fileRunTerm :: Handle -> IO RunTerm -fileRunTerm h_in = do - putter <- putOut - cp <- getCodePage - return RunTerm { - closeTerm = return (), - putStrOut = putter, - encodeForTerm = unicodeToCodePage cp, - decodeForTerm = codePageToUnicode cp, - wrapInterrupt = withCtrlCHandler, - termOps = Right FileOps { - inputHandle = h_in, - getLocaleChar = getMultiByteChar cp h_in, - maybeReadNewline = hMaybeReadNewline h_in, - getLocaleLine = Term.hGetLine h_in - >>= liftIO . codePageToUnicode cp - } - - } - --- On Windows, Unicode written to the console must be written with the WriteConsole API call. --- And to make the API cross-platform consistent, Unicode to a file should be UTF-8. -putOut :: IO (String -> IO ()) -putOut = do - outIsTerm <- hIsTerminalDevice stdout - if outIsTerm - then do - h <- getStdHandle sTD_OUTPUT_HANDLE - return (writeConsole h) - else do - cp <- getCodePage - return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout - - - -type Handler = DWORD -> IO BOOL - -foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler) - -foreign import stdcall "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler - :: FunPtr Handler -> BOOL -> IO BOOL - --- sets the tv to True when ctrl-c is pressed. -withCtrlCHandler :: MonadException m => m a -> m a -withCtrlCHandler f = bracket (liftIO $ do - tid <- myThreadId - fp <- wrapHandler (handler tid) - -- don't fail if we can't set the ctrl-c handler - -- for example, we might not be attached to a console? - _ <- c_SetConsoleCtrlHandler fp True - return fp) - (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False) - (const f) - where - handler tid (#const CTRL_C_EVENT) = do - throwTo tid Interrupt - return True - handler _ _ = return False - - ------------------------- --- Multi-byte conversion - -foreign import stdcall "WideCharToMultiByte" wideCharToMultiByte - :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt - -> LPCSTR -> LPBOOL -> IO CInt - -unicodeToCodePage :: CodePage -> String -> IO B.ByteString -unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do - -- first, ask for the length without filling the buffer. - outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) - nullPtr 0 nullPtr nullPtr - -- then, actually perform the encoding. - createAndTrim (fromEnum outSize) $ \outBuff -> - fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) - (castPtr outBuff) outSize nullPtr nullPtr - -foreign import stdcall "MultiByteToWideChar" multiByteToWideChar - :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt - -codePageToUnicode :: CodePage -> B.ByteString -> IO String -codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do - -- first ask for the size without filling the buffer. - outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0 - -- then, actually perform the decoding. - allocaArray0 (fromEnum outSize) $ \outBuff -> do - outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize - peekCWStringLen (outBuff, fromEnum outSize') - - -getCodePage :: IO CodePage -getCodePage = do - conCP <- getConsoleCP - if conCP > 0 - then return conCP - else getACP - -foreign import stdcall "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx - :: CodePage -> BYTE -> BOOL - -getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char -getMultiByteChar cp h = hWithBinaryMode h loop - where - loop = do - b1 <- hGetByte h - bs <- if c_IsDBCSLeadByteEx cp b1 - then hGetByte h >>= \b2 -> return [b1,b2] - else return [b1] - cs <- liftIO $ codePageToUnicode cp (B.pack bs) - case cs of - [] -> loop - (c:_) -> return c +{-# LANGUAGE CPP #-} + +module System.Console.Haskeline.Backend.Win32( + win32Term, + win32TermStdin, + fileRunTerm + )where + + +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, 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 +import System.Console.Haskeline.LineState +import System.Console.Haskeline.Term +import System.Console.Haskeline.Backend.WCWidth +import System.Console.Haskeline.Backend.Win32.Echo (hWithoutInputEcho) + +import Data.ByteString.Internal (createAndTrim) +import qualified Data.ByteString as B + +#include "win_console.h" +##include "windows_cconv.h" + +foreign import WINDOWS_CCONV "windows.h ReadConsoleInputW" c_ReadConsoleInput + :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool + +foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" c_WaitForSingleObject + :: HANDLE -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV "windows.h GetNumberOfConsoleInputEvents" + c_GetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO Bool + +getNumberOfEvents :: HANDLE -> IO Int +getNumberOfEvents h = alloca $ \numEventsPtr -> do + failIfFalse_ "GetNumberOfConsoleInputEvents" + $ c_GetNumberOfConsoleInputEvents h numEventsPtr + fmap fromEnum $ peek numEventsPtr + +getEvent :: HANDLE -> TChan Event -> IO Event +getEvent h = keyEventLoop (eventReader h) + +eventReader :: HANDLE -> IO [Event] +eventReader h = do + let waitTime = 500 -- milliseconds + ret <- c_WaitForSingleObject h waitTime + yield -- otherwise, the above foreign call causes the loop to never + -- respond to the killThread + if ret /= (#const WAIT_OBJECT_0) + then eventReader h + else do + es <- readEvents h + 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$" + h_out <- open "CONOUT$" + return Handles { hIn = h_in, hOut = h_out } + where + open file = handle (\(_::IOException) -> mzero) $ liftIO + $ createFile file (gENERIC_READ .|. gENERIC_WRITE) + (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing + oPEN_EXISTING 0 Nothing + + +processEvent :: InputEvent -> Maybe Event +processEvent KeyEvent {keyDown = kd, unicodeChar = c, virtualKeyCode = vc, + controlKeyState = cstate} + | kd || ((testMod (#const LEFT_ALT_PRESSED) || vc == (#const VK_MENU)) + && c /= '\NUL') + -- Make sure not to ignore Unicode key events! The Unicode character might + -- only be emitted on a keyup event. See also GH issue #54. + = fmap (\e -> KeyInput [Key modifier' e]) $ keyFromCode vc `mplus` simpleKeyChar + where + simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c) + testMod ck = (cstate .&. ck) /= 0 + modifier' = if hasMeta modifier && hasControl modifier + then noModifier {hasShift = hasShift modifier} + else modifier + modifier = Modifier {hasMeta = testMod ((#const RIGHT_ALT_PRESSED) + .|. (#const LEFT_ALT_PRESSED)) + ,hasControl = testMod ((#const RIGHT_CTRL_PRESSED) + .|. (#const LEFT_CTRL_PRESSED)) + && not (c > '\NUL' && c <= '\031') + ,hasShift = testMod (#const SHIFT_PRESSED) + && not (isPrint c) + } + +processEvent WindowEvent = Just WindowResize +processEvent _ = Nothing + +keyFromCode :: WORD -> Maybe BaseKey +keyFromCode (#const VK_BACK) = Just Backspace +keyFromCode (#const VK_LEFT) = Just LeftKey +keyFromCode (#const VK_RIGHT) = Just RightKey +keyFromCode (#const VK_UP) = Just UpKey +keyFromCode (#const VK_DOWN) = Just DownKey +keyFromCode (#const VK_DELETE) = Just Delete +keyFromCode (#const VK_HOME) = Just Home +keyFromCode (#const VK_END) = Just End +keyFromCode (#const VK_PRIOR) = Just PageUp +keyFromCode (#const VK_NEXT) = Just PageDown +-- The Windows console will return '\r' when return is pressed. +keyFromCode (#const VK_RETURN) = Just (KeyChar '\n') +-- TODO: KillLine? +-- TODO: function keys. +keyFromCode _ = Nothing + +data InputEvent = KeyEvent {keyDown :: BOOL, + repeatCount :: WORD, + virtualKeyCode :: WORD, + virtualScanCode :: WORD, + unicodeChar :: Char, + controlKeyState :: DWORD} + -- TODO: WINDOW_BUFFER_SIZE_RECORD + -- I can't figure out how the user generates them. + | WindowEvent + | OtherEvent + deriving Show + +peekEvent :: Ptr () -> IO InputEvent +peekEvent pRecord = do + eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord + let eventPtr = (#ptr INPUT_RECORD, Event) pRecord + case eventType of + (#const KEY_EVENT) -> getKeyEvent eventPtr + (#const WINDOW_BUFFER_SIZE_EVENT) -> return WindowEvent + _ -> return OtherEvent + +readEvents :: HANDLE -> IO [InputEvent] +readEvents h = do + n <- getNumberOfEvents h + alloca $ \numEventsPtr -> + allocaBytes (n * #size INPUT_RECORD) $ \pRecord -> do + failIfFalse_ "ReadConsoleInput" + $ c_ReadConsoleInput h pRecord (toEnum n) numEventsPtr + numRead <- fmap fromEnum $ peek numEventsPtr + forM [0..toEnum numRead-1] $ \i -> peekEvent + $ pRecord `plusPtr` (i * #size INPUT_RECORD) + +getKeyEvent :: Ptr () -> IO InputEvent +getKeyEvent p = do + kDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) p + repeat' <- (#peek KEY_EVENT_RECORD, wRepeatCount) p + keyCode <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) p + scanCode <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) p + char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p + state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p + return KeyEvent {keyDown = kDown', + repeatCount = repeat', + virtualKeyCode = keyCode, + virtualScanCode = scanCode, + unicodeChar = toEnum (fromEnum char), + controlKeyState = state} + +data Coord = Coord {coordX, coordY :: Int} + deriving Show + +instance Storable Coord where + sizeOf _ = (#size COORD) + alignment _ = (#alignment COORD) + peek p = do + 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) + + +foreign import ccall "haskeline_SetPosition" + c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool + +setPosition :: HANDLE -> Coord -> IO () +setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition" + . c_SetPosition h + +foreign import WINDOWS_CCONV "windows.h GetConsoleScreenBufferInfo" + c_GetScreenBufferInfo :: HANDLE -> Ptr () -> IO Bool + +getPosition :: HANDLE -> IO Coord +getPosition = withScreenBufferInfo $ + (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition) + +withScreenBufferInfo :: (Ptr () -> IO a) -> HANDLE -> IO a +withScreenBufferInfo f h = allocaBytes (#size CONSOLE_SCREEN_BUFFER_INFO) + $ \infoPtr -> do + failIfFalse_ "GetConsoleScreenBufferInfo" + $ c_GetScreenBufferInfo h infoPtr + f infoPtr + +getBufferSize :: HANDLE -> IO Layout +getBufferSize = withScreenBufferInfo $ \p -> do + c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p + return Layout {width = coordX c, height = coordY c} + +foreign import WINDOWS_CCONV "windows.h WriteConsoleW" c_WriteConsoleW + :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool + +writeConsole :: HANDLE -> String -> IO () +-- For some reason, Wine returns False when WriteConsoleW is called on an empty +-- string. Easiest fix: just don't call that function. +writeConsole _ "" = return () +writeConsole h str = writeConsole' >> writeConsole h ys + where + (xs,ys) = splitAt limit str + -- WriteConsoleW has a buffer limit which is documented as 32768 word8's, + -- but bug reports from online suggest that the limit may be lower (~25000). + -- 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' + = withCWStringLen xs + $ \(t_arr, len) -> alloca $ \numWritten -> do + failIfFalse_ "WriteConsoleW" + $ c_WriteConsoleW h t_arr (toEnum len) + numWritten nullPtr + +foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool + +messageBeep :: IO () +messageBeep = c_messageBeep simpleBeep >> return ()-- intentionally ignore failures. + where simpleBeep = 0xffffffff + + +---------- +-- Console mode +foreign import WINDOWS_CCONV "windows.h GetConsoleMode" c_GetConsoleMode + :: HANDLE -> Ptr DWORD -> IO Bool + +foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode + :: HANDLE -> DWORD -> IO Bool + +withWindowMode :: (MonadIO m, MonadMask m) => Handles -> m a -> m a +withWindowMode hs f = do + let h = hIn hs + bracket (getConsoleMode h) (setConsoleMode h) + $ \m -> setConsoleMode h (m .|. (#const ENABLE_WINDOW_INPUT)) >> f + where + getConsoleMode h = liftIO $ alloca $ \p -> do + failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h p + peek p + setConsoleMode h m = liftIO $ failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h m + +---------------------------- +-- Drawing + +data Handles = Handles { hIn, hOut :: HANDLE } + +closeHandles :: Handles -> IO () +closeHandles hs = closeHandle (hIn hs) >> closeHandle (hOut hs) + +newtype Draw m a = Draw {runDraw :: ReaderT Handles m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadReader Handles, + MonadThrow, MonadCatch, MonadMask) + +type DrawM a = forall m . (MonadIO m, MonadReader Layout m) => Draw m a + +instance MonadTrans Draw where + lift = Draw . lift + +getPos :: MonadIO m => Draw m Coord +getPos = asks hOut >>= liftIO . getPosition + +setPos :: Coord -> DrawM () +setPos c = do + h <- asks hOut + -- SetPosition will fail if you give it something out of bounds of + -- the window buffer (i.e., the input line doesn't fit in the window). + -- So we do a simple guard against that uncommon case. + -- However, we don't throw away the x coord since it produces sensible + -- results for some cases. + maxY <- liftM (subtract 1) $ asks height + liftIO $ setPosition h c { coordY = max 0 $ min maxY $ coordY c } + +printText :: MonadIO m => String -> Draw m () +printText txt = do + h <- asks hOut + liftIO (writeConsole h txt) + +printAfter :: [Grapheme] -> DrawM () +printAfter gs = do + -- NOTE: you may be tempted to write + -- do {p <- getPos; printText (...); setPos p} + -- Unfortunately, that would be WRONG, because if printText wraps + -- a line at the bottom of the window, causing the window to scroll, + -- then the old value of p will be incorrect. + printText (graphemesToString gs) + movePosLeft gs + +drawLineDiffWin :: LineChars -> LineChars -> DrawM () +drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of + ([],[]) | ys1 == ys2 -> return () + (xs1',[]) | xs1' ++ ys1 == ys2 -> movePosLeft xs1' + ([],xs2') | ys1 == xs2' ++ ys2 -> movePosRight xs2' + (xs1',xs2') -> do + movePosLeft xs1' + let m = gsWidth xs1' + gsWidth ys1 - (gsWidth xs2' + gsWidth ys2) + let deadText = stringToGraphemes $ replicate m ' ' + printText (graphemesToString xs2') + printAfter (ys2 ++ deadText) + +movePosRight, movePosLeft :: [Grapheme] -> DrawM () +movePosRight str = do + p <- getPos + w <- asks width + setPos $ moveCoord w p str + where + moveCoord _ p [] = p + moveCoord w p cs = case splitAtWidth (w - coordX p) cs of + (_,[],len) | len < w - coordX p -- stayed on same line + -> Coord { coordY = coordY p, + coordX = coordX p + len + } + (_,cs',_) -- moved to next line + -> moveCoord w Coord { + coordY = coordY p + 1, + coordX = 0 + } cs' + +movePosLeft str = do + p <- getPos + w <- asks width + setPos $ moveCoord w p str + where + moveCoord _ p [] = p + moveCoord w p cs = case splitAtWidth (coordX p) cs of + (_,[],len) -- stayed on same line + -> Coord { coordY = coordY p, + coordX = coordX p - len + } + (_,_:cs',_) -- moved to previous line + -> moveCoord w Coord { + coordY = coordY p - 1, + coordX = w-1 + } cs' + +crlf :: String +crlf = "\r\n" + +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. + reposition _ _ = return () + + printLines [] = return () + printLines ls = printText $ intercalate crlf ls ++ crlf + + clearLayout = clearScreen + + moveToNextLine s = do + movePosRight (snd s) + printText "\r\n" -- make the console take care of creating a new line + + ringBell True = liftIO messageBeep + ringBell False = return () -- TODO + +win32TermStdin :: MaybeT IO RunTerm +win32TermStdin = do + liftIO (hIsTerminalDevice stdin) >>= guard + win32Term + +win32Term :: MaybeT IO RunTerm +win32Term = do + hs <- consoleHandles + ch <- liftIO newTChanIO + fileRT <- liftIO $ fileRunTerm stdin + return fileRT + { termOps = Left TermOps { + getLayout = getBufferSize (hOut hs) + , withGetEvent = withWindowMode hs + . win32WithEvent hs ch + , saveUnusedKeys = saveKeys ch + , evalTerm = EvalTerm (runReaderT' hs . runDraw) + (Draw . lift) + , externalPrint = atomically . writeTChan ch . ExternalPrint + } + , closeTerm = do + flushEventQueue (putStrOut fileRT) ch + closeHandles hs + } + +win32WithEvent :: MonadIO m => Handles -> TChan Event + -> (m Event -> m a) -> m a +win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan + +-- stdin is not a terminal, but we still need to check the right way to output unicode to stdout. +fileRunTerm :: Handle -> IO RunTerm +fileRunTerm h_in = do + putter <- putOut + cp <- getCodePage + return RunTerm { + closeTerm = return (), + putStrOut = putter, + wrapInterrupt = withCtrlCHandler, + termOps = Right FileOps + { withoutInputEcho = hWithoutInputEcho h_in + , wrapFileInput = hWithBinaryMode h_in + , getLocaleChar = getMultiByteChar cp h_in + , maybeReadNewline = hMaybeReadNewline h_in + , getLocaleLine = hGetLocaleLine h_in + >>= liftIO . codePageToUnicode cp + } + + } + +-- On Windows, Unicode written to the console must be written with the WriteConsole API call. +-- And to make the API cross-platform consistent, Unicode to a file should be UTF-8. +putOut :: IO (String -> IO ()) +putOut = do + outIsTerm <- hIsTerminalDevice stdout + if outIsTerm + then do + h <- getStdHandle sTD_OUTPUT_HANDLE + return (writeConsole h) + else do + cp <- getCodePage + return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout + + +type Handler = DWORD -> IO BOOL + +foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler) + +foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler + :: FunPtr Handler -> BOOL -> IO BOOL + +-- sets the tv to True when ctrl-c is pressed. +withCtrlCHandler :: (MonadMask m, MonadIO m) => m a -> m a +withCtrlCHandler f = bracket (liftIO $ do + tid <- myThreadId + fp <- wrapHandler (handler tid) + -- don't fail if we can't set the ctrl-c handler + -- for example, we might not be attached to a console? + _ <- c_SetConsoleCtrlHandler fp True + return fp) + (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False) + (const f) + where + handler tid (#const CTRL_C_EVENT) = do + throwTo tid Interrupt + return True + handler _ _ = return False + + + +------------------------ +-- Multi-byte conversion + +foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte + :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt + -> LPCSTR -> LPBOOL -> IO CInt + +unicodeToCodePage :: CodePage -> String -> IO B.ByteString +unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do + -- first, ask for the length without filling the buffer. + outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) + nullPtr 0 nullPtr nullPtr + -- then, actually perform the encoding. + createAndTrim (fromEnum outSize) $ \outBuff -> + fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen) + (castPtr outBuff) outSize nullPtr nullPtr + +foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar + :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt + +codePageToUnicode :: CodePage -> B.ByteString -> IO String +codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do + -- first ask for the size without filling the buffer. + outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0 + -- then, actually perform the decoding. + allocaArray0 (fromEnum outSize) $ \outBuff -> do + outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize + peekCWStringLen (outBuff, fromEnum outSize') + + +getCodePage :: IO CodePage +getCodePage = do + conCP <- getConsoleCP + if conCP > 0 + then return conCP + else getACP + +foreign import WINDOWS_CCONV "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx + :: CodePage -> BYTE -> BOOL + +getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char +getMultiByteChar cp h = do + b1 <- hGetByte h + bs <- if c_IsDBCSLeadByteEx cp b1 + then hGetByte h >>= \b2 -> return [b1,b2] + else return [b1] + cs <- liftIO $ codePageToUnicode cp (B.pack bs) + case cs of + [] -> getMultiByteChar cp h + (c:_) -> return c + +---------------------------------- +-- Clearing screen +-- WriteConsole has a limit of ~20,000-30000 characters, which is +-- less than a 200x200 window, for example. +-- So we'll use other Win32 functions to clear the screen. + +getAttribute :: HANDLE -> IO WORD +getAttribute = withScreenBufferInfo $ + (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) + +fillConsoleChar :: HANDLE -> Char -> Int -> Coord -> IO () +fillConsoleChar h c n start = with start $ \startPtr -> alloca $ \numWritten -> do + failIfFalse_ "FillConsoleOutputCharacter" + $ c_FillConsoleCharacter h (toEnum $ fromEnum c) + (toEnum n) startPtr numWritten + +foreign import ccall "haskeline_FillConsoleCharacter" c_FillConsoleCharacter + :: HANDLE -> TCHAR -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL + +fillConsoleAttribute :: HANDLE -> WORD -> Int -> Coord -> IO () +fillConsoleAttribute h a n start = with start $ \startPtr -> alloca $ \numWritten -> do + failIfFalse_ "FillConsoleOutputAttribute" + $ c_FillConsoleAttribute h a + (toEnum n) startPtr numWritten + +foreign import ccall "haskeline_FillConsoleAttribute" c_FillConsoleAttribute + :: HANDLE -> WORD -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL + +clearScreen :: DrawM () +clearScreen = do + lay <- ask + h <- asks hOut + let windowSize = width lay * height lay + let origin = Coord 0 0 + attr <- liftIO $ getAttribute h + liftIO $ fillConsoleChar h ' ' windowSize origin + liftIO $ fillConsoleAttribute h attr windowSize origin + setPos origin diff --git a/System/Console/Haskeline/Backend/Win32/Echo.hs b/System/Console/Haskeline/Backend/Win32/Echo.hs new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/Backend/Win32/Echo.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE CPP #-} + +module System.Console.Haskeline.Backend.Win32.Echo (hWithoutInputEcho) where + +import Control.Exception (throw) +import Control.Monad (void) +import Control.Monad.Catch (MonadMask, bracket) +import Control.Monad.IO.Class (MonadIO(..)) + +import System.Exit (ExitCode(..)) +import System.IO (Handle, hGetContents, hGetEcho, hSetEcho) +import System.Process (StdStream(..), createProcess, shell, + std_in, std_out, waitForProcess) + +#if MIN_VERSION_Win32(2,5,0) +import Control.Concurrent.MVar (readMVar) + +import Data.Typeable (cast) + +import Foreign.C.Types +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) +import System.Win32.MinTTY (isMinTTYHandle) +#endif + +-- | Return the handle's current input 'EchoState'. +hGetInputEchoState :: Handle -> IO EchoState +hGetInputEchoState input = do + min_tty <- minTTY input + if min_tty + then fmap MinTTY (hGetInputEchoSTTY input) + else fmap DefaultTTY $ hGetEcho input + +-- | Return all of @stty@'s current settings in a non-human-readable format. +-- +-- This function is not very useful on its own. Its greater purpose is to +-- provide a compact 'STTYSettings' that can be fed back into +-- 'hSetInputEchoState'. +hGetInputEchoSTTY :: Handle -> IO STTYSettings +hGetInputEchoSTTY input = hSttyRaw input "-g" + +-- | Set the handle's input 'EchoState'. +hSetInputEchoState :: Handle -> EchoState -> IO () +hSetInputEchoState input (MinTTY settings) = hSetInputEchoSTTY input settings +hSetInputEchoState input (DefaultTTY echo) = hSetEcho input echo + +-- | Create an @stty@ process and wait for it to complete. This is useful for +-- changing @stty@'s settings, after which @stty@ does not output anything. +-- +-- @ +-- hSetInputEchoSTTY input = 'void' . 'hSttyRaw' input +-- @ +hSetInputEchoSTTY :: Handle -> STTYSettings -> IO () +hSetInputEchoSTTY input = void . hSttyRaw input + +-- | Save the handle's current input 'EchoState', perform a computation, +-- restore the saved 'EchoState', and then return the result of the +-- computation. +-- +-- @ +-- bracketInputEcho input action = +-- 'bracket' ('liftIO' $ 'hGetInputEchoState' input) +-- ('liftIO' . 'hSetInputEchoState' input) +-- (const action) +-- @ +hBracketInputEcho :: (MonadIO m, MonadMask m) => Handle -> m a -> m a +hBracketInputEcho input action = + bracket (liftIO $ hGetInputEchoState input) + (liftIO . hSetInputEchoState input) + (const action) + +-- | 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 :: (MonadIO m, MonadMask m) => Handle -> m a -> m a +hWithoutInputEcho input action = do + echo_off <- liftIO $ hEchoOff input + hBracketInputEcho input + (liftIO (hSetInputEchoState input echo_off) >> action) + +-- | Create an @stty@ process, wait for it to complete, and return its output. +hSttyRaw :: Handle -> String -> IO STTYSettings +hSttyRaw input arg = do + let stty = (shell $ "stty " ++ arg) { + std_in = UseHandle input + , std_out = CreatePipe + } + (_, mbStdout, _, rStty) <- createProcess stty + exStty <- waitForProcess rStty + case exStty of + e@ExitFailure{} -> throw e + ExitSuccess -> maybe (return "") hGetContents mbStdout + +-- | A representation of the handle input's current echoing state. +-- See, for instance, 'hEchoOff'. +data EchoState + = MinTTY STTYSettings + -- ^ The argument to (or value returned from) an invocation of the @stty@ + -- command-line utility. Most POSIX-like shells have @stty@, including + -- MinTTY on Windows. Since neither 'hGetEcho' nor 'hSetEcho' work on + -- MinTTY, when 'getInputEchoState' runs on MinTTY, it returns a value + -- built with this constructor. + -- + -- However, native Windows consoles like @cmd.exe@ or PowerShell do not + -- have @stty@, so if you construct an 'EchoState' with this constructor + -- manually, take care not to use it with a native Windows console. + | DefaultTTY Bool + -- ^ A simple on ('True') or off ('False') toggle. This is returned by + -- 'hGetEcho' and given as an argument to 'hSetEcho', which work on most + -- consoles, with the notable exception of MinTTY on Windows. If you + -- construct an 'EchoState' with this constructor manually, take care not + -- to use it with MinTTY. + deriving (Eq, Ord, Show) + +-- | Indicates that the handle's input echoing is (or should be) off. +hEchoOff :: Handle -> IO EchoState +hEchoOff input = do + min_tty <- minTTY input + return $ if min_tty + then MinTTY "-echo" + else DefaultTTY False + +-- | Settings used to configure the @stty@ command-line utility. +type STTYSettings = String + +-- | Is the current process attached to a MinTTY console (e.g., Cygwin or MSYS)? +minTTY :: Handle -> IO Bool +#if MIN_VERSION_Win32(2,5,0) +minTTY input = withHandleToHANDLE input isMinTTYHandle +#else +-- On older versions of Win32, we simply punt. +minTTY _ = return False +#endif + +#if MIN_VERSION_Win32(2,5,0) +foreign import ccall unsafe "_get_osfhandle" + c_get_osfhandle :: CInt -> IO HANDLE + +-- | Extract a Windows 'HANDLE' from a Haskell 'Handle' and perform +-- an action on it. + +-- Originally authored by Max Bolingbroke in the ansi-terminal library +withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a +#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 + DuplexHandle _ _ handle_mvar -> handle_mvar + -- This is "write" MVar, we could also take the "read" one + + -- Get the FD from the algebraic data type + Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) + $ readMVar write_handle_mvar + + -- 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 + +withStablePtr :: a -> (StablePtr a -> IO b) -> IO b +withStablePtr value = bracket (newStablePtr value) freeStablePtr +#endif 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,30 +20,32 @@ change, changeFromChar, (+>), + useKey, useChar, choiceCmd, keyChoiceCmd, keyChoiceCmdM, + doAfter, doBefore ) where import Data.Char(isPrint) -import Control.Monad(mplus, liftM) -import Control.Monad.Trans +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 @@ -54,15 +55,22 @@ 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 +instance Monad m => Functor (CmdM m) where + fmap = liftM + +instance Monad m => Applicative (CmdM m) where + pure = Result + (<*>) = ap + instance Monad m => Monad (CmdM m) where - return = Result + return = pure GetKey km >>= g = GetKey $ fmap (>>= g) km DoEffect e f >>= g = DoEffect e (f >>= g) @@ -85,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 @@ -104,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 @@ -153,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 @@ -21,10 +23,10 @@ where r | isFinished c = replacement c ++ " " | otherwise = replacement c -askIMCompletions :: CommandMonad m => +askIMCompletions :: CommandMonad m => Command m InsertMode (InsertMode, [Completion]) askIMCompletions (IMode xs ys) = do - (rest, completions) <- runCompletion (withRev graphemesToString xs, + (rest, completions) <- lift $ runCompletion (withRev graphemesToString xs, graphemesToString ys) return (IMode (withRev stringToGraphemes rest) ys, completions) where @@ -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 @@ -72,7 +74,7 @@ pagingCompletion k prefs completions = \im -> do ls <- asks $ makeLines (map display completions) let pageAction = do - askFirst prefs (length completions) $ + askFirst prefs (length completions) $ if completionPaging prefs then printPage ls else effect (PrintLines ls) @@ -85,7 +87,7 @@ -> CmdM m () askFirst prefs n cmd | maybe False (< n) (completionPromptLimit prefs) = do - _ <- setState (Message () $ "Display all " ++ show n + _ <- setState (Message $ "Display all " ++ show n ++ " possibilities? (y or n)") keyChoiceCmdM [ simpleChar 'y' +> cmd @@ -96,7 +98,7 @@ pageCompletions :: MonadReader Layout m => [String] -> CmdM m () pageCompletions [] = return () pageCompletions wws@(w:ws) = do - _ <- setState $ Message () "----More----" + _ <- setState $ Message "----More----" keyChoiceCmdM [ simpleChar '\n' +> oneLine , simpleKey DownKey +> oneLine @@ -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. @@ -159,5 +160,3 @@ ceilDiv :: Integral a => a -> a -> a ceilDiv m n | m `rem` n == 0 = m `div` n | otherwise = m `div` n + 1 - - 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,9 +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 @@ -15,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)] @@ -26,22 +28,24 @@ histLog hist = HistLog {pastHistory = map stringToGraphemes $ historyLines hist, futureHistory = []} -runHistoryFromFile :: MonadIO m => Maybe FilePath -> Maybe Int -> StateT History m a -> m a -runHistoryFromFile Nothing _ f = evalStateT' emptyHistory f +runHistoryFromFile :: (MonadIO m, MonadMask m) => Maybe FilePath -> Maybe Int + -> ReaderT (IORef History) m a -> m a +runHistoryFromFile Nothing _ f = do + historyRef <- liftIO $ newIORef emptyHistory + runReaderT f historyRef runHistoryFromFile (Just file) stifleAmt f = do oldHistory <- liftIO $ readHistory file - (x,newHistory) <- runStateT f (stifleHistory stifleAmt oldHistory) - liftIO $ writeHistory file newHistory + historyRef <- liftIO $ newIORef $ stifleHistory stifleAmt oldHistory + -- Run the action and then write the new history, even on an exception. + -- For example, if there's an unhandled ctrl-c, we don't want to lose + -- the user's previously-entered commands. + -- (Note that this requires using ReaderT (IORef History) instead of StateT. + x <- runReaderT f historyRef + `finally` (liftIO $ readIORef historyRef >>= writeHistory file) return x -runHistLog :: Monad m => StateT HistLog m a -> StateT History m a -runHistLog f = do - history <- get - lift (evalStateT' (histLog history) f) - - 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') @@ -69,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], @@ -80,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 @@ -101,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 @@ -5,6 +5,7 @@ import System.Console.Haskeline.Monads import System.Console.Haskeline.Command.Undo import Control.Monad +import Data.IORef -- standard trick for a purely functional queue: data Stack a = Stack [a] [a] @@ -28,62 +29,64 @@ type KillRing = Stack [Grapheme] -runKillRing :: Monad m => StateT KillRing m a -> m a -runKillRing = evalStateT' emptyStack +runKillRing :: MonadIO m => ReaderT (IORef KillRing) m a -> m a +runKillRing act = do + ringRef <- liftIO $ newIORef emptyStack + runReaderT act ringRef 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 @@ -3,9 +3,12 @@ Completion(..), noCompletion, simpleCompletion, + fallbackCompletion, -- * Word completion completeWord, + completeWord', completeWordWithPrev, + completeWordWithPrev', completeQuotedWord, -- * Filename completion completeFilename, @@ -15,7 +18,7 @@ import System.FilePath -import Data.List(isPrefixOf) +import Data.List(isPrefixOf, sort) import Control.Monad(forM) import System.Console.Haskeline.Directory @@ -39,7 +42,7 @@ -- ^ Whether this word should be followed by a -- space, end quote, etc. } - deriving Show + deriving (Eq, Ord, Show) -- | Disable completion altogether. noCompletion :: Monad m => CompletionFunc m @@ -51,13 +54,21 @@ -- | A custom 'CompletionFunc' which completes the word immediately to the left of the cursor. -- -- A word begins either at the start of the line or after an unescaped whitespace character. -completeWord :: Monad m => Maybe Char +completeWord :: Monad m => Maybe Char -- ^ An optional escape character -> [Char]-- ^ 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 +-- | 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. -- @@ -70,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) @@ -104,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 _ "" = "" @@ -119,14 +141,14 @@ completeQuotedWord :: Monad m => Maybe Char -- ^ An optional escape character -> [Char] -- ^ Characters which set off quotes -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions - -> CompletionFunc m -- ^ Alternate completion to perform if the + -> CompletionFunc m -- ^ Alternate completion to perform if the -- cursor is not at a quoted word -> CompletionFunc m completeQuotedWord esc qs completer alterative line@(left,_) = 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 @@ -136,7 +158,7 @@ splitAtQuote :: Maybe Char -> String -> String -> Maybe (String,String) splitAtQuote esc qs line = case line of - c:e:cs | isEscape e && isEscapable c + c:e:cs | isEscape e && isEscapable c -> do (w,rest) <- splitAtQuote esc qs cs return (c:w,rest) @@ -164,9 +186,9 @@ -- 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 + -- The replacement text should include the directory part, and also -- have a trailing slash if it's itself a directory. forM allFiles $ \c -> do isDir <- doesDirectoryExist (fixedDir replacement c) @@ -188,3 +210,12 @@ home <- getHomeDirectory return (home path) fixPath path = return path + +-- | If the first completer produces no suggestions, fallback to the second +-- completer's output. +fallbackCompletion :: Monad m => CompletionFunc m -> CompletionFunc m -> CompletionFunc m +fallbackCompletion a b input = do + aCompletions <- a input + if null (snd aCompletions) + then b input + else return aCompletions diff --git a/System/Console/Haskeline/Directory.hsc b/System/Console/Haskeline/Directory.hsc --- a/System/Console/Haskeline/Directory.hsc +++ b/System/Console/Haskeline/Directory.hsc @@ -14,20 +14,19 @@ import Foreign import Foreign.C import System.Win32.Types -#if __GLASGOW_HASKELL__ >= 611 import qualified System.Directory -#endif #include -#include +#include +##include "windows_cconv.h" -foreign import stdcall "FindFirstFileW" c_FindFirstFile +foreign import WINDOWS_CCONV "FindFirstFileW" c_FindFirstFile :: LPCTSTR -> Ptr () -> IO HANDLE -foreign import stdcall "FindNextFileW" c_FindNextFile +foreign import WINDOWS_CCONV "FindNextFileW" c_FindNextFile :: HANDLE -> Ptr () -> IO Bool -foreign import stdcall "FindClose" c_FindClose :: HANDLE -> IO BOOL +foreign import WINDOWS_CCONV "FindClose" c_FindClose :: HANDLE -> IO BOOL getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents fp = allocaBytes (#size WIN32_FIND_DATA) $ \findP -> @@ -45,7 +44,7 @@ else c_FindClose h >> return [f] peekFileName = peekCWString . (#ptr WIN32_FIND_DATA, cFileName) -foreign import stdcall "GetFileAttributesW" c_GetFileAttributes +foreign import WINDOWS_CCONV "GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO DWORD doesDirectoryExist :: FilePath -> IO Bool @@ -54,59 +53,11 @@ return $ attrs /= (#const INVALID_FILE_ATTRIBUTES) && (attrs .&. (#const FILE_ATTRIBUTE_DIRECTORY)) /= 0 -#if __GLASGOW_HASKELL__ >= 611 getHomeDirectory :: IO FilePath getHomeDirectory = System.Directory.getHomeDirectory -#else -type HRESULT = #type HRESULT -foreign import stdcall "SHGetFolderPathW" c_SHGetFolderPath - :: Ptr () -> CInt -> HANDLE -> DWORD -> LPTSTR -> IO HRESULT - -getHomeDirectory :: IO FilePath -getHomeDirectory = allocaBytes ((#const MAX_PATH) * (#size TCHAR)) $ \pathPtr -> do - result <- c_SHGetFolderPath nullPtr (#const CSIDL_PROFILE) nullPtr 0 pathPtr - - if result /= (#const S_OK) - then return "" - else peekCWString pathPtr -#endif - -#else --- POSIX --- On 7.2.1 and later, getDirectoryContents uses the locale encoding --- But previous version don't, so we need to decode manually. - -#if __GLASGOW_HASKELL__ >= 701 -import System.Directory #else -import Data.ByteString.Char8 (pack, unpack) -import qualified System.Directory as D -import Control.Exception.Extensible -import System.Console.Haskeline.Backend.IConv - -getDirectoryContents :: FilePath -> IO [FilePath] -getDirectoryContents path = do - codeset <- getCodeset - encoder <- openEncoder codeset - decoder <- openDecoder codeset - dirEnc <- fmap unpack (encoder path) - filesEnc <- handle (\(_::IOException) -> return []) - $ D.getDirectoryContents dirEnc - mapM (decoder . pack) filesEnc - -doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist file = do - codeset <- getCodeset - encoder <- openEncoder codeset - encoder file >>= D.doesDirectoryExist . unpack +import System.Directory -getHomeDirectory :: IO FilePath -getHomeDirectory = do - codeset <- getCodeset - decoder <- openDecoder codeset - handle (\(_::IOException) -> return "") - $ D.getHomeDirectory >>= decoder . pack -#endif #endif 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 . Monad m => Command (InputCmdT m) s t -type InputKeyCmd s t = forall m . Monad 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 ] @@ -89,7 +96,7 @@ wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode wordRight = goRightUntil (atStart (not . isAlphaNum)) wordLeft = goLeftUntil (atStart isAlphaNum) -bigWordLeft = goLeftUntil (atStart isSpace) +bigWordLeft = goLeftUntil (atStart (not . isSpace)) modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode modifyWord f im = IMode (reverse (f ys1) ++ xs) ys2 diff --git a/System/Console/Haskeline/Encoding.hs b/System/Console/Haskeline/Encoding.hs deleted file mode 100644 --- a/System/Console/Haskeline/Encoding.hs +++ /dev/null @@ -1,40 +0,0 @@ -{- | - -This module exposes the console Unicode API which is used by the functions -in "System.Console.Haskeline". On POSIX systems, it uses @iconv@ plus the -console\'s locale; on Windows it uses the console's current code page. - -Characters or bytes which cannot be encoded/decoded (for example, not belonging -to the output range) will be ignored. --} - -module System.Console.Haskeline.Encoding ( - encode, - decode, - getEncoder, - getDecoder - ) where - -import System.Console.Haskeline.InputT -import System.Console.Haskeline.Term -import System.Console.Haskeline.Monads -import Data.ByteString (ByteString) - --- | Encode a Unicode 'String' into a 'ByteString' suitable for the current --- console. -encode :: MonadIO m => String -> InputT m ByteString -encode str = do - encoder <- asks encodeForTerm - liftIO $ encoder str - --- | Convert a 'ByteString' from the console's encoding into a Unicode 'String'. -decode :: MonadIO m => ByteString -> InputT m String -decode str = do - decoder <- asks decodeForTerm - liftIO $ decoder str - -getEncoder :: Monad m => InputT m (String -> IO ByteString) -getEncoder = asks encodeForTerm - -getDecoder :: Monad m => InputT m (ByteString -> IO String) -getDecoder = asks decodeForTerm diff --git a/System/Console/Haskeline/History.hs b/System/Console/Haskeline/History.hs --- a/System/Console/Haskeline/History.hs +++ b/System/Console/Haskeline/History.hs @@ -28,12 +28,13 @@ import Data.Sequence ( Seq, (<|), ViewL(..), ViewR(..), viewl, viewr ) import Data.Foldable (toList) -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as UTF8 -import Control.Exception.Extensible +import Control.Exception import System.Directory(doesFileExist) +import qualified System.IO as IO +import System.Console.Haskeline.Recover + data History = History {histLines :: Seq String, stifleAmt :: Maybe Int} -- stored in reverse @@ -58,9 +59,7 @@ readHistory file = handle (\(_::IOException) -> return emptyHistory) $ do exists <- doesFileExist file contents <- if exists - -- use binary file I/O to avoid Windows CRLF line endings - -- which cause confusion when switching between systems. - then fmap UTF8.toString (B.readFile file) + then readUTF8File file else return "" _ <- evaluate (length contents) -- force file closed return History {histLines = Seq.fromList $ lines contents, @@ -70,7 +69,7 @@ -- error when writing the file, it will be ignored. writeHistory :: FilePath -> History -> IO () writeHistory file = handle (\(_::IOException) -> return ()) - . B.writeFile file . UTF8.fromString + . writeUTF8File file . unlines . historyLines -- | Limit the number of lines stored in the history. @@ -87,7 +86,7 @@ addHistory s h = h {histLines = maybeDropLast (stifleAmt h) (s <| (histLines h))} -- If the sequence is too big, drop the last entry. -maybeDropLast :: Ord a => Maybe Int -> Seq a -> Seq a +maybeDropLast :: Maybe Int -> Seq a -> Seq a maybeDropLast maxAmt hs | rightSize = hs | otherwise = case viewr hs of @@ -108,3 +107,25 @@ addHistoryRemovingAllDupes h hs = addHistory h hs {histLines = filteredHS} where filteredHS = Seq.fromList $ filter (/= h) $ toList $ histLines hs + +--------- +-- UTF-8 file I/O, for old versions of GHC + +readUTF8File :: FilePath -> IO String +readUTF8File file = do + h <- IO.openFile file IO.ReadMode + IO.hSetEncoding h $ transliterateFailure IO.utf8 + IO.hSetNewlineMode h IO.noNewlineTranslation + contents <- IO.hGetContents h + _ <- evaluate (length contents) + IO.hClose h + return contents + +writeUTF8File :: FilePath -> String -> IO () +writeUTF8File file contents = do + h <- IO.openFile file IO.WriteMode + IO.hSetEncoding h IO.utf8 + -- Write a file which is portable between systems. + IO.hSetNewlineMode h IO.noNewlineTranslation + IO.hPutStr h contents + IO.hClose h 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,7 +42,8 @@ import System.Console.Haskeline hiding (completeFilename) import Control.Concurrent -import Control.Monad.Trans +import Control.Exception (finally) +import Control.Monad.IO.Class -- Providing a non-monadic API for haskeline -- A process is forked off which runs the monadic InputT API 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,10 +11,13 @@ import System.Console.Haskeline.Backend import System.Console.Haskeline.Term -import System.Directory(getHomeDirectory) +import Control.Exception (IOException) +import Control.Monad.Catch +import Control.Monad.Fail as Fail +import Control.Monad.Fix +import Data.IORef +import System.Directory(getXdgDirectory, XdgDirectory(XdgConfig), doesFileExist, getHomeDirectory) import System.FilePath -import Control.Applicative -import qualified Control.Monad.State as State import System.IO -- | Application-specific customizations to the user interface. @@ -38,45 +41,83 @@ -- | A monad transformer which carries all of the state and settings -- relevant to a line-reading application. -newtype InputT m a = InputT {unInputT :: ReaderT RunTerm - (StateT History - (StateT KillRing (ReaderT Prefs +newtype InputT m a = InputT {unInputT :: + ReaderT RunTerm + -- Use ReaderT (IO _) vs StateT so that exceptions (e.g., ctrl-c) + -- don't cause us to lose the existing state. + (ReaderT (IORef History) + (ReaderT (IORef KillRing) + (ReaderT Prefs (ReaderT (Settings m) m)))) a} - deriving (Monad, MonadIO, MonadException, - MonadState History, MonadReader Prefs, - MonadReader (Settings m), MonadReader RunTerm) - -instance Monad m => Functor (InputT m) where - fmap = State.liftM - -instance Monad m => Applicative (InputT m) where - pure = return - (<*>) = State.ap + 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 + -- we implement the mtl versions of those classes. instance MonadTrans InputT where lift = InputT . lift . lift . lift . lift . lift -instance Monad m => State.MonadState History (InputT m) where - get = get - put = put +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 + +-- | Set the line input history. +putHistory :: MonadIO m => History -> InputT m () +putHistory = InputT . put + +-- | Change the current line input history. +modifyHistory :: MonadIO m => (History -> History) -> InputT m () +modifyHistory = InputT . modify + -- for internal use only -type InputCmdT m = StateT Layout (UndoT (StateT HistLog (StateT KillRing +type InputCmdT m = StateT Layout (UndoT (StateT HistLog (ReaderT (IORef KillRing) + -- HistLog can be just StateT, since its final state + -- isn't used outside of InputCmdT. (ReaderT Prefs (ReaderT (Settings m) m))))) runInputCmdT :: MonadIO m => TermOps -> InputCmdT m a -> InputT m a runInputCmdT tops f = InputT $ do layout <- liftIO $ getLayout tops - lift $ runHistLog $ runUndoT $ evalStateT' layout f + history <- get + lift $ lift $ evalStateT' (histLog history) $ runUndoT $ evalStateT' layout f -instance Monad 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. @@ -88,12 +129,12 @@ -- 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'.) haveTerminalUI :: Monad m => InputT m Bool -haveTerminalUI = asks isTerminalStyle +haveTerminalUI = InputT $ asks isTerminalStyle {- | Haskeline has two ways of interacting with the user: @@ -112,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. @@ -120,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 @@ -142,6 +183,11 @@ $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs) $ runReaderT f run +-- | Map a user interaction by modifying the base monad computation. +mapInputT :: (forall b . m b -> m b) -> InputT m a -> InputT m a +mapInputT f = InputT . mapReaderT (mapReaderT (mapReaderT + (mapReaderT (mapReaderT f)))) + . unInputT -- | Read input from 'stdin'. -- Use terminal-style interaction if 'stdin' is connected to @@ -170,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,24 +342,23 @@ 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) --------------- --- TODO: messageState param not needed anymore. -data Message s = Message {messageState :: s, messageText :: String} +newtype Message = Message {messageText :: String} -instance LineState (Message s) where +instance LineState Message where beforeCursor _ = stringToGraphemes . messageText afterCursor _ = [] @@ -407,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,84 +0,0 @@ -{- | This module redefines some of the functions in "Control.Exception.Extensible" to -work for more general monads than only 'IO'. --} - -module System.Console.Haskeline.MonadException( - MonadException(..), - handle, - finally, - throwIO, - throwTo, - bracket, - throwDynIO, - handleDyn, - Exception, - SomeException(..), - E.IOException()) - where - -import qualified Control.Exception.Extensible as E -import Control.Exception.Extensible(Exception,SomeException) -import Prelude hiding (catch) -import Control.Monad.Reader -import Control.Monad.State -import Control.Concurrent(ThreadId) - -class MonadIO m => MonadException m where - catch :: Exception e => m a -> (e -> m a) -> m a - block :: m a -> m a - unblock :: m a -> m a - -handle :: (MonadException m, Exception e) => (e -> m a) -> m a -> m a -handle = flip catch - -finally :: MonadException m => m a -> m b -> m a -finally f ender = block (do - r <- catch - (unblock f) - (\(e::SomeException) -> do {_ <- ender; throwIO e}) - _ <- ender - return r) - -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 - -bracket :: MonadException m => m a -> (a -> m b) -> (a -> m c) -> m c -bracket before after thing = - block (do - a <- before - r <- catch - (unblock (thing a)) - (\(e::SomeException) -> do { _ <- after a; throwIO e }) - _ <- after a - return r - ) - -throwDynIO :: (Exception exception, MonadIO m) => exception -> m a -throwDynIO = throwIO - -handleDyn :: (Exception exception, MonadException m) => (exception -> m a) - -> m a -> m a -handleDyn = handle - - -instance MonadException IO where - catch = E.catch - block = E.block - unblock = E.unblock - -instance MonadException m => MonadException (ReaderT r m) where - catch f h = ReaderT $ \r -> catch (runReaderT f r) - (\e -> runReaderT (h e) r) - block = mapReaderT block - unblock = mapReaderT unblock - --- Not needed anymore by our code (we have a custom StateT monad), --- but we should follow the PVP and not remove this in a point release. -instance MonadException m => MonadException (StateT s m) where - catch f h = StateT $ \s -> catch (runStateT f s) - (\e -> runStateT (h e) s) - block = mapStateT block - unblock = mapStateT unblock 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,27 +1,36 @@ module System.Console.Haskeline.Monads( - module Control.Monad.Trans, - module System.Console.Haskeline.MonadException, - ReaderT(..), + MonadTrans(..), + MonadIO(..), + ReaderT, + runReaderT, runReaderT', + mapReaderT, asks, StateT, runStateT, evalStateT', + mapStateT, gets, modify, update, MonadReader(..), MonadState(..), - MaybeT(..), + MaybeT(MaybeT), + runMaybeT, orElse ) where -import Control.Monad.Trans -import System.Console.Haskeline.MonadException -import Prelude hiding (catch) +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 Control.Monad.Trans.State.Strict hiding (get, put, gets, modify) +import qualified Control.Monad.Trans.State.Strict as State -import Control.Monad.Reader hiding (MonadReader,ask,asks,local) -import qualified Control.Monad.Reader as Reader +import Data.IORef class Monad m => MonadReader r m where ask :: m r @@ -32,7 +41,8 @@ instance Monad m => MonadReader s (StateT s m) where ask = get -instance (MonadReader r m, MonadTrans t, Monad (t m)) => MonadReader r (t m) where +instance {-# OVERLAPPABLE #-} (MonadReader r m, MonadTrans t, Monad (t m)) + => MonadReader r (t m) where ask = lift ask asks :: MonadReader r m => (r -> a) -> m a @@ -55,68 +65,26 @@ put s' return x -runReaderT' :: Monad m => r -> ReaderT r m a -> m a +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 => Monad (StateT s m) where - return x = StateT $ \s -> return $ \f -> f x s - 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 - -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') - 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 (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where +instance {-# OVERLAPPABLE #-} (MonadState s m, MonadTrans t, Monad (t m)) + => MonadState s (t m) where get = lift get put = lift . put -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 - block m = StateT $ \s -> block $ getStateTFunc m s - unblock m = StateT $ \s -> unblock $ getStateTFunc m s - catch f h = StateT $ \s -> catch (getStateTFunc f s) - $ \e -> getStateTFunc (h e) s - -newtype MaybeT m a = MaybeT { unMaybeT :: m (Maybe a) } - -instance Monad m => Monad (MaybeT m) where - return x = MaybeT $ return $ Just x - MaybeT f >>= g = MaybeT $ f >>= maybe (return Nothing) (unMaybeT . g) - -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = lift . liftIO - -instance MonadTrans MaybeT where - lift = MaybeT . liftM Just +-- ReaderT (IORef s) is better than StateT s for some applications, +-- since StateT loses its state after an exception such as ctrl-c. +instance MonadIO m => MonadState s (ReaderT (IORef s) m) where + get = ask >>= liftIO . readIORef + put s = ask >>= liftIO . flip writeIORef s -instance MonadException m => MonadException (MaybeT m) where - block = MaybeT . block . unMaybeT - unblock = MaybeT . unblock . unMaybeT - catch f h = MaybeT $ catch (unMaybeT f) $ unMaybeT . h +evalStateT' :: Monad m => s -> StateT s m a -> m a +evalStateT' = flip evalStateT orElse :: Monad m => MaybeT m a -> m a -> m a orElse (MaybeT f) g = f >>= maybe g return - -instance Monad m => MonadPlus (MaybeT m) where - mzero = MaybeT $ return Nothing - MaybeT f `mplus` MaybeT g = MaybeT $ f >>= maybe g (return . Just) 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/Recover.hs b/System/Console/Haskeline/Recover.hs new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/Recover.hs @@ -0,0 +1,22 @@ +module System.Console.Haskeline.Recover where + +import GHC.IO.Encoding +import GHC.IO.Encoding.Failure + +transliterateFailure :: TextEncoding -> TextEncoding +transliterateFailure + TextEncoding + { mkTextEncoder = mkEncoder + , mkTextDecoder = mkDecoder + , textEncodingName = name + } = TextEncoding + { mkTextDecoder = fmap (setRecover + $ recoverDecode TransliterateCodingFailure) + mkDecoder + , mkTextEncoder = fmap (setRecover + $ recoverEncode TransliterateCodingFailure) + mkEncoder + , textEncodingName = name + } + where + setRecover r x = x { recover = r } diff --git a/System/Console/Haskeline/RunCommand.hs b/System/Console/Haskeline/RunCommand.hs --- a/System/Console/Haskeline/RunCommand.hs +++ b/System/Console/Haskeline/RunCommand.hs @@ -7,36 +7,46 @@ import System.Console.Haskeline.Prefs import System.Console.Haskeline.Key +import Control.Exception (SomeException) import Control.Monad +import Control.Monad.Catch (handle, throwM) -runCommandLoop :: (MonadException m, CommandMonad m, MonadState Layout m, - LineState s) - => TermOps -> String -> KeyCommand m s a -> s -> m a -runCommandLoop tops prefix cmds initState = runTerm tops $ - RunTermType (withGetEvent tops - $ runCommandLoop' tops (stringToGraphemes prefix) initState cmds) +runCommandLoop :: (CommandMonad m, MonadState Layout m, LineState s) + => 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 prefix initState + cmds -runCommandLoop' :: forall t m s a . (MonadTrans t, Term (t m), CommandMonad (t m), - MonadState Layout m, MonadReader Prefs m, LineState s) - => TermOps -> Prefix -> s -> KeyCommand m s a -> t m Event -> t m a -runCommandLoop' tops prefix initState cmds getEvent = do +runCommandLoop' :: forall m n s a . (Term n, CommandMonad n, + MonadState Layout m, LineState s) + => (forall b . m b -> n b) -> TermOps -> Prefix -> s -> KeyCommand m s a -> n Event + -> n a +runCommandLoop' liftE tops prefix initState cmds getEvent = do let s = lineChars prefix initState drawLine s readMoreKeys s (fmap (liftM (\x -> (x,[])) . ($ initState)) cmds) where - readMoreKeys :: LineChars -> KeyMap (CmdM m (a,[Key])) -> t m a + 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 - WindowResize -> drawReposition tops s - >> readMoreKeys s next + ErrorEvent e -> moveToNextLine s >> throwM e + WindowResize -> do + drawReposition liftE tops s + readMoreKeys s next KeyInput ks -> do - bound_ks <- mapM (lift . asks . lookupKeyBinding) ks + bound_ks <- mapM (asks . lookupKeyBinding) ks loopCmd s $ applyKeysToMap (concat bound_ks) next + ExternalPrint str -> do + printPreservingLineChars s str + readMoreKeys s next - loopCmd :: LineChars -> CmdM m (a,[Key]) -> t m a + loopCmd :: LineChars -> CmdM m (a,[Key]) -> n a loopCmd s (GetKey next) = readMoreKeys s next -- If there are multiple consecutive LineChanges, only render the diff -- to the last one, and skip the rest. This greatly improves speed when @@ -46,15 +56,28 @@ loopCmd s (DoEffect e next) = do t <- drawEffect prefix s e loopCmd t next - loopCmd s (CmdM next) = lift next >>= loopCmd s + loopCmd s (CmdM next) = liftE next >>= loopCmd s loopCmd s (Result (x,ks)) = do liftIO (saveUnusedKeys tops ks) moveToNextLine s return x +printPreservingLineChars :: Term m => LineChars -> String -> m () +printPreservingLineChars s str = do + clearLine s + printLines . lines $ str + drawLine s -drawEffect :: (MonadTrans t, Term (t m), MonadReader Prefs m) - => Prefix -> LineChars -> Effect -> t m LineChars +drawReposition :: (Term n, MonadState Layout m) + => (forall a . m a -> n a) -> TermOps -> LineChars -> n () +drawReposition liftE tops s = do + oldLayout <- liftE get + newLayout <- liftIO (getLayout tops) + liftE (put newLayout) + when (oldLayout /= newLayout) $ reposition oldLayout s + +drawEffect :: (Term m, MonadReader Prefs m) + => Prefix -> LineChars -> Effect -> m LineChars drawEffect prefix s (LineChange ch) = do let t = ch prefix drawLineDiff s t @@ -70,23 +93,13 @@ return s drawEffect _ s RingBell = actBell >> return s -actBell :: (MonadTrans t, Term (t m), MonadReader Prefs m) => t m () +actBell :: (Term m, MonadReader Prefs m) => m () actBell = do - style <- lift $ asks bellStyle + style <- asks bellStyle case style of NoBell -> return () VisualBell -> ringBell False AudibleBell -> ringBell True - -drawReposition :: (MonadTrans t, Term (t m), MonadState Layout m) - => TermOps -> LineChars -> t m () -drawReposition tops s = do - -- explicit lifts prevent the need for IncoherentInstances. - oldLayout <- lift get - newLayout <- liftIO $ getLayout tops - when (oldLayout /= newLayout) $ do - lift $ put newLayout - reposition oldLayout s --------------- 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 @@ -7,16 +7,25 @@ import System.Console.Haskeline.Completion(Completion) import Control.Concurrent -import Data.Typeable -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B +import Control.Concurrent.STM +import Control.Exception (Exception, SomeException(..)) +import Control.Monad.Catch + ( MonadMask + , bracket + , handle + , throwM + , finally + ) import Data.Word -import Control.Exception.Extensible (fromException, AsyncException(..),bracket_) +import Control.Exception (fromException, AsyncException(..)) +import Data.Typeable import System.IO import Control.Monad(liftM,when,guard) import System.IO.Error (isEOFError) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC -class (MonadReader Layout m, MonadException m) => Term m where +class (MonadReader Layout m, MonadIO m, MonadMask m) => Term m where reposition :: Layout -> LineChars -> m () moveToNextLine :: LineChars -> m () printLines :: [String] -> m () @@ -28,29 +37,48 @@ drawLine = drawLineDiff ([],[]) clearLine = flip drawLineDiff ([],[]) - + data RunTerm = RunTerm { -- | Write unicode characters to stdout. putStrOut :: String -> IO (), - encodeForTerm :: String -> IO ByteString, - decodeForTerm :: ByteString -> IO String, termOps :: Either TermOps FileOps, - wrapInterrupt :: MonadException m => m a -> m a, + wrapInterrupt :: forall a m . (MonadIO m, MonadMask m) => m a -> m a, closeTerm :: IO () } -- | Operations needed for terminal-style interaction. -data TermOps = TermOps { - getLayout :: IO Layout - , withGetEvent :: (MonadException m, CommandMonad m) - => (m Event -> m a) -> m a - , runTerm :: (MonadException m, CommandMonad m) => RunTermType m a -> m a - , saveUnusedKeys :: [Key] -> IO () - } +data TermOps = TermOps + { getLayout :: IO Layout + , withGetEvent :: forall m a . CommandMonad m => (m Event -> m a) -> m a + , evalTerm :: forall m . CommandMonad m => EvalTerm m + , saveUnusedKeys :: [Key] -> IO () + , externalPrint :: String -> IO () + } +-- This hack is needed to grab latest writes from some other thread. +-- Without it, if you are using another thread to process the logging +-- and write on screen via exposed externalPrint, latest writes from +-- this thread are not able to cross the thread boundary in time. +flushEventQueue :: (String -> IO ()) -> TChan Event -> IO () +flushEventQueue print' eventChan = yield >> loopUntilFlushed + where loopUntilFlushed = do + flushed <- atomically $ isEmptyTChan eventChan + if flushed then return () else do + event <- atomically $ readTChan eventChan + case event of + ExternalPrint str -> do + print' (str ++ "\n") >> loopUntilFlushed + -- We don't want to raise exceptions when doing cleanup. + _ -> loopUntilFlushed + -- | Operations needed for file-style interaction. +-- +-- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline +-- are "wrapped" by wrapFileInput. data FileOps = FileOps { - inputHandle :: Handle, -- ^ e.g. for turning off echoing. + 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, getLocaleChar :: MaybeT IO Char, maybeReadNewline :: IO () @@ -62,17 +90,30 @@ Left TermOps{} -> True _ -> False +-- Specific, hidden terminal action type -- Generic terminal actions which are independent of the Term being used. --- Wrapped in a newtype so that we don't need RankNTypes. -newtype RunTermType m a = RunTermType (forall t . - (MonadTrans t, Term (t m), MonadException (t m), CommandMonad (t m)) - => t m a) +data EvalTerm m + = forall n . (Term n, CommandMonad n) + => EvalTerm (forall a . n a -> m a) (forall a . m a -> n a) -class (MonadReader Prefs m , MonadReader Layout m) +mapEvalTerm :: (forall a . n a -> m a) -> (forall a . m a -> n a) + -> EvalTerm n -> EvalTerm m +mapEvalTerm eval liftE (EvalTerm eval' liftE') + = EvalTerm (eval . eval') (liftE' . liftE) + +data Interrupt = Interrupt + deriving (Show,Typeable,Eq) + +instance Exception Interrupt where + + + +class (MonadReader Prefs m , MonadReader Layout m, MonadIO m, MonadMask m) => CommandMonad m where runCompletion :: (String,String) -> m (String,[Completion]) -instance (MonadTrans t, CommandMonad m, MonadReader Prefs (t m), +instance {-# OVERLAPPABLE #-} (MonadTrans t, CommandMonad m, MonadReader Prefs (t m), + MonadIO (t m), MonadMask (t m), MonadReader Layout (t m)) => CommandMonad (t m) where runCompletion = lift . runCompletion @@ -82,44 +123,36 @@ matchInit (x:xs) (y:ys) | x == y = matchInit xs ys matchInit xs ys = (xs,ys) -data Event = WindowResize | KeyInput [Key] | ErrorEvent SomeException - deriving Show +data Event + = WindowResize + | KeyInput [Key] + | ErrorEvent SomeException + | ExternalPrint String + deriving Show -keyEventLoop :: IO [Event] -> Chan Event -> IO Event +keyEventLoop :: IO [Event] -> TChan Event -> IO Event keyEventLoop readEvents eventChan = do -- first, see if any events are already queued up (from a key/ctrl-c -- event or from a previous call to getEvent where we read in multiple -- keys) - isEmpty <- isEmptyChan eventChan + isEmpty <- atomically $ isEmptyTChan eventChan if not isEmpty - then readChan eventChan + then atomically $ readTChan eventChan else do - lock <- newEmptyMVar - tid <- forkIO $ handleErrorEvent (readerLoop lock) - readChan eventChan `finally` do - putMVar lock () - killThread tid + tid <- forkIO $ handleErrorEvent readerLoop + atomically (readTChan eventChan) `finally` killThread tid where - readerLoop lock = do + readerLoop = do es <- readEvents if null es - then readerLoop lock - else -- Use the lock to work around the fact that writeList2Chan - -- isn't atomic. Otherwise, some events could be ignored if - -- the subthread is killed before it saves them in the chan. - bracket_ (putMVar lock ()) (takeMVar lock) $ - writeList2Chan eventChan es + then readerLoop + else atomically $ mapM_ (writeTChan eventChan) es handleErrorEvent = handle $ \e -> case fromException e of Just ThreadKilled -> return () - _ -> writeChan eventChan (ErrorEvent e) - -saveKeys :: Chan Event -> [Key] -> IO () -saveKeys ch = writeChan ch . KeyInput - -data Interrupt = Interrupt - deriving (Show,Typeable,Eq) + _ -> atomically $ writeTChan eventChan (ErrorEvent e) -instance Exception Interrupt where +saveKeys :: TChan Event -> [Key] -> IO () +saveKeys ch = atomically . writeTChan ch . KeyInput data Layout = Layout {width, height :: Int} deriving (Show,Eq) @@ -128,55 +161,39 @@ -- 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 -#if __GLASGOW_HASKELL__ >= 611 +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) >>) -#else -hWithBinaryMode _ = id -#endif -- | Utility function for changing a property of a terminal for the duration of -- a computation. -bracketSet :: (Eq a, 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) - -- | Returns one 8-bit word. Needs to be wrapped by hWithBinaryMode. hGetByte :: Handle -> MaybeT IO Word8 -hGetByte h = do - eof <- liftIO $ hIsEOF h - guard (not eof) - liftIO $ liftM (toEnum . fromEnum) $ hGetChar h - +hGetByte = guardedEOF $ liftM (toEnum . fromEnum) . hGetChar --- | Utility function to correctly get a ByteString line of input. -hGetLine :: Handle -> MaybeT IO ByteString -hGetLine h = do - atEOF <- liftIO $ hIsEOF h - guard (not atEOF) - -- It's more efficient to use B.getLine, but that function throws an - -- error if the Handle (e.g., stdin) is set to NoBuffering. - buff <- liftIO $ hGetBuffering h - liftIO $ if buff == NoBuffering - then hWithBinaryMode h $ fmap B.pack $ System.IO.hGetLine h - else B.hGetLine h +guardedEOF :: (Handle -> IO a) -> Handle -> MaybeT IO a +guardedEOF f h = do + eof <- lift $ hIsEOF h + guard (not eof) + lift $ f h -- If another character is immediately available, and it is a newline, consume it. -- -- Two portability fixes: --- +-- +-- 1) By itself, this (by using hReady) might crash on invalid characters. +-- The handle should be set to binary mode or a TextEncoder that +-- transliterates or ignores invalid input. +-- -- 1) Note that in ghc-6.8.3 and earlier, hReady returns False at an EOF, -- whereas in ghc-6.10.1 and later it throws an exception. (GHC trac #1063). -- This code handles both of those cases. --- --- 2) Also note that on Windows with ghc<6.10, hReady may not behave correctly (#1198) --- The net result is that this might cause --- But this function will generally only be used when reading buffered input --- (since stdin isn't a terminal), so it should probably be OK. hMaybeReadNewline :: Handle -> IO () hMaybeReadNewline h = returnOnEOF () $ do ready <- hReady h @@ -184,7 +201,17 @@ 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 +hGetLocaleLine = guardedEOF $ \h -> do + -- It's more efficient to use B.getLine, but that function throws an + -- error if the Handle (e.g., stdin) is set to NoBuffering. + buff <- liftIO $ hGetBuffering h + liftIO $ if buff == NoBuffering + then fmap BC.pack $ System.IO.hGetLine h + else BC.hGetLine h diff --git a/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 . Monad m => Command (ViT m) s t -type InputKeyCmd s t = forall m . Monad 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 :: Monad 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 :: Monad m => KillHelper -> Command (ViT m) (ArgMode CommandMode) InsertMode +killAndStoreI :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) InsertMode killAndStoreI = storedIAction . killFromArgHelper -killAndStoreIE :: Monad 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_iconv.c b/cbits/h_iconv.c deleted file mode 100644 --- a/cbits/h_iconv.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "h_iconv.h" - -// Wrapper functions, since iconv_open et al are macros in libiconv. -iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode) { - return iconv_open(tocode, fromcode); -} - -void haskeline_iconv_close(iconv_t cd) { - iconv_close(cd); -} - -size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, - char **outbuf, size_t *outbytesleft) { - // Cast inbuf to (void*) so that it works both on Solaris, which expects - // a (const char**), and on other platforms (e.g. Linux), which expect - // a (char **). - return iconv(cd, (void*)inbuf, inbytesleft, outbuf, outbytesleft); -} 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/cbits/win_console.c b/cbits/win_console.c --- a/cbits/win_console.c +++ b/cbits/win_console.c @@ -3,3 +3,11 @@ BOOL haskeline_SetPosition(HANDLE h, COORD* c) { return SetConsoleCursorPosition(h,*c); } + +BOOL haskeline_FillConsoleCharacter(HANDLE h, TCHAR c, DWORD l, COORD *p, LPDWORD n) { + return FillConsoleOutputCharacter(h,c,l,*p,n); +} + +BOOL haskeline_FillConsoleAttribute(HANDLE h, WORD a, DWORD l, COORD *p, LPDWORD n) { + return FillConsoleOutputAttribute(h,a,l,*p,n); +} diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -1,40 +1,138 @@ +{-# LANGUAGE CPP #-} module Main where import System.Console.Haskeline -import System.Environment +import Options.Applicative +import Data.Monoid ((<>)) +#ifndef MINGW +import System.IO (openFile, hClose, IOMode(..)) +#endif {-- Testing the line-input functions and their interaction with ctrl-c signals. Usage: -./Test (line input) -./Test chars (character input) -./Test password (no masking characters) -./Test password \* -./Test initial (use initial text in the prompt) + ./Test (line input, default Behavior) + ./Test chars (character input) + ./Test password (no masking) + ./Test password \* (masking with '*') + ./Test initial (initial text in the prompt) + + ./Test --mode useTermHandles (POSIX only) + ./Test --mode useTermHandlesWith --term-type vt100 + (POSIX only) + +The --mode flag selects the haskeline Behavior; positional INPUT_ARG +selects which prompt function to use, and works with any --mode. --} +data Mode + = UseTerm -- ^ defaultBehavior + | UseTermHandles -- ^ useTermHandles on /dev/tty + | UseTermHandlesWith String -- ^ useTermHandlesWith TERM on /dev/tty + +data InputMode + = LineInput + | CharInput + | PasswordInput (Maybe Char) + | InitialInput + +data Opts = Opts { optMode :: Mode, optInput :: InputMode } + mySettings :: Settings IO mySettings = defaultSettings {historyFile = Just "myhist"} main :: IO () main = do - args <- getArgs - let inputFunc = case args of - ["chars"] -> fmap (fmap (\c -> [c])) . getInputChar - ["password"] -> getPassword Nothing - ["password", [c]] -> getPassword (Just c) - ["initial"] -> flip getInputLineWithInitial ("left ", "right") - _ -> getInputLine - runInputT mySettings $ withInterrupt $ loop inputFunc 0 - where - loop inputFunc n = do - minput <- handleInterrupt (return (Just "Caught interrupted")) - $ inputFunc (show n ++ ":") - case minput of - Nothing -> return () - Just "quit" -> return () - Just "q" -> return () - Just s -> do - outputStrLn ("line " ++ show n ++ ":" ++ s) - loop inputFunc (n+1) + Opts {optMode = m, optInput = im} <- execParser optsInfo + case m of + UseTerm -> + runInputT mySettings (runAction im) +#ifndef MINGW + UseTermHandles -> + runWithHandles Nothing im + UseTermHandlesWith t -> + runWithHandles (Just t) im +#else + _ -> error "useTermHandles[With] is not available on Windows" +#endif + +runAction :: InputMode -> InputT IO () +runAction im = withInterrupt $ loop (inputFunc im) 0 + +inputFunc :: InputMode -> String -> InputT IO (Maybe String) +inputFunc LineInput = getInputLine +inputFunc CharInput = fmap (fmap (\c -> [c])) . getInputChar +inputFunc (PasswordInput mc) = getPassword mc +inputFunc InitialInput = flip getInputLineWithInitial ("left ", "right") + +loop :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO () +loop f n = do + minput <- handleInterrupt (return (Just "Caught interrupted")) + $ f (show n ++ ":") + case minput of + Nothing -> return () + Just "quit" -> return () + Just "q" -> return () + Just s -> do + outputStrLn ("line " ++ show n ++ ":" ++ s) + loop f (n+1) + +#ifndef MINGW +-- Drive Haskeline against /dev/tty (the controlling terminal) via the +-- useTermHandles[With] Behaviors. This still happens to be the controlling +-- tty in our test setup, but it goes through the new code path. +runWithHandles :: Maybe String -> InputMode -> IO () +runWithHandles mTerm im = do + input <- openFile "/dev/tty" ReadMode + output <- openFile "/dev/tty" WriteMode + let beh = case mTerm of + Nothing -> useTermHandles input output + Just t -> useTermHandlesWith t input output + runInputTBehavior beh mySettings (runAction im) + hClose input + hClose output +#endif + +---------------------------------------------------------------- +-- Command-line parsing + +optsInfo :: ParserInfo Opts +optsInfo = info (optsP <**> helper) + (fullDesc <> progDesc "Haskeline test program") + +optsP :: Parser Opts +optsP = Opts <$> modeP <*> inputModeP + +modeP :: Parser Mode +modeP = mkMode + <$> strOption + ( long "mode" + <> value "useTerm" + <> showDefault + <> metavar "MODE" + <> help "useTerm | useTermHandles | useTermHandlesWith" ) + <*> optional + (strOption + ( long "term-type" + <> metavar "TERM" + <> help "term type for --mode useTermHandlesWith" )) + where + mkMode "useTerm" _ = UseTerm + mkMode "useTermHandles" _ = UseTermHandles + mkMode "useTermHandlesWith" (Just t) = UseTermHandlesWith t + mkMode "useTermHandlesWith" Nothing = + error "--mode useTermHandlesWith requires --term-type" + mkMode other _ = + error ("unknown --mode: " ++ other) + +inputModeP :: Parser InputMode +inputModeP = mkInput <$> many (argument str (metavar "INPUT_ARG")) + where + mkInput [] = LineInput + mkInput ["chars"] = CharInput + mkInput ["password"] = PasswordInput Nothing + mkInput ["password", [c]] = PasswordInput (Just c) + mkInput ["initial"] = InitialInput + mkInput xs = + error ("unrecognized positional args: " ++ show xs) diff --git a/haskeline.cabal b/haskeline.cabal --- a/haskeline.cabal +++ b/haskeline.cabal @@ -1,29 +1,46 @@ Name: haskeline -Cabal-Version: >=1.6 -Version: 0.6.4.7 +Cabal-Version: >=1.10 +Version: 0.8.5.0 Category: User Interfaces License: BSD3 License-File: LICENSE Copyright: (c) Judah Jacobson Author: Judah Jacobson -Maintainer: Judah Jacobson -Category: User Interfaces +Maintainer: Troels Henriksen Synopsis: A command-line interface for user input, written in Haskell. -Description: +Description: Haskeline provides a user interface for line input in command-line programs. This library is similar in purpose to readline, but since it is written in Haskell it is (hopefully) more easily used in other Haskell programs. . Haskeline runs both on POSIX-compatible systems and on Windows. -Homepage: http://trac.haskell.org/haskeline -Stability: Experimental -Build-Type: Custom -extra-source-files: examples/Test.hs CHANGES +Homepage: https://github.com/haskell/haskeline +Bug-Reports: https://github.com/haskell/haskeline/issues +Stability: Stable +Build-Type: Simple -flag base2 - Description: Use the base packages from before version 6.8 +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: 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 -- when redrawing the input. Second, and more importantly, it enables us @@ -35,49 +52,47 @@ flag terminfo Description: Use the terminfo package for POSIX consoles. Default: True + Manual: True --- Note that the Setup script checks whether -liconv is necessary. This flag --- lets us override that decision. When it is True, we use -liconv. When it --- is False, we run tests to decide. -flag libiconv - Description: Explicitly link against the libiconv library. - Default: False +-- 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 - if flag(base2) { - Build-depends: base == 2.* - cpp-options: -DOLD_BASE - } - else { - if impl(ghc>=6.11) { - Build-depends: base >=4.1 && < 4.6, containers>=0.1 && < 0.6, directory>=1.0 && < 1.2, - bytestring>=0.9 && < 0.11 - } - else { - Build-depends: base>=3 && <4.1 , containers>=0.1 && < 0.3, directory==1.0.*, - bytestring==0.9.* - } - } - Build-depends: filepath >= 1.1 && < 1.4, mtl >= 1.1 && < 2.2, - utf8-string==0.3.* && >=0.3.6, - extensible-exceptions==0.1.* && >=0.1.1.0 - Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances, + 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, TypeSynonymInstances FlexibleContexts, ExistentialQuantification ScopedTypeVariables, GeneralizedNewtypeDeriving - MultiParamTypeClasses, OverlappingInstances + StandaloneDeriving + MultiParamTypeClasses, UndecidableInstances - PatternSignatures, CPP, DeriveDataTypeable, + ScopedTypeVariables, CPP, DeriveDataTypeable, PatternGuards Exposed-Modules: System.Console.Haskeline System.Console.Haskeline.Completion - System.Console.Haskeline.Encoding - 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 System.Console.Haskeline.Command System.Console.Haskeline.Command.Completion System.Console.Haskeline.Command.History @@ -89,37 +104,72 @@ System.Console.Haskeline.LineState System.Console.Haskeline.Monads System.Console.Haskeline.Prefs + System.Console.Haskeline.Recover System.Console.Haskeline.RunCommand System.Console.Haskeline.Term System.Console.Haskeline.Command.Undo System.Console.Haskeline.Vi include-dirs: includes - if os(windows) { - Build-depends: Win32>=2.0 + c-sources: cbits/h_wcwidth.c + + 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 + includes: win_console.h, windows_cconv.h install-includes: win_console.h cpp-options: -DMINGW - } else { - Build-depends: unix>=2.0 && < 2.6 - -- unix-2.3 doesn't build on ghc-6.8.1 or earlier - c-sources: cbits/h_iconv.c - cbits/h_wcwidth.c - includes: h_iconv.h - install-includes: h_iconv.h - Other-modules: - System.Console.Haskeline.Backend.WCWidth + else + Build-depends: unix>=2.0 && < 2.9 + Other-modules: System.Console.Haskeline.Backend.Posix - System.Console.Haskeline.Backend.IConv + System.Console.Haskeline.Backend.Posix.Encoder System.Console.Haskeline.Backend.DumbTerm if flag(terminfo) { - Build-depends: terminfo>=0.3.1.3 && <0.4 + Build-depends: terminfo>=0.3.1.3 && <0.5 Other-modules: System.Console.Haskeline.Backend.Terminfo cpp-options: -DTERMINFO } 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/win_console.h b/includes/win_console.h --- a/includes/win_console.h +++ b/includes/win_console.h @@ -3,5 +3,7 @@ #include BOOL haskeline_SetPosition(HANDLE h, COORD* c); +BOOL haskeline_FillConsoleCharacter(HANDLE h, TCHAR c, DWORD l, COORD *p, LPDWORD n); +BOOL haskeline_FillConsoleAttribute(HANDLE h, WORD c, DWORD l, COORD *p, LPDWORD n); #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'