vty-5.4.0/0000755000000000000000000000000012563510500010525 5ustar0000000000000000vty-5.4.0/vty.cabal0000644000000000000000000005023712563510500012342 0ustar0000000000000000name: vty version: 5.4.0 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. . Developers: See the "Graphics.Vty" module. . Users: See the "Graphics.Vty.Config" module. . If your terminal is not behaving as expected the results of the vty-interactive-terminal-test executable should be sent to the Vty maintainter to aid in debugging the issue. . Notable infelicities: Assumes UTF-8 character encoding support by the terminal; Poor signal handling; Requires terminfo. . This project is hosted on github.com: . > git clone git://github.com/coreyoconnor/vty.git . © 2006-2007 Stefan O'Rear; BSD3 license. . © Corey O'Connor; BSD3 license. cabal-version: >= 1.18 build-type: Simple data-files: README.md, TODO, AUTHORS, CHANGELOG, LICENSE tested-with: GHC >= 7.6.2 library default-language: Haskell2010 build-depends: base >= 4 && < 5, blaze-builder >= 0.3.3.2 && < 0.5, bytestring, containers, data-default >= 0.5.3, deepseq >= 1.1 && < 1.5, directory, filepath >= 1.0 && < 2.0, lens >= 3.9.0.2 && < 5.0, -- required for nice installation with yi hashable >= 1.2, mtl >= 1.1.1.0 && < 2.3, parallel >= 2.2 && < 3.3, parsec >= 2 && < 4, stm, terminfo >= 0.3 && < 0.5, transformers >= 0.3.0.0, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 exposed-modules: Graphics.Vty Graphics.Vty.Attributes Graphics.Vty.Config Graphics.Vty.Error Graphics.Vty.Image Graphics.Vty.Inline Graphics.Vty.Inline.Unsafe Graphics.Vty.Input Graphics.Vty.Input.Events Graphics.Vty.Picture Graphics.Vty.Prelude Graphics.Vty.Output Graphics.Text.Width -- the modules below are only meant to be used by the tests. Codec.Binary.UTF8.Debug Data.Terminfo.Parse Data.Terminfo.Eval Graphics.Vty.Debug Graphics.Vty.DisplayAttributes Graphics.Vty.Image.Internal Graphics.Vty.Input.Classify Graphics.Vty.Input.Loop Graphics.Vty.Input.Terminfo Graphics.Vty.PictureToSpans Graphics.Vty.Span Graphics.Vty.Output.Mock Graphics.Vty.Output.Interface Graphics.Vty.Output.XTermColor Graphics.Vty.Output.TerminfoBased other-modules: Graphics.Vty.Attributes.Color Graphics.Vty.Attributes.Color240 Graphics.Vty.Debug.Image Graphics.Vty.Input.Terminfo.ANSIVT c-sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c include-dirs: cbits hs-source-dirs: src default-extensions: ScopedTypeVariables ForeignFunctionInterface ghc-options: -O2 -funbox-strict-fields -threaded -Wall -fspec-constr -fspec-constr-count=10 ghc-prof-options: -O2 -funbox-strict-fields -threaded -caf-all -Wall -fspec-constr -fspec-constr-count=10 cc-options: -O2 executable vty-demo main-is: Demo.hs default-language: Haskell2010 default-extensions: ScopedTypeVariables ghc-options: -threaded build-depends: vty, base >= 4 && < 5, containers, data-default >= 0.5.3, lens, mtl >= 1.1.1.0 && < 2.3 test-suite verify-attribute-ops default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyAttributeOps build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-using-mock-terminal default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyUsingMockTerminal other-modules: Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Prelude Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span Verify.Graphics.Vty.Output build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, terminfo >= 0.3 && < 0.5, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-terminal default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyOutput other-modules: Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Prelude Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span Verify.Graphics.Vty.Output build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, data-default >= 0.5.3, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, terminfo >= 0.3 && < 0.5, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-display-attributes default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyDisplayAttributes other-modules: Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.DisplayAttributes Verify.Graphics.Vty.Prelude Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-empty-image-props default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyEmptyImageProps other-modules: Verify build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-eval-terminfo-caps default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyEvalTerminfoCaps other-modules: Verify Verify.Graphics.Vty.Output build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, blaze-builder >= 0.3.3.2 && < 0.5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, terminfo >= 0.3 && < 0.5, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-image-ops default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyImageOps other-modules: Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Image build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-image-trans default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyImageTrans other-modules: Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Image build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-inline default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyInline other-modules: Verify Verify.Graphics.Vty.Output build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-parse-terminfo-caps default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyParseTerminfoCaps other-modules: Verify Verify.Data.Terminfo.Parse Verify.Graphics.Vty.Output build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, terminfo >= 0.3 && < 0.5, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-simple-span-generation default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifySimpleSpanGeneration other-modules: Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Prelude Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-crop-span-generation default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyCropSpanGeneration other-modules: Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Prelude Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-layers-span-generation default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyLayersSpanGeneration other-modules: Verify Verify.Graphics.Vty.Attributes Verify.Graphics.Vty.Prelude Verify.Graphics.Vty.Picture Verify.Graphics.Vty.Image Verify.Graphics.Vty.Span build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-utf8-width default-language: Haskell2010 default-extensions: ScopedTypeVariables type: detailed-0.9 hs-source-dirs: test test-module: VerifyUtf8Width other-modules: Verify build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, mtl >= 1.1.1.0 && < 2.3, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 test-suite verify-using-mock-input default-language: Haskell2010 default-extensions: ScopedTypeVariables type: exitcode-stdio-1.0 hs-source-dirs: test main-is: VerifyUsingMockInput.hs build-depends: vty, Cabal >= 1.20, data-default >= 0.5.3, QuickCheck >= 2.7, smallcheck == 1.*, quickcheck-assertions >= 0.1.1, test-framework == 0.8.*, test-framework-smallcheck == 0.2.*, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, lens >= 3.9.0.2 && < 5.0, mtl >= 1.1.1.0 && < 2.3, stm, terminfo >= 0.3 && < 0.5, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 ghc-options: -threaded -Wall test-suite verify-config default-language: Haskell2010 default-extensions: ScopedTypeVariables type: exitcode-stdio-1.0 hs-source-dirs: test main-is: VerifyConfig.hs build-depends: vty, Cabal >= 1.20, data-default >= 0.5.3, HUnit, QuickCheck >= 2.7, smallcheck == 1.*, quickcheck-assertions >= 0.1.1, test-framework == 0.8.*, test-framework-smallcheck == 0.2.*, test-framework-hunit, random >= 1.0 && < 1.2, base >= 4 && < 5, bytestring, containers, deepseq >= 1.1 && < 1.5, lens >= 3.9.0.2 && < 5.0, mtl >= 1.1.1.0 && < 2.3, string-qq, terminfo >= 0.3 && < 0.5, text >= 0.11.3, unix, utf8-string >= 0.3 && < 1.1, vector >= 0.7 ghc-options: -threaded -Wall vty-5.4.0/README.md0000644000000000000000000000571212563510500012011 0ustar0000000000000000[![Build Status](https://travis-ci.org/coreyoconnor/vty.png)](https://travis-ci.org/coreyoconnor/vty) `vty` is a terminal interface library. This project is hosted on github.com: https://github.com/coreyoconnor/vty Install via `git` with: ``` git clone git://github.com/coreyoconnor/vty.git ``` Install via `cabal` with: ``` cabal install vty ``` # Features * Support for a large number of terminals. vt100, ansi, hurd, linux, screen etc etc. Anything with a sufficient terminfo entry. * Automatic handling of window resizes. * If the terminal support UTF-8 then vty supports Unicode output. * Handles multi-column glyphs. (Requires user to properly configure terminal.) * Efficient output. Output buffering and terminal state changes are minimized. * Minimizes repaint area. Virtually eliminating the flicker problems 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 for lone ESC. The timeout is customizable. * Interface is designed for easy compatible extension. * Supports ANSI graphics modes (SGR as defined in console_codes(4)) with a type-safe interface. Gracefull fallback for terminals that do not support, or partially support the standard ANSI graphics modes. * Properly handles cleanup, but not due to signals. * Comprehensive test suite. # Known Issues * Terminals have numerous quirks and bugs. vty picks what works best for the author in ambigious, or buggy situations. * Signal handling of STOP, TERM and INT are non existent. * The character encoding of the terminal is assumed to be UTF-8 if unicode is used. * Terminfo is assumed to be correct unless there is an override configured. Some terminals will not have correct special key support (shifted F10 etc). See Config for customizing vty's behavior for a particular terminal. * Uses the TIOCGWINSZ ioctl to find the current window size, which appears to be limited to Linux and BSD. # Platform Support ## Posix Terminals Uses terminfo to determine terminal protocol. With some special rules to handle some omissions from terminfo. ## Windows cygwin only. # Development Notes ## Under NixOS After installing ncurses to user env. ~~~ LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal configure --enable-tests --extra-lib-dirs=$HOME/.nix-profile/lib LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal build LIBRARY_PATH=$HOME/.nix-profile/lib/ cabal test ~~~ ## Coverage As of last testing, profiling causes issues with coverage when enabled. To evaluate coverage configure as follows: ~~~ rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \ --disable-library-profiling \ --disable-executable-profiling ~~~ ## Profiling ~~~ rm -rf dist ; cabal configure --enable-tests --disable-library-coverage \ --enable-library-profiling \ --enable-executable-profiling ~~~ vty-5.4.0/LICENSE0000644000000000000000000000303212563510500011530 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-5.4.0/AUTHORS0000644000000000000000000000073212563510500011577 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 * Dmitry Ivanov Plus others.. Check the git log for a full list. vty-5.4.0/Setup.lhs0000644000000000000000000000011312563510500012330 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMainvty-5.4.0/CHANGELOG0000644000000000000000000003122512563510500011742 0ustar00000000000000005.4.0 - Changed eventChannel of Graphics.Vty.Input from Chan to TChan. This enables clients to query if there are no pending events. The Graphics.Vty interface nextEvent is unchanged. Clients that use eventChannel directly will require updating. https://github.com/coreyoconnor/vty/issues/60 5.3.1 - Reverted cabal file to depend on Cabal >= 1.18 instead of 1.20 due to possibly breaking this on reasonable GHC versions 5.3 - Upgraded QuickCheck dependency to 2.7 - The standard IO Config (standardIOConfig) was overriding any provided application config. In addition, the inputFd and outputFd could not be changed if mkVty was used. Fixed. - Correct handling of display attributes at end of line. The output attributes are set to default at the end of content for the line and at the start of a new line. Previously the current attribute would extend to the next start of content. This was odd to reason about and was the cause of https://github.com/coreyoconnor/vty/issues/76 IIRC Yi requires the old behavior to display the selection region correctly. - shutdown of the input thread is now performed using killThread and synchronization on an MVar. For correct handling of the terminal read vmin and vtime the read must be a blocking read on an OS thread. This places a threadWaitRead, which will be interrupted by the killThread, prior to the uninterruptable read. An alternative would be to re-import the read foreign call as interruptable. 5.2.11 - deepseq bounds increased for tests. - Clean up warnings when compiling on 7.10 - Thanks Eric Mertens - Avoid discarding input bytes after multi-byte encoded codepoint - Thanks Eric Mertens 5.2.10 - "str" now returns EmptyImage for empty strings to match behavior of other string-like Image constructors (fixes #74) - Thanks Jonathan Daugherty 5.2.9 - dependency version bumps - https://github.com/coreyoconnor/vty/pull/71 - https://github.com/coreyoconnor/vty/pull/70 - Correct/Simplify the example code - Thanks glguy - https://github.com/coreyoconnor/vty/pull/69 5.2.8 - blaze-builder, lens, utf8-string version constraint bump - Thanks glguy - https://github.com/coreyoconnor/vty/pull/67 - Do not differentiate based on TERM_PROGRAM - https://github.com/coreyoconnor/vty/issues/68 5.2.7 - lens and deepseq constraint bump + misc - Thanks ethercrow - https://github.com/coreyoconnor/vty/pull/66 5.2.6 - lens constraint bump - Thanks alexander-b! - https://github.com/coreyoconnor/vty/pull/64 5.2.5 - lens and random version constraint bump. - Thanks RyanGlScott! - https://github.com/coreyoconnor/vty/pull/62 5.2.4 - removed -fpic from cc-options. No longer required. - https://github.com/coreyoconnor/vty/issues/61 - https://ghc.haskell.org/trac/ghc/ticket/9657 - Thanks Fuuzetsu! 5.2.3 - evaluate/compile the input parsing table once instead of each keystroke. - https://github.com/coreyoconnor/vty/pull/59 - Thanks ethercrow! 5.2.2 - When looking at input for an event, don't look too deep. - https://github.com/coreyoconnor/vty/pull/57 - Thanks ethercrow! 5.2.1 - Bump upper version bound for lens to 4.5. Thanks markus1189! 5.2.0 - Config structure now specifies file descriptor to use. The default is stdInput and stdOutput file descriptors. Previously Vty used stdInput for input and the follow code for output: - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering` NoBuffering) - the difference was required by Vty.Inline. Now, Vty.Inline uses the Config structure options to acheive the same effect. - removed: derivedVtime, derivedVmin, inputForCurrentTerminal, inputForNameAndIO, outputForCurrentTerminal, outputForNameAndIO - added: inputForConfig, outputForConfig - updates to vty-rogue from jtdaugherty. Thanks! - the oldest version of GHC tested to support vty is 7.6.2. - the oldest version of GHC that vty compiles under is 7.4.2 5.1.4 - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi! 5.1.1 - merged https://github.com/coreyoconnor/vty/pull/48 thanks sjmielke! - jtdaugherty resolved a number of compiler warnings. Thanks! 5.1.0 - vmin and vtime can be specified however the application requires. See Graphics.Vty.Config. - fixed the processing of input when vmin is set > 1. 5.0.0 - The naming convention now matches: - http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions - all projects using vty for input must be compiled with -threaded. Please notify vty author if this is not acceptable. - mkVtyEscDelay has been removed. Use "mkVty def". Which initialized vty with the default configuration. - input handling changes - KASCII is now KChar - KPN5 is now KCenter - tests exist. - Applications can add to the input tables by setting inputMap of the Config. See Graphics.Vty.Config - Users can define input table extensions that will apply to all vty applications. See Graphics.Vty.Config - terminal timing is now handled by selecting an appropriate VTIME. Previously this was implemented within Vty itself. This reduced complexity in vty but provides a different meta key behavior and implies a requirement on -threaded. - The time vty will wait to verify an ESC byte means a single ESC key is the singleEscPeriod of the Input Config structure. - removed the typeclass based terminal and display context interface in favor of a data structure of properties interface. - renamed the Terminal interface to Output - The default picture for an image now uses the "clear" background. This background fills background spans with spaces or just ends the line. - Previously the background defaulted to the space character. This causes issues copying text from a text editor. The text would end up with extra spaces at the end of the line. - Layer support - Each layer is an image. - The layers for a picture are a list of images. - The first image is the top-most layer. The images are ordered from top to bottom. - The transparent areas for a layer are the backgroundFill areas. backgroundFill is added to pad images when images of different sizes are joined. - If the background is clear there is no background layer. - If there is a background character then the bottom layer is the background layer. - emptyPicture is a Picture with no layers and no cursor - addToTop and addToBottom add a layer to the top and bottom of the given Picture. - compatibility improvements: - terminfo based terminals with no cursor support are silently accepted. The cursor visibility changes in the Picture will have no effect. - alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a guess. - added "rgbColor" for easy support of RGB specified colors. - Both applications and users can add to the mapping used to translate from input bytes to events. - Additional information about input and output process can be appended to a debug log - Set environment variable VTY_DEBUG_LOG to path of debug log - Or use "debugLog " config directive - Or set 'debugLog' property of the Config provided to mkVty. - examples moved to vty-examples package. See test directory for cabal file. - vty-interactive-terminal-test - interactive test. Useful for building a bug report for vty's author. - test/interactive_terminal_test.hs - vty-event-echo - view a input event log for vty. Example of interacting with user. - test/EventEcho.hs - vty-rogue - The start of a rogue-like game. Example of layers and image build operations. - test/Rogue.hs - vty-benchmark - benchmarks vty. A series of tests that push random pictures to the terminal. The random pictures are generated using QuickCheck. The same generators used in the automated tests. - test/benchmark.hs 4.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-5.4.0/TODO0000644000000000000000000000140712563510500011217 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-5.4.0/Demo.hs0000644000000000000000000000627012563510500011752 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Main where import Graphics.Vty import Control.Applicative hiding ((<|>)) import Control.Arrow import Control.Monad.RWS import Data.Default (def) import Data.Sequence (Seq, (<|) ) import qualified Data.Sequence as Seq import Data.Foldable eventBufferSize = 1000 type App = RWST Vty () (Seq String) IO main = do vty <- if True -- change to false for emacs-like input processing then mkVty def else mkVty (def { vmin = Just 2, vtime = Just 300 } ) _ <- execRWST (vtyInteract False) vty Seq.empty shutdown vty vtyInteract :: Bool -> App () vtyInteract shouldExit = do updateDisplay unless shouldExit $ handleNextEvent >>= vtyInteract introText = vertCat $ map (string defAttr) [ "this line is hidden by the top layer" , "The vty demo program will echo the events generated by the pressed keys." , "Below there is a 240 color box." , "Followed by a description of the 16 color pallete." , "If the 240 color box is not visible then the terminal" , "claims 240 colors are not supported." , "Try setting TERM to xterm-256color" , "This text is on a lower layer than the event list." , "Which means it'll be hidden soon." , "Bye!" , "Great Faith in the ¯\\_(ツ)_/¯" , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯" ] colorbox_240 :: Image colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages where colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239] splitColorImages [] = [] splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is)) colorbox_16 :: Image colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border where column0 = vertCat $ map lineWithColor normal column1 = vertCat $ map lineWithColor bright border = vertCat $ replicate (length normal) $ string defAttr " | " column2 = vertCat $ map (string defAttr . snd) normal lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName normal = zip [ black, red, green, yellow, blue, magenta, cyan, white ] [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ] bright = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue , brightMagenta, brightCyan, brightWhite ] [ "bright black", "bright red", "bright green", "bright yellow" , "bright blue", "bright magenta", "bright cyan", "bright white" ] updateDisplay :: App () updateDisplay = do let info = string (defAttr `withForeColor` black `withBackColor` green) "Press ESC to exit. Events for keys below." eventLog <- foldMap (string defAttr) <$> get let pic = picForImage (info <-> eventLog) `addToBottom` (introText <-> colorbox_240 <|> colorbox_16) vty <- ask liftIO $ update vty pic handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent where handleEvent e = do modify $ (<|) (show e) >>> Seq.take eventBufferSize return $ e == EvKey KEsc [] vty-5.4.0/dist/0000755000000000000000000000000012563510500011470 5ustar0000000000000000vty-5.4.0/dist/build/0000755000000000000000000000000012563510500012567 5ustar0000000000000000vty-5.4.0/dist/build/verify-inlineStub/0000755000000000000000000000000012563510500016205 5ustar0000000000000000vty-5.4.0/dist/build/verify-inlineStub/verify-inlineStub-tmp/0000755000000000000000000000000012563510500022421 5ustar0000000000000000vty-5.4.0/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs0000644000000000000000000000022112563510500026366 0ustar0000000000000000module Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyInline ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-empty-image-propsStub/0000755000000000000000000000000012563510500020306 5ustar0000000000000000vty-5.4.0/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/0000755000000000000000000000000012563510500026623 5ustar0000000000000000build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs0000644000000000000000000000023212563510500034614 0ustar0000000000000000vty-5.4.0/distmodule Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyEmptyImageProps ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-eval-terminfo-capsStub/0000755000000000000000000000000012563510500020423 5ustar0000000000000000vty-5.4.0/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/0000755000000000000000000000000012563510500027055 5ustar0000000000000000verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs0000644000000000000000000000023312563510500035164 0ustar0000000000000000vty-5.4.0/dist/buildmodule Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyEvalTerminfoCaps ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-utf8-widthStub/0000755000000000000000000000000012563510500016732 5ustar0000000000000000vty-5.4.0/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/0000755000000000000000000000000012563510500023673 5ustar0000000000000000vty-5.4.0/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs0000644000000000000000000000022412563510500030370 0ustar0000000000000000module Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyUtf8Width ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-attribute-opsStub/0000755000000000000000000000000012563510500017531 5ustar0000000000000000vty-5.4.0/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/0000755000000000000000000000000012563510500025271 5ustar0000000000000000dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs0000644000000000000000000000022712563510500032511 0ustar0000000000000000vty-5.4.0module Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyAttributeOps ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-image-transStub/0000755000000000000000000000000012563510500017136 5ustar0000000000000000vty-5.4.0/dist/build/verify-image-transStub/verify-image-transStub-tmp/0000755000000000000000000000000012563510500024303 5ustar0000000000000000vty-5.4.0/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs0000644000000000000000000000022512563510500031205 0ustar0000000000000000module Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyImageTrans ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-display-attributesStub/0000755000000000000000000000000012563510500020560 5ustar0000000000000000vty-5.4.0/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/0000755000000000000000000000000012563510500027347 5ustar0000000000000000verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs0000644000000000000000000000023412563510500035614 0ustar0000000000000000vty-5.4.0/dist/buildmodule Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyDisplayAttributes ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-simple-span-generationStub/0000755000000000000000000000000012563510500021310 5ustar0000000000000000vty-5.4.0/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/0000755000000000000000000000000012563510500030627 5ustar0000000000000000verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs0000644000000000000000000000023712563510500037627 0ustar0000000000000000vty-5.4.0/dist/build/verify-simple-span-generationStubmodule Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifySimpleSpanGeneration ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-crop-span-generationStub/0000755000000000000000000000000012563510500020762 5ustar0000000000000000vty-5.4.0/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/0000755000000000000000000000000012563510500027753 5ustar0000000000000000verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs0000644000000000000000000000023512563510500036423 0ustar0000000000000000vty-5.4.0/dist/build/verify-crop-span-generationStubmodule Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyCropSpanGeneration ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-parse-terminfo-capsStub/0000755000000000000000000000000012563510500020606 5ustar0000000000000000vty-5.4.0/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/0000755000000000000000000000000012563510500027423 5ustar0000000000000000verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs0000644000000000000000000000023412563510500035716 0ustar0000000000000000vty-5.4.0/dist/buildmodule Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyParseTerminfoCaps ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-using-mock-terminalStub/0000755000000000000000000000000012563510500020614 5ustar0000000000000000vty-5.4.0/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/0000755000000000000000000000000012563510500027437 5ustar0000000000000000verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs0000644000000000000000000000023412563510500035740 0ustar0000000000000000vty-5.4.0/dist/buildmodule Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyUsingMockTerminal ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-layers-span-generationStub/0000755000000000000000000000000012563510500021316 5ustar0000000000000000vty-5.4.0/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/0000755000000000000000000000000012563510500030643 5ustar0000000000000000verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs0000644000000000000000000000023712563510500037651 0ustar0000000000000000vty-5.4.0/dist/build/verify-layers-span-generationStubmodule Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyLayersSpanGeneration ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-image-opsStub/0000755000000000000000000000000012563510500016610 5ustar0000000000000000vty-5.4.0/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/0000755000000000000000000000000012563510500023427 5ustar0000000000000000vty-5.4.0/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs0000644000000000000000000000022312563510500030001 0ustar0000000000000000module Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyImageOps ( tests ) main :: IO () main = stubMain tests vty-5.4.0/dist/build/verify-terminalStub/0000755000000000000000000000000012563510500016542 5ustar0000000000000000vty-5.4.0/dist/build/verify-terminalStub/verify-terminalStub-tmp/0000755000000000000000000000000012563510500023313 5ustar0000000000000000vty-5.4.0/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs0000644000000000000000000000022112563510500027615 0ustar0000000000000000module Main ( main ) where import Distribution.Simple.Test.LibV09 ( stubMain ) import VerifyOutput ( tests ) main :: IO () main = stubMain tests vty-5.4.0/src/0000755000000000000000000000000012563510500011314 5ustar0000000000000000vty-5.4.0/src/Codec/0000755000000000000000000000000012563510500012331 5ustar0000000000000000vty-5.4.0/src/Codec/Binary/0000755000000000000000000000000012563510500013555 5ustar0000000000000000vty-5.4.0/src/Codec/Binary/UTF8/0000755000000000000000000000000012563510500014303 5ustar0000000000000000vty-5.4.0/src/Codec/Binary/UTF8/Debug.hs0000644000000000000000000000073012563510500015665 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- Copyright 2009 Corey O'Connor module Codec.Binary.UTF8.Debug where import Codec.Binary.UTF8.String ( encode ) import Data.Word import Numeric -- | Converts an array of ISO-10646 characters (Char type) to an array of Word8 bytes that is the -- corresponding UTF8 byte sequence utf8FromIso :: [Int] -> [Word8] utf8FromIso = encode . map toEnum ppUtf8 :: [Int] -> IO () ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso vty-5.4.0/src/Graphics/0000755000000000000000000000000012563510500013054 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty.hs0000644000000000000000000001503212563510500014173 0ustar0000000000000000-- | Vty supports input and output to terminal devices. -- -- - Input to the terminal is provided to the app as a sequence of 'Event's. -- -- - The output is defined by a 'Picture'. Which is one or more layers of 'Image's. -- -- - The module "Graphics.Vty.Image" provides a number of constructor equations that will build -- correct 'Image' values. See 'string', '<|>', and '<->' for starters. -- -- - The constructors in "Graphics.Vty.Image.Internal" should not be used. -- -- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes". -- -- See the vty-examples package for a number of examples. -- -- @ -- import "Graphics.Vty" -- -- main = do -- cfg <- 'standardIOConfig' -- vty <- 'mkVty' cfg -- let line0 = 'string' ('defAttr' ` 'withForeColor' ` 'green') \"first line\" -- line1 = 'string' ('defAttr' ` 'withBackColor' ` 'blue') \"second line\" -- img = line0 '<->' line1 -- pic = 'picForImage' img -- 'update' vty pic -- e <- 'nextEvent' vty -- 'shutdown' vty -- 'print' (\"Last event was: \" '++' 'show' e) -- @ -- -- Good sources of documentation for terminal programming are: -- -- - -- -- - -- -- - -- -- - -- -- - -- -- - module Graphics.Vty ( Vty(..) , mkVty , module Graphics.Vty.Config , module Graphics.Vty.Input , module Graphics.Vty.Output , module Graphics.Vty.Picture , DisplayRegion ) where import Graphics.Vty.Prelude import Graphics.Vty.Config import Graphics.Vty.Input import Graphics.Vty.Output import Graphics.Vty.Picture import Control.Concurrent.STM import Data.IORef import Data.Monoid -- | The main object. At most one should be created. -- -- 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. -- -- An alternative to tracking the Vty instance is to use 'withVty' in "Graphics.Vty.Inline.Unsafe". -- -- 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 Remove explicit `shutdown` requirement. data Vty = Vty { -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context -- implicitly managed by Vty. The managed display context is reset on resize. update :: Picture -> IO () -- | Get one Event object, blocking if necessary. This will refresh the terminal if the event -- is a 'EvResize'. , nextEvent :: IO Event -- | The input interface. See 'Input' , inputIface :: Input -- | The output interface. See 'Output' , outputIface :: Output -- | Refresh the display. 'nextEvent' will refresh the display if a resize occurs. -- If other programs output to the terminal and mess up the display then the application might -- want to force a refresh. , refresh :: IO () -- | Clean up after vty. -- The above methods will throw an exception if executed after this is executed. , shutdown :: IO () } -- | Set up the state object for using vty. At most one state object should be -- created at a time for a given terminal device. -- -- The specified config is added to the 'userConfig'. With the 'userConfig' taking precedence. -- See "Graphics.Vty.Config" -- -- For most applications @mkVty def@ is sufficient. mkVty :: Config -> IO Vty mkVty appConfig = do config <- (<> appConfig) <$> userConfig input <- inputForConfig config out <- outputForConfig config intMkVty input out intMkVty :: Input -> Output -> IO Vty intMkVty input out = do reserveDisplay out let shutdownIo = do shutdownInput input releaseDisplay out releaseTerminal out lastPicRef <- newIORef Nothing lastUpdateRef <- newIORef Nothing let innerUpdate inPic = do b@(w,h) <- displayBounds out let cursor = picCursor inPic inPic' = case cursor of Cursor x y -> let x' = case x of _ | x < 0 -> 0 | x >= w -> w - 1 | otherwise -> x y' = case y of _ | y < 0 -> 0 | y >= h -> h - 1 | otherwise -> y in inPic { picCursor = Cursor x' y' } _ -> inPic mlastUpdate <- readIORef lastUpdateRef updateData <- case mlastUpdate of Nothing -> do dc <- displayContext out b outputPicture dc inPic' return (b, dc) Just (lastBounds, lastContext) -> do if b /= lastBounds then do dc <- displayContext out b outputPicture dc inPic' return (b, dc) else do outputPicture lastContext inPic' return (b, lastContext) writeIORef lastUpdateRef $ Just updateData writeIORef lastPicRef $ Just inPic' let innerRefresh = writeIORef lastUpdateRef Nothing >> readIORef lastPicRef >>= maybe ( return () ) ( \pic -> innerUpdate pic ) let gkey = do k <- atomically $ readTChan $ _eventChannel input case k of (EvResize _ _) -> innerRefresh >> displayBounds out >>= return . (\(w,h)-> EvResize w h) _ -> return k return $ Vty { update = innerUpdate , nextEvent = gkey , inputIface = input , outputIface = out , refresh = innerRefresh , shutdown = shutdownIo } vty-5.4.0/src/Graphics/Vty/0000755000000000000000000000000012563510500013636 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty/Config.hs0000644000000000000000000002235312563510500015404 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE KindSignatures #-} -- | A 'Config' can be provided to mkVty to customize the applications use of vty. A config file can -- be used to customize vty for a user's system. -- -- The 'Config' provided is mappend'd to 'Config's loaded from @'getAppUserDataDirectory'/config@ -- and @$VTY_CONFIG_FILE@. The @$VTY_CONFIG_FILE@ takes precedence over the @config@ file or the -- application provided 'Config'. -- -- Lines in config files that fail to parse are ignored. Later entries take precedence over -- earlier. -- -- For all directives: -- -- @ -- string := \"\\\"\" chars+ \"\\\"\" -- @ -- -- = Debug -- -- == @debugLog@ -- -- Format: -- -- @ -- \"debugLog\" string -- @ -- -- The value of the environment variable @VTY_DEBUG_LOG@ is equivalent to a debugLog entry at the -- end of the last config file. -- -- = Input Processing -- -- == @map@ -- -- Format: -- -- @ -- \"map\" term string key modifier_list -- where -- key := KEsc | KChar Char | KBS ... (same as 'Key') -- modifier_list := \"[\" modifier+ \"]\" -- modifier := MShift | MCtrl | MMeta | MAlt -- term := "_" | string -- @ -- -- EG: If the contents are -- -- @ -- map _ \"\\ESC[B\" KUp [] -- map _ \"\\ESC[1;3B\" KDown [MAlt] -- map \"xterm\" \"\\ESC[D\" KLeft [] -- @ -- -- Then the bytes @\"\\ESC[B\"@ will result in the KUp event on all terminals. The bytes -- @\"\\ESC[1;3B\"@ will result in the event KDown with the MAlt modifier on all terminals. -- The bytes @\"\\ESC[D\"@ will result in the KLeft event when @TERM@ is @xterm@. -- -- If a debug log is requested then vty will output the current input table to the log in the above -- format. -- -- Set VTY_DEBUG_LOG. Run vty. Check debug log for incorrect mappings. Add corrected mappings to -- .vty/config -- module Graphics.Vty.Config where #if __GLASGOW_HASKELL__ > 704 import Prelude #else import Prelude hiding (catch) #endif import Control.Applicative hiding (many) import Control.Exception (catch, IOException) import Control.Monad (void) import Control.Monad.Trans.Class import Control.Monad.Trans.Writer import qualified Data.ByteString as BS import Data.Default import Data.Monoid import Graphics.Vty.Input.Events import System.Directory (getAppUserDataDirectory) import System.Posix.Env (getEnv) import System.Posix.IO (stdInput, stdOutput) import System.Posix.Types (Fd(..)) import Text.Parsec hiding ((<|>)) import Text.Parsec.Token ( GenLanguageDef(..) ) import qualified Text.Parsec.Token as P -- | Mappings from input bytes to event in the order specified. Later entries take precedence over -- earlier in the case multiple entries have the same byte string. type InputMap = [(Maybe String, String, Event)] data Config = Config { -- | The default is 1 character. vmin :: Maybe Int -- | The default is 100 milliseconds, 0.1 seconds. , vtime :: Maybe Int -- | Debug information is appended to this file if not Nothing. , debugLog :: Maybe FilePath -- | The (input byte, output event) pairs extend the internal input table of VTY and the table -- from terminfo. -- -- See "Graphics.Vty.Config" module documentation for documentation of the @map@ directive. , inputMap :: InputMap -- | The input file descriptor to use. The default is 'System.Posix.IO.stdInput' , inputFd :: Maybe Fd -- | The output file descriptor to use. The default is 'System.Posix.IO.stdOutput' , outputFd :: Maybe Fd -- | The terminal name used to look up terminfo capabilities. -- The default is the value of the TERM environment variable. , termName :: Maybe String } deriving (Show, Eq) instance Default Config where def = mempty instance Monoid Config where mempty = Config { vmin = Nothing , vtime = Nothing , debugLog = mempty , inputMap = mempty , inputFd = Nothing , outputFd = Nothing , termName = Nothing } mappend c0 c1 = Config -- latter config takes priority for everything but inputMap { vmin = vmin c1 <|> vmin c0 , vtime = vtime c1 <|> vtime c0 , debugLog = debugLog c1 <|> debugLog c0 , inputMap = inputMap c0 <> inputMap c1 , inputFd = inputFd c1 <|> inputFd c0 , outputFd = outputFd c1 <|> outputFd c0 , termName = termName c1 <|> termName c0 } type ConfigParser s a = ParsecT s () (Writer Config) a -- | Config from @'getAppUserDataDirectory'/config@ and @$VTY_CONFIG_FILE@ userConfig :: IO Config userConfig = do configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE" let base = configFile <> overrideConfig mappend base <$> overrideEnvConfig overrideEnvConfig :: IO Config overrideEnvConfig = do d <- getEnv "VTY_DEBUG_LOG" return $ def { debugLog = d } standardIOConfig :: IO Config standardIOConfig = do Just t <- getEnv "TERM" return $ def { vmin = Just 1 , vtime = Just 100 , inputFd = Just stdInput , outputFd = Just stdOutput , termName = Just t } parseConfigFile :: FilePath -> IO Config parseConfigFile path = do catch (runParseConfig path <$> BS.readFile path) (\(_ :: IOException) -> return def) runParseConfig :: Stream s (Writer Config) Char => String -> s -> Config runParseConfig name = execWriter . runParserT parseConfig () name -- I tried to use the haskellStyle here but that was specialized (without requirement?) to the -- String stream type. configLanguage :: Stream s m Char => P.GenLanguageDef s u m configLanguage = LanguageDef { commentStart = "{-" , commentEnd = "-}" , commentLine = "--" , nestedComments = True , identStart = letter <|> char '_' , identLetter = alphaNum <|> oneOf "_'" , opStart = opLetter configLanguage , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" , reservedOpNames = [] , reservedNames = [] , caseSensitive = True } configLexer :: Stream s m Char => P.GenTokenParser s u m configLexer = P.makeTokenParser configLanguage mapDecl :: forall s u (m :: * -> *). (Monad m, Stream s (WriterT Config m) Char) => ParsecT s u (WriterT Config m) () mapDecl = do void $ string "map" P.whiteSpace configLexer termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing) <|> (Just <$> P.stringLiteral configLexer) bytes <- P.stringLiteral configLexer key <- parseKey modifiers <- parseModifiers lift $ tell $ def { inputMap = [(termIdent, bytes, EvKey key modifiers)] } -- TODO: Generated by a vim macro. There is a better way here. Derive parser? Use Read -- instance? Generics? parseKey :: forall s u (m :: * -> *). Stream s m Char => ParsecT s u m Key parseKey = do key <- P.identifier configLexer case key of "KChar" -> KChar <$> P.charLiteral configLexer "KFun" -> KFun . fromInteger <$> P.natural configLexer "KEsc" -> return KEsc "KBS" -> return KBS "KEnter" -> return KEnter "KLeft" -> return KLeft "KRight" -> return KRight "KUp" -> return KUp "KDown" -> return KDown "KUpLeft" -> return KUpLeft "KUpRight" -> return KUpRight "KDownLeft" -> return KDownLeft "KDownRight" -> return KDownRight "KCenter" -> return KCenter "KBackTab" -> return KBackTab "KPrtScr" -> return KPrtScr "KPause" -> return KPause "KIns" -> return KIns "KHome" -> return KHome "KPageUp" -> return KPageUp "KDel" -> return KDel "KEnd" -> return KEnd "KPageDown" -> return KPageDown "KBegin" -> return KBegin "KMenu" -> return KMenu _ -> fail $ key ++ " is not a valid key identifier" parseModifiers :: forall s u (m :: * -> *). Stream s m Char => ParsecT s u m [Modifier] parseModifiers = P.brackets configLexer (parseModifier `sepBy` P.symbol configLexer ",") parseModifier :: forall s u (m :: * -> *). Stream s m Char => ParsecT s u m Modifier parseModifier = do m <- P.identifier configLexer case m of "KMenu" -> return MShift "MCtrl" -> return MCtrl "MMeta" -> return MMeta "MAlt" -> return MAlt _ -> fail $ m ++ " is not a valid modifier identifier" debugLogDecl :: forall s u (m :: * -> *). (Monad m, Stream s (WriterT Config m) Char) => ParsecT s u (WriterT Config m) () debugLogDecl = do void $ string "debugLog" P.whiteSpace configLexer path <- P.stringLiteral configLexer lift $ tell $ def { debugLog = Just path } ignoreLine :: forall s u (m :: * -> *). Stream s m Char => ParsecT s u m () ignoreLine = void $ manyTill anyChar newline parseConfig :: forall s u (m :: * -> *). (Monad m, Stream s (WriterT Config m) Char) => ParsecT s u (WriterT Config m) () parseConfig = void $ many $ do P.whiteSpace configLexer let directives = [mapDecl, debugLogDecl] try (choice directives) <|> ignoreLine vty-5.4.0/src/Graphics/Vty/PictureToSpans.hs0000644000000000000000000003574512563510500017133 0ustar0000000000000000-- Copyright Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif {- | Transforms an image into rows of operations. -} module Graphics.Vty.PictureToSpans where import Graphics.Vty.Prelude import Graphics.Vty.Image import Graphics.Vty.Image.Internal import Graphics.Vty.Picture import Graphics.Vty.Span import Control.Lens hiding ( op ) import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state ) #if __GLASGOW_HASKELL__ < 708 import Control.Monad.ST.Strict hiding ( unsafeIOToST ) #else import Control.Monad.ST.Strict #endif import qualified Data.Vector as Vector hiding ( take, replicate ) import Data.Vector.Mutable ( MVector(..)) import qualified Data.Vector.Mutable as MVector import qualified Data.Text.Lazy as TL #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (mappend) #endif type MRowOps s = MVector s SpanOps type MSpanOps s = MVector s SpanOp -- transform plus clip. More or less. data BlitState = BlitState -- we always snoc to the operation vectors. Thus the columnOffset = length of row at rowOffset -- although, one possibility is to merge layers right in snocOp (naming it something else, of -- course). In which case columnnOffset would be applicable. -- Right now we need it to exist. { _columnOffset :: Int , _rowOffset :: Int -- clip coordinate space is in image space. Which means it's >= 0 and < imageWidth. , _skipColumns :: Int -- >= 0 and < imageHeight , _skipRows :: Int -- includes consideration of skipColumns. In display space. -- The number of columns from the next column to be defined to the end of the display for the -- row. , _remainingColumns :: Int -- includes consideration of skipRows. In display space. , _remainingRows :: Int } makeLenses ''BlitState data BlitEnv s = BlitEnv { _region :: DisplayRegion , _mrowOps :: MRowOps s } makeLenses ''BlitEnv type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a -- | Produces the span ops that will render the given picture, possibly cropped or padded, into the -- specified region. displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r) -- | Returns the DisplayOps for an image rendered to a window the size of the image. -- -- largerly used only for debugging. displayOpsForImage :: Image -> DisplayOps displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i) -- | Produces the span ops for each layer then combines them. -- -- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire -- region. combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s) combinedOpsForLayers pic r | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0 | otherwise = do layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic) case layerOps of [] -> fail "empty picture" [ops] -> substituteSkips (picBackground pic) ops -- instead of merging ops after generation the merging can be performed as part of -- snocOp. topOps : lowerOps -> do ops <- foldM mergeUnder topOps lowerOps substituteSkips (picBackground pic) ops substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s) substituteSkips ClearBackground ops = do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row -- the image operations assure that background fills are combined. -- clipping a background fill does not split the background fill. -- merging of image layers can split a skip, but only by the insertion of a non skip. -- all this combines to mean we can check the last operation and remove it if it's a skip -- todo: or does it? let rowOps' = case Vector.last rowOps of Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w _ -> rowOps -- now all the skips can be replaced by replications of ' ' of the required width. let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps' MVector.write ops row rowOps'' return ops substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do -- At this point we decide if the background character is single column or not. -- obviously, single column is easier. case safeWcwidth backgroundChar of w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar | w == 1 -> do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row let rowOps' = swapSkipsForSingleColumnCharSpan backgroundChar backgroundAttr rowOps MVector.write ops row rowOps' | otherwise -> do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row let rowOps' = swapSkipsForCharSpan w backgroundChar backgroundAttr rowOps MVector.write ops row rowOps' return ops mergeUnder :: MRowOps s -> MRowOps s -> ST s (MRowOps s) mergeUnder upper lower = do forM_ [0 .. MVector.length upper - 1] $ \row -> do upperRowOps <- MVector.read upper row lowerRowOps <- MVector.read lower row let rowOps = mergeRowUnder upperRowOps lowerRowOps MVector.write upper row rowOps return upper -- fugly mergeRowUnder :: SpanOps -> SpanOps -> SpanOps mergeRowUnder upperRowOps lowerRowOps = onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps where -- H: it will never be the case that we are out of upper ops before lower ops. onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps = let lowerOps' = dropOps w lowerOps outOps' = Vector.snoc outOps op in if Vector.null lowerOps' then outOps' else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps' onUpperOp outOps (Skip w) upperOps lowerOps = let (ops', lowerOps') = splitOpsAt w lowerOps outOps' = outOps `mappend` ops' in if Vector.null lowerOps' then outOps' else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps' onUpperOp _ (RowEnd _) _ _ = error "cannot merge rows containing RowEnd ops" swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps swapSkipsForSingleColumnCharSpan c a = Vector.map f where f (Skip ow) = let txt = TL.pack $ replicate ow c in TextSpan a ow ow txt f v = v swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps swapSkipsForCharSpan w c a = Vector.map f where f (Skip ow) = let txt0Cw = ow `div` w txt0 = TL.pack $ replicate txt0Cw c txt1Cw = ow `mod` w txt1 = TL.pack $ replicate txt1Cw '…' cw = txt0Cw + txt1Cw txt = txt0 `TL.append` txt1 in TextSpan a ow cw txt f v = v -- | Builds a vector of row operations that will output the given picture to the terminal. -- -- Crops to the given display region. -- -- \todo I'm pretty sure there is an algorithm that does not require a mutable buffer. buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s) buildSpans image outRegion = do -- First we create a mutable vector for each rows output operations. outOps <- MVector.replicate (regionHeight outRegion) Vector.empty -- \todo 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. when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ 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. let fullBuild = do startImageBuild image -- Fill in any unspecified columns with a skip. forM_ [0 .. (regionHeight outRegion - 1)] (addRowCompletion outRegion) initEnv = BlitEnv outRegion outOps initState = BlitState 0 0 0 0 (regionWidth outRegion) (regionHeight outRegion) _ <- runStateT (runReaderT fullBuild initEnv) initState return () return outOps -- | Add the operations required to build a given image to the current set of row operations. startImageBuild :: Image -> BlitM s () startImageBuild image = do outOfBounds <- isOutOfBounds image <$> get when (not outOfBounds) $ addMaybeClipped image isOutOfBounds :: Image -> BlitState -> Bool isOutOfBounds i s | s ^. remainingColumns <= 0 = True | s ^. remainingRows <= 0 = True | s ^. skipColumns >= imageWidth i = True | s ^. skipRows >= imageHeight i = True | otherwise = False -- | This adds an image that might be partially clipped to the output ops. -- -- This is a very touchy algorithm. Too touchy. For instance, the CropRight and CropBottom -- implementations are odd. They pass the current tests but something seems terribly wrong about all -- this. -- -- \todo prove this cannot be called in an out of bounds case. addMaybeClipped :: forall s . Image -> BlitM s () addMaybeClipped EmptyImage = return () addMaybeClipped (HorizText a textStr ow _cw) = do -- TODO: assumption that text spans are only 1 row high. s <- use skipRows when (s < 1) $ do leftClip <- use skipColumns rightClip <- use remainingColumns let leftClipped = leftClip > 0 rightClipped = (ow - leftClip) > rightClip if leftClipped || rightClipped then let textStr' = clipText textStr leftClip rightClip in addUnclippedText a textStr' else addUnclippedText a textStr addMaybeClipped (VertJoin topImage bottomImage _ow oh) = do addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset (imageHeight topImage) topImage bottomImage oh addMaybeClipped (HorizJoin leftImage rightImage ow _oh) = do addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset (imageWidth leftImage) leftImage rightImage ow addMaybeClipped BGFill {outputWidth, outputHeight} = do s <- get let outputWidth' = min (outputWidth - s^.skipColumns) (s^.remainingColumns) outputHeight' = min (outputHeight - s^.skipRows ) (s^.remainingRows) y <- use rowOffset forM_ [y..y+outputHeight'-1] $ snocOp (Skip outputWidth') addMaybeClipped CropRight {croppedImage, outputWidth} = do s <- use skipColumns r <- use remainingColumns let x = outputWidth - s when (x < r) $ remainingColumns .= x addMaybeClipped croppedImage addMaybeClipped CropLeft {croppedImage, leftSkip} = do skipColumns += leftSkip addMaybeClipped croppedImage addMaybeClipped CropBottom {croppedImage, outputHeight} = do s <- use skipRows r <- use remainingRows let x = outputHeight - s when (x < r) $ remainingRows .= x addMaybeClipped croppedImage addMaybeClipped CropTop {croppedImage, topSkip} = do skipRows += topSkip addMaybeClipped croppedImage addMaybeClippedJoin :: forall s . String -> Lens BlitState BlitState Int Int -> Lens BlitState BlitState Int Int -> Lens BlitState BlitState Int Int -> Int -> Image -> Image -> Int -> BlitM s () addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do state <- get when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0" case state^.skip of s -- TODO: check if clipped in other dim. if not use addUnclipped | s >= size -> fail $ name ++ " on fully clipped" | s == 0 -> if state^.remaining > i0Dim then do addMaybeClipped i0 put $ state & offset +~ i0Dim & remaining -~ i0Dim addMaybeClipped i1 else addMaybeClipped i0 | s < i0Dim -> let i0Dim' = i0Dim - s in if state^.remaining <= i0Dim' then addMaybeClipped i0 else do addMaybeClipped i0 put $ state & offset +~ i0Dim' & remaining -~ i0Dim' & skip .~ 0 addMaybeClipped i1 | s >= i0Dim -> do put $ state & skip -~ i0Dim addMaybeClipped i1 _ -> fail $ name ++ " has unhandled skip class" addUnclippedText :: Attr -> DisplayText -> BlitM s () addUnclippedText a txt = do let op = TextSpan a usedDisplayColumns (fromIntegral $ TL.length txt) txt usedDisplayColumns = wcswidth $ TL.unpack txt use rowOffset >>= snocOp op addRowCompletion :: DisplayRegion -> Int -> BlitM s () addRowCompletion displayRegion row = do allRowOps <- view mrowOps rowOps <- lift $ lift $ MVector.read allRowOps row let endX = spanOpsEffectedColumns rowOps when (endX < regionWidth displayRegion) $ do let ow = regionWidth displayRegion - endX snocOp (Skip ow) row -- | snocs the operation to the operations for the given row. snocOp :: SpanOp -> Int -> BlitM s () snocOp !op !row = do theMrowOps <- view mrowOps theRegion <- view region lift $ lift $ do ops <- MVector.read theMrowOps row let ops' = Vector.snoc ops op when (spanOpsEffectedColumns ops' > regionWidth theRegion) $ fail $ "row " ++ show row ++ " now exceeds region width" MVector.write theMrowOps row ops' vty-5.4.0/src/Graphics/Vty/DisplayAttributes.hs0000644000000000000000000001162512563510500017653 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif module Graphics.Vty.DisplayAttributes where import Graphics.Vty.Attributes import Data.Bits ((.&.)) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..), mconcat) #endif -- | 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. fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr fixDisplayAttr fattr attr = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr)) (fixColor (fixedForeColor fattr) (attrForeColor attr)) (fixColor (fixedBackColor fattr) (attrBackColor attr)) where fixStyle _s Default = defaultStyleMask fixStyle s KeepCurrent = s fixStyle _s (SetTo newStyle) = newStyle fixColor _c Default = Nothing fixColor c KeepCurrent = c fixColor _c (SetTo c) = Just c -- | difference between two display attributes. Used in the calculation of the operations required -- to go from one display attribute to the next. -- -- Previously, vty would reset display attributes to default then apply the new display attributes. -- This turned out to be very expensive: A *lot* more data would be sent to the terminal than -- required. data DisplayAttrDiff = DisplayAttrDiff { styleDiffs :: [StyleStateChange] , foreColorDiff :: DisplayColorDiff , backColorDiff :: DisplayColorDiff } deriving (Show) instance Monoid DisplayAttrDiff where mempty = DisplayAttrDiff [] NoColorChange NoColorChange mappend d0 d1 = let ds = simplifyStyleDiffs (styleDiffs d0) (styleDiffs d1) fcd = simplifyColorDiffs (foreColorDiff d0) (foreColorDiff d1) bcd = simplifyColorDiffs (backColorDiff d0) (backColorDiff d1) in DisplayAttrDiff ds fcd bcd -- | Used in the computation of a final style attribute change. -- -- TODO(corey): not really a simplify but a monoid instance. simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange] simplifyStyleDiffs cs0 cs1 = cs0 `mappend` cs1 -- | Consider two display color attributes diffs. What display color attribute diff are these -- equivalent to? -- -- TODO(corey): not really a simplify but a monoid instance. simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff simplifyColorDiffs _cd ColorToDefault = ColorToDefault simplifyColorDiffs cd NoColorChange = cd simplifyColorDiffs _cd (SetColor !c) = SetColor c -- | Difference between two display color attribute changes. data DisplayColorDiff = ColorToDefault | NoColorChange | SetColor !Color deriving (Show, Eq) -- | Style attribute changes are transformed into a sequence of apply/removes of the individual -- attributes. data StyleStateChange = ApplyStandout | RemoveStandout | ApplyUnderline | RemoveUnderline | ApplyReverseVideo | RemoveReverseVideo | ApplyBlink | RemoveBlink | ApplyDim | RemoveDim | ApplyBold | RemoveBold deriving (Show, Eq) -- | Determines the diff between two display&color attributes. This diff determines the operations -- that actually get output to the terminal. displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff displayAttrDiffs attr attr' = DisplayAttrDiff { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr') , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr') , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr') } diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff diffColor Nothing (Just c') = SetColor c' diffColor (Just c) (Just c') | c == c' = NoColorChange | otherwise = SetColor c' diffColor Nothing Nothing = NoColorChange diffColor (Just _) Nothing = ColorToDefault diffStyles :: Style -> Style -> [StyleStateChange] diffStyles prev cur = mconcat [ styleDiff standout ApplyStandout RemoveStandout , styleDiff underline ApplyUnderline RemoveUnderline , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo , styleDiff blink ApplyBlink RemoveBlink , styleDiff dim ApplyDim RemoveDim , styleDiff bold ApplyBold RemoveBold ] where styleDiff 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-5.4.0/src/Graphics/Vty/Inline.hs0000644000000000000000000001060212563510500015407 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. -- -- @ -- putStr \"Not styled. \" -- putAttrChange_ $ do -- backColor red -- applyStyle underline -- putStr \" Styled! \" -- putAttrChange_ $ defaultAll -- putStrLn \"Not styled.\" -- @ -- -- 'putAttrChange' outputs the control codes to the terminal device 'Handle'. This is a duplicate -- of the 'stdout' handle when the 'terminalHandle' was (first) acquired. If 'stdout' has since been -- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than -- 'putAttrChange' -- -- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif module Graphics.Vty.Inline ( module Graphics.Vty.Inline , withVty ) where import Graphics.Vty import Graphics.Vty.DisplayAttributes import Graphics.Vty.Inline.Unsafe import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder (writeToByteString) import Control.Monad.State.Strict import Data.Bits ( (.&.), complement ) import Data.IORef import System.IO #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative import Data.Monoid ( mappend ) #endif type InlineM v = State Attr v -- | Set the background color to the provided 'Color' backColor :: Color -> InlineM () backColor c = modify $ flip mappend ( currentAttr `withBackColor` c ) -- | Set the foreground color to the provided 'Color' foreColor :: Color -> InlineM () foreColor c = modify $ flip mappend ( currentAttr `withForeColor` 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. applyStyle :: Style -> InlineM () applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s ) -- | Attempt to remove the specified 'Style' from the display of the following text. -- -- This will fail if applyStyle for the given style has not been previously called. removeStyle :: Style -> InlineM () removeStyle sMask = modify $ \attr -> let style' = case attrStyle attr of Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used." SetTo s -> s .&. complement sMask in attr { attrStyle = SetTo style' } -- | Reset the display attributes defaultAll :: InlineM () defaultAll = put defAttr -- | Apply the provided display attribute changes to the given terminal output device. -- -- This does not flush the terminal. putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () putAttrChange out c = liftIO $ do bounds <- displayBounds out dc <- displayContext out bounds mfattr <- prevFattr <$> readIORef (assumedStateRef out) fattr <- case mfattr of Nothing -> do liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc return $ FixedAttr defaultStyleMask Nothing Nothing Just v -> return v let attr = execState c currentAttr attr' = limitAttrForDisplay out attr fattr' = fixDisplayAttr fattr attr' diffs = displayAttrDiffs fattr fattr' outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' } inlineHack dc -- | Apply the provided display attributes changes to the terminal output device that was current at -- the time this was first used. Which, for most use cases, is the current terminal. -- -- This will flush the terminal output. putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m () putAttrChange_ c = liftIO $ withOutput $ \out -> do hFlush stdout putAttrChange out c hFlush stdout vty-5.4.0/src/Graphics/Vty/Span.hs0000644000000000000000000001416512563510500015102 0ustar0000000000000000-- Copyright Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GADTs #-} {- | 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 `spansForPic`. - - todo: Partition attribute changes into multiple categories according to the serialized - representation of the various attributes. -} module Graphics.Vty.Span where import Graphics.Vty.Prelude import Graphics.Vty.Image import Graphics.Vty.Image.Internal ( clipText ) import qualified Data.Text.Lazy as TL import Data.Vector (Vector) import qualified Data.Vector as Vector -- | This represents an operation on the terminal. Either an attribute change or the output of a -- text string. data SpanOp = -- | 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 [Attr] [output width in columns] [number of characters] [data] TextSpan { textSpanAttr :: !Attr , textSpanOutputWidth :: !Int , textSpanCharWidth :: !Int , textSpanText :: DisplayText } -- | Skips the given number of columns -- A skip is transparent.... maybe? I am not sure how attribute changes interact. -- todo: separate from this type. | Skip !Int -- | Marks the end of a row. specifies how many columns are remaining. These columns will not be -- explicitly overwritten with the span ops. The terminal is require to assure the remaining -- columns are clear. -- todo: separate from this type. | RowEnd !Int deriving Eq -- | vector of span operations. executed in succession. This represents the operations required to -- render a row of the terminal. The operations in one row may effect subsequent rows. -- EG: Setting the foreground color in one row will effect all subsequent rows until the foreground -- color is changed. type SpanOps = Vector SpanOp dropOps :: Int -> SpanOps -> SpanOps dropOps w = snd . splitOpsAt w splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps) splitOpsAt inW inOps = splitOpsAt' inW inOps where splitOpsAt' 0 ops = (Vector.empty, ops) splitOpsAt' remainingColumns ops = case Vector.head ops of t@(TextSpan {}) -> if remainingColumns >= textSpanOutputWidth t then let (pre,post) = splitOpsAt' (remainingColumns - textSpanOutputWidth t) (Vector.tail ops) in (Vector.cons t pre, post) else let preTxt = clipText (textSpanText t) 0 remainingColumns preOp = TextSpan { textSpanAttr = textSpanAttr t , textSpanOutputWidth = remainingColumns , textSpanCharWidth = fromIntegral $! TL.length preTxt , textSpanText = preTxt } postWidth = textSpanOutputWidth t - remainingColumns postTxt = clipText (textSpanText t) remainingColumns postWidth postOp = TextSpan { textSpanAttr = textSpanAttr t , textSpanOutputWidth = postWidth , textSpanCharWidth = fromIntegral $! TL.length postTxt , textSpanText = postTxt } in ( Vector.singleton preOp , Vector.cons postOp (Vector.tail ops) ) Skip w -> if remainingColumns >= w then let (pre,post) = splitOpsAt' (remainingColumns - w) (Vector.tail ops) in (Vector.cons (Skip w) pre, post) else ( Vector.singleton $ Skip remainingColumns , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops) ) RowEnd _ -> error "cannot split ops containing a row end" -- | vector of span operation vectors for display. One per row of the output region. type DisplayOps = Vector SpanOps instance Show SpanOp where show (TextSpan attr ow cw _) = "TextSpan(" ++ show attr ++ ")(" ++ show ow ++ ", " ++ show cw ++ ")" show (Skip ow) = "Skip(" ++ show ow ++ ")" show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")" -- | Number of columns the DisplayOps are defined for -- -- All spans are verified to define same number of columns. See: VerifySpanOps displayOpsColumns :: DisplayOps -> Int displayOpsColumns ops | Vector.length ops == 0 = 0 | otherwise = Vector.length $ Vector.head ops -- | Number of rows the DisplayOps are defined for displayOpsRows :: DisplayOps -> Int displayOpsRows ops = Vector.length ops effectedRegion :: DisplayOps -> DisplayRegion effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops) -- | The number of columns a SpanOps effects. spanOpsEffectedColumns :: SpanOps -> Int spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps where spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w spanOpsEffectedColumns' t (Skip w) = t + w spanOpsEffectedColumns' t (RowEnd w) = t + w -- | The width of a single SpanOp in columns spanOpHasWidth :: SpanOp -> Maybe (Int, Int) spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow) spanOpHasWidth (Skip ow) = Just (ow,ow) spanOpHasWidth (RowEnd ow) = Just (ow,ow) -- | returns the number of columns to the character at the given position in the span op columnsToCharOffset :: Int -> SpanOp -> Int columnsToCharOffset cx (TextSpan _ _ _ utf8Str) = let str = TL.unpack utf8Str in wcswidth (take cx str) columnsToCharOffset cx (Skip _) = cx columnsToCharOffset cx (RowEnd _) = cx vty-5.4.0/src/Graphics/Vty/Output.hs0000644000000000000000000001001512563510500015467 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} -- | Output interface. -- -- Access to the current terminal or a specific terminal device. -- -- See also: -- -- 1. "Graphics.Vty.Output": This instantiates an abtract interface to the terminal interface based -- on the TERM and COLORTERM environment variables. -- -- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all terminals need to implement. -- -- 3. "Graphics.Vty.Output.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.Output.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. module Graphics.Vty.Output ( module Graphics.Vty.Output , Output(..) -- \todo hide constructors , AssumedState(..) , DisplayContext(..) -- \todo hide constructors , outputPicture , displayContext ) where import Graphics.Vty.Prelude import Graphics.Vty.Config import Graphics.Vty.Output.Interface import Graphics.Vty.Output.XTermColor as XTermColor import Graphics.Vty.Output.TerminfoBased as TerminfoBased import Blaze.ByteString.Builder (writeToByteString) import Control.Monad.Trans import Data.List (isPrefixOf) import Data.Monoid ((<>)) -- | Returns a `Output` for the terminal specified in `Config` -- -- The specific Output 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. -- -- Specifics about it being based on terminfo are hidden from the API user. If a terminal -- implementation is developed for a terminal without terminfo support then Vty should work as -- expected on that terminal. -- -- Selection of a terminal is done as follows: -- -- * If TERM == xterm use XTermColor. -- * for any other TERM value TerminfoBased is used. -- -- \todo add an implementation for windows that does not depend on terminfo. Should be installable -- with only what is provided in the haskell platform. Use ansi-terminal outputForConfig :: Config -> IO Output outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do t <- if "xterm" `isPrefixOf` termName then XTermColor.reserveTerminal termName fd -- Not an xterm-like terminal. try for generic terminfo. else TerminfoBased.reserveTerminal termName fd return t outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig -- | 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 outputPicture or refresh. setCursorPos :: MonadIO m => Output -> Int -> Int -> m () setCursorPos t x y = do bounds <- displayBounds t when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do dc <- displayContext t bounds liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y -- | Hides the cursor hideCursor :: MonadIO m => Output -> m () hideCursor t = do bounds <- displayBounds t dc <- displayContext t bounds liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc -- | Shows the cursor showCursor :: MonadIO m => Output -> m () showCursor t = do bounds <- displayBounds t dc <- displayContext t bounds liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc vty-5.4.0/src/Graphics/Vty/Image.hs0000644000000000000000000002755212563510500015227 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-} module Graphics.Vty.Image ( DisplayText , Image , imageWidth , imageHeight , horizJoin , (<|>) , vertJoin , (<->) , horizCat , vertCat , backgroundFill , text , text' , char , string , iso10646String , utf8String , utf8Bytestring , utf8Bytestring' , charFill , emptyImage , safeWcwidth , safeWcswidth , wcwidth , wcswidth , crop , cropRight , cropLeft , cropBottom , cropTop , pad , resize , resizeWidth , resizeHeight , translate , translateX , translateY -- | The possible display attributes used in constructing an `Image`. , module Graphics.Vty.Attributes ) where import Graphics.Vty.Attributes import Graphics.Vty.Image.Internal import Graphics.Text.Width import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Data.Word infixr 5 <|> infixr 4 <-> -- | An area of the picture's bacground (See Background) of w columns and h rows. backgroundFill :: Int -> Int -> Image backgroundFill w h | w == 0 = EmptyImage | h == 0 = EmptyImage | otherwise = BGFill w h -- | Combines two images horizontally. Alias for horizJoin -- -- infixr 5 (<|>) :: Image -> Image -> Image (<|>) = horizJoin -- | Combines two images vertically. Alias for vertJoin -- -- infixr 4 (<->) :: Image -> Image -> Image (<->) = vertJoin -- | Compose any number of images horizontally. horizCat :: [Image] -> Image horizCat = foldr horizJoin EmptyImage -- | Compose any number of images vertically. vertCat :: [Image] -> Image vertCat = foldr vertJoin EmptyImage -- | A Data.Text.Lazy value text :: Attr -> TL.Text -> Image text a txt | TL.length txt == 0 = EmptyImage | otherwise = let displayWidth = safeWcswidth (TL.unpack txt) in HorizText a txt displayWidth (fromIntegral $! TL.length txt) -- | A Data.Text value text' :: Attr -> T.Text -> Image text' a txt | T.length txt == 0 = EmptyImage | otherwise = let displayWidth = safeWcswidth (T.unpack txt) in HorizText a (TL.fromStrict txt) displayWidth (T.length txt) -- | 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 displayWidth = safeWcwidth c in HorizText a (TL.singleton c) displayWidth 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 iso10646String or string. -- iso10646String :: Attr -> String -> Image iso10646String _ [] = EmptyImage iso10646String a str = let displayWidth = safeWcswidth str in HorizText a (TL.pack str) displayWidth (length str) -- | Alias for iso10646String. 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 = iso10646String -- | A string of characters layed out on a single row. The input is assumed to be the bytes for -- UTF-8 encoded text. utf8String :: Attr -> [Word8] -> Image utf8String a bytes = utf8Bytestring a (BL.pack bytes) -- | Renders a UTF-8 encoded lazy bytestring. utf8Bytestring :: Attr -> BL.ByteString -> Image utf8Bytestring a bs = text a (TL.decodeUtf8 bs) -- | Renders a UTF-8 encoded strict bytestring. utf8Bytestring' :: Attr -> B.ByteString -> Image utf8Bytestring' a bs = text' a (T.decodeUtf8 bs) -- | creates a fill of the specified character. The dimensions are in number of characters wide and -- number of rows high. charFill :: Integral d => Attr -> Char -> d -> d -> Image charFill _a _c 0 _h = EmptyImage charFill _a _c _w 0 = EmptyImage charFill a c w h = vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth where txt = TL.replicate (fromIntegral w) (TL.singleton c) displayWidth = safeWcwidth c * (fromIntegral w) charWidth = fromIntegral w -- | The empty image. Useful for fold combinators. These occupy no space nor define any display -- attributes. emptyImage :: Image emptyImage = EmptyImage -- | pad the given image. This adds background character fills to the left, top, right, bottom. -- The pad values are how many display columns or rows to add. pad :: Int -> Int -> Int -> Int -> Image -> Image pad 0 0 0 0 i = i pad inL inT inR inB inImage | inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount" | otherwise = go inL inT inR inB inImage where -- TODO: uh. go 0 0 0 0 i = i go 0 0 0 b i = VertJoin i (BGFill w b) w h where w = imageWidth i h = imageHeight i + b go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h where w = imageWidth i + r h = imageHeight i go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h where w = imageWidth i h = imageHeight i + t go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h where w = imageWidth i + l h = imageHeight i -- | translates an image by padding or cropping the left and top. First param is amount to translate -- left. Second param is amount to translate top. -- -- This can have an unexpected effect: Translating an image to less than (0,0) then to greater than -- (0,0) will crop the image. translate :: Int -> Int -> Image -> Image translate x y i = translateX x (translateY y i) -- | translates an image by padding or cropping the left translateX :: Int -> Image -> Image translateX x i | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i) | x == 0 = i | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h -- | translates an image by padding or cropping the top translateY :: Int -> Image -> Image translateY y i | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s) | y == 0 = i | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) -- | Ensure an image is no larger than the provided size. If the image is larger then crop the right -- or bottom. -- -- This is transformed to a vertical crop from the bottom followed by horizontal crop from the -- right. crop :: Int -> Int -> Image -> Image crop 0 _ _ = EmptyImage crop _ 0 _ = EmptyImage crop w h i = cropBottom h (cropRight w i) -- | crop the display height. If the image is less than or equal in height then this operation has -- no effect. Otherwise the image is cropped from the bottom. cropBottom :: Int -> Image -> Image cropBottom 0 _ = EmptyImage cropBottom h inI | h < 0 = error "cannot crop height to less than zero" | otherwise = go inI where go EmptyImage = EmptyImage go i@(CropBottom {croppedImage, outputWidth, outputHeight}) | outputHeight <= h = i | otherwise = CropBottom croppedImage outputWidth h go i | h >= imageHeight i = i | otherwise = CropBottom i (imageWidth i) h -- | ensure the image is no wider than the given width. If the image is wider then crop the right -- side. cropRight :: Int -> Image -> Image cropRight 0 _ = EmptyImage cropRight w inI | w < 0 = error "cannot crop width to less than zero" | otherwise = go inI where go EmptyImage = EmptyImage go i@(CropRight {croppedImage, outputWidth, outputHeight}) | outputWidth <= w = i | otherwise = CropRight croppedImage w outputHeight go i | w >= imageWidth i = i | otherwise = CropRight i w (imageHeight i) -- | ensure the image is no wider than the given width. If the image is wider then crop the left -- side. cropLeft :: Int -> Image -> Image cropLeft 0 _ = EmptyImage cropLeft w inI | w < 0 = error "cannot crop the width to less than zero" | otherwise = go inI where go EmptyImage = EmptyImage go i@(CropLeft {croppedImage, leftSkip, outputWidth, outputHeight}) | outputWidth <= w = i | otherwise = let leftSkip' = leftSkip + outputWidth - w in CropLeft croppedImage leftSkip' w outputHeight go i | imageWidth i <= w = i | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i) -- | crop the display height. If the image is less than or equal in height then this operation has -- no effect. Otherwise the image is cropped from the top. cropTop :: Int -> Image -> Image cropTop 0 _ = EmptyImage cropTop h inI | h < 0 = error "cannot crop the height to less than zero" | otherwise = go inI where go EmptyImage = EmptyImage go i@(CropTop {croppedImage, topSkip, outputWidth, outputHeight}) | outputHeight <= h = i | otherwise = let topSkip' = topSkip + outputHeight - h in CropTop croppedImage topSkip' outputWidth h go i | imageHeight i <= h = i | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h -- | Generic resize. Pads and crops as required to assure the given display width and height. -- This is biased to pad/crop the right and bottom. resize :: Int -> Int -> Image -> Image resize w h i = resizeHeight h (resizeWidth w i) -- | Resize the width. Pads and crops as required to assure the given display width. -- This is biased to pad/crop the right. resizeWidth :: Int -> Image -> Image resizeWidth w i = case w `compare` imageWidth i of LT -> cropRight w i EQ -> i GT -> i <|> BGFill (w - imageWidth i) (imageHeight i) -- | Resize the height. Pads and crops as required to assure the given display height. -- This is biased to pad/crop the bottom. resizeHeight :: Int -> Image -> Image resizeHeight h i = case h `compare` imageHeight i of LT -> cropBottom h i EQ -> i GT -> i <-> BGFill (imageWidth i) (h - imageHeight i) vty-5.4.0/src/Graphics/Vty/Debug.hs0000644000000000000000000000225012563510500015217 0ustar0000000000000000-- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Debug ( module Graphics.Vty.Debug , module Graphics.Vty.Debug.Image ) where import Graphics.Vty.Prelude import Graphics.Vty.Attributes import Graphics.Vty.Debug.Image import Graphics.Vty.Span import qualified Data.Vector as Vector rowOpsEffectedColumns :: DisplayOps -> [Int] rowOpsEffectedColumns ops = Vector.toList $ Vector.map spanOpsEffectedColumns ops allSpansHaveWidth :: DisplayOps -> Int -> Bool allSpansHaveWidth ops expected = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops spanOpsEffectedRows :: DisplayOps -> Int spanOpsEffectedRows ops = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops)) type SpanConstructLog = [SpanConstructEvent] data SpanConstructEvent = SpanSetAttr Attr isSetAttr :: Attr -> SpanConstructEvent -> Bool isSetAttr expectedAttr (SpanSetAttr inAttr) | inAttr == expectedAttr = True isSetAttr _attr _event = False data MockWindow = MockWindow Int Int deriving (Show, Eq) regionForWindow :: MockWindow -> DisplayRegion regionForWindow (MockWindow w h) = (w,h) vty-5.4.0/src/Graphics/Vty/Picture.hs0000644000000000000000000000710712563510500015612 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | The 'Picture' data structure is representative of the final terminal view. -- -- A 'Picture' is a background paired with a layer of 'Image's. module Graphics.Vty.Picture ( module Graphics.Vty.Picture , module Graphics.Vty.Image ) where import Graphics.Vty.Image import Control.DeepSeq -- | The type of images to be displayed using 'update'. -- -- Can be constructed directly or using `picForImage`. Which provides an initial instance with -- reasonable defaults for picCursor and picBackground. data Picture = Picture { picCursor :: Cursor , picLayers :: [Image] , picBackground :: Background } instance Show Picture where show (Picture _ layers _ ) = "Picture ?? " ++ show layers ++ " ??" instance NFData Picture where rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` () -- | a picture with no cursor, background or image layers emptyPicture :: Picture emptyPicture = Picture NoCursor [] ClearBackground -- | The given 'Image' is added as the top layer of the 'Picture' addToTop :: Picture -> Image -> Picture addToTop p i = p {picLayers = i : picLayers p} -- | The given 'Image' is added as the bottom layer of the 'Picture' addToBottom :: Picture -> Image -> Picture addToBottom p i = p {picLayers = picLayers p ++ [i]} -- | Create a picture for display for the given image. The picture will not have a displayed cursor -- and no background pattern (ClearBackground) will be used. picForImage :: Image -> Picture picForImage i = Picture { picCursor = NoCursor , picLayers = [i] , picBackground = ClearBackground } -- | Create a picture for display with the given layers. Ordered top to bottom. -- -- The picture will not have a displayed cursor and no background apttern (ClearBackgroun) will be -- used. -- -- The first 'Image' is the top layer. picForLayers :: [Image] -> Picture picForLayers is = Picture { picCursor = NoCursor , picLayers = is , picBackground = ClearBackground } -- | 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 Int Int instance NFData Cursor where rnf NoCursor = () rnf (Cursor w h) = w `seq` h `seq` () -- | A 'Picture' has a background pattern. The background is either ClearBackground. Which shows the -- layer below or is blank if the bottom layer. Or the background pattern is a character and a -- display attribute. If the display attribute used previously should be used for a background fill -- then use `currentAttr` for the background attribute. -- -- \todo The current attribute is always set to the default attributes at the start of updating the -- screen to a picture. data Background = Background { backgroundChar :: Char , backgroundAttr :: Attr } -- | A ClearBackground is: -- -- * the space character if there are remaining non-skip ops -- -- * End of line if there are no remaining non-skip ops. | ClearBackground instance NFData Background where rnf (Background c a) = c `seq` a `seq` () rnf ClearBackground = () -- | Compatibility with applications that do not use more than a single layer. picImage :: Picture -> Image picImage = head . picLayers vty-5.4.0/src/Graphics/Vty/Error.hs0000644000000000000000000000041112563510500015257 0ustar0000000000000000module Graphics.Vty.Error where -- | The type of exceptions specific to vty. -- -- These have fully qualified names by default since, IMO, exception handling requires this. data VtyException = VtyFailure String -- ^ Uncategorized failure specific to vty. vty-5.4.0/src/Graphics/Vty/Attributes.hs0000644000000000000000000001625612563510500016332 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif -- | Display attributes -- -- Typically the values 'defAttr' or 'currentAttr' are modified to form attributes: -- -- @ -- defAttr `withForeColor` red -- @ -- -- Is the attribute that will set the foreground color to red and the background color to the -- default. -- -- This can then be used to build an image wiht a red foreground like so: -- -- @ -- string (defAttr `withForeColor` red) "this text will be red" -- @ -- -- The default attributes set by 'defAttr' have a presentation determined by the terminal. This is -- not something VTY can control. The user is free to define the color scheme of the terminal as -- they see fit. Up to the limits of the terminal anyways. -- -- The value 'currentAttr' will keep the attributes of whatever was output previously. -- -- \todo This API is very verbose IMO. I'd like something more succinct. module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes , module Graphics.Vty.Attributes.Color , module Graphics.Vty.Attributes.Color240 ) where import Data.Bits import Data.Default import Data.Word import Graphics.Vty.Attributes.Color import Graphics.Vty.Attributes.Color240 #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid #endif -- | 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 { attrStyle :: !(MaybeDefault Style) , attrForeColor :: !(MaybeDefault Color) , attrBackColor :: !(MaybeDefault Color) } deriving ( Eq, Show, Read ) -- This could be 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. instance Monoid Attr where mempty = Attr mempty mempty mempty mappend attr0 attr1 = Attr ( attrStyle attr0 `mappend` attrStyle attr1 ) ( attrForeColor attr0 `mappend` attrForeColor attr1 ) ( attrBackColor attr0 `mappend` attrBackColor attr1 ) -- | 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 { fixedStyle :: !Style , fixedForeColor :: !(Maybe Color) , fixedBackColor :: !(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, Read v ) => !v -> MaybeDefault v deriving instance Eq v => Eq (MaybeDefault v) deriving instance Eq v => Show (MaybeDefault v) deriving instance (Eq v, Show v, Read v) => Read (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 -- | 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 brightBlack, brightRed, brightGreen, brightYellow :: Color brightBlue, brightMagenta, brightCyan, brightWhite :: Color brightBlack = ISOColor 8 brightRed = ISOColor 9 brightGreen = ISOColor 10 brightYellow = ISOColor 11 brightBlue = ISOColor 12 brightMagenta= ISOColor 13 brightCyan = ISOColor 14 brightWhite = 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 -- -- * reverseVideo -- -- * blink -- -- * dim -- -- * bold/bright -- -- ( The invisible, protect, and altcharset display attributes some terminals support are not -- supported via VTY.) standout, underline, reverseVideo, blink, dim, bold :: Style standout = 0x01 underline = 0x02 reverseVideo = 0x04 blink = 0x08 dim = 0x10 bold = 0x20 defaultStyleMask :: Style defaultStyleMask = 0x00 styleMask :: Attr -> Word8 styleMask attr = case attrStyle attr of Default -> 0 KeepCurrent -> 0 SetTo v -> v -- | true if the given Style value has the specified Style set. hasStyle :: Style -> Style -> Bool hasStyle s bitMask = ( s .&. bitMask ) /= 0 -- | Set the foreground color of an `Attr'. withForeColor :: Attr -> Color -> Attr withForeColor attr c = attr { attrForeColor = SetTo c } -- | Set the background color of an `Attr'. withBackColor :: Attr -> Color -> Attr withBackColor attr c = attr { attrBackColor = SetTo c } -- | Add the given style attribute withStyle :: Attr -> Style -> Attr withStyle attr styleFlag = attr { attrStyle = SetTo $ styleMask attr .|. styleFlag } -- | 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. defAttr :: Attr defAttr = Attr Default Default Default instance Default Attr where def = defAttr -- | Keeps the style, background color and foreground color that was previously set. Used to -- override some part of the previous style. -- -- EG: current_style `withForeColor` brightMagenta -- -- Would be the currently applied style (be it underline, bold, etc) but with the foreground color -- set to brightMagenta. currentAttr :: Attr currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent vty-5.4.0/src/Graphics/Vty/Input.hs0000644000000000000000000002134612563510500015277 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif -- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can -- then be used to read 'Event's from the terminal. -- -- The history of terminals has resulted in a broken input process. Some keys and combinations will -- not reliably map to the expected events by any terminal program. Even those not using vty. There -- is no 1:1 mapping from key events to bytes read from the terminal input device. In very limited -- cases the terminal and vty's input process can be customized to resolve these issues. -- -- See "Graphics.Vty.Config" for how to configure vty's input processing. Customizing terminfo and -- the terminal is beyond the scope of this documentation. -- -- = VTY's Implementation -- -- One can get the brain rot trying to understand all this. So, as far as I can care... -- -- There are two input modes: -- -- 1. 7 bit -- -- 2. 8 bit -- -- 7 bit input is the default and the expected in most use cases. This is what vty uses. -- -- == 7 bit input encoding -- -- Control key combinations are represented by masking the two high bits of the 7bit input. Back in -- the day the control key actually grounded the two high bit wires: 6 and 7. This is why -- control key combos map to single character events: The input bytes are identical. The input byte -- is the bit encoding of the character with bits 6 and 7 masked. Bit 6 is set by shift. Bit 6 and -- 7 are masked by control. EG: -- -- * Control-I is 'i', `01101001`, has bit 6 and 7 masked to become `00001001`. Which is the ASCII -- and UTF-8 encoding of the tab key. -- -- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero which makes `0000011` and -- is the "End of Text" code. -- -- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: This is the value 1 with bit 7 -- set and 6 unset. -- -- * Hypothesis: Bit 6 is unset by upper case letters because, initially, there were only upper case -- letters used and a 5 bit encoding. -- -- == 8 bit encoding -- -- The 8th bit was originally used for parity checking. Useless for emulators. Some terminal -- emulators support a 8 bit input encoding. While this provides some advantages the actual usage is -- low. Most systems use 7bit mode but recognize 8bit control characters when escaped. This is what -- vty does. -- -- == Escaped Control Keys -- -- Using 7 bit input encoding the @ESC@ byte can signal the start of an encoded control key. To -- differentiate a single @ESC@ eventfrom a control key the timing of the input is used. -- -- 1. @ESC@ individually: @ESC@ byte; no bytes for 'singleEscPeriod'. -- -- 2. control keys that contain @ESC@ in their encoding: The @ESC byte; followed by more bytes read -- within 'singleEscPeriod'. All bytes up until the next valid input block are passed to the -- classifier. -- -- If the current runtime is the threaded runtime then the terminal's @VMIN@ and @VTIME@ behavior -- reliably implement the above rules. If the current runtime does not support forkOS then there is -- currently no implementation. -- -- Vty used to emulate @VMIN@ and @VTIME@. This was a input loop which did tricky things with -- non-blocking reads and timers. The implementation was not reliable. A reliable implementation is -- possible, but there are no plans to implement this. -- -- == Unicode Input and Escaped Control Key Sequences -- -- The input encoding determines how UTF-8 encoded characters are recognize. -- -- * 7 bit mode: UTF-8 can be input unambiguiously. UTF-8 input is a superset of ASCII. UTF-8 does -- not overlap escaped control key sequences. However, the escape key must be differentiated from -- escaped control key sequences by the timing of the input bytes. -- -- * 8 bit mode: UTF-8 cannot be input unambiguously. This does not require using the timing of -- input bytes to differentiate the escape key. Many terminals do not support 8 bit mode. -- -- == Terminfo -- -- The terminfo system is used to determine how some keys are encoded. Terminfo is incomplete. In -- some cases terminfo is incorrect. Vty assumes terminfo is correct but provides a mechanism to -- override terminfo. See "Graphics.Vty.Config" specifically 'inputOverrides'. -- -- == Terminal Input is Broken -- -- Clearly terminal input has fundemental issues. There is no easy way to reliably resolve these -- issues. -- -- One resolution would be to ditch standard terminal interfaces entirely and just go directly to -- scancodes. A reasonable option for vty if everybody used the linux kernel console. I hear GUIs -- are popular these days. Sadly, GUI terminal emulators don't provide access to scancodes AFAIK. -- -- All is lost? Not really. "Graphics.Vty.Config" supports customizing the input byte to event -- mapping and xterm supports customizing the scancode to input byte mapping. With a lot of work a -- user's system can be set up to encode all the key combos in an almost-sane manner. -- -- There are other tricky work arounds that can be done. I have no interest in implementing most of -- these. They are not really worth the time. -- -- == Terminal Output is Also Broken -- -- This isn't the only odd aspect of terminals due to historical aspects that no longer apply. EG: -- Some terminfo capabilities specify millisecond delays. (Capabilities are how terminfo describes -- the control sequence to output red, for instance) This is to account for the slow speed of -- hardcopy teletype interfaces. Cause, uh, we totally still use those. -- -- The output encoding of colors and attributes are also rife with issues. -- -- == See also -- -- * http://www.leonerd.org.uk/hacks/fixterms/ -- -- In my experience this cannot resolve the issues without changes to the terminal emulator and -- device. module Graphics.Vty.Input ( Key(..) , Modifier(..) , Button(..) , Event(..) , Input(..) , inputForConfig ) where import Graphics.Vty.Config import Graphics.Vty.Input.Events import Graphics.Vty.Input.Loop import Graphics.Vty.Input.Terminfo import Control.Concurrent.STM import Control.Lens import qualified System.Console.Terminfo as Terminfo import System.Posix.Signals.Exts #if !(MIN_VERSION_base(4,8,0)) import Data.Functor ((<$>)) import Data.Monoid #else import Data.Monoid ((<>)) #endif -- | Set up the terminal with file descriptor `inputFd` for input. Returns a 'Input'. -- -- The table used to determine the 'Events' to produce for the input bytes comes from -- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from -- 'inputMap'. -- -- The terminal device is configured with the attributes: -- -- * IXON disabled -- - disables software flow control on outgoing data. This stops the process from being -- suspended if the output terminal cannot keep up. I presume this has little effect these -- days. I hope this means that output will be buffered if the terminal cannot keep up. In the -- old days the output might of been dropped? -- -- "raw" mode is used for input. -- -- * ISIG disabled -- - enables keyboard combinations that result in signals. TODO: should probably be a dynamic -- option. -- -- * ECHO disabled -- - input is not echod to the output. TODO: should be a dynamic option. -- -- * ICANON disabled -- - canonical mode (line mode) input is not used. TODO: should be a dynamic option. -- -- * IEXTEN disabled -- - extended functions are disabled. TODO: I don't know what those are. -- inputForConfig :: Config -> IO Input inputForConfig config@Config{ termName = Just termName , inputFd = Just termFd , vmin = Just _ , vtime = Just _ , .. } = do terminal <- Terminfo.setupTerm termName let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName] activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides (setAttrs,unsetAttrs) <- attributeControl termFd setAttrs input <- initInput config activeInputMap let pokeIO = Catch $ do let e = error "vty internal failure: this value should not propagate to users" setAttrs atomically $ writeTChan (input^.eventChannel) (EvResize e e) _ <- installHandler windowChange pokeIO Nothing _ <- installHandler continueProcess pokeIO Nothing return $ input { shutdownInput = do shutdownInput input _ <- installHandler windowChange Ignore Nothing _ <- installHandler continueProcess Ignore Nothing unsetAttrs } inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig vty-5.4.0/src/Graphics/Vty/Prelude.hs0000644000000000000000000000100012563510500015561 0ustar0000000000000000-- | Prelude for Vty modules. Not particularly useful outside of Vty. module Graphics.Vty.Prelude ( module Graphics.Vty.Prelude , module Control.Applicative , module Control.Monad ) where import Control.Applicative hiding ((<|>)) import Control.Monad -- | Named alias for a Int pair type DisplayRegion = (Int,Int) regionWidth :: DisplayRegion -> Int regionWidth = fst regionHeight :: DisplayRegion -> Int regionHeight = snd vty-5.4.0/src/Graphics/Vty/Image/0000755000000000000000000000000012563510500014660 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty/Image/Internal.hs0000644000000000000000000003156412563510500017001 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_HADDOCK hide #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif module Graphics.Vty.Image.Internal where import Graphics.Vty.Attributes import Graphics.Text.Width import Control.DeepSeq import qualified Data.Text.Lazy as TL #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid #endif -- | A display text is a Data.Text.Lazy -- -- TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each -- application probably uses a single type. Perhaps parameterize the entire vty interface by the -- input text type? -- TODO: Try using a builder instead of a TL.Text instance directly. That might improve performance -- for the usual case of appending a bunch of characters with the same attribute together. type DisplayText = TL.Text -- TODO: store a skip list in HorizText(?) -- TODO: represent display strings containing chars that are not 1 column chars as a separate -- display string value? clipText :: DisplayText -> Int -> Int -> DisplayText clipText txt leftSkip rightClip = -- CPS would clarify this I think let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0 txt' = if padPrefix then TL.cons '…' (TL.drop (toDrop+1) txt) else TL.drop toDrop txt (toTake,padSuffix) = clipForCharWidth rightClip txt' 0 txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty) clipForCharWidth 0 _ n = (n, False) clipForCharWidth w t n | TL.null t = (n, False) | w < cw = (n, True) | w == cw = (n+1, False) | w > cw = clipForCharWidth (w - cw) (TL.tail t) (n + 1) where cw = safeWcwidth (TL.head t) clipForCharWidth _ _ _ = error "clipForCharWidth applied to undefined" in txt'' -- | This is the internal representation of Images. Use the constructors in "Graphics.Vty.Image" to -- create instances. -- -- Images are: -- -- * a horizontal span of text -- -- * a horizontal or vertical join of two images -- -- * a two dimensional fill of the 'Picture's background character -- -- * a cropped image -- -- * an empty image of no size or content. data Image = -- | A horizontal text span is always >= 1 column and has a row height of 1. HorizText { attr :: Attr -- | The text to display. The display width of the text is always outputWidth. , displayText :: DisplayText -- | The number of display columns for the text. Always > 0. , outputWidth :: Int -- | the number of characters in the text. Always > 0. , charWidth :: Int } -- | 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 horizJoin constructor adds background -- fills to the provided images that assure this is true for the HorizJoin value produced. | HorizJoin { partLeft :: Image , partRight :: Image , outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 1 , outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0 } -- | 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 vertJoin constructor adds background -- fills to the provides images that assure this is true for the VertJoin value produced. | VertJoin { partTop :: Image , partBottom :: Image , outputWidth :: Int -- ^ imageWidth partTop == imageWidth partBottom. always > 0 , outputHeight :: Int -- ^ imageHeight partTop == imageHeight partBottom. always > 1 } -- | A background fill will be filled with the background char. The background char is -- defined as a property of the Picture this Image is used to form. | BGFill { outputWidth :: Int -- ^ always > 0 , outputHeight :: Int -- ^ always > 0 } -- | Crop an image horizontally to a size by reducing the size from the right. | CropRight { croppedImage :: Image -- | Always < imageWidth croppedImage > 0 , outputWidth :: Int , outputHeight :: Int -- ^ imageHeight croppedImage } -- | Crop an image horizontally to a size by reducing the size from the left. | CropLeft { croppedImage :: Image -- | Always < imageWidth croppedImage > 0 , leftSkip :: Int -- | Always < imageWidth croppedImage > 0 , outputWidth :: Int , outputHeight :: Int } -- | Crop an image vertically to a size by reducing the size from the bottom | CropBottom { croppedImage :: Image -- | imageWidth croppedImage , outputWidth :: Int -- | height image is cropped to. Always < imageHeight croppedImage > 0 , outputHeight :: Int } -- | Crop an image vertically to a size by reducing the size from the top | CropTop { croppedImage :: Image -- | Always < imageHeight croppedImage > 0 , topSkip :: Int -- | imageWidth croppedImage , outputWidth :: Int -- | Always < imageHeight croppedImage > 0 , outputHeight :: Int } -- | The empty image -- -- The combining operators identity constant. -- EmptyImage <|> a = a -- EmptyImage <-> a = a -- -- Any image of zero size equals the empty image. | EmptyImage deriving Eq instance Show Image where show ( HorizText { attr, displayText, outputWidth, charWidth } ) = "HorizText " ++ show displayText ++ "@(" ++ show attr ++ "," ++ show outputWidth ++ "," ++ show charWidth ++ ")" show ( BGFill { outputWidth, outputHeight } ) = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")" show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } ) = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")" show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } ) = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")" show ( CropRight { croppedImage, outputWidth, outputHeight } ) = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]" ++ " (" ++ show croppedImage ++ ")" show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } ) = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]" ++ " (" ++ show croppedImage ++ ")" show ( CropBottom { croppedImage, outputWidth, outputHeight } ) = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]" ++ " (" ++ show croppedImage ++ ")" show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } ) = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]" ++ " (" ++ show croppedImage ++ ")" show ( EmptyImage ) = "EmptyImage" -- | pretty print just the structure of an image. ppImageStructure :: Image -> String ppImageStructure inImg = go 0 inImg where go indent img = tab indent ++ pp indent img tab indent = concat $ replicate indent " " pp _ (HorizText {outputWidth}) = "HorizText(" ++ show outputWidth ++ ")" pp _ (BGFill {outputWidth, outputHeight}) = "BGFill(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")" pp i (HorizJoin {partLeft = l, partRight = r, outputWidth = c}) = "HorizJoin(" ++ show c ++ ")\n" ++ go (i+1) l ++ "\n" ++ go (i+1) r pp i (VertJoin {partTop = t, partBottom = b, outputWidth = c, outputHeight = r}) = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n" ++ go (i+1) t ++ "\n" ++ go (i+1) b pp i (CropRight {croppedImage, outputWidth, outputHeight}) = "CropRight(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" ++ go (i+1) croppedImage pp i (CropLeft {croppedImage, leftSkip, outputWidth, outputHeight}) = "CropLeft(" ++ show leftSkip ++ "->" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" ++ go (i+1) croppedImage pp i (CropBottom {croppedImage, outputWidth, outputHeight}) = "CropBottom(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n" ++ go (i+1) croppedImage pp i (CropTop {croppedImage, topSkip, outputWidth, outputHeight}) = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n" ++ go (i+1) croppedImage pp _ EmptyImage = "EmptyImage" instance NFData Image where rnf EmptyImage = () rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` () rnf (CropLeft i s w h) = i `deepseq` s `seq` w `seq` h `seq` () rnf (CropBottom i w h) = i `deepseq` w `seq` h `seq` () rnf (CropTop i s w h) = i `deepseq` s `seq` w `seq` h `seq` () rnf (BGFill w h) = w `seq` h `seq` () rnf (VertJoin t b w h) = t `deepseq` b `deepseq` w `seq` h `seq` () rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` () rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` () -- | The width of an Image. This is the number display columns the image will occupy. imageWidth :: Image -> Int imageWidth HorizText { outputWidth = w } = w imageWidth HorizJoin { outputWidth = w } = w imageWidth VertJoin { outputWidth = w } = w imageWidth BGFill { outputWidth = w } = w imageWidth CropRight { outputWidth = w } = w imageWidth CropLeft { outputWidth = w } = w imageWidth CropBottom { outputWidth = w } = w imageWidth CropTop { outputWidth = w } = w imageWidth EmptyImage = 0 -- | The height of an Image. This is the number of display rows the image will occupy. imageHeight :: Image -> Int imageHeight HorizText {} = 1 imageHeight HorizJoin { outputHeight = h } = h imageHeight VertJoin { outputHeight = h } = h imageHeight BGFill { outputHeight = h } = h imageHeight CropRight { outputHeight = h } = h imageHeight CropLeft { outputHeight = h } = h imageHeight CropBottom { outputHeight = h } = h imageHeight CropTop { outputHeight = h } = h imageHeight EmptyImage = 0 -- | Append in the Monoid instance is equivalent to <->. instance Monoid Image where mempty = EmptyImage mappend = vertJoin -- | combines two images side by side -- -- Combines text chunks where possible. Assures outputWidth and outputHeight properties are not -- violated. -- -- 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. -- -- TODO: the bg fill is biased towards top to bottom languages(?) horizJoin :: Image -> Image -> Image horizJoin EmptyImage i = i horizJoin i EmptyImage = i horizJoin i0@(HorizText a0 t0 w0 cw0) i1@(HorizText a1 t1 w1 cw1) | a0 == a1 = HorizText a0 (TL.append t0 t1) (w0 + w1) (cw0 + cw1) -- TODO: assumes horiz text height is always 1 | otherwise = HorizJoin i0 i1 (w0 + w1) 1 horizJoin i0 i1 -- If the images are of the same height then no padding is required | h0 == h1 = HorizJoin i0 i1 w h0 -- otherwise one of the images needs to be padded to the right size. | h0 < h1 -- Pad i0 = let padAmount = h1 - h0 in HorizJoin (VertJoin i0 (BGFill w0 padAmount) w0 h1) i1 w h1 | h0 > h1 -- Pad i1 = let padAmount = h0 - h1 in HorizJoin i0 (VertJoin i1 (BGFill w1 padAmount) w1 h0) w h0 where w0 = imageWidth i0 w1 = imageWidth i1 w = w0 + w1 h0 = imageHeight i0 h1 = imageHeight i1 horizJoin _ _ = error "horizJoin applied to undefined values." -- | 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. -- -- TODO: the bg fill is biased towards right to left languages(?) vertJoin :: Image -> Image -> Image vertJoin EmptyImage i = i vertJoin i EmptyImage = i vertJoin i0 i1 -- If the images are of the same width then no background padding is required | w0 == w1 = VertJoin i0 i1 w0 h -- Otherwise one of the images needs to be padded to the size of the other image. | w0 < w1 = let padAmount = w1 - w0 in VertJoin (HorizJoin i0 (BGFill padAmount h0) w1 h0) i1 w1 h | w0 > w1 = let padAmount = w0 - w1 in VertJoin i0 (HorizJoin i1 (BGFill padAmount h1) w0 h1) w0 h where w0 = imageWidth i0 w1 = imageWidth i1 h0 = imageHeight i0 h1 = imageHeight i1 h = h0 + h1 vertJoin _ _ = error "vertJoin applied to undefined values." vty-5.4.0/src/Graphics/Vty/Debug/0000755000000000000000000000000012563510500014664 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty/Debug/Image.hs0000644000000000000000000000137212563510500016245 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} module Graphics.Vty.Debug.Image where import Graphics.Vty.Image type ImageConstructLog = [ImageConstructEvent] data ImageConstructEvent = ImageConstructEvent deriving ( Show, Eq ) forwardImageOps :: [Image -> Image] forwardImageOps = map forwardTransform debugImageOps forwardTransform, reverseTransform :: ImageOp -> (Image -> Image) forwardTransform (ImageOp f _) = f reverseTransform (ImageOp _ r) = r data ImageOp = ImageOp ImageEndo ImageEndo type ImageEndo = Image -> Image debugImageOps :: [ImageOp] debugImageOps = [ idImageOp -- , renderSingleColumnCharOp -- , renderDoubleColumnCharOp ] idImageOp :: ImageOp idImageOp = ImageOp id id -- renderCharOp :: ImageOp -- renderCharOp = ImageOp id id vty-5.4.0/src/Graphics/Vty/Input/0000755000000000000000000000000012563510500014735 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty/Input/Loop.hs0000644000000000000000000001776112563510500016216 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} -- | The input layer used to be a single function that correctly accounted for the non-threaded -- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with -- a more straightforward parser. The non-threaded runtime is no longer supported. -- -- This is an example of an algorithm where code coverage could be high, even 100%, but the -- behavior is still under tested. I should collect more of these examples... -- -- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html module Graphics.Vty.Input.Loop where import Graphics.Vty.Config import Graphics.Vty.Input.Classify import Graphics.Vty.Input.Events import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception (mask, try, SomeException) import Control.Lens import Control.Monad (when, mzero, forM_) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.State (StateT(..), evalStateT) import Control.Monad.Trans.Reader (ReaderT(..)) import Data.Char import Data.IORef import Data.Word (Word8) import Foreign ( allocaArray, peekArray, Ptr ) import Foreign.C.Types (CInt(..)) import System.IO import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..)) import System.Posix.Terminal import System.Posix.Types (Fd(..)) import Text.Printf (hPrintf) data Input = Input { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh -- the display if the next event is an 'EvResize'. _eventChannel :: TChan Event -- | Shuts down the input processing. This should return the terminal input state to before -- the input initialized. , shutdownInput :: IO () -- | Changes to this value are reflected after the next event. , _configRef :: IORef Config -- | input debug log , _inputDebug :: Maybe Handle } makeLenses ''Input data InputBuffer = InputBuffer { _ptr :: Ptr Word8 , _size :: Int } makeLenses ''InputBuffer data InputState = InputState { _unprocessedBytes :: String , _appliedConfig :: Config , _inputBuffer :: InputBuffer , _classifier :: String -> KClass } makeLenses ''InputState type InputM a = StateT InputState (ReaderT Input IO) a logMsg :: String -> InputM () logMsg msg = do d <- view inputDebug case d of Nothing -> return () Just h -> liftIO $ hPutStrLn h msg >> hFlush h -- this must be run on an OS thread dedicated to this input handling. -- otherwise the terminal timing read behavior will block the execution of the lightweight threads. loopInputProcessor :: InputM () loopInputProcessor = do readFromDevice >>= addBytesToProcess validEvents <- many parseEvent forM_ validEvents emit dropInvalid loopInputProcessor addBytesToProcess :: String -> InputM () addBytesToProcess block = unprocessedBytes <>= block emit :: Event -> InputM () emit event = do logMsg $ "parsed event: " ++ show event view eventChannel >>= liftIO . atomically . flip writeTChan event -- The timing requirements are assured by the VMIN and VTIME set for the device. -- -- Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case -- satisfies precondition. -- TODO: When under the non-threaded runtime emulate VMIN and VTIME readFromDevice :: InputM String readFromDevice = do newConfig <- view configRef >>= liftIO . readIORef oldConfig <- use appliedConfig let Just fd = inputFd newConfig when (newConfig /= oldConfig) $ do logMsg $ "new config: " ++ show newConfig liftIO $ applyConfig fd newConfig appliedConfig .= newConfig bufferPtr <- use $ inputBuffer.ptr maxBytes <- use $ inputBuffer.size stringRep <- liftIO $ do -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses -- this provides a location to be interrupted prior to the foreign call. If there is input -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime -- terminal setting. threadWaitRead fd bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes) if bytesRead > 0 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr else return [] when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep return stringRep applyConfig :: Fd -> Config -> IO () applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime }) = setTermTiming fd theVmin (theVtime `div` 100) applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration" parseEvent :: InputM Event parseEvent = do c <- use classifier b <- use unprocessedBytes case c b of Valid e remaining -> do logMsg $ "valid parse: " ++ show e logMsg $ "remaining: " ++ show remaining unprocessedBytes .= remaining return e _ -> mzero dropInvalid :: InputM () dropInvalid = do c <- use classifier b <- use unprocessedBytes when (c b == Invalid) $ do logMsg "dropping input bytes" unprocessedBytes .= [] runInputProcessorLoop :: ClassifyMap -> Input -> IO () runInputProcessorLoop classifyTable input = do let bufferSize = 1024 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do s0 <- InputState [] <$> readIORef (_configRef input) <*> pure (InputBuffer bufferPtr bufferSize) <*> pure (classify classifyTable) runReaderT (evalStateT loopInputProcessor s0) input attributeControl :: Fd -> IO (IO (), IO ()) attributeControl fd = do original <- getTerminalAttributes fd let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts , EnableEcho, ProcessInput, ExtendedFunctions ] let setAttrs = setTerminalAttributes fd vtyMode Immediately unsetAttrs = setTerminalAttributes fd original Immediately return (setAttrs,unsetAttrs) logInitialInputState :: Input -> ClassifyMap -> IO() logInitialInputState input classifyTable = case _inputDebug input of Nothing -> return () Just h -> do Config{ vmin = Just theVmin , vtime = Just theVtime , termName = Just theTerm, .. } <- readIORef $ _configRef input _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime)) forM_ classifyTable $ \i -> case i of (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm) (show inBytes) (show k) (show mods) _ -> return () initInput :: Config -> ClassifyMap -> IO Input initInput config classifyTable = do let Just fd = inputFd config setFdOption fd NonBlockingRead False applyConfig fd config stopSync <- newEmptyMVar input <- Input <$> atomically newTChan <*> pure (return ()) <*> newIORef config <*> maybe (return Nothing) (\f -> Just <$> openFile f AppendMode) (debugLog config) logInitialInputState input classifyTable inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input) (\_ -> putMVar stopSync ()) let killAndWait = do killThread inputThread takeMVar stopSync return $ input { shutdownInput = killAndWait } foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO () forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkOSFinally action and_then = mask $ \restore -> forkOS $ try (restore action) >>= and_then vty-5.4.0/src/Graphics/Vty/Input/Events.hs0000644000000000000000000000310412563510500016533 0ustar0000000000000000module Graphics.Vty.Input.Events where -- | Representations of non-modifier keys. -- -- * KFun is indexed from 0 to 63. Range of supported FKeys varies by terminal and keyboard. -- -- * KUpLeft, KUpRight, KDownLeft, KDownRight, KCenter support varies by terminal and keyboard. -- -- * Actually, support for most of these but KEsc, KChar, KBS, and KEnter vary by terminal and -- keyboard. data Key = KEsc | KChar Char | KBS | KEnter | KLeft | KRight | KUp | KDown | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter | KFun Int | KBackTab | KPrtScr | KPause | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu deriving (Eq,Show,Read,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,Read,Ord) -- | Mouse buttons. -- -- \todo not supported. data Button = BLeft | BMiddle | BRight deriving (Eq,Show,Ord) -- | Events. data Event = EvKey Key [Modifier] -- | \todo mouse events are not supported | EvMouse Int Int Button [Modifier] -- | if read from 'eventChannel' this is the size at the time of the signal. If read from -- 'nextEvent' this is the size at the time the event was processed by Vty. Typically these are -- the same, but if somebody is resizing the terminal quickly they can be different. | EvResize Int Int deriving (Eq,Show,Ord) type ClassifyMap = [(String,Event)] vty-5.4.0/src/Graphics/Vty/Input/Classify.hs0000644000000000000000000000622312563510500017051 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- This makes a kind of tri. Has space efficiency issues with large input blocks. -- Likely building a parser and just applying that would be better. -- I did not write this so I might just rewrite it for better understanding. Which is not the best -- of reasons. -- TODO: measure and rewrite if required. -- TODO: The ClassifyMap interface requires this code to always assure later entries override -- earlier. module Graphics.Vty.Input.Classify ( classify , KClass(..) ) where import Graphics.Vty.Input.Events import Codec.Binary.UTF8.Generic (decode) import Data.List(inits) import qualified Data.Map as M( fromList, lookup ) import Data.Maybe ( mapMaybe ) import qualified Data.Set as S( fromList, member ) import Data.Char import Data.Word data KClass = Valid Event [Char] | Invalid | Prefix deriving(Show, Eq) compile :: ClassifyMap -> [Char] -> KClass compile table = cl' where -- take all prefixes and create a set of these prefixSet = S.fromList $ concatMap (init . inits . fst) $ table maxValidInputLength = maximum (map (length . fst) table) eventForInput = M.fromList table cl' [] = Prefix cl' inputBlock = case M.lookup inputBlock eventForInput of -- if the inputBlock is exactly what is expected for an event then consume the whole -- block and return the event Just e -> Valid e [] Nothing -> case S.member inputBlock prefixSet of True -> Prefix -- look up progressively smaller tails of the input block until an event is found -- The assumption is that the event that consumes the most input bytes should be -- produced. -- The test verifyFullSynInputToEvent2x verifies this. -- H: There will always be one match. The prefixSet contains, by definition, all -- prefixes of an event. False -> let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of (s,e) : _ -> Valid e (drop (length s) inputBlock) -- neither a prefix or a full event. -- TODO: debug log [] -> Invalid classify :: ClassifyMap -> [Char] -> KClass classify table = let standardClassifier = compile table in \s -> case s of c:cs | ord c >= 0xC2 -> classifyUtf8 c cs _ -> standardClassifier s classifyUtf8 :: Char -> [Char] -> KClass classifyUtf8 c cs = let n = utf8Length (ord c) (codepoint,rest) = splitAt n (c:cs) codepoint8 :: [Word8] codepoint8 = map (fromIntegral . ord) codepoint in case decode codepoint8 of _ | n < length codepoint -> Prefix Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest Nothing -> Invalid -- something bad happened; just ignore and continue. utf8Length :: (Num t, Ord a, Num a) => a -> t utf8Length c | c < 0x80 = 1 | c < 0xE0 = 2 | c < 0xF0 = 3 | otherwise = 4 vty-5.4.0/src/Graphics/Vty/Input/Terminfo.hs0000644000000000000000000001247112563510500017061 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Graphics.Vty.Input.Terminfo where import Graphics.Vty.Input.Events import qualified Graphics.Vty.Input.Terminfo.ANSIVT as ANSIVT import Control.Arrow import System.Console.Terminfo -- | queries the terminal for all capability based input sequences then adds on a terminal dependent -- input sequence mapping. -- -- For reference see: -- -- * http://vimdoc.sourceforge.net/htmldoc/term.html -- -- * vim74/src/term.c -- -- * http://invisible-island.net/vttest/ -- -- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html -- -- This is painful. Terminfo is incomplete. The vim source implies that terminfo is also incorrect. -- Vty assumes that the an internal terminfo table added to the system provided terminfo table is -- correct. -- -- 1. build terminfo table for all caps. Missing caps are not added. -- -- 2. add tables for visible chars, esc, del plus ctrl and meta -- -- 3. add internally defined table for given terminal type. -- -- Precedence is currently implicit in the 'compile' algorithm. Which is a bit odd. -- -- \todo terminfo meta is not supported. -- \todo no 8bit classifyMapForTerm :: String -> Terminal -> ClassifyMap classifyMapForTerm termName term = concat $ capsClassifyMap term keysFromCapsTable : universalTable : termSpecificTables termName -- | key table applicable to all terminals. -- -- TODO: some probably only applicable to ANSI/VT100 terminals. universalTable :: ClassifyMap universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys] capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table] where extractCap = first (getCapability terminal . tiGetStr) -- | tables specific to a given terminal that are not derivable from terminfo. -- -- TODO: Adds the ANSI/VT100/VT50 tables regardless of term identifier. termSpecificTables :: String -> [ClassifyMap] termSpecificTables _termName = ANSIVT.classifyTable -- | Visible characters in the ISO-8859-1 and UTF-8 common set. -- -- we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this -- classify table is reached. -- -- TODO: resolve -- 1. start at ' '. The earlier characters are all 'ctrlChar' visibleChars :: ClassifyMap visibleChars = [ ([x], EvKey (KChar x) []) | x <- [' ' .. toEnum 0xC1] ] -- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char. -- -- \todo resolve CTRL-i is the same as tab ctrlChars :: ClassifyMap ctrlChars = [ ([toEnum x],EvKey (KChar y) [MCtrl]) | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']) , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB. , y /= 'h' -- CTRL-h should not hide BS ] -- | Ctrl+Meta+Char ctrlMetaChars :: ClassifyMap ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars -- | esc, meta esc, delete, meta delete, enter, meta enter specialSupportKeys :: ClassifyMap specialSupportKeys = [ -- special support for ESC ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta]) -- Special support for backspace , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]) -- Special support for Enter , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter []) -- explicit support for tab , ("\t", EvKey (KChar '\t') []) ] -- | classify table directly generated from terminfo cap strings -- -- these are: -- -- * ka1 - keypad up-left -- -- * ka3 - keypad up-right -- -- * kb2 - keypad center -- -- * kbs - keypad backspace -- -- * kbeg - begin -- -- * kcbt - back tab -- -- * kc1 - keypad left-down -- -- * kc3 - keypad right-down -- -- * kdch1 - delete -- -- * kcud1 - down -- -- * kend - end -- -- * kent - enter -- -- * kf0 - kf63 - function keys -- -- * khome - KHome -- -- * kich1 - insert -- -- * kcub1 - left -- -- * knp - next page (page down) -- -- * kpp - previous page (page up) -- -- * kcuf1 - right -- -- * kDC - shift delete -- -- * kEND - shift end -- -- * kHOM - shift home -- -- * kIC - shift insert -- -- * kLFT - shift left -- -- * kRIT - shift right -- -- * kcuu1 - up keysFromCapsTable :: ClassifyMap keysFromCapsTable = [ ("ka1", EvKey KUpLeft []) , ("ka3", EvKey KUpRight []) , ("kb2", EvKey KCenter []) , ("kbs", EvKey KBS []) , ("kbeg", EvKey KBegin []) , ("kcbt", EvKey KBackTab []) , ("kc1", EvKey KDownLeft []) , ("kc3", EvKey KDownRight []) , ("kdch1", EvKey KDel []) , ("kcud1", EvKey KDown []) , ("kend", EvKey KEnd []) , ("kent", EvKey KEnter []) , ("khome", EvKey KHome []) , ("kich1", EvKey KIns []) , ("kcub1", EvKey KLeft []) , ("knp", EvKey KPageDown []) , ("kpp", EvKey KPageUp []) , ("kcuf1", EvKey KRight []) , ("kDC", EvKey KDel [MShift]) , ("kEND", EvKey KEnd [MShift]) , ("kHOM", EvKey KHome [MShift]) , ("kIC", EvKey KIns [MShift]) , ("kLFT", EvKey KLeft [MShift]) , ("kRIT", EvKey KRight [MShift]) , ("kcuu1", EvKey KUp []) ] ++ functionKeyCapsTable -- | cap names for function keys functionKeyCapsTable :: ClassifyMap functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) []) vty-5.4.0/src/Graphics/Vty/Input/Terminfo/0000755000000000000000000000000012563510500016520 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs0000644000000000000000000000547512563510500020073 0ustar0000000000000000-- | Input mappings for ANSI/VT100/VT50 terminals that is missing from terminfo. -- -- Or that are sent regardless of terminfo by terminal emulators. EG: Terminal emulators will often -- use VT50 input bytes regardless of declared terminal type. This provides compatibility with -- programs that don't follow terminfo. module Graphics.Vty.Input.Terminfo.ANSIVT where import Graphics.Vty.Input.Events -- | Encoding for navigation keys. -- -- TODO: This is not the same as the input bytes pulled from teh caps table. navKeys0 :: ClassifyMap navKeys0 = [ k "G" KCenter , k "P" KPause , k "A" KUp , k "B" KDown , k "C" KRight , k "D" KLeft , k "H" KHome , k "F" KEnd , k "E" KBegin ] where k c s = ("\ESC["++c,EvKey s []) -- | encoding for shift, meta and ctrl plus arrows/home/end navKeys1 :: ClassifyMap navKeys1 = [("\ESC[" ++ charCnt ++ show mc++c,EvKey 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 ] -- | encoding for ins, del, pageup, pagedown, home, end navKeys2 :: ClassifyMap navKeys2 = let k n s = ("\ESC["++show n++"~",EvKey s []) in zipWith k [2::Int,3,5,6,1,4] [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] -- | encoding for ctrl + ins, del, pageup, pagedown, home, end navKeys3 :: ClassifyMap navKeys3 = let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl]) in zipWith k [2::Int,3,5,6,1,4] [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] -- | encoding for shift plus function keys -- -- According to -- -- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html -- -- This encoding depends on the terminal. functionKeys1 :: ClassifyMap functionKeys1 = let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ] -- | encoding for meta plus char -- -- TODO: resolve - -- -- 1. removed 'ESC' from second list due to duplication with "special_support_keys". -- 2. removed '[' from second list due to conflict with 7-bit encoding for ESC. Whether meta+[ is -- the same as ESC should examine km and current encoding. -- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by -- special_support_keys. functionKeys2 :: ClassifyMap functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta]) | x <- '\t':[' ' .. '~'] , x /= '[' ] classifyTable :: [ClassifyMap] classifyTable = [ navKeys0 , navKeys1 , navKeys2 , navKeys3 , functionKeys1 , functionKeys2 ] vty-5.4.0/src/Graphics/Vty/Output/0000755000000000000000000000000012563510500015136 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty/Output/Mock.hs0000644000000000000000000000641212563510500016366 0ustar0000000000000000-- Copyright Corey O'Connor {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -- | This provides a mock terminal implementation that is nice for testing. This transforms the -- output operations to visible characters. Which is nice for some tests. module Graphics.Vty.Output.Mock ( MockData, mockTerminal ) where import Graphics.Vty.Prelude import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder.Word (writeWord8) import Control.Monad.Trans import qualified Data.ByteString as BS import Data.IORef import qualified Data.String.UTF8 as UTF8 type MockData = IORef (UTF8.UTF8 BS.ByteString) -- | The mock 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 mock 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. -- -- The string representation is a sequence of identifiers where each identifier is the name of an -- operation in the algebra. mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output) mockTerminal r = liftIO $ do outRef <- newIORef undefined newAssumedStateRef <- newIORef initialAssumedState let t = Output { terminalID = "mock terminal" , releaseTerminal = return () , reserveDisplay = return () , releaseDisplay = return () , displayBounds = return r , outputByteBuffer = \bytes -> do putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes" writeIORef outRef $ UTF8.fromRep bytes , contextColorCount = 16 , supportsCursorVisibility = True , assumedStateRef = newAssumedStateRef , mkDisplayContext = \tActual rActual -> return $ DisplayContext { contextRegion = rActual , contextDevice = tActual -- A cursor move is always visualized as the single character 'M' , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M' -- Show cursor is always visualized as the single character 'S' , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S' -- Hide cursor is always visualized as the single character 'H' , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H' -- An attr change is always visualized as the single character 'A' , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A' -- default attr is always visualized as the single character 'D' , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D' -- row end is always visualized as the single character 'E' , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E' , inlineHack = return () } } return (outRef, t) vty-5.4.0/src/Graphics/Vty/Output/Interface.hs0000644000000000000000000002715112563510500017400 0ustar0000000000000000-- Copyright Corey O'Connor -- General philosophy is: MonadIO is for equations exposed to clients. {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif module Graphics.Vty.Output.Interface where import Graphics.Vty.Prelude import Graphics.Vty.Picture import Graphics.Vty.PictureToSpans import Graphics.Vty.Span import Graphics.Vty.DisplayAttributes import Blaze.ByteString.Builder (Write, writeToByteString) import Blaze.ByteString.Builder.ByteString (writeByteString) import Control.Monad.Trans import qualified Data.ByteString as BS import Data.IORef import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Vector as Vector #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (mempty, mappend) #endif data Output = Output { -- | Text identifier for the output device. Used for debugging. terminalID :: String , releaseTerminal :: forall m. MonadIO m => 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 released the display returns to the previous state. , reserveDisplay :: forall m. MonadIO m => m () -- | Return the display to the state before `reserveDisplay` -- If no previous state then set the display state to the initial state. , releaseDisplay :: forall m. MonadIO m => m () -- | Returns the current display bounds. , displayBounds :: forall m. MonadIO m => m DisplayRegion -- | Output the byte string to the terminal device. , outputByteBuffer :: BS.ByteString -> IO () -- | Maximum number of colors supported by the context. , contextColorCount :: Int -- | if the cursor can be shown / hidden , supportsCursorVisibility :: Bool , assumedStateRef :: IORef AssumedState -- | 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 displayWidth providedWidth, max displayHeight providedHeight) , mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext } displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext displayContext t = liftIO . mkDisplayContext t t data AssumedState = AssumedState { prevFattr :: Maybe FixedAttr , prevOutputOps :: Maybe DisplayOps } initialAssumedState :: AssumedState initialAssumedState = AssumedState Nothing Nothing data DisplayContext = DisplayContext { contextDevice :: Output -- | Provide the bounds of the display context. , contextRegion :: DisplayRegion -- | 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. , writeMoveCursor :: Int -> Int -> Write , writeShowCursor :: Write , writeHideCursor :: Write -- | 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. , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write -- | Reset the display attributes to the default display attributes , writeDefaultAttr :: Write , writeRowEnd :: Write -- | See `Graphics.Vty.Output.XTermColor.inlineHack` , inlineHack :: IO () } -- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory. writeUtf8Text :: BS.ByteString -> Write writeUtf8Text = writeByteString -- | 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. outputPicture :: MonadIO m => DisplayContext -> Picture -> m () outputPicture dc pic = liftIO $ do as <- readIORef (assumedStateRef $ contextDevice dc) let manipCursor = supportsCursorVisibility (contextDevice dc) r = contextRegion dc ops = displayOpsForPic pic r initialAttr = FixedAttr defaultStyleMask Nothing Nothing -- Diff the previous output against the requested output. Differences are currently on a per-row -- basis. -- \todo handle resizes that crop the dominate directions better. diffs :: [Bool] = case prevOutputOps as of Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True Just previousOps -> if effectedRegion previousOps /= effectedRegion ops then replicate (displayOpsRows ops) True else zipWith (/=) (Vector.toList previousOps) (Vector.toList ops) -- build the Write corresponding to the output image out = (if manipCursor then writeHideCursor dc else mempty) `mappend` writeOutputOps dc initialAttr diffs ops `mappend` (case picCursor pic of _ | not manipCursor -> mempty NoCursor -> mempty Cursor x y -> let m = cursorOutputMap ops $ picCursor pic (ox, oy) = charToOutputPos m (x,y) in writeShowCursor dc `mappend` writeMoveCursor dc ox oy ) -- ... then serialize outputByteBuffer (contextDevice dc) (writeToByteString out) -- Cache the output spans. let as' = as { prevOutputOps = Just ops } writeIORef (assumedStateRef $ contextDevice dc) as' writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write writeOutputOps dc initialAttr diffs ops = let (_, out, _) = Vector.foldl' writeOutputOps' (0, mempty, diffs) ops in out where writeOutputOps' (y, out, True : diffs') spanOps = let spanOut = writeSpanOps dc y initialAttr spanOps out' = out `mappend` spanOut in (y+1, out', diffs') writeOutputOps' (y, out, False : diffs') _spanOps = (y + 1, out, diffs') writeOutputOps' (_y, _out, []) _spanOps = error "vty - output spans without a corresponding diff." writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> Write writeSpanOps dc y initialAttr spanOps = -- The first operation is to set the cursor to the start of the row let start = writeMoveCursor dc 0 y `mappend` writeDefaultAttr dc -- then the span ops are serialized in the order specified in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of (opOut, fattr') -> (out `mappend` opOut, fattr') ) (start, initialAttr) spanOps writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr) writeSpanOp dc (TextSpan attr _ _ str) fattr = let attr' = limitAttrForDisplay (contextDevice dc) attr fattr' = fixDisplayAttr fattr attr' diffs = displayAttrDiffs fattr fattr' out = writeSetAttr dc fattr attr' diffs `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str) in (out, fattr') writeSpanOp _dc (Skip _) _fattr = error "writeSpanOp for Skip" writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc, fattr) -- | The cursor position is given in X,Y character offsets. Due to multi-column characters this -- needs to be translated to column, row positions. data CursorOutputMap = CursorOutputMap { charToOutputPos :: (Int, Int) -> (Int, Int) } cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap cursorOutputMap spanOps _cursor = CursorOutputMap { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy) } cursorColumnOffset :: DisplayOps -> Int -> Int -> Int cursorColumnOffset ops cx cy = let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy) (outOffset, _, _) = Vector.foldl' ( \(d, currentCx, done) op -> if done then (d, currentCx, done) else case spanOpHasWidth op of Nothing -> (d, currentCx, False) Just (cw, ow) -> case compare cx (currentCx + cw) of GT -> ( d + ow , currentCx + cw , False ) EQ -> ( d + ow , currentCx + cw , True ) LT -> ( d + columnsToCharOffset (cx - currentCx) op , currentCx + cw , True ) ) (0, 0, False) cursorRowOps in outOffset -- | Not all terminals support all display attributes. This filters a display attribute to what the -- given terminal can display. limitAttrForDisplay :: Output -> Attr -> Attr limitAttrForDisplay t attr = attr { attrForeColor = clampColor $ attrForeColor attr , attrBackColor = clampColor $ attrBackColor attr } where clampColor Default = Default clampColor KeepCurrent = KeepCurrent clampColor (SetTo c) = clampColor' c clampColor' (ISOColor v) | contextColorCount t < 8 = Default | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8) | otherwise = SetTo $ ISOColor v clampColor' (Color240 v) -- TODO: Choose closes ISO color? | contextColorCount t < 8 = Default | contextColorCount t < 16 = Default | contextColorCount t <= 256 = SetTo $ Color240 v | otherwise = let p :: Double = fromIntegral v / 240.0 v' = floor $ p * (fromIntegral $ contextColorCount t) in SetTo $ Color240 v' vty-5.4.0/src/Graphics/Vty/Output/TerminfoBased.hs0000644000000000000000000004773212563510500020231 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-} {-# CFILES gwinsz.c #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif -- | Terminfo based terminal handling. -- -- The color handling assumes tektronix like. No HP support provided. If the terminal is not one I -- have easy access to then color support is entirely based of the docs. Probably with some -- assumptions mixed in. -- -- Copyright Corey O'Connor (coreyoconnor@gmail.com) module Graphics.Vty.Output.TerminfoBased ( reserveTerminal ) where import Graphics.Vty.Prelude import Data.ByteString.Internal (toForeignPtr) import Data.Terminfo.Parse import Data.Terminfo.Eval import Graphics.Vty.Attributes import Graphics.Vty.DisplayAttributes import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder (Write, writeToByteString) import Control.Monad.Trans import Data.Bits ((.&.)) import Data.IORef import Data.Maybe (isJust, isNothing, fromJust) import Data.Word import Foreign.C.Types ( CInt(..), CLong(..) ) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import qualified System.Console.Terminfo as Terminfo import System.Posix.IO (fdWriteBuf) import System.Posix.Types (Fd(..)) #if !(MIN_VERSION_base(4,8,0)) import Data.Foldable (foldMap) import Data.Monoid #endif data TerminfoCaps = TerminfoCaps { smcup :: Maybe CapExpression , rmcup :: Maybe CapExpression , cup :: CapExpression , cnorm :: Maybe CapExpression , civis :: Maybe CapExpression , supportsNoColors :: Bool , useAltColorMap :: Bool , setForeColor :: CapExpression , setBackColor :: CapExpression , setDefaultAttr :: CapExpression , clearScreen :: CapExpression , clearEol :: CapExpression , displayAttrCaps :: DisplayAttrCaps } data DisplayAttrCaps = DisplayAttrCaps { setAttrStates :: Maybe CapExpression , enterStandout :: Maybe CapExpression , exitStandout :: Maybe CapExpression , enterUnderline :: Maybe CapExpression , exitUnderline :: Maybe CapExpression , enterReverseVideo :: Maybe CapExpression , enterDimMode :: Maybe CapExpression , enterBoldMode :: Maybe CapExpression } -- kinda like: https://code.google.com/p/vim/source/browse/src/fileio.c#10422 -- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR the write will be retried. fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int fdWriteAll outFd ptr len count | len < 0 = fail "fdWriteAll: len is less than 0" | len == 0 = return count | otherwise = do writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len) let len' = len - writeCount ptr' = ptr `plusPtr` writeCount count' = count + writeCount fdWriteAll outFd ptr' len' count' sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO () sendCapToTerminal t cap capParams = do outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams {- | 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. -} reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output reserveTerminal termName outFd = liftIO $ do ti <- Terminfo.setupTerm termName -- assumes set foreground always implies set background exists. -- if set foreground is not set then all color changing style attributes are filtered. msetaf <- probeCap ti "setaf" msetf <- probeCap ti "setf" let (noColors, useAlt, setForeCap) = case msetaf of Just setaf -> (False, False, setaf) Nothing -> case msetf of Just setf -> (False, True, setf) Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName) msetab <- probeCap ti "setab" msetb <- probeCap ti "setb" let set_back_cap = case msetab of Nothing -> case msetb of Just setb -> setb Nothing -> error $ "no back color support for terminal " ++ termName Just setab -> setab terminfoCaps <- pure TerminfoCaps <*> probeCap ti "smcup" <*> probeCap ti "rmcup" <*> requireCap ti "cup" <*> probeCap ti "cnorm" <*> probeCap ti "civis" <*> pure noColors <*> pure useAlt <*> pure setForeCap <*> pure set_back_cap <*> requireCap ti "sgr0" <*> requireCap ti "clear" <*> requireCap ti "el" <*> currentDisplayAttrCaps ti newAssumedStateRef <- newIORef initialAssumedState let t = Output { terminalID = termName , releaseTerminal = liftIO $ do sendCap setDefaultAttr [] maybeSendCap cnorm [] , reserveDisplay = liftIO $ do -- If there is no support for smcup: Clear the screen and then move the mouse to the -- home position to approximate the behavior. maybeSendCap smcup [] sendCap clearScreen [] , releaseDisplay = liftIO $ do maybeSendCap rmcup [] maybeSendCap cnorm [] , displayBounds = do rawSize <- liftIO $ getWindowSize outFd case rawSize of (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize | otherwise -> return (w,h) , outputByteBuffer = \outBytes -> do let (fptr, offset, len) = toForeignPtr outBytes actualLen <- withForeignPtr fptr $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer " ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen ++ " Please report this bug to vty project." , contextColorCount = case supportsNoColors terminfoCaps of False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of Nothing -> 8 Just v -> toEnum v True -> 1 , supportsCursorVisibility = isJust $ civis terminfoCaps , assumedStateRef = newAssumedStateRef -- I think fix would help assure tActual is the only reference. I was having issues -- tho. , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps } sendCap s = sendCapToTerminal t (s terminfoCaps) maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s) return t requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression requireCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\"" Just capStr -> parseCap capStr probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression) probeCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> return Nothing Just capStr -> Just <$> parseCap capStr parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression parseCap capStr = do case parseCapExpression capStr of Left e -> fail $ show e Right cap -> return cap currentDisplayAttrCaps :: ( Applicative m, MonadIO m ) => Terminfo.Terminal -> m DisplayAttrCaps currentDisplayAttrCaps ti = pure DisplayAttrCaps <*> probeCap ti "sgr" <*> probeCap ti "smso" <*> probeCap ti "rmso" <*> probeCap ti "smul" <*> probeCap ti "rmul" <*> probeCap ti "rev" <*> probeCap ti "dim" <*> probeCap ti "bold" foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong getWindowSize :: Fd -> IO (Int,Int) getWindowSize fd = do (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd return (fromIntegral b, fromIntegral a) terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext terminfoDisplayContext tActual terminfoCaps r = return dc where dc = DisplayContext { contextDevice = tActual , contextRegion = r , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x] , writeShowCursor = case cnorm terminfoCaps of Nothing -> error "this terminal does not support show cursor" Just c -> writeCapExpr c [] , writeHideCursor = case civis terminfoCaps of Nothing -> error "this terminal does not support hide cursor" Just c -> writeCapExpr c [] , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) [] , writeRowEnd = writeCapExpr (clearEol terminfoCaps) [] , inlineHack = return () } -- | 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 procedure is used: -- -- 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 cap 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. -- -- This equation implements the above logic. -- -- \todo This assumes the removal of color changes in the display attributes is done as expected -- with noColors == True. See `limitAttrForDisplay` -- -- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I -- haven't measured this or even examined terminal implementations. *shrug* terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do case (foreColorDiff diffs == ColorToDefault) || (backColorDiff 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 reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) (fixedStyle attr ) (styleToApplySeq $ fixedStyle attr) of -- only way to reset a color to the defaults EnterExitSeq caps -> writeDefaultAttr dc `mappend` foldMap (\cap -> writeCapExpr cap []) caps `mappend` setColors -- implicitly resets the colors to the defaults SetState state -> writeCapExpr (fromJust $ setAttrStates $ displayAttrCaps $ terminfoCaps ) (sgrArgsForState state) `mappend` setColors -- 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 reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) (fixedStyle attr) (styleDiffs 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 -> foldMap (\cap -> writeCapExpr cap []) caps `mappend` writeColorDiff setForeColor (foreColorDiff diffs) `mappend` writeColorDiff setBackColor (backColorDiff diffs) -- implicitly resets the colors to the defaults SetState state -> writeCapExpr (fromJust $ setAttrStates $ displayAttrCaps terminfoCaps ) (sgrArgsForState state) `mappend` setColors where colorMap = case useAltColorMap terminfoCaps of False -> ansiColorIndex True -> altColorIndex attr = fixDisplayAttr prevAttr reqAttr setColors = (case fixedForeColor attr of Just c -> writeCapExpr (setForeColor terminfoCaps) [toEnum $ colorMap c] Nothing -> mempty) `mappend` (case fixedBackColor attr of Just c -> writeCapExpr (setBackColor terminfoCaps) [toEnum $ colorMap c] Nothing -> mempty) writeColorDiff _f NoColorChange = mempty writeColorDiff _f ColorToDefault = error "ColorToDefault is not a possible case for applyColorDiffs" writeColorDiff f (SetColor c) = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c] -- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not -- be supported by the terminal. -- -- This takes a Color which clearly identifies which pallete to use and computes the index -- into the full 256 color pallete. ansiColorIndex :: Color -> Int ansiColorIndex (ISOColor v) = fromEnum v ansiColorIndex (Color240 v) = 16 + fromEnum v -- | For terminals without setaf/setab -- -- See table in `man terminfo` -- Will error if not in table. altColorIndex :: Color -> Int altColorIndex (ISOColor 0) = 0 altColorIndex (ISOColor 1) = 4 altColorIndex (ISOColor 2) = 2 altColorIndex (ISOColor 3) = 6 altColorIndex (ISOColor 4) = 1 altColorIndex (ISOColor 5) = 5 altColorIndex (ISOColor 6) = 3 altColorIndex (ISOColor 7) = 7 altColorIndex (ISOColor v) = fromEnum v altColorIndex (Color240 v) = 16 + 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 { applyStandout :: Bool , applyUnderline :: Bool , applyReverseVideo :: Bool , applyBlink :: Bool , applyDim :: Bool , applyBold :: Bool } sgrArgsForState :: DisplayAttrState -> [CapParam] sgrArgsForState attrState = map (\b -> if b then 1 else 0) [ applyStandout attrState , applyUnderline attrState , applyReverseVideo attrState , applyBlink attrState , applyDim attrState , applyBold attrState , False -- invis , False -- protect , False -- alt char set ] reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq reqDisplayCapSeqFor 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 noEnterExitCap diffs, isJust $ setAttrStates caps) of -- If all the diffs have an enter-exit cap then just use those ( False, _ ) -> EnterExitSeq $ map enterExitCap 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 enterExitCap $ filter (not . noEnterExitCap) 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 $ stateForStyle s where noEnterExitCap ApplyStandout = isNothing $ enterStandout caps noEnterExitCap RemoveStandout = isNothing $ exitStandout caps noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps noEnterExitCap RemoveReverseVideo = True noEnterExitCap ApplyBlink = True noEnterExitCap RemoveBlink = True noEnterExitCap ApplyDim = isNothing $ enterDimMode caps noEnterExitCap RemoveDim = True noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps noEnterExitCap RemoveBold = True enterExitCap ApplyStandout = fromJust $ enterStandout caps enterExitCap RemoveStandout = fromJust $ exitStandout caps enterExitCap ApplyUnderline = fromJust $ enterUnderline caps enterExitCap RemoveUnderline = fromJust $ exitUnderline caps enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps enterExitCap ApplyDim = fromJust $ enterDimMode caps enterExitCap ApplyBold = fromJust $ enterBoldMode caps enterExitCap _ = error "enterExitCap applied to diff that was known not to have one." stateForStyle :: Style -> DisplayAttrState stateForStyle s = DisplayAttrState { applyStandout = isStyleSet standout , applyUnderline = isStyleSet underline , applyReverseVideo = isStyleSet reverseVideo , applyBlink = isStyleSet blink , applyDim = isStyleSet dim , applyBold = isStyleSet bold } where isStyleSet = hasStyle s styleToApplySeq :: Style -> [StyleStateChange] styleToApplySeq s = concat [ applyIfRequired ApplyStandout standout , applyIfRequired ApplyUnderline underline , applyIfRequired ApplyReverseVideo reverseVideo , applyIfRequired ApplyBlink blink , applyIfRequired ApplyDim dim , applyIfRequired ApplyBlink bold ] where applyIfRequired op flag = if 0 == (flag .&. s) then [] else [op] vty-5.4.0/src/Graphics/Vty/Output/XTermColor.hs0000644000000000000000000000412612563510500017533 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Output.XTermColor ( reserveTerminal ) where import Graphics.Vty.Output.Interface import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased import Blaze.ByteString.Builder (writeToByteString) import Blaze.ByteString.Builder.Word (writeWord8) import Control.Monad (void) import Control.Monad.Trans import System.Posix.IO (fdWrite) import System.Posix.Types (Fd) #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative import Data.Foldable (foldMap) #endif -- | Initialize the display to UTF-8. reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output reserveTerminal variant outFd = liftIO $ do let flushedPut = void . fdWrite outFd -- 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 flushedPut setUtf8CharSet t <- TerminfoBased.reserveTerminal variant' outFd let t' = t { terminalID = terminalID t ++ " (xterm-color)" , releaseTerminal = do liftIO $ flushedPut setDefaultCharSet releaseTerminal t , mkDisplayContext = \tActual r -> do dc <- mkDisplayContext t tActual r return $ dc { inlineHack = xtermInlineHack t' } } return t' -- | These sequences set xterm based terminals to UTF-8 output. -- -- \todo I don't know of a terminfo cap that is equivalent to this. setUtf8CharSet, setDefaultCharSet :: String setUtf8CharSet = "\ESC%G" setDefaultCharSet = "\ESC%@" -- | 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. xtermInlineHack :: Output -> IO () xtermInlineHack t = do let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K" outputByteBuffer t $ writeToByteString writeReset vty-5.4.0/src/Graphics/Vty/Attributes/0000755000000000000000000000000012563510500015764 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty/Attributes/Color240.hs0000644000000000000000000003163212563510500017631 0ustar0000000000000000{- - This header file was generated by ./256colres.pl -} module Graphics.Vty.Attributes.Color240 where import Graphics.Vty.Attributes.Color import Text.Printf -- | RGB color to 240 color palette. -- -- generated from 256colres.pl which is forked from xterm 256colres.pl -- todo: all values get clamped high. rgbColor :: Integral i => i -> i -> i -> Color rgbColor r g b | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity" | r == 8 && g == 8 && b == 8 = Color240 216 | r == 18 && g == 18 && b == 18 = Color240 217 | r == 28 && g == 28 && b == 28 = Color240 218 | r == 38 && g == 38 && b == 38 = Color240 219 | r == 48 && g == 48 && b == 48 = Color240 220 | r == 58 && g == 58 && b == 58 = Color240 221 | r == 68 && g == 68 && b == 68 = Color240 222 | r == 78 && g == 78 && b == 78 = Color240 223 | r == 88 && g == 88 && b == 88 = Color240 224 | r == 98 && g == 98 && b == 98 = Color240 225 | r == 108 && g == 108 && b == 108 = Color240 226 | r == 118 && g == 118 && b == 118 = Color240 227 | r == 128 && g == 128 && b == 128 = Color240 228 | r == 138 && g == 138 && b == 138 = Color240 229 | r == 148 && g == 148 && b == 148 = Color240 230 | r == 158 && g == 158 && b == 158 = Color240 231 | r == 168 && g == 168 && b == 168 = Color240 232 | r == 178 && g == 178 && b == 178 = Color240 233 | r == 188 && g == 188 && b == 188 = Color240 234 | r == 198 && g == 198 && b == 198 = Color240 235 | r == 208 && g == 208 && b == 208 = Color240 236 | r == 218 && g == 218 && b == 218 = Color240 237 | r == 228 && g == 228 && b == 228 = Color240 238 | r == 238 && g == 238 && b == 238 = Color240 239 | r <= 0 && g <= 0 && b <= 0 = Color240 0 | r <= 0 && g <= 0 && b <= 95 = Color240 1 | r <= 0 && g <= 0 && b <= 135 = Color240 2 | r <= 0 && g <= 0 && b <= 175 = Color240 3 | r <= 0 && g <= 0 && b <= 215 = Color240 4 | r <= 0 && g <= 0 && b <= 255 = Color240 5 | r <= 0 && g <= 95 && b <= 0 = Color240 6 | r <= 0 && g <= 95 && b <= 95 = Color240 7 | r <= 0 && g <= 95 && b <= 135 = Color240 8 | r <= 0 && g <= 95 && b <= 175 = Color240 9 | r <= 0 && g <= 95 && b <= 215 = Color240 10 | r <= 0 && g <= 95 && b <= 255 = Color240 11 | r <= 0 && g <= 135 && b <= 0 = Color240 12 | r <= 0 && g <= 135 && b <= 95 = Color240 13 | r <= 0 && g <= 135 && b <= 135 = Color240 14 | r <= 0 && g <= 135 && b <= 175 = Color240 15 | r <= 0 && g <= 135 && b <= 215 = Color240 16 | r <= 0 && g <= 135 && b <= 255 = Color240 17 | r <= 0 && g <= 175 && b <= 0 = Color240 18 | r <= 0 && g <= 175 && b <= 95 = Color240 19 | r <= 0 && g <= 175 && b <= 135 = Color240 20 | r <= 0 && g <= 175 && b <= 175 = Color240 21 | r <= 0 && g <= 175 && b <= 215 = Color240 22 | r <= 0 && g <= 175 && b <= 255 = Color240 23 | r <= 0 && g <= 215 && b <= 0 = Color240 24 | r <= 0 && g <= 215 && b <= 95 = Color240 25 | r <= 0 && g <= 215 && b <= 135 = Color240 26 | r <= 0 && g <= 215 && b <= 175 = Color240 27 | r <= 0 && g <= 215 && b <= 215 = Color240 28 | r <= 0 && g <= 215 && b <= 255 = Color240 29 | r <= 0 && g <= 255 && b <= 0 = Color240 30 | r <= 0 && g <= 255 && b <= 95 = Color240 31 | r <= 0 && g <= 255 && b <= 135 = Color240 32 | r <= 0 && g <= 255 && b <= 175 = Color240 33 | r <= 0 && g <= 255 && b <= 215 = Color240 34 | r <= 0 && g <= 255 && b <= 255 = Color240 35 | r <= 95 && g <= 0 && b <= 0 = Color240 36 | r <= 95 && g <= 0 && b <= 95 = Color240 37 | r <= 95 && g <= 0 && b <= 135 = Color240 38 | r <= 95 && g <= 0 && b <= 175 = Color240 39 | r <= 95 && g <= 0 && b <= 215 = Color240 40 | r <= 95 && g <= 0 && b <= 255 = Color240 41 | r <= 95 && g <= 95 && b <= 0 = Color240 42 | r <= 95 && g <= 95 && b <= 95 = Color240 43 | r <= 95 && g <= 95 && b <= 135 = Color240 44 | r <= 95 && g <= 95 && b <= 175 = Color240 45 | r <= 95 && g <= 95 && b <= 215 = Color240 46 | r <= 95 && g <= 95 && b <= 255 = Color240 47 | r <= 95 && g <= 135 && b <= 0 = Color240 48 | r <= 95 && g <= 135 && b <= 95 = Color240 49 | r <= 95 && g <= 135 && b <= 135 = Color240 50 | r <= 95 && g <= 135 && b <= 175 = Color240 51 | r <= 95 && g <= 135 && b <= 215 = Color240 52 | r <= 95 && g <= 135 && b <= 255 = Color240 53 | r <= 95 && g <= 175 && b <= 0 = Color240 54 | r <= 95 && g <= 175 && b <= 95 = Color240 55 | r <= 95 && g <= 175 && b <= 135 = Color240 56 | r <= 95 && g <= 175 && b <= 175 = Color240 57 | r <= 95 && g <= 175 && b <= 215 = Color240 58 | r <= 95 && g <= 175 && b <= 255 = Color240 59 | r <= 95 && g <= 215 && b <= 0 = Color240 60 | r <= 95 && g <= 215 && b <= 95 = Color240 61 | r <= 95 && g <= 215 && b <= 135 = Color240 62 | r <= 95 && g <= 215 && b <= 175 = Color240 63 | r <= 95 && g <= 215 && b <= 215 = Color240 64 | r <= 95 && g <= 215 && b <= 255 = Color240 65 | r <= 95 && g <= 255 && b <= 0 = Color240 66 | r <= 95 && g <= 255 && b <= 95 = Color240 67 | r <= 95 && g <= 255 && b <= 135 = Color240 68 | r <= 95 && g <= 255 && b <= 175 = Color240 69 | r <= 95 && g <= 255 && b <= 215 = Color240 70 | r <= 95 && g <= 255 && b <= 255 = Color240 71 | r <= 135 && g <= 0 && b <= 0 = Color240 72 | r <= 135 && g <= 0 && b <= 95 = Color240 73 | r <= 135 && g <= 0 && b <= 135 = Color240 74 | r <= 135 && g <= 0 && b <= 175 = Color240 75 | r <= 135 && g <= 0 && b <= 215 = Color240 76 | r <= 135 && g <= 0 && b <= 255 = Color240 77 | r <= 135 && g <= 95 && b <= 0 = Color240 78 | r <= 135 && g <= 95 && b <= 95 = Color240 79 | r <= 135 && g <= 95 && b <= 135 = Color240 80 | r <= 135 && g <= 95 && b <= 175 = Color240 81 | r <= 135 && g <= 95 && b <= 215 = Color240 82 | r <= 135 && g <= 95 && b <= 255 = Color240 83 | r <= 135 && g <= 135 && b <= 0 = Color240 84 | r <= 135 && g <= 135 && b <= 95 = Color240 85 | r <= 135 && g <= 135 && b <= 135 = Color240 86 | r <= 135 && g <= 135 && b <= 175 = Color240 87 | r <= 135 && g <= 135 && b <= 215 = Color240 88 | r <= 135 && g <= 135 && b <= 255 = Color240 89 | r <= 135 && g <= 175 && b <= 0 = Color240 90 | r <= 135 && g <= 175 && b <= 95 = Color240 91 | r <= 135 && g <= 175 && b <= 135 = Color240 92 | r <= 135 && g <= 175 && b <= 175 = Color240 93 | r <= 135 && g <= 175 && b <= 215 = Color240 94 | r <= 135 && g <= 175 && b <= 255 = Color240 95 | r <= 135 && g <= 215 && b <= 0 = Color240 96 | r <= 135 && g <= 215 && b <= 95 = Color240 97 | r <= 135 && g <= 215 && b <= 135 = Color240 98 | r <= 135 && g <= 215 && b <= 175 = Color240 99 | r <= 135 && g <= 215 && b <= 215 = Color240 100 | r <= 135 && g <= 215 && b <= 255 = Color240 101 | r <= 135 && g <= 255 && b <= 0 = Color240 102 | r <= 135 && g <= 255 && b <= 95 = Color240 103 | r <= 135 && g <= 255 && b <= 135 = Color240 104 | r <= 135 && g <= 255 && b <= 175 = Color240 105 | r <= 135 && g <= 255 && b <= 215 = Color240 106 | r <= 135 && g <= 255 && b <= 255 = Color240 107 | r <= 175 && g <= 0 && b <= 0 = Color240 108 | r <= 175 && g <= 0 && b <= 95 = Color240 109 | r <= 175 && g <= 0 && b <= 135 = Color240 110 | r <= 175 && g <= 0 && b <= 175 = Color240 111 | r <= 175 && g <= 0 && b <= 215 = Color240 112 | r <= 175 && g <= 0 && b <= 255 = Color240 113 | r <= 175 && g <= 95 && b <= 0 = Color240 114 | r <= 175 && g <= 95 && b <= 95 = Color240 115 | r <= 175 && g <= 95 && b <= 135 = Color240 116 | r <= 175 && g <= 95 && b <= 175 = Color240 117 | r <= 175 && g <= 95 && b <= 215 = Color240 118 | r <= 175 && g <= 95 && b <= 255 = Color240 119 | r <= 175 && g <= 135 && b <= 0 = Color240 120 | r <= 175 && g <= 135 && b <= 95 = Color240 121 | r <= 175 && g <= 135 && b <= 135 = Color240 122 | r <= 175 && g <= 135 && b <= 175 = Color240 123 | r <= 175 && g <= 135 && b <= 215 = Color240 124 | r <= 175 && g <= 135 && b <= 255 = Color240 125 | r <= 175 && g <= 175 && b <= 0 = Color240 126 | r <= 175 && g <= 175 && b <= 95 = Color240 127 | r <= 175 && g <= 175 && b <= 135 = Color240 128 | r <= 175 && g <= 175 && b <= 175 = Color240 129 | r <= 175 && g <= 175 && b <= 215 = Color240 130 | r <= 175 && g <= 175 && b <= 255 = Color240 131 | r <= 175 && g <= 215 && b <= 0 = Color240 132 | r <= 175 && g <= 215 && b <= 95 = Color240 133 | r <= 175 && g <= 215 && b <= 135 = Color240 134 | r <= 175 && g <= 215 && b <= 175 = Color240 135 | r <= 175 && g <= 215 && b <= 215 = Color240 136 | r <= 175 && g <= 215 && b <= 255 = Color240 137 | r <= 175 && g <= 255 && b <= 0 = Color240 138 | r <= 175 && g <= 255 && b <= 95 = Color240 139 | r <= 175 && g <= 255 && b <= 135 = Color240 140 | r <= 175 && g <= 255 && b <= 175 = Color240 141 | r <= 175 && g <= 255 && b <= 215 = Color240 142 | r <= 175 && g <= 255 && b <= 255 = Color240 143 | r <= 215 && g <= 0 && b <= 0 = Color240 144 | r <= 215 && g <= 0 && b <= 95 = Color240 145 | r <= 215 && g <= 0 && b <= 135 = Color240 146 | r <= 215 && g <= 0 && b <= 175 = Color240 147 | r <= 215 && g <= 0 && b <= 215 = Color240 148 | r <= 215 && g <= 0 && b <= 255 = Color240 149 | r <= 215 && g <= 95 && b <= 0 = Color240 150 | r <= 215 && g <= 95 && b <= 95 = Color240 151 | r <= 215 && g <= 95 && b <= 135 = Color240 152 | r <= 215 && g <= 95 && b <= 175 = Color240 153 | r <= 215 && g <= 95 && b <= 215 = Color240 154 | r <= 215 && g <= 95 && b <= 255 = Color240 155 | r <= 215 && g <= 135 && b <= 0 = Color240 156 | r <= 215 && g <= 135 && b <= 95 = Color240 157 | r <= 215 && g <= 135 && b <= 135 = Color240 158 | r <= 215 && g <= 135 && b <= 175 = Color240 159 | r <= 215 && g <= 135 && b <= 215 = Color240 160 | r <= 215 && g <= 135 && b <= 255 = Color240 161 | r <= 215 && g <= 175 && b <= 0 = Color240 162 | r <= 215 && g <= 175 && b <= 95 = Color240 163 | r <= 215 && g <= 175 && b <= 135 = Color240 164 | r <= 215 && g <= 175 && b <= 175 = Color240 165 | r <= 215 && g <= 175 && b <= 215 = Color240 166 | r <= 215 && g <= 175 && b <= 255 = Color240 167 | r <= 215 && g <= 215 && b <= 0 = Color240 168 | r <= 215 && g <= 215 && b <= 95 = Color240 169 | r <= 215 && g <= 215 && b <= 135 = Color240 170 | r <= 215 && g <= 215 && b <= 175 = Color240 171 | r <= 215 && g <= 215 && b <= 215 = Color240 172 | r <= 215 && g <= 215 && b <= 255 = Color240 173 | r <= 215 && g <= 255 && b <= 0 = Color240 174 | r <= 215 && g <= 255 && b <= 95 = Color240 175 | r <= 215 && g <= 255 && b <= 135 = Color240 176 | r <= 215 && g <= 255 && b <= 175 = Color240 177 | r <= 215 && g <= 255 && b <= 215 = Color240 178 | r <= 215 && g <= 255 && b <= 255 = Color240 179 | r <= 255 && g <= 0 && b <= 0 = Color240 180 | r <= 255 && g <= 0 && b <= 95 = Color240 181 | r <= 255 && g <= 0 && b <= 135 = Color240 182 | r <= 255 && g <= 0 && b <= 175 = Color240 183 | r <= 255 && g <= 0 && b <= 215 = Color240 184 | r <= 255 && g <= 0 && b <= 255 = Color240 185 | r <= 255 && g <= 95 && b <= 0 = Color240 186 | r <= 255 && g <= 95 && b <= 95 = Color240 187 | r <= 255 && g <= 95 && b <= 135 = Color240 188 | r <= 255 && g <= 95 && b <= 175 = Color240 189 | r <= 255 && g <= 95 && b <= 215 = Color240 190 | r <= 255 && g <= 95 && b <= 255 = Color240 191 | r <= 255 && g <= 135 && b <= 0 = Color240 192 | r <= 255 && g <= 135 && b <= 95 = Color240 193 | r <= 255 && g <= 135 && b <= 135 = Color240 194 | r <= 255 && g <= 135 && b <= 175 = Color240 195 | r <= 255 && g <= 135 && b <= 215 = Color240 196 | r <= 255 && g <= 135 && b <= 255 = Color240 197 | r <= 255 && g <= 175 && b <= 0 = Color240 198 | r <= 255 && g <= 175 && b <= 95 = Color240 199 | r <= 255 && g <= 175 && b <= 135 = Color240 200 | r <= 255 && g <= 175 && b <= 175 = Color240 201 | r <= 255 && g <= 175 && b <= 215 = Color240 202 | r <= 255 && g <= 175 && b <= 255 = Color240 203 | r <= 255 && g <= 215 && b <= 0 = Color240 204 | r <= 255 && g <= 215 && b <= 95 = Color240 205 | r <= 255 && g <= 215 && b <= 135 = Color240 206 | r <= 255 && g <= 215 && b <= 175 = Color240 207 | r <= 255 && g <= 215 && b <= 215 = Color240 208 | r <= 255 && g <= 215 && b <= 255 = Color240 209 | r <= 255 && g <= 255 && b <= 0 = Color240 210 | r <= 255 && g <= 255 && b <= 95 = Color240 211 | r <= 255 && g <= 255 && b <= 135 = Color240 212 | r <= 255 && g <= 255 && b <= 175 = Color240 213 | r <= 255 && g <= 255 && b <= 215 = Color240 214 | r <= 255 && g <= 255 && b <= 255 = Color240 215 | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette." (fromIntegral r :: Int) (fromIntegral g :: Int) (fromIntegral b :: Int)) vty-5.4.0/src/Graphics/Vty/Attributes/Color.hs0000644000000000000000000000356112563510500017403 0ustar0000000000000000module Graphics.Vty.Attributes.Color where import Data.Word -- | 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 for the first -- 224 colors. The remaining 16 colors is a greyscale palette. -- -- 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, Read ) vty-5.4.0/src/Graphics/Vty/Inline/0000755000000000000000000000000012563510500015054 5ustar0000000000000000vty-5.4.0/src/Graphics/Vty/Inline/Unsafe.hs0000644000000000000000000000352112563510500016632 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif module Graphics.Vty.Inline.Unsafe where import Graphics.Vty import Data.Default import Data.Monoid import Data.IORef import GHC.IO.Handle (hDuplicate) import System.IO (stdin, stdout, hSetBuffering, BufferMode(NoBuffering)) import System.IO.Unsafe import System.Posix.IO (handleToFd) #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif globalVty :: IORef (Maybe Vty) {-# NOINLINE globalVty #-} globalVty = unsafePerformIO $ newIORef Nothing globalOutput :: IORef (Maybe Output) {-# NOINLINE globalOutput #-} globalOutput = unsafePerformIO $ newIORef Nothing mkDupeConfig :: IO Config mkDupeConfig = do hSetBuffering stdout NoBuffering hSetBuffering stdin NoBuffering stdinDupe <- hDuplicate stdin >>= handleToFd stdoutDupe <- hDuplicate stdout >>= handleToFd return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe } -- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance. -- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'. -- -- This instance will use duplicates of the stdin and stdout Handles. withVty :: (Vty -> IO b) -> IO b withVty f = do mvty <- readIORef globalVty vty <- case mvty of Nothing -> do vty <- mkDupeConfig >>= mkVty writeIORef globalVty (Just vty) return vty Just vty -> return vty f vty withOutput :: (Output -> IO b) -> IO b withOutput f = do mout <- readIORef globalOutput out <- case mout of Nothing -> do config <- mappend <$> userConfig <*> mkDupeConfig out <- outputForConfig config writeIORef globalOutput (Just out) return out Just out -> return out f out vty-5.4.0/src/Graphics/Text/0000755000000000000000000000000012563510500014000 5ustar0000000000000000vty-5.4.0/src/Graphics/Text/Width.hs0000644000000000000000000000231712563510500015416 0ustar0000000000000000-- Copyright 2009 Corey O'Connor {-# OPTIONS_GHC -D_XOPEN_SOURCE #-} {-# LANGUAGE ForeignFunctionInterface #-} module Graphics.Text.Width ( wcwidth , wcswidth , safeWcwidth , safeWcswidth ) where foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int wcswidth :: String -> Int wcswidth = sum . map wcwidth -- 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 0 width safeWcwidth :: Char -> Int safeWcwidth c = case wcwidth c of i | i < 0 -> 0 | otherwise -> i -- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width safeWcswidth :: String -> Int safeWcswidth str = case wcswidth str of i | i < 0 -> 0 | otherwise -> i vty-5.4.0/src/Data/0000755000000000000000000000000012563510500012165 5ustar0000000000000000vty-5.4.0/src/Data/Terminfo/0000755000000000000000000000000012563510500013750 5ustar0000000000000000vty-5.4.0/src/Data/Terminfo/Parse.hs0000644000000000000000000002334112563510500015361 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -funbox-strict-fields -O #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif module Data.Terminfo.Parse ( module Data.Terminfo.Parse , Text.Parsec.ParseError ) where import Control.Monad ( liftM ) import Control.DeepSeq import Data.Word import qualified Data.Vector.Unboxed as Vector import Numeric (showHex) import Text.Parsec #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid #endif data CapExpression = CapExpression { capOps :: !CapOps , capBytes :: !(Vector.Vector Word8) , sourceString :: !String , paramCount :: !Int , paramOps :: !ParamOps } deriving (Eq) instance Show CapExpression where show c = "CapExpression { " ++ show (capOps c) ++ " }" ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]" ++ " <= " ++ show (sourceString c) where hexDump :: [Word8] -> String hexDump = foldr (\b s -> showHex b s) "" instance NFData CapExpression where rnf (CapExpression ops !_bytes !str !c !pOps) = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps type CapParam = Word type CapOps = [CapOp] data CapOp = Bytes !Int !Int -- offset count | 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 { conditionalExpr :: !CapOps , conditionalParts :: ![(CapOps, CapOps)] } | BitwiseOr | BitwiseXOr | BitwiseAnd | ArithPlus | ArithMinus | CompareEq | CompareLt | CompareGt deriving (Show, Eq) instance NFData CapOp where rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount rnf (PushParam pn) = rnf pn rnf (PushValue v) = rnf v rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts 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, Eq) instance NFData ParamOp where rnf IncFirstTwo = () parseCapExpression :: String -> Either ParseError CapExpression parseCapExpression capString = let v = runParser capExpressionParser initialBuildState "terminfo cap" capString in case v of Left e -> Left e Right buildResults -> Right $ constructCapExpression capString buildResults constructCapExpression :: [Char] -> BuildResults -> CapExpression constructCapExpression capString buildResults = let expr = CapExpression { capOps = outCapOps buildResults -- 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. , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString , sourceString = capString , paramCount = outParamCount buildResults , paramOps = outParamOps buildResults } in rnf expr `seq` expr type CapParser a = Parsec String BuildState a capExpressionParser :: CapParser BuildResults capExpressionParser = do rs <- many $ paramEscapeParser <|> bytesOpParser return $ mconcat rs paramEscapeParser :: CapParser BuildResults paramEscapeParser = do _ <- char '%' incOffset 1 literalPercentParser <|> paramOpParser literalPercentParser :: CapParser BuildResults literalPercentParser = do _ <- char '%' startOffset <- getState >>= return . nextOffset incOffset 1 return $ BuildResults 0 [Bytes startOffset 1] [] paramOpParser :: CapParser BuildResults paramOpParser = incrementOpParser <|> pushOpParser <|> decOutParser <|> charOutParser <|> conditionalOpParser <|> bitwiseOpParser <|> arithOpParser <|> literalIntOpParser <|> compareOpParser <|> charConstParser incrementOpParser :: CapParser BuildResults incrementOpParser = do _ <- char 'i' incOffset 1 return $ BuildResults 0 [] [ IncFirstTwo ] pushOpParser :: CapParser BuildResults pushOpParser = do _ <- char 'p' paramN <- digit >>= return . (\d -> read [d]) incOffset 2 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] [] decOutParser :: CapParser BuildResults decOutParser = do _ <- char 'd' incOffset 1 return $ BuildResults 0 [ DecOut ] [] charOutParser :: CapParser BuildResults charOutParser = do _ <- char 'c' incOffset 1 return $ BuildResults 0 [ CharOut ] [] conditionalOpParser :: CapParser BuildResults conditionalOpParser = do _ <- char '?' incOffset 1 condPart <- manyExpr conditionalTrueParser parts <- manyP ( do truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser , conditionalFalseParser ] falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser , conditionalTrueParser ] return ( truePart, falsePart ) ) conditionalEndParser let trueParts = map fst parts falseParts = map snd parts BuildResults n cond condParamOps = condPart let n' = maximum $ n : map outParamCount trueParts n'' = maximum $ n' : map outParamCount falseParts let trueOps = map outCapOps trueParts falseOps = map outCapOps falseParts condParts = zip trueOps falseOps let trueParamOps = mconcat $ map outParamOps trueParts falseParamOps = mconcat $ map outParamOps falseParts pOps = mconcat [condParamOps, trueParamOps, falseParamOps] return $ BuildResults n'' [ Conditional cond condParts ] pOps where manyP !p !end = choice [ try end >> return [] , do !v <- p !vs <- manyP p end return $! v : vs ] manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end conditionalTrueParser :: CapParser () conditionalTrueParser = do _ <- string "%t" incOffset 2 conditionalFalseParser :: CapParser () conditionalFalseParser = do _ <- string "%e" incOffset 2 conditionalEndParser :: CapParser () conditionalEndParser = do _ <- string "%;" incOffset 2 bitwiseOpParser :: CapParser BuildResults bitwiseOpParser = bitwiseOrParser <|> bitwiseAndParser <|> bitwiseXorParser bitwiseOrParser :: CapParser BuildResults bitwiseOrParser = do _ <- char '|' incOffset 1 return $ BuildResults 0 [ BitwiseOr ] [ ] bitwiseAndParser :: CapParser BuildResults bitwiseAndParser = do _ <- char '&' incOffset 1 return $ BuildResults 0 [ BitwiseAnd ] [ ] bitwiseXorParser :: CapParser BuildResults bitwiseXorParser = do _ <- char '^' incOffset 1 return $ BuildResults 0 [ BitwiseXOr ] [ ] arithOpParser :: CapParser BuildResults arithOpParser = plusOp <|> minusOp where plusOp = do _ <- char '+' incOffset 1 return $ BuildResults 0 [ ArithPlus ] [ ] minusOp = do _ <- char '-' incOffset 1 return $ BuildResults 0 [ ArithMinus ] [ ] literalIntOpParser :: CapParser BuildResults literalIntOpParser = do _ <- char '{' incOffset 1 nStr <- many1 digit incOffset $ toEnum $ length nStr let n :: Word = read nStr _ <- char '}' incOffset 1 return $ BuildResults 0 [ PushValue n ] [ ] compareOpParser :: CapParser BuildResults compareOpParser = compareEqOp <|> compareLtOp <|> compareGtOp where compareEqOp = do _ <- char '=' incOffset 1 return $ BuildResults 0 [ CompareEq ] [ ] compareLtOp = do _ <- char '<' incOffset 1 return $ BuildResults 0 [ CompareLt ] [ ] compareGtOp = do _ <- char '>' incOffset 1 return $ BuildResults 0 [ CompareGt ] [ ] bytesOpParser :: CapParser BuildResults bytesOpParser = do bytes <- many1 $ satisfy (/= '%') startOffset <- getState >>= return . nextOffset let !c = length bytes !s <- getState let s' = s { nextOffset = startOffset + c } setState s' return $ BuildResults 0 [Bytes startOffset c] [] charConstParser :: CapParser BuildResults charConstParser = do _ <- char '\'' charValue <- liftM (toEnum . fromEnum) anyChar _ <- char '\'' incOffset 3 return $ BuildResults 0 [ PushValue charValue ] [ ] data BuildState = BuildState { nextOffset :: Int } incOffset :: Int -> CapParser () incOffset n = do s <- getState let s' = s { nextOffset = nextOffset s + n } setState s' initialBuildState :: BuildState initialBuildState = BuildState 0 data BuildResults = BuildResults { outParamCount :: !Int , outCapOps :: !CapOps , outParamOps :: !ParamOps } instance Monoid BuildResults where mempty = BuildResults 0 [] [] v0 `mappend` v1 = BuildResults { outParamCount = (outParamCount v0) `max` (outParamCount v1) , outCapOps = (outCapOps v0) `mappend` (outCapOps v1) , outParamOps = (outParamOps v0) `mappend` (outParamOps v1) } vty-5.4.0/src/Data/Terminfo/Eval.hs0000644000000000000000000000713312563510500015177 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} #ifndef MIN_VERSION_base #defined MIN_VERSION_base(x,y,z) 1 #endif {- Evaluates the paramaterized terminfo string capability with the given parameters. - -} module Data.Terminfo.Eval (writeCapExpr) where import Blaze.ByteString.Builder.Word import Blaze.ByteString.Builder import Data.Terminfo.Parse import Control.Monad.Identity import Control.Monad.State.Strict import Control.Monad.Writer import Data.Bits ((.|.), (.&.), xor) import Data.List import qualified Data.Vector.Unboxed as Vector #if !(MIN_VERSION_base(4,8,0)) import Data.Word #endif -- | capability evaluator state data EvalState = EvalState { evalStack :: ![CapParam] , evalExpression :: !CapExpression , evalParams :: ![CapParam] } type Eval a = StateT EvalState (Writer Write) a pop :: Eval CapParam pop = do s <- get let v : stack' = evalStack s s' = s { evalStack = stack' } put s' return v readParam :: Word -> Eval CapParam readParam pn = do !params <- get >>= return . evalParams return $! genericIndex params pn push :: CapParam -> Eval () push !v = do s <- get let s' = s { evalStack = v : evalStack s } put s' applyParamOps :: CapExpression -> [CapParam] -> [CapParam] applyParamOps cap params = foldl applyParamOp params (paramOps cap) applyParamOp :: [CapParam] -> ParamOp -> [CapParam] applyParamOp params IncFirstTwo = map (+ 1) params writeCapExpr :: CapExpression -> [CapParam] -> Write writeCapExpr cap params = let params' = applyParamOps cap params s0 = EvalState [] cap params' in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0) writeCapOps :: CapOps -> Eval () writeCapOps ops = mapM_ writeCapOp ops writeCapOp :: CapOp -> Eval () writeCapOp (Bytes !offset !count) = do !cap <- get >>= return . evalExpression let bytes = Vector.take count $ Vector.drop offset (capBytes cap) Vector.forM_ bytes $ tell.writeWord8 writeCapOp DecOut = do p <- pop forM_ (show p) $ tell.writeWord8.toEnum.fromEnum writeCapOp CharOut = do pop >>= tell.writeWord8.toEnum.fromEnum writeCapOp (PushParam pn) = do readParam pn >>= push writeCapOp (PushValue v) = do push v writeCapOp (Conditional expr parts) = do writeCapOps expr writeContitionalParts parts where writeContitionalParts [] = return () writeContitionalParts ((trueOps, falseOps) : falseParts) = 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 if v /= 0 then writeCapOps trueOps else do writeCapOps falseOps writeContitionalParts falseParts writeCapOp BitwiseOr = do v0 <- pop v1 <- pop push $ v0 .|. v1 writeCapOp BitwiseAnd = do v0 <- pop v1 <- pop push $ v0 .&. v1 writeCapOp BitwiseXOr = do v1 <- pop v0 <- pop push $ v0 `xor` v1 writeCapOp ArithPlus = do v1 <- pop v0 <- pop push $ v0 + v1 writeCapOp ArithMinus = do v1 <- pop v0 <- pop push $ v0 - v1 writeCapOp CompareEq = do v1 <- pop v0 <- pop push $ if v0 == v1 then 1 else 0 writeCapOp CompareLt = do v1 <- pop v0 <- pop push $ if v0 < v1 then 1 else 0 writeCapOp CompareGt = do v1 <- pop v0 <- pop push $ if v0 > v1 then 1 else 0 vty-5.4.0/test/0000755000000000000000000000000012563510500011504 5ustar0000000000000000vty-5.4.0/test/VerifyCropSpanGeneration.hs0000644000000000000000000000755012563510500016775 0ustar0000000000000000{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} module VerifyCropSpanGeneration where import Verify.Graphics.Vty.Prelude import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.Picture import Verify.Graphics.Vty.Span import Graphics.Vty.Debug import Graphics.Vty.PictureToSpans import Verify import qualified Data.Vector as Vector cropOpDisplayOps :: (Int -> Image -> Image) -> Int -> Image -> (DisplayOps, Image) cropOpDisplayOps cropOp v i = let iOut = cropOp v i p = picForImage iOut w = MockWindow (imageWidth iOut) (imageHeight iOut) in (displayOpsForPic p (regionForWindow w), iOut) widthCropOutputColumns :: (Int -> Image -> Image) -> SingleAttrSingleSpanStack -> NonNegative Int -> Property widthCropOutputColumns cropOp s (NonNegative w) = stackWidth s > w ==> let (ops, iOut) = cropOpDisplayOps cropOp w (stackImage s) in verifyAllSpansHaveWidth iOut ops w heightCropOutputColumns :: (Int -> Image -> Image) -> SingleAttrSingleSpanStack -> NonNegative Int -> Property heightCropOutputColumns cropOp s (NonNegative h) = stackHeight s > h ==> let (ops, _) = cropOpDisplayOps cropOp h (stackImage s) in displayOpsRows ops == h cropRightOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property cropRightOutputColumns = widthCropOutputColumns cropRight cropLeftOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property cropLeftOutputColumns = widthCropOutputColumns cropLeft cropTopOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property cropTopOutputRows = heightCropOutputColumns cropTop cropBottomOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property cropBottomOutputRows = heightCropOutputColumns cropBottom -- TODO: known benign failure. cropRightAndLeftRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property cropRightAndLeftRejoinedEquivalence stack = imageWidth (stackImage stack) `mod` 2 == 0 ==> let i = stackImage stack -- the right part is made by cropping the image from the left. iR = cropLeft (imageWidth i `div` 2) i -- the left part is made by cropping the image from the right iL = cropRight (imageWidth i `div` 2) i iAlt = iL <|> iR iOps = displayOpsForImage i iAltOps = displayOpsForImage iAlt in verifyOpsEquality iOps iAltOps cropTopAndBottomRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod` 2 == 0 ==> let i = stackImage stack -- the top part is made by cropping the image from the bottom. iT = cropBottom (imageHeight i `div` 2) i -- the bottom part is made by cropping the image from the top. iB = cropTop (imageHeight i `div` 2) i iAlt = iT <-> iB in displayOpsForImage i == displayOpsForImage iAlt tests :: IO [Test] tests = return [ verify "cropping from the bottom produces display operations covering the expected rows" cropBottomOutputRows , verify "cropping from the top produces display operations covering the expected rows" cropTopOutputRows , verify "cropping from the left produces display operations covering the expected columns" cropLeftOutputColumns , verify "cropping from the right produces display operations covering the expected columns" cropRightOutputColumns -- TODO: known benign failure. -- , verify "the output of a stack is the same as that stack cropped left & right and joined together" -- cropRightAndLeftRejoinedEquivalence , verify "the output of a stack is the same as that stack cropped top & bottom and joined together" cropTopAndBottomRejoinedEquivalence ] vty-5.4.0/test/VerifyImageTrans.hs0000644000000000000000000000267012563510500015264 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} module VerifyImageTrans where import Verify.Graphics.Vty.Image import Graphics.Vty.Image.Internal import Verify import Data.Word isHorizTextOfColumns :: Image -> Int -> Bool isHorizTextOfColumns (HorizText { outputWidth = inW }) expectedW = inW == expectedW isHorizTextOfColumns (BGFill { outputWidth = inW }) expectedW = inW == expectedW isHorizTextOfColumns _image _expectedW = False verifyHorizContatWoAttrChangeSimplifies :: SingleRowSingleAttrImage -> Bool verifyHorizContatWoAttrChangeSimplifies (SingleRowSingleAttrImage _attr charCount image) = isHorizTextOfColumns image charCount verifyHorizContatWAttrChangeSimplifies :: SingleRowTwoAttrImage -> Bool verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0) (SingleRowSingleAttrImage attr1 charCount1 _image1) i ) | charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1) | otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1) tests :: IO [Test] tests = return [ verify "verifyHorizContatWoAttrChangeSimplifies" verifyHorizContatWoAttrChangeSimplifies , verify "verifyHorizContatWAttrChangeSimplifies" verifyHorizContatWAttrChangeSimplifies ] vty-5.4.0/test/VerifyEmptyImageProps.hs0000644000000000000000000000040612563510500016312 0ustar0000000000000000module VerifyEmptyImageProps where import Verify -- should be exported by Graphics.Vty.Picture import Graphics.Vty.Picture ( Image, emptyImage ) tests :: IO [Test] tests = do -- should provide an image type. let _ :: Image = emptyImage return [] vty-5.4.0/test/VerifyDisplayAttributes.hs0000644000000000000000000000025612563510500016704 0ustar0000000000000000module VerifyDisplayAttributes where import Verify.Graphics.Vty.DisplayAttributes import Verify.Graphics.Vty.Attributes import Verify tests :: IO [Test] tests = return [] vty-5.4.0/test/VerifyUsingMockInput.hs0000644000000000000000000002120412563510500016143 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {- Generate some input bytes and delays between blocks of input bytes. Verify the events produced - are as expected. -} module Main where import Verify.Graphics.Vty.Output import Graphics.Vty hiding (resize) import Graphics.Vty.Input.Events import Graphics.Vty.Input.Loop import Graphics.Vty.Input.Terminfo import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Lens ((^.)) import Control.Monad import Data.Default import Data.IORef import Data.List (intersperse, reverse, nubBy) import System.Console.Terminfo import System.Posix.IO import System.Posix.Terminal (openPseudoTerminal) import System.Posix.Types import System.Timeout import Test.Framework.Providers.SmallCheck import Test.Framework import Test.SmallCheck import Test.SmallCheck.Series import Text.Printf -- processing a block of 16 chars is the largest I can do without taking too long to run the test. maxBlockSize :: Int maxBlockSize = 16 maxTableSize :: Int maxTableSize = 28 forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m forEachOf l = over (generate (\n -> take n l)) data InputEvent = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time. | Delay Int -- | microsecond delay deriving Show type InputSpec = [InputEvent] type ExpectedSpec = [Event] synthesizeInput :: InputSpec -> Fd -> IO () synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD") where f (Bytes str) = void $ fdWrite outHandle str f (Delay t) = threadDelay t minDetectableDelay :: Int minDetectableDelay = 4000 minTimout :: Int minTimout = 4000000 testKeyDelay :: Int testKeyDelay = minDetectableDelay * 4 testEscSampleDelay :: Int testEscSampleDelay = minDetectableDelay * 2 genEventsUsingIoActions :: Int -> IO () -> IO () -> IO () genEventsUsingIoActions maxDuration inputAction outputAction = do let maxDuration' = max minTimout maxDuration readComplete <- newEmptyMVar writeComplete <- newEmptyMVar _ <- forkOS $ inputAction `finally` putMVar writeComplete () _ <- forkOS $ outputAction `finally` putMVar readComplete () Just () <- timeout maxDuration' $ takeMVar writeComplete Just () <- timeout maxDuration' $ takeMVar readComplete return () compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents where compareEvents' [] [] = return True compareEvents' [] outEvents' = do printf "extra events %s\n" (show outEvents') :: IO () return False compareEvents' expectedEvents' [] = do printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO () printf "expected events %s\n" (show expectedEvents) :: IO () printf "received events %s\n" (show outEvents) :: IO () return False compareEvents' (e : expectedEvents') (o : outEvents') | e == o = compareEvents' expectedEvents' outEvents' | otherwise = do printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO () printf "expected events %s\n" (show expectedEvents) :: IO () printf "received events %s\n" (show outEvents) :: IO () return False assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool assertEventsFromSynInput table inputSpec expectedEvents = do let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay eventCount = length expectedEvents (writeFd, readFd) <- openPseudoTerminal (setTermAttr,_) <- attributeControl readFd setTermAttr let testConfig = def { inputFd = Just readFd , termName = Just "dummy" , vmin = Just 1 , vtime = Just 100 } input <- initInput testConfig table eventsRef <- newIORef [] let writeWaitClose = do synthesizeInput inputSpec writeFd threadDelay minDetectableDelay shutdownInput input threadDelay minDetectableDelay closeFd writeFd closeFd readFd -- drain output pipe let readEvents = readLoop eventCount readLoop 0 = return () readLoop n = do e <- atomically $ readTChan $ input^.eventChannel modifyIORef eventsRef ((:) e) readLoop (n - 1) genEventsUsingIoActions maxDuration writeWaitClose readEvents outEvents <- reverse <$> readIORef eventsRef compareEvents inputSpec expectedEvents outEvents newtype InputBlocksUsingTable event = InputBlocksUsingTable ([(String,event)] -> [(String, event)]) instance Show (InputBlocksUsingTable event) where show (InputBlocksUsingTable _g) = "InputBlocksUsingTable" instance Monad m => Serial m (InputBlocksUsingTable event) where series = do n :: Int <- localDepth (const maxTableSize) series return $ InputBlocksUsingTable $ \raw_table -> let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table in concat (take n (selections table)) where selections [] = [] selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z) verifyVisibleSynInputToEvent :: Property IO verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do let table = visibleChars inputSeq = gen table events = map snd inputSeq keydowns = map (Bytes . fst) inputSeq input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] assertEventsFromSynInput universalTable input events verifyCapsSynInputToEvent :: Property IO verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> forEachOf terminalsOfInterest $ \termName -> monadic $ do term <- setupTerm termName let table = capsClassifyMap term keysFromCapsTable inputSeq = gen table events = map snd inputSeq keydowns = map (Bytes . fst) inputSeq input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] assertEventsFromSynInput table input events verifySpecialSynInputToEvent :: Property IO verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do let table = specialSupportKeys inputSeq = gen table events = map snd inputSeq keydowns = map (Bytes . fst) inputSeq input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] assertEventsFromSynInput universalTable input events verifyFullSynInputToEvent :: Property IO verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> forEachOf terminalsOfInterest $ \termName -> monadic $ do term <- setupTerm termName let table = classifyMapForTerm termName term inputSeq = gen table events = map snd inputSeq keydowns = map (Bytes . fst) inputSeq input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] assertEventsFromSynInput table input events verifyFullSynInputToEvent_2x :: Property IO verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) -> forEachOf terminalsOfInterest $ \termName -> monadic $ do term <- setupTerm termName let table = classifyMapForTerm termName term inputSeq = gen table events = concatMap ((\s -> [s,s]) . snd) inputSeq keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay] assertEventsFromSynInput table input events main :: IO () main = defaultMain [ testProperty "synthesized typing of single visible chars translates to expected events" verifyVisibleSynInputToEvent , testProperty "synthesized typing of keys from capabilities tables translates to expected events" verifyCapsSynInputToEvent , testProperty "synthesized typing of hard coded special keys translates to expected events" verifySpecialSynInputToEvent , testProperty "synthesized typing of any key in the table translates to its paired event" verifyFullSynInputToEvent , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event" verifyFullSynInputToEvent_2x ] vty-5.4.0/test/VerifyConfig.hs0000644000000000000000000000240512563510500014433 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Main where import Graphics.Vty.Config import Graphics.Vty.Input.Events import Data.Default import Data.String.QQ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test) exampleConfig :: String exampleConfig = [s| -- comments should be ignored. map _ "\ESC[B" KUp [] askfjla dfasjdflk jasdlkfj asdfj -- lines failing parse should be ignored map _ "\ESC[1;3B" KDown [MAlt] map "xterm" "\ESC[1;3B" KDown [MAlt] map "xterm-256-color" "\ESC[1;3B" KDown [MAlt] debugLog "/tmp/vty-debug.txt" |] exampleConfigConfig :: Config exampleConfigConfig = def { debugLog = Just "/tmp/vty-debug.txt" , inputMap = [ (Nothing, "\ESC[B", EvKey KUp []) , (Nothing, "\ESC[1;3B", EvKey KDown [MAlt]) , (Just "xterm", "\ESC[1;3B", EvKey KDown [MAlt]) , (Just "xterm-256-color", "\ESC[1;3B", EvKey KDown [MAlt]) ] } exampleConfigParses :: IO () exampleConfigParses = assertEqual "example config parses as expected" exampleConfigConfig (runParseConfig "exampleConfig" exampleConfig) main :: IO () main = defaultMain [ testCase "example config parses" $ exampleConfigParses ] vty-5.4.0/test/VerifyInline.hs0000644000000000000000000000152512563510500014446 0ustar0000000000000000module VerifyInline where import Graphics.Vty.Inline import Graphics.Vty.Output import Graphics.Vty.Output.TerminfoBased as TerminfoBased import Verify.Graphics.Vty.Output import Verify import Distribution.TestSuite import System.IO tests :: IO [Test] tests = concat <$> forM terminalsOfInterest (\termName -> return $ [ Test $ TestInstance { name = "verify vty inline" , run = do {- disabled because I cannot get useful output out of cabal why this fails. nullOut <- openFile "/dev/null" WriteMode t <- TerminfoBased.reserveTerminal termName nullOut putAttrChange t $ default_all releaseTerminal t -} return $ Finished Pass , tags = [] , options = [] , setOption = \_ _ -> Left "no options supported" } ]) vty-5.4.0/test/VerifyEvalTerminfoCaps.hs0000644000000000000000000000615612563510500016437 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} module VerifyEvalTerminfoCaps where import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound) import Data.Terminfo.Eval import Data.Terminfo.Parse import Control.DeepSeq import qualified System.Console.Terminfo as Terminfo import Verify import Verify.Graphics.Vty.Output import Control.Applicative ( (<$>) ) import Control.Exception ( try, SomeException(..) ) import Control.Monad ( mapM_, forM, forM_ ) import Data.Maybe ( fromJust ) import Data.Word import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, minusPtr) import Numeric -- If a terminal defines one of the caps then it's expected to be parsable. capsOfInterest = [ "cup" , "sc" , "rc" , "setf" , "setb" , "setaf" , "setab" , "op" , "cnorm" , "civis" , "smcup" , "rmcup" , "clear" , "hpa" , "vpa" , "sgr" , "sgr0" ] fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) tests :: IO [Test] tests = do evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-) fmap concat $ forM terminalsOfInterest $ \termName -> do putStrLn $ "adding tests for terminal: " ++ termName mti <- try $ Terminfo.setupTerm termName case mti of Left (_e :: SomeException) -> return [] Right ti -> do fmap concat $ forM capsOfInterest $ \capName -> do case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Just capDef -> do putStrLn $ "\tadding test for cap: " ++ capName let testName = termName ++ "(" ++ capName ++ ")" case parseCapExpression capDef of Left error -> return [verify testName (failed {reason = "parse error " ++ show error})] Right !cap_expr -> return [verify testName (verifyEvalCap evalBuffer cap_expr)] Nothing -> do return [] {-# NOINLINE verifyEvalCap #-} verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property verifyEvalCap evalBuffer expr !junkInt = do forAll (vector 9) $ \inputValues -> let write = writeCapExpr expr inputValues !byteCount = getBound write in liftIOResult $ do let startPtr :: Ptr Word8 = evalBuffer forM_ [0..100] $ \i -> runWrite write startPtr endPtr <- runWrite write startPtr case endPtr `minusPtr` startPtr of count | count < 0 -> return $ failed { reason = "End pointer before start pointer." } | toEnum count > byteCount -> return $ failed { reason = "End pointer past end of buffer by " ++ show (toEnum count - byteCount) } | otherwise -> return succeeded vty-5.4.0/test/VerifyParseTerminfoCaps.hs0000644000000000000000000000702712563510500016620 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} module VerifyParseTerminfoCaps where import Prelude hiding ( catch ) import qualified System.Console.Terminfo as Terminfo import Verify.Data.Terminfo.Parse import Verify.Graphics.Vty.Output import Verify import Data.Maybe ( catMaybes, fromJust ) import Data.Word import Numeric -- If a terminal defines one of the caps then it's expected to be parsable. -- TODO: reduce duplication with terminfo terminal implementation. capsOfInterest = [ "cup" , "sc" , "rc" , "setf" , "setb" , "setaf" , "setab" , "op" , "cnorm" , "civis" , "smcup" , "rmcup" , "clear" , "hpa" , "vpa" , "sgr" , "sgr0" ] fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name) tests :: IO [Test] tests = do parseTests <- concat <$> forM terminalsOfInterest (\termName -> liftIO (try $ Terminfo.setupTerm termName) >>= either (\(_e :: SomeException) -> return []) (\ti -> concat <$> forM capsOfInterest (\capName -> do let caseName = "\tparsing cap: " ++ capName liftIO $ putStrLn caseName return $ case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Just capDef -> [verify (caseName ++ " -> " ++ show capDef) (verifyParseCap capDef $ const succeeded)] Nothing -> [] ) ) ) return $ [ verify "parse_nonParamaterizedCaps" nonParamaterizedCaps , verify "parse cap string with literal %" literalPercentCaps , verify "parse cap string with %i op" incFirstTwoCaps , verify "parse cap string with %pN op" pushParamCaps ] ++ parseTests verifyParseCap capString onParse = case parseCapExpression capString of Left error -> failed { reason = "parse error " ++ show error } Right e -> onParse e nonParamaterizedCaps (NonParamCapString cap) = do verifyParseCap cap $ \e -> let expectedBytes = map (toEnum . fromEnum) cap outBytes = bytesForRange e 0 (length cap) in verifyBytesEqual outBytes expectedBytes literalPercentCaps (LiteralPercentCap capString expectedBytes) = do verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do verifyParseCap capString $ \e -> let outBytes = collectBytes e outParamCount = paramCount e in if outParamCount == expectedParamCount then verifyBytesEqual outBytes expectedBytes else failed { reason = "out param count /= expected param count" } decPrintParamCaps (DecPrintCap capString expectedParamCount expectedBytes) = do verifyParseCap capString $ \e -> let outBytes = collectBytes e outParamCount = paramCount e in if outParamCount == expectedParamCount then verifyBytesEqual outBytes expectedBytes else failed { reason = "out param count /= expected param count" } printCap ti capName = do putStrLn $ capName ++ ": " ++ show (fromCapname ti capName) printExpression ti capName = do let parseResult = parseCapExpression $ fromCapname ti capName putStrLn $ capName ++ ": " ++ show parseResult vty-5.4.0/test/VerifyImageOps.hs0000644000000000000000000001677212563510500014746 0ustar0000000000000000module VerifyImageOps where import Graphics.Vty.Attributes import Graphics.Vty.Image.Internal import Verify.Graphics.Vty.Image import Verify import Control.DeepSeq twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) = imageWidth (char defAttr c1 <|> char defAttr c2) == 2 manySwHorizConcat :: [SingleColumnChar] -> Bool manySwHorizConcat cs = let chars = [ char | SingleColumnChar char <- cs ] l = fromIntegral $ length cs in imageWidth ( horizCat $ map (char defAttr) chars ) == l twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) = imageHeight (char defAttr c1 <-> char defAttr c2) == 2 horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) = (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 == char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2) twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = imageWidth (char defAttr c1 <|> char defAttr c2) == 4 manyDwHorizConcat :: [DoubleColumnChar] -> Bool manyDwHorizConcat cs = let chars = [ char | DoubleColumnChar char <- cs ] l = fromIntegral $ length cs in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2 twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) = imageHeight (char defAttr c1 <-> char defAttr c2) == 2 horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) = (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2 == char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2) vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool vertContatSingleRow (NonEmpty stack) = let expectedHeight :: Int = length stack stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ] in imageHeight stackImage == expectedHeight disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) = let expectedHeight :: Int = max (length stack0) (length stack1) stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] in imageHeight (stackImage0 <|> stackImage1) == expectedHeight disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) = let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] image = stackImage0 <|> stackImage1 expectedHeight = imageHeight image in case image of HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) ) && ( expectedHeight == (imageHeight $ partRight image) ) _ -> True disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) = let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images) stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] stack0Image = vertCat stack0Images stack1Image = vertCat stack1Images image = stack0Image <-> stack1Image in imageWidth image == expectedWidth disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage -> NonEmptyList SingleRowSingleAttrImage -> Bool disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) = let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images) stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ] stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ] stack0Image = vertCat stack0Images stack1Image = vertCat stack1Images image = stack0Image <-> stack1Image in case image of VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) ) && ( expectedWidth == (imageWidth $ partBottom image) ) _ -> True translationIsLinearOnOutSize :: Translation -> Bool translationIsLinearOnOutSize (Translation i (x,y) i') = imageWidth i' == imageWidth i + x && imageHeight i' == imageHeight i + y paddingIsLinearOnOutSize :: Image -> Gen Bool paddingIsLinearOnOutSize i = do l <- offset t <- offset r <- offset b <- offset let i' = pad l t r b i return $ imageWidth i' == imageWidth i + l + r && imageHeight i' == imageHeight i + t + b where offset = choose (1,1024) cropLeftLimitsWidth :: Image -> Int -> Property cropLeftLimitsWidth i v = v >= 0 ==> v >= imageWidth (cropLeft v i) cropRightLimitsWidth :: Image -> Int -> Property cropRightLimitsWidth i v = v >= 0 ==> v >= imageWidth (cropRight v i) cropTopLimitsHeight :: Image -> Int -> Property cropTopLimitsHeight i v = v >= 0 ==> v >= imageHeight (cropTop v i) cropBottomLimitsHeight :: Image -> Int -> Property cropBottomLimitsHeight i v = v >= 0 ==> v >= imageHeight (cropBottom v i) -- rediculous tests just to satisfy my desire for nice code coverage :-P canShowImage :: Image -> Bool canShowImage i = length (show i) > 0 canRnfImage :: Image -> Bool canRnfImage i = rnf i == () canPpImage :: Image -> Bool canPpImage i = length (ppImageStructure i) > 0 tests :: IO [Test] tests = return [ verify "twoSwHorizConcat" twoSwHorizConcat , verify "manySwHorizConcat" manySwHorizConcat , verify "twoSwVertConcat" twoSwVertConcat , verify "horizConcatSwAssoc" horizConcatSwAssoc , verify "manyDwHorizConcat" manyDwHorizConcat , verify "twoDwHorizConcat" twoDwHorizConcat , verify "twoDwVertConcat" twoDwVertConcat , verify "horizConcatDwAssoc" horizConcatDwAssoc , verify "single row vert concats to correct height" vertContatSingleRow , verify "disjointHeightHorizJoin" disjointHeightHorizJoin , verify "disjointHeightHorizJoin BG fill" disjointHeightHorizJoinBgFill , verify "disjointWidthVertJoin" disjointWidthVertJoin , verify "disjointWidthVertJoin BG fill" disjointWidthVertJoinBgFill , verify "translation effects output dimensions linearly" translationIsLinearOnOutSize , verify "padding effects output dimensions linearly" paddingIsLinearOnOutSize , verify "crop left limits width" cropLeftLimitsWidth , verify "crop right limits width" cropRightLimitsWidth , verify "crop top limits height" cropTopLimitsHeight , verify "crop bottom limits height" cropBottomLimitsHeight , verify "can show image" canShowImage , verify "can rnf image" canRnfImage , verify "can pp image" canPpImage ] vty-5.4.0/test/Verify.hs0000644000000000000000000000606212563510500013310 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} module Verify ( module Verify , module Control.Applicative , module Control.DeepSeq , module Control.Exception , module Control.Monad , module Test.QuickCheck , module Test.QuickCheck.Modifiers , module Text.Printf , succeeded , failed , monadicIO , liftIO , liftBool , Test(..) , Prop.Result(..) ) where import Control.Exception ( bracket, try, SomeException(..) ) 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.Modifiers import Test.QuickCheck.Property hiding ( Result(..) ) import qualified Test.QuickCheck.Property as Prop import Test.QuickCheck.Monadic ( monadicIO ) import Text.Printf import qualified Codec.Binary.UTF8.String as UTF8 import Control.Applicative hiding ( (<|>) ) import Control.DeepSeq import Control.Monad ( forM, mapM, mapM_, forM_ ) import Control.Monad.State.Strict import Numeric ( showHex ) verify :: Testable t => String -> t -> Test verify testName p = Test $ TestInstance { name = testName , run = do qcResult <- quickCheckWithResult (stdArgs {chatty = False}) p case qcResult of QC.Success {..} -> return $ Finished TS.Pass QC.Failure {numShrinks,reason} -> return $ Finished $ TS.Fail $ "After " ++ show numShrinks ++ " shrinks determined failure to be: " ++ show reason _ -> 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 = ioProperty #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 data Bench where Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench vty-5.4.0/test/VerifyLayersSpanGeneration.hs0000644000000000000000000001277612563510500017337 0ustar0000000000000000{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} module VerifyLayersSpanGeneration where import Verify.Graphics.Vty.Prelude import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.Picture import Verify.Graphics.Vty.Span import Graphics.Vty.Debug import Graphics.Vty.PictureToSpans import Verify import qualified Data.Vector as Vector largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result largerHorizSpanOcclusion row0 row1 = let i0 = rowImage row0 i1 = rowImage row1 (iLarger, iSmaller) = if imageWidth i0 > imageWidth i1 then (i0, i1) else (i1, i0) expectedOps = displayOpsForImage iLarger p = picForLayers [iLarger, iSmaller] ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger) in verifyOpsEquality expectedOps ops -- | Two rows stacked vertical is equivalent to the first row rendered as the top layer and the -- second row rendered as a bottom layer with a background fill where the first row would be. vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result vertStackLayerEquivalence0 row0 row1 = let i0 = rowImage row0 i1 = rowImage row1 i = i0 <-> i1 p = picForImage i iLower = backgroundFill (imageWidth i0) 1 <-> i1 pLayered = picForLayers [i0, iLower] expectedOps = displayOpsForImage i opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) in verifyOpsEquality expectedOps opsLayered vertStackLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result vertStackLayerEquivalence1 row0 row1 = let i0 = rowImage row0 i1 = rowImage row1 i = i0 <-> i1 p = picForImage i iLower = i0 <-> backgroundFill (imageWidth i1) 1 iUpper = backgroundFill (imageWidth i0) 1 <-> i1 pLayered = picForLayers [iUpper, iLower] expectedOps = displayOpsForImage i opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) in verifyOpsEquality expectedOps opsLayered -- | Two rows horiz joined is equivalent to the first row rendered as the top layer and the -- second row rendered as a bottom layer with a background fill where the first row would be. horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result horizJoinLayerEquivalence0 row0 row1 = let i0 = rowImage row0 i1 = rowImage row1 i = i0 <|> i1 p = picForImage i iLower = backgroundFill (imageWidth i0) 1 <|> i1 pLayered = picForLayers [i0, iLower] expectedOps = displayOpsForImage i opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) in verifyOpsEquality expectedOps opsLayered horizJoinLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result horizJoinLayerEquivalence1 row0 row1 = let i0 = rowImage row0 i1 = rowImage row1 i = i0 <|> i1 p = picForImage i iLower = i0 <|> backgroundFill (imageWidth i1) 1 iUpper = backgroundFill (imageWidth i0) 1 <|> i1 pLayered = picForLayers [iUpper, iLower] expectedOps = displayOpsForImage i opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower) in verifyOpsEquality expectedOps opsLayered horizJoinAlternate0 :: Result horizJoinAlternate0 = let size = 4 str0 = replicate size 'a' str1 = replicate size 'b' i0 = string defAttr str0 i1 = string defAttr str1 i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1) layer0 = horizCat $ replicate size $ i0 <|> backgroundFill size 1 layer1 = horizCat $ replicate size $ backgroundFill size 1 <|> i1 expectedOps = displayOpsForImage i opsLayered = displayOpsForPic (picForLayers [layer0, layer1]) (imageWidth i,imageHeight i) in verifyOpsEquality expectedOps opsLayered horizJoinAlternate1 :: Result horizJoinAlternate1 = let size = 4 str0 = replicate size 'a' str1 = replicate size 'b' i0 = string defAttr str0 i1 = string defAttr str1 i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1) layers = [l | b <- take 4 [0,size*2..], let l = backgroundFill b 1 <|> i0 <|> i1] expectedOps = displayOpsForImage i opsLayered = displayOpsForPic (picForLayers layers) (imageWidth i,imageHeight i) in verifyOpsEquality expectedOps opsLayered tests :: IO [Test] tests = return [ verify "a larger horiz span occludes a smaller span on a lower layer" largerHorizSpanOcclusion , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)" vertStackLayerEquivalence0 , verify "two rows stack vertical equiv to first image layered on top of second with padding (1)" vertStackLayerEquivalence1 -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (0)" -- horizJoinLayerEquivalence0 -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (1)" -- horizJoinLayerEquivalence1 -- , verify "alternating images using joins is the same as alternating images using layers (0)" -- horizJoinAlternate0 -- , verify "alternating images using joins is the same as alternating images using layers (1)" -- horizJoinAlternate1 ] vty-5.4.0/test/VerifyAttributeOps.hs0000644000000000000000000000017512563510500015655 0ustar0000000000000000module VerifyAttributeOps where import Verify.Graphics.Vty.Attributes import Verify tests :: IO [Test] tests = return [] vty-5.4.0/test/VerifyUtf8Width.hs0000644000000000000000000000156012563510500015055 0ustar0000000000000000module VerifyUtf8Width where import Verify import Graphics.Text.Width import Graphics.Vty.Attributes import Graphics.Vty.Picture swIs1Column :: SingleColumnChar -> Bool swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1 dwIs2Column :: DoubleColumnChar -> Bool dwIs2Column (DoubleColumnChar c) = imageWidth (char defAttr c) == 2 dcStringIsEven :: NonEmptyList DoubleColumnChar -> Bool dcStringIsEven (NonEmpty dw_list) = even $ safeWcswidth [ c | DoubleColumnChar c <- dw_list ] safeWcwidthForControlChars :: Bool safeWcwidthForControlChars = 0 == safeWcwidth '\NUL' tests :: IO [Test] tests = return [ verify "swIs1Column" swIs1Column , verify "dwIs2Column" dwIs2Column , verify "a string of double characters is an even width" dcStringIsEven , verify "safeWcwidth provides a width of 0 for chars without widths" safeWcwidthForControlChars ] vty-5.4.0/test/VerifySimpleSpanGeneration.hs0000644000000000000000000002215312563510500017317 0ustar0000000000000000{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} module VerifySimpleSpanGeneration where import Verify.Graphics.Vty.Prelude import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.Picture import Verify.Graphics.Vty.Span import Graphics.Vty.Debug import Graphics.Vty.PictureToSpans import Verify import qualified Data.Vector as Vector unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) = let p = picForImage i ops = displayOpsForPic p (regionForWindow w) in displayOpsColumns ops == 0 && displayOpsRows ops == 0 unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) = let p = picForImage i ops = displayOpsForPic p (regionForWindow w) in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 ) horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = let p = picForImage i ops = displayOpsForPic p (regionForWindow w) in displayOpsColumns ops == 0 && displayOpsRows ops == 0 horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) = let p = picForImage i ops = displayOpsForPic p (regionForWindow w) in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 ) horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) = let p = picForImage i w = MockWindow c 1 ops = displayOpsForPic p (regionForWindow w) in verifyAllSpansHaveWidth i ops c horizSpanImageAndEqualWindow1 :: SingleRowSingleAttrImage -> Bool horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) = let p = picForImage i w = MockWindow c 1 ops = displayOpsForPic p (regionForWindow w) in spanOpsEffectedRows ops == 1 horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) = let p = picForImage i lesserWidth = c `div` 2 w = MockWindow lesserWidth 1 ops = displayOpsForPic p (regionForWindow w) in verifyAllSpansHaveWidth i ops lesserWidth singleAttrSingleSpanStackCropped0 :: SingleAttrSingleSpanStack -> Result singleAttrSingleSpanStackCropped0 stack = let p = picForImage (stackImage stack) w = MockWindow (stackWidth stack `div` 2) (stackHeight stack) ops = displayOpsForPic p (regionForWindow w) in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack `div` 2) singleAttrSingleSpanStackCropped1 :: SingleAttrSingleSpanStack -> Bool singleAttrSingleSpanStackCropped1 stack = let p = picForImage (stackImage stack) expectedRowCount = stackHeight stack `div` 2 w = MockWindow (stackWidth stack) expectedRowCount ops = displayOpsForPic p (regionForWindow w) actualRowCount = spanOpsEffectedRows ops in expectedRowCount == actualRowCount singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result singleAttrSingleSpanStackCropped2 stack0 stack1 = let p = picForImage (stackImage stack0 <|> stackImage stack1) w = MockWindow (stackWidth stack0) (imageHeight (picImage p)) ops = displayOpsForPic p (regionForWindow w) in verifyAllSpansHaveWidth (picImage p) ops (stackWidth stack0) singleAttrSingleSpanStackCropped3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool singleAttrSingleSpanStackCropped3 stack0 stack1 = let p = picForImage (stackImage stack0 <|> stackImage stack1) w = MockWindow (imageWidth (picImage p)) expectedRowCount ops = displayOpsForPic p (regionForWindow w) expectedRowCount = imageHeight (picImage p) `div` 2 actualRowCount = spanOpsEffectedRows ops in expectedRowCount == actualRowCount singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result singleAttrSingleSpanStackCropped4 stack0 stack1 = let p = picForImage (stackImage stack0 <-> stackImage stack1) w = MockWindow expectedWidth (imageHeight (picImage p)) ops = displayOpsForPic p (regionForWindow w) expectedWidth = imageWidth (picImage p) `div` 2 in verifyAllSpansHaveWidth (picImage p) ops expectedWidth singleAttrSingleSpanStackCropped5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool singleAttrSingleSpanStackCropped5 stack0 stack1 = let p = picForImage (stackImage stack0 <-> stackImage stack1) w = MockWindow (imageWidth (picImage p)) (stackHeight stack0) ops = displayOpsForPic p (regionForWindow w) expectedRowCount = stackHeight stack0 actualRowCount = spanOpsEffectedRows ops in expectedRowCount == actualRowCount horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result horizSpanImageAndGreaterWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) = let p = picForImage i -- SingleRowSingleAttrImage always has width >= 1 greaterWidth = c * 2 w = MockWindow greaterWidth 1 ops = displayOpsForPic p (regionForWindow w) in verifyAllSpansHaveWidth i ops greaterWidth arbImageIsCropped :: DefaultImage -> MockWindow -> Bool arbImageIsCropped (DefaultImage image) win@(MockWindow w h) = let pic = picForImage image ops = displayOpsForPic pic (regionForWindow win) in ( spanOpsEffectedRows ops == h ) && ( allSpansHaveWidth ops w ) spanOpsActuallyFillRows :: DefaultPic -> Bool spanOpsActuallyFillRows (DefaultPic pic win) = let ops = displayOpsForPic pic (regionForWindow win) expectedRowCount = regionHeight (regionForWindow win) actualRowCount = spanOpsEffectedRows ops in expectedRowCount == actualRowCount spanOpsActuallyFillColumns :: DefaultPic -> Bool spanOpsActuallyFillColumns (DefaultPic pic win) = let ops = displayOpsForPic pic (regionForWindow win) expectedColumnCount = regionWidth (regionForWindow win) in allSpansHaveWidth ops expectedColumnCount firstSpanOpSetsAttr :: DefaultPic -> Bool firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } = let ops = displayOpsForPic pic (regionForWindow win) in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops ) singleAttrSingleSpanStackOpCoverage :: SingleAttrSingleSpanStack -> Result singleAttrSingleSpanStackOpCoverage stack = let p = picForImage (stackImage stack) w = MockWindow (stackWidth stack) (stackHeight stack) ops = displayOpsForPic p (regionForWindow w) in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack) imageCoverageMatchesBounds :: Image -> Result imageCoverageMatchesBounds i = let p = picForImage i r = (imageWidth i,imageHeight i) ops = displayOpsForPic p r in verifyAllSpansHaveWidth i ops (imageWidth i) tests :: IO [Test] tests = return [ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0 , verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1 , verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0 , verify "horiz span image is cropped when window size == (0,0) [1]" horizSpanImageAndZeroWindow1 , verify "horiz span image is not cropped when window size == size of image [width]" horizSpanImageAndEqualWindow0 , verify "horiz span image is not cropped when window size == size of image [height]" horizSpanImageAndEqualWindow1 , verify "horiz span image is not cropped when window size < size of image [width]" horizSpanImageAndLesserWindow0 , verify "horiz span image is not cropped when window size > size of image [width]" horizSpanImageAndGreaterWindow0 , verify "first span op is always to set the text attribute" firstSpanOpSetsAttr , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]" singleAttrSingleSpanStackOpCoverage , verify "a single attr text span is cropped when window size < size of stack image [width]" singleAttrSingleSpanStackCropped0 , verify "a single attr text span is cropped when window size < size of stack image [height]" singleAttrSingleSpanStackCropped1 , verify "single attr text span <|> single attr text span display cropped. [width]" singleAttrSingleSpanStackCropped2 , verify "single attr text span <|> single attr text span display cropped. [height]" singleAttrSingleSpanStackCropped3 , verify "single attr text span <-> single attr text span display cropped. [width]" singleAttrSingleSpanStackCropped4 , verify "single attr text span <-> single attr text span display cropped. [height]" singleAttrSingleSpanStackCropped5 , verify "an arbitrary image when rendered to a window of the same size will cover the entire window" imageCoverageMatchesBounds ] vty-5.4.0/test/VerifyOutput.hs0000644000000000000000000000337212563510500014532 0ustar0000000000000000{- We setup the environment to envoke certain terminals of interest. - This assumes appropriate definitions exist in the current environment for the terminals of - interest. -} module VerifyOutput where import Verify import Graphics.Vty import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.Output import Control.Monad import Data.Default import qualified System.Console.Terminfo as Terminfo import System.Posix.Env import System.Posix.IO tests :: IO [Test] tests = concat <$> forM terminalsOfInterest (\termName -> do -- check if that terminfo exists -- putStrLn $ "testing end to end for terminal: " ++ termName mti <- try $ Terminfo.setupTerm termName case mti of Left (_ :: SomeException) -> return [] Right _ -> return [ verify ("verify " ++ termName ++ " could output a picture") (smokeTestTermNonMac termName) ] ) smokeTestTermNonMac :: String -> Image -> Property smokeTestTermNonMac termName i = liftIOResult $ do smokeTestTerm termName i smokeTestTerm :: String -> Image -> IO Result smokeTestTerm termName i = do nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags t <- outputForConfig $ def { outputFd = Just nullOut, termName = Just termName } -- putStrLn $ "context color count: " ++ show (contextColorCount t) reserveDisplay t dc <- displayContext t (100,100) -- always show the cursor to produce tests for terminals with no cursor support. let pic = (picForImage i) { picCursor = Cursor 0 0 } outputPicture dc pic setCursorPos t 0 0 when (supportsCursorVisibility t) $ do hideCursor t showCursor t releaseDisplay t releaseTerminal t closeFd nullOut return succeeded vty-5.4.0/test/VerifyUsingMockTerminal.hs0000644000000000000000000001056612563510500016630 0ustar0000000000000000module VerifyUsingMockTerminal where import Verify.Graphics.Vty.Prelude import Verify.Graphics.Vty.Picture import Verify.Graphics.Vty.Image import Verify.Graphics.Vty.Span import Verify.Graphics.Vty.Output import Graphics.Vty.Output import Graphics.Vty.Output.Mock 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 unitImageUnitBounds :: UnitImage -> Property unitImageUnitBounds (UnitImage _ i) = liftIOResult $ do (_,t) <- mockTerminal (1,1) dc <- displayBounds t >>= displayContext t let pic = picForImage i outputPicture dc pic return succeeded unitImageArbBounds :: UnitImage -> MockWindow -> Property unitImageArbBounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do (_,t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t let pic = picForImage i outputPicture dc pic return succeeded singleTRow :: MockWindow -> Property singleTRow (MockWindow w h) = liftIOResult $ do (mockData,t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t -- create an image that contains just the character T repeated for a single row let i = horizCat $ replicate (fromEnum w) (char defAttr 'T') pic = (picForImage i) { picBackground = Background 'B' defAttr } outputPicture dc pic -- The mock output string that represents the output bytes a single line containing the T -- string: Followed by h - 1 lines of a change to the background attribute and then the -- background character let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T' ++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B') compareMockOutput mockData expected manyTRows :: MockWindow -> Property manyTRows (MockWindow w h) = liftIOResult $ do (mockData, t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t -- create an image that contains the character 'T' repeated for all the rows let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T') pic = (picForImage i) { picBackground = Background 'B' defAttr } outputPicture dc pic -- 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 = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') compareMockOutput mockData expected manyTRowsCroppedWidth :: MockWindow -> Property manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do (mockData,t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t -- create an image that contains the character 'T' repeated for all the rows let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T') pic = (picForImage i) { picBackground = Background 'B' defAttr } outputPicture dc pic -- 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 = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') compareMockOutput mockData expected manyTRowsCroppedHeight :: MockWindow -> Property manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do (mockData,t) <- mockTerminal (w,h) dc <- displayBounds t >>= displayContext t -- create an image that contains the character 'T' repeated for all the rows let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T') pic = (picForImage i) { picBackground = Background 'B' defAttr } outputPicture dc pic -- 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 = "H" ++ concat (replicate (fromEnum h) $ "MDA" ++ replicate (fromEnum w) 'T') compareMockOutput mockData expected tests :: IO [Test] tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds , verify "unitImageArbBounds" unitImageArbBounds , verify "singleTRow" singleTRow , verify "manyTRows" manyTRows , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight ] vty-5.4.0/test/Verify/0000755000000000000000000000000012563510500012750 5ustar0000000000000000vty-5.4.0/test/Verify/Graphics/0000755000000000000000000000000012563510500014510 5ustar0000000000000000vty-5.4.0/test/Verify/Graphics/Vty/0000755000000000000000000000000012563510500015272 5ustar0000000000000000vty-5.4.0/test/Verify/Graphics/Vty/DisplayAttributes.hs0000644000000000000000000000044012563510500021300 0ustar0000000000000000module Verify.Graphics.Vty.DisplayAttributes ( module Verify.Graphics.Vty.DisplayAttributes , module Graphics.Vty.DisplayAttributes ) where import Graphics.Vty.DisplayAttributes import Verify vty-5.4.0/test/Verify/Graphics/Vty/Span.hs0000644000000000000000000000225312563510500016531 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 qualified Data.Vector as Vector import Data.Word import Verify isAttrSpanOp :: SpanOp -> Bool isAttrSpanOp TextSpan {} = True isAttrSpanOp _ = False verifyAllSpansHaveWidth i spans w = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans) in case any ((== True) . fst) v of False -> succeeded True -> failed { reason = "Not all spans contained operations defining exactly " ++ show w ++ " columns of output - \n" ++ (concatMap ((++ "\n") . show)) v } verifyOpsEquality i_ops i_alt_ops = if i_ops == i_alt_ops then succeeded else failed { reason = "ops for alternate image " ++ show i_alt_ops ++ " are not the same as " ++ show i_ops } vty-5.4.0/test/Verify/Graphics/Vty/Output.hs0000644000000000000000000000275712563510500017141 0ustar0000000000000000module Verify.Graphics.Vty.Output where import Control.Applicative ((<$>)) import Graphics.Vty.Output.Mock import qualified Data.ByteString as BS import Data.IORef import qualified Data.String.UTF8 as UTF8 import Test.QuickCheck.Property -- A list of terminals that should be supported. -- This started with a list of terminals ubuntu supported. Then those terminals that really could -- not be supported were removed. Then a few more were pruned until a reasonable looking set was -- made. terminalsOfInterest :: [String] terminalsOfInterest = [ "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" ] compareMockOutput :: MockData -> String -> IO Result compareMockOutput mockData expectedStr = do outStr <- UTF8.toString <$> readIORef mockData if outStr /= expectedStr then return $ failed { reason = "bytes\n" ++ outStr ++ "\nare not the expected bytes\n" ++ expectedStr } else return succeeded vty-5.4.0/test/Verify/Graphics/Vty/Image.hs0000644000000000000000000001732212563510500016655 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# 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.Image import Graphics.Vty.Image.Internal import Verify data UnitImage = UnitImage Char Image instance Arbitrary UnitImage where arbitrary = do SingleColumnChar c <- arbitrary a <- arbitrary return $ UnitImage c (char a c) instance Show UnitImage where show (UnitImage c _) = "UnitImage " ++ show c data DefaultImage = DefaultImage Image instance Show DefaultImage where show (DefaultImage i) = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i) instance Arbitrary DefaultImage where arbitrary = do i <- return $ char defAttr 'X' return $ DefaultImage i data SingleRowSingleAttrImage = SingleRowSingleAttrImage { expectedAttr :: Attr , expectedColumns :: Int , rowImage :: Image } instance Show SingleRowSingleAttrImage where show (SingleRowSingleAttrImage attr columns image) = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )" newtype WidthResize = WidthResize (Image -> (Image, Int)) instance Arbitrary WidthResize where arbitrary = do WidthResize f <- arbitrary w <- choose (1,64) oneof $ map (return . WidthResize) [ \i -> (i, imageWidth i) , \i -> (resizeWidth w $ fst $ f i, w) , \i -> let i' = fst $ f i in (cropLeft w i', min (imageWidth i') w) , \i -> let i' = fst $ f i in (cropRight w i', min (imageWidth i') w) ] newtype HeightResize = HeightResize (Image -> (Image, Int)) instance Arbitrary HeightResize where arbitrary = do HeightResize f <- arbitrary h <- choose (1,64) oneof $ map (return . HeightResize) [ \i -> (i, imageHeight i) , \i -> (resizeHeight h $ fst $ f i, h) , \i -> let i' = fst $ f i in (cropTop h i', min (imageHeight i') h) , \i -> let i' = fst $ f i in (cropBottom h i', min (imageHeight i') h) ] newtype ImageResize = ImageResize (Image -> (Image, (Int, Int))) instance Arbitrary ImageResize where arbitrary = oneof [ return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i)) , do ImageResize f <- arbitrary WidthResize g <- arbitrary return $! ImageResize $! \i -> let (i0, (_, outHeight)) = f i gI = g i0 in (fst gI, (snd gI, outHeight)) , do ImageResize f <- arbitrary HeightResize g <- arbitrary return $! ImageResize $! \i -> let (i0, (outWidth, _)) = f i gI = g i0 in (fst gI, (outWidth, snd gI)) ] 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 singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary) a <- arbitrary let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText] outWidth = length singleColumnRowText return $ SingleRowSingleAttrImage a outWidth outImage data SingleRowTwoAttrImage = SingleRowTwoAttrImage { part0 :: SingleRowSingleAttrImage , part1 :: SingleRowSingleAttrImage , joinImage :: Image } deriving Show instance Arbitrary SingleRowTwoAttrImage where arbitrary = do p0 <- arbitrary p1 <- arbitrary return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1) data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack { stackImage :: Image , stackSourceImages :: [SingleRowSingleAttrImage] , stackWidth :: Int , stackHeight :: Int } deriving Show instance Arbitrary SingleAttrSingleSpanStack where arbitrary = do imageList <- Verify.resize 16 (listOf1 arbitrary) return $ mkSingleAttrSingleSpanStack imageList shrink s = do imageList <- shrink $ stackSourceImages s if null imageList then [] else return $ mkSingleAttrSingleSpanStack imageList mkSingleAttrSingleSpanStack imageList = let image = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- imageList ] in SingleAttrSingleSpanStack image imageList (maximum $ map expectedColumns imageList) (toEnum $ length imageList) instance Arbitrary Image where arbitrary = oneof [ return EmptyImage , do SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary ImageResize f <- Verify.resize 2 arbitrary return $! fst $! f stackImage , do SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary ImageResize f <- Verify.resize 2 arbitrary return $! fst $! f stackImage , do i0 <- arbitrary i1 <- arbitrary let i = i0 <|> i1 ImageResize f <- Verify.resize 2 arbitrary return $! fst $! f i , do i0 <- arbitrary i1 <- arbitrary let i = i0 <-> i1 ImageResize f <- Verify.resize 2 arbitrary return $! fst $! f i ] {- shrink i@(HorizJoin {partLeft, partRight}) = do let !i_alt = backgroundFill (imageWidth i) (imageHeight i) !partLeft' <- shrink partLeft !partRight' <- shrink partRight [i_alt, partLeft' <|> partRight'] shrink i@(VertJoin {partTop, partBottom}) = do let !i_alt = backgroundFill (imageWidth i) (imageHeight i) !partTop' <- shrink partTop !partBottom' <- shrink partBottom [i_alt, partTop' <-> partBottom'] shrink i@(CropRight {croppedImage, outputWidth}) = do let !i_alt = backgroundFill (imageWidth i) (imageHeight i) [i_alt, croppedImage] shrink i@(CropLeft {croppedImage, leftSkip, outputWidth}) = do let !i_alt = backgroundFill (imageWidth i) (imageHeight i) [i_alt, croppedImage] shrink i@(CropBottom {croppedImage, outputHeight}) = do let !i_alt = backgroundFill (imageWidth i) (imageHeight i) [i_alt, croppedImage] shrink i@(CropTop {croppedImage, topSkip, outputHeight}) = do let !i_alt = backgroundFill (imageWidth i) (imageHeight i) [i_alt, croppedImage] shrink i = [emptyImage, backgroundFill (imageWidth i) (imageHeight i)] -} data CropOperation = CropFromLeft | CropFromRight | CropFromTop | CropFromBottom deriving (Eq, Show) instance Arbitrary CropOperation where arbitrary = oneof $ map return [CropFromLeft, CropFromRight, CropFromTop, CropFromBottom] data Translation = Translation Image (Int, Int) Image deriving (Eq, Show) instance Arbitrary Translation where arbitrary = do i <- arbitrary x <- arbitrary `suchThat` (> 0) y <- arbitrary `suchThat` (> 0) let i' = translate x y i return $ Translation i (x,y) i' vty-5.4.0/test/Verify/Graphics/Vty/Picture.hs0000644000000000000000000000274612563510500017252 0ustar0000000000000000{-# LANGUAGE DisambiguateRecordFields #-} module Verify.Graphics.Vty.Picture ( module Verify.Graphics.Vty.Picture , module Graphics.Vty.Picture ) where import Verify.Graphics.Vty.Prelude import Graphics.Vty.Picture import Graphics.Vty.Debug import Verify.Graphics.Vty.Attributes import Verify.Graphics.Vty.Image import Verify data DefaultPic = DefaultPic { defaultPic :: Picture , defaultWin :: MockWindow } instance Show DefaultPic where show (DefaultPic pic win) = "DefaultPic\n\t( " ++ show pic ++ ")\n\t" ++ show win ++ "\n" instance Arbitrary DefaultPic where arbitrary = do DefaultImage image <- arbitrary let win = MockWindow (imageWidth image) (imageHeight image) return $ DefaultPic (picForImage image) win data PicWithBGAttr = PicWithBGAttr { withAttrPic :: Picture , withAttrWin :: MockWindow , withAttrSpecifiedAttr :: Attr } deriving ( Show ) instance Arbitrary PicWithBGAttr where arbitrary = do DefaultImage image <- arbitrary let win = MockWindow (imageWidth image) (imageHeight image) attr <- arbitrary return $ PicWithBGAttr (picForImage image) win attr instance Arbitrary Picture where arbitrary = do layers <- Verify.resize 20 (listOf1 arbitrary) return $ picForLayers layers vty-5.4.0/test/Verify/Graphics/Vty/Attributes.hs0000644000000000000000000000330612563510500017756 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 ) allColors :: [Color] allColors = [ black , red , green , yellow , blue , magenta , cyan , white , brightBlack , brightRed , brightGreen , brightYellow , brightBlue , brightMagenta , brightCyan , brightWhite ] ++ map Color240 [0..239] allStyles :: [Style] allStyles = [ standout , underline , reverseVideo , blink , dim , bold ] -- Limit the possible attributes to just a few for now. possibleAttrMods :: [ AttrOp ] possibleAttrMods = [ idOp ] ++ map setForeColorOp allColors ++ map setBackColorOp allColors ++ map setStyleOp allStyles instance Arbitrary Attr where arbitrary = elements possibleAttrMods >>= return . flip applyOp defAttr data DiffAttr = DiffAttr Attr Attr instance Arbitrary DiffAttr where arbitrary = do op0 <- elements possibleAttrMods let possibleAttrMods' = delete op0 possibleAttrMods op1 <- elements possibleAttrMods' return $ DiffAttr (applyOp op0 defAttr) (applyOp op1 defAttr) data AttrOp = AttrOp String (Attr -> Attr) instance Eq AttrOp where AttrOp n0 _ == AttrOp n1 _ = n0 == n1 setStyleOp s = AttrOp "set_style" (flip withStyle s) setForeColorOp c = AttrOp "set_fore_color" (flip withForeColor c) setBackColorOp c = AttrOp "set_back_color" (flip withBackColor c) idOp = AttrOp "id" id applyOp :: AttrOp -> Attr -> Attr applyOp (AttrOp _ f) a = f a vty-5.4.0/test/Verify/Graphics/Vty/Prelude.hs0000644000000000000000000000125112563510500017225 0ustar0000000000000000module Verify.Graphics.Vty.Prelude ( module Verify.Graphics.Vty.Prelude , module Graphics.Vty.Prelude , MockWindow(..) ) where import Graphics.Vty.Prelude import Graphics.Vty.Debug import Verify data EmptyWindow = EmptyWindow MockWindow instance Arbitrary EmptyWindow where arbitrary = return $ EmptyWindow (MockWindow (0 :: Int) (0 :: Int)) instance Show EmptyWindow where show (EmptyWindow _) = "EmptyWindow" instance Arbitrary MockWindow where arbitrary = do w <- choose (1,1024) h <- choose (1,1024) return $ MockWindow w h vty-5.4.0/test/Verify/Data/0000755000000000000000000000000012563510500013621 5ustar0000000000000000vty-5.4.0/test/Verify/Data/Terminfo/0000755000000000000000000000000012563510500015404 5ustar0000000000000000vty-5.4.0/test/Verify/Data/Terminfo/Parse.hs0000644000000000000000000000722712563510500017022 0ustar0000000000000000module 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 qualified Data.Vector.Unboxed as Vector import Numeric hexDump :: [Word8] -> String hexDump 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) <- insertEscapeOp "%" [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) <- insertEscapeOp "i" [] s return $ IncFirstTwoCap s' bytes ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 ) data PushParamCap = PushParamCap String Int [Word8] deriving ( Show ) instance Arbitrary PushParamCap where arbitrary = ( do NonParamCapString s <- arbitrary n <- choose (1,9) (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s return $ PushParamCap s' n bytes ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 ) data DecPrintCap = DecPrintCap String Int [Word8] deriving ( Show ) instance Arbitrary DecPrintCap where arbitrary = ( do NonParamCapString s <- arbitrary n <- choose (1,9) (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s return $ DecPrintCap s' n bytes ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 ) insertEscapeOp opStr replBytes s = do insertPoints <- listOf1 $ elements [0 .. length s - 1] let s' = f s ('%' : opStr) remainingBytes = f (map (toEnum . fromEnum) s) replBytes f inVs out_v = concat [ vs | vi <- zip inVs [0 .. length s - 1] , let vs = fst vi : ( if snd vi `elem` insertPoints then out_v else [] ) ] return (s', remainingBytes) isBytesOp :: CapOp -> Bool isBytesOp (Bytes {}) = True -- isBytesOp _ = False bytesForRange cap offset count = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap collectBytes :: CapExpression -> [Word8] collectBytes e = concat [ bytes | Bytes offset count <- capOps e , let bytes = bytesForRange e offset count ] verifyBytesEqual :: [Word8] -> [Word8] -> Result verifyBytesEqual outBytes expectedBytes = if outBytes == expectedBytes then succeeded else failed { reason = "outBytes [" ++ hexDump outBytes ++ "] /= expectedBytes [" ++ hexDump expectedBytes ++ "]" } vty-5.4.0/cbits/0000755000000000000000000000000012563510500011631 5ustar0000000000000000vty-5.4.0/cbits/gwinsz.c0000644000000000000000000000030012563510500013307 0ustar0000000000000000#include unsigned long vty_c_get_window_size(int fd) { struct winsize w; if (ioctl (fd, TIOCGWINSZ, &w) >= 0) return (w.ws_row << 16) + w.ws_col; else return 0x190050; } vty-5.4.0/cbits/mk_wcwidth.c0000644000000000000000000003321412563510500014140 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-5.4.0/cbits/set_term_timing.c0000644000000000000000000000042612563510500015170 0ustar0000000000000000#include #include #include #include void vty_set_term_timing(int fd, int vmin, int vtime) { struct termios trm; tcgetattr(fd, &trm); trm.c_cc[VMIN] = vmin; trm.c_cc[VTIME] = vtime; tcsetattr(fd, TCSANOW, &trm); }