vty-4.7.0.20/0000755000000000000000000000000012044700040010741 5ustar0000000000000000vty-4.7.0.20/AUTHORS0000644000000000000000000000062412044700037012021 0ustar0000000000000000The following people should be thanked for contributing to the vty library: * Andrea Vezzosi * Corey O'Connor * Emily Backes * Josef Svenningsson * Nicolas Pouillard * Roman Cheplyaka * Stefan O'Rear * Yusaku Hashimoto * allan.clark * gwern0 * jeanphilippe.bernardy * m.niloc * mikesteele81 * Mikolaj Konarski * Eyal Lotem * Yoshikuni Jujo vty-4.7.0.20/CHANGELOG0000644000000000000000000001127712044700037012171 0ustar00000000000000004.7.0.0 * API changes: * Added Graphics.Vty.Image.crop: Ensure an image is no larger than the specified size. * Added Graphics.Vty.Image.pad: Ensure an image is no smaller than the specified size. * Added Graphics.Vty.Image.translate: Offset an image. * Thanks Ben Boeckel for these features. 4.3.0.0 4.2.1.0 * API changes: * Attr record accessor fore_color changed to attr_fore_color * Attr record accessor back_color changed to attr_back_color * Attr record accessor style changed to attr_style * Added an "inline" display attribute changing DSL: * put_attr_change applies a display attribute change immediately to a terminal * For instance, can be used to change the display attrbiutes of text output via putStrLn and putStr. EX: "put_attr_change $ back_color red" will set the background color to red. * Changes do not apply to a Picture output via output_picture. * See Graphics.Vty.Inline * Moved all IO actions into any monad an instance of MonadIO 4.0.0.1 * binding for mk_wcswidth was incorrect. Most platforms just magically worked due to coincidence. 4.0.0 * API changes: * "getSize" has been removed. Use "terminal vty >>= display_bounds" where "vty" is an instance of the Vty data structure. * added a "terminal" field to the Vty data structure. Accesses the TerminalHandle associated with the Vty instance. * Graphics.Vty.Types has undergone a number of changes. Summary: * Partitioned into Graphics.Vty.Attributes for display attributes. Graphics.Vty.Image for image combinators. Graphics.Vty.Picture for final picture construction. * Graphics.Vty.Attributes: * "setFG" and "setBG" are now "with_fore_color" and "with_back_color" * All other "set.." equations similarly replaced. * "attr" is now "def_attr", short for "default display attributes" Also added a "current_attr" for "currently applied display attributes" * Graphics.Vty.Image: * "horzcat" is now "horiz_cat" * "vertcat" is now "vert_cat" * "renderBS" is now "utf8_bytestring" * "renderChar" is now "char" * "renderFill" is now "char_fill" * added a "utf8_string" and "string" (AKA "iso_10464_string") for UTF-8 encoded Strings and ISO-10464 encoded Strings. String literals in GHC have an ISO-10464 runtime representation. * Graphics.Vty.Picture: * exports Graphics.Vty.Image * "pic" is now "pic_for_image" * added API for setting background fill pattern. * Completely rewritten output backend. * Efficient, scanline style output span generator. Has not been fully optimized, but good enough. * The details required to display the desired picture on a terminal are well encapsulated. * Terminfo based display terminal implementation. With specialized derivitives for xterm, Terminal.app, and iTerm.app. * Attempts to robustly handle even terminals that don't support all display attributes. * I've tested the following terminals with success: iTerm.app, Terminal.app, xterm, rxvt, mlterm, Eterm, gnome-terminal, konsole, screen, linux vty. Hopefully you will be as successfull. * Improved unicode support. Double wide characters will display as expected. * 256 color support. See Graphics.Vty.Attributes.Color240. The actual output color is adjusted according to the number of colors the terminal supports. * The Graphics.Vty.Image combinators no longer require matching dimensions to arguments. Unspecified areas are filled in with a user-customizable background pattern. See Graphics.Vty.Picture. * output images are always cropped to display size. * Significant code coverage by QuickCheck tests. An interactive test for those final properties that couldn't be automatically verified. issues resolved: * "gnome terminal displays non-basic attributes as strikethrough" * http://trac.haskell.org/vty/ticket/14 * "Multi-byte characters are not displayed correctly on update" * http://trac.haskell.org/vty/ticket/10 * "Redraw does not handle rendering a line that extends beyond screen width characters" * http://trac.haskell.org/vty/ticket/13 * "The <|> and <-> combinators should be more forgiving of mismatched dimensions" * http://trac.haskell.org/vty/ticket/9 * "256-color support" * http://trac.haskell.org/vty/ticket/19 vty-4.7.0.20/LICENSE0000644000000000000000000000303212044700037011752 0ustar0000000000000000Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Stefan O'Rear nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vty-4.7.0.20/README0000644000000000000000000000272012044700037011630 0ustar0000000000000000vty is a terminal interface library. Vty currently provides: * Automatic handling of window resizes. * Supports Unicode characters on output, automatically setting and resetting UTF-8 mode for xterm. Other terminals are assumed to support * Efficient output. * Minimizes repaint area, thus virtually eliminating the flicker problem that plagues ncurses programs. * A pure, compositional interface for efficiently constructing display images. * Automatically decodes keyboard keys into (key,[modifier]) tuples. * Automatically supports refresh on Ctrl-L. * Automatically supports timeout after 50ms for lone ESC (a barely noticable delay) * Interface is designed for relatively easy compatible extension. * Supports all ANSI SGR-modes (defined in console_codes(4)) with a type-safe interface. * Properly handles cleanup. Current disadvantages: * The character encoding of the output terminal is assumed to be UTF-8. * Minimal support for special keys on terminals other than the linux-console. (F1-5 and arrow keys should work, but anything shifted isn't likely to.) * Uses the TIOCGWINSZ ioctl to find the current window size, which appears to be limited to Linux and *BSD. Project is hosted on github.com: https://github.com/coreyoconnor/vty git clone git://github.com/coreyoconnor/vty.git To compile the demonstration program: ghc --make test/Test.hs gwinsz.c The main documentation consists of the haddock-comments and the demonstration program vty-4.7.0.20/Setup.lhs0000644000000000000000000000011312044700040012544 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMainvty-4.7.0.20/TODO0000644000000000000000000000140712044700037011441 0ustar0000000000000000- Improve input handling - base off of haskeline input system. The haskeline input system appears to be excellent and satisfy all of Vty's input requirements. The current haskeline distribution does not appear to export the required modules. Either: 0. Add the required exports to the haskeline distribution. - fine for development but complicates the UI for production clients. Though, exposing the modules would only complicate the appearance of haskeline's interface. 1. Partition the backend of haskeline into a separate package usable by both vty and haskeline. - use compact-string for character encoding handling - Custom cursor appearance handling? - specific color? - reverse video? - auto? vty-4.7.0.20/vty.cabal0000644000000000000000000005106512044700040012556 0ustar0000000000000000name: vty version: 4.7.0.20 license: BSD3 license-file: LICENSE author: AUTHORS maintainer: Corey O'Connor (coreyoconnor@gmail.com) homepage: https://github.com/coreyoconnor/vty category: User Interfaces synopsis: A simple terminal UI library description: vty is terminal GUI library in the niche of ncurses. It is intended to be easy to use, have no confusing corner cases, and good support for common terminal types. . Included in the source distribution is a program test/interactive_terminal_test.hs that demonstrates the various features. . If your terminal is not behaving as expected the results of the test/interactive_terminal_test.hs program should be sent to the Vty maintainter to aid in debugging the issue. . Notable infelicities: Sometimes poor efficiency; Assumes UTF-8 character encoding support by the terminal; . Project is hosted on github.com: https://github.com/coreyoconnor/vty . git clone git://github.com/coreyoconnor/vty.git . © 2006-2007 Stefan O'Rear; BSD3 license. . © 2008-2012 Corey O'Connor; BSD3 license. -- the test suites require >= 1.17.0 cabal-version: >= 1.14.0 build-type: Simple data-files: README, TODO, AUTHORS, CHANGELOG, LICENSE library default-language: Haskell2010 build-depends: base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 exposed-modules: Graphics.Vty Graphics.Vty.Terminal Graphics.Vty.LLInput Graphics.Vty.Attributes Graphics.Vty.Image Graphics.Vty.Inline Graphics.Vty.Picture Graphics.Vty.DisplayRegion other-modules: Codec.Binary.UTF8.Width Data.Marshalling Data.Terminfo.Parse Data.Terminfo.Eval Graphics.Vty.DisplayAttributes Graphics.Vty.Span Graphics.Vty.Terminal.Generic Graphics.Vty.Terminal.MacOSX Graphics.Vty.Terminal.XTermColor Graphics.Vty.Terminal.TerminfoBased c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c include-dirs: cbits hs-source-dirs: src ghc-options: -O2 -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10 cc-options: -O2 test-suite verify-attribute-ops default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyAttributeOps build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-using-mock-terminal default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyMockTerminal other-modules: Graphics.Vty Graphics.Vty.Attributes Graphics.Vty.DisplayAttributes Graphics.Vty.DisplayRegion Graphics.Vty.Image Graphics.Vty.Picture Graphics.Vty.Span Graphics.Vty.Terminal Graphics.Vty.Terminal.Generic Graphics.Vty.Terminal.Debug Graphics.Vty.Debug Graphics.Vty.Debug.Image Codec.Binary.UTF8.Width Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.DisplayRegion Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-display-attributes default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyDisplayAttributes other-modules: Graphics.Vty Graphics.Vty.Attributes Graphics.Vty.DisplayAttributes Graphics.Vty.DisplayRegion Graphics.Vty.Image Graphics.Vty.Picture Graphics.Vty.Span Graphics.Vty.Terminal Graphics.Vty.Terminal.Generic Graphics.Vty.Terminal.Debug Graphics.Vty.Debug Graphics.Vty.Debug.Image Codec.Binary.UTF8.Width Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.DisplayRegion Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-empty-image-props default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyEmptyImageProps other-modules: Graphics.Vty.Picture Verify build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-eval-terminfo-caps default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyEvalTerminfoCaps other-modules: Data.Terminfo.Parse Data.Terminfo.Eval Data.Marshalling Codec.Binary.UTF8.Width Verify build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-image-ops default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyImageOps other-modules: Graphics.Vty.Attributes Graphics.Vty.DisplayAttributes Graphics.Vty.DisplayRegion Graphics.Vty.Image Graphics.Vty.Picture Graphics.Vty.Span Graphics.Vty.Debug.Image Codec.Binary.UTF8.Width Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Image c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-image-trans default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyImageTrans other-modules: Graphics.Vty.Attributes Graphics.Vty.Debug.Image Graphics.Vty.Image Codec.Binary.UTF8.Width Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Image c-sources: cbits/mk_wcwidth.c include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-inline default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyInline other-modules: Codec.Binary.UTF8.Width Data.Terminfo.Eval Data.Terminfo.Parse Data.Marshalling Graphics.Vty.Attributes Graphics.Vty.DisplayAttributes Graphics.Vty.DisplayRegion Graphics.Vty.Image Graphics.Vty.Inline Graphics.Vty.Span Graphics.Vty.Terminal Graphics.Vty.Terminal.Generic Graphics.Vty.Terminal.MacOSX Graphics.Vty.Terminal.TerminfoBased Graphics.Vty.Terminal.XTermColor c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-parse-terminfo-caps default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyParseTerminfoCaps other-modules: Data.Terminfo.Parse Verify Verify.Data.Terminfo.Parse include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-picture-ops default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyPictureOps other-modules: Graphics.Vty.Picture Verify include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-picture-to-span default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyPictureToSpan other-modules: Graphics.Vty Graphics.Vty.Attributes Graphics.Vty.DisplayAttributes Graphics.Vty.DisplayRegion Graphics.Vty.Image Graphics.Vty.Picture Graphics.Vty.Span Graphics.Vty.Terminal Graphics.Vty.Terminal.Generic Graphics.Vty.Terminal.Debug Graphics.Vty.Debug Graphics.Vty.Debug.Image Codec.Binary.UTF8.Width Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.DisplayRegion Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-span-ops default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifySpanOps other-modules: Graphics.Vty Graphics.Vty.Attributes Graphics.Vty.DisplayAttributes Graphics.Vty.DisplayRegion Graphics.Vty.Image Graphics.Vty.Picture Graphics.Vty.Span Graphics.Vty.Terminal Graphics.Vty.Terminal.Generic Graphics.Vty.Terminal.Debug Graphics.Vty.Debug Graphics.Vty.Debug.Image Codec.Binary.UTF8.Width Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.DisplayRegion Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 test-suite verify-utf8-width default-language: Haskell2010 type: detailed-0.9 hs-source-dirs: src test test-module: VerifyUtf8Width other-modules: Codec.Binary.UTF8.Width Graphics.Vty.Attributes Graphics.Vty.Image Verify c-sources: cbits/mk_wcwidth.c include-dirs: cbits build-depends: Cabal == 1.17.*, QuickCheck == 2.4.*, random == 1.0.*, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.4, ghc-prim, mtl >= 1.1.1.0 && < 2.2, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, terminfo >= 0.3 && < 0.4, unix, utf8-string >= 0.3 && < 0.4, vector >= 0.7 -- Bench.hs -- Bench2.hs -- BenchRenderChar.hs -- ControlTable.hs -- HereDoc.hs -- Test.hs -- Test2.hs -- Verify.hs -- Verify/Data/Terminfo/Parse.hs -- Verify/Graphics/Vty/Attributes.hs -- Verify/Graphics/Vty/DisplayRegion.hs -- Verify/Graphics/Vty/Image.hs -- Verify/Graphics/Vty/Picture.hs -- Verify/Graphics/Vty/Span.hs -- interactive_terminal_test.hs -- vty_inline_example.hs -- vty_issue_18.hs -- yi_issue_264.hs vty-4.7.0.20/cbits/0000755000000000000000000000000012044700037012053 5ustar0000000000000000vty-4.7.0.20/cbits/gwinsz.c0000644000000000000000000000027512044700037013544 0ustar0000000000000000#include unsigned long vty_c_get_window_size(void) { struct winsize w; if (ioctl (0, TIOCGWINSZ, &w) >= 0) return (w.ws_row << 16) + w.ws_col; else return 0x190050; } vty-4.7.0.20/cbits/mk_wcwidth.c0000644000000000000000000003321412044700037014362 0ustar0000000000000000/* * This is an implementation of wcwidth() and wcswidth() (defined in * IEEE Std 1002.1-2001) for Unicode. * * http://www.opengroup.org/onlinepubs/007904975/functions/wcwidth.html * http://www.opengroup.org/onlinepubs/007904975/functions/wcswidth.html * * In fixed-width output devices, Latin characters all occupy a single * "cell" position of equal width, whereas ideographic CJK characters * occupy two such cells. Interoperability between terminal-line * applications and (teletype-style) character terminals using the * UTF-8 encoding requires agreement on which character should advance * the cursor by how many cell positions. No established formal * standards exist at present on which Unicode character shall occupy * how many cell positions on character terminals. These routines are * a first attempt of defining such behavior based on simple rules * applied to data provided by the Unicode Consortium. * * For some graphical characters, the Unicode standard explicitly * defines a character-cell width via the definition of the East Asian * FullWidth (F), Wide (W), Half-width (H), and Narrow (Na) classes. * In all these cases, there is no ambiguity about which width a * terminal shall use. For characters in the East Asian Ambiguous (A) * class, the width choice depends purely on a preference of backward * compatibility with either historic CJK or Western practice. * Choosing single-width for these characters is easy to justify as * the appropriate long-term solution, as the CJK practice of * displaying these characters as double-width comes from historic * implementation simplicity (8-bit encoded characters were displayed * single-width and 16-bit ones double-width, even for Greek, * Cyrillic, etc.) and not any typographic considerations. * * Much less clear is the choice of width for the Not East Asian * (Neutral) class. Existing practice does not dictate a width for any * of these characters. It would nevertheless make sense * typographically to allocate two character cells to characters such * as for instance EM SPACE or VOLUME INTEGRAL, which cannot be * represented adequately with a single-width glyph. The following * routines at present merely assign a single-cell width to all * neutral characters, in the interest of simplicity. This is not * entirely satisfactory and should be reconsidered before * establishing a formal standard in this area. At the moment, the * decision which Not East Asian (Neutral) characters should be * represented by double-width glyphs cannot yet be answered by * applying a simple rule from the Unicode database content. Setting * up a proper standard for the behavior of UTF-8 character terminals * will require a careful analysis not only of each Unicode character, * but also of each presentation form, something the author of these * routines has avoided to do so far. * * http://www.unicode.org/unicode/reports/tr11/ * * Markus Kuhn -- 2007-05-26 (Unicode 5.0) * * Permission to use, copy, modify, and distribute this software * for any purpose and without fee is hereby granted. The author * disclaims all warranties with regard to this software. * * Latest version: http://www.cl.cam.ac.uk/~mgk25/ucs/wcwidth.c */ #include struct interval { int first; int last; }; /* auxiliary function for binary search in interval table */ static int vty_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 vty_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 (vty_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 vty_mk_wcswidth(const wchar_t *pwcs, size_t n) { int w, width = 0; for (;n-- > 0; pwcs++) if ((w = vty_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 vty_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 (vty_bisearch(ucs, ambiguous, sizeof(ambiguous) / sizeof(struct interval) - 1)) return 2; return vty_mk_wcwidth(ucs); } int vty_mk_wcswidth_cjk(const wchar_t *pwcs, size_t n) { int w, width = 0; for (;n-- > 0; pwcs++) if ((w = vty_mk_wcwidth_cjk(*pwcs)) < 0) return -1; else width += w; return width; } vty-4.7.0.20/cbits/set_term_timing.c0000644000000000000000000000041612044700037015411 0ustar0000000000000000#include #include #include #include void vty_set_term_timing(void) { struct termios trm; tcgetattr(STDIN_FILENO, &trm); trm.c_cc[VMIN] = 0; trm.c_cc[VTIME] = 0; tcsetattr(STDIN_FILENO, TCSANOW, &trm); } vty-4.7.0.20/src/0000755000000000000000000000000012044700037011536 5ustar0000000000000000vty-4.7.0.20/src/Codec/0000755000000000000000000000000012044700037012553 5ustar0000000000000000vty-4.7.0.20/src/Codec/Binary/0000755000000000000000000000000012044700037013777 5ustar0000000000000000vty-4.7.0.20/src/Codec/Binary/UTF8/0000755000000000000000000000000012044700037014525 5ustar0000000000000000vty-4.7.0.20/src/Codec/Binary/UTF8/Width.hs0000644000000000000000000000215312044700037016141 0ustar0000000000000000-- Copyright 2009 Corey O'Connor {-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-} {-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} module Codec.Binary.UTF8.Width ( wcwidth , wcswidth ) where import Foreign.C.Types import Foreign.C.String import Foreign.Storable import Foreign.Ptr -- import Numeric ( showHex ) import System.IO.Unsafe wcwidth :: Char -> Int wcwidth c = unsafePerformIO (withCWString [c] $! \ws -> do wc <- peek ws -- putStr $ "wcwidth(0x" ++ showHex (fromEnum wc) "" ++ ")" let !w = fromIntegral $! wcwidth' wc -- putStrLn $ " -> " ++ show w return w ) {-# NOINLINE wcwidth #-} foreign import ccall unsafe "vty_mk_wcwidth" wcwidth' :: CWchar -> CInt wcswidth :: String -> Int wcswidth str = unsafePerformIO (withCWStringLen str $! \(ws, ws_len) -> do -- putStr $ "wcswidth(...)" let !w = fromIntegral $! wcswidth' ws (fromIntegral ws_len) -- putStrLn $ " -> " ++ show w return w ) {-# NOINLINE wcswidth #-} foreign import ccall unsafe "vty_mk_wcswidth" wcswidth' :: Ptr CWchar -> CSize -> CInt vty-4.7.0.20/src/Data/0000755000000000000000000000000012044700037012407 5ustar0000000000000000vty-4.7.0.20/src/Data/Marshalling.hs0000644000000000000000000000151512044700037015206 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- Copyright 2009 Corey O'Connor module Data.Marshalling ( module Data.Marshalling , module Data.Word , module Foreign.Ptr , module Foreign.ForeignPtr , module Foreign.Marshal , module Foreign.Storable ) where import Control.Monad.Trans import Data.Word import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Marshal import Foreign.Storable type OutputBuffer = Ptr Word8 string_to_bytes :: String -> [Word8] string_to_bytes str = map (toEnum . fromEnum) str serialize_bytes :: MonadIO m => [Word8] -> OutputBuffer -> m OutputBuffer serialize_bytes bytes !out_ptr = do liftIO $! pokeArray out_ptr bytes return $! out_ptr `plusPtr` ( length bytes ) vty-4.7.0.20/src/Data/Terminfo/0000755000000000000000000000000012044700037014172 5ustar0000000000000000vty-4.7.0.20/src/Data/Terminfo/Eval.hs0000644000000000000000000001713512044700037015424 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {- Evaluates the paramaterized terminfo string capability with the given parameters. - - todo: This can be greatly simplified. -} module Data.Terminfo.Eval ( cap_expression_required_bytes , serialize_cap_expression ) where import Data.ByteString.Internal ( memcpy ) import Data.Marshalling import Data.Terminfo.Parse import Control.Monad.Identity import Control.Monad.State.Strict import Data.Bits ( (.|.), (.&.), xor ) import Data.List import GHC.Prim import GHC.Word data EvalState = EvalState { eval_stack :: ![ CapParam ] , eval_expression :: !CapExpression , eval_params :: ![ CapParam ] } type EvalT m a = StateT EvalState m a type Eval a = EvalT Identity a {-# SPECIALIZE pop :: EvalT IO CapParam #-} pop :: Monad m => EvalT m CapParam pop = do s <- get let v : stack' = eval_stack s s' = s { eval_stack = stack' } put s' return v {-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-} read_param :: Monad m => Word -> EvalT m CapParam read_param pn = do !params <- get >>= return . eval_params return $! genericIndex params pn {-# SPECIALIZE push :: CapParam -> EvalT IO () #-} push :: Monad m => CapParam -> EvalT m () push !v = do s <- get let s' = s { eval_stack = v : eval_stack s } put s' apply_param_ops :: CapExpression -> [CapParam] -> [CapParam] apply_param_ops cap params = foldl apply_param_op params (param_ops cap) apply_param_op :: [CapParam] -> ParamOp -> [CapParam] apply_param_op params IncFirstTwo = map (+ 1) params cap_expression_required_bytes :: CapExpression -> [CapParam] -> Word cap_expression_required_bytes cap params = let params' = apply_param_ops cap params s_0 = EvalState [] cap params' in fst $! runIdentity $! runStateT ( cap_ops_required_bytes $! cap_ops cap ) s_0 cap_ops_required_bytes :: CapOps -> Eval Word cap_ops_required_bytes ops = do counts <- mapM cap_op_required_bytes ops return $ sum counts cap_op_required_bytes :: CapOp -> Eval Word cap_op_required_bytes (Bytes _ _ c) = return $ toEnum c cap_op_required_bytes DecOut = do p <- pop return $ toEnum $ length $ show p cap_op_required_bytes CharOut = do _ <- pop return 1 cap_op_required_bytes (PushParam pn) = do read_param pn >>= push return 0 cap_op_required_bytes (PushValue v) = do push v return 0 cap_op_required_bytes (Conditional expr parts) = do c_expr <- cap_ops_required_bytes expr c_parts <- cond_parts_required_bytes parts return $ c_expr + c_parts where cond_parts_required_bytes [] = return 0 cond_parts_required_bytes ( (true_ops, false_ops) : false_parts ) = do -- (man 5 terminfo) -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the -- stack, testing if it is nonzero (true). If it is zero (false), control -- passes to the %e (else) part. v <- pop c_total <- if v /= 0 then cap_ops_required_bytes true_ops else do c_false <- cap_ops_required_bytes false_ops c_remain <- cond_parts_required_bytes false_parts return $ c_false + c_remain return c_total cap_op_required_bytes BitwiseOr = do v_1 <- pop v_0 <- pop push $ v_0 .|. v_1 return 0 cap_op_required_bytes BitwiseAnd = do v_1 <- pop v_0 <- pop push $ v_0 .&. v_1 return 0 cap_op_required_bytes BitwiseXOr = do v_1 <- pop v_0 <- pop push $ v_0 `xor` v_1 return 0 cap_op_required_bytes ArithPlus = do v_1 <- pop v_0 <- pop push $ v_0 + v_1 return 0 cap_op_required_bytes ArithMinus = do v_1 <- pop v_0 <- pop push $ v_0 - v_1 return 0 cap_op_required_bytes CompareEq = do v_1 <- pop v_0 <- pop push $ if v_0 == v_1 then 1 else 0 return 0 cap_op_required_bytes CompareLt = do v_1 <- pop v_0 <- pop push $ if v_0 < v_1 then 1 else 0 return 0 cap_op_required_bytes CompareGt = do v_1 <- pop v_0 <- pop push $ if v_0 > v_1 then 1 else 0 return 0 serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer serialize_cap_expression cap params out_ptr = do let params' = apply_param_ops cap params s_0 = EvalState [] cap params' (!out_ptr', _) <- runStateT ( serialize_cap_ops out_ptr (cap_ops cap) ) s_0 return $! out_ptr' serialize_cap_ops :: OutputBuffer -> CapOps -> EvalT IO OutputBuffer serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops serialize_cap_op :: OutputBuffer -> CapOp -> EvalT IO OutputBuffer serialize_cap_op !out_ptr ( Bytes !offset !byte_count !next_offset ) = do !cap <- get >>= return . eval_expression let ( !start_ptr, _ ) = cap_bytes cap !src_ptr = start_ptr `plusPtr` offset !out_ptr' = out_ptr `plusPtr` next_offset liftIO $! memcpy out_ptr src_ptr (fromIntegral byte_count) return $! out_ptr' serialize_cap_op out_ptr DecOut = do p <- pop let out_str = show p out_bytes = string_to_bytes out_str serialize_bytes out_bytes out_ptr serialize_cap_op out_ptr CharOut = do W# p <- pop -- XXX Truncate the character value to a single byte? let !out_byte = W8# (and# p 0xFF##) !out_ptr' = out_ptr `plusPtr` 1 liftIO $ poke out_ptr out_byte return out_ptr' serialize_cap_op out_ptr (PushParam pn) = do read_param pn >>= push return out_ptr serialize_cap_op out_ptr (PushValue v) = do push v return out_ptr serialize_cap_op out_ptr (Conditional expr parts) = do out_ptr' <- serialize_cap_ops out_ptr expr out_ptr'' <- serialize_cond_parts out_ptr' parts return out_ptr'' where serialize_cond_parts ptr [] = return ptr serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = do -- (man 5 terminfo) -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the -- stack, testing if it is nonzero (true). If it is zero (false), control -- passes to the %e (else) part. v <- pop ptr'' <- if v /= 0 then serialize_cap_ops ptr true_ops else do ptr' <- serialize_cap_ops ptr false_ops serialize_cond_parts ptr' false_parts return ptr'' serialize_cap_op out_ptr BitwiseOr = do v_0 <- pop v_1 <- pop push $ v_0 .|. v_1 return out_ptr serialize_cap_op out_ptr BitwiseAnd = do v_0 <- pop v_1 <- pop push $ v_0 .&. v_1 return out_ptr serialize_cap_op out_ptr BitwiseXOr = do v_1 <- pop v_0 <- pop push $ v_0 `xor` v_1 return out_ptr serialize_cap_op out_ptr ArithPlus = do v_1 <- pop v_0 <- pop push $ v_0 + v_1 return out_ptr serialize_cap_op out_ptr ArithMinus = do v_1 <- pop v_0 <- pop push $ v_0 - v_1 return out_ptr serialize_cap_op out_ptr CompareEq = do v_1 <- pop v_0 <- pop push $ if v_0 == v_1 then 1 else 0 return out_ptr serialize_cap_op out_ptr CompareLt = do v_1 <- pop v_0 <- pop push $ if v_0 < v_1 then 1 else 0 return out_ptr serialize_cap_op out_ptr CompareGt = do v_1 <- pop v_0 <- pop push $ if v_0 > v_1 then 1 else 0 return out_ptr vty-4.7.0.20/src/Data/Terminfo/Parse.hs0000644000000000000000000002407212044700037015605 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -funbox-strict-fields -O #-} module Data.Terminfo.Parse ( module Data.Terminfo.Parse , Text.ParserCombinators.Parsec.ParseError ) where import Control.Applicative ( Applicative(..), pure, (<*>) ) import Control.Monad ( liftM ) import Control.Monad.Trans import Control.DeepSeq import Data.Monoid import Data.Word import Foreign.C.Types import Foreign.Marshal.Array import Foreign.Ptr import Text.ParserCombinators.Parsec type CapBytes = ( Ptr Word8, CSize ) data CapExpression = CapExpression { cap_ops :: !CapOps , cap_bytes :: !CapBytes , source_string :: !String , param_count :: !Word , param_ops :: !ParamOps } instance NFData CapExpression where rnf (CapExpression ops !_bytes !str !c !p_ops) = rnf ops `seq` rnf str `seq` rnf c `seq` rnf p_ops type CapParam = Word type CapOps = [CapOp] data CapOp = Bytes !Int !CSize !Int | DecOut | CharOut -- This stores a 0-based index to the parameter. However the operation that implies this op is -- 1-based | PushParam !Word | PushValue !Word -- The conditional parts are the sequence of (%t expression, %e expression) pairs. -- The %e expression may be NOP | Conditional { conditional_expr :: !CapOps , conditional_parts :: ![(CapOps, CapOps)] } | BitwiseOr | BitwiseXOr | BitwiseAnd | ArithPlus | ArithMinus | CompareEq | CompareLt | CompareGt deriving ( Show ) instance NFData CapOp where rnf (Bytes offset _count next_offset) = rnf offset `seq` rnf next_offset rnf (PushParam pn) = rnf pn rnf (PushValue v) = rnf v rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts rnf BitwiseOr = () rnf BitwiseXOr = () rnf BitwiseAnd = () rnf ArithPlus = () rnf ArithMinus = () rnf CompareEq = () rnf CompareLt = () rnf CompareGt = () rnf DecOut = () rnf CharOut = () type ParamOps = [ParamOp] data ParamOp = IncFirstTwo deriving ( Show ) instance NFData ParamOp where rnf IncFirstTwo = () parse_cap_expression :: ( Applicative m , MonadIO m ) => String -> m ( Either ParseError CapExpression ) parse_cap_expression cap_string = let v = runParser cap_expression_parser initial_build_state "terminfo cap" cap_string in case v of Left e -> return $ Left e Right build_results -> pure Right <*> construct_cap_expression cap_string build_results construct_cap_expression :: MonadIO m => [Char] -> BuildResults -> m CapExpression construct_cap_expression cap_string build_results = do byte_array <- liftIO $ newArray (map ( toEnum . fromEnum ) cap_string ) let expr = CapExpression { cap_ops = out_cap_ops build_results -- The cap bytes are the lower 8 bits of the input string's characters. -- \todo Verify the input string actually contains an 8bit byte per character. , cap_bytes = ( byte_array, toEnum $! length cap_string ) , source_string = cap_string , param_count = out_param_count build_results , param_ops = out_param_ops build_results } return $! rnf expr `seq` expr type CapParser a = GenParser Char BuildState a cap_expression_parser :: CapParser BuildResults cap_expression_parser = do rs <- many $ param_escape_parser <|> bytes_op_parser return $ mconcat rs param_escape_parser :: CapParser BuildResults param_escape_parser = do _ <- char '%' inc_offset 1 literal_percent_parser <|> param_op_parser literal_percent_parser :: CapParser BuildResults literal_percent_parser = do _ <- char '%' start_offset <- getState >>= return . next_offset inc_offset 1 return $ BuildResults 0 [Bytes start_offset 1 1] [] param_op_parser :: CapParser BuildResults param_op_parser = increment_op_parser <|> push_op_parser <|> dec_out_parser <|> char_out_parser <|> conditional_op_parser <|> bitwise_op_parser <|> arith_op_parser <|> literal_int_op_parser <|> compare_op_parser <|> char_const_parser increment_op_parser :: CapParser BuildResults increment_op_parser = do _ <- char 'i' inc_offset 1 return $ BuildResults 0 [] [ IncFirstTwo ] push_op_parser :: CapParser BuildResults push_op_parser = do _ <- char 'p' param_n <- digit >>= return . (\d -> read [d]) inc_offset 2 return $ BuildResults param_n [ PushParam $ param_n - 1 ] [] dec_out_parser :: CapParser BuildResults dec_out_parser = do _ <- char 'd' inc_offset 1 return $ BuildResults 0 [ DecOut ] [] char_out_parser :: CapParser BuildResults char_out_parser = do _ <- char 'c' inc_offset 1 return $ BuildResults 0 [ CharOut ] [] conditional_op_parser :: CapParser BuildResults conditional_op_parser = do _ <- char '?' inc_offset 1 cond_part <- many_expr conditional_true_parser parts <- many_p ( do true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser , conditional_false_parser ] false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser , conditional_true_parser ] return ( true_part, false_part ) ) conditional_end_parser let true_parts = map fst parts false_parts = map snd parts BuildResults n cond cond_param_ops = cond_part let n' = maximum $ n : map out_param_count true_parts n'' = maximum $ n' : map out_param_count false_parts let true_ops = map out_cap_ops true_parts false_ops = map out_cap_ops false_parts cond_parts = zip true_ops false_ops let true_param_ops = mconcat $ map out_param_ops true_parts false_param_ops = mconcat $ map out_param_ops false_parts p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops] return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops where many_p !p !end = choice [ try end >> return [] , do !v <- p !vs <- many_p p end return $! v : vs ] many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end conditional_true_parser :: CapParser () conditional_true_parser = do _ <- string "%t" inc_offset 2 conditional_false_parser :: CapParser () conditional_false_parser = do _ <- string "%e" inc_offset 2 conditional_end_parser :: CapParser () conditional_end_parser = do _ <- string "%;" inc_offset 2 bitwise_op_parser :: CapParser BuildResults bitwise_op_parser = bitwise_or_parser <|> bitwise_and_parser <|> bitwise_xor_parser bitwise_or_parser :: CapParser BuildResults bitwise_or_parser = do _ <- char '|' inc_offset 1 return $ BuildResults 0 [ BitwiseOr ] [ ] bitwise_and_parser :: CapParser BuildResults bitwise_and_parser = do _ <- char '&' inc_offset 1 return $ BuildResults 0 [ BitwiseAnd ] [ ] bitwise_xor_parser :: CapParser BuildResults bitwise_xor_parser = do _ <- char '^' inc_offset 1 return $ BuildResults 0 [ BitwiseXOr ] [ ] arith_op_parser :: CapParser BuildResults arith_op_parser = plus_op <|> minus_op where plus_op = do _ <- char '+' inc_offset 1 return $ BuildResults 0 [ ArithPlus ] [ ] minus_op = do _ <- char '-' inc_offset 1 return $ BuildResults 0 [ ArithMinus ] [ ] literal_int_op_parser :: CapParser BuildResults literal_int_op_parser = do _ <- char '{' inc_offset 1 n_str <- many1 digit inc_offset $ toEnum $ length n_str let n :: Word = read n_str _ <- char '}' inc_offset 1 return $ BuildResults 0 [ PushValue n ] [ ] compare_op_parser :: CapParser BuildResults compare_op_parser = compare_eq_op <|> compare_lt_op <|> compare_gt_op where compare_eq_op = do _ <- char '=' inc_offset 1 return $ BuildResults 0 [ CompareEq ] [ ] compare_lt_op = do _ <- char '<' inc_offset 1 return $ BuildResults 0 [ CompareLt ] [ ] compare_gt_op = do _ <- char '>' inc_offset 1 return $ BuildResults 0 [ CompareGt ] [ ] bytes_op_parser :: CapParser BuildResults bytes_op_parser = do bytes <- many1 $ satisfy (/= '%') start_offset <- getState >>= return . next_offset let !c = length bytes !s <- getState let s' = s { next_offset = start_offset + c } setState s' return $ BuildResults 0 [Bytes start_offset ( toEnum c ) c ] [] char_const_parser :: CapParser BuildResults char_const_parser = do _ <- char '\'' char_value <- liftM (toEnum . fromEnum) anyChar _ <- char '\'' inc_offset 3 return $ BuildResults 0 [ PushValue char_value ] [ ] data BuildState = BuildState { next_offset :: Int } inc_offset :: Int -> CapParser () inc_offset n = do s <- getState let s' = s { next_offset = next_offset s + n } setState s' initial_build_state :: BuildState initial_build_state = BuildState 0 data BuildResults = BuildResults { out_param_count :: !Word , out_cap_ops :: !CapOps , out_param_ops :: !ParamOps } instance Monoid BuildResults where mempty = BuildResults 0 [] [] v0 `mappend` v1 = BuildResults { out_param_count = (out_param_count v0) `max` (out_param_count v1) , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1) , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1) } vty-4.7.0.20/src/Graphics/0000755000000000000000000000000012044700037013276 5ustar0000000000000000vty-4.7.0.20/src/Graphics/Vty.hs0000644000000000000000000001346212044700037014422 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ForeignFunctionInterface, BangPatterns, UnboxedTuples #-} {-# CFILES gwinsz.c #-} -- Good sources of documentation for terminal programming are: -- vt100 control sequences: http://vt100.net/docs/vt100-ug/chapter3.html#S3.3.3 -- Xterm control sequences: http://invisible-island.net/xterm/ctlseqs/ctlseqs.html module Graphics.Vty ( Vty(..) , mkVty , mkVtyEscDelay , module Graphics.Vty.Terminal , module Graphics.Vty.Picture , module Graphics.Vty.DisplayRegion , Key(..) , Modifier(..) , Button(..) , Event(..) ) where import Graphics.Vty.Terminal import Graphics.Vty.Picture import Graphics.Vty.DisplayRegion import Graphics.Vty.LLInput import Data.IORef import qualified System.Console.Terminfo as Terminfo -- | The main object. At most one should be created. -- An alternative is to use unsafePerformIO to automatically create a singleton Vty instance when -- required. -- -- This does not assure any thread safety. In theory, as long as an update action is not executed -- when another update action is already then it's safe to call this on multiple threads. -- -- todo: Once the Terminal interface encompasses input this interface will be deprecated. -- Currently, just using the Terminal interface there is no support for input events. data Vty = Vty { -- | Outputs the given Picture. Equivalent to output_picture applied to a display context -- implicitly managed by Vty. update :: Picture -> IO () -- | Get one Event object, blocking if necessary. , next_event :: IO Event -- | Handle to the terminal interface. See `Terminal` -- -- The use of Vty typically follows this process: -- -- 0. initialize vty -- -- 1. use the update equation of Vty to display a picture -- -- 2. repeat -- -- 3. shutdown vty. -- -- todo: provide a similar abstraction to Graphics.Vty.Terminal for input. Use haskeline's -- input backend for implementation. -- -- todo: remove explicit `shutdown` requirement. , terminal :: TerminalHandle -- | Refresh the display. Normally the library takes care of refreshing. Nonetheless, some -- other program might output to the terminal and mess the display. In that case the user -- might want to force a refresh. , refresh :: IO () -- | Clean up after vty. , shutdown :: IO () } -- | Set up the state object for using vty. At most one state object should be -- created at a time. mkVty :: IO Vty mkVty = mkVtyEscDelay 0 -- | Set up the state object for using vty. At most one state object should be -- created at a time. The delay, in microseconds, specifies the period of time to wait for a key -- following reading ESC from the terminal before considering the ESC key press as a discrete event. mkVtyEscDelay :: Int -> IO Vty mkVtyEscDelay escDelay = do term_info <- Terminfo.setupTermFromEnv t <- terminal_handle reserve_display t (kvar, endi) <- initTermInput escDelay term_info intMkVty kvar ( endi >> release_display t >> release_terminal t ) t intMkVty :: IO Event -> IO () -> TerminalHandle -> IO Vty intMkVty kvar fend t = do last_pic_ref <- newIORef Nothing last_update_ref <- newIORef Nothing let inner_update in_pic = do b <- display_bounds t let DisplayRegion w h = b cursor = pic_cursor in_pic in_pic' = case cursor of Cursor x y -> let x' = case x of _ | x >= 0x80000000 -> 0 | x >= w -> w - 1 | otherwise -> x y' = case y of _ | y >= 0x80000000 -> 0 | y >= h -> h - 1 | otherwise -> y in in_pic { pic_cursor = Cursor x' y' } _ -> in_pic mlast_update <- readIORef last_update_ref update_data <- case mlast_update of Nothing -> do d <- display_context t b output_picture d in_pic' return (b, d) Just (last_bounds, last_context) -> do if b /= last_bounds then do d <- display_context t b output_picture d in_pic' return (b, d) else do output_picture last_context in_pic' return (b, last_context) writeIORef last_update_ref $ Just update_data writeIORef last_pic_ref $ Just in_pic' let inner_refresh = writeIORef last_update_ref Nothing >> readIORef last_pic_ref >>= maybe ( return () ) ( \pic -> inner_update pic ) let gkey = do k <- kvar case k of (EvResize _ _) -> inner_refresh >> display_bounds t >>= return . ( \(DisplayRegion w h) -> EvResize (fromEnum w) (fromEnum h) ) _ -> return k return $ Vty { update = inner_update , next_event = gkey , terminal = t , refresh = inner_refresh , shutdown = fend } vty-4.7.0.20/src/Graphics/Vty/0000755000000000000000000000000012044700037014060 5ustar0000000000000000vty-4.7.0.20/src/Graphics/Vty/Attributes.hs0000644000000000000000000001727112044700037016552 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -- Copyright 2009-2010 Corey O'Connor -- Display attributes -- -- For efficiency this can be, in the future, encoded into a single 32 bit word. The 32 bit word is -- first divided into 4 groups of 8 bits where: -- The first group codes what action should be taken with regards to the other groups. -- XXYYZZ__ -- XX - style action -- 00 => reset to default -- 01 => unchanged -- 10 => set -- YY - foreground color action -- 00 => reset to default -- 01 => unchanged -- 10 => set -- ZZ - background color action -- 00 => reset to default -- 01 => unchanged -- 10 => set -- __ - unused -- -- Next is the style flags -- SURBDO__ -- S - standout -- U - underline -- R - reverse video -- B - blink -- D - dim -- O - bold -- __ - unused -- -- Then the foreground color encoded into 8 bits. -- Then the background color encoded into 8 bits. -- module Graphics.Vty.Attributes where import Data.Bits import Data.Monoid import Data.Word -- | A display attribute defines the Color and Style of all the characters rendered after the -- attribute is applied. -- -- At most 256 colors, picked from a 240 and 16 color palette, are possible for the background and -- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more -- information. data Attr = Attr { attr_style :: !(MaybeDefault Style) , attr_fore_color :: !(MaybeDefault Color) , attr_back_color :: !(MaybeDefault Color) } deriving ( Eq, Show ) instance Monoid Attr where mempty = Attr mempty mempty mempty mappend attr_0 attr_1 = Attr ( attr_style attr_0 `mappend` attr_style attr_1 ) ( attr_fore_color attr_0 `mappend` attr_fore_color attr_1 ) ( attr_back_color attr_0 `mappend` attr_back_color attr_1 ) -- | Specifies the display attributes such that the final style and color values do not depend on -- the previously applied display attribute. The display attributes can still depend on the -- terminal's default colors (unfortunately). data FixedAttr = FixedAttr { fixed_style :: !Style , fixed_fore_color :: !(Maybe Color) , fixed_back_color :: !(Maybe Color) } deriving ( Eq, Show ) -- | The style and color attributes can either be the terminal defaults. Or be equivalent to the -- previously applied style. Or be a specific value. data MaybeDefault v where Default :: MaybeDefault v KeepCurrent :: MaybeDefault v SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v deriving instance Eq v => Eq (MaybeDefault v) deriving instance Eq v => Show (MaybeDefault v) instance Eq v => Monoid ( MaybeDefault v ) where mempty = KeepCurrent mappend Default Default = Default mappend Default KeepCurrent = Default mappend Default ( SetTo v ) = SetTo v mappend KeepCurrent Default = Default mappend KeepCurrent KeepCurrent = KeepCurrent mappend KeepCurrent ( SetTo v ) = SetTo v mappend ( SetTo _v ) Default = Default mappend ( SetTo v ) KeepCurrent = SetTo v mappend ( SetTo _ ) ( SetTo v ) = SetTo v -- | Abstract data type representing a color. -- -- Currently the foreground and background color are specified as points in either a: -- -- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8 -- color palette and the second 8 colors are bright/vivid versions of the first 8 colors. -- -- * 240 color palette. This palette is a regular sampling of the full RGB colorspace. -- -- The 8 ISO 6429 (ANSI) colors are as follows: -- -- 0. black -- -- 1. red -- -- 2. green -- -- 3. yellow -- -- 4. blue -- -- 5. magenta -- -- 6. cyan -- -- 7. white -- -- The mapping from points in the 240 color palette to colors actually displayable by the terminal -- depends on the number of colors the terminal claims to support. Which is usually determined by -- the terminfo "colors" property. If this property is not being accurately reported then the color -- reproduction will be incorrect. -- -- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8 -- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not -- addressable via the 240 color palette. -- -- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest -- points in a ("color count" - 16) subsampling of the 240 color palette. -- -- All of this assumes the terminals are behaving similarly to xterm and rxvt when handling colors. -- And that the individual colors have not been remapped by the user. There may be a way to verify -- this through terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE. data Color = ISOColor !Word8 | Color240 !Word8 deriving ( Eq, Show ) -- | Standard 8-color ANSI terminal color codes. black, red, green, yellow, blue, magenta, cyan, white :: Color black = ISOColor 0 red = ISOColor 1 green = ISOColor 2 yellow = ISOColor 3 blue = ISOColor 4 magenta= ISOColor 5 cyan = ISOColor 6 white = ISOColor 7 -- | Bright/Vivid variants of the standard 8-color ANSI bright_black, bright_red, bright_green, bright_yellow :: Color bright_blue, bright_magenta, bright_cyan, bright_white :: Color bright_black = ISOColor 8 bright_red = ISOColor 9 bright_green = ISOColor 10 bright_yellow = ISOColor 11 bright_blue = ISOColor 12 bright_magenta= ISOColor 13 bright_cyan = ISOColor 14 bright_white = ISOColor 15 -- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute -- assigned to that bit should be applied and 0 if the style attribute should not be applied. type Style = Word8 -- | The 6 possible style attributes: -- -- * standout -- -- * underline -- -- * reverse_video -- -- * blink -- -- * dim -- -- * bold/bright -- -- ( The invisible, protect, and altcharset display attributes some terminals support are not -- supported via VTY.) standout, underline, reverse_video, blink, dim, bold :: Style standout = 0x01 underline = 0x02 reverse_video = 0x04 blink = 0x08 dim = 0x10 bold = 0x20 default_style_mask :: Style default_style_mask = 0x00 style_mask :: Attr -> Word8 style_mask attr = case attr_style attr of Default -> 0 KeepCurrent -> 0 SetTo v -> v -- | true if the given Style value has the specified Style set. has_style :: Style -> Style -> Bool has_style s bit_mask = ( s .&. bit_mask ) /= 0 -- | Set the foreground color of an `Attr'. with_fore_color :: Attr -> Color -> Attr with_fore_color attr c = attr { attr_fore_color = SetTo c } -- | Set the background color of an `Attr'. with_back_color :: Attr -> Color -> Attr with_back_color attr c = attr { attr_back_color = SetTo c } -- | Add the given style attribute with_style :: Attr -> Style -> Attr with_style attr style_flag = attr { attr_style = SetTo $ style_mask attr .|. style_flag } -- | Sets the style, background color and foreground color to the default values for the terminal. -- There is no easy way to determine what the default background and foreground colors are. def_attr :: Attr def_attr = Attr Default Default Default -- | Keeps the style, background color and foreground color that was previously set. Used to -- override some part of the previous style. -- -- EG: current_style `with_fore_color` bright_magenta -- -- Would be the currently applied style (be it underline, bold, etc) but with the foreground color -- set to bright_magenta. current_attr :: Attr current_attr = Attr KeepCurrent KeepCurrent KeepCurrent vty-4.7.0.20/src/Graphics/Vty/Debug.hs0000644000000000000000000000260112044700037015441 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ScopedTypeVariables #-} module Graphics.Vty.Debug ( module Graphics.Vty.Debug , module Graphics.Vty.Debug.Image ) where import Graphics.Vty.Attributes import Graphics.Vty.Debug.Image import Graphics.Vty.Span import Graphics.Vty.DisplayRegion import qualified Data.Vector as Vector import Data.Word row_ops_effected_columns :: DisplayOps -> [Word] row_ops_effected_columns spans = Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans all_spans_have_width :: DisplayOps -> Word -> Bool all_spans_have_width spans expected = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns $ display_ops spans span_ops_effected_rows :: DisplayOps -> Word span_ops_effected_rows (DisplayOps _ the_row_ops) = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList the_row_ops)) type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr is_set_attr :: Attr -> SpanConstructEvent -> Bool is_set_attr expected_attr (SpanSetAttr in_attr) | in_attr == expected_attr = True is_set_attr _attr _event = False data DebugWindow = DebugWindow Word Word deriving (Show, Eq) region_for_window :: DebugWindow -> DisplayRegion region_for_window (DebugWindow w h) = DisplayRegion w h type TestWindow = DebugWindow vty-4.7.0.20/src/Graphics/Vty/DisplayAttributes.hs0000644000000000000000000000755712044700037020106 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} module Graphics.Vty.DisplayAttributes where import Graphics.Vty.Attributes import Data.Bits ( (.&.) ) import Data.Monoid ( Monoid(..), mconcat ) -- | Given the previously applied display attributes as a FixedAttr and the current display -- attributes as an Attr produces a FixedAttr that represents the current display attributes. This -- is done by using the previously applied display attributes to remove the "KeepCurrent" -- abstraction. fix_display_attr :: FixedAttr -> Attr -> FixedAttr fix_display_attr fattr attr = FixedAttr ( fix_style (fixed_style fattr) (attr_style attr) ) ( fix_color (fixed_fore_color fattr) (attr_fore_color attr) ) ( fix_color (fixed_back_color fattr) (attr_back_color attr) ) where fix_style _s Default = default_style_mask fix_style s KeepCurrent = s fix_style _s (SetTo new_style) = new_style fix_color _c Default = Nothing fix_color c KeepCurrent = c fix_color _c (SetTo c) = Just c data DisplayAttrDiff = DisplayAttrDiff { style_diffs :: [ StyleStateChange ] , fore_color_diff :: DisplayColorDiff , back_color_diff :: DisplayColorDiff } deriving ( Show ) instance Monoid DisplayAttrDiff where mempty = DisplayAttrDiff [] NoColorChange NoColorChange mappend d_0 d_1 = let ds = simplify_style_diffs ( style_diffs d_0 ) ( style_diffs d_1 ) fcd = simplify_color_diffs ( fore_color_diff d_0 ) ( fore_color_diff d_1 ) bcd = simplify_color_diffs ( back_color_diff d_0 ) ( back_color_diff d_1 ) in DisplayAttrDiff ds fcd bcd simplify_style_diffs :: [ StyleStateChange ] -> [ StyleStateChange ] -> [ StyleStateChange ] simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1 simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff simplify_color_diffs _cd ColorToDefault = ColorToDefault simplify_color_diffs cd NoColorChange = cd simplify_color_diffs _cd ( SetColor !c ) = SetColor c data DisplayColorDiff = ColorToDefault | NoColorChange | SetColor !Color deriving ( Show, Eq ) data StyleStateChange = ApplyStandout | RemoveStandout | ApplyUnderline | RemoveUnderline | ApplyReverseVideo | RemoveReverseVideo | ApplyBlink | RemoveBlink | ApplyDim | RemoveDim | ApplyBold | RemoveBold deriving ( Show, Eq ) display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff display_attr_diffs attr attr' = DisplayAttrDiff { style_diffs = diff_styles ( fixed_style attr ) ( fixed_style attr' ) , fore_color_diff = diff_color ( fixed_fore_color attr ) ( fixed_fore_color attr' ) , back_color_diff = diff_color ( fixed_back_color attr ) ( fixed_back_color attr' ) } diff_color :: Maybe Color -> Maybe Color -> DisplayColorDiff diff_color Nothing (Just c') = SetColor c' diff_color (Just c) (Just c') | c == c' = NoColorChange | otherwise = SetColor c' diff_color Nothing Nothing = NoColorChange diff_color (Just _) Nothing = ColorToDefault diff_styles :: Style -> Style -> [StyleStateChange] diff_styles prev cur = mconcat [ style_diff standout ApplyStandout RemoveStandout , style_diff underline ApplyUnderline RemoveUnderline , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo , style_diff blink ApplyBlink RemoveBlink , style_diff dim ApplyDim RemoveDim , style_diff bold ApplyBold RemoveBold ] where style_diff s sm rm = case ( 0 == prev .&. s, 0 == cur .&. s ) of -- not set in either ( True, True ) -> [] -- set in both ( False, False ) -> [] -- now set ( True, False) -> [ sm ] -- now unset ( False, True) -> [ rm ] vty-4.7.0.20/src/Graphics/Vty/DisplayRegion.hs0000644000000000000000000000033312044700037017164 0ustar0000000000000000-- Copyright 2009 Corey O'Connor module Graphics.Vty.DisplayRegion where import Data.Word data DisplayRegion = DisplayRegion { region_width :: !Word , region_height :: !Word } deriving ( Show, Eq ) vty-4.7.0.20/src/Graphics/Vty/Image.hs0000644000000000000000000003750712044700037015452 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Graphics.Vty.Image ( DisplayString , Image(..) , image_width , image_height , (<|>) , (<->) , horiz_cat , vert_cat , background_fill , char , string , iso_10646_string , utf8_string , utf8_bytestring , char_fill , empty_image , translate , safe_wcwidth , safe_wcswidth , wcwidth , wcswidth , crop , pad -- | The possible display attributes used in constructing an `Image`. , module Graphics.Vty.Attributes ) where import Graphics.Vty.Attributes import Codec.Binary.UTF8.Width import Codec.Binary.UTF8.String ( decode ) import qualified Data.ByteString as BS import Data.Monoid import qualified Data.Sequence as Seq import qualified Data.String.UTF8 as UTF8 import Data.Word infixr 5 <|> infixr 4 <-> -- | We pair each character with it's display length. This way we only compute the length once per -- character. -- * Though currently the width of some strings is still compute multiple times. type DisplayString = Seq.Seq (Char, Word) -- | An image in VTY defines: -- -- * properties required to display the image. These are properties that effect the output image -- but are independent of position -- -- * A set of position-dependent text and attribute regions. The possible regions are: -- -- * a point. ( char ) -- -- * a horizontal line of characters with a single attribute. (string, utf8_string, -- utf8_bytestring ) -- -- * a fill of a single character. (char_fill) -- -- * a fill of the picture's background. (background_fill) -- -- todo: increase the number of encoded bytestring formats supported. data Image = -- A horizontal text span is always >= 1 column and has a row height of 1. HorizText { attr :: !Attr -- All character data is stored as Char sequences with the ISO-10646 encoding. , text :: DisplayString , output_width :: !Word -- >= 0 , char_width :: !Word -- >= 1 } -- A horizontal join can be constructed between any two images. However a HorizJoin instance is -- required to be between two images of equal height. The horiz_join constructor adds background -- filles to the provided images that assure this is true for the HorizJoin value produced. | HorizJoin { part_left :: Image , part_right :: Image , output_width :: !Word -- >= 1 , output_height :: !Word -- >= 1 } -- A veritical join can be constructed between any two images. However a VertJoin instance is -- required to be between two images of equal width. The vert_join constructor adds background -- fills to the provides images that assure this is true for the VertJoin value produced. | VertJoin { part_top :: Image , part_bottom :: Image , output_width :: !Word -- >= 1 , output_height :: !Word -- >= 1 } -- A background fill will be filled with the background pattern. The background pattern is -- defined as a property of the Picture this Image is used to form. | BGFill { output_width :: !Word -- >= 1 , output_height :: !Word -- >= 1 } -- The combining operators identity constant. -- EmptyImage <|> a = a -- EmptyImage <-> a = a -- -- Any image of zero size equals the empty image. | EmptyImage | Translation (Int, Int) Image -- Crop an image to a size | ImageCrop (Word, Word) Image -- Pad an image up to a size | ImagePad (Word, Word) Image deriving Eq instance Show Image where show ( HorizText { output_width = ow, text = txt } ) = "HorizText [" ++ show ow ++ "] (" ++ show (fmap fst txt) ++ ")" show ( BGFill { output_width = c, output_height = r } ) = "BGFill (" ++ show c ++ "," ++ show r ++ ")" show ( HorizJoin { part_left = l, part_right = r, output_width = c } ) = "HorizJoin " ++ show c ++ " ( " ++ show l ++ " <|> " ++ show r ++ " )" show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } ) = "VertJoin (" ++ show c ++ ", " ++ show r ++ ") ( " ++ show t ++ " ) <-> ( " ++ show b ++ " )" show ( Translation offset i ) = "Translation " ++ show offset ++ " ( " ++ show i ++ " )" show ( ImageCrop size i ) = "ImageCrop " ++ show size ++ " ( " ++ show i ++ " )" show ( ImagePad size i ) = "ImagePad " ++ show size ++ " ( " ++ show i ++ " )" show ( EmptyImage ) = "EmptyImage" -- | Currently append in the Monoid instance is equivalent to <->. instance Monoid Image where mempty = empty_image mappend = (<->) -- A horizontal text image of 0 characters in width simplifies to the EmptyImage horiz_text :: Attr -> DisplayString -> Word -> Image horiz_text a txt ow | ow == 0 = EmptyImage | otherwise = HorizText a txt ow (toEnum $ Seq.length txt) horiz_join :: Image -> Image -> Word -> Word -> Image horiz_join i_0 i_1 w h -- A horiz join of two 0 width images simplifies to the EmptyImage | w == 0 = EmptyImage -- A horizontal join where either part is 0 columns in width simplifies to the other part. -- This covers the case where one part is the EmptyImage. | image_width i_0 == 0 = i_1 | image_width i_1 == 0 = i_0 -- If the images are of the same height then no BG padding is required | image_height i_0 == image_height i_1 = HorizJoin i_0 i_1 w h -- otherwise one of the imagess needs to be padded to the right size. | image_height i_0 < image_height i_1 -- Pad i_0 = let pad_amount = image_height i_1 - image_height i_0 in horiz_join ( vert_join i_0 ( BGFill ( image_width i_0 ) pad_amount ) ( image_width i_0 ) ( image_height i_1 ) ) i_1 w h | image_height i_0 > image_height i_1 -- Pad i_1 = let pad_amount = image_height i_0 - image_height i_1 in horiz_join i_0 ( vert_join i_1 ( BGFill ( image_width i_1 ) pad_amount ) ( image_width i_1 ) ( image_height i_0 ) ) w h horiz_join _ _ _ _ = error "horiz_join applied to undefined values." vert_join :: Image -> Image -> Word -> Word -> Image vert_join i_0 i_1 w h -- A vertical join of two 0 height images simplifies to the EmptyImage | h == 0 = EmptyImage -- A vertical join where either part is 0 rows in height simplifies to the other part. -- This covers the case where one part is the EmptyImage | image_height i_0 == 0 = i_1 | image_height i_1 == 0 = i_0 -- If the images are of the same height then no background padding is required | image_width i_0 == image_width i_1 = VertJoin i_0 i_1 w h -- Otherwise one of the images needs to be padded to the size of the other image. | image_width i_0 < image_width i_1 = let pad_amount = image_width i_1 - image_width i_0 in vert_join ( horiz_join i_0 ( BGFill pad_amount ( image_height i_0 ) ) ( image_width i_1 ) ( image_height i_0 ) ) i_1 w h | image_width i_0 > image_width i_1 = let pad_amount = image_width i_0 - image_width i_1 in vert_join i_0 ( horiz_join i_1 ( BGFill pad_amount ( image_height i_1 ) ) ( image_width i_0 ) ( image_height i_1 ) ) w h vert_join _ _ _ _ = error "vert_join applied to undefined values." -- | An area of the picture's bacground (See Background) of w columns and h rows. background_fill :: Word -> Word -> Image background_fill w h | w == 0 = EmptyImage | h == 0 = EmptyImage | otherwise = BGFill w h -- | The width of an Image. This is the number display columns the image will occupy. image_width :: Image -> Word image_width HorizText { output_width = w } = w image_width HorizJoin { output_width = w } = w image_width VertJoin { output_width = w } = w image_width BGFill { output_width = w } = w image_width EmptyImage = 0 image_width ( Translation v i ) = toEnum $ max 0 $ (fst v +) $ fromEnum $ image_width i image_width ( ImageCrop v i ) = min (image_width i) $ fst v image_width ( ImagePad v i ) = max (image_width i) $ fst v -- | The height of an Image. This is the number of display rows the image will occupy. image_height :: Image -> Word image_height HorizText {} = 1 image_height HorizJoin { output_height = r } = r image_height VertJoin { output_height = r } = r image_height BGFill { output_height = r } = r image_height EmptyImage = 0 image_height ( Translation v i ) = toEnum $ max 0 $ (snd v +) $ fromEnum $ image_height i image_height ( ImageCrop v i ) = min (image_height i) $ snd v image_height ( ImagePad v i ) = max (image_height i) $ snd v -- | Combines two images side by side. -- -- The result image will have a width equal to the sum of the two images width. And the height will -- equal the largest height of the two images. The area not defined in one image due to a height -- missmatch will be filled with the background pattern. (<|>) :: Image -> Image -> Image -- Two horizontal text spans with the same attributes can be merged. h0@(HorizText attr_0 text_0 ow_0 _) <|> h1@(HorizText attr_1 text_1 ow_1 _) | attr_0 == attr_1 = horiz_text attr_0 (text_0 Seq.>< text_1) (ow_0 + ow_1) | otherwise = horiz_join h0 h1 (ow_0 + ow_1) 1 -- Anything placed to the right of a join wil be joined to the right sub image. -- The total columns for the join is the sum of the two arguments columns h0@( HorizJoin {} ) <|> h1 = horiz_join ( part_left h0 ) ( part_right h0 <|> h1 ) ( image_width h0 + image_width h1 ) ( max (image_height h0) (image_height h1) ) -- Anything but a join placed to the left of a join wil be joined to the left sub image. -- The total columns for the join is the sum of the two arguments columns h0 <|> h1@( HorizJoin {} ) = horiz_join ( h0 <|> part_left h1 ) ( part_right h1 ) ( image_width h0 + image_width h1 ) ( max (image_height h0) (image_height h1) ) h0 <|> h1 = horiz_join h0 h1 ( image_width h0 + image_width h1 ) ( max (image_height h0) (image_height h1) ) -- | Combines two images vertically. -- The result image will have a height equal to the sum of the heights of both images. -- The width will equal the largest width of the two images. -- The area not defined in one image due to a width missmatch will be filled with the background -- pattern. (<->) :: Image -> Image -> Image im_t <-> im_b = vert_join im_t im_b ( max (image_width im_t) (image_width im_b) ) ( image_height im_t + image_height im_b ) -- | Compose any number of images horizontally. horiz_cat :: [Image] -> Image horiz_cat = foldr (<|>) EmptyImage -- | Compose any number of images vertically. vert_cat :: [Image] -> Image vert_cat = foldr (<->) EmptyImage -- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in -- the ISO-10646 encoding. char :: Attr -> Char -> Image char !a !c = let display_width = safe_wcwidth c in HorizText a (Seq.singleton (c, display_width)) display_width 1 -- | A string of characters layed out on a single row with the same display attribute. The string is -- assumed to be a sequence of ISO-10646 characters. -- -- Note: depending on how the Haskell compiler represents string literals a string literal in a -- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string. -- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry -- about the encoding format when outputting string literals. Just provide the string literal -- directly to iso_10646_string or string. -- iso_10646_string :: Attr -> String -> Image iso_10646_string !a !str = let display_text = Seq.fromList $ map (\c -> (c, safe_wcwidth c)) str in horiz_text a display_text (safe_wcswidth str) -- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is -- represented internally as a list of ISO 10646 31 bit characters. -- -- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while -- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime -- representation. string :: Attr -> String -> Image string = iso_10646_string -- | A string of characters layed out on a single row. The string is assumed to be a sequence of -- UTF-8 characters. utf8_string :: Attr -> [Word8] -> Image utf8_string !a !str = string a ( decode str ) -- XXX: Characters with unknown widths occupy 1 column? -- -- Not sure if this is actually correct. I presume there is a replacement character that is output -- by the terminal instead of the character and this replacement character is 1 column wide. If this -- is not true for all terminals then a per-terminal replacement character width needs to be -- implemented. -- | Returns the display width of a character. Assumes all characters with unknown widths are 1 width safe_wcwidth :: Char -> Word safe_wcwidth c = case wcwidth c of i | i < 0 -> 1 | otherwise -> toEnum i -- | Returns the display width of a string. Assumes all characters with unknown widths are 1 width safe_wcswidth :: String -> Word safe_wcswidth str = case wcswidth str of i | i < 0 -> 1 | otherwise -> toEnum i -- | Renders a UTF-8 encoded bytestring. utf8_bytestring :: Attr -> BS.ByteString -> Image utf8_bytestring !a !bs = string a (UTF8.toString $ UTF8.fromRep bs) -- | creates a fill of the specified character. The dimensions are in number of characters wide and -- number of rows high. -- -- Unlike the Background fill character this character can have double column display width. char_fill :: Enum d => Attr -> Char -> d -> d -> Image char_fill !a !c w h = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) $ char a c -- | The empty image. Useful for fold combinators. These occupy no space nor define any display -- attributes. empty_image :: Image empty_image = EmptyImage -- | Apply the given offset to the image. translate :: (Int, Int) -> Image -> Image translate v i = Translation v i -- | Ensure an image is no larger than the provided size. If the image is larger then crop. crop :: (Word, Word) -> Image -> Image crop (0,_) _ = EmptyImage crop (_,0) _ = EmptyImage crop v (ImageCrop _size i) = ImageCrop (min (fst v) (fst _size), min (snd v) (snd _size)) i crop v i = ImageCrop v i -- | Ensure an image is at least the provided size. If the image is smaller then pad. pad :: (Word, Word) -> Image -> Image pad (0,_) _ = EmptyImage pad (_,0) _ = EmptyImage pad v (ImagePad _size i) = ImagePad (max (fst v) (fst _size), max (snd v) (snd _size)) i pad v i = ImagePad v i vty-4.7.0.20/src/Graphics/Vty/Inline.hs0000644000000000000000000000776112044700037015645 0ustar0000000000000000-- | The inline module provides a limited interface to changing the style of terminal output. The -- intention is for this interface to be used inline with other output systems. -- -- The changes specified by the InlineM monad are applied to the terminals display attributes. These -- display attributes effect the display of all following text output to the terminal file -- descriptor. -- -- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the -- text \" Styled! \" drawn over a red background and underlined. -- -- @ -- t <- terminal_handle -- putStr \"Not styled. \" -- put_attr_change t $ do -- back_color red -- apply_style underline -- putStr \" Styled! \" -- put_attr_change t $ default_all -- putStrLn \"Not styled.\" -- release_terminal t -- @ -- -- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate -- of the 'stdout' handle when the 'terminal_handle' was (first) acquired. If 'stdout' has since been -- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than -- 'put_attr_change' -- -- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} module Graphics.Vty.Inline ( module Graphics.Vty.Inline ) where import Graphics.Vty.Attributes import Graphics.Vty.DisplayAttributes import Graphics.Vty.Terminal.Generic import Control.Applicative import Control.Monad.State.Strict import Data.Bits ( (.&.), complement ) import Data.IORef import Data.Monoid ( mappend ) import System.IO type InlineM v = State Attr v -- | Set the background color to the provided 'Color' back_color :: Color -> InlineM () back_color c = modify $ flip mappend ( current_attr `with_back_color` c ) -- | Set the foreground color to the provided 'Color' fore_color :: Color -> InlineM () fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c ) -- | Attempt to change the 'Style' of the following text. -- -- If the terminal does not support the style change no error is produced. The style can still be -- removed. apply_style :: Style -> InlineM () apply_style s = modify $ flip mappend ( current_attr `with_style` s ) -- | Attempt to remove the specified 'Style' from the display of the following text. -- -- This will fail if apply_style for the given style has not been previously called. remove_style :: Style -> InlineM () remove_style s_mask = modify $ \attr -> let style' = case attr_style attr of Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used." KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used." SetTo s -> s .&. complement s_mask in attr { attr_style = SetTo style' } -- | Reset the display attributes default_all :: InlineM () default_all = put def_attr -- | Apply the provided display attribute changes to the terminal. -- -- This also flushes the 'stdout' handle. put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> InlineM () -> m () put_attr_change t c = do bounds <- display_bounds t d <- display_context t bounds mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t ) fattr <- case mfattr of Nothing -> do liftIO $ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d) return $ FixedAttr default_style_mask Nothing Nothing Just v -> return v let attr = execState c current_attr attr' = limit_attr_for_display d attr fattr' = fix_display_attr fattr attr' diffs = display_attr_diffs fattr fattr' liftIO $ hFlush stdout liftIO $ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs ) ( serialize_set_attr d fattr attr' diffs ) liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' } inline_hack d liftIO $ hFlush stdout vty-4.7.0.20/src/Graphics/Vty/LLInput.hs0000644000000000000000000002421112044700037015743 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- Copyright 2009-2010 Corey O'Connor {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ForeignFunctionInterface #-} module Graphics.Vty.LLInput ( Key(..) , Modifier(..) , Button(..) , Event(..) , initTermInput ) where import Data.Char import Data.Maybe ( mapMaybe ) import Data.List( inits ) import Data.Word import qualified Data.Map as M( fromList, lookup ) import qualified Data.Set as S( fromList, member ) import Codec.Binary.UTF8.Generic (decode) import Control.Monad (when) import Control.Concurrent import Control.Exception import System.Console.Terminfo import System.Posix.Signals.Exts import System.Posix.Terminal import System.Posix.IO ( stdInput ,fdReadBuf ,setFdOption ,FdOption(..) ) import Foreign ( alloca, poke, peek, Ptr ) -- |Representations of non-modifier keys. data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KNP5 | KUp | KMenu | KLeft | KDown | KRight | KEnter deriving (Eq,Show,Ord) -- |Modifier keys. Key codes are interpreted such that users are more likely to -- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will -- generally correspond to the physical Alt key. data Modifier = MShift | MCtrl | MMeta | MAlt deriving (Eq,Show,Ord) -- |Mouse buttons. Not yet used. data Button = BLeft | BMiddle | BRight deriving (Eq,Show,Ord) -- |Generic events. data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier] | EvResize Int Int deriving (Eq,Show,Ord) data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char] deriving(Show) -- | Set up the terminal for input. Returns a function which reads key -- events, and a function for shutting down the terminal access. initTermInput :: Int -> Terminal -> IO (IO Event, IO ()) initTermInput escDelay terminal = do eventChannel <- newChan inputChannel <- newChan hadInput <- newEmptyMVar oattr <- getTerminalAttributes stdInput let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts, EnableEcho, ProcessInput, ExtendedFunctions] setTerminalAttributes stdInput nattr Immediately set_term_timing let inputToEventThread :: IO () inputToEventThread = loop [] where loop kb = case (classify kb) of Prefix -> do c <- readChan inputChannel loop (kb ++ [c]) Invalid -> do c <- readChan inputChannel loop [c] MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s Valid k m -> writeChan eventChannel (EvKey k m) >> loop "" finishAtomicInput = writeChan inputChannel '\xFFFE' inputThread :: IO () inputThread = do _ <- alloca $ \(input_buffer :: Ptr Word8) -> do let loop = do setFdOption stdInput NonBlockingRead False threadWaitRead stdInput setFdOption stdInput NonBlockingRead True _ <- try readAll :: IO (Either IOException ()) when (escDelay == 0) finishAtomicInput loop readAll = do poke input_buffer 0 bytes_read <- fdReadBuf stdInput input_buffer 1 input_char <- fmap (chr . fromIntegral) $ peek input_buffer when (bytes_read > 0) $ do _ <- tryPutMVar hadInput () -- signal input writeChan inputChannel input_char readAll loop return () -- | If there is no input for some time, this thread puts '\xFFFE' in the -- inputChannel. noInputThread :: IO () noInputThread = when (escDelay > 0) loop where loop = do takeMVar hadInput -- wait for some input threadDelay escDelay -- microseconds hadNoInput <- isEmptyMVar hadInput -- no input yet? -- TODO(corey): there is a race between here and the inputThread. when hadNoInput $ do finishAtomicInput loop compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass compile lst = cl' where lst' = concat lst pfx = S.fromList $ concatMap (init . inits . fst) $ lst' mlst = M.fromList lst' cl' str = case S.member str pfx of True -> Prefix False -> case M.lookup str mlst of Just (k,m) -> Valid k m Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of (s,(k,m)) -> MisPfx k m (drop (length s) str) -- ANSI specific bits classify, classifyTab :: [Char] -> KClass -- As soon as classify "\xFFFE" = Invalid classify s@(c:_) | ord c >= 0xC2 = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence classify other = classifyTab other classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of Just (unicodeChar, _) -> Valid (KASCII unicodeChar) [] _ -> Invalid -- something bad happened; just ignore and continue. classifyTab = compile (caps_classify_table : ansi_classify_table) caps_tabls = [("khome", (KHome, [])), ("kend", (KEnd, [])), ("cbt", (KBackTab, [])), ("kcud1", (KDown, [])), ("kcuu1", (KUp, [])), ("kcuf1", (KRight, [])), ("kcub1", (KLeft, [])), ("kLFT", (KLeft, [MShift])), ("kRIT", (KRight, [MShift])) ] caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls] ansi_classify_table :: [[([Char], (Key, [Modifier]))]] ansi_classify_table = [ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5 , k "P" KPause , k "A" KUp , k "B" KDown , k "C" KRight , k "D" KLeft , k "H" KHome , k "F" KEnd , k "E" KBegin ], -- Support for arrows and KHome/KEnd [("\ESC[" ++ charCnt ++ show mc++c,(s,m)) | charCnt <- ["1;", ""], -- we can have a count or not (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes ], let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [2::Int,3,5,6,1,4] [KIns,KDel,KPageUp,KPageDown,KHome,KEnd], let k n s = ("\ESC["++show n++";5~",(s,[MCtrl])) in zipWith k [2::Int,3,5,6,1,4] [KIns,KDel,KPageUp,KPageDown,KHome,KEnd], -- Support for simple characters. [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ], -- Support for function keys (should use terminfo) [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ], let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ], [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ], -- Ctrl+Char [ ([toEnum x],(KASCII y,[MCtrl])) | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']), y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB. ], -- Ctrl+Meta+Char [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ], -- Special support [ -- special support for ESC ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])), -- Special support for backspace ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])), -- Special support for Enter ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] ] eventThreadId <- forkIO $ inputToEventThread inputThreadId <- forkIO $ inputThread noInputThreadId <- forkIO $ noInputThread let pokeIO = (Catch $ do let e = error "(getsize in input layer)" setTerminalAttributes stdInput nattr Immediately writeChan eventChannel (EvResize e e)) _ <- installHandler windowChange pokeIO Nothing _ <- installHandler continueProcess pokeIO Nothing -- TODO(corey): killThread is a bit risky for my tastes. let uninit = do killThread eventThreadId killThread inputThreadId killThread noInputThreadId _ <- installHandler windowChange Ignore Nothing _ <- installHandler continueProcess Ignore Nothing setTerminalAttributes stdInput oattr Immediately return (readChan eventChannel, uninit) first :: (a -> b) -> (a,c) -> (b,c) first f (x,y) = (f x, y) utf8Length :: (Num t, Ord a, Num a) => a -> t utf8Length c | c < 0x80 = 1 | c < 0xE0 = 2 | c < 0xF0 = 3 | otherwise = 4 foreign import ccall "vty_set_term_timing" set_term_timing :: IO () vty-4.7.0.20/src/Graphics/Vty/Picture.hs0000644000000000000000000000565712044700037016044 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Picture ( module Graphics.Vty.Picture , Image , image_width , image_height , (<|>) , (<->) , horiz_cat , vert_cat , background_fill , char , string , iso_10646_string , utf8_string , utf8_bytestring , char_fill , empty_image , translate , crop , pad -- | The possible display attributes used in constructing an `Image`. , module Graphics.Vty.Attributes ) where import Graphics.Vty.Attributes import Graphics.Vty.Image hiding ( attr ) import Data.Word -- |The type of images to be displayed using 'update'. -- Can be constructed directly or using `pic_for_image`. Which provides an initial instance with -- reasonable defaults for pic_cursor and pic_background. data Picture = Picture { pic_cursor :: Cursor , pic_image :: Image , pic_background :: Background } instance Show Picture where show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??" -- | Create a picture for display for the given image. The picture will not have a displayed cursor -- and the background display attribute will be `current_attr`. pic_for_image :: Image -> Picture pic_for_image i = Picture { pic_cursor = NoCursor , pic_image = i , pic_background = Background ' ' current_attr } -- | A picture can be configured either to not show the cursor or show the cursor at the specified -- character position. -- -- There is not a 1 to 1 map from character positions to a row and column on the screen due to -- characters that take more than 1 column. -- -- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the -- output region. In this case the cursor will not be shown. data Cursor = NoCursor | Cursor Word Word -- | Unspecified regions are filled with the picture's background pattern. The background pattern -- can specify a character and a display attribute. If the display attribute used previously should -- be used for a background fill then use `current_attr` for the background attribute. This is the -- default background display attribute. -- -- (tofix) The current attribute is always set to the default attributes at the start of updating the -- screen to a picture. -- -- (tofix) The background character *must* occupy a single column and no more. data Background = Background { background_char :: Char , background_attr :: Attr } vty-4.7.0.20/src/Graphics/Vty/Span.hs0000644000000000000000000004270212044700037015322 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} -- The ops to define the content for an output region. module Graphics.Vty.Span where import Graphics.Vty.Image import Graphics.Vty.Picture import Graphics.Vty.DisplayRegion import Codec.Binary.UTF8.String ( encode ) import Control.Monad ( forM_ ) import Control.Monad.ST.Strict import Data.Vector (Vector) import qualified Data.Vector as Vector hiding ( take, replicate ) import Data.Vector.Mutable ( MVector(..)) import qualified Data.Vector.Mutable as Vector import qualified Data.ByteString as B import qualified Data.ByteString.Internal as BInt import qualified Data.Foldable as Foldable import qualified Data.String.UTF8 as UTF8 import Data.Word import Foreign.Storable ( pokeByteOff ) {- | A picture is translated into a sequences of state changes and character spans. - State changes are currently limited to new attribute values. The attribute is applied to all - following spans. Including spans of the next row. The nth element of the sequence represents the - nth row (from top to bottom) of the picture to render. - - A span op sequence will be defined for all rows and columns (and no more) of the region provided - with the picture to spans_for_pic. - - todo: Partition attribute changes into multiple categories according to the serialized - representation of the various attributes. -} data DisplayOps = DisplayOps { effected_region :: DisplayRegion , display_ops :: RowOps } -- vector of span operation vectors. One per row of the screen. type RowOps = Vector SpanOps type MRowOps s = MVector s SpanOps -- vector of span operations. executed in succession type SpanOps = Vector SpanOp type MSpanOps s = MVector s SpanOp instance Show DisplayOps where show (DisplayOps _ the_row_ops) = "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }" instance Show SpanOp where show (AttributeChange attr) = show attr show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw span_ops_columns :: DisplayOps -> Word span_ops_columns ops = region_width $ effected_region ops span_ops_rows :: DisplayOps -> Word span_ops_rows ops = region_height $ effected_region ops span_ops_effected_columns :: SpanOps -> Word span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops where span_ops_effected_columns' t (TextSpan w _ _ ) = t + w span_ops_effected_columns' t _ = t -- | -- -- todo: This type may need to be restructured to increase sharing in the bytestring -- -- todo: Make foldable data SpanOp = AttributeChange !Attr -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width -- TextSpan [output width in columns] [number of characters] [data] | TextSpan !Word !Word (UTF8.UTF8 B.ByteString) deriving Eq -- used to determine the width of a span operation , if it has one. span_op_has_width :: SpanOp -> Maybe (Word, Word) span_op_has_width (TextSpan ow cw _) = Just (cw, ow) span_op_has_width _ = Nothing -- returns the number of columns to the character at the given position in the span op columns_to_char_offset :: Word -> SpanOp -> Word columns_to_char_offset cx (TextSpan _ _ utf8_str) = let str = UTF8.toString utf8_str in toEnum $! sum $! map wcwidth $! take (fromEnum cx) str columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width" -- | Produces the span ops that will render the given picture, possibly cropped or padded, into the -- specified region. spans_for_pic :: Picture -> DisplayRegion -> DisplayOps spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r) build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s) build_spans pic region = do -- m for mutable! ;-) mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty -- XXX: I think building the span operations in display order would provide better performance. -- However, I got stuck trying to implement an algorithm that did this. This will be considered -- as a possible future optimization. -- -- A depth first traversal of the image is performed. ordered according to the column range -- defined by the image from least to greatest. The output row ops will at least have the -- region of the image specified. Iterate over all output rows and output background fills for -- all unspecified columns. -- -- The images are made into span operations from left to right. It's possible that this could -- easily be made to assure top to bottom output as well. if region_height region > 0 then do -- The ops builder recursively descends the image and outputs span ops that would -- display that image. The number of columns remaining in this row before exceeding the -- bounds is also provided. This is used to clip the span ops produced to the display. -- The skip dimensions provided do....??? _ <- row_ops_for_image mrow_ops (pic_image pic) (pic_background pic) region (0,0) 0 (region_width region) (fromEnum $ region_height region) -- Fill in any unspecified columns with the background pattern. forM_ [0 .. (fromEnum $ region_height region - 1)] $! \row -> do end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns if end_x < region_width region then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row else return () else return () return mrow_ops row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> Int -> ST s (Word, Word) row_ops_for_image mrow_ops -- the image to output the ops to image -- the image to rasterize in column order to mrow_ops bg -- the background fill region -- ??? skip_dim@(skip_row,skip_col) -- the number of rows y -- ??? remaining_columns -- ??? remain_rows | remaining_columns == 0 = return skip_dim | remain_rows == 0 = return skip_dim | y >= fromEnum (region_height region) = return skip_dim | otherwise = case image of EmptyImage -> return skip_dim -- The width provided is the number of columns this text span will occupy when displayed. -- if this is greater than the number of remaining columsn the output has to be produced a -- character at a time. HorizText a text_str _ _ -> do if skip_row > 0 then return (skip_row - 1, skip_col) else do skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns return (skip_row, skip_col') VertJoin top_image bottom_image _ _ -> do (skip_row',skip_col') <- row_ops_for_image mrow_ops top_image bg region skip_dim y remaining_columns remain_rows let top_height = (fromEnum $! image_height top_image) - (fromEnum $! skip_row - skip_row') (skip_row'',skip_col'') <- row_ops_for_image mrow_ops bottom_image bg region (skip_row', skip_col) (y + top_height) remaining_columns (max 0 $ remain_rows - top_height) return (skip_row'', min skip_col' skip_col'') HorizJoin l r _ _ -> do (skip_row',skip_col') <- row_ops_for_image mrow_ops l bg region skip_dim y remaining_columns remain_rows -- Don't output the right part unless there is at least a single column left after -- outputting the left part. if image_width l - (skip_col - skip_col') > remaining_columns then return (skip_row,skip_col') else do (skip_row'',skip_col'') <- row_ops_for_image mrow_ops r bg region (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col')) remain_rows return (min skip_row' skip_row'', skip_col'') BGFill width height -> do let min_height = if y + (fromEnum height) > (fromEnum $! region_height region) then region_height region - (toEnum y) else min height (toEnum remain_rows) min_width = min width remaining_columns actual_height = if skip_row > min_height then 0 else min_height - skip_row actual_width = if skip_col > min_width then 0 else min_width - skip_col forM_ [y .. y + fromEnum actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y' let skip_row' = if actual_height > skip_row then 0 else skip_row - min_height skip_col' = if actual_width > skip_col then 0 else skip_col - min_width return (skip_row',skip_col') Translation (dx,dy) i -> do if dx < 0 -- Translation left -- Extract the delta and add it to skip_col. then row_ops_for_image mrow_ops (translate (0, dy) i) bg region (skip_row, skip_col + dw) y remaining_columns remain_rows -- Translation right else if dy < 0 -- Translation up -- Extract the delta and add it to skip_row. then row_ops_for_image mrow_ops (translate (dx, 0) i) bg region (skip_row + dh, skip_col) y remaining_columns remain_rows -- Translation down -- Pad the start of lines and above the image with a -- background_fill image else row_ops_for_image mrow_ops (background_fill ow dh <-> (background_fill dw ih <|> i)) bg region skip_dim y remaining_columns remain_rows where dw = toEnum $ abs dx dh = toEnum $ abs dy ow = image_width image ih = image_height i ImageCrop (max_w,max_h) i -> row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w) (min remain_rows $ fromEnum max_h) ImagePad (min_w,min_h) i -> do let hpad = if image_width i < min_w then background_fill (min_w - image_width i) (image_height i) else empty_image let vpad = if image_height i < min_h then background_fill (image_width i) (min_h - image_height i) else empty_image row_ops_for_image mrow_ops ((i <|> hpad) <-> vpad) bg region skip_dim y remaining_columns remain_rows snoc_text_span :: Attr -- the display attributes of the text span -> DisplayString -- the text to output -> MRowOps s -- the display operations to add to -> Word -- the number of display columns in the text span to -- skip before outputting -> Int -- the row of the display operations to add to -> Word -- the number of columns from the next column to be -- defined to the end of the display for the row. -> ST s Word snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do {-# SCC "snoc_text_span-pre" #-} snoc_op mrow_ops y $! AttributeChange a -- At most a text span will consist of remaining_columns characters -- we keep track of the position of the next character. let max_len :: Int = fromEnum remaining_columns mspan_chars <- Vector.new max_len ( used_display_columns, display_columns_skipped, used_char_count ) <- {-# SCC "snoc_text_span-foldlM" #-} Foldable.foldlM (build_text_span mspan_chars) ( 0, 0, 0 ) text_str -- once all characters have been output to mspan_chars we grab the used head out_text <- Vector.unsafeFreeze $! Vector.take used_char_count mspan_chars -- convert to UTF8 bytestring. -- This could be made faster. Hopefully the optimizer does a fair job at fusing the fold -- contained in fromString with the unfold in toList. No biggy right now then. {-# SCC "snoc_text_span-post" #-} snoc_op mrow_ops y $! TextSpan used_display_columns (toEnum used_char_count) $! UTF8.fromString $! Vector.toList out_text return $ columns_to_skip - display_columns_skipped where build_text_span mspan_chars (!used_display_columns, !display_columns_skipped, !used_char_count) (out_char, char_display_width) = {-# SCC "build_text_span" #-} -- Only valid if the maximum width of a character is 2 display columns. -- XXX: Optimize into a skip pass then clipped fill pass if display_columns_skipped == columns_to_skip then if used_display_columns == remaining_columns then return $! ( used_display_columns, display_columns_skipped, used_char_count ) else if ( used_display_columns + char_display_width ) > remaining_columns then do Vector.unsafeWrite mspan_chars used_char_count '…' return $! ( used_display_columns + 1 , display_columns_skipped , used_char_count + 1 ) else do Vector.unsafeWrite mspan_chars used_char_count out_char return $! ( used_display_columns + char_display_width , display_columns_skipped , used_char_count + 1 ) else if (display_columns_skipped + char_display_width) > columns_to_skip then do Vector.unsafeWrite mspan_chars used_char_count '…' return $! ( used_display_columns + 1 , columns_to_skip , used_char_count + 1 ) else return $ ( used_display_columns , display_columns_skipped + char_display_width , used_char_count ) snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s () snoc_bg_fill _row_ops _bg 0 _row = return () snoc_bg_fill mrow_ops (Background c back_attr) fill_length row = do snoc_op mrow_ops row $ AttributeChange back_attr -- By all likelyhood the background character will be an ASCII character. Which is a single -- byte in utf8. Optimize for this special case. utf8_bs <- if c <= (toEnum 255 :: Char) then let !(c_byte :: Word8) = BInt.c2w c in unsafeIOToST $ do BInt.create ( fromEnum fill_length ) $ \ptr -> mapM_ (\i -> pokeByteOff ptr i c_byte) [0 .. fromEnum (fill_length - 1)] else let !(c_bytes :: [Word8]) = encode [c] in unsafeIOToST $ do BInt.create (fromEnum fill_length * length c_bytes) $ \ptr -> mapM_ (\(i,b) -> pokeByteOff ptr i b) $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes) snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs) snoc_op :: MRowOps s -> Int -> SpanOp -> ST s () snoc_op !mrow_ops !row !op = do ops <- Vector.read mrow_ops row let ops' = Vector.snoc ops op Vector.write mrow_ops row ops' vty-4.7.0.20/src/Graphics/Vty/Terminal.hs0000644000000000000000000001432412044700037016173 0ustar0000000000000000-- | Generic Terminal interface. -- -- Defines the common interface supported by all terminals. -- -- See also: -- -- 1. Graphics.Vty.Terminal: This instantiates an abtract interface to the terminal interface based -- on the TERM and COLORTERM environment variables. -- -- 2. Graphics.Vty.Terminal.Generic: Defines the generic interface all terminals need to implement. -- -- 3. Graphics.Vty.Terminal.TerminfoBased: Defines a terminal instance that uses terminfo for all -- control strings. No attempt is made to change the character set to UTF-8 for these terminals. -- I don't know a way to reliably determine if that is required or how to do so. -- -- 4. Graphics.Vty.Terminal.XTermColor: This module contains an interface suitable for xterm-like -- terminals. These are the terminals where TERM == xterm. This does use terminfo for as many -- control codes as possible. -- -- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ScopedTypeVariables #-} module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal , Terminal(..) , TerminalHandle(..) , DisplayHandle(..) , output_picture , display_context ) where import Graphics.Vty.Terminal.Generic import Graphics.Vty.Terminal.MacOSX as MacOSX import Graphics.Vty.Terminal.XTermColor as XTermColor import Graphics.Vty.Terminal.TerminfoBased as TerminfoBased import Control.Applicative import Control.Exception ( SomeException, try ) import Control.Monad.Trans import Data.List ( isPrefixOf ) import Data.Word import System.Environment -- | Returns a TerminalHandle (an abstract Terminal instance) for the current terminal. -- -- The specific Terminal implementation used is hidden from the API user. All terminal -- implementations are assumed to perform more, or less, the same. Currently all implementations use -- terminfo for at least some terminal specific information. This is why platforms without terminfo -- are not supported. However, as mentioned before, any specifics about it being based on terminfo -- are hidden from the API user. If a terminal implementation is developed for a terminal for a -- platform without terminfo support then Vty should work as expected on that terminal. -- -- Selection of a terminal is done as follows: -- -- * If TERM == xterm -- then the terminal might be one of the Mac OS X .app terminals. Check if that might be -- the case and use MacOSX if so. -- otherwise use XTermColor. -- -- * for any other TERM value TerminfoBased is used. -- -- -- The terminal has to be determined dynamically at runtime. To satisfy this requirement all -- terminals instances are lifted into an abstract terminal handle via existential qualification. -- This implies that the only equations that can used are those in the terminal class. -- -- To differentiate between Mac OS X terminals this uses the TERM_PROGRAM environment variable. -- However, an xterm started by Terminal or iTerm *also* has TERM_PROGRAM defined since the -- environment variable is not reset/cleared by xterm. However a Terminal.app or iTerm.app started -- from an xterm under X11 on mac os x will likely be done via open. Since this does not propogate -- environment variables (I think?) this assumes that XTERM_VERSION will never be set for a true -- Terminal.app or iTerm.app session. -- -- -- The file descriptor used for output will a duplicate of the current stdout file descriptor. -- -- todo: add an implementation for windows that does not depend on terminfo. Should be installable -- with only what is provided in the haskell platform. -- -- todo: The Terminal interface does not provide any input support. terminal_handle :: ( Applicative m, MonadIO m ) => m TerminalHandle terminal_handle = do term_type <- liftIO $ getEnv "TERM" t <- if "xterm" `isPrefixOf` term_type then do maybe_terminal_app <- get_env "TERM_PROGRAM" case maybe_terminal_app of Nothing -> XTermColor.terminal_instance term_type >>= new_terminal_handle Just v | v == "Apple_Terminal" || v == "iTerm.app" -> do maybe_xterm <- get_env "XTERM_VERSION" case maybe_xterm of Nothing -> MacOSX.terminal_instance v >>= new_terminal_handle Just _ -> XTermColor.terminal_instance term_type >>= new_terminal_handle -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app -- like terminal? _ -> XTermColor.terminal_instance term_type >>= new_terminal_handle -- Not an xterm-like terminal. try for generic terminfo. else TerminfoBased.terminal_instance term_type >>= new_terminal_handle return t where get_env var = do mv <- liftIO $ try $ getEnv var case mv of Left (_e :: SomeException) -> return $ Nothing Right v -> return $ Just v -- | Sets the cursor position to the given output column and row. -- -- This is not necessarially the same as the character position with the same coordinates. -- Characters can be a variable number of columns in width. -- -- Currently, the only way to set the cursor position to a given character coordinate is to specify -- the coordinate in the Picture instance provided to output_picture or refresh. set_cursor_pos :: MonadIO m => TerminalHandle -> Word -> Word -> m () set_cursor_pos t x y = do bounds <- display_bounds t d <- display_context t bounds liftIO $ marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y) -- | Hides the cursor hide_cursor :: MonadIO m => TerminalHandle -> m () hide_cursor t = do bounds <- display_bounds t d <- display_context t bounds liftIO $ marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d) -- | Shows the cursor show_cursor :: MonadIO m => TerminalHandle -> m () show_cursor t = do bounds <- display_bounds t d <- display_context t bounds liftIO $ marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d) vty-4.7.0.20/src/Graphics/Vty/Debug/0000755000000000000000000000000012044700037015106 5ustar0000000000000000vty-4.7.0.20/src/Graphics/Vty/Debug/Image.hs0000644000000000000000000000144312044700037016466 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Graphics.Vty.Debug.Image where import Graphics.Vty.Image type ImageConstructLog = [ImageConstructEvent] data ImageConstructEvent = ImageConstructEvent deriving ( Show, Eq ) forward_image_ops :: [Image -> Image] forward_image_ops = map forward_transform debug_image_ops forward_transform, reverse_transform :: ImageOp -> (Image -> Image) forward_transform (ImageOp f _) = f reverse_transform (ImageOp _ r) = r data ImageOp = ImageOp ImageEndo ImageEndo type ImageEndo = Image -> Image debug_image_ops :: [ImageOp] debug_image_ops = [ id_image_op -- , render_single_column_char_op -- , render_double_column_char_op ] id_image_op :: ImageOp id_image_op = ImageOp id id -- render_char_op :: ImageOp -- render_char_op = ImageOp id id vty-4.7.0.20/src/Graphics/Vty/Terminal/0000755000000000000000000000000012044700037015633 5ustar0000000000000000vty-4.7.0.20/src/Graphics/Vty/Terminal/Debug.hs0000644000000000000000000001104612044700037017217 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} module Graphics.Vty.Terminal.Debug ( DebugTerminal(..) , DebugDisplay(..) , terminal_instance , dehandle ) where import Graphics.Vty.DisplayRegion import Graphics.Vty.Terminal.Generic import Control.Applicative import Control.Monad.Trans import Control.Monad.State.Strict import qualified Data.ByteString.UTF8 as BS import qualified Data.ByteString as BSCore import Data.IORef import qualified Data.Sequence as Seq import qualified Data.String.UTF8 as UTF8 import Data.Word import Foreign.Marshal.Array ( peekArray ) import Foreign.Ptr ( plusPtr ) import Foreign.Storable ( poke ) import System.IO import Unsafe.Coerce -- | The debug display terminal produces a string representation of the requested picture. There is -- *not* an isomorphism between the string representation and the picture. The string -- representation is a simplification of the picture that is only useful in debugging VTY without -- considering terminal specific issues. -- -- The debug implementation is useful in manually determining if the sequence of terminal operations -- matches the expected sequence. So requirement of the produced representation is simplicity in -- parsing the text representation and determining how the picture was mapped to terminal -- operations. -- -- All terminals support the operations specified in the Terminal class defined in -- Graphics.Vty.Terminal. As an instance of the Terminal class is also an instance of the Monad -- class there exists a monoid that defines it's algebra. The string representation is a sequence of -- identifiers where each identifier is the name of an operation in the algebra. data DebugTerminal = DebugTerminal { debug_terminal_last_output :: IORef (UTF8.UTF8 BS.ByteString) , debug_terminal_bounds :: DisplayRegion } instance Terminal DebugTerminal where terminal_ID _t = "debug_terminal" release_terminal _t = return () reserve_display _t = return () release_display _t = return () display_bounds t = return $ debug_terminal_bounds t display_terminal_instance t r c = return $ c (DebugDisplay r) output_byte_buffer t out_buffer buffer_size = liftIO $ do putStrLn $ "output_byte_buffer ?? " ++ show buffer_size peekArray (fromEnum buffer_size) out_buffer >>= return . UTF8.fromRep . BSCore.pack >>= writeIORef (debug_terminal_last_output t) output_handle t = return stdout data DebugDisplay = DebugDisplay { debug_display_bounds :: DisplayRegion } terminal_instance :: ( Applicative m, MonadIO m ) => DisplayRegion -> m TerminalHandle terminal_instance r = do output_ref <- liftIO $ newIORef undefined new_terminal_handle $ DebugTerminal output_ref r dehandle :: TerminalHandle -> DebugTerminal dehandle (TerminalHandle t _) = unsafeCoerce t instance DisplayTerminal DebugDisplay where -- | Provide the current bounds of the output terminal. context_region d = debug_display_bounds d -- | A cursor move is always visualized as the single character 'M' move_cursor_required_bytes _d _x _y = 1 -- | A cursor move is always visualized as the single character 'M' serialize_move_cursor _d _x _y ptr = do liftIO $ poke ptr (toEnum $ fromEnum 'M') return $ ptr `plusPtr` 1 -- | Show cursor is always visualized as the single character 'S' show_cursor_required_bytes _d = 1 -- | Show cursor is always visualized as the single character 'S' serialize_show_cursor _d ptr = do liftIO $ poke ptr (toEnum $ fromEnum 'S') return $ ptr `plusPtr` 1 -- | Hide cursor is always visualized as the single character 'H' hide_cursor_required_bytes _d = 1 -- | Hide cursor is always visualized as the single character 'H' serialize_hide_cursor _d ptr = do liftIO $ poke ptr (toEnum $ fromEnum 'H') return $ ptr `plusPtr` 1 -- | An attr change is always visualized as the single character 'A' attr_required_bytes _d _fattr _diffs _attr = 1 -- | An attr change is always visualized as the single character 'A' serialize_set_attr _d _fattr _diffs _attr ptr = do liftIO $ poke ptr (toEnum $ fromEnum 'A') return $ ptr `plusPtr` 1 default_attr_required_bytes _d = 1 serialize_default_attr _d ptr = do liftIO $ poke ptr (toEnum $ fromEnum 'D') return $ ptr `plusPtr` 1 vty-4.7.0.20/src/Graphics/Vty/Terminal/Generic.hs0000644000000000000000000004557412044700037017562 0ustar0000000000000000-- Copyright 2009-2011 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic , OutputBuffer ) where import Data.Marshalling import Graphics.Vty.Picture import Graphics.Vty.Span import Graphics.Vty.DisplayRegion import Graphics.Vty.DisplayAttributes import Control.Monad ( liftM ) import Control.Monad.Trans import qualified Data.ByteString.Internal as BSCore import Data.IORef import Data.String.UTF8 hiding ( foldl ) import qualified Data.Vector as Vector import System.IO data TerminalHandle where TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle state_ref :: TerminalHandle -> IORef TerminalState state_ref (TerminalHandle _ s_ref) = s_ref new_terminal_handle :: forall m t. ( MonadIO m, Terminal t ) => t -> m TerminalHandle new_terminal_handle t = do s_ref <- liftIO $ newIORef initial_terminal_state return $ TerminalHandle t s_ref data TerminalState = TerminalState { -- | The current terminal display attributes or Nothing if they are not known. known_fattr :: Maybe FixedAttr } initial_terminal_state :: TerminalState initial_terminal_state = TerminalState Nothing class Terminal t where -- | Text identifier for the terminal. Used for debugging. terminal_ID :: t -> String -- | release_terminal :: MonadIO m => t -> m () -- | Clear the display and initialize the terminal to some initial display state. -- -- The expectation of a program is that the display starts in some initial state. -- The initial state would consist of fixed values: -- - cursor at top left -- - UTF-8 character encoding -- - drawing characteristics are the default -- The abstract operation I think all these behaviors are instances of is reserving exclusive -- access to a display such that: -- - The previous state cannot be determined -- - When exclusive access to a display is release the display returns to the previous state. reserve_display :: MonadIO m => t -> m () -- | Return the display to the state before reserve_display -- If no previous state then set the display state to the initial state. release_display :: MonadIO m => t -> m () -- | Returns the current display bounds. display_bounds :: MonadIO m => t -> m DisplayRegion -- Internal method used to provide the DisplayTerminal instance to the DisplayHandle -- constructor. display_terminal_instance :: MonadIO m => t -> DisplayRegion -> (forall d. DisplayTerminal d => d -> DisplayHandle) -> m DisplayHandle -- | Output the byte buffer of the specified size to the terminal device. The size is equal to -- end_ptr - start_ptr output_byte_buffer :: t -> OutputBuffer -> Word -> IO () -- | Handle of output device output_handle :: t -> IO Handle instance Terminal TerminalHandle where terminal_ID (TerminalHandle t _) = terminal_ID t release_terminal (TerminalHandle t _) = release_terminal t reserve_display (TerminalHandle t _) = reserve_display t release_display (TerminalHandle t _) = release_display t display_bounds (TerminalHandle t _) = display_bounds t display_terminal_instance (TerminalHandle t _) = display_terminal_instance t output_byte_buffer (TerminalHandle t _) = output_byte_buffer t output_handle (TerminalHandle t _) = output_handle t data DisplayHandle where DisplayHandle :: forall d . DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle -- | Acquire display access to the given region of the display. -- Currently all regions have the upper left corner of (0,0) and the lower right corner at -- (max display_width provided_width, max display_height provided_height) display_context :: MonadIO m => TerminalHandle -> DisplayRegion -> m DisplayHandle display_context t b = do s <- initial_display_state display_terminal_instance t b (\ d -> DisplayHandle d t s) data DisplayState = DisplayState { previous_output_ref :: IORef (Maybe DisplayOps) } initial_display_state :: MonadIO m => m DisplayState initial_display_state = liftM DisplayState $ liftIO $ newIORef Nothing class DisplayTerminal d where -- | Provide the bounds of the display context. context_region :: d -> DisplayRegion -- | Maximum number of colors supported by the context. context_color_count :: d -> Word -- | sets the output position to the specified row and column. Where the number of bytes -- required for the control codes can be specified seperate from the actual byte sequence. move_cursor_required_bytes :: d -> Word -> Word -> Word serialize_move_cursor :: MonadIO m => d -> Word -> Word -> OutputBuffer -> m OutputBuffer show_cursor_required_bytes :: d -> Word serialize_show_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer hide_cursor_required_bytes :: d -> Word serialize_hide_cursor :: MonadIO m => d -> OutputBuffer -> m OutputBuffer -- | Assure the specified output attributes will be applied to all the following text until the -- next output attribute change. Where the number of bytes required for the control codes can -- be specified seperate from the actual byte sequence. The required number of bytes must be -- at least the maximum number of bytes required by any attribute changes. The serialization -- equations must provide the ptr to the next byte to be specified in the output buffer. -- -- The currently applied display attributes are provided as well. The Attr data type can -- specify the style or color should not be changed from the currently applied display -- attributes. In order to support this the currently applied display attributes are required. -- In addition it may be possible to optimize the state changes based off the currently applied -- display attributes. attr_required_bytes :: d -> FixedAttr -> Attr -> DisplayAttrDiff -> Word serialize_set_attr :: MonadIO m => d -> FixedAttr -> Attr -> DisplayAttrDiff -> OutputBuffer -> m OutputBuffer -- | Reset the display attributes to the default display attributes default_attr_required_bytes :: d -> Word serialize_default_attr :: MonadIO m => d -> OutputBuffer -> m OutputBuffer -- | See Graphics.Vty.Terminal.XTermColor.inline_hack inline_hack :: MonadIO m => d -> m () inline_hack _d = return () instance DisplayTerminal DisplayHandle where context_region (DisplayHandle d _ _) = context_region d context_color_count (DisplayHandle d _ _) = context_color_count d move_cursor_required_bytes (DisplayHandle d _ _) = move_cursor_required_bytes d serialize_move_cursor (DisplayHandle d _ _) = serialize_move_cursor d show_cursor_required_bytes (DisplayHandle d _ _) = show_cursor_required_bytes d serialize_show_cursor (DisplayHandle d _ _) = serialize_show_cursor d hide_cursor_required_bytes (DisplayHandle d _ _) = hide_cursor_required_bytes d serialize_hide_cursor (DisplayHandle d _ _) = serialize_hide_cursor d attr_required_bytes (DisplayHandle d _ _) = attr_required_bytes d serialize_set_attr (DisplayHandle d _ _) = serialize_set_attr d default_attr_required_bytes (DisplayHandle d _ _) = default_attr_required_bytes d serialize_default_attr (DisplayHandle d _ _) = serialize_default_attr d inline_hack (DisplayHandle d _ _) = inline_hack d -- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory. utf8_text_required_bytes :: UTF8 BSCore.ByteString -> Word utf8_text_required_bytes str = let (_, _, src_bytes_length) = BSCore.toForeignPtr (toRep str) in toEnum src_bytes_length -- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory. serialize_utf8_text :: MonadIO m => UTF8 BSCore.ByteString -> OutputBuffer -> m OutputBuffer serialize_utf8_text str dest_ptr = let (src_fptr, src_ptr_offset, src_bytes_length) = BSCore.toForeignPtr (toRep str) in liftIO $ withForeignPtr src_fptr $ \src_ptr -> do let src_ptr' = src_ptr `plusPtr` src_ptr_offset BSCore.memcpy dest_ptr src_ptr' (toEnum src_bytes_length) return (dest_ptr `plusPtr` src_bytes_length) -- | Displays the given `Picture`. -- -- 0. The image is cropped to the display size. -- -- 1. Converted into a sequence of attribute changes and text spans. -- -- 2. The cursor is hidden. -- -- 3. Serialized to the display. -- -- 4. The cursor is then shown and positioned or kept hidden. -- -- -- todo: specify possible IO exceptions. -- abstract from IO monad to a MonadIO instance. output_picture :: MonadIO m => DisplayHandle -> Picture -> m () output_picture (DisplayHandle d t s) pic = do let !r = context_region d let !ops = spans_for_pic pic r let !initial_attr = FixedAttr default_style_mask Nothing Nothing -- Diff the previous output against the requested output. Differences are currently on a per-row -- basis. diffs :: [Bool] <- liftIO ( readIORef (previous_output_ref s) ) >>= \mprevious_ops -> case mprevious_ops of Nothing -> return $ replicate ( fromEnum $ region_height $ effected_region ops ) True Just previous_ops -> if effected_region previous_ops /= effected_region ops then return $ replicate ( fromEnum $ region_height $ effected_region ops ) True else return $ zipWith (/=) ( Vector.toList $ display_ops previous_ops ) ( Vector.toList $ display_ops ops ) -- determine the number of bytes required to completely serialize the output ops. let total = hide_cursor_required_bytes d + default_attr_required_bytes d + required_bytes d initial_attr diffs ops + case pic_cursor pic of NoCursor -> 0 Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic ( ox, oy ) = char_to_output_pos m ( x, y ) in show_cursor_required_bytes d + move_cursor_required_bytes d ox oy -- ... then serialize liftIO $ allocaBytes (fromEnum total) $ \start_ptr -> do ptr <- serialize_hide_cursor d start_ptr ptr' <- serialize_default_attr d ptr ptr'' <- serialize_output_ops d ptr' initial_attr diffs ops end_ptr <- case pic_cursor pic of NoCursor -> return ptr'' Cursor x y -> do let m = cursor_output_map ops $ pic_cursor pic (ox, oy) = char_to_output_pos m (x,y) serialize_show_cursor d ptr'' >>= serialize_move_cursor d ox oy -- todo: How to handle exceptions? case end_ptr `minusPtr` start_ptr of count | count < 0 -> fail "End pointer before start of buffer." | toEnum count > total -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - total) | otherwise -> output_byte_buffer t start_ptr (toEnum count) -- Cache the output spans. liftIO $ writeIORef (previous_output_ref s) (Just ops) return () required_bytes :: DisplayTerminal d => d -> FixedAttr -> [Bool] -> DisplayOps -> Word required_bytes d in_fattr diffs ops = let (_, n, _, _) = Vector.foldl' required_bytes' (0, 0, in_fattr, diffs) ( display_ops ops ) in n where required_bytes' (y, current_sum, fattr, True : diffs') span_ops = let (s, fattr') = span_ops_required_bytes d y fattr span_ops in ( y + 1, s + current_sum, fattr', diffs' ) required_bytes' (y, current_sum, fattr, False : diffs') _span_ops = ( y + 1, current_sum, fattr, diffs' ) required_bytes' (_y, _current_sum, _fattr, [] ) _span_ops = error "shouldn't be possible" span_ops_required_bytes :: DisplayTerminal d => d -> Word -> FixedAttr -> SpanOps -> (Word, FixedAttr) span_ops_required_bytes d y in_fattr span_ops = -- The first operation is to set the cursor to the start of the row let header_required_bytes = move_cursor_required_bytes d 0 y -- then the span ops are serialized in the order specified in Vector.foldl' ( \(current_sum, fattr) op -> let (c, fattr') = span_op_required_bytes d fattr op in (c + current_sum, fattr') ) (header_required_bytes, in_fattr) span_ops span_op_required_bytes :: DisplayTerminal d => d -> FixedAttr -> SpanOp -> (Word, FixedAttr) span_op_required_bytes d fattr (AttributeChange attr) = let attr' = limit_attr_for_display d attr diffs = display_attr_diffs fattr fattr' c = attr_required_bytes d fattr attr' diffs fattr' = fix_display_attr fattr attr' in (c, fattr') span_op_required_bytes _d fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr) serialize_output_ops :: ( MonadIO m, DisplayTerminal d ) => d -> OutputBuffer -> FixedAttr -> [Bool] -> DisplayOps -> m OutputBuffer serialize_output_ops d start_ptr in_fattr diffs ops = do (_, end_ptr, _, _) <- Vector.foldM' serialize_output_ops' ( 0, start_ptr, in_fattr, diffs ) ( display_ops ops ) return end_ptr where serialize_output_ops' ( y, out_ptr, fattr, True : diffs' ) span_ops = serialize_span_ops d y out_ptr fattr span_ops >>= return . ( \(out_ptr', fattr') -> ( y + 1, out_ptr', fattr', diffs' ) ) serialize_output_ops' ( y, out_ptr, fattr, False : diffs' ) _span_ops = return ( y + 1, out_ptr, fattr, diffs' ) serialize_output_ops' (_y, _out_ptr, _fattr, [] ) _span_ops = error "shouldn't be possible" serialize_span_ops :: ( MonadIO m, DisplayTerminal d ) => d -> Word -> OutputBuffer -> FixedAttr -> SpanOps -> m (OutputBuffer, FixedAttr) serialize_span_ops d y out_ptr in_fattr span_ops = do -- The first operation is to set the cursor to the start of the row out_ptr' <- serialize_move_cursor d 0 y out_ptr -- then the span ops are serialized in the order specified Vector.foldM ( \(out_ptr'', fattr) op -> serialize_span_op d op out_ptr'' fattr ) (out_ptr', in_fattr) span_ops serialize_span_op :: ( MonadIO m, DisplayTerminal d ) => d -> SpanOp -> OutputBuffer -> FixedAttr -> m (OutputBuffer, FixedAttr) serialize_span_op d (AttributeChange attr) out_ptr fattr = do let attr' = limit_attr_for_display d attr fattr' = fix_display_attr fattr attr' diffs = display_attr_diffs fattr fattr' out_ptr' <- serialize_set_attr d fattr attr' diffs out_ptr return (out_ptr', fattr') serialize_span_op _d (TextSpan _ _ str) out_ptr fattr = do out_ptr' <- serialize_utf8_text str out_ptr return (out_ptr', fattr) marshall_to_terminal :: ( Terminal t ) => t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO () marshall_to_terminal t c f = do start_ptr <- mallocBytes (fromEnum c) -- -- todo: capture exceptions? end_ptr <- f start_ptr case end_ptr `minusPtr` start_ptr of count | count < 0 -> fail "End pointer before start pointer." | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c) | otherwise -> output_byte_buffer t start_ptr (toEnum count) free start_ptr return () data CursorOutputMap = CursorOutputMap { char_to_output_pos :: (Word, Word) -> (Word, Word) } cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap cursor_output_map span_ops _cursor = CursorOutputMap { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy) } cursor_column_offset :: DisplayOps -> Word -> Word -> Word cursor_column_offset span_ops cx cy = let cursor_row_ops = Vector.unsafeIndex (display_ops span_ops) (fromEnum cy) (out_offset, _, _) = Vector.foldl' ( \(d, current_cx, done) op -> if done then (d, current_cx, done) else case span_op_has_width op of Nothing -> (d, current_cx, False) Just (cw, ow) -> case compare cx (current_cx + cw) of GT -> ( d + ow , current_cx + cw , False ) EQ -> ( d + ow , current_cx + cw , True ) LT -> ( d + columns_to_char_offset (cx - current_cx) op , current_cx + cw , True ) ) (0, 0, False) cursor_row_ops in out_offset limit_attr_for_display :: DisplayTerminal d => d -> Attr -> Attr limit_attr_for_display d attr = attr { attr_fore_color = clamp_color $ attr_fore_color attr , attr_back_color = clamp_color $ attr_back_color attr } where clamp_color Default = Default clamp_color KeepCurrent = KeepCurrent clamp_color (SetTo c) = clamp_color' c clamp_color' (ISOColor v) | context_color_count d < 8 = Default | context_color_count d < 16 && v >= 8 = SetTo $ ISOColor (v - 8) | otherwise = SetTo $ ISOColor v clamp_color' (Color240 v) -- TODO: Choose closes ISO color? | context_color_count d < 8 = Default | context_color_count d < 16 = Default | context_color_count d == 240 = SetTo $ Color240 v | otherwise = let p :: Double = fromIntegral v / 240.0 v' = floor $ p * (fromIntegral $ context_color_count d) in SetTo $ Color240 v' vty-4.7.0.20/src/Graphics/Vty/Terminal/MacOSX.hs0000644000000000000000000000630512044700037017265 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor -- The standard Mac OS X terminals Terminal.app and iTerm both declare themselves to be -- "xterm-color" by default. However the terminfo database for xterm-color included with OS X is -- incomplete. -- -- This terminal implementation modifies the standard terminfo terminal as required for complete OS -- X support. {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} module Graphics.Vty.Terminal.MacOSX ( terminal_instance ) where import Graphics.Vty.Terminal.Generic import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased import Control.Applicative import Control.Monad.Trans import System.IO data Term = Term { super_term :: TerminalHandle , term_app :: String } -- for Terminal.app use "xterm". For iTerm.app use "xterm-256color" terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term terminal_instance v = do let base_term "iTerm.app" = "xterm-256color" base_term _ = "xterm" t <- TerminfoBased.terminal_instance (base_term v) >>= new_terminal_handle return $ Term t v flushed_put :: MonadIO m => String -> m () flushed_put str = do liftIO $ hPutStr stdout str liftIO $ hFlush stdout -- Terminal.app really does want the xterm-color smcup and rmcup caps. Not the generic xterm ones. smcup_str, rmcup_str :: String smcup_str = "\ESC7\ESC[?47h" rmcup_str = "\ESC[2J\ESC[?47l\ESC8" -- iTerm needs a clear screen after smcup as well? clear_screen_str :: String clear_screen_str = "\ESC[H\ESC[2J" instance Terminal Term where terminal_ID t = term_app t ++ " :: MacOSX" release_terminal t = do release_terminal $ super_term t reserve_display _t = do flushed_put smcup_str flushed_put clear_screen_str release_display _t = do flushed_put rmcup_str display_terminal_instance t b c = do d <- display_context (super_term t) b return $ c (DisplayContext d) display_bounds t = display_bounds (super_term t) output_byte_buffer t = output_byte_buffer (super_term t) output_handle t = output_handle (super_term t) data DisplayContext = DisplayContext { super_display :: DisplayHandle } instance DisplayTerminal DisplayContext where context_region d = context_region (super_display d) context_color_count d = context_color_count (super_display d) move_cursor_required_bytes d = move_cursor_required_bytes (super_display d) serialize_move_cursor d = serialize_move_cursor (super_display d) show_cursor_required_bytes d = show_cursor_required_bytes (super_display d) serialize_show_cursor d = serialize_show_cursor (super_display d) hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d) serialize_hide_cursor d = serialize_hide_cursor (super_display d) attr_required_bytes d = attr_required_bytes (super_display d) serialize_set_attr d = serialize_set_attr (super_display d) default_attr_required_bytes d = default_attr_required_bytes (super_display d) serialize_default_attr d = serialize_default_attr (super_display d) vty-4.7.0.20/src/Graphics/Vty/Terminal/TerminfoBased.hs0000644000000000000000000004574212044700037020725 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-} module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance ) where import Data.Terminfo.Parse import Data.Terminfo.Eval import Graphics.Vty.Attributes import Graphics.Vty.DisplayAttributes import Graphics.Vty.Terminal.Generic import Graphics.Vty.DisplayRegion import Control.Applicative import Control.Monad ( foldM ) import Control.Monad.Trans import Data.Bits ( (.&.) ) import Data.Maybe ( isJust, isNothing, fromJust ) import Data.Word import Foreign.C.Types ( CLong(..) ) import GHC.IO.Handle import qualified System.Console.Terminfo as Terminfo import System.IO data Term = Term { term_info_ID :: String , term_info :: Terminfo.Terminal , smcup :: Maybe CapExpression , rmcup :: Maybe CapExpression , cup :: CapExpression , cnorm :: CapExpression , civis :: CapExpression , set_fore_color :: CapExpression , set_back_color :: CapExpression , set_default_attr :: CapExpression , clear_screen :: CapExpression , display_attr_caps :: DisplayAttrCaps , term_handle :: Handle } data DisplayAttrCaps = DisplayAttrCaps { set_attr_states :: Maybe CapExpression , enter_standout :: Maybe CapExpression , exit_standout :: Maybe CapExpression , enter_underline :: Maybe CapExpression , exit_underline :: Maybe CapExpression , enter_reverse_video :: Maybe CapExpression , enter_dim_mode :: Maybe CapExpression , enter_bold_mode :: Maybe CapExpression } marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO () marshall_cap_to_terminal t cap_selector cap_params = do marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params ) ( serialize_cap_expression (cap_selector t) cap_params ) return () {- | Uses terminfo for all control codes. While this should provide the most compatible terminal - terminfo does not support some features that would increase efficiency and improve compatibility: - * determine the character encoding supported by the terminal. Should this be taken from the LANG - environment variable? - * Provide independent string capabilities for all display attributes. - - - todo: Some display attributes like underline and bold have independent string capabilities that - should be used instead of the generic "sgr" string capability. -} terminal_instance :: ( Applicative m, MonadIO m ) => String -> m Term terminal_instance in_ID = do ti <- liftIO $ Terminfo.setupTerm in_ID let require_cap str = case Terminfo.getCapability ti (Terminfo.tiGetStr str) of Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\"" Just cap_str -> do parse_result <- parse_cap_expression cap_str case parse_result of Left e -> fail $ show e Right cap -> return cap probe_cap cap_name = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of Nothing -> return Nothing Just cap_str -> do parse_result <- parse_cap_expression cap_str case parse_result of Left e -> fail $ show e Right cap -> return $ Just cap the_handle <- liftIO $ hDuplicate stdout pure Term <*> pure in_ID <*> pure ti <*> probe_cap "smcup" <*> probe_cap "rmcup" <*> require_cap "cup" <*> require_cap "cnorm" <*> require_cap "civis" <*> require_cap "setaf" <*> require_cap "setab" <*> require_cap "sgr0" <*> require_cap "clear" <*> current_display_attr_caps ti <*> pure the_handle current_display_attr_caps :: ( Applicative m, MonadIO m ) => Terminfo.Terminal -> m DisplayAttrCaps current_display_attr_caps ti = pure DisplayAttrCaps <*> probe_cap "sgr" <*> probe_cap "smso" <*> probe_cap "rmso" <*> probe_cap "smul" <*> probe_cap "rmul" <*> probe_cap "rev" <*> probe_cap "dim" <*> probe_cap "bold" where probe_cap cap_name = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of Nothing -> return Nothing Just cap_str -> do parse_result <- parse_cap_expression cap_str case parse_result of Left e -> fail $ show e Right cap -> return $ Just cap instance Terminal Term where terminal_ID t = term_info_ID t ++ " :: TerminfoBased" release_terminal t = do liftIO $ marshall_cap_to_terminal t set_default_attr [] liftIO $ marshall_cap_to_terminal t cnorm [] liftIO $ hClose $ term_handle t return () reserve_display t = do if (isJust $ smcup t) then liftIO $ marshall_cap_to_terminal t (fromJust . smcup) [] else return () -- Screen on OS X does not appear to support smcup? -- To approximate the expected behavior: clear the screen and then move the mouse to the -- home position. liftIO $ hFlush stdout liftIO $ marshall_cap_to_terminal t clear_screen [] return () release_display t = do if (isJust $ rmcup t) then liftIO $ marshall_cap_to_terminal t (fromJust . rmcup) [] else return () liftIO $ marshall_cap_to_terminal t cnorm [] return () display_terminal_instance t b c = do let color_count = case Terminfo.getCapability (term_info t) (Terminfo.tiGetNum "colors" ) of Nothing -> 8 Just v -> toEnum v return $ c (DisplayContext b t color_count) display_bounds _t = do raw_size <- liftIO $ get_window_size case raw_size of ( w, h ) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h) -- | Output the byte buffer of the specified size to the terminal device. output_byte_buffer t out_ptr out_byte_count = do -- if the out fd is actually the same as stdout's then a -- flush is required *before* the c_output_byte_buffer call -- otherwise there may still be data in GHC's internal stdout buffer. -- _ <- handleToFd stdout hPutBuf (term_handle t) out_ptr (fromEnum out_byte_count) hFlush (term_handle t) output_handle t = return (term_handle t) foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size :: IO CLong get_window_size :: IO (Int,Int) get_window_size = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size return (fromIntegral b, fromIntegral a) data DisplayContext = DisplayContext { bounds :: DisplayRegion , term :: Term , supported_colors :: Word } instance DisplayTerminal DisplayContext where context_region d = bounds d context_color_count d = supported_colors d move_cursor_required_bytes d x y = cap_expression_required_bytes (cup $ term d) [y, x] serialize_move_cursor d x y out_ptr = liftIO $ serialize_cap_expression (cup $ term d) [y, x] out_ptr show_cursor_required_bytes d = cap_expression_required_bytes (cnorm $ term d) [] serialize_show_cursor d out_ptr = liftIO $ serialize_cap_expression (cnorm $ term d) [] out_ptr hide_cursor_required_bytes d = cap_expression_required_bytes (civis $ term d) [] serialize_hide_cursor d out_ptr = liftIO $ serialize_cap_expression (civis $ term d) [] out_ptr -- Instead of evaluating all the rules related to setting display attributes twice (once in -- required bytes and again in serialize) or some memoization scheme just return a size -- requirement as big the longest possible control string. -- -- Which is assumed to the be less than 512 for now. -- -- \todo Not verified as safe and wastes memory. attr_required_bytes _d _prev_attr _req_attr _diffs = 512 -- Portably setting the display attributes is a giant pain in the ass. -- If the terminal supports the sgr capability (which sets the on/off state of each style -- directly ; and, for no good reason, resets the colors to the default) this always works: -- 0. set the style attributes. This resets the fore and back color. -- 1, If a foreground color is to be set then set the foreground color -- 2. likewise with the background color -- -- If the terminal does not support the sgr then -- if there is a change from an applied color to the default (in either the fore or back color) -- then: -- 0. reset all display attributes (sgr0) -- 1. enter required style modes -- 2. set the fore color if required -- 3. set the back color if required -- -- Entering the required style modes could require a reset of the display attributes. If this is -- the case then the back and fore colors always need to be set if not default. -- -- All this (I think) is satisfied by the following logic: serialize_set_attr d prev_attr req_attr diffs out_ptr = do case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of -- The only way to reset either color, portably, to the default is to use either the set -- state capability or the set default capability. True -> do case req_display_cap_seq_for ( display_attr_caps $ term d ) ( fixed_style attr ) ( style_to_apply_seq $ fixed_style attr ) of EnterExitSeq caps -- only way to reset a color to the defaults -> serialize_default_attr d out_ptr >>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps) >>= set_colors SetState state -- implicitly resets the colors to the defaults -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states $ display_attr_caps $ term d ) ( sgr_args_for_state state ) out_ptr >>= set_colors -- Otherwise the display colors are not changing or changing between two non-default -- points. False -> do -- Still, it could be the case that the change in display attributes requires the -- colors to be reset because the required capability was not available. case req_display_cap_seq_for ( display_attr_caps $ term d ) ( fixed_style attr ) ( style_diffs diffs ) of -- Really, if terminals were re-implemented with modern concepts instead of -- bowing down to 40 yr old dumb terminal requirements this would be the -- only case ever reached! -- Changes the style and color states according to the differences with the -- currently applied states. EnterExitSeq caps -> liftIO ( foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps ) >>= apply_color_diff set_fore_color ( fore_color_diff diffs ) >>= apply_color_diff set_back_color ( back_color_diff diffs ) SetState state -- implicitly resets the colors to the defaults -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states $ display_attr_caps $ term d ) ( sgr_args_for_state state ) out_ptr >>= set_colors where attr = fix_display_attr prev_attr req_attr set_colors ptr = do ptr' <- case fixed_fore_color attr of Just c -> liftIO $ serialize_cap_expression ( set_fore_color $ term d ) [ ansi_color_index c ] ptr Nothing -> return ptr ptr'' <- case fixed_back_color attr of Just c -> liftIO $ serialize_cap_expression ( set_back_color $ term d ) [ ansi_color_index c ] ptr' Nothing -> return ptr' return ptr'' apply_color_diff _f NoColorChange ptr = return ptr apply_color_diff _f ColorToDefault _ptr = fail "ColorToDefault is not a possible case for apply_color_diffs" apply_color_diff f ( SetColor c ) ptr = liftIO $ serialize_cap_expression ( f $ term d ) [ ansi_color_index c ] ptr default_attr_required_bytes d = cap_expression_required_bytes (set_default_attr $ term d) [] serialize_default_attr d out_ptr = do liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr ansi_color_index :: Color -> Word ansi_color_index (ISOColor v) = toEnum $ fromEnum v ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v ) {- The sequence of terminfo caps to apply a given style are determined according to these rules. - - 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than - the full set display attribute state capability. - - 2. If a mode is supposed to be removed but there is not an exit capability defined then the - display attributes are reset to defaults then the display attribute state is set. - - 3. If a mode is supposed to be applied but there is not an enter capability defined then then - display attribute state is set if possible. Otherwise the mode is not applied. - - 4. If the display attribute state is being set then just update the arguments to that for any - apply/remove. - -} data DisplayAttrSeq = EnterExitSeq [CapExpression] | SetState DisplayAttrState data DisplayAttrState = DisplayAttrState { apply_standout :: Bool , apply_underline :: Bool , apply_reverse_video :: Bool , apply_blink :: Bool , apply_dim :: Bool , apply_bold :: Bool } sgr_args_for_state :: DisplayAttrState -> [CapParam] sgr_args_for_state attr_state = map (\b -> if b then 1 else 0) [ apply_standout attr_state , apply_underline attr_state , apply_reverse_video attr_state , apply_blink attr_state , apply_dim attr_state , apply_bold attr_state , False -- invis , False -- protect , False -- alt char set ] req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq req_display_cap_seq_for caps s diffs -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap -- then either the state needs to be set or the attribute change ignored. = case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of -- If all the diffs have an enter-exit cap then just use those ( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out -- all unsupported diffs and just apply the rest ( True, False ) -> EnterExitSeq $ map enter_exit_cap $ filter (not . no_enter_exit_cap) diffs -- if not all the diffs have an enter-exit can and there is a set state cap then just use -- the set state cap. ( True, True ) -> SetState $ state_for_style s where no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps no_enter_exit_cap RemoveReverseVideo = True no_enter_exit_cap ApplyBlink = True no_enter_exit_cap RemoveBlink = True no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps no_enter_exit_cap RemoveDim = True no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps no_enter_exit_cap RemoveBold = True enter_exit_cap ApplyStandout = fromJust $ enter_standout caps enter_exit_cap RemoveStandout = fromJust $ exit_standout caps enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one." state_for_style :: Style -> DisplayAttrState state_for_style s = DisplayAttrState { apply_standout = is_style_set standout , apply_underline = is_style_set underline , apply_reverse_video = is_style_set reverse_video , apply_blink = is_style_set blink , apply_dim = is_style_set dim , apply_bold = is_style_set bold } where is_style_set = has_style s style_to_apply_seq :: Style -> [StyleStateChange] style_to_apply_seq s = concat [ apply_if_required ApplyStandout standout , apply_if_required ApplyUnderline underline , apply_if_required ApplyReverseVideo reverse_video , apply_if_required ApplyBlink blink , apply_if_required ApplyDim dim , apply_if_required ApplyBlink bold ] where apply_if_required ap flag = if 0 == ( flag .&. s ) then [] else [ ap ] vty-4.7.0.20/src/Graphics/Vty/Terminal/XTermColor.hs0000644000000000000000000000714012044700037020227 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} module Graphics.Vty.Terminal.XTermColor ( terminal_instance ) where import Graphics.Vty.Terminal.Generic import qualified Graphics.Vty.Terminal.TerminfoBased as TerminfoBased import Control.Applicative import Control.Monad.Trans import qualified Data.String.UTF8 as UTF8 import System.IO data XTermColor = XTermColor { xterm_variant :: String , super_term :: TerminalHandle } -- Initialize the display to UTF-8 -- Regardless of what is output the text encoding is assumed to be UTF-8 terminal_instance :: ( Applicative m, MonadIO m ) => String -> m XTermColor terminal_instance variant = do -- If the terminal variant is xterm-color use xterm instead since, more often than not, -- xterm-color is broken. let variant' = if variant == "xterm-color" then "xterm" else variant flushed_put set_utf8_char_set t <- TerminfoBased.terminal_instance variant' >>= new_terminal_handle return $ XTermColor variant' t flushed_put :: MonadIO m => String -> m () flushed_put str = do liftIO $ hPutStr stdout str liftIO $ hFlush stdout -- Since I don't know of a terminfo string cap that produces these strings these are hardcoded. set_utf8_char_set, set_default_char_set :: String set_utf8_char_set = "\ESC%G" set_default_char_set = "\ESC%@" instance Terminal XTermColor where terminal_ID t = (show $ xterm_variant t) ++ " :: XTermColor" release_terminal t = do flushed_put set_default_char_set release_terminal $ super_term t reserve_display t = reserve_display (super_term t) release_display t = release_display (super_term t) display_terminal_instance t b c = do d <- display_context (super_term t) b return $ c (DisplayContext d) display_bounds t = display_bounds (super_term t) output_byte_buffer t = output_byte_buffer (super_term t) output_handle t = output_handle (super_term t) data DisplayContext = DisplayContext { super_display :: DisplayHandle } instance DisplayTerminal DisplayContext where context_region d = context_region (super_display d) context_color_count d = context_color_count (super_display d) move_cursor_required_bytes d = move_cursor_required_bytes (super_display d) serialize_move_cursor d = serialize_move_cursor (super_display d) show_cursor_required_bytes d = show_cursor_required_bytes (super_display d) serialize_show_cursor d = serialize_show_cursor (super_display d) hide_cursor_required_bytes d = hide_cursor_required_bytes (super_display d) serialize_hide_cursor d = serialize_hide_cursor (super_display d) attr_required_bytes d = attr_required_bytes (super_display d) serialize_set_attr d = serialize_set_attr (super_display d) default_attr_required_bytes d = default_attr_required_bytes (super_display d) serialize_default_attr d = serialize_default_attr (super_display d) -- I think xterm is broken: Reseting the background color as the first bytes serialized on a new -- line does not effect the background color xterm uses to clear the line. Which is used *after* -- the next newline. inline_hack d = do let t = case super_display d of DisplayHandle _ t_ _ -> t_ let s_utf8 = UTF8.fromString "\ESC[K" liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8) ( serialize_utf8_text s_utf8 ) vty-4.7.0.20/test/0000755000000000000000000000000012044700037011726 5ustar0000000000000000vty-4.7.0.20/test/Verify.hs0000644000000000000000000000457612044700037013542 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} module Verify ( module Verify , module Test.QuickCheck , succeeded , failed , result , monadicIO , liftIO , liftBool , Test(..) , Prop.Result(..) ) where import Distribution.TestSuite hiding ( Result(..) ) import qualified Distribution.TestSuite as TS import Test.QuickCheck hiding ( Result(..) ) import qualified Test.QuickCheck as QC import Test.QuickCheck.Property hiding ( Result(..) ) import qualified Test.QuickCheck.Property as Prop import Test.QuickCheck.Monadic ( monadicIO ) import qualified Codec.Binary.UTF8.String as UTF8 import Control.Monad.State.Strict import Data.IORef import Data.Word import Numeric ( showHex ) import System.IO import System.Random verify :: Testable t => String -> t -> Test verify test_name p = Test $ TestInstance { name = test_name , run = do qc_result <- quickCheckResult p case qc_result of QC.Success {..} -> return $ Finished TS.Pass _ -> return $ Finished $ TS.Fail "TODO(corey): add failure message" , tags = [] , options = [] , setOption = \_ _ -> Left "no options supported" } data SingleColumnChar = SingleColumnChar Char deriving (Show, Eq) instance Arbitrary SingleColumnChar where arbitrary = elements $ map SingleColumnChar [toEnum 0x21 .. toEnum 0x7E] data DoubleColumnChar = DoubleColumnChar Char deriving (Eq) instance Show DoubleColumnChar where show (DoubleColumnChar c) = "(0x" ++ showHex (fromEnum c) "" ++ ") ->" ++ UTF8.encodeString [c] instance Arbitrary DoubleColumnChar where arbitrary = elements $ map DoubleColumnChar $ [ toEnum 0x3040 .. toEnum 0x3098 ] ++ [ toEnum 0x309B .. toEnum 0xA4CF ] liftIOResult :: Testable prop => IO prop -> Property liftIOResult = morallyDubiousIOProperty #if __GLASGOW_HASKELL__ <= 701 instance Random Word where random g = let (i :: Int, g') = random g in (toEnum i, g') randomR (l,h) g = let (i :: Int, g') = randomR (fromEnum l,fromEnum h) g in (toEnum i, g') #endif vty-4.7.0.20/test/VerifyAttributeOps.hs0000644000000000000000000000017512044700037016077 0ustar0000000000000000module VerifyAttributeOps where import Verify.Graphics.Vty.Attributes import Verify tests :: IO [Test] tests = return [] vty-4.7.0.20/test/VerifyDisplayAttributes.hs0000644000000000000000000000025612044700037017126 0ustar0000000000000000module VerifyDisplayAttributes where import Verify.Graphics.Vty.DisplayAttributes import Verify.Graphics.Vty.Attributes import Verify tests :: IO [Test] tests = return [] vty-4.7.0.20/test/VerifyEmptyImageProps.hs0000644000000000000000000000045512044700037016540 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module VerifyEmptyImageProps where import Verify -- should be exported by Graphics.Vty.Picture import Graphics.Vty.Picture ( Image, empty_image ) tests :: IO [Test] tests = do -- should provide an image type. let _ :: Image = empty_image return [] vty-4.7.0.20/test/VerifyEvalTerminfoCaps.hs0000644000000000000000000000757612044700037016670 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns #-} module VerifyEvalTerminfoCaps where import Data.Marshalling import Data.Terminfo.Eval import Data.Terminfo.Parse import Control.DeepSeq import qualified System.Console.Terminfo as Terminfo import Verify import Control.Applicative ( (<$>) ) import Control.Exception ( try, SomeException(..) ) import Control.Monad ( mapM_, forM, forM_ ) import Data.Maybe ( fromJust ) import Data.Word import Numeric -- A list of terminals that ubuntu includes a terminfo cap file for. -- Assuming that is a good place to start. terminals_of_interest = [ "wsvt25" , "wsvt25m" , "vt52" , "vt100" , "vt220" , "vt102" , "xterm-r5" , "xterm-xfree86" , "xterm-r6" , "xterm-256color" , "xterm-vt220" , "xterm-debian" , "xterm-mono" , "xterm-color" , "xterm" , "mach" , "mach-bold" , "mach-color" , "linux" , "ansi" , "hurd" , "Eterm" , "pcansi" , "screen-256color" , "screen-bce" , "screen-s" , "screen-w" , "screen" , "screen-256color-bce" , "sun" , "rxvt" , "rxvt-unicode" , "rxvt-basic" , "cygwin" , "cons25" , "dumb" ] -- If a terminal defines one of the caps then it's expected to be parsable. caps_of_interest = [ "cup" , "sc" , "rc" , "setf" , "setb" , "setaf" , "setab" , "op" , "cnorm" , "civis" , "smcup" , "rmcup" , "clear" , "hpa" , "vpa" , "sgr" , "sgr0" ] from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) tests :: IO [Test] tests = do eval_buffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-) fmap concat $ forM terminals_of_interest $ \term_name -> do putStrLn $ "adding tests for terminal: " ++ term_name mti <- try $ Terminfo.setupTerm term_name case mti of Left (_e :: SomeException) -> return [] Right ti -> do fmap concat $ forM caps_of_interest $ \cap_name -> do case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of Just cap_def -> do putStrLn $ "\tadding test for cap: " ++ cap_name let test_name = term_name ++ "(" ++ cap_name ++ ")" parse_result <- parse_cap_expression cap_def case parse_result of Left error -> return [ verify test_name ( failed { reason = "parse error " ++ show error } ) ] Right !cap_expr -> return [ verify test_name ( verify_eval_cap eval_buffer cap_expr ) ] Nothing -> do return [] {-# NOINLINE verify_eval_cap #-} verify_eval_cap :: Ptr Word8 -> CapExpression -> Int -> Property verify_eval_cap eval_buffer expr !junk_int = do forAll (vector 9) $ \input_values -> let !byte_count = cap_expression_required_bytes expr input_values in liftIOResult $ do let start_ptr :: Ptr Word8 = eval_buffer forM_ [0..100] $ \i -> serialize_cap_expression expr input_values start_ptr end_ptr <- serialize_cap_expression expr input_values start_ptr case end_ptr `minusPtr` start_ptr of count | count < 0 -> return $ failed { reason = "End pointer before start pointer." } | toEnum count > byte_count -> return $ failed { reason = "End pointer past end of buffer by " ++ show (toEnum count - byte_count) } | otherwise -> return succeeded vty-4.7.0.20/test/VerifyImageOps.hs0000644000000000000000000001413412044700037015156 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module VerifyImageOps where import Graphics.Vty.Attributes import Verify.Graphics.Vty.Image import Verify import Data.Word two_sw_horiz_concat :: SingleColumnChar -> SingleColumnChar -> Bool two_sw_horiz_concat (SingleColumnChar c1) (SingleColumnChar c2) = image_width (char def_attr c1 <|> char def_attr c2) == 2 many_sw_horiz_concat :: [SingleColumnChar] -> Bool many_sw_horiz_concat cs = let chars = [ char | SingleColumnChar char <- cs ] l = fromIntegral $ length cs in image_width ( horiz_cat $ map (char def_attr) chars ) == l two_sw_vert_concat :: SingleColumnChar -> SingleColumnChar -> Bool two_sw_vert_concat (SingleColumnChar c1) (SingleColumnChar c2) = image_height (char def_attr c1 <-> char def_attr c2) == 2 horiz_concat_sw_assoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool horiz_concat_sw_assoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2 == char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2) two_dw_horiz_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool two_dw_horiz_concat (DoubleColumnChar c1) (DoubleColumnChar c2) = image_width (char def_attr c1 <|> char def_attr c2) == 4 many_dw_horiz_concat :: [DoubleColumnChar] -> Bool many_dw_horiz_concat cs = let chars = [ char | DoubleColumnChar char <- cs ] l = fromIntegral $ length cs in image_width ( horiz_cat $ map (char def_attr) chars ) == l * 2 two_dw_vert_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool two_dw_vert_concat (DoubleColumnChar c1) (DoubleColumnChar c2) = image_height (char def_attr c1 <-> char def_attr c2) == 2 horiz_concat_dw_assoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool horiz_concat_dw_assoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2 == char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2) vert_contat_single_row :: NonEmptyList SingleRowSingleAttrImage -> Bool vert_contat_single_row (NonEmpty stack) = let expected_height :: Word = fromIntegral $ length stack stack_image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack ] in image_height stack_image == expected_height disjoint_height_horiz_join :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjoint_height_horiz_join (NonEmpty stack_0) (NonEmpty stack_1) = let expected_height :: Word = fromIntegral $ max (length stack_0) (length stack_1) stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ] stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ] in image_height (stack_image_0 <|> stack_image_1) == expected_height disjoint_height_horiz_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjoint_height_horiz_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) = let stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ] stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ] image = stack_image_0 <|> stack_image_1 expected_height = image_height image in case image of HorizJoin {} -> ( expected_height == (image_height $ part_left image) ) && ( expected_height == (image_height $ part_right image) ) _ -> True disjoint_width_vert_join :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjoint_width_vert_join (NonEmpty stack_0) (NonEmpty stack_1) = let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images) stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ] stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ] stack_0_image = vert_cat stack_0_images stack_1_image = vert_cat stack_1_images image = stack_0_image <-> stack_1_image in image_width image == expected_width disjoint_width_vert_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) = let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images) stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ] stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ] stack_0_image = vert_cat stack_0_images stack_1_image = vert_cat stack_1_images image = stack_0_image <-> stack_1_image in case image of VertJoin {} -> ( expected_width == (image_width $ part_top image) ) && ( expected_width == (image_width $ part_bottom image) ) _ -> True tests :: IO [Test] tests = return [ verify "two_sw_horiz_concat" two_sw_horiz_concat , verify "many_sw_horiz_concat" many_sw_horiz_concat , verify "two_sw_vert_concat" two_sw_vert_concat , verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc , verify "many_dw_horiz_concat" many_dw_horiz_concat , verify "two_dw_horiz_concat" two_dw_horiz_concat , verify "two_dw_vert_concat" two_dw_vert_concat , verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc , verify "single row vert concats to correct height" vert_contat_single_row , verify "disjoint_height_horiz_join" disjoint_height_horiz_join , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill , verify "disjoint_width_vert_join" disjoint_width_vert_join , verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill ] vty-4.7.0.20/test/VerifyImageTrans.hs0000644000000000000000000000300212044700037015474 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} module VerifyImageTrans where import Verify.Graphics.Vty.Image import Verify import Data.Word is_horiz_text_of_columns :: Image -> Word -> Bool is_horiz_text_of_columns (HorizText { output_width = in_w }) expected_w = in_w == expected_w is_horiz_text_of_columns (BGFill { output_width = in_w }) expected_w = in_w == expected_w is_horiz_text_of_columns _image _expected_w = False verify_horiz_contat_wo_attr_change_simplifies :: SingleRowSingleAttrImage -> Bool verify_horiz_contat_wo_attr_change_simplifies (SingleRowSingleAttrImage _attr char_count image) = is_horiz_text_of_columns image char_count verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 _image0) (SingleRowSingleAttrImage attr1 char_count1 _image1) i ) | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1) | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1) tests :: IO [Test] tests = return [ verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies , verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies ] vty-4.7.0.20/test/VerifyInline.hs0000644000000000000000000000073412044700037014671 0ustar0000000000000000module VerifyInline where import Graphics.Vty.Inline import Graphics.Vty.Terminal import Verify import Distribution.TestSuite tests :: IO [Test] tests = return [ Test $ TestInstance { name = "verify vty inline" , run = do t <- terminal_handle put_attr_change t $ default_all return $ Finished Pass , tags = [] , options = [] , setOption = \_ _ -> Left "no options supported" } ] vty-4.7.0.20/test/VerifyMockTerminal.hs0000644000000000000000000001332012044700037016033 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module VerifyMockTerminal where import Verify.Graphics.Vty.DisplayRegion import Verify.Graphics.Vty.Picture import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.Span import Graphics.Vty.Terminal import Graphics.Vty.Terminal.Debug import Graphics.Vty.Debug import Verify import qualified Data.ByteString as BS import Data.IORef import qualified Data.String.UTF8 as UTF8 import System.IO unit_image_unit_bounds :: UnitImage -> Property unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do t <- terminal_instance (DisplayRegion 1 1) d <- display_bounds t >>= display_context t let pic = pic_for_image i output_picture d pic return succeeded unit_image_arb_bounds :: UnitImage -> DebugWindow -> Property unit_image_arb_bounds (UnitImage _ i) (DebugWindow w h) = liftIOResult $ do t <- terminal_instance (DisplayRegion w h) d <- display_bounds t >>= display_context t let pic = pic_for_image i output_picture d pic return succeeded single_T_row :: DebugWindow -> Property single_T_row (DebugWindow w h) = liftIOResult $ do t <- terminal_instance (DisplayRegion w h) d <- display_bounds t >>= display_context t -- create an image that contains just the character T repeated for a single row let i = horiz_cat $ replicate (fromEnum w) (char def_attr 'T') pic = (pic_for_image i) { pic_background = Background 'B' def_attr } output_picture d pic out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep -- The UTF8 string that represents the output bytes a single line containing the T string: let expected = "HD" ++ "MA" ++ replicate (fromEnum w) 'T' -- Followed by h - 1 lines of a change to the background attribute and then the background -- character ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows :: DebugWindow -> Property many_T_rows (DebugWindow w h) = liftIOResult $ do t <- terminal_instance (DisplayRegion w h) d <- display_bounds t >>= display_context t -- create an image that contains the character 'T' repeated for all the rows let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T') pic = (pic_for_image i) { pic_background = Background 'B' def_attr } output_picture d pic out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an -- attribute change. 'A', followed by w 'T's let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows_cropped_width :: DebugWindow -> Property many_T_rows_cropped_width (DebugWindow w h) = liftIOResult $ do t <- terminal_instance (DisplayRegion w h) d <- display_bounds t >>= display_context t -- create an image that contains the character 'T' repeated for all the rows let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w * 2) (char def_attr 'T') pic = (pic_for_image i) { pic_background = Background 'B' def_attr } output_picture d pic out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an -- attribute change. 'A', followed by w 'T's let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows_cropped_height :: DebugWindow -> Property many_T_rows_cropped_height (DebugWindow w h) = liftIOResult $ do t <- terminal_instance (DisplayRegion w h) d <- display_bounds t >>= display_context t -- create an image that contains the character 'T' repeated for all the rows let i = vert_cat $ replicate (fromEnum h * 2) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T') pic = (pic_for_image i) { pic_background = Background 'B' def_attr } output_picture d pic out_bytes <- readIORef (debug_terminal_last_output $ dehandle t) >>= return . UTF8.toRep -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an -- attribute change. 'A', followed by w count 'T's let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded tests :: IO [Test] tests = return [ verify "unit_image_unit_bounds" unit_image_unit_bounds , verify "unit_image_arb_bounds" unit_image_arb_bounds , verify "single_T_row" single_T_row , verify "many_T_rows" many_T_rows , verify "many_T_rows_cropped_width" many_T_rows_cropped_width , verify "many_T_rows_cropped_height" many_T_rows_cropped_height ] vty-4.7.0.20/test/VerifyParseTerminfoCaps.hs0000644000000000000000000001220412044700037017033 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns #-} module VerifyParseTerminfoCaps where import Prelude hiding ( catch ) import qualified System.Console.Terminfo as Terminfo import Verify.Data.Terminfo.Parse import Verify import Control.Applicative ( (<$>) ) import Control.Exception ( try, SomeException(..) ) import Control.Monad ( mapM_, forM, forM_ ) import Data.Maybe ( catMaybes, fromJust ) import Data.Word import Numeric -- A list of terminals that ubuntu includes a terminfo cap file for. -- Assuming that is a good place to start. terminals_of_interest = [ "wsvt25" , "wsvt25m" , "vt52" , "vt100" , "vt220" , "vt102" , "xterm-r5" , "xterm-xfree86" , "xterm-r6" , "xterm-256color" , "xterm-vt220" , "xterm-debian" , "xterm-mono" , "xterm-color" , "xterm" , "mach" , "mach-bold" , "mach-color" , "linux" , "ansi" , "hurd" , "Eterm" , "pcansi" , "screen-256color" , "screen-bce" , "screen-s" , "screen-w" , "screen" , "screen-256color-bce" , "sun" , "rxvt" , "rxvt-unicode" , "rxvt-basic" , "cygwin" , "cons25" , "dumb" ] -- If a terminal defines one of the caps then it's expected to be parsable. caps_of_interest = [ "cup" , "sc" , "rc" , "setf" , "setb" , "setaf" , "setab" , "op" , "cnorm" , "civis" , "smcup" , "rmcup" , "clear" , "hpa" , "vpa" , "sgr" , "sgr0" ] from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) tests :: IO [Test] tests = do parse_tests <- concat <$> forM terminals_of_interest ( \term_name -> do putStrLn $ "testing parsing of caps for terminal: " ++ term_name mti <- liftIO $ try $ Terminfo.setupTerm term_name case mti of Left (_e :: SomeException) -> return [] Right ti -> do concat <$> forM caps_of_interest ( \cap_name -> do liftIO $ putStrLn $ "\tparsing cap: " ++ cap_name case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of Just cap_def -> do return [ verify ( "\tparse cap " ++ cap_name ++ " -> " ++ show cap_def ) ( verify_parse_cap cap_def $ const (return succeeded) ) ] Nothing -> do return [] ) ) -- The quickcheck tests return $ [ verify "parse_non_paramaterized_caps" non_paramaterized_caps , verify "parse cap string with literal %" literal_percent_caps , verify "parse cap string with %i op" inc_first_two_caps , verify "parse cap string with %pN op" push_param_caps ] ++ parse_tests verify_parse_cap cap_string on_parse = liftIOResult $ do parse_result <- parse_cap_expression cap_string case parse_result of Left error -> return $ failed { reason = "parse error " ++ show error } Right e -> on_parse e non_paramaterized_caps (NonParamCapString cap) = do verify_parse_cap cap $ \e -> let expected_count :: Word8 = toEnum $ length cap expected_bytes = map (toEnum . fromEnum) cap out_bytes = bytes_for_range e 0 expected_count in return $ verify_bytes_equal out_bytes expected_bytes literal_percent_caps (LiteralPercentCap cap_string expected_bytes) = do verify_parse_cap cap_string $ \e -> let expected_count :: Word8 = toEnum $ length expected_bytes out_bytes = collect_bytes e in return $ verify_bytes_equal out_bytes expected_bytes inc_first_two_caps (IncFirstTwoCap cap_string expected_bytes) = do verify_parse_cap cap_string $ \e -> let expected_count :: Word8 = toEnum $ length expected_bytes out_bytes = collect_bytes e in return $ verify_bytes_equal out_bytes expected_bytes push_param_caps (PushParamCap cap_string expected_param_count expected_bytes) = do verify_parse_cap cap_string $ \e -> let expected_count :: Word8 = toEnum $ length expected_bytes out_bytes = collect_bytes e out_param_count = param_count e in return $ if out_param_count == expected_param_count then verify_bytes_equal out_bytes expected_bytes else failed { reason = "out param count /= expected param count" } dec_print_param_caps (DecPrintCap cap_string expected_param_count expected_bytes) = do verify_parse_cap cap_string $ \e -> let expected_count :: Word8 = toEnum $ length expected_bytes out_bytes = collect_bytes e out_param_count = param_count e in return $ if out_param_count == expected_param_count then verify_bytes_equal out_bytes expected_bytes else failed { reason = "out param count /= expected param count" } print_cap ti cap_name = do putStrLn $ cap_name ++ ": " ++ show (from_capname ti cap_name) print_expression ti cap_name = do parse_result <- parse_cap_expression $ from_capname ti cap_name putStrLn $ cap_name ++ ": " ++ show parse_result vty-4.7.0.20/test/VerifyPictureOps.hs0000644000000000000000000000017612044700037015550 0ustar0000000000000000module VerifyPictureOps where import Graphics.Vty.Picture ( translate ) import Verify tests :: IO [Test] tests = return [] vty-4.7.0.20/test/VerifyPictureToSpan.hs0000644000000000000000000000025712044700037016213 0ustar0000000000000000module VerifyPictureToSpan where import Graphics.Vty.Picture import Graphics.Vty.Span import Graphics.Vty.PictureToSpans import Verify tests :: IO [Test] tests = return [] vty-4.7.0.20/test/VerifySpanOps.hs0000644000000000000000000002316412044700037015040 0ustar0000000000000000{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} module VerifySpanOps where import Verify.Graphics.Vty.Picture import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.Span import Verify.Graphics.Vty.DisplayRegion import Graphics.Vty.Debug import Verify import qualified Data.Vector as Vector unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool unit_image_and_zero_window_0 (UnitImage _ i) (EmptyWindow w) = let p = pic_for_image i spans = spans_for_pic p (region_for_window w) in span_ops_columns spans == 0 && span_ops_rows spans == 0 unit_image_and_zero_window_1 :: UnitImage -> EmptyWindow -> Bool unit_image_and_zero_window_1 (UnitImage _ i) (EmptyWindow w) = let p = pic_for_image i spans = spans_for_pic p (region_for_window w) in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 ) horiz_span_image_and_zero_window_0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool horiz_span_image_and_zero_window_0 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) = let p = pic_for_image i spans = spans_for_pic p (region_for_window w) in span_ops_columns spans == 0 && span_ops_rows spans == 0 horiz_span_image_and_zero_window_1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool horiz_span_image_and_zero_window_1 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) = let p = pic_for_image i spans = spans_for_pic p (region_for_window w) in ( span_ops_effected_rows spans == 0 ) && ( all_spans_have_width spans 0 ) horiz_span_image_and_equal_window_0 :: SingleRowSingleAttrImage -> Result horiz_span_image_and_equal_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) = let p = pic_for_image i w = DebugWindow c 1 spans = spans_for_pic p (region_for_window w) in verify_all_spans_have_width i spans c horiz_span_image_and_equal_window_1 :: SingleRowSingleAttrImage -> Bool horiz_span_image_and_equal_window_1 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) = let p = pic_for_image i w = DebugWindow c 1 spans = spans_for_pic p (region_for_window w) in span_ops_effected_rows spans == 1 horiz_span_image_and_lesser_window_0 :: SingleRowSingleAttrImage -> Result horiz_span_image_and_lesser_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) = let p = pic_for_image i lesser_width = c `div` 2 w = DebugWindow lesser_width 1 spans = spans_for_pic p (region_for_window w) in verify_all_spans_have_width i spans lesser_width single_attr_single_span_stack_cropped_0 :: SingleAttrSingleSpanStack -> Result single_attr_single_span_stack_cropped_0 stack = let p = pic_for_image (stack_image stack) w = DebugWindow (stack_width stack `div` 2) (stack_height stack) spans = spans_for_pic p (region_for_window w) in verify_all_spans_have_width (stack_image stack) spans (stack_width stack `div` 2) single_attr_single_span_stack_cropped_1 :: SingleAttrSingleSpanStack -> Bool single_attr_single_span_stack_cropped_1 stack = let p = pic_for_image (stack_image stack) expected_row_count = stack_height stack `div` 2 w = DebugWindow (stack_width stack) expected_row_count spans = spans_for_pic p (region_for_window w) actual_row_count = span_ops_effected_rows spans in expected_row_count == actual_row_count single_attr_single_span_stack_cropped_2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result single_attr_single_span_stack_cropped_2 stack_0 stack_1 = let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1) w = DebugWindow (stack_width stack_0) (image_height (pic_image p)) spans = spans_for_pic p (region_for_window w) in verify_all_spans_have_width (pic_image p) spans (stack_width stack_0) single_attr_single_span_stack_cropped_3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool single_attr_single_span_stack_cropped_3 stack_0 stack_1 = let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1) w = DebugWindow (image_width (pic_image p)) expected_row_count spans = spans_for_pic p (region_for_window w) expected_row_count = image_height (pic_image p) `div` 2 actual_row_count = span_ops_effected_rows spans in expected_row_count == actual_row_count single_attr_single_span_stack_cropped_4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result single_attr_single_span_stack_cropped_4 stack_0 stack_1 = let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1) w = DebugWindow expected_width (image_height (pic_image p)) spans = spans_for_pic p (region_for_window w) expected_width = image_width (pic_image p) `div` 2 in verify_all_spans_have_width (pic_image p) spans expected_width single_attr_single_span_stack_cropped_5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool single_attr_single_span_stack_cropped_5 stack_0 stack_1 = let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1) w = DebugWindow (image_width (pic_image p)) (stack_height stack_0) spans = spans_for_pic p (region_for_window w) expected_row_count = stack_height stack_0 actual_row_count = span_ops_effected_rows spans in expected_row_count == actual_row_count horiz_span_image_and_greater_window_0 :: SingleRowSingleAttrImage -> Result horiz_span_image_and_greater_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) = let p = pic_for_image i -- SingleRowSingleAttrImage always has width >= 1 greater_width = c * 2 w = DebugWindow greater_width 1 spans = spans_for_pic p (region_for_window w) in verify_all_spans_have_width i spans greater_width arb_image_is_cropped :: DefaultImage -> DebugWindow -> Bool arb_image_is_cropped (DefaultImage image _) win@(DebugWindow w h) = let pic = pic_for_image image spans = spans_for_pic pic (region_for_window win) in ( span_ops_effected_rows spans == h ) && ( all_spans_have_width spans w ) span_ops_actually_fill_rows :: DefaultPic -> Bool span_ops_actually_fill_rows (DefaultPic pic win _) = let spans = spans_for_pic pic (region_for_window win) expected_row_count = region_height (region_for_window win) actual_row_count = span_ops_effected_rows spans in expected_row_count == actual_row_count span_ops_actually_fill_columns :: DefaultPic -> Bool span_ops_actually_fill_columns (DefaultPic pic win _) = let spans = spans_for_pic pic (region_for_window win) expected_column_count = region_width (region_for_window win) in all_spans_have_width spans expected_column_count first_span_op_sets_attr :: DefaultPic -> Bool first_span_op_sets_attr DefaultPic { default_pic = pic, default_win = win } = let spans = spans_for_pic pic (region_for_window win) in all ( is_attr_span_op . Vector.head ) ( Vector.toList $ display_ops spans ) single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result single_attr_single_span_stack_op_coverage stack = let p = pic_for_image (stack_image stack) w = DebugWindow (stack_width stack) (stack_height stack) spans = spans_for_pic p (region_for_window w) in verify_all_spans_have_width (stack_image stack) spans (stack_width stack) tests :: IO [Test] tests = return [ verify "unit image is cropped when window size == (0,0) [0]" unit_image_and_zero_window_0 , verify "unit image is cropped when window size == (0,0) [1]" unit_image_and_zero_window_1 , verify "horiz span image is cropped when window size == (0,0) [0]" horiz_span_image_and_zero_window_0 , verify "horiz span image is cropped when window size == (0,0) [1]" horiz_span_image_and_zero_window_1 , verify "horiz span image is not cropped when window size == size of image [width]" horiz_span_image_and_equal_window_0 , verify "horiz span image is not cropped when window size == size of image [height]" horiz_span_image_and_equal_window_1 , verify "horiz span image is not cropped when window size < size of image [width]" horiz_span_image_and_lesser_window_0 , verify "horiz span image is not cropped when window size > size of image [width]" horiz_span_image_and_greater_window_0 , verify "arbitrary image is padded or cropped" arb_image_is_cropped , verify "The span ops actually define content for all the rows in the output region" span_ops_actually_fill_rows , verify "The span ops actually define content for all the columns in the output region" span_ops_actually_fill_columns , verify "first span op is always to set the text attribute" first_span_op_sets_attr , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]" single_attr_single_span_stack_op_coverage , verify "a single attr text span is cropped when window size < size of stack image [width]" single_attr_single_span_stack_cropped_0 , verify "a single attr text span is cropped when window size < size of stack image [height]" single_attr_single_span_stack_cropped_1 , verify "single attr text span <|> single attr text span cropped. [width]" single_attr_single_span_stack_cropped_2 , verify "single attr text span <|> single attr text span cropped. [height]" single_attr_single_span_stack_cropped_3 , verify "single attr text span <-> single attr text span cropped. [width]" single_attr_single_span_stack_cropped_4 , verify "single attr text span <-> single attr text span cropped. [height]" single_attr_single_span_stack_cropped_5 ] vty-4.7.0.20/test/VerifyUtf8Width.hs0000644000000000000000000000071712044700037015302 0ustar0000000000000000module VerifyUtf8Width where import Verify import Graphics.Vty.Attributes import Graphics.Vty.Picture sw_is_1_column :: SingleColumnChar -> Bool sw_is_1_column (SingleColumnChar c) = image_width (char def_attr c) == 1 dw_is_2_column :: DoubleColumnChar -> Bool dw_is_2_column (DoubleColumnChar c) = image_width (char def_attr c) == 2 tests :: IO [Test] tests = return [ verify "sw_is_1_column" sw_is_1_column , verify "dw_is_2_column" dw_is_2_column ] vty-4.7.0.20/test/Verify/0000755000000000000000000000000012044700037013172 5ustar0000000000000000vty-4.7.0.20/test/Verify/Data/0000755000000000000000000000000012044700037014043 5ustar0000000000000000vty-4.7.0.20/test/Verify/Data/Terminfo/0000755000000000000000000000000012044700037015626 5ustar0000000000000000vty-4.7.0.20/test/Verify/Data/Terminfo/Parse.hs0000644000000000000000000001001112044700037017225 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse , module Data.Terminfo.Parse ) where import Data.Terminfo.Parse import Data.Terminfo.Eval import Verify import Data.Word import Numeric instance Show CapExpression where show c = "CapExpression { " ++ show (cap_ops c) ++ " }" ++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! source_string c ) ++ "]" ++ " <= " ++ show (source_string c) hex_dump :: [Word8] -> String hex_dump bytes = foldr (\b s -> showHex b s) "" bytes data NonParamCapString = NonParamCapString String deriving Show instance Arbitrary NonParamCapString where arbitrary = ( do s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%') return $ NonParamCapString s ) `suchThat` ( \(NonParamCapString str) -> length str < 255 ) data LiteralPercentCap = LiteralPercentCap String [Word8] deriving ( Show ) instance Arbitrary LiteralPercentCap where arbitrary = ( do NonParamCapString s <- arbitrary (s', bytes) <- insert_escape_op "%" [toEnum $ fromEnum '%'] s return $ LiteralPercentCap s' bytes ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 ) data IncFirstTwoCap = IncFirstTwoCap String [Word8] deriving ( Show ) instance Arbitrary IncFirstTwoCap where arbitrary = ( do NonParamCapString s <- arbitrary (s', bytes) <- insert_escape_op "i" [] s return $ IncFirstTwoCap s' bytes ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) data PushParamCap = PushParamCap String Word [Word8] deriving ( Show ) instance Arbitrary PushParamCap where arbitrary = ( do NonParamCapString s <- arbitrary n :: Word <- choose (1,9) >>= return . toEnum (s', bytes) <- insert_escape_op ("p" ++ show n) [] s return $ PushParamCap s' n bytes ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) data DecPrintCap = DecPrintCap String Word [Word8] deriving ( Show ) instance Arbitrary DecPrintCap where arbitrary = ( do NonParamCapString s <- arbitrary n :: Word <- choose (1,9) >>= return . toEnum (s', bytes) <- insert_escape_op ("p" ++ show n ++ "%d") [] s return $ DecPrintCap s' n bytes ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) insert_escape_op op_str repl_bytes s = do insert_points <- listOf1 $ elements [0 .. length s - 1] let s' = f s ('%' : op_str) remaining_bytes = f (map (toEnum . fromEnum) s) repl_bytes f in_vs out_v = concat [ vs | vi <- zip in_vs [0 .. length s - 1] , let vs = fst vi : ( if snd vi `elem` insert_points then out_v else [] ) ] return (s', remaining_bytes) is_bytes_op :: CapOp -> Bool is_bytes_op (Bytes {}) = True -- is_bytes_op _ = False bytes_for_range cap offset c = take (fromEnum c) $ drop (fromEnum offset) $ ( map ( toEnum . fromEnum ) $! source_string cap ) collect_bytes :: CapExpression -> [Word8] collect_bytes e = concat [ bytes | Bytes offset c _ <- cap_ops e , let bytes = bytes_for_range e offset c ] verify_bytes_equal :: [Word8] -> [Word8] -> Result verify_bytes_equal out_bytes expected_bytes = if out_bytes == expected_bytes then succeeded else failed { reason = "out_bytes [" ++ hex_dump out_bytes ++ "] /= expected_bytes [" ++ hex_dump expected_bytes ++ "]" } vty-4.7.0.20/test/Verify/Graphics/0000755000000000000000000000000012044700037014732 5ustar0000000000000000vty-4.7.0.20/test/Verify/Graphics/Vty/0000755000000000000000000000000012044700037015514 5ustar0000000000000000vty-4.7.0.20/test/Verify/Graphics/Vty/Attributes.hs0000644000000000000000000000212312044700037020174 0ustar0000000000000000module Verify.Graphics.Vty.Attributes ( module Verify.Graphics.Vty.Attributes , module Graphics.Vty.Attributes ) where import Graphics.Vty.Attributes import Verify import Data.List ( delete ) -- Limit the possible attributes to just a few for now. possible_attr_mods :: [ AttrOp ] possible_attr_mods = [ set_bold_op , id_op ] instance Arbitrary Attr where arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr data DiffAttr = DiffAttr Attr Attr instance Arbitrary DiffAttr where arbitrary = do op0 <- elements possible_attr_mods let possible_attr_mods' = delete op0 possible_attr_mods op1 <- elements possible_attr_mods' return $ DiffAttr (apply_op op0 def_attr) (apply_op op1 def_attr) data AttrOp = AttrOp String (Attr -> Attr) instance Eq AttrOp where AttrOp n0 _ == AttrOp n1 _ = n0 == n1 set_bold_op = AttrOp "set_bold" (flip with_style bold) id_op = AttrOp "id" id apply_op :: AttrOp -> Attr -> Attr apply_op (AttrOp _ f) a = f a vty-4.7.0.20/test/Verify/Graphics/Vty/DisplayRegion.hs0000644000000000000000000000142012044700037020616 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Verify.Graphics.Vty.DisplayRegion ( module Verify.Graphics.Vty.DisplayRegion , module Graphics.Vty.DisplayRegion , DebugWindow(..) ) where import Graphics.Vty.Debug import Graphics.Vty.DisplayRegion import Verify import Data.Word data EmptyWindow = EmptyWindow DebugWindow instance Arbitrary EmptyWindow where arbitrary = return $ EmptyWindow (DebugWindow (0 :: Word) (0 :: Word)) instance Show EmptyWindow where show (EmptyWindow _) = "EmptyWindow" instance Arbitrary DebugWindow where arbitrary = do w <- choose (1,1024) h <- choose (1,1024) return $ DebugWindow w h vty-4.7.0.20/test/Verify/Graphics/Vty/Image.hs0000644000000000000000000000603412044700037017075 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image , module Graphics.Vty.Image ) where import Verify.Graphics.Vty.Attributes import Graphics.Vty.Debug.Image import Graphics.Vty.Image import Verify import Data.Word data UnitImage = UnitImage Char Image instance Arbitrary UnitImage where arbitrary = do SingleColumnChar c <- arbitrary return $ UnitImage c (char def_attr c) instance Show UnitImage where show (UnitImage c _) = "UnitImage " ++ show c data DefaultImage = DefaultImage Image ImageConstructLog instance Show DefaultImage where show (DefaultImage i image_log) = "DefaultImage (" ++ show i ++ ") " ++ show (image_width i, image_height i) ++ " " ++ show image_log instance Arbitrary DefaultImage where arbitrary = do i <- return $ char def_attr 'X' -- elements forward_image_ops >>= return . (\op -> op empty_image) return $ DefaultImage i [] data SingleRowSingleAttrImage = SingleRowSingleAttrImage { expected_attr :: Attr , expected_columns :: Word , row_image :: Image } instance Show SingleRowSingleAttrImage where show (SingleRowSingleAttrImage attr columns image) = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )" instance Arbitrary SingleRowSingleAttrImage where arbitrary = do -- The text must contain at least one character. Otherwise the image simplifies to the -- IdImage which has a height of 0. If this is to represent a single row then the height -- must be 1 single_column_row_text <- resize 128 (listOf1 arbitrary) attr <- arbitrary return $ SingleRowSingleAttrImage attr ( fromIntegral $ length single_column_row_text ) ( horiz_cat $ [ char attr c | SingleColumnChar c <- single_column_row_text ] ) data SingleRowTwoAttrImage = SingleRowTwoAttrImage { part_0 :: SingleRowSingleAttrImage , part_1 :: SingleRowSingleAttrImage , join_image :: Image } deriving Show instance Arbitrary SingleRowTwoAttrImage where arbitrary = do p0 <- arbitrary p1 <- arbitrary return $ SingleRowTwoAttrImage p0 p1 (row_image p0 <|> row_image p1) data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack { stack_image :: Image , stack_source_images :: [SingleRowSingleAttrImage] , stack_width :: Word , stack_height :: Word } deriving Show instance Arbitrary SingleAttrSingleSpanStack where arbitrary = do image_list <- resize 128 (listOf1 arbitrary) let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ] return $ SingleAttrSingleSpanStack image image_list ( maximum $ map expected_columns image_list ) ( toEnum $ length image_list ) vty-4.7.0.20/test/Verify/Graphics/Vty/Picture.hs0000644000000000000000000000322112044700037017461 0ustar0000000000000000{-# LANGUAGE DisambiguateRecordFields #-} module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture , module Graphics.Vty.Picture ) where import Graphics.Vty.Picture import Graphics.Vty.Debug import Verify.Graphics.Vty.Attributes import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.DisplayRegion import Verify data DefaultPic = DefaultPic { default_pic :: Picture , default_win :: DebugWindow , default_construct_log :: ImageConstructLog } instance Show DefaultPic where show (DefaultPic pic win image_log) = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n\t" ++ show image_log ++ "\n" instance Arbitrary DefaultPic where arbitrary = do DefaultImage image image_construct_events <- arbitrary let win = DebugWindow (image_width image) (image_height image) return $ DefaultPic (pic_for_image image) win image_construct_events data PicWithBGAttr = PicWithBGAttr { with_attr_pic :: Picture , with_attr_win :: DebugWindow , with_attr_construct_log :: ImageConstructLog , with_attr_specified_attr :: Attr } deriving ( Show ) instance Arbitrary PicWithBGAttr where arbitrary = do DefaultImage image image_construct_events <- arbitrary let win = DebugWindow (image_width image) (image_height image) attr <- arbitrary return $ PicWithBGAttr (pic_for_image image) win image_construct_events attr vty-4.7.0.20/test/Verify/Graphics/Vty/Span.hs0000644000000000000000000000161612044700037016755 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module Verify.Graphics.Vty.Span ( module Verify.Graphics.Vty.Span , module Graphics.Vty.Span ) where import Graphics.Vty.Debug import Graphics.Vty.Span import Verify.Graphics.Vty.Picture import Data.Word import Verify is_attr_span_op :: SpanOp -> Bool is_attr_span_op AttributeChange {} = True is_attr_span_op _ = False verify_all_spans_have_width i spans w = case all_spans_have_width spans w of True -> succeeded False -> failed { reason = "Not all spans contained operations defining exactly " ++ show w ++ " columns of output -\n" ++ show i ++ "\n->\n" ++ show spans }