haskeline 0.6.4.7 → 0.8.5.0
raw patch · 47 files changed
Files
- CHANGES +0/−103
- Changelog +294/−0
- LICENSE +14/−11
- Setup.hs +1/−115
- System/Console/Haskeline.hs +144/−66
- System/Console/Haskeline/Backend.hs +17/−5
- System/Console/Haskeline/Backend/DumbTerm.hs +14/−22
- System/Console/Haskeline/Backend/IConv.hsc +0/−156
- System/Console/Haskeline/Backend/Posix.hsc +229/−150
- System/Console/Haskeline/Backend/Posix/Encoder.hs +69/−0
- System/Console/Haskeline/Backend/Terminfo.hs +39/−37
- System/Console/Haskeline/Backend/WCWidth.hs +2/−2
- System/Console/Haskeline/Backend/Win32.hsc +579/−456
- System/Console/Haskeline/Backend/Win32/Echo.hs +193/−0
- System/Console/Haskeline/Command.hs +29/−22
- System/Console/Haskeline/Command/Completion.hs +21/−22
- System/Console/Haskeline/Command/History.hs +25/−17
- System/Console/Haskeline/Command/KillRing.hs +17/−14
- System/Console/Haskeline/Command/Undo.hs +2/−3
- System/Console/Haskeline/Completion.hs +47/−16
- System/Console/Haskeline/Directory.hsc +7/−56
- System/Console/Haskeline/Emacs.hs +11/−4
- System/Console/Haskeline/Encoding.hs +0/−40
- System/Console/Haskeline/History.hs +29/−8
- System/Console/Haskeline/IO.hs +2/−1
- System/Console/Haskeline/InputT.hs +148/−35
- System/Console/Haskeline/Internal.hs +47/−0
- System/Console/Haskeline/Key.hs +48/−8
- System/Console/Haskeline/LineState.hs +17/−19
- System/Console/Haskeline/MonadException.hs +0/−84
- System/Console/Haskeline/Monads.hs +32/−64
- System/Console/Haskeline/Prefs.hs +16/−3
- System/Console/Haskeline/ReaderT.hs +133/−0
- System/Console/Haskeline/Recover.hs +22/−0
- System/Console/Haskeline/RunCommand.hs +46/−33
- System/Console/Haskeline/Term.hs +106/−79
- System/Console/Haskeline/Vi.hs +203/−147
- cbits/h_iconv.c +0/−18
- cbits/h_wcwidth.c +2/−2
- cbits/win_console.c +8/−0
- examples/Test.hs +123/−25
- haskeline.cabal +104/−54
- includes/h_iconv.h +0/−9
- includes/win_console.h +2/−0
- tests/Pty.hs +98/−0
- tests/RunTTY.hs +116/−0
- tests/Unit.hs +374/−0
− CHANGES
@@ -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)
+ Changelog view
@@ -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)
LICENSE view
@@ -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.
Setup.hs view
@@ -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 <iconv.h>"- , "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
System/Console/Haskeline.hs view
@@ -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-<http://trac.haskell.org/haskeline/wiki/UserPrefs> for more information.+<https://github.com/judah/haskeline/wiki/UserPreferences> 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 <https://github.com/haskell/haskeline/wiki/ControlSequencesInPrompt> 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
System/Console/Haskeline/Backend.hs view
@@ -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
System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -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
− System/Console/Haskeline/Backend/IConv.hsc
@@ -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 <locale.h>-#include <langinfo.h>-#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)-
System/Console/Haskeline/Backend/Posix.hsc view
@@ -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 <termios.h> #endif #include <sys/ioctl.h> +#include <HsBaseConfig.h>+ ----------------------------------------------- -- 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
+ System/Console/Haskeline/Backend/Posix/Encoder.hs view
@@ -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+++
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -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
System/Console/Haskeline/Backend/WCWidth.hs view
@@ -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
System/Console/Haskeline/Backend/Win32.hsc view
@@ -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
+ System/Console/Haskeline/Backend/Win32/Echo.hs view
@@ -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
System/Console/Haskeline/Command.hs view
@@ -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 >|>)
System/Console/Haskeline/Command/Completion.hs view
@@ -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--
System/Console/Haskeline/Command/History.hs view
@@ -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)
System/Console/Haskeline/Command/KillRing.hs view
@@ -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)
System/Console/Haskeline/Command/Undo.hs view
@@ -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-
System/Console/Haskeline/Completion.hs view
@@ -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
System/Console/Haskeline/Directory.hsc view
@@ -14,20 +14,19 @@ import Foreign import Foreign.C import System.Win32.Types-#if __GLASGOW_HASKELL__ >= 611 import qualified System.Directory-#endif #include <windows.h>-#include <Shlobj.h>+#include <shlobj.h>+##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
System/Console/Haskeline/Emacs.hs view
@@ -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
− System/Console/Haskeline/Encoding.hs
@@ -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
System/Console/Haskeline/History.hs view
@@ -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
System/Console/Haskeline/IO.hs view
@@ -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
System/Console/Haskeline/InputT.hs view
@@ -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+-- <https://xtermjs.org/ Xterm.js> 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"))
+ System/Console/Haskeline/Internal.hs view
@@ -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: <https://github.com/judah/haskeline/wiki/CustomKeyBindings>+--+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 "> "
System/Console/Haskeline/Key.hs view
@@ -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
System/Console/Haskeline/LineState.hs view
@@ -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)
− System/Console/Haskeline/MonadException.hs
@@ -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
System/Console/Haskeline/Monads.hs view
@@ -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)
System/Console/Haskeline/Prefs.hs view
@@ -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) ]
+ System/Console/Haskeline/ReaderT.hs view
@@ -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
+ System/Console/Haskeline/Recover.hs view
@@ -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 }
System/Console/Haskeline/RunCommand.hs view
@@ -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 ---------------
System/Console/Haskeline/Term.hs view
@@ -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
System/Console/Haskeline/Vi.hs view
@@ -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)
− cbits/h_iconv.c
@@ -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);-}
cbits/h_wcwidth.c view
@@ -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" */
cbits/win_console.c view
@@ -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);+}
examples/Test.hs view
@@ -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)
haskeline.cabal view
@@ -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 <judah.jacobson@gmail.com>-Category: User Interfaces+Maintainer: Troels Henriksen <athas@sigkill.dk> 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
− includes/h_iconv.h
@@ -1,9 +0,0 @@-#include <iconv.h>--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);-
includes/win_console.h view
@@ -3,5 +3,7 @@ #include <windows.h> 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
+ tests/Pty.hs view
@@ -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+
+ tests/RunTTY.hs view
@@ -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
+ tests/Unit.hs view
@@ -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'