haskeline-0.7.0.3/0000755000000000000000000000000012022257742012013 5ustar0000000000000000haskeline-0.7.0.3/CHANGES0000644000000000000000000001067112022257741013012 0ustar0000000000000000Changed 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) haskeline-0.7.0.3/haskeline.cabal0000644000000000000000000001312712022257742014746 0ustar0000000000000000Name: haskeline Cabal-Version: >=1.6 Version: 0.7.0.3 Category: User Interfaces License: BSD3 License-File: LICENSE Copyright: (c) Judah Jacobson Author: Judah Jacobson Maintainer: Judah Jacobson Category: User Interfaces Synopsis: A command-line interface for user input, written in Haskell. 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 source-repository head type: darcs location: http://code.haskell.org/haskeline -- 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 -- to draw on multiple lines, so we can wrap long input strings. And third, -- the backend adds some extra key sequences such as forwards delete. -- -- (The "dumb" terminal also allows editing of long input strings, but is -- restricted to only one line and thus only shows part of the input at once.) flag terminfo Description: Use the terminfo package for POSIX consoles. Default: 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 flag legacy-encoding Description: Use the legacy iconv encoding for POSIX, even on ghc>=7.4.1. (Intended for testing only.) Default: False Library if impl(ghc>=6.11) { Build-depends: base >=4.1 && < 4.7, containers>=0.1 && < 0.6, directory>=1.0 && < 1.3, 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, transformers >= 0.2 && < 0.4 Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances, TypeSynonymInstances FlexibleContexts, ExistentialQuantification ScopedTypeVariables, GeneralizedNewtypeDeriving MultiParamTypeClasses, OverlappingInstances UndecidableInstances ScopedTypeVariables, CPP, DeriveDataTypeable, PatternGuards Exposed-Modules: System.Console.Haskeline System.Console.Haskeline.Completion System.Console.Haskeline.MonadException System.Console.Haskeline.History System.Console.Haskeline.IO 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 System.Console.Haskeline.Command.KillRing System.Console.Haskeline.Directory System.Console.Haskeline.Emacs System.Console.Haskeline.InputT System.Console.Haskeline.Key System.Console.Haskeline.LineState System.Console.Haskeline.Monads System.Console.Haskeline.Prefs System.Console.Haskeline.RunCommand System.Console.Haskeline.Term System.Console.Haskeline.Command.Undo System.Console.Haskeline.Vi include-dirs: includes c-sources: cbits/h_wcwidth.c -- We require ghc>=7.4.1 to use the base library encodings, -- even though it was implemented in earlier releases, -- due to GHC bug #5436 which wasn't fixed until 7.4.1 if !flag(legacy-encoding) && impl(ghc>=7.4) { cpp-options: -DUSE_GHC_ENCODINGS Other-modules: System.Console.Haskeline.Recover } else { Build-depends: utf8-string==0.3.* && >=0.3.6 } if os(windows) { Build-depends: Win32>=2.0 Other-modules: System.Console.Haskeline.Backend.Win32 c-sources: cbits/win_console.c includes: win_console.h install-includes: win_console.h cpp-options: -DMINGW } else { Build-depends: unix>=2.0 && < 2.7 -- unix-2.3 doesn't build on ghc-6.8.1 or earlier -- Use manual encoding/decoding on ghc<7.4 if flag (legacy-encoding) || impl(ghc<7.4) { c-sources: cbits/h_iconv.c includes: h_iconv.h install-includes: h_iconv.h Other-modules: System.Console.Haskeline.Backend.Posix.IConv } Other-modules: System.Console.Haskeline.Backend.Posix System.Console.Haskeline.Backend.Posix.Encoder System.Console.Haskeline.Backend.DumbTerm if flag(terminfo) { Build-depends: terminfo>=0.3.1.3 && <0.4 Other-modules: System.Console.Haskeline.Backend.Terminfo cpp-options: -DTERMINFO } if os(solaris) { cpp-options: -DUSE_TERMIOS_H } } ghc-options: -Wall haskeline-0.7.0.3/LICENSE0000644000000000000000000000237212022257741013023 0ustar0000000000000000Copyright 2007-2009, Judah Jacobson. All Rights Reserved. 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. - Redistribution 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 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE 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 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. haskeline-0.7.0.3/Setup.hs0000644000000000000000000001075512022257742013457 0ustar0000000000000000{-# LANGUAGE CPP #-} 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 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'}}} } warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo"))) $ mapM_ putStrLn [ "*** Warning: running on POSIX but not building the terminfo backend. ***" , "You may need to install the terminfo package manually, e.g. with" , "\"cabal install terminfo\"; or, use \"-fterminfo\" when configuring or" , "installing this package." ,"" ] hasFlagSet :: ConfigFlags -> FlagName -> Bool hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags) -- Test whether compiling a c program that links against libiconv needs -liconv. -- (Not needed for ghc>=7.4.1, even for the legacy POSIX backend, since -- the base library always links against iconv .) maybeSetLibiconv :: ConfigFlags -> BuildInfo -> LocalBuildInfo -> IO BuildInfo #if __GLASGOW_HASKELL__ >= 704 maybeSetLibiconv _ bi _ = return bi #else maybeSetLibiconv flags bi lbi = do let biWithIconv = addIconv bi let verb = fromFlag (configVerbosity flags) 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." tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool tryCompile program bi lbi verb = handle processExit $ handle processException $ do tempDir <- getTemporaryDirectory withTempFile tempDir ".c" $ \fname cH -> withTempFile tempDir "" $ \execName oH -> do hPutStr cH program hClose cH hClose oH -- TODO take verbosity from the args. rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi) (fname : "-o" : execName : args) return True where processException :: IOException -> IO Bool processException e = return False processExit = return . (==ExitSuccess) -- Mimicing Distribution.Simple.Configure deps = topologicalOrder (installedPkgs lbi) args = concat [ ccOptions bi , cppOptions bi , ldOptions bi -- --extra-include-dirs and --extra-lib-dirs are included -- in the below fields. -- Also sometimes a dependency like rts points to a nonstandard -- include/lib directory where iconv can be found. , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps) , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps) , map ("-l" ++) (extraLibs bi) ] addIconv :: BuildInfo -> BuildInfo addIconv bi = bi {extraLibs = "iconv" : extraLibs bi} iconv_prog :: String iconv_prog = unlines $ [ "#include " , "int main(void) {" , " iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");" , " return 0;" , "}" ] #endif haskeline-0.7.0.3/cbits/0000755000000000000000000000000012022257741013116 5ustar0000000000000000haskeline-0.7.0.3/cbits/h_iconv.c0000644000000000000000000000120312022257741014703 0ustar0000000000000000#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); } haskeline-0.7.0.3/cbits/h_wcwidth.c0000644000000000000000000003333312022257741015247 0ustar0000000000000000/* * This is an implementation of wcwidth() and wcswidth() (defined in * IEEE Std 1002.1-2001) for Unicode. * * http://www.opengroup.org/onlinepubs/007904975/functions/wcwidth.html * http://www.opengroup.org/onlinepubs/007904975/functions/wcswidth.html * * In fixed-width output devices, Latin characters all occupy a single * "cell" position of equal width, whereas ideographic CJK characters * occupy two such cells. Interoperability between terminal-line * applications and (teletype-style) character terminals using the * UTF-8 encoding requires agreement on which character should advance * the cursor by how many cell positions. No established formal * standards exist at present on which Unicode character shall occupy * how many cell positions on character terminals. These routines are * a first attempt of defining such behavior based on simple rules * applied to data provided by the Unicode Consortium. * * For some graphical characters, the Unicode standard explicitly * defines a character-cell width via the definition of the East Asian * FullWidth (F), Wide (W), Half-width (H), and Narrow (Na) classes. * In all these cases, there is no ambiguity about which width a * terminal shall use. For characters in the East Asian Ambiguous (A) * class, the width choice depends purely on a preference of backward * compatibility with either historic CJK or Western practice. * Choosing single-width for these characters is easy to justify as * the appropriate long-term solution, as the CJK practice of * displaying these characters as double-width comes from historic * implementation simplicity (8-bit encoded characters were displayed * single-width and 16-bit ones double-width, even for Greek, * Cyrillic, etc.) and not any typographic considerations. * * Much less clear is the choice of width for the Not East Asian * (Neutral) class. Existing practice does not dictate a width for any * of these characters. It would nevertheless make sense * typographically to allocate two character cells to characters such * as for instance EM SPACE or VOLUME INTEGRAL, which cannot be * represented adequately with a single-width glyph. The following * routines at present merely assign a single-cell width to all * neutral characters, in the interest of simplicity. This is not * entirely satisfactory and should be reconsidered before * establishing a formal standard in this area. At the moment, the * decision which Not East Asian (Neutral) characters should be * represented by double-width glyphs cannot yet be answered by * applying a simple rule from the Unicode database content. Setting * up a proper standard for the behavior of UTF-8 character terminals * will require a careful analysis not only of each Unicode character, * but also of each presentation form, something the author of these * routines has avoided to do so far. * * http://www.unicode.org/unicode/reports/tr11/ * * Markus Kuhn -- 2007-05-26 (Unicode 5.0) * * Permission to use, copy, modify, and distribute this software * for any purpose and without fee is hereby granted. The author * disclaims all warranties with regard to this software. * * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c */ #include struct interval { int first; int last; }; /* auxiliary function for binary search in interval table */ static int haskeline_bisearch(wchar_t ucs, const struct interval *table, int max) { int min = 0; int mid; if (ucs < table[0].first || ucs > table[max].last) return 0; while (max >= min) { mid = (min + max) / 2; if (ucs > table[mid].last) min = mid + 1; else if (ucs < table[mid].first) max = mid - 1; else return 1; } return 0; } /* The following two functions define the column width of an ISO 10646 * character as follows: * * - The null character (U+0000) has a column width of 0. * * - Other C0/C1 control characters and DEL will lead to a return * value of -1. * * - Non-spacing and enclosing combining characters (general * category code Mn or Me in the Unicode database) have a * column width of 0. * * - SOFT HYPHEN (U+00AD) has a column width of 1. * * - Other format characters (general category code Cf in the Unicode * database) and ZERO WIDTH SPACE (U+200B) have a column width of 0. * * - Hangul Jamo medial vowels and final consonants (U+1160-U+11FF) * have a column width of 0. * * - Spacing characters in the East Asian Wide (W) or East Asian * Full-width (F) category as defined in Unicode Technical * Report #11 have a column width of 2. * * - All remaining characters (including all printable * ISO 8859-1 and WGL4 characters, Unicode control characters, * etc.) have a column width of 1. * * This implementation assumes that wchar_t characters are encoded * in ISO 10646. */ int haskeline_mk_wcwidth(wchar_t 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" */ static const struct interval combining[] = { { 0x0300, 0x036F }, { 0x0483, 0x0486 }, { 0x0488, 0x0489 }, { 0x0591, 0x05BD }, { 0x05BF, 0x05BF }, { 0x05C1, 0x05C2 }, { 0x05C4, 0x05C5 }, { 0x05C7, 0x05C7 }, { 0x0600, 0x0603 }, { 0x0610, 0x0615 }, { 0x064B, 0x065E }, { 0x0670, 0x0670 }, { 0x06D6, 0x06E4 }, { 0x06E7, 0x06E8 }, { 0x06EA, 0x06ED }, { 0x070F, 0x070F }, { 0x0711, 0x0711 }, { 0x0730, 0x074A }, { 0x07A6, 0x07B0 }, { 0x07EB, 0x07F3 }, { 0x0901, 0x0902 }, { 0x093C, 0x093C }, { 0x0941, 0x0948 }, { 0x094D, 0x094D }, { 0x0951, 0x0954 }, { 0x0962, 0x0963 }, { 0x0981, 0x0981 }, { 0x09BC, 0x09BC }, { 0x09C1, 0x09C4 }, { 0x09CD, 0x09CD }, { 0x09E2, 0x09E3 }, { 0x0A01, 0x0A02 }, { 0x0A3C, 0x0A3C }, { 0x0A41, 0x0A42 }, { 0x0A47, 0x0A48 }, { 0x0A4B, 0x0A4D }, { 0x0A70, 0x0A71 }, { 0x0A81, 0x0A82 }, { 0x0ABC, 0x0ABC }, { 0x0AC1, 0x0AC5 }, { 0x0AC7, 0x0AC8 }, { 0x0ACD, 0x0ACD }, { 0x0AE2, 0x0AE3 }, { 0x0B01, 0x0B01 }, { 0x0B3C, 0x0B3C }, { 0x0B3F, 0x0B3F }, { 0x0B41, 0x0B43 }, { 0x0B4D, 0x0B4D }, { 0x0B56, 0x0B56 }, { 0x0B82, 0x0B82 }, { 0x0BC0, 0x0BC0 }, { 0x0BCD, 0x0BCD }, { 0x0C3E, 0x0C40 }, { 0x0C46, 0x0C48 }, { 0x0C4A, 0x0C4D }, { 0x0C55, 0x0C56 }, { 0x0CBC, 0x0CBC }, { 0x0CBF, 0x0CBF }, { 0x0CC6, 0x0CC6 }, { 0x0CCC, 0x0CCD }, { 0x0CE2, 0x0CE3 }, { 0x0D41, 0x0D43 }, { 0x0D4D, 0x0D4D }, { 0x0DCA, 0x0DCA }, { 0x0DD2, 0x0DD4 }, { 0x0DD6, 0x0DD6 }, { 0x0E31, 0x0E31 }, { 0x0E34, 0x0E3A }, { 0x0E47, 0x0E4E }, { 0x0EB1, 0x0EB1 }, { 0x0EB4, 0x0EB9 }, { 0x0EBB, 0x0EBC }, { 0x0EC8, 0x0ECD }, { 0x0F18, 0x0F19 }, { 0x0F35, 0x0F35 }, { 0x0F37, 0x0F37 }, { 0x0F39, 0x0F39 }, { 0x0F71, 0x0F7E }, { 0x0F80, 0x0F84 }, { 0x0F86, 0x0F87 }, { 0x0F90, 0x0F97 }, { 0x0F99, 0x0FBC }, { 0x0FC6, 0x0FC6 }, { 0x102D, 0x1030 }, { 0x1032, 0x1032 }, { 0x1036, 0x1037 }, { 0x1039, 0x1039 }, { 0x1058, 0x1059 }, { 0x1160, 0x11FF }, { 0x135F, 0x135F }, { 0x1712, 0x1714 }, { 0x1732, 0x1734 }, { 0x1752, 0x1753 }, { 0x1772, 0x1773 }, { 0x17B4, 0x17B5 }, { 0x17B7, 0x17BD }, { 0x17C6, 0x17C6 }, { 0x17C9, 0x17D3 }, { 0x17DD, 0x17DD }, { 0x180B, 0x180D }, { 0x18A9, 0x18A9 }, { 0x1920, 0x1922 }, { 0x1927, 0x1928 }, { 0x1932, 0x1932 }, { 0x1939, 0x193B }, { 0x1A17, 0x1A18 }, { 0x1B00, 0x1B03 }, { 0x1B34, 0x1B34 }, { 0x1B36, 0x1B3A }, { 0x1B3C, 0x1B3C }, { 0x1B42, 0x1B42 }, { 0x1B6B, 0x1B73 }, { 0x1DC0, 0x1DCA }, { 0x1DFE, 0x1DFF }, { 0x200B, 0x200F }, { 0x202A, 0x202E }, { 0x2060, 0x2063 }, { 0x206A, 0x206F }, { 0x20D0, 0x20EF }, { 0x302A, 0x302F }, { 0x3099, 0x309A }, { 0xA806, 0xA806 }, { 0xA80B, 0xA80B }, { 0xA825, 0xA826 }, { 0xFB1E, 0xFB1E }, { 0xFE00, 0xFE0F }, { 0xFE20, 0xFE23 }, { 0xFEFF, 0xFEFF }, { 0xFFF9, 0xFFFB }, { 0x10A01, 0x10A03 }, { 0x10A05, 0x10A06 }, { 0x10A0C, 0x10A0F }, { 0x10A38, 0x10A3A }, { 0x10A3F, 0x10A3F }, { 0x1D167, 0x1D169 }, { 0x1D173, 0x1D182 }, { 0x1D185, 0x1D18B }, { 0x1D1AA, 0x1D1AD }, { 0x1D242, 0x1D244 }, { 0xE0001, 0xE0001 }, { 0xE0020, 0xE007F }, { 0xE0100, 0xE01EF } }; /* test for 8-bit control characters */ if (ucs == 0) return 0; if (ucs < 32 || (ucs >= 0x7f && ucs < 0xa0)) return -1; /* binary search in table of non-spacing characters */ if (haskeline_bisearch(ucs, combining, sizeof(combining) / sizeof(struct interval) - 1)) return 0; /* if we arrive here, ucs is not a combining or C0/C1 control character */ return 1 + (ucs >= 0x1100 && (ucs <= 0x115f || /* Hangul Jamo init. consonants */ ucs == 0x2329 || ucs == 0x232a || (ucs >= 0x2e80 && ucs <= 0xa4cf && ucs != 0x303f) || /* CJK ... Yi */ (ucs >= 0xac00 && ucs <= 0xd7a3) || /* Hangul Syllables */ (ucs >= 0xf900 && ucs <= 0xfaff) || /* CJK Compatibility Ideographs */ (ucs >= 0xfe10 && ucs <= 0xfe19) || /* Vertical forms */ (ucs >= 0xfe30 && ucs <= 0xfe6f) || /* CJK Compatibility Forms */ (ucs >= 0xff00 && ucs <= 0xff60) || /* Fullwidth Forms */ (ucs >= 0xffe0 && ucs <= 0xffe6) || (ucs >= 0x20000 && ucs <= 0x2fffd) || (ucs >= 0x30000 && ucs <= 0x3fffd))); } int haskeline_mk_wcswidth(const wchar_t *pwcs, size_t n) { int w, width = 0; for (;*pwcs && n-- > 0; pwcs++) if ((w = haskeline_mk_wcwidth(*pwcs)) < 0) return -1; else width += w; return width; } /* * The following functions are the same as mk_wcwidth() and * mk_wcswidth(), except that spacing characters in the East Asian * Ambiguous (A) category as defined in Unicode Technical Report #11 * have a column width of 2. This variant might be useful for users of * CJK legacy encodings who want to migrate to UCS without changing * the traditional terminal character-width behaviour. It is not * otherwise recommended for general use. */ int haskeline_mk_wcwidth_cjk(wchar_t ucs) { /* sorted list of non-overlapping intervals of East Asian Ambiguous * characters, generated by "uniset +WIDTH-A -cat=Me -cat=Mn -cat=Cf c" */ static const struct interval ambiguous[] = { { 0x00A1, 0x00A1 }, { 0x00A4, 0x00A4 }, { 0x00A7, 0x00A8 }, { 0x00AA, 0x00AA }, { 0x00AE, 0x00AE }, { 0x00B0, 0x00B4 }, { 0x00B6, 0x00BA }, { 0x00BC, 0x00BF }, { 0x00C6, 0x00C6 }, { 0x00D0, 0x00D0 }, { 0x00D7, 0x00D8 }, { 0x00DE, 0x00E1 }, { 0x00E6, 0x00E6 }, { 0x00E8, 0x00EA }, { 0x00EC, 0x00ED }, { 0x00F0, 0x00F0 }, { 0x00F2, 0x00F3 }, { 0x00F7, 0x00FA }, { 0x00FC, 0x00FC }, { 0x00FE, 0x00FE }, { 0x0101, 0x0101 }, { 0x0111, 0x0111 }, { 0x0113, 0x0113 }, { 0x011B, 0x011B }, { 0x0126, 0x0127 }, { 0x012B, 0x012B }, { 0x0131, 0x0133 }, { 0x0138, 0x0138 }, { 0x013F, 0x0142 }, { 0x0144, 0x0144 }, { 0x0148, 0x014B }, { 0x014D, 0x014D }, { 0x0152, 0x0153 }, { 0x0166, 0x0167 }, { 0x016B, 0x016B }, { 0x01CE, 0x01CE }, { 0x01D0, 0x01D0 }, { 0x01D2, 0x01D2 }, { 0x01D4, 0x01D4 }, { 0x01D6, 0x01D6 }, { 0x01D8, 0x01D8 }, { 0x01DA, 0x01DA }, { 0x01DC, 0x01DC }, { 0x0251, 0x0251 }, { 0x0261, 0x0261 }, { 0x02C4, 0x02C4 }, { 0x02C7, 0x02C7 }, { 0x02C9, 0x02CB }, { 0x02CD, 0x02CD }, { 0x02D0, 0x02D0 }, { 0x02D8, 0x02DB }, { 0x02DD, 0x02DD }, { 0x02DF, 0x02DF }, { 0x0391, 0x03A1 }, { 0x03A3, 0x03A9 }, { 0x03B1, 0x03C1 }, { 0x03C3, 0x03C9 }, { 0x0401, 0x0401 }, { 0x0410, 0x044F }, { 0x0451, 0x0451 }, { 0x2010, 0x2010 }, { 0x2013, 0x2016 }, { 0x2018, 0x2019 }, { 0x201C, 0x201D }, { 0x2020, 0x2022 }, { 0x2024, 0x2027 }, { 0x2030, 0x2030 }, { 0x2032, 0x2033 }, { 0x2035, 0x2035 }, { 0x203B, 0x203B }, { 0x203E, 0x203E }, { 0x2074, 0x2074 }, { 0x207F, 0x207F }, { 0x2081, 0x2084 }, { 0x20AC, 0x20AC }, { 0x2103, 0x2103 }, { 0x2105, 0x2105 }, { 0x2109, 0x2109 }, { 0x2113, 0x2113 }, { 0x2116, 0x2116 }, { 0x2121, 0x2122 }, { 0x2126, 0x2126 }, { 0x212B, 0x212B }, { 0x2153, 0x2154 }, { 0x215B, 0x215E }, { 0x2160, 0x216B }, { 0x2170, 0x2179 }, { 0x2190, 0x2199 }, { 0x21B8, 0x21B9 }, { 0x21D2, 0x21D2 }, { 0x21D4, 0x21D4 }, { 0x21E7, 0x21E7 }, { 0x2200, 0x2200 }, { 0x2202, 0x2203 }, { 0x2207, 0x2208 }, { 0x220B, 0x220B }, { 0x220F, 0x220F }, { 0x2211, 0x2211 }, { 0x2215, 0x2215 }, { 0x221A, 0x221A }, { 0x221D, 0x2220 }, { 0x2223, 0x2223 }, { 0x2225, 0x2225 }, { 0x2227, 0x222C }, { 0x222E, 0x222E }, { 0x2234, 0x2237 }, { 0x223C, 0x223D }, { 0x2248, 0x2248 }, { 0x224C, 0x224C }, { 0x2252, 0x2252 }, { 0x2260, 0x2261 }, { 0x2264, 0x2267 }, { 0x226A, 0x226B }, { 0x226E, 0x226F }, { 0x2282, 0x2283 }, { 0x2286, 0x2287 }, { 0x2295, 0x2295 }, { 0x2299, 0x2299 }, { 0x22A5, 0x22A5 }, { 0x22BF, 0x22BF }, { 0x2312, 0x2312 }, { 0x2460, 0x24E9 }, { 0x24EB, 0x254B }, { 0x2550, 0x2573 }, { 0x2580, 0x258F }, { 0x2592, 0x2595 }, { 0x25A0, 0x25A1 }, { 0x25A3, 0x25A9 }, { 0x25B2, 0x25B3 }, { 0x25B6, 0x25B7 }, { 0x25BC, 0x25BD }, { 0x25C0, 0x25C1 }, { 0x25C6, 0x25C8 }, { 0x25CB, 0x25CB }, { 0x25CE, 0x25D1 }, { 0x25E2, 0x25E5 }, { 0x25EF, 0x25EF }, { 0x2605, 0x2606 }, { 0x2609, 0x2609 }, { 0x260E, 0x260F }, { 0x2614, 0x2615 }, { 0x261C, 0x261C }, { 0x261E, 0x261E }, { 0x2640, 0x2640 }, { 0x2642, 0x2642 }, { 0x2660, 0x2661 }, { 0x2663, 0x2665 }, { 0x2667, 0x266A }, { 0x266C, 0x266D }, { 0x266F, 0x266F }, { 0x273D, 0x273D }, { 0x2776, 0x277F }, { 0xE000, 0xF8FF }, { 0xFFFD, 0xFFFD }, { 0xF0000, 0xFFFFD }, { 0x100000, 0x10FFFD } }; /* binary search in table of non-spacing characters */ if (haskeline_bisearch(ucs, ambiguous, sizeof(ambiguous) / sizeof(struct interval) - 1)) return 2; return haskeline_mk_wcwidth(ucs); } int haskeline_mk_wcswidth_cjk(const wchar_t *pwcs, size_t n) { int w, width = 0; for (;*pwcs && n-- > 0; pwcs++) if ((w = haskeline_mk_wcwidth_cjk(*pwcs)) < 0) return -1; else width += w; return width; } haskeline-0.7.0.3/cbits/win_console.c0000644000000000000000000000062112022257741015600 0ustar0000000000000000#include "win_console.h" 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); } haskeline-0.7.0.3/examples/0000755000000000000000000000000012022257741013630 5ustar0000000000000000haskeline-0.7.0.3/examples/Test.hs0000644000000000000000000000254412022257741015110 0ustar0000000000000000module Main where import System.Console.Haskeline import System.Environment import Control.Exception (AsyncException(..)) {-- 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) --} mySettings :: Settings IO mySettings = defaultSettings {historyFile = Just "myhist"} main :: IO () main = do args <- getArgs let inputFunc = case args of ["chars"] -> fmap (fmap (\c -> [c])) . getInputChar ["password"] -> getPassword Nothing ["password", [c]] -> getPassword (Just c) ["initial"] -> flip getInputLineWithInitial ("left ", "right") _ -> getInputLine runInputT mySettings $ withInterrupt $ loop inputFunc 0 where loop inputFunc n = do minput <- handle (\Interrupt -> return (Just "Caught interrupted")) $ inputFunc (show n ++ ":") case minput of Nothing -> return () Just "quit" -> return () Just "q" -> return () Just s -> do outputStrLn ("line " ++ show n ++ ":" ++ s) loop inputFunc (n+1) haskeline-0.7.0.3/includes/0000755000000000000000000000000012022257742013621 5ustar0000000000000000haskeline-0.7.0.3/includes/h_iconv.h0000644000000000000000000000040312022257742015414 0ustar0000000000000000#include iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode); void haskeline_iconv_close(iconv_t cd); size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, char **outbuf, size_t *outbytesleft); haskeline-0.7.0.3/includes/win_console.h0000644000000000000000000000044712022257742016316 0ustar0000000000000000#ifndef _WIN_CONSOLE_H #define _WIN_CONSOLE_H #include BOOL haskeline_SetPosition(HANDLE h, COORD* c); BOOL haskeline_FillConsoleCharacter(HANDLE h, TCHAR c, DWORD l, COORD *p, LPDWORD n); BOOL haskeline_FillConsoleAttribute(HANDLE h, WORD c, DWORD l, COORD *p, LPDWORD n); #endif haskeline-0.7.0.3/System/0000755000000000000000000000000012022257741013276 5ustar0000000000000000haskeline-0.7.0.3/System/Console/0000755000000000000000000000000012022257741014700 5ustar0000000000000000haskeline-0.7.0.3/System/Console/Haskeline.hs0000644000000000000000000003044112022257741017141 0ustar0000000000000000{- | 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. Users may customize the interface with a @~/.haskeline@ file; see 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 > loop :: InputT IO () > loop = do > minput <- getInputLine "% " > case minput of > Nothing -> return () > Just "quit" -> return () > Just input -> do outputStrLn $ "Input was: " ++ input > loop -} module System.Console.Haskeline( -- * Interactive sessions -- ** The InputT monad transformer InputT, runInputT, haveTerminalUI, mapInputT, -- ** Behaviors Behavior, runInputTBehavior, defaultBehavior, useFileHandle, useFile, preferTerm, -- * User interaction functions -- ** Reading user input -- $inputfncs getInputLine, getInputLineWithInitial, getInputChar, getPassword, -- ** Outputting text -- $outputfncs outputStr, outputStrLn, -- * Customization -- ** Settings Settings(..), defaultSettings, setComplete, -- ** User preferences Prefs(), readPrefs, defaultPrefs, runInputTWithPrefs, runInputTBehaviorWithPrefs, -- ** History -- $history getHistory, putHistory, modifyHistory, -- * Ctrl-C handling withInterrupt, Interrupt(..), handleInterrupt, -- * Additional submodules module System.Console.Haskeline.Completion, module System.Console.Haskeline.MonadException) where import System.Console.Haskeline.LineState import System.Console.Haskeline.Command import System.Console.Haskeline.Vi import System.Console.Haskeline.Emacs 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 Data.Char (isSpace, isPrint) -- | A useful default. In particular: -- -- @ -- defaultSettings = Settings { -- complete = completeFilename, -- historyFile = Nothing, -- autoAddHistory = True -- } -- @ defaultSettings :: MonadIO m => Settings m defaultSettings = Settings {complete = completeFilename, historyFile = Nothing, autoAddHistory = True} {- $outputfncs The following functions enable cross-platform output of text that may contain Unicode characters. -} -- | Write a Unicode string to the user's standard output. outputStr :: MonadIO m => String -> InputT m () outputStr xs = do putter <- InputT $ asks putStrOut liftIO $ putter xs -- | Write a string to the user's standard output, followed by a newline. outputStrLn :: MonadIO m => String -> InputT m () outputStrLn = outputStr . (++ "\n") {- $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. When using file-style interaction, these functions return 'Nothing' if an @EOF@ was encountered before any characters were read. -} {- | Reads one line of input. The final newline (if any) is removed. When using terminal-style interaction, this function provides a rich line-editing user interface. If @'autoAddHistory' == 'True'@ and the line input is nonblank (i.e., is not all spaces), it will be automatically added to the history. -} getInputLine :: MonadException m => String -- ^ The input prompt -> InputT m (Maybe String) 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 added ability to give the user default values. This function behaves in the exact same manner as 'getInputLine', except that it pre-populates the input area. The text that resides in the input area is given as a 2-tuple with two 'String's. The string on the left of the tuple (obtained by calling 'fst') is what will appear to the left of the cursor and the string on the right (obtained by calling 'snd') is what will appear to the right of the cursor. Some examples of calling of this function are: > 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 => 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) (runMaybeT . getLocaleLine) prompt where initialIM = insertString left $ moveToStart $ insertString right $ emptyIM getInputCmdLine :: MonadException m => InsertMode -> TermOps -> String -> InputT m (Maybe String) getInputCmdLine initialIM tops prefix = do emode <- InputT $ asks editMode result <- runInputCmdT tops $ case emode of Emacs -> runCommandLoop tops prefix emacsCommands initialIM Vi -> evalStateT' emptyViState $ runCommandLoop tops prefix viKeyCommands initialIM maybeAddHistory result return result maybeAddHistory :: forall m . MonadIO m => Maybe String -> InputT m () maybeAddHistory result = do settings :: Settings m <- InputT ask histDupes <- InputT $ asks historyDuplicates case result of Just line | autoAddHistory settings && not (all isSpace line) -> let adder = case histDupes of AlwaysAdd -> addHistory IgnoreConsecutive -> addHistoryUnlessConsecutiveDupe IgnoreAll -> addHistoryRemovingAllDupes in modifyHistory (adder line) _ -> return () ---------- {- | Reads one character of input. Ignores non-printable characters. When using terminal-style interaction, the character will be read without waiting for a newline. 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 -> InputT m (Maybe Char) getInputChar = promptedInput getInputCmdChar $ \fops -> do c <- getPrintableChar fops maybeReadNewline fops return c getPrintableChar :: FileOps -> IO (Maybe Char) getPrintableChar fops = do 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 $ 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 >|> keyCommand acceptOneChar , ctrlChar 'd' +> failCmd] ---------- -- Passwords {- | Reads one line of input, without displaying the input while it is being typed. When using terminal-style interaction, the masking character (if given) will replace each typed character. When using file-style interaction, this function turns off echoing while reading the line of input. -} getPassword :: MonadException 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 $ runMaybeT $ getLocaleLine fops) where loop = choiceCmd [ simpleChar '\n' +> finish , simpleKey Backspace +> change deletePasswordChar >|> loop' , useChar $ \c -> change (addPasswordChar c) >|> loop' , ctrlChar 'd' +> \p -> if null (passwordState p) then failCmd p else finish p , 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. -- This is the function that calls "wrapFileInput" around file backend input -- functions (see Term.hs). promptedInput :: MonadIO m => (TermOps -> String -> InputT m a) -> (FileOps -> IO a) -> String -> InputT m a 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 <- InputT ask case termOps rterm of Right fops -> liftIO $ do putStrOut rterm prompt wrapFileInput fops $ doFile fops Left tops -> do -- If the prompt contains newlines, print all but the last line. let (lastLine,rest) = break (`elem` "\r\n") $ reverse prompt outputStr $ reverse rest doTerm tops $ reverse lastLine {- | If Ctrl-C is pressed during the given action, throw an exception of type 'Interrupt'. For example: > tryAction :: InputT IO () > tryAction = handle (\Interrupt -> outputStrLn "Cancelled.") > $ wrapInterrupt $ someLongAction The action can handle the interrupt itself; a new 'Interrupt' exception will be thrown every time Ctrl-C is pressed. > tryAction :: InputT IO () > tryAction = wrapInterrupt loop > where loop = handle (\Interrupt -> outputStrLn "Cancelled; try again." >> loop) > someLongAction 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 :: MonadException m => InputT m a -> InputT m a withInterrupt act = do rterm <- InputT ask liftIOOp_ (wrapInterrupt rterm) act -- | Catch and handle an exception of type 'Interrupt'. -- -- > handleInterrupt f = handle $ \Interrupt -> f handleInterrupt :: MonadException m => m a -> m a -> m a handleInterrupt f = handle $ \Interrupt -> f haskeline-0.7.0.3/System/Console/Haskeline/0000755000000000000000000000000012022257741016603 5ustar0000000000000000haskeline-0.7.0.3/System/Console/Haskeline/Backend.hs0000644000000000000000000000235312022257741020471 0ustar0000000000000000module System.Console.Haskeline.Backend where import System.Console.Haskeline.Term import System.Console.Haskeline.Monads import Control.Monad import System.IO (stdin, hGetEcho, Handle) #ifdef MINGW import System.Console.Haskeline.Backend.Win32 as Win32 #else import System.Console.Haskeline.Backend.Posix as Posix #ifdef TERMINFO import System.Console.Haskeline.Backend.Terminfo as Terminfo #endif import System.Console.Haskeline.Backend.DumbTerm as DumbTerm #endif defaultRunTerm :: IO RunTerm defaultRunTerm = (liftIO (hGetEcho stdin) >>= guard >> stdinTTY) `orElse` fileHandleRunTerm stdin terminalRunTerm :: IO RunTerm terminalRunTerm = directTTY `orElse` fileHandleRunTerm stdin stdinTTY :: MaybeT IO RunTerm #ifdef MINGW stdinTTY = win32TermStdin #else stdinTTY = stdinTTYHandles >>= runDraw #endif directTTY :: MaybeT IO RunTerm #ifdef MINGW directTTY = win32Term #else directTTY = ttyHandles >>= runDraw #endif #ifndef MINGW runDraw :: Handles -> MaybeT IO RunTerm #ifndef TERMINFO runDraw = runDumbTerm #else runDraw h = runTerminfoDraw h `mplus` runDumbTerm h #endif #endif fileHandleRunTerm :: Handle -> IO RunTerm #ifdef MINGW fileHandleRunTerm = Win32.fileRunTerm #else fileHandleRunTerm = Posix.fileRunTerm #endif haskeline-0.7.0.3/System/Console/Haskeline/Command.hs0000644000000000000000000001142012022257741020513 0ustar0000000000000000module System.Console.Haskeline.Command( -- * Commands Effect(..), KeyMap(..), CmdM(..), Command, KeyCommand, KeyConsumed(..), withoutConsuming, keyCommand, (>|>), (>+>), try, effect, clearScreenCmd, finish, failCmd, simpleCommand, charCommand, setState, change, changeFromChar, (+>), useChar, choiceCmd, keyChoiceCmd, keyChoiceCmdM, doBefore ) where import Data.Char(isPrint) import Control.Monad(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 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 instance Functor KeyMap where fmap f km = KeyMap $ fmap (fmap f) . lookupKM km instance Functor KeyConsumed where fmap f (NotConsumed x) = NotConsumed (f x) 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 type Command m s t = s -> CmdM m t instance Monad m => Monad (CmdM m) where return = Result GetKey km >>= g = GetKey $ fmap (>>= g) km DoEffect e f >>= g = DoEffect e (f >>= g) CmdM f >>= g = CmdM $ liftM (>>= g) f Result x >>= g = g x type KeyCommand m s t = KeyMap (Command m s t) instance MonadTrans CmdM where lift m = CmdM $ do x <- m return $ Result x keyCommand :: KeyCommand m s t -> Command m s t keyCommand km = \s -> GetKey $ fmap ($ s) km useKey :: Key -> a -> KeyMap a useKey k x = KeyMap $ \k' -> if k==k' then Just (Consumed x) else Nothing -- 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 -> Just $ Consumed (act c) _ -> Nothing withoutConsuming :: Command m s t -> KeyCommand m s t withoutConsuming = KeyMap . const . Just . NotConsumed choiceCmd :: [KeyMap a] -> KeyMap a choiceCmd = foldl orKM nullKM where nullKM = KeyMap $ const Nothing orKM (KeyMap f) (KeyMap g) = KeyMap $ \k -> f k `mplus` g k keyChoiceCmd :: [KeyCommand m s t] -> Command m s t keyChoiceCmd = keyCommand . choiceCmd 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 infixr 6 >+> (>+>) :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u km >+> g = fmap (>|> g) km -- 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 +> (+>) :: Key -> a -> KeyMap a (+>) = useKey finish :: (Monad m, Result s) => Command m s (Maybe String) finish = return . Just . toResult failCmd :: Monad m => Command m s (Maybe a) failCmd _ = return Nothing effect :: Effect -> CmdM m () effect e = DoEffect e $ Result () clearScreenCmd :: Command m s s clearScreenCmd = DoEffect ClearScreen . Result simpleCommand :: (LineState s, Monad m) => (s -> m (Either Effect s)) -> Command m s s simpleCommand f = \s -> do et <- lift (f s) case et of Left e -> effect e >> return s Right t -> setState t charCommand :: (LineState s, Monad m) => (Char -> s -> m (Either Effect s)) -> KeyCommand m s s charCommand f = useChar $ simpleCommand . f setState :: (Monad m, LineState s) => Command m s s setState s = effect (lineChange s) >> return s change :: (LineState t, Monad m) => (s -> t) -> Command m s t change = (setState .) 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 >|>) haskeline-0.7.0.3/System/Console/Haskeline/Completion.hs0000644000000000000000000001737112022257741021261 0ustar0000000000000000module System.Console.Haskeline.Completion( CompletionFunc, Completion(..), noCompletion, simpleCompletion, -- * Word completion completeWord, completeWordWithPrev, completeQuotedWord, -- * Filename completion completeFilename, listFiles, filenameWordBreakChars ) where import System.FilePath import Data.List(isPrefixOf) import Control.Monad(forM) import System.Console.Haskeline.Directory import System.Console.Haskeline.Monads -- | Performs completions from the given line state. -- -- The first 'String' argument is the contents of the line to the left of the cursor, -- reversed. -- The second 'String' argument is the contents of the line to the right of the cursor. -- -- The output 'String' is the unused portion of the left half of the line, reversed. type CompletionFunc m = (String,String) -> m (String, [Completion]) data Completion = Completion {replacement :: String, -- ^ Text to insert in line. display :: String, -- ^ Text to display when listing -- alternatives. isFinished :: Bool -- ^ Whether this word should be followed by a -- space, end quote, etc. } deriving Show -- | Disable completion altogether. noCompletion :: Monad m => CompletionFunc m noCompletion (s,_) = return (s,[]) -------------- -- Word break functions -- | 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 -- ^ 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 -- | 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. -- -- A word begins either at the start of the line or after an unescaped whitespace character. completeWordWithPrev :: Monad m => Maybe Char -- ^ An optional escape character -> [Char]-- ^ 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 ws f (line, _) = do let (word,rest) = case esc of Nothing -> break (`elem` ws) line Just e -> escapedBreak e line completions <- f rest (reverse word) return (rest,map (escapeReplacement esc ws) completions) where escapedBreak e (c:d:cs) | d == e && c `elem` (e:ws) = let (xs,ys) = escapedBreak e cs in (c:xs,ys) escapedBreak e (c:cs) | notElem c ws = let (xs,ys) = escapedBreak e cs in (c:xs,ys) escapedBreak _ cs = ("",cs) -- | Create a finished completion out of the given word. simpleCompletion :: String -> Completion simpleCompletion = completion -- NOTE: this is the same as for readline, except that I took out the '\\' -- so they can be used as a path separator. filenameWordBreakChars :: String filenameWordBreakChars = " \t\n`@$><=;|&{(" -- A completion command for file and folder names. completeFilename :: MonadIO m => CompletionFunc m completeFilename = completeQuotedWord (Just '\\') "\"'" listFiles $ completeWord (Just '\\') ("\"\'" ++ filenameWordBreakChars) listFiles completion :: String -> Completion completion str = Completion str str True 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 Nothing -> f Just e -> f {replacement = escape e (replacement f)} where escape e (c:cs) | c `elem` (e:ws) = e : c : escape e cs | otherwise = c : escape e cs escape _ "" = "" --------- -- Quoted completion 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 -- 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) _ -> alterative line addQuotes :: Completion -> Completion addQuotes c = if isFinished c then c {replacement = "\"" ++ replacement c ++ "\""} else c {replacement = "\"" ++ replacement c} splitAtQuote :: Maybe Char -> String -> String -> Maybe (String,String) splitAtQuote esc qs line = case line of c:e:cs | isEscape e && isEscapable c -> do (w,rest) <- splitAtQuote esc qs cs return (c:w,rest) q:cs | isQuote q -> Just ("",cs) c:cs -> do (w,rest) <- splitAtQuote esc qs cs return (c:w,rest) "" -> Nothing where isQuote = (`elem` qs) isEscape c = Just c == esc isEscapable c = isEscape c || isQuote c isUnquoted :: Maybe Char -> String -> String -> Bool isUnquoted esc qs s = case splitAtQuote esc qs s of Just (_,s') -> not (isUnquoted esc qs s') _ -> True -- | List all of the files or folders beginning with this path. listFiles :: MonadIO m => FilePath -> m [Completion] listFiles path = liftIO $ do fixedDir <- fixPath dir dirExists <- doesDirectoryExist fixedDir -- get all of the files in that directory, as basenames allFiles <- if not dirExists then return [] else fmap (map completion . filterPrefix) $ getDirectoryContents fixedDir -- The replacement text should include the directory part, and also -- have a trailing slash if it's itself a directory. forM allFiles $ \c -> do isDir <- doesDirectoryExist (fixedDir replacement c) return $ setReplacement fullName $ alterIfDir isDir c where (dir, file) = splitFileName path filterPrefix = filter (\f -> notElem f [".",".."] && file `isPrefixOf` f) alterIfDir False c = c alterIfDir True c = c {replacement = addTrailingPathSeparator (replacement c), isFinished = False} fullName = replaceFileName path -- turn a user-visible path into an internal version useable by System.FilePath. fixPath :: String -> IO String -- For versions of filepath < 1.2 fixPath "" = return "." fixPath ('~':c:path) | isPathSeparator c = do home <- getHomeDirectory return (home path) fixPath path = return path haskeline-0.7.0.3/System/Console/Haskeline/Directory.hsc0000644000000000000000000000717512022257741021260 0ustar0000000000000000{- | A Unicode-aware module for interacting with files. We just need enough to support filename completion. In particular, these functions will silently handle all errors (for example, file does not exist) -} module System.Console.Haskeline.Directory( getDirectoryContents, doesDirectoryExist, getHomeDirectory ) where #ifdef MINGW import Foreign import Foreign.C import System.Win32.Types #if __GLASGOW_HASKELL__ >= 611 import qualified System.Directory #endif #include #include ##if defined(i386_HOST_ARCH) ## define WINDOWS_CCONV stdcall ##elif defined(x86_64_HOST_ARCH) ## define WINDOWS_CCONV ccall ##else ## error Unknown mingw32 arch ##endif foreign import WINDOWS_CCONV "FindFirstFileW" c_FindFirstFile :: LPCTSTR -> Ptr () -> IO HANDLE foreign import WINDOWS_CCONV "FindNextFileW" c_FindNextFile :: HANDLE -> Ptr () -> IO Bool foreign import WINDOWS_CCONV "FindClose" c_FindClose :: HANDLE -> IO BOOL getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents fp = allocaBytes (#size WIN32_FIND_DATA) $ \findP -> withCWString (fp ++ "\\*") $ \t_arr -> do h <- c_FindFirstFile t_arr findP if h == iNVALID_HANDLE_VALUE then return [] else loop h findP where loop h findP = do f <- peekFileName findP isNext <- c_FindNextFile h findP if isNext then do {fs <- loop h findP; return (f:fs)} else c_FindClose h >> return [f] peekFileName = peekCWString . (#ptr WIN32_FIND_DATA, cFileName) foreign import WINDOWS_CCONV "GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO DWORD doesDirectoryExist :: FilePath -> IO Bool doesDirectoryExist file = do attrs <- withCWString file c_GetFileAttributes 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 WINDOWS_CCONV "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 import System.Console.Haskeline.Backend.Posix.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 getHomeDirectory :: IO FilePath getHomeDirectory = do codeset <- getCodeset decoder <- openDecoder codeset handle (\(_::IOException) -> return "") $ D.getHomeDirectory >>= decoder . pack #endif #endif haskeline-0.7.0.3/System/Console/Haskeline/Emacs.hs0000644000000000000000000001022312022257741020165 0ustar0000000000000000module System.Console.Haskeline.Emacs where import System.Console.Haskeline.Command import System.Console.Haskeline.Monads import System.Console.Haskeline.Key import System.Console.Haskeline.Command.Completion import System.Console.Haskeline.Command.History import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.Command.KillRing import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT import Data.Char type InputCmd s t = forall m . MonadException m => Command (InputCmdT m) s t type InputKeyCmd s t = forall m . MonadException m => KeyCommand (InputCmdT m) s t emacsCommands :: InputKeyCmd InsertMode (Maybe String) emacsCommands = choiceCmd [ choiceCmd [simpleActions, controlActions] >+> keyCommand emacsCommands , enders] enders :: InputKeyCmd InsertMode (Maybe String) enders = choiceCmd [simpleChar '\n' +> finish, eotKey +> deleteCharOrEOF] where eotKey = ctrlChar 'd' deleteCharOrEOF s | s == emptyIM = return Nothing | otherwise = change deleteNext s >>= justDelete justDelete = keyChoiceCmd [eotKey +> change deleteNext >|> justDelete , emacsCommands] simpleActions, controlActions :: InputKeyCmd InsertMode InsertMode simpleActions = choiceCmd [ simpleKey LeftKey +> change goLeft , simpleKey RightKey +> change goRight , simpleKey Backspace +> change deletePrev , simpleKey Delete +> change deleteNext , changeFromChar insertChar , completionCmd (simpleChar '\t') , simpleKey UpKey +> historyBack , simpleKey DownKey +> historyForward , searchHistory ] controlActions = choiceCmd [ ctrlChar 'a' +> change moveToStart , ctrlChar 'e' +> change moveToEnd , ctrlChar 'b' +> change goLeft , ctrlChar 'f' +> change goRight , ctrlChar 'l' +> clearScreenCmd , metaChar 'f' +> change wordRight , metaChar 'b' +> change wordLeft , ctrlKey (simpleKey LeftKey) +> change wordLeft , ctrlKey (simpleKey RightKey) +> change wordRight , metaChar 'c' +> change (modifyWord capitalize) , metaChar 'l' +> change (modifyWord (mapBaseChars toLower)) , metaChar 'u' +> change (modifyWord (mapBaseChars toUpper)) , ctrlChar '_' +> commandUndo , ctrlChar 'x' +> try (ctrlChar 'u' +> commandUndo) , ctrlChar 't' +> change transposeChars , ctrlChar 'p' +> historyBack , ctrlChar 'n' +> historyForward , metaChar '<' +> historyStart , metaChar '>' +> historyEnd , simpleKey Home +> change moveToStart , simpleKey End +> change moveToEnd , choiceCmd [ ctrlChar 'w' +> killFromHelper (SimpleMove bigWordLeft) , metaKey (simpleKey Backspace) +> killFromHelper (SimpleMove wordLeft) , metaChar 'd' +> killFromHelper (SimpleMove wordRight) , ctrlChar 'k' +> killFromHelper (SimpleMove moveToEnd) , simpleKey KillLine +> killFromHelper (SimpleMove moveToStart) ] , ctrlChar 'y' +> rotatePaste ] rotatePaste :: InputCmd InsertMode InsertMode rotatePaste im = get >>= loop where loop kr = case peek kr of Nothing -> return im Just s -> setState (insertGraphemes s im) >>= try (metaChar 'y' +> \_ -> loop (rotate kr)) wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode wordRight = goRightUntil (atStart (not . isAlphaNum)) wordLeft = goLeftUntil (atStart isAlphaNum) bigWordLeft = goLeftUntil (atStart isSpace) modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode modifyWord f im = IMode (reverse (f ys1) ++ xs) ys2 where IMode xs ys = skipRight (not . isAlphaNum) im (ys1,ys2) = span (isAlphaNum . baseChar) ys capitalize :: [Grapheme] -> [Grapheme] capitalize [] = [] capitalize (c:cs) = modifyBaseChar toUpper c : cs haskeline-0.7.0.3/System/Console/Haskeline/History.hs0000644000000000000000000001215612022257741020605 0ustar0000000000000000{- | This module provides a low-level API to the line history stored in the @InputT@ monad transformer. For most application, it should suffice to instead use the following @Settings@ flags: * @autoAddHistory@: add nonblank lines to the command history ('True' by default). * @historyFile@: read/write the history to a file before and after the line input session. If you do want custom history behavior, you may need to disable the above default setting(s). -} module System.Console.Haskeline.History( History(), emptyHistory, addHistory, addHistoryUnlessConsecutiveDupe, addHistoryRemovingAllDupes, historyLines, readHistory, writeHistory, stifleHistory, stifleAmount, ) where import qualified Data.Sequence as Seq import Data.Sequence ( Seq, (<|), ViewL(..), ViewR(..), viewl, viewr ) import Data.Foldable (toList) import Control.Exception import System.Directory(doesFileExist) #ifdef USE_GHC_ENCODINGS import qualified System.IO as IO import System.Console.Haskeline.Recover #else import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 #endif data History = History {histLines :: Seq String, stifleAmt :: Maybe Int} -- stored in reverse -- | The maximum number of lines stored in the history. If 'Nothing', the history storage is unlimited. stifleAmount :: History -> Maybe Int stifleAmount = stifleAmt instance Show History where show = show . histLines emptyHistory :: History emptyHistory = History Seq.empty Nothing -- | The input lines stored in the history (newest first) historyLines :: History -> [String] historyLines = toList . histLines -- | Reads the line input history from the given file. Returns -- 'emptyHistory' if the file does not exist or could not be read. readHistory :: FilePath -> IO History readHistory file = handle (\(_::IOException) -> return emptyHistory) $ do exists <- doesFileExist file contents <- if exists then readUTF8File file else return "" _ <- evaluate (length contents) -- force file closed return History {histLines = Seq.fromList $ lines contents, stifleAmt = Nothing} -- | Writes the line history to the given file. If there is an -- error when writing the file, it will be ignored. writeHistory :: FilePath -> History -> IO () writeHistory file = handle (\(_::IOException) -> return ()) . writeUTF8File file . unlines . historyLines -- | Limit the number of lines stored in the history. stifleHistory :: Maybe Int -> History -> History stifleHistory Nothing hist = hist {stifleAmt = Nothing} stifleHistory a@(Just n) hist = History {histLines = stifleFnc (histLines hist), stifleAmt = a} where stifleFnc = if n > Seq.length (histLines hist) then id else Seq.fromList . take n . toList addHistory :: String -> History -> History 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 maxAmt hs | rightSize = hs | otherwise = case viewr hs of EmptyR -> hs hs' :> _ -> hs' where rightSize = maybe True (>= Seq.length hs) maxAmt -- | Add a line to the history unless it matches the previously recorded line. addHistoryUnlessConsecutiveDupe :: String -> History -> History addHistoryUnlessConsecutiveDupe h hs = case viewl (histLines hs) of h1 :< _ | h==h1 -> hs _ -> addHistory h hs -- | Add a line to the history, and remove all previous entries which are the -- same as it. addHistoryRemovingAllDupes :: String -> History -> History 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 #ifdef USE_GHC_ENCODINGS 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 #else readUTF8File file = do contents <- fmap UTF8.toString $ B.readFile file _ <- evaluate (length contents) return contents #endif writeUTF8File :: FilePath -> String -> IO () #ifdef USE_GHC_ENCODINGS 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 #else -- use binary file I/O to avoid Windows CRLF line endings -- which cause confusion when switching between systems. writeUTF8File file = B.writeFile file . UTF8.fromString #endif haskeline-0.7.0.3/System/Console/Haskeline/InputT.hs0000644000000000000000000002117112022257741020364 0ustar0000000000000000module System.Console.Haskeline.InputT where import System.Console.Haskeline.History import System.Console.Haskeline.Command.History import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.Command.KillRing import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.Prefs import System.Console.Haskeline.Completion import System.Console.Haskeline.Backend import System.Console.Haskeline.Term import System.Directory(getHomeDirectory) import System.FilePath import Control.Applicative import Control.Monad (liftM, ap) import System.IO import Data.IORef -- | Application-specific customizations to the user interface. data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion. historyFile :: Maybe FilePath, -- ^ Where to read/write the history at the -- start and end of each -- line input session. autoAddHistory :: Bool -- ^ If 'True', each nonblank line returned by -- @getInputLine@ will be automatically added to the history. } -- | Because 'complete' is the only field of 'Settings' depending on @m@, -- the expression @defaultSettings {completionFunc = f}@ leads to a type error -- from being too general. This function works around that issue, and may become unnecessary if another field -- depending on @m@ is added. setComplete :: CompletionFunc m -> Settings m -> Settings m setComplete f s = s {complete = f} -- | 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 -- 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) -- 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 Monad m => Functor (InputT m) where fmap = liftM instance Monad m => Applicative (InputT m) where pure = return (<*>) = ap instance MonadTrans InputT where lift = InputT . lift . lift . lift . lift . lift -- | 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 (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 history <- get lift $ lift $ evalStateT' (histLog history) $ runUndoT $ evalStateT' layout f instance MonadException 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 = runInputTBehaviorWithPrefs defaultBehavior -- | Run a line-reading application. This function should suffice for most applications. -- -- This function is equivalent to @'runInputTBehavior' 'defaultBehavior'@. It -- uses terminal-style interaction if 'stdin' is connected to a terminal and has -- echoing enabled. Otherwise (e.g., if 'stdin' is a pipe), it uses file-style interaction. -- -- 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 = runInputTBehavior defaultBehavior -- | Returns 'True' if the current session uses terminal-style interaction. (See 'Behavior'.) haveTerminalUI :: Monad m => InputT m Bool haveTerminalUI = InputT $ asks isTerminalStyle {- | Haskeline has two ways of interacting with the user: * \"Terminal-style\" interaction provides an rich user interface by connecting to the user's terminal (which may be different than 'stdin' or 'stdout'). * \"File-style\" interaction treats the input as a simple stream of characters, for example when reading from a file or pipe. Input functions (e.g., @getInputLine@) print the prompt to 'stdout'. A 'Behavior' is a method for deciding at run-time which type of interaction to use. For most applications (e.g., a REPL), 'defaultBehavior' should have the correct effect. -} data Behavior = Behavior (IO RunTerm) -- | 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 (Behavior run) f = bracket (liftIO run) (liftIO . closeTerm) f -- | Run a line-reading application according to the given behavior. -- -- 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 behavior settings f = withBehavior behavior $ \run -> do prefs <- if isTerminalStyle run then liftIO readPrefsFromHome else return defaultPrefs execInputT prefs settings run f -- | Run a line-reading application. runInputTBehaviorWithPrefs :: MonadException 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 -> InputT m a -> m a execInputT prefs settings run (InputT f) = runReaderT' settings $ runReaderT' prefs $ runKillRing $ 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 -- a terminal and has echoing enabled. Otherwise (e.g., if 'stdin' is a pipe), use -- file-style interaction. -- -- This behavior should suffice for most applications. defaultBehavior :: Behavior defaultBehavior = Behavior defaultRunTerm -- | Use file-style interaction, reading input from the given 'Handle'. useFileHandle :: Handle -> Behavior useFileHandle = Behavior . fileHandleRunTerm -- | Use file-style interaction, reading input from the given file. useFile :: FilePath -> Behavior useFile file = Behavior $ do h <- openBinaryFile file ReadMode rt <- fileHandleRunTerm h return rt { closeTerm = closeTerm rt >> hClose h} -- | Use terminal-style interaction whenever possible, even if 'stdin' and/or 'stdout' are not -- terminals. -- -- If it cannot open the user's terminal, use file-style interaction, reading input from 'stdin'. preferTerm :: Behavior preferTerm = Behavior terminalRunTerm -- | Read 'Prefs' from @~/.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") haskeline-0.7.0.3/System/Console/Haskeline/IO.hs0000644000000000000000000000707412022257741017456 0ustar0000000000000000{- | This module provides a stateful, IO-based interface to Haskeline, which may be easier to integrate into some existing programs or libraries. It is strongly recommended to use the safer, monadic API of "System.Console.Haskeline", if possible, rather than the explicit state management functions of this module. The equivalent REPL example is: @ import System.Console.Haskeline import System.Console.Haskeline.IO import Control.Concurrent main = bracketOnError (initializeInput defaultSettings) cancelInput -- This will only be called if an exception such -- as a SigINT is received. (\\hd -> loop hd >> closeInput hd) where loop :: InputState -> IO () loop hd = do minput <- queryInput hd (getInputLine \"% \") case minput of Nothing -> return () Just \"quit\" -> return () Just input -> do queryInput hd $ outputStrLn $ \"Input was: \" ++ input loop hd @ -} module System.Console.Haskeline.IO( InputState(), initializeInput, closeInput, cancelInput, queryInput ) where import System.Console.Haskeline hiding (completeFilename) import Control.Concurrent import Control.Monad.IO.Class -- Providing a non-monadic API for haskeline -- A process is forked off which runs the monadic InputT API -- and actions to be run are passed to it through the following MVars. data Request = forall a . Request (InputT IO a) (MVar a) data InputState = HD {forkedThread :: ThreadId, requestVar :: MVar (Maybe Request), subthreadFinished :: MVar () } -- | Initialize a session of line-oriented user interaction. initializeInput :: Settings IO -> IO InputState initializeInput settings = do reqV <- newEmptyMVar finished <- newEmptyMVar tid <- forkIO (runHaskeline settings reqV finished) return HD {requestVar = reqV, forkedThread = tid, subthreadFinished = finished} runHaskeline :: Settings IO -> MVar (Maybe Request) -> MVar () -> IO () runHaskeline settings reqV finished = runInputT settings loop `finally` putMVar finished () where loop = do mf <- liftIO $ takeMVar reqV case mf of Nothing -> return () Just (Request f var) -> f >>= liftIO . putMVar var >> loop -- | Finish and clean up the line-oriented user interaction session. Blocks on an -- existing call to 'queryInput'. closeInput :: InputState -> IO () closeInput hd = putMVar (requestVar hd) Nothing >> takeMVar (subthreadFinished hd) -- | Cancel and clean up the user interaction session. Does not block on an existing -- call to 'queryInput'. cancelInput :: InputState -> IO () cancelInput hd = killThread (forkedThread hd) >> takeMVar (subthreadFinished hd) -- | Run one action (for example, 'getInputLine') as part of a session of user interaction. -- -- For example, multiple calls to 'queryInput' using the same 'InputState' will share -- the same input history. In constrast, multiple calls to 'runInputT' will use distinct -- histories unless they share the same history file. -- -- This function should not be called on a closed or cancelled 'InputState'. queryInput :: InputState -> InputT IO a -> IO a queryInput hd f = do var <- newEmptyMVar putMVar (requestVar hd) (Just (Request f var)) takeMVar var haskeline-0.7.0.3/System/Console/Haskeline/Key.hs0000644000000000000000000000731012022257741017670 0ustar0000000000000000module System.Console.Haskeline.Key(Key(..), Modifier(..), BaseKey(..), noModifier, simpleKey, simpleChar, metaChar, ctrlChar, metaKey, ctrlKey, parseKey ) where import Data.Char import Control.Monad import Data.Maybe import Data.Bits data Key = Key Modifier BaseKey deriving (Show,Eq,Ord) data Modifier = Modifier {hasControl, hasMeta, hasShift :: Bool} deriving (Eq,Ord) instance Show Modifier where show m = show $ catMaybes [maybeUse hasControl "ctrl" , maybeUse hasMeta "meta" , maybeUse hasShift "shift" ] where maybeUse f str = if f m then Just str else Nothing noModifier :: Modifier noModifier = Modifier False False False 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) simpleKey :: BaseKey -> Key simpleKey = Key noModifier metaKey :: Key -> Key metaKey (Key m bc) = Key m {hasMeta = True} bc ctrlKey :: Key -> Key ctrlKey (Key m bc) = Key m {hasControl = True} bc simpleChar, metaChar, ctrlChar :: Char -> Key simpleChar = simpleKey . KeyChar metaChar = metaKey . simpleChar ctrlChar = simpleChar . setControlBits setControlBits :: Char -> Char setControlBits '?' = toEnum 127 setControlBits c = toEnum $ fromEnum c .&. complement (bit 5 .|. bit 6) specialKeys :: [(String,BaseKey)] specialKeys = [("left",LeftKey) ,("right",RightKey) ,("down",DownKey) ,("up",UpKey) ,("killline",KillLine) ,("home",Home) ,("end",End) ,("pagedown",PageDown) ,("pageup",PageUp) ,("backspace",Backspace) ,("delete",Delete) ,("return",KeyChar '\n') ,("enter",KeyChar '\n') ,("tab",KeyChar '\t') ,("esc",KeyChar '\ESC') ,("escape",KeyChar '\ESC') ] parseModifiers :: [String] -> BaseKey -> Key parseModifiers strs = Key mods where mods = foldl1 (.) (map parseModifier strs) noModifier parseModifier :: String -> (Modifier -> Modifier) parseModifier str m = case map toLower str of "ctrl" -> m {hasControl = True} "control" -> m {hasControl = True} "meta" -> m {hasMeta = True} "shift" -> m {hasShift = True} _ -> m breakAtDashes :: String -> [String] breakAtDashes "" = [] breakAtDashes str = case break (=='-') str of (xs,'-':rest) -> xs : breakAtDashes rest (xs,_) -> [xs] parseKey :: String -> Maybe Key parseKey str = fmap canonicalizeKey $ case reverse (breakAtDashes str) of [ks] -> liftM simpleKey (parseBaseKey ks) ks:ms -> liftM (parseModifiers ms) (parseBaseKey ks) [] -> Nothing parseBaseKey :: String -> Maybe BaseKey parseBaseKey ks = lookup (map toLower ks) specialKeys `mplus` parseFunctionKey ks `mplus` parseKeyChar ks where parseKeyChar [c] | isPrint c = Just (KeyChar c) parseKeyChar _ = Nothing parseFunctionKey (f:ns) | f `elem` "fF" = case reads ns of [(n,"")] -> Just (FunKey n) _ -> Nothing parseFunctionKey _ = Nothing canonicalizeKey :: Key -> Key canonicalizeKey (Key m (KeyChar c)) | hasControl m = Key m {hasControl = False} (KeyChar (setControlBits c)) | hasShift m = Key m {hasShift = False} (KeyChar (toUpper c)) canonicalizeKey k = k haskeline-0.7.0.3/System/Console/Haskeline/LineState.hs0000644000000000000000000003516112022257741021035 0ustar0000000000000000{- | This module contains the various datatypes which model the state of the line; that is, the characters displayed and the position of the cursor. -} module System.Console.Haskeline.LineState( -- * Graphemes Grapheme(), baseChar, stringToGraphemes, graphemesToString, modifyBaseChar, mapBaseChars, -- * Line State class LineState(..), Prefix, -- ** Convenience functions for the drawing backends LineChars, lineChars, lengthToEnd, -- ** Supplementary classes Result(..), Save(..), listSave, listRestore, Move(..), -- * Instances -- ** InsertMode InsertMode(..), emptyIM, insertChar, insertString, replaceCharIM, insertGraphemes, deleteNext, deletePrev, skipLeft, skipRight, transposeChars, -- *** Moving to word boundaries goRightUntil, goLeftUntil, atStart, atEnd, beforeChar, afterChar, overChar, -- ** CommandMode CommandMode(..), deleteChar, replaceChar, pasteGraphemesBefore, pasteGraphemesAfter, -- *** Transitioning between modes enterCommandMode, enterCommandModeRight, insertFromCommandMode, appendFromCommandMode, withCommandMode, -- ** ArgMode ArgMode(..), startArg, addNum, applyArg, applyCmdArg, -- ** Other line state types Message(..), Password(..), addPasswordChar, deletePasswordChar, ) where import Data.Char -- | A 'Grapheme' is a fundamental unit of display for the UI. Several characters in sequence -- 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]} deriving Eq instance Show Grapheme where show g = show (gBaseChar g : combiningChars g) baseChar :: Grapheme -> Char baseChar = gBaseChar modifyBaseChar :: (Char -> Char) -> Grapheme -> Grapheme modifyBaseChar f g = g {gBaseChar = f (gBaseChar g)} mapBaseChars :: (Char -> Char) -> [Grapheme] -> [Grapheme] mapBaseChars f = map (modifyBaseChar f) -- | Create a 'Grapheme' from a single base character. -- -- NOTE: Careful, don't use outside this module; and inside, make sure this is only -- ever called on non-combining characters. baseGrapheme :: Char -> Grapheme baseGrapheme c = Grapheme {gBaseChar = c, combiningChars = []} -- | Add a combining character to the given 'Grapheme'. addCombiner :: Grapheme -> Char -> Grapheme addCombiner g c = g {combiningChars = combiningChars g ++ [c]} isCombiningChar :: Char -> Bool isCombiningChar c = generalCategory c == NonSpacingMark -- | Converts a string into a sequence of graphemes. -- -- NOTE: Drops any initial, unattached combining characters. stringToGraphemes :: String -> [Grapheme] stringToGraphemes = mkString . dropWhile isCombiningChar where mkString [] = [] -- Minor hack: "\ESC...\STX" or "\SOH\ESC...\STX", where "\ESC..." is some -- control sequence (e.g., ANSI colors), is represented as a grapheme -- of zero length with '\ESC' as the base character. -- Note that this won't round-trip correctly with graphemesToString. -- In practice, however, that's fine since control characters can only occur -- in the prompt. mkString ('\SOH':cs) = stringToGraphemes cs mkString ('\ESC':cs) | (ctrl,'\STX':rest) <- break (=='\STX') cs = Grapheme '\ESC' ctrl : stringToGraphemes rest mkString (c:cs) = Grapheme c (takeWhile isCombiningChar cs) : mkString (dropWhile isCombiningChar cs) graphemesToString :: [Grapheme] -> String graphemesToString = concatMap (\g -> (baseChar g : combiningChars g)) -- | This class abstracts away the internal representations of the line state, -- for use by the drawing actions. Line state is generally stored in a zipper format. class LineState s where beforeCursor :: Prefix -- ^ The input prefix. -> s -- ^ The current line state. -> [Grapheme] -- ^ The text to the left of the cursor -- (including the prefix). afterCursor :: s -> [Grapheme] -- ^ The text under and to the right of the cursor. type Prefix = [Grapheme] -- | The characters in the line (with the cursor in the middle). NOT in a zippered format; -- both lists are in the order left->right that appears on the screen. type LineChars = ([Grapheme],[Grapheme]) -- | Accessor function for the various backends. lineChars :: LineState s => Prefix -> s -> LineChars lineChars prefix s = (beforeCursor prefix s, afterCursor s) -- | Compute the number of characters under and to the right of the cursor. lengthToEnd :: LineChars -> Int lengthToEnd = length . snd class LineState s => Result s where toResult :: s -> String class LineState s => Save s where save :: s -> InsertMode restore :: InsertMode -> s listSave :: Save s => s -> [Grapheme] listSave s = case save s of IMode xs ys -> reverse xs ++ ys listRestore :: Save s => [Grapheme] -> s listRestore xs = restore $ IMode (reverse xs) [] 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] deriving (Show, Eq) instance LineState InsertMode where beforeCursor prefix (IMode xs _) = prefix ++ reverse xs afterCursor (IMode _ ys) = ys instance Result InsertMode where toResult (IMode xs ys) = graphemesToString $ reverse xs ++ ys instance Save InsertMode where save = id restore = id instance Move InsertMode where goLeft im@(IMode [] _) = im goLeft (IMode (x:xs) ys) = IMode xs (x:ys) goRight im@(IMode _ []) = im goRight (IMode ys (x:xs)) = IMode (x:ys) xs moveToStart (IMode xs ys) = IMode [] (reverse xs ++ ys) moveToEnd (IMode xs ys) = IMode (reverse ys ++ xs) [] emptyIM :: InsertMode 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 [] -> im -- drop a combining character if it -- appears at the start of the line. 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. insertString :: String -> InsertMode -> InsertMode insertString s (IMode xs ys) = IMode (reverse (stringToGraphemes s) ++ xs) ys deleteNext, deletePrev :: InsertMode -> InsertMode deleteNext im@(IMode _ []) = im deleteNext (IMode xs (_:ys)) = IMode xs ys deletePrev im@(IMode [] _) = im 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 in IMode zs (reverse ws ++ ys) skipRight f (IMode xs ys) = let (ws,zs) = span (f . baseChar) ys in IMode (reverse ws ++ xs) zs transposeChars :: InsertMode -> InsertMode transposeChars (IMode (x:xs) (y:ys)) = IMode (x:y:xs) ys transposeChars (IMode (y:x:xs) []) = IMode (x:y:xs) [] transposeChars im = im insertGraphemes :: [Grapheme] -> InsertMode -> InsertMode insertGraphemes s (IMode xs ys) = IMode (reverse s ++ xs) ys -- For the 'R' command. replaceCharIM :: Char -> InsertMode -> InsertMode replaceCharIM c im | isCombiningChar c = case im of IMode [] [] -> im IMode [] (y:ys) -> IMode [] (addCombiner y c:ys) IMode (x:xs) ys -> IMode (addCombiner x c:xs) ys | otherwise = let g = baseGrapheme c in case im of IMode xs [] -> IMode (g:xs) [] IMode xs (_:ys) -> IMode (g:xs) ys -- | Used by vi mode. Considers the cursor to be located over some specific character. -- The first list is reversed. data CommandMode = CMode [Grapheme] Grapheme [Grapheme] | CEmpty deriving Show instance LineState CommandMode where beforeCursor prefix CEmpty = prefix beforeCursor prefix (CMode xs _ _) = prefix ++ reverse xs afterCursor CEmpty = [] afterCursor (CMode _ c ys) = c:ys instance Result CommandMode where toResult CEmpty = "" toResult (CMode xs c ys) = graphemesToString $ reverse xs ++ (c:ys) instance Save CommandMode where save = insertFromCommandMode restore = enterCommandModeRight instance Move CommandMode where goLeft (CMode (x:xs) c ys) = CMode xs x (c:ys) goLeft cm = cm goRight (CMode xs c (y:ys)) = CMode (c:xs) y ys goRight cm = cm moveToStart (CMode xs c ys) = let zs = reverse xs ++ (c:ys) in CMode [] (head zs) (tail zs) moveToStart CEmpty = CEmpty moveToEnd (CMode xs c ys) = let zs = reverse ys ++ (c:xs) in CMode (tail zs) (head zs) [] moveToEnd CEmpty = CEmpty deleteChar :: CommandMode -> CommandMode deleteChar (CMode xs _ (y:ys)) = CMode xs y ys deleteChar (CMode (x:xs) _ []) = CMode xs x [] deleteChar _ = CEmpty replaceChar :: Char -> CommandMode -> CommandMode replaceChar c (CMode xs d ys) | not (isCombiningChar c) = CMode xs (baseGrapheme c) ys | otherwise = CMode xs (addCombiner d c) ys replaceChar _ CEmpty = CEmpty pasteGraphemesBefore, pasteGraphemesAfter :: [Grapheme] -> CommandMode -> CommandMode pasteGraphemesBefore [] = id pasteGraphemesBefore s = enterCommandMode . insertGraphemes s . insertFromCommandMode pasteGraphemesAfter [] = id pasteGraphemesAfter s = enterCommandMode . insertGraphemes s . appendFromCommandMode ------------------------ -- Transitioning between modes enterCommandMode, enterCommandModeRight :: InsertMode -> CommandMode enterCommandMode (IMode (x:xs) ys) = CMode xs x ys enterCommandMode (IMode [] (y:ys)) = CMode [] y ys enterCommandMode _ = CEmpty enterCommandModeRight (IMode xs (y:ys)) = CMode xs y ys enterCommandModeRight (IMode (x:xs) []) = CMode xs x [] enterCommandModeRight _ = CEmpty insertFromCommandMode, appendFromCommandMode :: CommandMode -> InsertMode insertFromCommandMode CEmpty = emptyIM insertFromCommandMode (CMode xs c ys) = IMode xs (c:ys) appendFromCommandMode CEmpty = emptyIM appendFromCommandMode (CMode xs c ys) = IMode (c:xs) ys withCommandMode :: (InsertMode -> InsertMode) -> CommandMode -> CommandMode withCommandMode f = enterCommandModeRight . f . insertFromCommandMode ---------------------- -- Supplementary modes -- | Used for commands which take an integer argument. data ArgMode s = ArgMode {arg :: Int, argState :: s} instance Functor ArgMode where fmap f am = am {argState = f (argState am)} instance LineState s => LineState (ArgMode s) where beforeCursor _ am = let pre = map baseGrapheme $ "(arg: " ++ show (arg am) ++ ") " in beforeCursor pre (argState am) afterCursor = afterCursor . argState instance Result s => Result (ArgMode s) where toResult = toResult . argState instance Save s => Save (ArgMode s) where save = save . argState restore = startArg 0 . restore startArg :: Int -> s -> ArgMode s startArg = ArgMode 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} -- 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 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} instance LineState (Message s) where beforeCursor _ = stringToGraphemes . messageText afterCursor _ = [] ---------------- data Password = Password {passwordState :: [Char], -- ^ reversed passwordChar :: Maybe Char} instance LineState Password where beforeCursor prefix p = prefix ++ (stringToGraphemes $ case passwordChar p of Nothing -> [] Just c -> replicate (length $ passwordState p) c) afterCursor _ = [] instance Result Password where toResult = reverse . passwordState addPasswordChar :: Char -> Password -> Password addPasswordChar c p = p {passwordState = c : passwordState p} deletePasswordChar :: Password -> Password deletePasswordChar (Password (_:cs) m) = Password cs m deletePasswordChar p = p ----------------- atStart, atEnd :: (Char -> Bool) -> InsertMode -> Bool atStart f (IMode (x:_) (y:_)) = not (f (baseChar x)) && f (baseChar y) atStart _ _ = False atEnd f (IMode _ (y1:y2:_)) = f (baseChar y1) && not (f (baseChar y2)) atEnd _ _ = False overChar, beforeChar, afterChar :: (Char -> Bool) -> InsertMode -> Bool overChar f (IMode _ (y:_)) = f (baseChar y) overChar _ _ = False beforeChar f (IMode _ (_:y:_)) = f (baseChar y) beforeChar _ _ = False afterChar f (IMode (x:_) _) = f (baseChar x) afterChar _ _ = False goRightUntil, goLeftUntil :: (InsertMode -> Bool) -> InsertMode -> InsertMode goRightUntil f = loop . goRight where 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) haskeline-0.7.0.3/System/Console/Haskeline/MonadException.hs0000644000000000000000000001463512022257741022065 0ustar0000000000000000{- | This module redefines some of the functions in "Control.Exception" to work for more general monads built on top of 'IO'. -} module System.Console.Haskeline.MonadException( -- * The MonadException class MonadException(..), -- * Generalizations of Control.Exception catch, handle, finally, throwIO, throwTo, bracket, -- * Helpers for defining \"wrapper\" functions liftIOOp, liftIOOp_, -- * Internal implementation RunIO(..), -- * Extensible Exceptions Exception, SomeException(..), E.IOException(), ) where import qualified Control.Exception as E import Control.Exception (Exception,SomeException) #if __GLASGOW_HASKELL__ < 705 import Prelude hiding (catch) #endif import Control.Monad(liftM, join) import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Error import Control.Monad.Trans.List import Control.Monad.Trans.Maybe import Control.Monad.Trans.RWS import Control.Monad.Trans.Writer import Data.Monoid import Control.Concurrent(ThreadId) -- This approach is based on that of the monad-control package. -- Since we want to use haskeline to bootstrap GHC, we reimplement -- a simplified version here. -- Additionally, we avoid TypeFamilies (which are used in the latest version of -- monad-control) so that we're still compatible with older versions of GHC. -- | A 'RunIO' function takes a monadic action @m@ as input, -- and outputs an IO action which performs the underlying impure part of @m@ -- and returns the ''pure'' part of @m@. -- -- Note that @(RunIO return)@ is an incorrect implementation, since it does not -- separate the pure and impure parts of the monadic action. This module defines -- implementations for several common monad transformers. newtype RunIO m = RunIO (forall b . m b -> IO (m b)) -- Uses a newtype so we don't need RankNTypes. -- | An instance of 'MonadException' is generally made up of monad transformers -- layered on top of the IO monad. -- -- The 'controlIO' method enables us to \"lift\" a function that manages IO actions (such -- as 'bracket' or 'catch') into a function that wraps arbitrary monadic actions. class MonadIO m => MonadException m where controlIO :: (RunIO m -> IO (m a)) -> m a -- | Lift a IO operation -- -- > wrap :: (a -> IO b) -> IO b -- -- to a more general monadic operation -- -- > liftIOOp wrap :: MonadException m => (a -> m b) -> m b -- -- For example: -- -- @ -- 'liftIOOp' ('System.IO.withFile' f m) :: MonadException m => (Handle -> m r) -> m r -- 'liftIOOp' 'Foreign.Marshal.Alloc.alloca' :: (MonadException m, Storable a) => (Ptr a -> m b) -> m b -- 'liftIOOp' (`Foreign.ForeignPtr.withForeignPtr` fp) :: MonadException m => (Ptr a -> m b) -> m b -- @ liftIOOp :: MonadException m => ((a -> IO (m b)) -> IO (m c)) -> (a -> m b) -> m c liftIOOp f g = controlIO $ \(RunIO run) -> f (run . g) -- | Lift an IO operation -- -- > wrap :: IO a -> IO a -- -- to a more general monadic operation -- -- > liftIOOp_ wrap :: MonadException m => m a -> m a liftIOOp_ :: MonadException m => (IO (m a) -> IO (m a)) -> m a -> m a liftIOOp_ f act = controlIO $ \(RunIO run) -> f (run act) catch :: (MonadException m, E.Exception e) => m a -> (e -> m a) -> m a catch act handler = controlIO $ \(RunIO run) -> E.catch (run act) (run . handler) handle :: (MonadException m, Exception e) => (e -> m a) -> m a -> m a handle = flip catch bracket :: MonadException m => m a -> (a -> m b) -> (a -> m c) -> m c bracket before after thing = controlIO $ \(RunIO run) -> E.bracket (run before) (\m -> run (m >>= after)) (\m -> run (m >>= thing)) finally :: MonadException m => m a -> m b -> m a finally thing ender = controlIO $ \(RunIO run) -> E.finally (run thing) (run ender) throwIO :: (MonadIO m, Exception e) => e -> m a throwIO = liftIO . E.throwIO throwTo :: (MonadIO m, Exception e) => ThreadId -> e -> m () throwTo tid = liftIO . E.throwTo tid ---------- -- Instances of MonadException. -- Since implementations of this class are non-obvious to a casual user, -- we provide instances for nearly everything in the transformers package. instance MonadException IO where controlIO f = join $ f (RunIO (liftM return)) -- Note: it's crucial that we use "liftM return" instead of "return" here. -- For example, in "finally thing end", this ensures that "end" will always run, -- regardless of whether an mzero occurred inside of "thing". instance MonadException m => MonadException (ReaderT r m) where controlIO f = ReaderT $ \r -> controlIO $ \(RunIO run) -> let run' = RunIO (fmap (ReaderT . const) . run . flip runReaderT r) in fmap (flip runReaderT r) $ f run' instance MonadException m => MonadException (StateT s m) where controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let run' = RunIO (fmap (StateT . const) . run . flip runStateT s) in fmap (flip runStateT s) $ f run' instance MonadException m => MonadException (MaybeT m) where controlIO f = MaybeT $ controlIO $ \(RunIO run) -> let run' = RunIO (fmap MaybeT . run . runMaybeT) in fmap runMaybeT $ f run' instance (MonadException m, Error e) => MonadException (ErrorT e m) where controlIO f = ErrorT $ controlIO $ \(RunIO run) -> let run' = RunIO (fmap ErrorT . run . runErrorT) in fmap runErrorT $ f run' instance MonadException m => MonadException (ListT m) where controlIO f = ListT $ controlIO $ \(RunIO run) -> let run' = RunIO (fmap ListT . run . runListT) in fmap runListT $ f run' instance (Monoid w, MonadException m) => MonadException (WriterT w m) where controlIO f = WriterT $ controlIO $ \(RunIO run) -> let run' = RunIO (fmap WriterT . run . runWriterT) in fmap runWriterT $ f run' instance (Monoid w, MonadException m) => MonadException (RWST r w s m) where controlIO f = RWST $ \r s -> controlIO $ \(RunIO run) -> let run' = RunIO (fmap (\act -> RWST (\_ _ -> act)) . run . (\m -> runRWST m r s)) in fmap (\m -> runRWST m r s) $ f run' haskeline-0.7.0.3/System/Console/Haskeline/Monads.hs0000644000000000000000000000745512022257741020373 0ustar0000000000000000module System.Console.Haskeline.Monads( module System.Console.Haskeline.MonadException, MonadTrans(..), MonadIO(..), ReaderT(..), runReaderT', mapReaderT, asks, StateT, runStateT, evalStateT', mapStateT, gets, modify, update, MonadReader(..), MonadState(..), MaybeT(..), orElse ) where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader hiding (ask,asks) import qualified Control.Monad.Trans.Reader as Reader import Data.IORef #if __GLASGOW_HASKELL__ < 705 import Prelude hiding (catch) #endif import System.Console.Haskeline.MonadException class Monad m => MonadReader r m where ask :: m r instance Monad m => MonadReader r (ReaderT r m) where ask = Reader.ask 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 ask = lift ask asks :: MonadReader r m => (r -> a) -> m a asks f = liftM f ask class Monad m => MonadState s m where get :: m s put :: s -> m () gets :: MonadState s m => (s -> a) -> m a gets f = liftM f get modify :: MonadState s m => (s -> s) -> m () modify f = get >>= put . f update :: MonadState s m => (s -> (a,s)) -> m a update f = do s <- get let (x,s') = f s put s' return x runReaderT' :: Monad m => 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 mapStateT :: (forall b . m b -> n b) -> StateT s m a -> StateT s n a mapStateT f (StateT m) = StateT (\s -> f (m s)) runStateT :: Monad m => StateT s m a -> s -> m (a, s) runStateT f s = do useXS <- getStateTFunc f s return $ useXS $ \x s' -> (x,s') makeStateT :: Monad m => (s -> m (a,s)) -> StateT s m a makeStateT f = StateT $ \s -> do (x,s') <- f s return $ \g -> g x s' instance Monad m => MonadState s (StateT s m) where get = StateT $ \s -> return $ \f -> f s s put s = s `seq` StateT $ \_ -> return $ \f -> f () s instance (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where get = lift get put = lift . put -- 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 evalStateT' :: Monad m => s -> StateT s m a -> m a evalStateT' s f = liftM fst $ runStateT f s instance MonadException m => MonadException (StateT s m) where controlIO f = makeStateT $ \s -> controlIO $ \run -> fmap (flip runStateT s) $ f $ stateRunIO s run where stateRunIO :: s -> RunIO m -> RunIO (StateT s m) stateRunIO s (RunIO run) = RunIO (\m -> fmap (makeStateT . const) $ run (runStateT m s)) orElse :: Monad m => MaybeT m a -> m a -> m a orElse (MaybeT f) g = f >>= maybe g return haskeline-0.7.0.3/System/Console/Haskeline/Prefs.hs0000644000000000000000000001320612022257741020220 0ustar0000000000000000module System.Console.Haskeline.Prefs( Prefs(..), defaultPrefs, readPrefs, CompletionType(..), BellStyle(..), EditMode(..), HistoryDuplicates(..), lookupKeyBinding ) where import Data.Char(isSpace,toLower) import Data.List(foldl') import qualified Data.Map as Map import System.Console.Haskeline.MonadException(handle,IOException) import System.Console.Haskeline.Key {- | 'Prefs' allow the user to customize the terminal-style line-editing interface. They are read by default from @~/.haskeline@; to override that behavior, use 'readPrefs' and @runInputTWithPrefs@. Each line of a @.haskeline@ file defines one field of the 'Prefs' datatype; field names are case-insensitive and unparseable lines are ignored. For example: > editMode: Vi > completionType: MenuCompletion > maxhistorysize: Just 40 -} data Prefs = Prefs { bellStyle :: !BellStyle, editMode :: !EditMode, maxHistorySize :: !(Maybe Int), historyDuplicates :: HistoryDuplicates, completionType :: !CompletionType, completionPaging :: !Bool, -- ^ When listing completion alternatives, only display -- one screen of possibilities at a time. completionPromptLimit :: !(Maybe Int), -- ^ If more than this number of completion -- possibilities are found, then ask before listing -- them. listCompletionsImmediately :: !Bool, -- ^ If 'False', completions with multiple possibilities -- will ring the bell and only display them if the user -- presses @TAB@ again. customBindings :: Map.Map Key [Key], -- (termName, keysequence, key) customKeySequences :: [(Maybe String, String,Key)] } deriving Show data CompletionType = ListCompletion | MenuCompletion deriving (Read,Show) data BellStyle = NoBell | VisualBell | AudibleBell deriving (Show, Read) data EditMode = Vi | Emacs deriving (Show,Read) data HistoryDuplicates = AlwaysAdd | IgnoreConsecutive | IgnoreAll deriving (Show,Read) -- | The default preferences which may be overwritten in the -- @.haskeline@ file. defaultPrefs :: Prefs defaultPrefs = Prefs {bellStyle = AudibleBell, maxHistorySize = Just 100, editMode = Emacs, completionType = ListCompletion, completionPaging = True, completionPromptLimit = Just 100, listCompletionsImmediately = True, historyDuplicates = AlwaysAdd, customBindings = Map.empty, customKeySequences = [] } mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs mkSettor f str = maybe id f (readMaybe str) readMaybe :: Read a => String -> Maybe a readMaybe str = case reads str of [(x,_)] -> Just x _ -> Nothing settors :: [(String, String -> Prefs -> Prefs)] settors = [("bellstyle", mkSettor $ \x p -> p {bellStyle = x}) ,("editmode", mkSettor $ \x p -> p {editMode = x}) ,("maxhistorysize", mkSettor $ \x p -> p {maxHistorySize = x}) ,("completiontype", mkSettor $ \x p -> p {completionType = x}) ,("completionpaging", mkSettor $ \x p -> p {completionPaging = x}) ,("completionpromptlimit", mkSettor $ \x p -> p {completionPromptLimit = x}) ,("listcompletionsimmediately", mkSettor $ \x p -> p {listCompletionsImmediately = x}) ,("historyduplicates", mkSettor $ \x p -> p {historyDuplicates = x}) ,("bind", addCustomBinding) ,("keyseq", addCustomKeySequence) ] addCustomBinding :: String -> Prefs -> Prefs addCustomBinding str p = case mapM parseKey (words str) of Just (k:ks) -> p {customBindings = Map.insert k ks (customBindings p)} _ -> p addCustomKeySequence :: String -> Prefs -> Prefs addCustomKeySequence str = maybe id addKS maybeParse where maybeParse :: Maybe (Maybe String, String,Key) maybeParse = case words str of [cstr,kstr] -> parseWords Nothing cstr kstr [term,cstr,kstr] -> parseWords (Just term) cstr kstr _ -> Nothing parseWords mterm cstr kstr = do k <- parseKey kstr cs <- readMaybe cstr return (mterm,cs,k) addKS ks p = p {customKeySequences = ks:customKeySequences p} lookupKeyBinding :: Key -> Prefs -> [Key] lookupKeyBinding k = Map.findWithDefault [k] k . customBindings -- | Read 'Prefs' from a given file. If there is an error reading the file, -- the 'defaultPrefs' will be returned. readPrefs :: FilePath -> IO Prefs readPrefs file = handle (\(_::IOException) -> return defaultPrefs) $ do ls <- fmap lines $ readFile file return $! foldl' applyField defaultPrefs ls where applyField p l = case break (==':') l of (name,val) -> case lookup (map toLower $ trimSpaces name) settors of Nothing -> p Just set -> set (drop 1 val) p -- drop initial ":", don't crash if val=="" trimSpaces = dropWhile isSpace . reverse . dropWhile isSpace . reverse haskeline-0.7.0.3/System/Console/Haskeline/Recover.hs0000644000000000000000000000131712022257741020546 0ustar0000000000000000module 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 } haskeline-0.7.0.3/System/Console/Haskeline/RunCommand.hs0000644000000000000000000001053112022257741021202 0ustar0000000000000000module System.Console.Haskeline.RunCommand (runCommandLoop) where import System.Console.Haskeline.Command import System.Console.Haskeline.Term import System.Console.Haskeline.LineState import System.Console.Haskeline.Monads import System.Console.Haskeline.Prefs import System.Console.Haskeline.Key import Control.Monad runCommandLoop :: (CommandMonad m, MonadState Layout m, LineState s) => TermOps -> String -> KeyCommand m s a -> s -> m a runCommandLoop tops@TermOps{evalTerm = EvalTerm eval liftE} prefix cmds initState = eval $ withGetEvent tops $ runCommandLoop' liftE tops (stringToGraphemes prefix) initState cmds runCommandLoop' :: forall m n s a . (Term n, CommandMonad n, MonadState Layout m, MonadReader Prefs n, 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])) -> n a readMoreKeys s next = do event <- handle (\(e::SomeException) -> moveToNextLine s >> throwIO e) getEvent case event of ErrorEvent e -> moveToNextLine s >> throwIO e WindowResize -> do drawReposition liftE tops s readMoreKeys s next KeyInput ks -> do bound_ks <- mapM (asks . lookupKeyBinding) ks loopCmd s $ applyKeysToMap (concat bound_ks) next 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 -- a large amount of text is pasted in at once. loopCmd s (DoEffect (LineChange _) e@(DoEffect (LineChange _) _)) = loopCmd s e loopCmd s (DoEffect e next) = do t <- drawEffect prefix s e loopCmd t next loopCmd s (CmdM next) = liftE next >>= loopCmd s loopCmd s (Result (x,ks)) = do liftIO (saveUnusedKeys tops ks) moveToNextLine s return x 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 return t drawEffect _ s ClearScreen = do clearLayout drawLine s return s drawEffect _ s (PrintLines ls) = do when (s /= ([],[])) $ moveToNextLine s printLines ls drawLine s return s drawEffect _ s RingBell = actBell >> return s actBell :: (Term m, MonadReader Prefs m) => m () actBell = do style <- asks bellStyle case style of NoBell -> return () VisualBell -> ringBell False AudibleBell -> ringBell True --------------- -- Traverse through the tree of keybindings, using the given keys. -- Remove as many GetKeys as possible. -- Returns any unused keys (so that they can be applied at the next getInputLine). applyKeysToMap :: Monad m => [Key] -> KeyMap (CmdM m (a,[Key])) -> CmdM m (a,[Key]) applyKeysToMap [] next = GetKey next applyKeysToMap (k:ks) next = case lookupKM next k of Nothing -> DoEffect RingBell $ GetKey next Just (Consumed cmd) -> applyKeysToCmd ks cmd Just (NotConsumed cmd) -> applyKeysToCmd (k:ks) cmd applyKeysToCmd :: Monad m => [Key] -> CmdM m (a,[Key]) -> CmdM m (a,[Key]) applyKeysToCmd ks (GetKey next) = applyKeysToMap ks next applyKeysToCmd ks (DoEffect e next) = DoEffect e (applyKeysToCmd ks next) applyKeysToCmd ks (CmdM next) = CmdM $ liftM (applyKeysToCmd ks) next applyKeysToCmd ks (Result (x,ys)) = Result (x,ys++ks) -- use in the next input line haskeline-0.7.0.3/System/Console/Haskeline/Term.hs0000644000000000000000000001620312022257741020050 0ustar0000000000000000module System.Console.Haskeline.Term where import System.Console.Haskeline.Monads import System.Console.Haskeline.LineState import System.Console.Haskeline.Key import System.Console.Haskeline.Prefs(Prefs) import System.Console.Haskeline.Completion(Completion) import Control.Concurrent import Data.Word import Control.Exception (fromException, AsyncException(..),bracket_) import Data.Typeable import System.IO import Control.Monad(liftM,when,guard) import System.IO.Error (isEOFError) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC class (MonadReader Layout m, MonadException m) => Term m where reposition :: Layout -> LineChars -> m () moveToNextLine :: LineChars -> m () printLines :: [String] -> m () drawLineDiff :: LineChars -> LineChars -> m () clearLayout :: m () ringBell :: Bool -> m () drawLine, clearLine :: Term m => LineChars -> m () drawLine = drawLineDiff ([],[]) clearLine = flip drawLineDiff ([],[]) data RunTerm = RunTerm { -- | Write unicode characters to stdout. putStrOut :: String -> IO (), termOps :: Either TermOps FileOps, wrapInterrupt :: forall a . IO a -> IO a, closeTerm :: IO () } -- | Operations needed for terminal-style interaction. data TermOps = TermOps { getLayout :: IO Layout , withGetEvent :: CommandMonad m => (m Event -> m a) -> m a , evalTerm :: forall m . CommandMonad m => EvalTerm m , saveUnusedKeys :: [Key] -> IO () } -- | Operations needed for file-style interaction. -- -- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline -- are "wrapped" by wrapFileInput. data FileOps = FileOps { inputHandle :: Handle, -- ^ e.g. for turning off echoing. wrapFileInput :: forall a . IO a -> IO a, getLocaleLine :: MaybeT IO String, getLocaleChar :: MaybeT IO Char, maybeReadNewline :: IO () } -- | Are we using terminal-style interaction? isTerminalStyle :: RunTerm -> Bool isTerminalStyle r = case termOps r of Left TermOps{} -> True _ -> False -- Specific, hidden terminal action type -- Generic terminal actions which are independent of the Term being used. data EvalTerm m = forall n . (Term n, CommandMonad n) => EvalTerm (forall a . n a -> m a) (forall a . m a -> n a) 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, MonadException m) => CommandMonad m where runCompletion :: (String,String) -> m (String,[Completion]) instance (MonadTrans t, CommandMonad m, MonadReader Prefs (t m), MonadException (t m), MonadReader Layout (t m)) => CommandMonad (t m) where runCompletion = lift . runCompletion -- Utility function for drawLineDiff instances. matchInit :: Eq a => [a] -> [a] -> ([a],[a]) matchInit (x:xs) (y:ys) | x == y = matchInit xs ys matchInit xs ys = (xs,ys) data Event = WindowResize | KeyInput [Key] | ErrorEvent SomeException deriving Show keyEventLoop :: IO [Event] -> Chan 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 if not isEmpty then readChan eventChan else do lock <- newEmptyMVar tid <- forkIO $ handleErrorEvent (readerLoop lock) readChan eventChan `finally` do putMVar lock () killThread tid where readerLoop lock = 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 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 Layout = Layout {width, height :: Int} deriving (Show,Eq) ----------------------------------- -- 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 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 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 = guardedEOF $ liftM (toEnum . fromEnum) . hGetChar 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. hMaybeReadNewline :: Handle -> IO () hMaybeReadNewline h = returnOnEOF () $ do ready <- hReady h when ready $ do c <- hLookAhead h when (c == '\n') $ getChar >> return () returnOnEOF :: MonadException m => a -> m a -> m a returnOnEOF x = handle $ \e -> if isEOFError e then return x else throwIO e -- | Utility function to correctly get a line of input as an undecoded ByteString. hGetLocaleLine :: Handle -> MaybeT IO ByteString hGetLocaleLine = guardedEOF $ \h -> do -- It's more efficient to use B.getLine, but that function throws an -- error if the Handle (e.g., stdin) is set to NoBuffering. buff <- liftIO $ hGetBuffering h liftIO $ if buff == NoBuffering then fmap BC.pack $ System.IO.hGetLine h else BC.hGetLine h haskeline-0.7.0.3/System/Console/Haskeline/Vi.hs0000644000000000000000000004624012022257741017523 0ustar0000000000000000module System.Console.Haskeline.Vi where import System.Console.Haskeline.Command import System.Console.Haskeline.Monads import System.Console.Haskeline.Key import System.Console.Haskeline.Command.Completion import System.Console.Haskeline.Command.History import System.Console.Haskeline.Command.KillRing import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT import Data.Char import Control.Monad(liftM) type EitherMode = Either CommandMode InsertMode type SavedCommand m = Command (ViT m) (ArgMode CommandMode) EitherMode data ViState m = ViState { lastCommand :: SavedCommand m, lastSearch :: [Grapheme] } emptyViState :: Monad m => ViState m emptyViState = ViState { lastCommand = return . Left . argState, lastSearch = [] } type ViT m = StateT (ViState m) (InputCmdT m) type InputCmd s t = forall m . MonadException m => Command (ViT m) s t type InputKeyCmd s t = forall m . MonadException m => KeyCommand (ViT m) s t viKeyCommands :: InputKeyCmd InsertMode (Maybe String) viKeyCommands = choiceCmd [ simpleChar '\n' +> finish , ctrlChar 'd' +> eofIfEmpty , simpleInsertions >+> viCommands , simpleChar '\ESC' +> change enterCommandMode >|> viCommandActions ] viCommands :: InputCmd InsertMode (Maybe String) viCommands = keyCommand viKeyCommands 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') ] insertChars :: InputKeyCmd InsertMode InsertMode insertChars = useChar $ loop [] where 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 -- If we receive a ^D and the line is empty, return Nothing -- otherwise, act like '\n' (mimicing how Readline behaves) eofIfEmpty :: (Monad m, Save s, Result s) => Command m s (Maybe String) eofIfEmpty s | save s == emptyIM = return Nothing | otherwise = finish s viCommandActions :: InputCmd CommandMode (Maybe String) viCommandActions = keyChoiceCmd [ simpleChar '\n' +> finish , ctrlChar 'd' +> eofIfEmpty , simpleCmdActions >+> viCommandActions , exitingCommands >+> viCommands , repeatedCommands >+> chooseEitherMode ] where chooseEitherMode :: InputCmd EitherMode (Maybe String) chooseEitherMode (Left cm) = viCommandActions cm 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) ] 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 -- 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) ] replaceOnce :: InputCmd CommandMode CommandMode replaceOnce = try $ changeFromChar replaceChar repeatedCommands :: InputKeyCmd CommandMode EitherMode repeatedCommands = choiceCmd [argumented, doBefore noArg repeatableCommands] where start = foreachDigit startArg ['1'..'9'] addDigit = foreachDigit addNum ['0'..'9'] argumented = start >+> loop loop = keyChoiceCmd [addDigit >+> loop , repeatableCommands -- if no match, bail out. , withoutConsuming (change argState) >+> return . Left ] pureMovements :: InputKeyCmd (ArgMode CommandMode) CommandMode pureMovements = choiceCmd $ charMovements ++ 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) ] useMovementsForKill :: Command m s t -> (KillHelper -> Command m s t) -> KeyCommand m s t useMovementsForKill alternate useHelper = choiceCmd $ specialCases ++ map (\(k,move) -> k +> 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) ] charMovement c move = simpleChar c +> keyChoiceCmd [ useChar (useHelper . SimpleMove . move) , withoutConsuming alternate] repeatableCommands :: InputKeyCmd (ArgMode CommandMode) EitherMode repeatableCommands = choiceCmd [ repeatableCmdToIMode , repeatableCmdMode >+> return . Left , simpleChar '.' +> saveForUndo >|> runLastCommand ] where runLastCommand s = liftM 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 , pureMovements ] where repeatableChange f = storedCmdAction (saveForUndo >|> change (applyArg f)) flipCase :: CommandMode -> CommandMode flipCase CEmpty = CEmpty flipCase (CMode xs y zs) = CMode xs (modifyBaseChar flipCaseG y) zs where flipCaseG c | isLower c = toUpper c | otherwise = toLower c repeatableCmdToIMode :: InputKeyCmd (ArgMode CommandMode) EitherMode repeatableCmdToIMode = simpleChar 'c' +> deletionToInsertCmd deletionCmd :: InputCmd (ArgMode CommandMode) CommandMode deletionCmd = keyChoiceCmd [ reinputArg >+> deletionCmd , simpleChar 'd' +> killAndStoreCmd killAll , useMovementsForKill (change argState) killAndStoreCmd , withoutConsuming (change argState) ] deletionToInsertCmd :: InputCmd (ArgMode CommandMode) EitherMode deletionToInsertCmd = keyChoiceCmd [ reinputArg >+> deletionToInsertCmd , simpleChar 'c' +> killAndStoreIE 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 , 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 :: LineState s => InputKeyCmd (ArgMode s) (ArgMode s) reinputArg = foreachDigit restartArg ['1'..'9'] >+> loop where restartArg n = startArg n . argState loop = keyChoiceCmd [ foreachDigit addNum ['0'..'9'] >+> loop , withoutConsuming return ] goToWordDelEnd, goToBigWordDelEnd :: InsertMode -> InsertMode goToWordDelEnd = goRightUntil $ atStart (not . isWordChar) .||. atStart (not . isOtherChar) goToBigWordDelEnd = goRightUntil $ atStart (not . isBigWordChar) movements :: [(Key,InsertMode -> InsertMode)] movements = [ (simpleChar 'h', goLeft) , (simpleChar 'l', goRight) , (simpleChar ' ', goRight) , (simpleKey LeftKey, goLeft) , (simpleKey RightKey, goRight) , (simpleChar '0', moveToStart) , (simpleChar '$', moveToEnd) , (simpleChar '^', skipRight isSpace . moveToStart) , (simpleChar '%', findMatchingBrace) ------------------ -- Word movements -- move to the start of the next word , (simpleChar 'w', goRightUntil $ atStart isWordChar .||. atStart isOtherChar) , (simpleChar 'W', goRightUntil (atStart isBigWordChar)) -- move to the beginning of the previous word , (simpleChar 'b', goLeftUntil $ atStart isWordChar .||. atStart isOtherChar) , (simpleChar 'B', goLeftUntil (atStart isBigWordChar)) -- move to the end of the current word , (simpleChar 'e', goRightUntil $ atEnd isWordChar .||. atEnd isOtherChar) , (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 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)) toDigit d = fromEnum d - fromEnum '0' -- This mimics the ctrl-w command in readline's vi mode, which corresponds to -- the tty's werase character. wordErase :: KillHelper wordErase = SimpleMove $ goLeftUntil $ atStart isBigWordChar ------------------ -- Matching braces findMatchingBrace :: InsertMode -> InsertMode findMatchingBrace (IMode xs (y:ys)) | Just b <- matchingRightBrace yc, Just ((b':bs),ys') <- scanBraces yc b ys = IMode (bs++[y]++xs) (b':ys') | Just b <- matchingLeftBrace yc, Just (bs,xs') <- scanBraces yc b xs = IMode xs' (bs ++ [y]++ys) where yc = baseChar y findMatchingBrace im = im deleteMatchingBrace :: InsertMode -> ([Grapheme],InsertMode) deleteMatchingBrace (IMode xs (y:ys)) | Just b <- matchingRightBrace yc, Just (bs,ys') <- scanBraces yc b ys = (y : reverse bs, IMode xs ys') | Just b <- matchingLeftBrace yc, Just (bs,xs') <- scanBraces yc b xs = (bs ++ [y], IMode xs' ys) where yc = baseChar y deleteMatchingBrace im = ([],im) scanBraces :: Char -> Char -> [Grapheme] -> Maybe ([Grapheme],[Grapheme]) scanBraces c d = scanBraces' (1::Int) [] where scanBraces' 0 bs xs = Just (bs,xs) scanBraces' _ _ [] = Nothing scanBraces' n bs (x:xs) = scanBraces' m (x:bs) xs where m | baseChar x == c = n+1 | baseChar x == d = n-1 | otherwise = n matchingRightBrace, matchingLeftBrace :: Char -> Maybe Char matchingRightBrace = flip lookup braceList matchingLeftBrace = flip lookup (map (\(c,d) -> (d,c)) braceList) braceList :: [(Char,Char)] braceList = [('(',')'), ('[',']'), ('{','}')] --------------- -- Replace mode replaceLoop :: InputCmd CommandMode CommandMode replaceLoop = saveForUndo >|> change insertFromCommandMode >|> loop >|> change enterCommandModeRight where loop = try (oneReplaceCmd >+> loop) oneReplaceCmd = choiceCmd [ simpleKey LeftKey +> change goLeft , simpleKey RightKey +> change goRight , changeFromChar replaceCharIM ] --------------------------- -- Saving previous commands storeLastCmd :: Monad m => SavedCommand m -> Command (ViT m) s s storeLastCmd act = \s -> do modify $ \vs -> vs {lastCommand = act} return s storedAction :: Monad m => SavedCommand m -> SavedCommand m 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 storedIAction :: Monad m => Command (ViT m) (ArgMode CommandMode) InsertMode -> Command (ViT m) (ArgMode CommandMode) InsertMode storedIAction act = storeLastCmd (liftM Right . act) >|> act killAndStoreCmd :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode killAndStoreCmd = storedCmdAction . killFromArgHelper killAndStoreI :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) InsertMode killAndStoreI = storedIAction . killFromArgHelper killAndStoreIE :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) EitherMode killAndStoreIE helper = storedAction (killFromArgHelper helper >|> return . Right) noArg :: Monad m => Command m s (ArgMode s) noArg = return . startArg 1 ------------------- -- Vi-style searching data SearchEntry = SearchEntry { entryState :: InsertMode, searchChar :: Char } searchText :: SearchEntry -> [Grapheme] searchText SearchEntry {entryState = IMode xs ys} = reverse xs ++ ys instance LineState SearchEntry where beforeCursor prefix se = beforeCursor (prefix ++ stringToGraphemes [searchChar se]) (entryState se) afterCursor = afterCursor . entryState viEnterSearch :: Monad m => Char -> Direction -> Command (ViT m) CommandMode CommandMode 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 , 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) ] viSearchHist :: forall m . Monad m => Direction -> [Grapheme] -> Command (ViT m) CommandMode CommandMode viSearchHist dir toSearch cm = do vstate :: ViState m <- get let toSearch' = if null toSearch then lastSearch vstate else toSearch result <- doSearch False SearchMode { searchTerm = toSearch', foundHistory = save cm, -- TODO: not needed direction = dir} case result of Left e -> effect e >> setState cm Right sm -> do put vstate {lastSearch = toSearch'} setState (restore (foundHistory sm)) haskeline-0.7.0.3/System/Console/Haskeline/Backend/0000755000000000000000000000000012022257741020132 5ustar0000000000000000haskeline-0.7.0.3/System/Console/Haskeline/Backend/DumbTerm.hs0000644000000000000000000000757612022257741022224 0ustar0000000000000000module System.Console.Haskeline.Backend.DumbTerm where import System.Console.Haskeline.Backend.Posix import System.Console.Haskeline.Backend.Posix.Encoder (putEncodedStr) import System.Console.Haskeline.Backend.WCWidth import System.Console.Haskeline.Term import System.Console.Haskeline.LineState import System.Console.Haskeline.Monads as Monads import System.IO import Control.Monad(liftM) -- TODO: ---- Put "<" and ">" at end of term if scrolls off. ---- Have a margin at the ends data Window = Window {pos :: Int -- ^ # of visible chars to left of cursor } initWindow :: Window initWindow = Window {pos=0} newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a} deriving (Monad, MonadIO, MonadException, MonadState Window, MonadReader Handles, MonadReader Encoder) type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a instance MonadTrans DumbTerm where lift = DumbTerm . lift . 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 = liftIO $ posixRunTerm h (posixLayouts h) [] id evalDumb instance (MonadException m, MonadReader Layout m) => Term (DumbTerm m) where reposition _ s = refitLine s drawLineDiff = drawLineDiff' printLines = mapM_ (printText . (++ crlf)) moveToNextLine _ = printText crlf clearLayout = clearLayoutD ringBell True = printText "\a" ringBell False = return () printText :: MonadIO m => String -> DumbTerm m () printText str = do h <- liftM ehOut ask encode <- ask liftIO $ putEncodedStr encode h str liftIO $ hFlush h -- Things we can assume a dumb terminal knows how to do cr,crlf :: String crlf = "\r\n" cr = "\r" backs,spaces :: Int -> String backs n = replicate n '\b' spaces n = replicate n ' ' clearLayoutD :: DumbTermM () clearLayoutD = do w <- maxWidth printText (cr ++ spaces w ++ cr) -- Don't want to print in the last column, as that may wrap to the next line. maxWidth :: DumbTermM Int maxWidth = asks (\lay -> width lay - 1) drawLineDiff' :: LineChars -> LineChars -> DumbTermM () drawLineDiff' (xs1,ys1) (xs2,ys2) = do Window {pos=p} <- get w <- maxWidth let (xs1',xs2') = matchInit xs1 xs2 let (xw1, xw2) = (gsWidth xs1', gsWidth xs2') let newP = p + xw2 - xw1 let (ys2', yw2) = takeWidth (w-newP) ys2 if xw1 > p || newP >= w then refitLine (xs2,ys2) else do -- we haven't moved outside the margins put Window {pos=newP} case (xs1',xs2') of ([],[]) | ys1 == ys2 -> return () -- no change (_,[]) | xs1' ++ ys1 == ys2 -> -- moved left printText $ backs xw1 ([],_) | ys1 == xs2' ++ ys2 -> -- moved right printText (graphemesToString xs2') _ -> let extraLength = xw1 + snd (takeWidth (w-p) ys1) - xw2 - yw2 in printText $ backs xw1 ++ graphemesToString (xs2' ++ ys2') ++ clearDeadText extraLength ++ backs yw2 refitLine :: ([Grapheme],[Grapheme]) -> DumbTermM () refitLine (xs,ys) = do w <- maxWidth let (xs',p) = dropFrames w xs put Window {pos=p} let (ys',k) = takeWidth (w - p) ys printText $ cr ++ graphemesToString (xs' ++ ys') ++ spaces (w-k-p) ++ backs (w-p) where -- returns the width of the returned characters. dropFrames w zs = case splitAtWidth w zs of (_,[],l) -> (zs,l) (_,zs',_) -> dropFrames w zs' clearDeadText :: Int -> String clearDeadText n | n > 0 = spaces n ++ backs n | otherwise = "" haskeline-0.7.0.3/System/Console/Haskeline/Backend/Posix.hsc0000644000000000000000000003060112022257741021733 0ustar0000000000000000module System.Console.Haskeline.Backend.Posix ( withPosixGetEvent, posixLayouts, tryGetLayouts, PosixT, Handles(), ehIn, ehOut, Encoder, Decoder, mapLines, stdinTTYHandles, ttyHandles, posixRunTerm, fileRunTerm ) where import Foreign import Foreign.C.Types import qualified Data.Map as Map import System.Posix.Terminal hiding (Interrupt) import Control.Monad import Control.Concurrent hiding (throwTo) import Data.Maybe (catMaybes) import System.Posix.Signals.Exts import System.Posix.Types(Fd(..)) import Data.List import System.IO import System.Environment import System.Console.Haskeline.Monads import System.Console.Haskeline.Key import System.Console.Haskeline.Term as Term import System.Console.Haskeline.Prefs import System.Console.Haskeline.Backend.Posix.Encoder #if __GLASGOW_HASKELL__ >= 611 import GHC.IO.FD (fdFD) import Data.Dynamic (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 #include #endif #include ----------------------------------------------- -- Input/output handles 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 posixLayouts :: Handles -> [IO (Maybe Layout)] posixLayouts h = [ioctlLayout $ ehOut h, envLayout] ioctlLayout :: Handle -> IO (Maybe Layout) ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do fd <- unsafeHandleToFD h ret <- ioctl fd (#const TIOCGWINSZ) ws rows :: CUShort <- (#peek struct winsize,ws_row) ws cols :: CUShort <- (#peek struct winsize,ws_col) ws if ret >= 0 then return $ Just Layout {height=fromEnum rows,width=fromEnum cols} else return Nothing unsafeHandleToFD :: Handle -> IO FD #if __GLASGOW_HASKELL__ >= 611 unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h $ \Handle__{haDevice=dev} -> do case cast dev of Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation "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 -- note the handle catches both undefined envs and bad reads r <- getEnv "ROWS" c <- getEnv "COLUMNS" return $ Just $ Layout {height=read r,width=read c} tryGetLayouts :: [IO (Maybe Layout)] -> IO Layout tryGetLayouts [] = return Layout {height=24,width=80} tryGetLayouts (f:fs) = do ml <- f case ml of Just l | height l > 2 && width l > 2 -> return l _ -> tryGetLayouts fs -------------------- -- Key sequences getKeySequences :: (MonadIO m, MonadReader Prefs m) => Handle -> [(String,Key)] -> m (TreeMap Char Key) getKeySequences h tinfos = do sttys <- liftIO $ sttyKeys h customKeySeqs <- getCustomKeySeqs -- note ++ acts as a union; so the below favors sttys over tinfos return $ listToTree $ ansiKeys ++ tinfos ++ sttys ++ customKeySeqs where getCustomKeySeqs = do kseqs <- asks customKeySequences termName <- liftIO $ handle (\(_::IOException) -> return "") (getEnv "TERM") let isThisTerm = maybe True (==termName) return $ map (\(_,cs,k) ->(cs,k)) $ filter (\(kseqs',_,_) -> isThisTerm kseqs') $ kseqs ansiKeys :: [(String, Key)] ansiKeys = [("\ESC[D", simpleKey LeftKey) ,("\ESC[C", simpleKey RightKey) ,("\ESC[A", simpleKey UpKey) ,("\ESC[B", simpleKey DownKey) ,("\b", simpleKey Backspace) -- ctrl-left/right aren't a standard -- part of terminfo, but enough people have complained -- that I've decided to hard-code them in. -- (Note they will be overridden by terminfo or .haskeline.) -- These appear to be the most common bindings: -- xterm: ,("\ESC[1;5D", ctrlKey $ simpleKey LeftKey) ,("\ESC[1;5C", ctrlKey $ simpleKey RightKey) -- Terminal.app: ,("\ESC[5D", ctrlKey $ simpleKey LeftKey) ,("\ESC[5C", ctrlKey $ simpleKey RightKey) -- rxvt: (Note: these will be superceded by e.g. xterm-color, -- which uses them as regular arrow keys.) ,("\ESC[OD", ctrlKey $ simpleKey LeftKey) ,("\ESC[OC", ctrlKey $ simpleKey RightKey) ] sttyKeys :: Handle -> IO [(String, Key)] sttyKeys h = do 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 emptyTreeMap :: TreeMap a b emptyTreeMap = TreeMap Map.empty insertIntoTree :: Ord a => ([a], b) -> TreeMap a b -> TreeMap a b insertIntoTree ([],_) _ = error "Can't insert empty list into a treemap!" insertIntoTree ((c:cs),k) (TreeMap m) = TreeMap (Map.alter f c m) where alterSubtree = insertIntoTree (cs,k) f Nothing = Just $ if null cs then (Just k, emptyTreeMap) else (Nothing, alterSubtree emptyTreeMap) f (Just (y,t)) = Just $ if null cs then (Just k, t) else (y, alterSubtree t) listToTree :: Ord a => [([a],b)] -> TreeMap a b listToTree = foldl' (flip insertIntoTree) emptyTreeMap -- for debugging ' mapLines :: (Show a, Show b) => TreeMap a b -> [String] mapLines (TreeMap m) = let m2 = Map.map (\(k,t) -> show k : mapLines t) m in concatMap (\(k,ls) -> show k : map (' ':) ls) $ Map.toList m2 lexKeys :: TreeMap Char Key -> [Char] -> [Key] lexKeys _ [] = [] lexKeys baseMap cs | Just (k,ds) <- lookupChars baseMap cs = k : lexKeys baseMap ds lexKeys baseMap ('\ESC':cs) -- TODO: what's the right thing ' to do here? | k:ks <- lexKeys baseMap cs = 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) ----------------------------- withPosixGetEvent :: (MonadException m, MonadReader Prefs m) => Chan Event -> Handles -> Decoder -> [(String,Key)] -> (m Event -> m a) -> m a withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do baseMap <- getKeySequences (ehIn h) termKeys withWindowHandler eventChan $ f $ liftIO $ getEvent (ehIn h) enc baseMap eventChan withWindowHandler :: MonadException m => Chan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ Catch $ writeChan eventChan WindowResize withSigIntHandler :: MonadException m => m a -> m a withSigIntHandler f = do tid <- liftIO myThreadId withHandler keyboardSignal (Catch (throwTo tid Interrupt)) f withHandler :: MonadException m => Signal -> Handler -> m a -> m a withHandler signal handler f = do old_handler <- liftIO $ installHandler signal handler Nothing f `finally` liftIO (installHandler signal old_handler Nothing) getEvent :: Handle -> Decoder -> TreeMap Char Key -> Chan Event -> IO Event getEvent h dec baseMap = keyEventLoop $ do cs <- getBlockOfChars h dec return [KeyInput $ lexKeys baseMap cs] stdinTTYHandles, ttyHandles :: MaybeT IO Handles stdinTTYHandles = do isInTerm <- liftIO $ hIsTerminalDevice stdin guard isInTerm h <- openTerm WriteMode -- Don't close stdin, since a different part of the program may use it later. return Handles { hIn = externalHandle stdin , hOut = h , closeHandles = hClose $ eH h } ttyHandles = do -- 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 (eH h_in) >> hClose (eH h_out) } openTerm :: IOMode -> MaybeT IO ExternalHandle openTerm mode = handle (\(_::IOException) -> mzero) $ liftIO $ openInCodingMode "/dev/tty" mode posixRunTerm :: Handles -> [IO (Maybe Layout)] -> [(String,Key)] -> (forall m b . MonadException m => m b -> m b) -> (forall m . (MonadException m, CommandMonad m) => EvalTerm (PosixT m)) -> IO RunTerm posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do ch <- newChan fileRT <- posixFileRunTerm hs (enc,dec) <- newEncoders return fileRT { closeTerm = closeTerm fileRT , termOps = Left TermOps { getLayout = tryGetLayouts layoutGetters , withGetEvent = wrapGetEvent . withPosixGetEvent ch hs dec keys , saveUnusedKeys = saveKeys ch , evalTerm = mapEvalTerm (runPosixT enc hs) (lift . lift) evalBackend } } type PosixT m = ReaderT Encoder (ReaderT Handles m) runPosixT :: Monad m => Encoder -> Handles -> PosixT m a -> m a runPosixT enc h = runReaderT' h . runReaderT' enc fileRunTerm :: Handle -> IO RunTerm fileRunTerm h_in = posixFileRunTerm Handles { hIn = externalHandle h_in , hOut = externalHandle stdout , closeHandles = return () } posixFileRunTerm :: Handles -> IO RunTerm posixFileRunTerm hs = do (enc,dec) <- newEncoders return RunTerm { putStrOut = \str -> withCodingMode (hOut hs) $ do putEncodedStr enc (ehOut hs) str hFlush (ehOut hs) , closeTerm = closeHandles hs , wrapInterrupt = withSigIntHandler , termOps = Right FileOps { inputHandle = ehIn hs , wrapFileInput = withCodingMode (hIn hs) , getLocaleChar = getDecodedChar (ehIn hs) dec , maybeReadNewline = hMaybeReadNewline (ehIn hs) , getLocaleLine = getDecodedLine (ehIn hs) dec } } -- NOTE: If we set stdout to NoBuffering, there can be a flicker effect when many -- characters are printed at once. We'll keep it buffered here, and let the Draw -- monad manually flush outputs that don't print a newline. wrapTerminalOps :: MonadException m => Handles -> m a -> m a wrapTerminalOps 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 . liftIOOp_ (withCodingMode $ hIn hs) . liftIOOp_ (withCodingMode $ hOut hs) where h_in = ehIn hs h_out = ehOut hs haskeline-0.7.0.3/System/Console/Haskeline/Backend/Terminfo.hs0000644000000000000000000003131312022257741022252 0ustar0000000000000000module System.Console.Haskeline.Backend.Terminfo( Draw(), runTerminfoDraw ) where import System.Console.Terminfo import Control.Monad import Data.List(foldl') import System.IO import qualified Control.Exception as Exception import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.IntMap as Map import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.LineState import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.Posix import System.Console.Haskeline.Backend.Posix.Encoder (getTermText) import System.Console.Haskeline.Backend.WCWidth import System.Console.Haskeline.Key import qualified Control.Monad.Trans.Writer as Writer ---------------------------------------------------------------- -- Low-level terminal output -- | Keep track of all of the output capabilities we can use. -- -- We'll be frequently using the (automatic) 'Monoid' instance for -- @Actions -> TermOutput@. data Actions = Actions {leftA, rightA, upA :: Int -> TermOutput, clearToLineEnd :: TermOutput, nl, cr :: TermOutput, bellAudible,bellVisual :: TermOutput, clearAllA :: LinesAffected -> TermOutput, wrapLine :: TermOutput} getActions :: Capability Actions getActions = do -- This capability is not strictly necessary, but is very widely supported -- and assuming it makes for a much simpler implementation of printText. autoRightMargin >>= guard leftA' <- moveLeft rightA' <- moveRight upA' <- moveUp clearToLineEnd' <- clearEOL clearAll' <- clearScreen nl' <- newline cr' <- carriageReturn -- Don't require the bell capabilities bellAudible' <- bell `mplus` return mempty bellVisual' <- visualBell `mplus` return mempty wrapLine' <- getWrapLine (leftA' 1) return Actions{leftA = leftA', rightA = rightA',upA = upA', clearToLineEnd = clearToLineEnd', nl = nl',cr = cr', bellAudible = bellAudible', bellVisual = bellVisual', clearAllA = clearAll', wrapLine = wrapLine'} -- If the wraparound glitch is in effect, force a wrap by printing a space. -- Otherwise, it'll wrap automatically. getWrapLine :: TermOutput -> Capability TermOutput getWrapLine left1 = (do wraparoundGlitch >>= guard return (termText " " <#> left1) ) `mplus` return mempty ---------------------------------------------------------------- -- The Draw monad -- denote in modular arithmetic; -- in particular, 0 <= termCol < width data TermPos = TermPos {termRow,termCol :: !Int} deriving Show initTermPos :: TermPos initTermPos = TermPos {termRow = 0, termCol = 0} data TermRows = TermRows { rowLengths :: !(Map.IntMap Int), -- ^ The length of each nonempty row lastRow :: !Int -- ^ The last nonempty row, or zero if the entire line -- is empty. Note that when the cursor wraps to the first -- column of the next line, termRow > lastRow. } deriving Show initTermRows :: TermRows initTermRows = TermRows {rowLengths = Map.empty, lastRow=0} setRow :: Int -> Int -> TermRows -> TermRows setRow r len rs = TermRows {rowLengths = Map.insert r len (rowLengths rs), lastRow=r} lookupCells :: TermRows -> Int -> Int lookupCells (TermRows rc _) r = Map.findWithDefault 0 r rc newtype Draw m a = Draw {unDraw :: (ReaderT Actions (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))) a} deriving (Monad, MonadIO, MonadException, MonadReader Actions, MonadReader Terminal, MonadState TermPos, MonadState TermRows, MonadReader Handles, MonadReader Encoder) instance MonadTrans Draw where lift = Draw . lift . 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 :: Handles -> MaybeT IO RunTerm runTerminfoDraw h = do mterm <- liftIO $ Exception.try setupTermFromEnv case mterm of Left (_::SetupTermError) -> mzero Right term -> do actions <- MaybeT $ return $ getCapability term getActions 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 h term f = (maybeOutput keypadOn >> f) `finally` maybeOutput keypadOff where maybeOutput = liftIO . hRunTermOutput h term . fromMaybe mempty . getCapability term tinfoLayout :: Terminal -> IO (Maybe Layout) tinfoLayout term = return $ getCapability term $ do c <- termColumns r <- termLines return Layout {height=r,width=c} terminfoKeys :: Terminal -> [(String,Key)] terminfoKeys term = mapMaybe getSequence keyCapabilities where getSequence (cap,x) = do keys <- getCapability term cap return (keys,x) keyCapabilities = [(keyLeft, simpleKey LeftKey) ,(keyRight, simpleKey RightKey) ,(keyUp, simpleKey UpKey) ,(keyDown, simpleKey DownKey) ,(keyBackspace, simpleKey Backspace) ,(keyDeleteChar, simpleKey Delete) ,(keyHome, simpleKey Home) ,(keyEnd, simpleKey End) ,(keyPageDown, simpleKey PageDown) ,(keyPageUp, simpleKey PageUp) ,(keyEnter, simpleKey $ KeyChar '\n') ] ---------------------------------------------------------------- -- Terminal output actions -- -- We combine all of the drawing commands into one big TermAction, -- via a writer monad, and then output them all at once. -- This prevents flicker, i.e., the cursor appearing briefly -- in an intermediate position. type TermAction = Actions -> TermOutput type ActionT = Writer.WriterT TermAction type ActionM a = forall m . (MonadReader Layout m, MonadIO m) => ActionT (Draw m) a runActionT :: MonadIO m => ActionT (Draw m) a -> Draw m a runActionT m = do (x,action) <- Writer.runWriterT m toutput <- asks action term <- ask ttyh <- liftM ehOut ask liftIO $ hRunTermOutput ttyh term toutput return x output :: TermAction -> ActionM () output = Writer.tell outputText :: String -> ActionM () outputText str = do encode <- lift ask liftIO (getTermText encode str) >>= output . const left,right,up :: Int -> TermAction left = flip leftA right = flip rightA up = flip upA clearAll :: LinesAffected -> TermAction clearAll = flip clearAllA mreplicate :: Monoid m => Int -> m -> m mreplicate n m | n <= 0 = mempty | otherwise = m `mappend` mreplicate (n-1) m -- We don't need to bother encoding the spaces. spaces :: Int -> TermAction spaces 0 = mempty spaces 1 = const $ termText " " -- share when possible spaces n = const $ termText $ replicate n ' ' changePos :: TermPos -> TermPos -> TermAction changePos TermPos {termRow=r1, termCol=c1} TermPos {termRow=r2, termCol=c2} | r1 == r2 = if c1 < c2 then right (c2-c1) else left (c1-c2) | r1 > r2 = cr <#> up (r1-r2) <#> right c2 | otherwise = cr <#> mreplicate (r2-r1) nl <#> right c2 moveToPos :: TermPos -> ActionM () moveToPos p = do oldP <- get put p output $ changePos oldP p moveRelative :: Int -> ActionM () moveRelative n = liftM3 (advancePos n) ask get get >>= moveToPos -- Note that these move by a certain number of cells, not graphemes. changeRight, changeLeft :: Int -> ActionM () changeRight n | n <= 0 = return () | otherwise = moveRelative n changeLeft n | n <= 0 = return () | otherwise = moveRelative (negate n) -- TODO: this could be more efficient by only checking intermediate rows. -- TODO: this is worth handling with QuickCheck. advancePos :: Int -> Layout -> TermRows -> TermPos -> TermPos advancePos k Layout {width=w} rs p = indexToPos $ k + posIndex where posIndex = termCol p + sum' (map (lookupCells rs) [0..termRow p-1]) indexToPos n = loopFindRow 0 n loopFindRow r m = r `seq` m `seq` let thisRowSize = lookupCells rs r in if m < thisRowSize || (m == thisRowSize && m < w) || thisRowSize <= 0 -- This shouldn't happen in practice, -- but double-check to prevent an infinite loop then TermPos {termRow=r, termCol=m} else loopFindRow (r+1) (m-thisRowSize) sum' :: [Int] -> Int sum' = foldl' (+) 0 ---------------------------------------------------------------- -- Text printing actions printText :: [Grapheme] -> ActionM () printText [] = return () printText gs = do -- First, get the monadic parameters: w <- asks width TermPos {termRow=r, termCol=c} <- get -- Now, split off as much as will fit on the rest of this row: let (thisLine,rest,thisWidth) = splitAtWidth (w-c) gs let lineWidth = c + thisWidth -- Finally, actually print out the relevant text. outputText (graphemesToString thisLine) modify $ setRow r lineWidth if null rest && lineWidth < w then -- everything fits on one line without wrapping put TermPos {termRow=r, termCol=lineWidth} else do -- Must wrap to the next line put TermPos {termRow=r+1,termCol=0} output $ if lineWidth == w then wrapLine else spaces (w-lineWidth) printText rest ---------------------------------------------------------------- -- High-level Term implementation drawLineDiffT :: LineChars -> LineChars -> ActionM () drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of ([],[]) | ys1 == ys2 -> return () (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (gsWidth xs1') ([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (gsWidth xs2') (xs1',xs2') -> do oldRS <- get changeLeft (gsWidth xs1') printText xs2' p <- get printText ys2 clearDeadText oldRS moveToPos p -- The number of nonempty lines after the current row position. getLinesLeft :: ActionM Int getLinesLeft = do p <- get rc <- get return $ max 0 (lastRow rc - termRow p) clearDeadText :: TermRows -> ActionM () clearDeadText oldRS = do TermPos {termRow = r, termCol = c} <- get let extraRows = lastRow oldRS - r if extraRows < 0 || (extraRows == 0 && lookupCells oldRS r <= c) then return () else do modify $ setRow r c when (extraRows /= 0) $ put TermPos {termRow = r + extraRows, termCol=0} output $ clearToLineEnd <#> mreplicate extraRows (nl <#> clearToLineEnd) clearLayoutT :: ActionM () clearLayoutT = do h <- asks height output (clearAll h) put initTermPos moveToNextLineT :: ActionM () moveToNextLineT = do lleft <- getLinesLeft output $ mreplicate (lleft+1) nl put initTermPos put initTermRows repositionT :: Layout -> LineChars -> ActionM () repositionT _ s = do oldPos <- get l <- getLinesLeft output $ cr <#> mreplicate l nl <#> mreplicate (l + termRow oldPos) (clearToLineEnd <#> up 1) put initTermPos put initTermRows drawLineDiffT ([],[]) s instance (MonadException m, MonadReader Layout m) => Term (Draw m) where drawLineDiff xs ys = runActionT $ drawLineDiffT xs ys reposition layout lc = runActionT $ repositionT layout lc printLines = mapM_ $ \line -> runActionT $ do outputText line output nl clearLayout = runActionT clearLayoutT moveToNextLine _ = runActionT moveToNextLineT ringBell True = runActionT $ output bellAudible ringBell False = runActionT $ output bellVisual haskeline-0.7.0.3/System/Console/Haskeline/Backend/WCWidth.hs0000644000000000000000000000340212022257741021776 0ustar0000000000000000module System.Console.Haskeline.Backend.WCWidth( gsWidth, splitAtWidth, takeWidth, ) where -- Certain characters are "wide", i.e. take up two spaces in the terminal. -- This module wraps the necessary foreign routines, and also provides some convenience -- functions for width-breaking code. import System.Console.Haskeline.LineState import Data.List import Foreign.C.Types foreign import ccall unsafe haskeline_mk_wcwidth :: CWchar -> CInt wcwidth :: Char -> Int wcwidth c = case haskeline_mk_wcwidth $ toEnum $ fromEnum c of -1 -> 0 -- Control characters have zero width. (Used by the -- "\SOH...\STX" hack in LineState.stringToGraphemes.) w -> fromIntegral w gWidth :: Grapheme -> Int gWidth g = wcwidth (baseChar g) gsWidth :: [Grapheme] -> Int gsWidth = foldl' (+) 0 . map gWidth -- | Split off the maximal list which is no more than the given width. -- returns the width of that list. splitAtWidth :: Int -> [Grapheme] -> ([Grapheme],[Grapheme],Int) splitAtWidth n xs = case splitAtWidth' n xs of (this,rest,remaining) -> (this,rest,n-remaining) -- Returns the amount of unused space in the line. splitAtWidth' :: Int -> [Grapheme] -> ([Grapheme],[Grapheme],Int) splitAtWidth' w [] = ([],[],w) splitAtWidth' w (g:gs) | gw > w = ([],g:gs,w) | otherwise = (g:gs',gs'',r) where gw = gWidth g (gs',gs'',r) = splitAtWidth' (w-gw) gs -- Returns the longest prefix less than or equal to the given width -- plus the width of that list. takeWidth :: Int -> [Grapheme] -> ([Grapheme],Int) takeWidth n gs = case splitAtWidth n gs of (gs',_,len) -> (gs',len) haskeline-0.7.0.3/System/Console/Haskeline/Backend/Win32.hsc0000644000000000000000000005261512022257741021544 0ustar0000000000000000module 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 import System.Console.Haskeline.Backend.WCWidth import Data.ByteString.Internal (createAndTrim) import qualified Data.ByteString as B ##if defined(i386_HOST_ARCH) ## define WINDOWS_CCONV stdcall ##elif defined(x86_64_HOST_ARCH) ## define WINDOWS_CCONV ccall ##else ## error Unknown mingw32 arch ##endif #include "win_console.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 -> 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 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' = withArray (map (toEnum . fromEnum) xs) $ \t_arr -> alloca $ \numWritten -> do failIfFalse_ "WriteConsoleW" $ c_WriteConsoleW h t_arr (toEnum $ length xs) numWritten nullPtr foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool messageBeep :: IO () messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures. ---------- -- 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 :: 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 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 (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 = 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 newChan 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) }, 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, wrapInterrupt = withCtrlCHandler, termOps = Right FileOps { inputHandle = h_in , wrapFileInput = hWithBinaryMode h_in , getLocaleChar = getMultiByteChar cp h_in , maybeReadNewline = hMaybeReadNewline h_in , getLocaleLine = hGetLocaleLine h_in >>= liftIO . codePageToUnicode cp } } -- 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 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 haskeline-0.7.0.3/System/Console/Haskeline/Backend/Posix/0000755000000000000000000000000012022257741021234 5ustar0000000000000000haskeline-0.7.0.3/System/Console/Haskeline/Backend/Posix/Encoder.hs0000644000000000000000000001425412022257741023155 0ustar0000000000000000{- | This module provides a wrapper for I/O encoding for the "old" and "new" ways. The "old" way uses iconv+utf8-string. The "new" way uses the base library's built-in encoding functionality. For the "new" way, we require ghc>=7.4.1 due to GHC bug #5436. This module exports opaque Encoder/Decoder datatypes, along with several helper functions that wrap the old/new ways. -} module System.Console.Haskeline.Backend.Posix.Encoder ( Encoder, Decoder, newEncoders, ExternalHandle(eH), externalHandle, withCodingMode, openInCodingMode, putEncodedStr, #ifdef TERMINFO getTermText, #endif getBlockOfChars, getDecodedChar, getDecodedLine, ) where import System.IO import System.Console.Haskeline.Monads import System.Console.Haskeline.Term #ifdef TERMINFO import qualified System.Console.Terminfo.Base as Terminfo #endif -- Way-dependent imports #ifdef USE_GHC_ENCODINGS import GHC.IO.Encoding (initLocaleEncoding) import System.Console.Haskeline.Recover #else import System.Console.Haskeline.Backend.Posix.IConv import Data.ByteString (ByteString) import qualified Data.ByteString as B #ifdef TERMINFO import qualified Data.ByteString.Char8 as BC #endif import Control.Monad (liftM2) #endif #ifdef USE_GHC_ENCODINGS data Encoder = Encoder data Decoder = Decoder #else type Decoder = PartialDecoder type Encoder = String -> IO ByteString #endif newEncoders :: IO (Encoder,Decoder) #ifdef USE_GHC_ENCODINGS newEncoders = return (Encoder,Decoder) #else newEncoders = do codeset <- bracket (setLocale (Just "")) setLocale $ const $ getCodeset liftM2 (,) (openEncoder codeset) (openPartialDecoder codeset) #endif -- | An 'ExternalHandle' is a handle which may or may not be in the correct -- mode for Unicode input/output. When the POSIX backend opens a file -- (or /dev/tty) it sets it permanently to the correct mode. -- However, when it uses an existing handle like stdin, it only temporarily -- sets it to the correct mode (e.g., for the duration of getInputLine); -- otherwise, we might interfere with the rest of the Haskell program. -- -- For the legacy backend, the correct mode is BinaryMode. -- For the new backend, the correct mode is the locale encoding, set to -- transliterate errors (rather than crashing, as is the base library's -- default.) (See Posix/Recover.hs) data ExternalHandle = ExternalHandle { externalMode :: ExternalMode , eH :: Handle } data ExternalMode = CodingMode | OtherMode externalHandle :: Handle -> ExternalHandle externalHandle = ExternalHandle OtherMode -- | Use to ensure that an external handle is in the correct mode -- for the duration of the given action. withCodingMode :: ExternalHandle -> IO a -> IO a withCodingMode ExternalHandle {externalMode=CodingMode} act = act #ifdef USE_GHC_ENCODINGS withCodingMode (ExternalHandle OtherMode h) act = do bracket (liftIO $ hGetEncoding h) (liftIO . hSetBinOrEncoding h) $ const $ do hSetEncoding h haskelineEncoding act hSetBinOrEncoding :: Handle -> Maybe TextEncoding -> IO () hSetBinOrEncoding h Nothing = hSetBinaryMode h True hSetBinOrEncoding h (Just enc) = hSetEncoding h enc #else withCodingMode (ExternalHandle OtherMode h) act = hWithBinaryMode h act #endif #ifdef USE_GHC_ENCODINGS haskelineEncoding :: TextEncoding haskelineEncoding = transliterateFailure initLocaleEncoding #endif -- Open a file and permanently set it to the correct mode. openInCodingMode :: FilePath -> IOMode -> IO ExternalHandle #ifdef USE_GHC_ENCODINGS openInCodingMode path iomode = do h <- openFile path iomode hSetEncoding h haskelineEncoding return $ ExternalHandle CodingMode h #else openInCodingMode path iomode = fmap (ExternalHandle CodingMode) $ openBinaryFile path iomode #endif ----------------------- -- Output putEncodedStr :: Encoder -> Handle -> String -> IO () #ifdef USE_GHC_ENCODINGS putEncodedStr _ h = hPutStr h #else putEncodedStr enc h s = enc s >>= B.hPutStr h #endif #ifdef TERMINFO getTermText :: Encoder -> String -> IO Terminfo.TermOutput #ifdef USE_GHC_ENCODINGS getTermText _ = return . Terminfo.termText #else getTermText enc s = enc s >>= return . Terminfo.termText . BC.unpack #endif #endif -- Read at least one character of input, and more if immediately -- available. In particular the characters making up a control sequence -- will all be available at once, so they can be processed together -- (with Posix.lexKeys). getBlockOfChars :: Handle -> Decoder -> IO String #ifdef USE_GHC_ENCODINGS getBlockOfChars h _ = do c <- hGetChar h loop [c] where loop cs = do isReady <- hReady h if not isReady then return $ reverse cs else do c <- hGetChar h loop (c:cs) #else getBlockOfChars h decode = do let bufferSize = 32 blockUntilInput h bs <- B.hGetNonBlocking h bufferSize decodeAndMore decode h bs #endif -- Read in a single character, or Nothing if eof. -- Assumes the handle is "prepared". getDecodedChar :: Handle -> Decoder -> MaybeT IO Char #ifdef USE_GHC_ENCODINGS getDecodedChar h _ = guardedEOF hGetChar h #else getDecodedChar h decode = do b <- hGetByte h cs <- liftIO $ decodeAndMore decode h (B.pack [b]) case cs of [] -> return '?' -- shouldn't happen, but doesn't hurt to be careful. (c:_) -> return c #endif -- Read in a single line, or Nothing if eof. getDecodedLine :: Handle -> Decoder -> MaybeT IO String #ifdef USE_GHC_ENCODINGS getDecodedLine h _ = guardedEOF hGetLine h #else getDecodedLine h decode = hGetLocaleLine h >>= liftIO . decodeAndMore decode h #endif -- Helper functions for iconv encoding #ifndef USE_GHC_ENCODINGS blockUntilInput :: Handle -> IO () #if __GLASGOW_HASKELL__ >= 611 -- threadWaitRead doesn't work with the new (ghc-6.12) IO library, -- because it keeps a buffer even when NoBuffering is set. blockUntilInput h = hWaitForInput h (-1) >> return () #else -- hWaitForInput doesn't work with -threaded on ghc < 6.10 -- (#2363 in ghc's trac) blockUntilInput h = unsafeHandleToFD h >>= threadWaitRead . Fd #endif #endif haskeline-0.7.0.3/System/Console/Haskeline/Backend/Posix/IConv.hsc0000644000000000000000000001504312022257741022754 0ustar0000000000000000{- | This module exports iconv-based encoding/decoding, for use on older versions of GHC. -} module System.Console.Haskeline.Backend.Posix.IConv( setLocale, getCodeset, openEncoder, openDecoder, openPartialDecoder, PartialDecoder, decodeAndMore, ) where import Foreign.C import Foreign import Data.ByteString (ByteString, useAsCStringLen, append ) -- TODO: Base or Internal, depending on whether base>=3. import Data.ByteString.Internal (createAndTrim') import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 import Data.Maybe (fromMaybe) import System.IO (Handle) #include #include #include "h_iconv.h" openEncoder :: String -> IO (String -> IO ByteString) openEncoder codeset = do encodeT <- iconvOpen codeset "UTF-8" return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString openDecoder :: String -> IO (ByteString -> IO String) openDecoder codeset = do decodeT <- iconvOpen "UTF-8" codeset return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT dropUTF8Char :: ByteString -> ByteString dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons replacement :: Word8 replacement = toEnum (fromEnum '?') -- handle errors by dropping unuseable chars. simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString simpleIConv dropper t bs = do (cs,result) <- iconv t bs case result of Invalid rest -> continueOnError cs rest Incomplete rest -> continueOnError cs rest _ -> return cs where continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`)) $ simpleIConv dropper t (dropper rest) type PartialDecoder = ByteString -> IO (String,Result) openPartialDecoder :: String -> IO PartialDecoder 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) ------------- -- Decode the given ByteString. If necessary, finish decoding it -- by reading more bytes one at a time from the given handle. -- (This assumes that the handle is in BinaryMode.) decodeAndMore:: PartialDecoder -> Handle -> B.ByteString -> IO String decodeAndMore decoder h bs = do (cs,result) <- decoder bs case result of Incomplete rest -> do extra <- B.hGetNonBlocking h 1 if B.null extra then return (cs ++ "?") else fmap (cs++) $ decodeAndMore decoder h (rest `B.append` extra) Invalid rest -> fmap ((cs ++) . ('?':)) $ decodeAndMore decoder h (B.drop 1 rest) Successful -> return cs haskeline-0.7.0.3/System/Console/Haskeline/Command/0000755000000000000000000000000012022257741020161 5ustar0000000000000000haskeline-0.7.0.3/System/Console/Haskeline/Command/Completion.hs0000644000000000000000000001417412022257741022635 0ustar0000000000000000module System.Console.Haskeline.Command.Completion( CompletionFunc, Completion, CompletionType(..), completionCmd ) where import System.Console.Haskeline.Command import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.Key import System.Console.Haskeline.Term (Layout(..), CommandMonad(..)) import System.Console.Haskeline.LineState import System.Console.Haskeline.Prefs import System.Console.Haskeline.Completion import System.Console.Haskeline.Monads import Data.List(transpose, unfoldr) useCompletion :: InsertMode -> Completion -> InsertMode useCompletion im c = insertString r im where r | isFinished c = replacement c ++ " " | otherwise = replacement c askIMCompletions :: CommandMonad m => Command m InsertMode (InsertMode, [Completion]) askIMCompletions (IMode xs ys) = do (rest, completions) <- lift $ runCompletion (withRev graphemesToString xs, graphemesToString ys) return (IMode (withRev stringToGraphemes rest) ys, completions) where withRev :: ([a] -> [b]) -> [a] -> [b] withRev f = reverse . f . reverse -- | Create a 'Command' for word completion. completionCmd :: (MonadState Undo m, CommandMonad m) => Key -> KeyCommand m InsertMode InsertMode completionCmd k = k +> saveForUndo >|> \oldIM -> do (rest,cs) <- askIMCompletions oldIM case cs of [] -> effect RingBell >> return oldIM [c] -> setState $ useCompletion rest c _ -> presentCompletions k oldIM rest cs presentCompletions :: (MonadReader Prefs m, MonadReader Layout m) => Key -> InsertMode -> InsertMode -> [Completion] -> CmdM m InsertMode presentCompletions k oldIM rest cs = do prefs <- ask case completionType prefs of MenuCompletion -> menuCompletion k (map (useCompletion rest) cs) oldIM ListCompletion -> do withPartial <- setState $ makePartialCompletion rest cs if withPartial /= oldIM then return withPartial else pagingCompletion k prefs cs withPartial menuCompletion :: Monad m => Key -> [InsertMode] -> Command m InsertMode InsertMode menuCompletion k = loop where loop [] = setState loop (c:cs) = change (const c) >|> try (k +> loop cs) makePartialCompletion :: InsertMode -> [Completion] -> InsertMode makePartialCompletion im completions = insertString partial im where partial = foldl1 commonPrefix (map replacement completions) commonPrefix (c:cs) (d:ds) | c == d = c : commonPrefix cs ds commonPrefix _ _ = "" pagingCompletion :: MonadReader Layout m => Key -> Prefs -> [Completion] -> Command m InsertMode InsertMode pagingCompletion k prefs completions = \im -> do ls <- asks $ makeLines (map display completions) let pageAction = do askFirst prefs (length completions) $ if completionPaging prefs then printPage ls else effect (PrintLines ls) setState im if listCompletionsImmediately prefs then pageAction else effect RingBell >> try (k +> const pageAction) im askFirst :: Monad m => Prefs -> Int -> CmdM m () -> CmdM m () askFirst prefs n cmd | maybe False (< n) (completionPromptLimit prefs) = do _ <- setState (Message () $ "Display all " ++ show n ++ " possibilities? (y or n)") keyChoiceCmdM [ simpleChar 'y' +> cmd , simpleChar 'n' +> return () ] | otherwise = cmd pageCompletions :: MonadReader Layout m => [String] -> CmdM m () pageCompletions [] = return () pageCompletions wws@(w:ws) = do _ <- setState $ Message () "----More----" keyChoiceCmdM [ simpleChar '\n' +> oneLine , simpleKey DownKey +> oneLine , simpleChar 'q' +> return () , simpleChar ' ' +> (clearMessage >> printPage wws) ] where oneLine = clearMessage >> effect (PrintLines [w]) >> pageCompletions ws clearMessage = effect $ LineChange $ const ([],[]) printPage :: MonadReader Layout m => [String] -> CmdM m () printPage ls = do layout <- ask let (ps,rest) = splitAt (height layout - 1) ls effect $ PrintLines ps pageCompletions rest ----------------------------------------------- -- Splitting the list of completions into lines for paging. makeLines :: [String] -> Layout -> [String] 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 then map (: []) ws else splitIntoGroups numCols ws in map (padWords maxLength) 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 -- 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 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 -- Split xs into rows of length n, -- such that the list increases incrementally along the columns. -- e.g.: splitIntoGroups 4 [1..11] == -- [[1,4,7,10] -- ,[2,5,8,11] -- ,[3,6,9]] splitIntoGroups :: Int -> [a] -> [[a]] splitIntoGroups n xs = transpose $ unfoldr f xs where f [] = Nothing f ys = Just (splitAt k ys) k = ceilDiv (length xs) n -- ceilDiv m n is the smallest k such that k * n >= m. ceilDiv :: Integral a => a -> a -> a ceilDiv m n | m `rem` n == 0 = m `div` n | otherwise = m `div` n + 1 haskeline-0.7.0.3/System/Console/Haskeline/Command/History.hs0000644000000000000000000002000012022257741022146 0ustar0000000000000000module System.Console.Haskeline.Command.History where import System.Console.Haskeline.LineState import System.Console.Haskeline.Command import System.Console.Haskeline.Key import Control.Monad(liftM,mplus) import System.Console.Haskeline.Monads import Data.List import Data.Maybe(fromMaybe) import System.Console.Haskeline.History import Data.IORef data HistLog = HistLog {pastHistory, futureHistory :: [[Grapheme]]} deriving Show prevHistoryM :: [Grapheme] -> HistLog -> Maybe ([Grapheme],HistLog) prevHistoryM _ HistLog {pastHistory = []} = Nothing prevHistoryM s HistLog {pastHistory=ls:past, futureHistory=future} = Just (ls, HistLog {pastHistory=past, futureHistory= s:future}) prevHistories :: [Grapheme] -> HistLog -> [([Grapheme],HistLog)] prevHistories s h = flip unfoldr (s,h) $ \(s',h') -> fmap (\r -> (r,r)) $ prevHistoryM s' h' histLog :: History -> HistLog histLog hist = HistLog {pastHistory = map stringToGraphemes $ historyLines hist, futureHistory = []} runHistoryFromFile :: MonadException 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 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 prevHistory, firstHistory :: Save s => s -> HistLog -> (s, HistLog) prevHistory s h = let (s',h') = fromMaybe (listSave s,h) $ prevHistoryM (listSave s) h in (listRestore s',h') firstHistory s h = let prevs = (listSave s,h):prevHistories (listSave s) h -- above makes sure we don't take the last of an empty list. (s',h') = last prevs in (listRestore s',h') historyBack, historyForward :: (Save s, MonadState HistLog m) => Command m s s historyBack = simpleCommand $ histUpdate prevHistory historyForward = simpleCommand $ reverseHist . histUpdate prevHistory historyStart, historyEnd :: (Save s, MonadState HistLog m) => Command m s s historyStart = simpleCommand $ histUpdate firstHistory historyEnd = simpleCommand $ reverseHist . histUpdate firstHistory histUpdate :: MonadState HistLog m => (s -> HistLog -> (t,HistLog)) -> s -> m (Either Effect t) histUpdate f = liftM Right . update . f reverseHist :: MonadState HistLog m => m b -> m b reverseHist f = do modify reverser y <- f modify reverser return y where reverser h = HistLog {futureHistory=pastHistory h, pastHistory=futureHistory h} data SearchMode = SearchMode {searchTerm :: [Grapheme], foundHistory :: InsertMode, direction :: Direction} deriving Show data Direction = Forward | Reverse deriving (Show,Eq) directionName :: Direction -> String directionName Forward = "i-search" directionName Reverse = "reverse-i-search" instance LineState SearchMode where beforeCursor _ sm = beforeCursor prefix (foundHistory sm) where prefix = stringToGraphemes ("(" ++ directionName (direction sm) ++ ")`") ++ searchTerm sm ++ stringToGraphemes "': " afterCursor = afterCursor . foundHistory instance Result SearchMode where toResult = toResult . foundHistory saveSM :: SearchMode -> [Grapheme] saveSM = listSave . foundHistory startSearchMode :: Direction -> InsertMode -> SearchMode startSearchMode dir im = SearchMode {searchTerm = [],foundHistory=im, direction=dir} addChar :: Char -> SearchMode -> SearchMode 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 im <- findInLine text l return (SearchMode text im dir,h) findInLine :: [Grapheme] -> [Grapheme] -> Maybe InsertMode findInLine text l = find' [] l where find' _ [] = Nothing find' prev ccs@(c:cs) | text `isPrefixOf` ccs = Just (IMode prev ccs) | otherwise = find' (c:prev) cs prepSearch :: SearchMode -> HistLog -> ([Grapheme],[([Grapheme],HistLog)]) prepSearch sm h = let text = searchTerm sm l = saveSM sm in (text,prevHistories l h) searchBackwards :: Bool -> SearchMode -> HistLog -> Maybe (SearchMode, HistLog) searchBackwards useCurrent s h = let (text,hists) = prepSearch s h hists' = if useCurrent then (saveSM s,h):hists else hists in searchHistories (direction s) text hists' doSearch :: MonadState HistLog m => Bool -> SearchMode -> m (Either Effect SearchMode) doSearch useCurrent sm = case direction sm of Reverse -> searchHist Forward -> reverseHist searchHist where searchHist = do hist <- get case searchBackwards useCurrent sm hist of Just (sm',hist') -> put hist' >> return (Right sm') Nothing -> return $ Left RingBell searchHistory :: MonadState HistLog m => KeyCommand m InsertMode InsertMode searchHistory = choiceCmd [ metaChar 'j' +> searchForPrefix Forward , metaChar 'k' +> searchForPrefix Reverse , choiceCmd [ backKey +> change (startSearchMode Reverse) , forwardKey +> change (startSearchMode Forward) ] >+> keepSearching ] where backKey = ctrlChar 'r' forwardKey = ctrlChar 's' keepSearching = keyChoiceCmd [ choiceCmd [ charCommand oneMoreChar , backKey +> simpleCommand (searchMore Reverse) , forwardKey +> simpleCommand (searchMore Forward) , simpleKey Backspace +> change delLastChar ] >+> keepSearching , withoutConsuming (change foundHistory) -- abort ] delLastChar s = s {searchTerm = minit (searchTerm s)} minit xs = if null xs then [] else init xs oneMoreChar c = doSearch True . addChar c searchMore d s = doSearch False s {direction=d} searchForPrefix :: MonadState HistLog m => Direction -> Command m InsertMode InsertMode searchForPrefix dir s@(IMode xs _) = do next <- findFirst prefixed dir s maybe (return s) setState next where prefixed gs = if rxs `isPrefixOf` gs then Just $ IMode xs (drop (length xs) gs) else Nothing rxs = reverse xs -- Search for the first entry in the history which satisfies the constraint. -- If it succeeds, the HistLog is updated and the result is returned. -- If it fails, the HistLog is unchanged. -- TODO: make the other history searching functions use this instead. findFirst :: forall s m . (Save s, MonadState HistLog m) => ([Grapheme] -> Maybe s) -> Direction -> s -> m (Maybe s) findFirst cond Forward s = reverseHist $ findFirst cond Reverse s findFirst cond Reverse s = do hist <- get case search (prevHistories (listSave s) hist) of Nothing -> return Nothing Just (s',hist') -> put hist' >> return (Just s') where search :: [([Grapheme],HistLog)] -> Maybe (s,HistLog) search [] = Nothing search ((g,h):gs) = case cond g of Nothing -> search gs Just s' -> Just (s',h) haskeline-0.7.0.3/System/Console/Haskeline/Command/KillRing.hs0000644000000000000000000000617412022257741022240 0ustar0000000000000000module System.Console.Haskeline.Command.KillRing where import System.Console.Haskeline.LineState import System.Console.Haskeline.Command 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] deriving Show emptyStack :: Stack a emptyStack = Stack [] [] peek :: Stack a -> Maybe a peek (Stack [] []) = Nothing peek (Stack (x:_) _) = Just x peek (Stack [] ys) = peek (Stack (reverse ys) []) rotate :: Stack a -> Stack a rotate s@(Stack [] []) = s rotate (Stack (x:xs) ys) = Stack xs (x:ys) rotate (Stack [] ys) = rotate (Stack (reverse ys) []) push :: a -> Stack a -> Stack a push x (Stack xs ys) = Stack (x:xs) ys type KillRing = Stack [Grapheme] 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 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' (IMode xs1 ys1) (IMode xs2 ys2) | posChange >= 0 = (take posChange ys1, IMode xs1 ys2) | 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) 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) 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) modify (push gs) setState (argState oldS) data KillHelper = SimpleMove (InsertMode -> InsertMode) | GenericKill (InsertMode -> ([Grapheme],InsertMode)) -- a generic kill gives more flexibility, but isn't repeatable. -- for example: dd,cc, % killAll :: KillHelper killAll = GenericKill $ \(IMode xs ys) -> (reverse xs ++ ys, emptyIM) 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 (SimpleMove move) im = deleteFromDiff' (argState im) (applyArg move im) applyArgHelper (GenericKill act) im = act (argState im) haskeline-0.7.0.3/System/Console/Haskeline/Command/Undo.hs0000644000000000000000000000271012022257741021422 0ustar0000000000000000module System.Console.Haskeline.Command.Undo where import System.Console.Haskeline.Command import System.Console.Haskeline.LineState import System.Console.Haskeline.Monads import Control.Monad data Undo = Undo {pastUndo, futureRedo :: [InsertMode]} type UndoT = StateT Undo runUndoT :: Monad m => UndoT m a -> m a runUndoT = evalStateT' initialUndo initialUndo :: Undo initialUndo = Undo {pastUndo = [emptyIM], futureRedo = []} saveToUndo :: Save s => s -> Undo -> Undo saveToUndo s undo | not isSame = Undo {pastUndo = toSave:pastUndo undo,futureRedo=[]} | otherwise = undo where toSave = save s isSame = case pastUndo undo of u:_ | u == toSave -> True _ -> False undoPast, redoFuture :: Save s => s -> Undo -> (s,Undo) undoPast ls u@Undo {pastUndo = []} = (ls,u) undoPast ls u@Undo {pastUndo = (pastLS:lss)} = (restore pastLS, u {pastUndo = lss, futureRedo = save ls : futureRedo u}) redoFuture ls u@Undo {futureRedo = []} = (ls,u) redoFuture ls u@Undo {futureRedo = (futureLS:lss)} = (restore futureLS, u {futureRedo = lss, pastUndo = save ls : pastUndo u}) saveForUndo :: (Save s, MonadState Undo m) => Command m s s saveForUndo s = do modify (saveToUndo s) return s commandUndo, commandRedo :: (MonadState Undo m, Save s) => Command m s s commandUndo = simpleCommand $ liftM Right . update . undoPast commandRedo = simpleCommand $ liftM Right . update . redoFuture