diff -ruN haskeline-0.6.2.2/cbits/h_iconv.c haskeline-0.6.3.2/cbits/h_iconv.c --- haskeline-0.6.2.2/cbits/h_iconv.c 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/cbits/h_iconv.c 2010-11-04 10:14:08.000000000 -0700 @@ -11,5 +11,8 @@ size_t h_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft, char **outbuf, size_t *outbytesleft) { - return iconv(cd, inbuf, inbytesleft, outbuf, outbytesleft); + // Cast inbuf to (void*) so that it works both on Solaris, which expects + // a (const char**), and on other platforms (e.g. Linux), which expect + // a (char **). + return iconv(cd, (void*)inbuf, inbytesleft, outbuf, outbytesleft); } diff -ruN haskeline-0.6.2.2/cbits/h_wcwidth.c haskeline-0.6.3.2/cbits/h_wcwidth.c --- haskeline-0.6.2.2/cbits/h_wcwidth.c 1969-12-31 16:00:00.000000000 -0800 +++ haskeline-0.6.3.2/cbits/h_wcwidth.c 2010-11-04 10:14:08.000000000 -0700 @@ -0,0 +1,309 @@ +/* + * 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 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 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 (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 mk_wcswidth(const wchar_t *pwcs, size_t n) +{ + int w, width = 0; + + for (;*pwcs && n-- > 0; pwcs++) + if ((w = 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 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 (bisearch(ucs, ambiguous, + sizeof(ambiguous) / sizeof(struct interval) - 1)) + return 2; + + return mk_wcwidth(ucs); +} + + +int mk_wcswidth_cjk(const wchar_t *pwcs, size_t n) +{ + int w, width = 0; + + for (;*pwcs && n-- > 0; pwcs++) + if ((w = mk_wcwidth_cjk(*pwcs)) < 0) + return -1; + else + width += w; + + return width; +} diff -ruN haskeline-0.6.2.2/CHANGES haskeline-0.6.3.2/CHANGES --- haskeline-0.6.2.2/CHANGES 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/CHANGES 2010-11-04 10:14:08.000000000 -0700 @@ -1,3 +1,50 @@ +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) diff -ruN haskeline-0.6.2.2/examples/Test.hs haskeline-0.6.3.2/examples/Test.hs --- haskeline-0.6.2.2/examples/Test.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/examples/Test.hs 2010-11-04 10:14:08.000000000 -0700 @@ -9,6 +9,8 @@ Usage: ./Test (line input) ./Test chars (character input) +./Test password (no masking characters) +./Test password \* --} mySettings :: Settings IO @@ -19,6 +21,8 @@ args <- getArgs let inputFunc = case args of ["chars"] -> fmap (fmap (\c -> [c])) . getInputChar + ["password"] -> getPassword Nothing + ["password", [c]] -> getPassword (Just c) _ -> getInputLine runInputT mySettings $ withInterrupt $ loop inputFunc 0 where diff -ruN haskeline-0.6.2.2/haskeline.cabal haskeline-0.6.3.2/haskeline.cabal --- haskeline-0.6.2.2/haskeline.cabal 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/haskeline.cabal 2010-11-04 10:14:08.000000000 -0700 @@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.6 -Version: 0.6.2.2 +Version: 0.6.3.2 Category: User Interfaces License: BSD3 License-File: LICENSE @@ -24,10 +24,21 @@ flag base2 Description: Use the base packages from before version 6.8 +-- 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 @@ -39,7 +50,7 @@ } else { if impl(ghc>=6.11) { - Build-depends: base >=4.1 && < 4.3, containers>=0.1 && < 0.4, directory==1.0.*, + Build-depends: base >=4.1 && < 4.4, containers>=0.1 && < 0.5, directory>=1.0 && < 1.2, bytestring==0.9.* } else { @@ -47,7 +58,7 @@ bytestring==0.9.* } } - Build-depends: filepath==1.1.*, mtl==1.1.*, + Build-depends: filepath >= 1.1 && < 1.3, mtl >= 1.1 && < 2.1, utf8-string==0.3.* && >=0.3.4, extensible-exceptions==0.1.* && >=0.1.1.0 Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances, @@ -94,14 +105,16 @@ Build-depends: unix>=2.0 && < 2.5 -- unix-2.3 doesn't build on ghc-6.8.1 or earlier c-sources: cbits/h_iconv.c + cbits/h_wcwidth.c includes: h_iconv.h install-includes: h_iconv.h Other-modules: + System.Console.Haskeline.Backend.WCWidth System.Console.Haskeline.Backend.Posix System.Console.Haskeline.Backend.IConv System.Console.Haskeline.Backend.DumbTerm if flag(terminfo) { - Build-depends: terminfo>=0.3.1.1 && <0.4 + Build-depends: terminfo>=0.3.1.3 && <0.4 Other-modules: System.Console.Haskeline.Backend.Terminfo cpp-options: -DTERMINFO } diff -ruN haskeline-0.6.2.2/LICENSE haskeline-0.6.3.2/LICENSE --- haskeline-0.6.2.2/LICENSE 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/LICENSE 2010-11-04 10:14:08.000000000 -0700 @@ -5,10 +5,10 @@ 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 disclamer. +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 disclamer in the documentation +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 diff -ruN haskeline-0.6.2.2/Setup.hs haskeline-0.6.3.2/Setup.hs --- haskeline-0.6.2.2/Setup.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/Setup.hs 2010-11-04 10:14:08.000000000 -0700 @@ -106,6 +106,11 @@ , "}" ] -warnIfNotTerminfo flags = when (not (hasFlagSet flags (FlagName "terminfo"))) $ - putStrLn $ - "*** Warning: running on POSIX but not building the terminfo backend. ***" +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." + ,"" + ] diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Backend/DumbTerm.hs haskeline-0.6.3.2/System/Console/Haskeline/Backend/DumbTerm.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Backend/DumbTerm.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Backend/DumbTerm.hs 2010-11-04 10:14:08.000000000 -0700 @@ -1,6 +1,7 @@ module System.Console.Haskeline.Backend.DumbTerm where import System.Console.Haskeline.Backend.Posix +import System.Console.Haskeline.Backend.WCWidth import System.Console.Haskeline.Term import System.Console.Haskeline.LineState import System.Console.Haskeline.Monads as Monads @@ -8,6 +9,7 @@ import System.IO import qualified Data.ByteString as B import Control.Concurrent.Chan +import Control.Monad(liftM) -- TODO: ---- Put "<" and ">" at end of term if scrolls off. @@ -22,17 +24,17 @@ newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a} deriving (Monad, MonadIO, MonadException, MonadState Window, - MonadReader Handle, MonadReader Encoders) + MonadReader Handles, MonadReader Encoders) type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a instance MonadTrans DumbTerm where lift = DumbTerm . lift . lift . lift -runDumbTerm :: IO RunTerm -runDumbTerm = do - ch <- newChan - posixRunTerm $ \enc h -> +runDumbTerm :: Handles -> MaybeT IO RunTerm +runDumbTerm h = do + ch <- liftIO newChan + posixRunTerm h $ \enc -> TermOps { getLayout = tryGetLayouts (posixLayouts h) , withGetEvent = withPosixGetEvent ch h enc [] @@ -54,7 +56,7 @@ printText :: MonadIO m => String -> DumbTerm m () printText str = do - h <- ask + h <- liftM hOut ask posixEncode str >>= liftIO . B.hPutStr h liftIO $ hFlush h @@ -82,40 +84,40 @@ Window {pos=p} <- get w <- maxWidth let (xs1',xs2') = matchInit xs1 xs2 - let newP = p + length xs2' - length xs1' - let ys2' = take (w-newP) ys2 - if length xs1' > p || newP >= w + 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 (length xs1') + printText $ backs xw1 ([],_) | ys1 == xs2' ++ ys2 -> -- moved right printText (graphemesToString xs2') - _ -> let - extraLength = length xs1' + length ys1 - - length xs2' - length ys2 - in printText $ backs (length xs1') + _ -> let extraLength = xw1 + snd (takeWidth (w-p) ys1) + - xw2 - yw2 + in printText $ backs xw1 ++ graphemesToString (xs2' ++ ys2') ++ clearDeadText extraLength - ++ backs (length ys2') + ++ backs yw2 refitLine :: ([Grapheme],[Grapheme]) -> DumbTermM () refitLine (xs,ys) = do w <- maxWidth - let xs' = dropFrames w xs - let p = length xs' + let (xs',p) = dropFrames w xs put Window {pos=p} - let ys' = take (w - p) ys - let k = length ys' + let (ys',k) = takeWidth (w - p) ys printText $ cr ++ graphemesToString (xs' ++ ys') ++ spaces (w-k-p) ++ backs (w-p) where - dropFrames w zs = case splitAt w zs of - (_,[]) -> zs - (_,zs') -> dropFrames w zs' + -- 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 diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Backend/Posix.hsc haskeline-0.6.3.2/System/Console/Haskeline/Backend/Posix.hsc --- haskeline-0.6.2.2/System/Console/Haskeline/Backend/Posix.hsc 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Backend/Posix.hsc 2010-11-04 10:14:08.000000000 -0700 @@ -4,10 +4,14 @@ tryGetLayouts, PosixT, runPosixT, + Handles(..), Encoders(), posixEncode, mapLines, - posixRunTerm + stdinTTYHandles, + ttyHandles, + posixRunTerm, + fileRunTerm ) where import Foreign @@ -18,16 +22,15 @@ import Control.Concurrent hiding (throwTo) import Data.Maybe (catMaybes) import System.Posix.Signals.Exts -import System.Posix.IO(stdInput) +import System.Posix.Types(Fd(..)) import Data.List import System.IO import qualified Data.ByteString as B -import Data.ByteString.Char8 as Char8 (pack) import System.Environment import System.Console.Haskeline.Monads import System.Console.Haskeline.Key -import System.Console.Haskeline.Term +import System.Console.Haskeline.Term as Term import System.Console.Haskeline.Prefs import System.Console.Haskeline.Backend.IConv @@ -50,13 +53,18 @@ #endif #include +----------------------------------------------- +-- Input/output handles +data Handles = Handles {hIn, hOut :: Handle, + closeHandles :: IO ()} + ------------------- -- Window size foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt -posixLayouts :: Handle -> [IO (Maybe Layout)] -posixLayouts h = [ioctlLayout h, envLayout] +posixLayouts :: Handles -> [IO (Maybe Layout)] +posixLayouts h = [ioctlLayout $ hOut h, envLayout] ioctlLayout :: Handle -> IO (Maybe Layout) ioctlLayout h = allocaBytes (#size struct winsize) $ \ws -> do @@ -101,9 +109,9 @@ -- Key sequences getKeySequences :: (MonadIO m, MonadReader Prefs m) - => [(String,Key)] -> m (TreeMap Char Key) -getKeySequences tinfos = do - sttys <- liftIO sttyKeys + => Handles -> [(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 @@ -123,12 +131,29 @@ ,("\ESC[C", simpleKey RightKey) ,("\ESC[A", simpleKey UpKey) ,("\ESC[B", simpleKey DownKey) - ,("\b", simpleKey Backspace)] - - -sttyKeys :: IO [(String, Key)] -sttyKeys = do - attrs <- getTerminalAttributes stdInput + ,("\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 :: Handles -> IO [(String, Key)] +sttyKeys h = do + fd <- unsafeHandleToFD $ hIn 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)] @@ -183,12 +208,12 @@ ----------------------------- withPosixGetEvent :: (MonadException m, MonadReader Prefs m) - => Chan Event -> Handle -> Encoders -> [(String,Key)] + => Chan Event -> Handles -> Encoders -> [(String,Key)] -> (m Event -> m a) -> m a withPosixGetEvent eventChan h enc termKeys f = wrapTerminalOps h $ do - baseMap <- getKeySequences termKeys + baseMap <- getKeySequences h termKeys withWindowHandler eventChan - $ f $ liftIO $ getEvent enc baseMap eventChan + $ f $ liftIO $ getEvent h enc baseMap eventChan withWindowHandler :: MonadException m => Chan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ @@ -206,82 +231,92 @@ old_handler <- liftIO $ installHandler signal handler Nothing f `finally` liftIO (installHandler signal old_handler Nothing) -getEvent :: Encoders -> TreeMap Char Key -> Chan Event -> IO Event -getEvent enc baseMap = keyEventLoop readKeyEvents +getEvent :: Handles -> Encoders -> TreeMap Char Key -> Chan Event -> IO Event +getEvent Handles {hIn=h} enc baseMap = keyEventLoop readKeyEvents where bufferSize = 32 readKeyEvents = do -- Read at least one character of input, and more if available. -- In particular, the characters making up a control sequence will all -- be available at once, so we can process them together with lexKeys. - blockUntilInput - bs <- B.hGetNonBlocking stdin bufferSize - cs <- convert (localeToUnicode enc) bs - return $ map KeyInput $ lexKeys baseMap cs + blockUntilInput h + bs <- B.hGetNonBlocking h bufferSize + cs <- convert h (localeToUnicode enc) bs + return [KeyInput $ lexKeys baseMap cs] -- Different versions of ghc work better using different functions. -blockUntilInput :: IO () +blockUntilInput :: Handle -> IO () #if __GLASGOW_HASKELL__ >= 611 -- threadWaitRead doesn't work with the new ghc IO library, -- because it keeps a buffer even when NoBuffering is set. -blockUntilInput = hWaitForInput stdin (-1) >> return () +blockUntilInput h = hWaitForInput h (-1) >> return () #else -- hWaitForInput doesn't work with -threaded on ghc < 6.10 -- (#2363 in ghc's trac) -blockUntilInput = threadWaitRead stdInput +blockUntilInput h = unsafeHandleToFD h >>= threadWaitRead . Fd #endif -- try to convert to the locale encoding using iconv. -- if the buffer has an incomplete shift sequence, -- read another byte of input and try again. -convert :: (B.ByteString -> IO (String,Result)) -> B.ByteString -> IO String -convert decoder bs = do +convert :: Handle -> (B.ByteString -> IO (String,Result)) + -> B.ByteString -> IO String +convert h decoder bs = do (cs,result) <- decoder bs case result of Incomplete rest -> do - extra <- B.hGetNonBlocking stdin 1 + extra <- B.hGetNonBlocking h 1 if B.null extra then return (cs ++ "?") - else fmap (cs ++) $ convert decoder (rest `B.append` extra) - Invalid rest -> fmap ((cs ++) . ('?':)) $ convert decoder (B.drop 1 rest) + else fmap (cs ++) + $ convert h decoder (rest `B.append` extra) + Invalid rest -> fmap ((cs ++) . ('?':)) $ convert h decoder (B.drop 1 rest) _ -> return cs -getMultiByteChar :: (B.ByteString -> IO (String,Result)) -> IO Char -getMultiByteChar decoder = hWithBinaryMode stdin $ do - b <- getChar - cs <- convert decoder (Char8.pack [b]) +getMultiByteChar :: Handle -> (B.ByteString -> IO (String,Result)) + -> MaybeT IO Char +getMultiByteChar h decoder = hWithBinaryMode h $ do + b <- hGetByte h + cs <- liftIO $ convert h decoder (B.pack [b]) case cs of [] -> return '?' -- shouldn't happen, but doesn't hurt to be careful. (c:_) -> return c --- fails if stdin is not a handle or if we couldn't access /dev/tty. -openTTY :: IO (Maybe Handle) -openTTY = do - inIsTerm <- hIsTerminalDevice stdin - if inIsTerm - then handle (\(_::IOException) -> return Nothing) $ do +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 = stdin, hOut = h, closeHandles = hClose h } + +ttyHandles = do + -- Open the input and output separately, since they need different buffering. + h_in <- openTerm ReadMode + h_out <- openTerm WriteMode + return Handles { hIn = h_in, hOut = h_out, + closeHandles = hClose h_in >> hClose h_out } + +openTerm :: IOMode -> MaybeT IO Handle +openTerm mode = handle (\(_::IOException) -> mzero) -- NB: we open the tty as a binary file since otherwise the terminfo -- backend, which writes output as Chars, would double-encode on ghc-6.12. - h <- openBinaryFile "/dev/tty" WriteMode - return (Just h) - else return Nothing - -posixRunTerm :: (Encoders -> Handle -> TermOps) -> IO RunTerm -posixRunTerm tOps = do - fileRT <- fileRunTerm + $ liftIO $ openBinaryFile "/dev/tty" mode + +posixRunTerm :: MonadIO m => Handles -> (Encoders -> TermOps) -> m RunTerm +posixRunTerm hs tOps = liftIO $ do codeset <- getCodeset - ttyH <- openTTY - encoders <- liftM2 Encoders (openEncoder codeset) (openPartialDecoder codeset) - case ttyH of - Nothing -> return fileRT - Just h -> return fileRT { - closeTerm = closeTerm fileRT >> hClose h, - -- NOTE: could also alloc Encoders once for each call to wrapRunTerm - termOps = Just $ tOps encoders h - } + encoders <- liftM2 Encoders (openEncoder codeset) + (openPartialDecoder codeset) + fileRT <- fileRunTerm $ hIn hs + return fileRT { + closeTerm = closeTerm fileRT >> closeHandles hs, + -- NOTE: could also alloc Encoders once for each call to wrapRunTerm + termOps = Left $ tOps encoders + } -type PosixT m = ReaderT Encoders (ReaderT Handle m) +type PosixT m = ReaderT Encoders (ReaderT Handles m) data Encoders = Encoders {unicodeToLocale :: String -> IO B.ByteString, localeToUnicode :: B.ByteString -> IO (String, Result)} @@ -291,38 +326,44 @@ encoder <- asks unicodeToLocale liftIO $ encoder str -runPosixT :: Monad m => Encoders -> Handle -> PosixT m a -> m a +runPosixT :: Monad m => Encoders -> Handles -> PosixT m a -> m a runPosixT enc h = runReaderT' h . runReaderT' enc -putTerm :: B.ByteString -> IO () -putTerm str = B.putStr str >> hFlush stdout +putTerm :: Handle -> B.ByteString -> IO () +putTerm h str = B.hPutStr h str >> hFlush h -fileRunTerm :: IO RunTerm -fileRunTerm = do +fileRunTerm :: Handle -> IO RunTerm +fileRunTerm h_in = do + let h_out = stdout oldLocale <- setLocale (Just "") codeset <- getCodeset let encoder str = join $ fmap ($ str) $ openEncoder codeset let decoder str = join $ fmap ($ str) $ openDecoder codeset decoder' <- openPartialDecoder codeset - return RunTerm {putStrOut = \str -> encoder str >>= putTerm, + return RunTerm {putStrOut = encoder >=> putTerm h_out, closeTerm = setLocale oldLocale >> return (), wrapInterrupt = withSigIntHandler, encodeForTerm = encoder, decodeForTerm = decoder, - getLocaleChar = getMultiByteChar decoder', - termOps = Nothing + termOps = Right FileOps { + inputHandle = h_in, + getLocaleChar = getMultiByteChar h_in decoder', + maybeReadNewline = hMaybeReadNewline h_in, + getLocaleLine = Term.hGetLine h_in + >>= liftIO . decoder + } + } -- 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 => Handle -> m a -> m a -wrapTerminalOps outH = - bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering - . bracketSet (hGetBuffering outH) (hSetBuffering outH) LineBuffering - . bracketSet (hGetEcho stdin) (hSetEcho stdin) False - -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) +wrapTerminalOps :: MonadException m => Handles -> m a -> m a +wrapTerminalOps Handles {hIn = h_in, hOut = h_out} = + bracketSet (hGetBuffering h_in) (hSetBuffering h_in) NoBuffering + -- TODO: block buffering? Certain \r and \n's are causing flicker... + -- - moving to the right + -- - breaking line after offset widechar? + . bracketSet (hGetBuffering h_out) (hSetBuffering h_out) LineBuffering + . bracketSet (hGetEcho h_in) (hSetEcho h_in) False + . hWithBinaryMode h_in diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Backend/Terminfo.hs haskeline-0.6.3.2/System/Console/Haskeline/Backend/Terminfo.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Backend/Terminfo.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Backend/Terminfo.hs 2010-11-04 10:14:08.000000000 -0700 @@ -6,19 +6,24 @@ import System.Console.Terminfo import Control.Monad -import Data.List(intersperse) +import Data.List(intersperse, foldl') import System.IO import qualified Control.Exception.Extensible as Exception import qualified Data.ByteString.Char8 as B import Data.Maybe (fromMaybe, mapMaybe) import Control.Concurrent.Chan +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.WCWidth import System.Console.Haskeline.Key +---------------------------------------------------------------- +-- 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 @@ -32,6 +37,10 @@ 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 @@ -42,29 +51,26 @@ -- Don't require the bell capabilities bellAudible' <- bell `mplus` return mempty bellVisual' <- visualBell `mplus` return mempty - wrapLine' <- getWrapLine nl' (leftA' 1) + 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'} -text :: B.ByteString -> Actions -> TermOutput -text str _ = termText $ B.unpack str - -getWrapLine :: TermOutput -> TermOutput -> Capability TermOutput -getWrapLine nl' left1 = (autoRightMargin >>= guard >> withAutoMargin) - `mplus` return nl' - where - -- If the wraparound glitch is in effect, force a wrap by printing a space. - -- Otherwise, it'll wrap automatically. - withAutoMargin = (do - wraparoundGlitch >>= guard - return (termText " " <#> left1) - )`mplus` return mempty +-- 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 type TermAction = Actions -> TermOutput +text :: B.ByteString -> TermAction +text str _ = termText $ B.unpack str + left,right,up :: Int -> TermAction left = flip leftA right = flip rightA @@ -73,57 +79,84 @@ 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 ' ' + +---------------------------------------------------------------- +-- The Draw monad + -- denote in modular arithmetic; -- in particular, 0 <= termCol < width -data TermPos = TermPos {termRow,termCol :: Int} +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 + +sum' :: [Int] -> Int newtype Draw m a = Draw {unDraw :: (ReaderT Actions - (ReaderT Terminal (StateT TermPos - (PosixT m)))) a} + (ReaderT Terminal + (StateT TermRows + (StateT TermPos + (PosixT m))))) a} deriving (Monad, MonadIO, MonadException, MonadReader Actions, MonadReader Terminal, MonadState TermPos, - MonadReader Handle, MonadReader Encoders) + MonadState TermRows, + MonadReader Handles, MonadReader Encoders) type DrawM a = forall m . (MonadReader Layout m, MonadIO m) => Draw m a instance MonadTrans Draw where - lift = Draw . lift . lift . lift . lift . lift + lift = Draw . lift . lift . lift . lift . lift . lift -runTerminfoDraw :: IO (Maybe RunTerm) -runTerminfoDraw = do - mterm <- Exception.try setupTermFromEnv - ch <- newChan +runTerminfoDraw :: Handles -> MaybeT IO RunTerm +runTerminfoDraw h = do + mterm <- liftIO $ Exception.try setupTermFromEnv + ch <- liftIO newChan case mterm of - -- XXX narrow this: either an ioexception (from getenv) or a - -- usererror. - Left (_::SetupTermError) -> return Nothing - Right term -> case getCapability term getActions of - Nothing -> return Nothing - Just actions -> fmap Just $ posixRunTerm $ \enc h -> + Left (_::SetupTermError) -> mzero + Right term -> do + actions <- MaybeT $ return $ getCapability term getActions + posixRunTerm h $ \enc -> TermOps { getLayout = tryGetLayouts (posixLayouts h ++ [tinfoLayout term]) - , withGetEvent = wrapKeypad h term + , withGetEvent = wrapKeypad (hOut h) term . withPosixGetEvent ch h enc (terminfoKeys term) , runTerm = \(RunTermType f) -> runPosixT enc h $ evalStateT' initTermPos + $ evalStateT' initTermRows $ runReaderT' term $ runReaderT' actions $ unDraw f @@ -160,6 +193,7 @@ ,(keyEnd, simpleKey End) ,(keyPageDown, simpleKey PageDown) ,(keyPageUp, simpleKey PageUp) + ,(keyEnter, simpleKey $ KeyChar '\n') ] @@ -167,97 +201,131 @@ output f = do toutput <- asks f term <- ask - ttyh <- ask + ttyh <- liftM hOut ask liftIO $ hRunTermOutput ttyh term toutput +---------------------------------------------------------------- +-- Movement actions +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 + +-- TODO: when drawLineDiffT calls this, shouldn't move if same. +moveToPos :: TermPos -> DrawM TermAction +moveToPos p = do + oldP <- get + put p + return $ changePos oldP p + +moveRelative :: Int -> DrawM () +moveRelative n = liftM3 (advancePos n) ask get get + >>= moveToPos >>= output + +-- Note that these move by a certain number of cells, not graphemes. changeRight, changeLeft :: Int -> DrawM () -changeRight n = do - w <- asks width - TermPos {termRow=r,termCol=c} <- get - if c+n < w - then do - put TermPos {termRow=r,termCol=c+n} - output (right n) - else do - let m = c+n - let linesDown = m `div` w - let newCol = m `rem` w - put TermPos {termRow=r+linesDown, termCol=newCol} - output $ cr <#> mreplicate linesDown nl <#> right newCol - -changeLeft n = do - w <- asks width - TermPos {termRow=r,termCol=c} <- get - if c - n >= 0 - then do - put TermPos {termRow = r,termCol = c-n} - output (left n) - else do - let m = n - c - let linesUp = 1 + ((m-1) `div` w) - let newCol = (-m) `mod` w -- mod returns positive # - put TermPos {termRow = r - linesUp, termCol=newCol} - output $ cr <#> up linesUp <#> right newCol - --- TODO: I think if we wrap this all up in one call to output, it'll be faster... -printText :: [Grapheme] -> DrawM () -printText [] = return () -printText xs = fillLine xs >>= printText - --- Draws as much of the string as possible in the line, and returns the rest. --- If we fill up the line completely, wrap to the next row. -fillLine :: [Grapheme] -> DrawM [Grapheme] -fillLine str = do +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' = foldl' (+) 0 + +---------------------------------------------------------------- +-- Text printing actions + +encodeGraphemes :: MonadIO m => [Grapheme] -> Draw m TermAction +encodeGraphemes = liftM text . posixEncode . graphemesToString + +printText :: [Grapheme] -> DrawM TermAction +printText = textAction mempty + +textAction :: TermAction -> [Grapheme] -> DrawM TermAction +textAction prevOutput [] = return prevOutput +textAction prevOutput gs = do + -- First, get the monadic parameters: w <- asks width - TermPos {termRow=r,termCol=c} <- get - let roomLeft = w - c - if length str < roomLeft - then do - posixEncode (graphemesToString str) >>= output . text - put TermPos{termRow=r, termCol=c+length str} - return [] - else do - let (thisLine,rest) = splitAt roomLeft str - bstr <- posixEncode (graphemesToString thisLine) - output (text bstr <#> wrapLine) - put TermPos {termRow=r+1,termCol=0} - return rest + 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 + ts <- encodeGraphemes thisLine + -- Finally, actually print out the relevant text. + modify $ setRow r lineWidth + if null rest && lineWidth < w + then do -- everything fits on one line without wrapping + put TermPos {termRow=r, termCol=lineWidth} + return (prevOutput <#> ts) + else do -- Must wrap to the next line + put TermPos {termRow=r+1,termCol=0} + let wrap = if lineWidth == w then wrapLine else spaces (w-lineWidth) + textAction (prevOutput <#> ts <#> wrap) rest + +---------------------------------------------------------------- +-- High-level Term implementation +-- +-- To prevent flicker, we combine all of the drawing commands into one big +-- TermAction, and output them all at once. drawLineDiffT :: LineChars -> LineChars -> DrawM () drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of ([],[]) | ys1 == ys2 -> return () - (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (length xs1') - ([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (length xs2') + (xs1',[]) | xs1' ++ ys1 == ys2 -> changeLeft (gsWidth xs1') + ([],xs2') | ys1 == xs2' ++ ys2 -> changeRight (gsWidth xs2') (xs1',xs2') -> do - changeLeft (length xs1') - printText (xs2' ++ ys2) - let m = length xs1' + length ys1 - (length xs2' + length ys2) - clearDeadText m - changeLeft (length ys2) - -linesLeft :: Layout -> TermPos -> Int -> Int -linesLeft Layout {width=w} TermPos {termCol = c} n - | c + n < w = 1 - | otherwise = 1 + div (c+n) w - -lsLinesLeft :: Layout -> TermPos -> LineChars -> Int -lsLinesLeft layout pos = linesLeft layout pos . lengthToEnd - -clearDeadText :: Int -> DrawM () -clearDeadText n - | n <= 0 = return () - | otherwise = do - layout <- ask - pos <- get - let numLinesToClear = linesLeft layout pos n - output clearToLineEnd - when (numLinesToClear > 1) $ output $ mconcat [ - mreplicate (numLinesToClear - 1) - $ nl <#> clearToLineEnd - , up (numLinesToClear - 1) - , right (termCol pos)] + oldRS <- get + -- TODO: this changeLeft could be merged with the rest of the output. + -- For now, we'll leave it separate since xs1' is often empty + -- (e.g. when typing new characters). + changeLeft (gsWidth xs1') + xsOut <- printText xs2' + p <- get + restOut <- liftM mconcat $ sequence + [ printText ys2 + , clearDeadText oldRS + , moveToPos p + ] + output (xsOut <#> restOut) + +-- The number of nonempty lines after the current row position. +getLinesLeft :: DrawM Int +getLinesLeft = do + p <- get + rc <- get + return $ max 0 (lastRow rc - termRow p) + +clearDeadText :: TermRows -> DrawM TermAction +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 mempty + else do + modify $ setRow r c + when (extraRows /= 0) + $ put TermPos {termRow = r + extraRows, termCol=0} + return $ clearToLineEnd <#> mreplicate extraRows (nl <#> clearToLineEnd) clearLayoutT :: DrawM () clearLayoutT = do @@ -266,19 +334,20 @@ put initTermPos moveToNextLineT :: LineChars -> DrawM () -moveToNextLineT s = do - pos <- get - layout <- ask - output $ mreplicate (lsLinesLeft layout pos s) nl +moveToNextLineT _ = do + lleft <- getLinesLeft + output $ mreplicate (lleft+1) nl put initTermPos + put initTermRows repositionT :: Layout -> LineChars -> DrawM () -repositionT oldLayout s = do +repositionT _ s = do oldPos <- get - let l = lsLinesLeft oldLayout oldPos s - 1 + 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 diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Backend/WCWidth.hs haskeline-0.6.3.2/System/Console/Haskeline/Backend/WCWidth.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Backend/WCWidth.hs 1969-12-31 16:00:00.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Backend/WCWidth.hs 2010-11-04 10:14:08.000000000 -0700 @@ -0,0 +1,50 @@ +module 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 mk_wcwidth :: CWchar -> Int + +wcwidth :: Char -> Int +wcwidth c = case mk_wcwidth $ toEnum $ fromEnum c of + -1 -> 0 -- Control characters have zero width. (Used by the + -- "\SOH...\STX" hack in LineState.stringToGraphemes.) + w -> 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) diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Backend/Win32.hsc haskeline-0.6.3.2/System/Console/Haskeline/Backend/Win32.hsc --- haskeline-0.6.2.2/System/Console/Haskeline/Backend/Win32.hsc 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Backend/Win32.hsc 2010-11-04 10:14:08.000000000 -0700 @@ -1,5 +1,7 @@ module System.Console.Haskeline.Backend.Win32( - win32Term + win32Term, + win32TermStdin, + fileRunTerm )where @@ -7,7 +9,7 @@ import Foreign import Foreign.C import System.Win32 hiding (multiByteToWideChar) -import Graphics.Win32.Misc(getStdHandle, sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE) +import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE) import Data.List(intercalate) import Control.Concurrent hiding (throwTo) import Data.Char(isPrint) @@ -17,7 +19,7 @@ import System.Console.Haskeline.Key import System.Console.Haskeline.Monads import System.Console.Haskeline.LineState -import System.Console.Haskeline.Term +import System.Console.Haskeline.Term as Term import Data.ByteString.Internal (createAndTrim) import qualified Data.ByteString as B @@ -53,17 +55,23 @@ else do es <- readEvents h return $ mapMaybe processEvent es - -getConOut :: IO (Maybe HANDLE) -getConOut = handle (\(_::IOException) -> return Nothing) $ fmap Just - $ createFile "CONOUT$" (gENERIC_READ .|. gENERIC_WRITE) + +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 + oPEN_EXISTING 0 Nothing + processEvent :: InputEvent -> Maybe Event processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc, controlKeyState = cstate} - = fmap (KeyInput . Key modifier') $ keyFromCode vc `mplus` simpleKeyChar + = fmap (\e -> KeyInput [Key modifier' e]) $ keyFromCode vc `mplus` simpleKeyChar where simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c) testMod ck = (cstate .&. ck) /= 0 @@ -215,9 +223,9 @@ foreign import stdcall "windows.h SetConsoleMode" c_SetConsoleMode :: HANDLE -> DWORD -> IO Bool -withWindowMode :: MonadException m => m a -> m a -withWindowMode f = do - h <- liftIO $ getStdHandle sTD_INPUT_HANDLE +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 @@ -229,8 +237,13 @@ ---------------------------- -- Drawing -newtype Draw m a = Draw {runDraw :: ReaderT HANDLE m a} - deriving (Monad,MonadIO,MonadException, MonadReader HANDLE) +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 () @@ -238,16 +251,16 @@ lift = Draw . lift getPos :: MonadIO m => Draw m Coord -getPos = ask >>= liftIO . getPosition +getPos = asks hOut >>= liftIO . getPosition setPos :: MonadIO m => Coord -> Draw m () setPos c = do - h <- ask + h <- asks hOut liftIO (setPosition h c) printText :: MonadIO m => String -> Draw m () printText txt = do - h <- ask + h <- asks hOut liftIO (writeConsole h txt) printAfter :: String -> DrawM () @@ -278,7 +291,9 @@ crlf = "\r\n" instance (MonadException m, MonadReader Layout m) => Term (Draw m) where - drawLineDiff = drawLineDiffWin + 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. @@ -300,45 +315,51 @@ ringBell True = liftIO messageBeep ringBell False = return () -- TODO -win32Term :: IO RunTerm +win32TermStdin :: MaybeT IO RunTerm +win32TermStdin = do + liftIO (hIsTerminalDevice stdin) >>= guard + win32Term + +win32Term :: MaybeT IO RunTerm win32Term = do - fileRT <- fileRunTerm - inIsTerm <- hIsTerminalDevice stdin - if not inIsTerm - then return fileRT - else do - oterm <- getConOut - case oterm of - Nothing -> return fileRT - Just h -> do - ch <- newChan - return fileRT { - wrapInterrupt = withWindowMode . withCtrlCHandler, - termOps = Just TermOps { - getLayout = getBufferSize h - , withGetEvent = win32WithEvent ch + hs <- consoleHandles + ch <- liftIO newChan + fileRT <- liftIO $ fileRunTerm stdin + return fileRT { + termOps = Left TermOps { + getLayout = getBufferSize (hOut hs) + , withGetEvent = withWindowMode hs + . win32WithEvent hs ch , runTerm = \(RunTermType f) -> - runReaderT' h $ runDraw f + runReaderT' hs $ runDraw f }, - closeTerm = closeHandle h} + closeTerm = closeHandles hs + } -win32WithEvent :: MonadException m => Chan Event -> (m Event -> m a) -> m a -win32WithEvent eventChan f = do - inH <- liftIO $ getStdHandle sTD_INPUT_HANDLE - f $ liftIO $ getEvent inH eventChan +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 :: IO RunTerm -fileRunTerm = do +fileRunTerm :: Handle -> IO RunTerm +fileRunTerm h_in = do putter <- putOut cp <- getCodePage - return RunTerm {termOps = Nothing, + return RunTerm { closeTerm = return (), putStrOut = putter, encodeForTerm = unicodeToCodePage cp, decodeForTerm = codePageToUnicode cp, - getLocaleChar = getMultiByteChar cp, - wrapInterrupt = withCtrlCHandler} + wrapInterrupt = withCtrlCHandler, + termOps = Right FileOps { + inputHandle = h_in, + getLocaleChar = getMultiByteChar cp h_in, + maybeReadNewline = hMaybeReadNewline h_in, + getLocaleLine = Term.hGetLine h_in + >>= liftIO . codePageToUnicode cp + } + + } -- On Windows, Unicode written to the console must be written with the WriteConsole API call. -- And to make the API cross-platform consistent, Unicode to a file should be UTF-8. @@ -352,8 +373,8 @@ else do cp <- getCodePage return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout - - + + type Handler = DWORD -> IO BOOL @@ -420,16 +441,15 @@ foreign import stdcall "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx :: CodePage -> BYTE -> BOOL -getMultiByteChar :: CodePage -> IO Char -getMultiByteChar cp = hWithBinaryMode stdin $ do - b1 <- getByte - bs <- if c_IsDBCSLeadByteEx cp b1 - then getByte >>= \b2 -> return [b1,b2] - else return [b1] - cs <- codePageToUnicode cp (B.pack bs) - case cs of - [] -> getMultiByteChar cp - (c:_) -> return c +getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char +getMultiByteChar cp h = hWithBinaryMode h loop where - -- NOTE: relies on getChar returning an 8-bit Char. - getByte = fmap (toEnum . fromEnum) getChar + loop = do + b1 <- hGetByte h + bs <- if c_IsDBCSLeadByteEx cp b1 + then hGetByte h >>= \b2 -> return [b1,b2] + else return [b1] + cs <- liftIO $ codePageToUnicode cp (B.pack bs) + case cs of + [] -> loop + (c:_) -> return c diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Backend.hs haskeline-0.6.3.2/System/Console/Haskeline/Backend.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Backend.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Backend.hs 2010-11-04 10:14:08.000000000 -0700 @@ -1,28 +1,55 @@ module 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 -myRunTerm :: IO RunTerm +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 -myRunTerm = win32Term +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 -myRunTerm = runDumbTerm +runDraw = runDumbTerm #else -myRunTerm = do - mRun <- runTerminfoDraw - case mRun of - Nothing -> runDumbTerm - Just run -> return run +runDraw h = runTerminfoDraw h `mplus` runDumbTerm h +#endif #endif + +fileHandleRunTerm :: Handle -> IO RunTerm +#ifdef MINGW +fileHandleRunTerm = Win32.fileRunTerm +#else +fileHandleRunTerm = Posix.fileRunTerm #endif diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Command/Completion.hs haskeline-0.6.3.2/System/Console/Haskeline/Command/Completion.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Command/Completion.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Command/Completion.hs 2010-11-04 10:14:08.000000000 -0700 @@ -28,6 +28,7 @@ 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. diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Command/History.hs haskeline-0.6.3.2/System/Console/Haskeline/Command/History.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Command/History.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Command/History.hs 2010-11-04 10:14:08.000000000 -0700 @@ -87,8 +87,8 @@ instance LineState SearchMode where beforeCursor _ sm = beforeCursor prefix (foundHistory sm) where - prefix = "(" ++ directionName (direction sm) ++ ")`" - ++ graphemesToString (searchTerm sm) ++ "': " + prefix = stringToGraphemes ("(" ++ directionName (direction sm) ++ ")`") + ++ searchTerm sm ++ stringToGraphemes "': " afterCursor = afterCursor . foundHistory instance Result SearchMode where diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Command.hs haskeline-0.6.3.2/System/Console/Haskeline/Command.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Command.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Command.hs 2010-11-04 10:14:08.000000000 -0700 @@ -34,7 +34,7 @@ import System.Console.Haskeline.LineState import System.Console.Haskeline.Key -data Effect = LineChange (String -> LineChars) +data Effect = LineChange (Prefix -> LineChars) | PrintLines [String] | ClearScreen | RingBell diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Completion.hs haskeline-0.6.3.2/System/Console/Haskeline/Completion.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Completion.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Completion.hs 2010-11-04 10:14:08.000000000 -0700 @@ -1,11 +1,12 @@ module System.Console.Haskeline.Completion( CompletionFunc, Completion(..), - completeWord, - completeQuotedWord, - -- * Building 'CompletionFunc's noCompletion, simpleCompletion, + -- * Word completion + completeWord, + completeWordWithPrev, + completeQuotedWord, -- * Filename completion completeFilename, listFiles, @@ -47,17 +48,33 @@ -------------- -- Word break functions --- | The following function creates a custom 'CompletionFunc' for use in the 'Settings.' +-- | 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 - -> String -- ^ List of characters which count as whitespace + -> [Char]-- ^ Characters which count as whitespace -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions -> CompletionFunc m -completeWord esc ws f (line, _) = do +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 (reverse word) + completions <- f rest (reverse word) return (rest,map (escapeReplacement esc ws) completions) where escapedBreak e (c:d:cs) | d == e && c `elem` (e:ws) @@ -65,7 +82,7 @@ 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 @@ -100,7 +117,7 @@ --------- -- Quoted completion completeQuotedWord :: Monad m => Maybe Char -- ^ An optional escape character - -> String -- List of characters which set off quotes + -> [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 @@ -161,19 +178,13 @@ alterIfDir False c = c alterIfDir True c = c {replacement = addTrailingPathSeparator (replacement c), isFinished = False} - -- NOTE In order for completion to work properly, all of the alternatives - -- must have the exact same prefix. As a result, is a little too clever; - -- for example, it doesn't prepend the directory if the file looks like - -- an absolute path (strange, but it can happen). - -- The FilePath docs state that (++) is an exact inverse of splitFileName, so - -- that's the right function to user here. - fullName = (dir ++) + 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 - diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Emacs.hs haskeline-0.6.3.2/System/Console/Haskeline/Emacs.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Emacs.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Emacs.hs 2010-11-04 10:14:08.000000000 -0700 @@ -53,6 +53,8 @@ , 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)) diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/InputT.hs haskeline-0.6.3.2/System/Console/Haskeline/InputT.hs --- haskeline-0.6.2.2/System/Console/Haskeline/InputT.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/InputT.hs 2010-11-04 10:14:08.000000000 -0700 @@ -15,6 +15,7 @@ import System.FilePath import Control.Applicative import qualified Control.Monad.State as State +import System.IO -- | Application-specific customizations to the user interface. data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion. @@ -73,20 +74,102 @@ 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 prefs settings (InputT f) = bracket (liftIO myRunTerm) - (liftIO . closeTerm) - $ \run -> runReaderT' settings $ runReaderT' prefs - $ runKillRing - $ runHistoryFromFile (historyFile settings) (maxHistorySize prefs) - $ runReaderT f run - --- | Run a line-reading application, reading user 'Prefs' from --- @~/.haskeline@ +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 settings f = do - prefs <- liftIO readPrefsFromHome - runInputTWithPrefs prefs settings f +runInputT = runInputTBehavior defaultBehavior + +-- | Returns 'True' if the current session uses terminal-style interaction. (See 'Behavior'.) +haveTerminalUI :: Monad m => InputT m Bool +haveTerminalUI = 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 + + +-- | 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. diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Key.hs haskeline-0.6.3.2/System/Console/Haskeline/Key.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Key.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Key.hs 2010-11-04 10:14:08.000000000 -0700 @@ -7,6 +7,7 @@ metaChar, ctrlChar, metaKey, + ctrlKey, parseKey ) where @@ -46,6 +47,9 @@ 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 diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/LineState.hs haskeline-0.6.3.2/System/Console/Haskeline/LineState.hs --- haskeline-0.6.2.2/System/Console/Haskeline/LineState.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/LineState.hs 2010-11-04 10:14:08.000000000 -0700 @@ -11,6 +11,7 @@ mapBaseChars, -- * Line State class LineState(..), + Prefix, -- ** Convenience functions for the drawing backends LineChars, lineChars, @@ -62,6 +63,9 @@ applyCmdArg, -- ** Other line state types Message(..), + Password(..), + addPasswordChar, + deletePasswordChar, ) where import Data.Char @@ -106,6 +110,15 @@ 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) @@ -115,18 +128,20 @@ -- | 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 :: String -- ^ The input prefix. + beforeCursor :: Prefix -- ^ The input prefix. -> s -- ^ The current line state. - -> [Grapheme] -- ^ The text to the left of the cursor, reversed. (This - -- includes the prefix.) + -> [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 => String -> s -> LineChars +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. @@ -155,7 +170,7 @@ deriving (Show, Eq) instance LineState InsertMode where - beforeCursor prefix (IMode xs _) = stringToGraphemes prefix ++ reverse xs + beforeCursor prefix (IMode xs _) = prefix ++ reverse xs afterCursor (IMode _ ys) = ys instance Result InsertMode where @@ -232,8 +247,8 @@ deriving Show instance LineState CommandMode where - beforeCursor prefix CEmpty = stringToGraphemes prefix - beforeCursor prefix (CMode xs _ _) = stringToGraphemes prefix ++ reverse xs + beforeCursor prefix CEmpty = prefix + beforeCursor prefix (CMode xs _ _) = prefix ++ reverse xs afterCursor CEmpty = [] afterCursor (CMode _ c ys) = c:ys @@ -310,7 +325,7 @@ fmap f am = am {argState = f (argState am)} instance LineState s => LineState (ArgMode s) where - beforeCursor _ am = let pre = "(arg: " ++ show (arg am) ++ ") " + beforeCursor _ am = let pre = map baseGrapheme $ "(arg: " ++ show (arg am) ++ ") " in beforeCursor pre (argState am) afterCursor = afterCursor . argState @@ -348,6 +363,29 @@ 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) diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/MonadException.hs haskeline-0.6.3.2/System/Console/Haskeline/MonadException.hs --- haskeline-0.6.2.2/System/Console/Haskeline/MonadException.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/MonadException.hs 2010-11-04 10:14:08.000000000 -0700 @@ -75,8 +75,10 @@ block = mapReaderT block unblock = mapReaderT unblock +-- Not needed anymore by our code (we have a custom StateT monad), +-- but we should follow the PVP and not remove this in a point release. instance MonadException m => MonadException (StateT s m) where catch f h = StateT $ \s -> catch (runStateT f s) - (\e -> runStateT (h e) s) + (\e -> runStateT (h e) s) block = mapStateT block unblock = mapStateT unblock diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Monads.hs haskeline-0.6.3.2/System/Console/Haskeline/Monads.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Monads.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Monads.hs 2010-11-04 10:14:08.000000000 -0700 @@ -4,21 +4,24 @@ ReaderT(..), runReaderT', asks, - StateT(..), + StateT, + runStateT, evalStateT', + gets, modify, update, MonadReader(..), - MonadState(..) + MonadState(..), + MaybeT(..), + orElse ) where import Control.Monad.Trans import System.Console.Haskeline.MonadException +import Prelude hiding (catch) import Control.Monad.Reader hiding (MonadReader,ask,asks,local) import qualified Control.Monad.Reader as Reader -import Control.Monad.State hiding (MonadState,get,put,modify) -import qualified Control.Monad.State as State class Monad m => MonadReader r m where ask :: m r @@ -39,14 +42,8 @@ get :: m s put :: s -> m () -instance Monad m => MonadState s (StateT s m) where - get = State.get - put = State.put - -instance (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where - get = lift get - put = lift . put - +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 @@ -61,5 +58,65 @@ 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 + +runStateT :: Monad m => StateT s m a -> s -> m (a, s) +runStateT f s = do + useXS <- getStateTFunc f s + return $ useXS $ \x s' -> (x,s') + +instance Monad m => MonadState s (StateT s m) where + get = StateT $ \s -> return $ \f -> f s s + put s = s `seq` StateT $ \_ -> return $ \f -> f () s + +instance (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where + get = lift get + put = lift . put + evalStateT' :: Monad m => s -> StateT s m a -> m a -evalStateT' = flip evalStateT +evalStateT' s f = liftM fst $ runStateT f s + +instance MonadException m => MonadException (StateT s m) where + block m = StateT $ \s -> block $ getStateTFunc m s + unblock m = StateT $ \s -> unblock $ getStateTFunc m s + catch f h = StateT $ \s -> catch (getStateTFunc f s) + $ \e -> getStateTFunc (h e) s + +newtype MaybeT m a = MaybeT { unMaybeT :: m (Maybe a) } + +instance Monad m => Monad (MaybeT m) where + return x = MaybeT $ return $ Just x + MaybeT f >>= g = MaybeT $ f >>= maybe (return Nothing) (unMaybeT . g) + +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = lift . liftIO + +instance MonadTrans MaybeT where + lift = MaybeT . liftM Just + +instance MonadException m => MonadException (MaybeT m) where + block = MaybeT . block . unMaybeT + unblock = MaybeT . unblock . unMaybeT + catch f h = MaybeT $ catch (unMaybeT f) $ unMaybeT . h + +orElse :: Monad m => MaybeT m a -> m a -> m a +orElse (MaybeT f) g = f >>= maybe g return + +instance Monad m => MonadPlus (MaybeT m) where + mzero = MaybeT $ return Nothing + MaybeT f `mplus` MaybeT g = MaybeT $ f >>= maybe g (return . Just) diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Prefs.hs haskeline-0.6.3.2/System/Console/Haskeline/Prefs.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Prefs.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Prefs.hs 2010-11-04 10:14:08.000000000 -0700 @@ -16,7 +16,7 @@ import System.Console.Haskeline.Key {- | -'Prefs' allow the user to customize the line-editing interface. They are +'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@. diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/RunCommand.hs haskeline-0.6.3.2/System/Console/Haskeline/RunCommand.hs --- haskeline-0.6.2.2/System/Console/Haskeline/RunCommand.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/RunCommand.hs 2010-11-04 10:14:08.000000000 -0700 @@ -9,45 +9,49 @@ import Control.Monad -runCommandLoop :: (MonadException m, CommandMonad m, MonadState Layout m) - => TermOps -> String -> KeyCommand m InsertMode a -> m a -runCommandLoop tops prefix cmds = runTerm tops $ - RunTermType (withGetEvent tops $ runCommandLoop' tops prefix cmds) - -runCommandLoop' :: forall t m a . (MonadTrans t, Term (t m), CommandMonad (t m), - MonadState Layout m, MonadReader Prefs m) - => TermOps -> String -> KeyCommand m InsertMode a -> t m Event -> t m a -runCommandLoop' tops prefix cmds getEvent = do - let s = lineChars prefix emptyIM +runCommandLoop :: (MonadException m, CommandMonad m, MonadState Layout m, + LineState s) + => TermOps -> String -> KeyCommand m s a -> s -> m a +runCommandLoop tops prefix cmds initState = runTerm tops $ + RunTermType (withGetEvent tops + $ runCommandLoop' tops (stringToGraphemes prefix) initState cmds) + +runCommandLoop' :: forall t m s a . (MonadTrans t, Term (t m), CommandMonad (t m), + MonadState Layout m, MonadReader Prefs m, LineState s) + => TermOps -> Prefix -> s -> KeyCommand m s a -> t m Event -> t m a +runCommandLoop' tops prefix initState cmds getEvent = do + let s = lineChars prefix initState drawLine s - loopKeys [] s (fmap ($ emptyIM) cmds) - where - loopKeys :: [Key] -> LineChars -> KeyMap (CmdM m a) -> t m a - loopKeys [] s processor = do -- no keys left, so read some more + readMoreKeys s (fmap ($ initState) cmds) + where + readMoreKeys :: LineChars -> KeyMap (CmdM m a) -> t m a + readMoreKeys s next = do event <- handle (\(e::SomeException) -> moveToNextLine s >> throwIO e) getEvent case event of ErrorEvent e -> moveToNextLine s >> throwIO e WindowResize -> drawReposition tops s - >> loopKeys [] s processor - KeyInput k -> do - ks <- lift $ asks $ lookupKeyBinding k - loopKeys ks s processor - loopKeys (k:ks) s processor = case lookupKM processor k of - Nothing -> actBell >> loopKeys [] s processor - Just (Consumed cmd) -> loopCmd ks s cmd - Just (NotConsumed cmd) -> loopCmd (k:ks) s cmd - - loopCmd :: [Key] -> LineChars -> CmdM m a -> t m a - loopCmd ks s (GetKey next) = loopKeys ks s next - loopCmd ks s (DoEffect e next) = do - t <- drawEffect prefix s e - loopCmd ks t next - loopCmd ks s (CmdM next) = lift next >>= loopCmd ks s - loopCmd _ s (Result x) = moveToNextLine s >> return x + >> readMoreKeys s next + KeyInput ks -> do + bound_ks <- mapM (lift . asks . lookupKeyBinding) ks + loopCmd s $ applyKeysToMap (concat bound_ks) next + + loopCmd :: LineChars -> CmdM m a -> t m 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) = lift next >>= loopCmd s + loopCmd s (Result x) = moveToNextLine s >> return x + drawEffect :: (MonadTrans t, Term (t m), MonadReader Prefs m) - => String -> LineChars -> Effect -> t m LineChars + => Prefix -> LineChars -> Effect -> t m LineChars drawEffect prefix s (LineChange ch) = do let t = ch prefix drawLineDiff s t @@ -82,3 +86,20 @@ reposition oldLayout s +--------------- +-- Traverse through the tree of keybindings, using the given keys. +-- Remove as many GetKeys as possible. +applyKeysToMap :: Monad m => [Key] -> KeyMap (CmdM m a) + -> CmdM m a +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 + -> CmdM m a +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 _ (Result x) = Result x diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Term.hs haskeline-0.6.3.2/System/Console/Haskeline/Term.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Term.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Term.hs 2010-11-04 10:14:08.000000000 -0700 @@ -8,13 +8,13 @@ import Control.Concurrent import Data.Typeable -import Data.ByteString (ByteString) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Word import Control.Exception.Extensible (fromException, AsyncException(..),bracket_) -import System.IO(Handle) - -#if __GLASGOW_HASKELL__ >= 611 -import System.IO (hGetEncoding, hSetEncoding, hSetBinaryMode) -#endif +import System.IO +import Control.Monad(liftM,when,guard) +import System.IO.Error (isEOFError) class (MonadReader Layout m, MonadException m) => Term m where reposition :: Layout -> LineChars -> m () @@ -29,18 +29,17 @@ clearLine = flip drawLineDiff ([],[]) --- putStrOut is the right way to send unicode chars to stdout. --- termOps being Nothing means we should read the input as a UTF-8 file. data RunTerm = RunTerm { + -- | Write unicode characters to stdout. putStrOut :: String -> IO (), encodeForTerm :: String -> IO ByteString, decodeForTerm :: ByteString -> IO String, - getLocaleChar :: IO Char, - termOps :: Maybe TermOps, + termOps :: Either TermOps FileOps, wrapInterrupt :: MonadException m => m a -> m a, closeTerm :: IO () } +-- | Operations needed for terminal-style interaction. data TermOps = TermOps { getLayout :: IO Layout , withGetEvent :: (MonadException m, CommandMonad m) @@ -48,6 +47,20 @@ , runTerm :: (MonadException m, CommandMonad m) => RunTermType m a -> m a } +-- | Operations needed for file-style interaction. +data FileOps = FileOps { + inputHandle :: Handle, -- ^ e.g. for turning off echoing. + 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 + -- Generic terminal actions which are independent of the Term being used. -- Wrapped in a newtype so that we don't need RankNTypes. newtype RunTermType m a = RunTermType (forall t . @@ -68,7 +81,7 @@ matchInit (x:xs) (y:ys) | x == y = matchInit xs ys matchInit xs ys = (xs,ys) -data Event = WindowResize | KeyInput Key | ErrorEvent SomeException +data Event = WindowResize | KeyInput [Key] | ErrorEvent SomeException deriving Show keyEventLoop :: IO [Event] -> Chan Event -> IO Event @@ -108,8 +121,10 @@ data Layout = Layout {width, height :: Int} deriving (Show,Eq) --------- --- Utility function since we're not using the new IO library yet. +----------------------------------- +-- 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) @@ -118,3 +133,55 @@ #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 h = do + eof <- liftIO $ hIsEOF h + guard (not eof) + liftIO $ liftM (toEnum . fromEnum) $ hGetChar h + + +-- | Utility function to correctly get a ByteString line of input. +hGetLine :: Handle -> MaybeT IO ByteString +hGetLine h = do + atEOF <- liftIO $ hIsEOF h + guard (not atEOF) + -- It's more efficient to use B.getLine, but that function throws an + -- error if the Handle (e.g., stdin) is set to NoBuffering. + buff <- liftIO $ hGetBuffering h + liftIO $ if buff == NoBuffering + then hWithBinaryMode h $ fmap B.pack $ System.IO.hGetLine h + else B.hGetLine h + +-- If another character is immediately available, and it is a newline, consume it. +-- +-- Two portability fixes: +-- +-- 1) Note that in ghc-6.8.3 and earlier, hReady returns False at an EOF, +-- whereas in ghc-6.10.1 and later it throws an exception. (GHC trac #1063). +-- This code handles both of those cases. +-- +-- 2) Also note that on Windows with ghc<6.10, hReady may not behave correctly (#1198) +-- The net result is that this might cause +-- But this function will generally only be used when reading buffered input +-- (since stdin isn't a terminal), so it should probably be OK. +hMaybeReadNewline :: Handle -> IO () +hMaybeReadNewline h = returnOnEOF () $ do + ready <- hReady h + 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 diff -ruN haskeline-0.6.2.2/System/Console/Haskeline/Vi.hs haskeline-0.6.3.2/System/Console/Haskeline/Vi.hs --- haskeline-0.6.2.2/System/Console/Haskeline/Vi.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline/Vi.hs 2010-11-04 10:14:08.000000000 -0700 @@ -205,31 +205,44 @@ deletionCmd :: InputCmd (ArgMode CommandMode) CommandMode deletionCmd = keyChoiceCmd - [simpleChar 'd' +> killAndStoreCmd killAll + [ reinputArg >+> deletionCmd + , simpleChar 'd' +> killAndStoreCmd killAll , useMovementsForKill (change argState) killAndStoreCmd , withoutConsuming (change argState) ] deletionToInsertCmd :: InputCmd (ArgMode CommandMode) EitherMode deletionToInsertCmd = keyChoiceCmd - [simpleChar 'c' +> killAndStoreIE killAll + [ 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 - [simpleChar 'y' +> copyAndStore killAll + [ 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) @@ -393,7 +406,7 @@ searchText SearchEntry {entryState = IMode xs ys} = reverse xs ++ ys instance LineState SearchEntry where - beforeCursor prefix se = beforeCursor (prefix ++ [searchChar se]) + beforeCursor prefix se = beforeCursor (prefix ++ stringToGraphemes [searchChar se]) (entryState se) afterCursor = afterCursor . entryState diff -ruN haskeline-0.6.2.2/System/Console/Haskeline.hs haskeline-0.6.3.2/System/Console/Haskeline.hs --- haskeline-0.6.2.2/System/Console/Haskeline.hs 2009-11-20 09:17:39.000000000 -0800 +++ haskeline-0.6.3.2/System/Console/Haskeline.hs 2010-11-04 10:14:08.000000000 -0700 @@ -6,7 +6,7 @@ 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 is the +An example use of this library for a simple read-eval-print loop (REPL) is the following: > import System.Console.Haskeline @@ -27,27 +27,39 @@ module System.Console.Haskeline( - -- * Main functions + -- * Interactive sessions -- ** The InputT monad transformer InputT, runInputT, - runInputTWithPrefs, + haveTerminalUI, + -- ** Behaviors + Behavior, + runInputTBehavior, + defaultBehavior, + useFileHandle, + useFile, + preferTerm, + -- * User interaction functions -- ** Reading user input -- $inputfncs getInputLine, getInputChar, + getPassword, -- ** Outputting text -- $outputfncs outputStr, outputStrLn, - -- * Settings + -- * Customization + -- ** Settings Settings(..), defaultSettings, setComplete, - -- * User preferences + -- ** User preferences Prefs(), readPrefs, defaultPrefs, + runInputTWithPrefs, + runInputTBehaviorWithPrefs, -- * Ctrl-C handling -- $ctrlc Interrupt(..), @@ -73,9 +85,6 @@ import System.IO import Data.Char (isSpace, isPrint) -import Control.Monad -import qualified Data.ByteString.Char8 as B -import System.IO.Error (isEOFError) -- | A useful default. In particular: @@ -93,17 +102,17 @@ autoAddHistory = True} {- $outputfncs -The following functions allow cross-platform output of text that may contain +The following functions enable cross-platform output of text that may contain Unicode characters. -} --- | Write a string to the standard output. +-- | Write a Unicode string to the user's standard output. outputStr :: MonadIO m => String -> InputT m () outputStr xs = do putter <- asks putStrOut liftIO $ putter xs --- | Write a string to the standard output, followed by a newline. +-- | Write a string to the user's standard output, followed by a newline. outputStrLn :: MonadIO m => String -> InputT m () outputStrLn = outputStr . (++ "\n") @@ -111,43 +120,30 @@ {- $inputfncs The following functions read one line or character of input from the user. -If 'stdin' is connected to a terminal, then these functions perform all user interaction, -including display of the prompt text, on the user's output terminal (which may differ from -'stdout'). -They return 'Nothing' if the user pressed @Ctrl-D@ when the -input text was empty. - -If 'stdin' is not connected to a terminal or does not have echoing enabled, -then these functions print the prompt to 'stdout', -and they return 'Nothing' if an @EOF@ was encountered before any characters were read. +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. Provides a rich -line-editing user interface if 'stdin' is a terminal. +{- | 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 :: forall m . MonadException m => String -- ^ The input prompt +getInputLine :: MonadException m => String -- ^ The input prompt -> InputT m (Maybe String) -getInputLine prefix = do - -- If other parts of the program have written text, make sure that it - -- appears before we interact with the user on the terminal. - liftIO $ hFlush stdout - rterm <- ask - echo <- liftIO $ hGetEcho stdin - case termOps rterm of - Just tops | echo -> getInputCmdLine tops prefix - _ -> simpleFileLoop prefix rterm +getInputLine = promptedInput getInputCmdLine $ unMaybeT . getLocaleLine getInputCmdLine :: MonadException m => TermOps -> String -> InputT m (Maybe String) getInputCmdLine tops prefix = do emode <- asks editMode result <- runInputCmdT tops $ case emode of - Emacs -> runCommandLoop tops prefix emacsCommands + Emacs -> runCommandLoop tops prefix emacsCommands emptyIM Vi -> evalStateT' emptyViState $ - runCommandLoop tops prefix viKeyCommands + runCommandLoop tops prefix viKeyCommands emptyIM maybeAddHistory result return result @@ -164,80 +160,33 @@ in modify (adder line) _ -> return () -simpleFileLoop :: MonadIO m => String -> RunTerm -> m (Maybe String) -simpleFileLoop prefix rterm = liftIO $ do - putStrOut rterm prefix - atEOF <- hIsEOF stdin - if atEOF - then return Nothing - else do - -- It's more efficient to use B.getLine, but that function throws an - -- error if stdin is set to NoBuffering. - buff <- hGetBuffering stdin - line <- case buff of - NoBuffering -> hWithBinaryMode stdin - $ fmap B.pack System.IO.getLine - _ -> B.getLine - fmap Just $ decodeForTerm rterm line - - ---------- {- | Reads one character of input. Ignores non-printable characters. -If stdin is a terminal, the character will be read without waiting for a newline. +When using terminal-style interaction, the character will be read without waiting +for a newline. -If stdin is not a terminal, a newline will be read if it is immediately +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 prefix = do - liftIO $ hFlush stdout - rterm <- ask - echo <- liftIO $ hGetEcho stdin - case termOps rterm of - Just tops | echo -> getInputCmdChar tops prefix - _ -> simpleFileChar prefix rterm - -simpleFileChar :: MonadIO m => String -> RunTerm -> m (Maybe Char) -simpleFileChar prefix rterm = liftIO $ do - putStrOut rterm prefix - c <- getPrintableChar - maybeReadNewline - return c - where - getPrintableChar = returnOnEOF Nothing $ do - c <- getLocaleChar rterm - if isPrint c - then return (Just c) - else getPrintableChar - --- If another character is immediately available, and it is a newline, consume it. --- --- 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. --- --- Also note that on Windows with ghc<6.10, hReady may not behave correctly (#1198) --- The net result is that this might cause --- But this function will generally only be used when reading buffered input --- (since stdin isn't a terminal), so it should probably be OK. -maybeReadNewline :: IO () -maybeReadNewline = returnOnEOF () $ do - ready <- hReady stdin - when ready $ do - c <- hLookAhead stdin - when (c == '\n') $ getChar >> return () - -returnOnEOF :: a -> IO a -> IO a -returnOnEOF x = handle $ \e -> if isEOFError e - then return x - else throwIO e - +getInputChar = promptedInput getInputCmdChar $ \fops -> do + c <- getPrintableChar fops + maybeReadNewline fops + return c + +getPrintableChar :: FileOps -> IO (Maybe Char) +getPrintableChar fops = do + c <- unMaybeT $ 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 + $ runCommandLoop tops prefix acceptOneChar emptyIM acceptOneChar :: Monad m => KeyCommand m InsertMode (Maybe Char) acceptOneChar = choiceCmd [useChar $ \c s -> change (insertChar c) s @@ -246,6 +195,59 @@ 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 + $ unMaybeT $ 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 + + + +------- +-- | Wrapper for input functions. +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 <- ask + case termOps rterm of + Right fops -> liftIO $ do + putStrOut rterm prompt + 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 + ------------ -- Interrupt