diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,249 @@ +6.6 +--- + +* Added support for horizontal scrolling inputs. The `Button` type in + `Graphics.Vty.Input.Events` got new constructors `BScrollLeft` and + `BScrollRight` for Vty backend implementations that support horizontal + scrolling inputs. + +6.5 +--- + +* Raised upper bound on `microlens` dependency to permit builds against + 0.5. +* Fixed the `utf8-string` dependency lower bound to account for an added + module in 0.3.1. (#279) +* Improved the allocation behavior of `swapSkipsForSingleColumnCharSpan`. + +6.4 +--- + +* Updated the behavior of character width computations when a custom + character width table has been installed. Now when a custom character + width table doesn't provide a width for a character, rather than + defaulting to 1 column, the built-in table is consulted. This change + shouldn't affect users using width tables generated by `vty-unix`'s + table-building tool since that tool generates tables that will provide + widths for all supported characters. + +6.3 +--- + +* Raise microlens upper bound to build with 0.4.14 (#278) +* Updated other bounds to permit building with GHC 9.12 (thanks Erik de + Catro Lopo) +* Removed defunct examples from project + +6.2 +--- + +Package changes: +* Update version bounds to support building with GHC 9.8 + +Bug fixes: +* Updated `PictureToSpans` module to implement its lenses manually to + avoid template haskell which has trouble on Windows and GHC 9.2 (#271) + +6.1 +--- + +API changes: +* `ColorMode` got a `Read` instance. +* The `Config` type got a new `configPreferredColorMode` field for + specifying a preferred `ColorMode`. Backend packages should respect + this field, but note that `vty` itself does not (and cannot) enact + this preference since it's up to the backend driver to configure the + color mode. +* The Vty configuration file got a new `colorMode` field whose value is + a string literal compatible with the `ColorMode` `Read` instance. + +6.0 +--- + +This release marks the beginning of multi-platform support in Vty. +Getting to this point involved removing Unix-specific functionality +from Vty and moving it to a new package, `vty-unix`. Windows support +is now provided via a `vty-windows` package. Another new package, +`vty-crossplatform`, is provided as a convenience for applications that +want to support both Unix and Windows platforms automatically at build +time. See the migration guide below for details on how to upgrade. + +**Migration guide for 6.0** + +To upgrade to this version of Vty, most people will only need to take a +few steps: + +1. Add a package dependency on `vty-unix`, `vty-windows,` or + `vty-crossplatform`, depending on the desired level of platform + support. For example, if an application only supports Unix systems, + it should depend on `vty-unix`. But if an application is intended to + work anywhere Vty works, then `vty-crossplatform` is the best choice. +2. Import `mkVty` from the platform package in step (1). (`mkVty` was + removed from the `vty` package and is now the responsibility of each + platform package.) Imports are as follows: + * `vty-unix`: `Graphics.Vty.Platform.Unix` + * `vty-windows`: `Graphics.Vty.Platform.Windows` + * `vty-crossplatform`: `Graphics.Vty.CrossPlatform` +3. Maintain any existing package dependency on `vty`; the core library + abstractions, types, and functions are still obtained from `vty` + itself. The platform packages do not re-export the core library's + modules. +4. If desired, call `Graphics.Vty.Config.userConfig` to load the Vty + user configuration since this step is no longer automatic. +5. Some configurations have been moved to `Graphics.Vty.Output`. For + example, `mouseMode` is no longer a field in `VtyUserConfig`. + Instead, use `setMode` to enable it. + +For applications using more of Vty's API than just the basic +initialization and rendering API, the full change list is provided +below. For people who want to write their own Vty platform package like +`vty-unix`, see `PLATFORM-HOWTO.md`. + +**Detailed change list for 6.0** + +* Package changes: + * The following modules got added to the `vty` library: + * `Graphics.Vty.UnicodeWidthTable.Main` + * The following modules got moved to `vty-unix`: + * `Data.Terminfo.Eval` + * `Data.Terminfo.Parse` + * The following modules got moved to `vty-unix` into the + `Graphics.Vty.Platform.Unix` module namespace (previously + `Graphics.Vty`): + * `Graphics.Vty.Input.Classify` + * `Graphics.Vty.Input.Classify.Parse` + * `Graphics.Vty.Input.Classify.Types` + * `Graphics.Vty.Input.Focus` + * `Graphics.Vty.Input.Loop` + * `Graphics.Vty.Input.Mouse` + * `Graphics.Vty.Input.Paste` + * `Graphics.Vty.Input.Terminfo` + * `Graphics.Vty.Output.TerminfoBased` + * `Graphics.Vty.Output.XTermColor` + * The following modules were removed entirely (with contents migrated + elsewhere as needed): + * `Graphics.Vty.Inline.Unsafe` + * `Graphics.Vty.Output.Interface` (migrated to + `Graphics.Vty.Output`) + * Removed library dependencies on the following packages: + * `ansi-terminal` + * `containers` + * `terminfo` + * `transformers` + * `unix` + * The following executables were moved to other packages: + * `vty-build-width-table` (moved to `vty-unix` as + `vty-unix-build-width-table`) + * `vty-mode-demo` (moved to `vty-crossplatform`) +* API changes: + * `Graphics.Vty.mkVty` moved to the `vty-unix` package's + `Graphics.Vty.Platform.Unix` module. + * Added `Graphics.Vty.mkVtyFromPair` for platform packages to + construct `Vty` handles. + * The contents of the `Graphics.Vty.Output.Interface` module were + merged into `Graphics.Vty.Output`. + * The `vty-build-width-table` tool was removed from the `vty` package, + but its core functionality is now exposed as a library for + platform packages to use to provide platform-specific tools using + `Graphics.Vty.UnicodeWidthTable.Main` and a new tool by the same + name was added to the `vty-unix` package. + * `Graphics.Vty.Events`: the `InternalEvent` type's + `ResumeAfterSignal` constructor was renamed to + `ResumeAfterInterrupt` to be a bit more abstract and + platform-agnostic. + * Removed the following lenses for fields of the `Input` type: + * `eventChannel` (was for `_eventChannel` which was then renamed to + `eventChannel`) + * `configRef` (was for `_configRef` which was then renamed to + `configRef`) + * The `Output` record type got a new field, `setOutputWindowTitle`. + * The `Input` record type got a new field, `inputLogMsg :: String -> + IO ()`, for logging to the Vty log. + * `Graphics.Vty.Config` now exposes `VtyUserConfig` instead of + `Config`. Many of its fields were Unix-specific and were + consequently moved to the `UnixSettings` type in `vty-unix` and + given a `settings` prefix. This includes `outputFd`, `inputFd`, + `vmin`, `vtime`, and `termName`. + * The `VtyUserConfig` type's fields got a `config` field name prefix. + * `inputForConfig` was moved to `vty-unix` as `buildInput` but + generally should not be needed and is exposed only for testing. + * `outputForConfig` was moved to `vty-unix` as `buildOutput` but + generally should not be needed and is exposed only for testing. +* Behavior changes: + * Since `vty` no longer implements `mkVty`, the Vty user configuration + is no longer implicitly loaded by Vty-based applications. + Instead, it is now up to the applications to call + `Graphics.Vty.Config.userConfig` to load any user-provided + configuration. + * Vty no longer implicitly attempts to load configured Unicode + width tables. It is now the responsibility of the platform packages + (such as `vty-unix`) and/or applications to load tables via + `Graphics.Vty.UnicodeWidthTable.IO` and install them via + `Graphics.Vty.UnicodeWidthTable.Install`. +* Changes to demonstration programs: + * `EventEcho`, `ModeDemo`, and `Rogue` demo programs moved to the + `vty-crossplatform` package. +* Changes to tests: + * Where appropriate, some test programs and test cases were moved to + `vty-unix` or `vty-crossplatform`. + +5.39 +---- + +Package changes: +* Now builds with `mtl-2.3.*`. + +Bug fixes: +* Fixed a long-standing issue where unused input on stdin could cause a + memory error and a crash when Vty was being initialized. (#266) + +5.38 +---- + +This release includes numerous API changes, although none of them should +break your programs. If so, please open a ticket on the Vty issue +tracker. + +Package changes: +* Support mtl 2.3 (thanks Daniel Firth) +* The test and example collections got completely overhauled to clean up + bit rot. + * Moved example programs into examples/ under a new vty-examples + package. + * Moved test suite programs out of vty.cabal and into tests/ under a + new vty-tests package. + * Cleaned up all build-depends lists in all three packages to remove + unused deps. + * Consolidated the test suite library modules into the vty-tests + library to avoid redundant compilation. + * Added build.sh to build everything in the development process to + help ensure that examples and tests don't get forgotten. + * Removeed lots of stale/unused modules in old test/ directory. +* Got vty-examples building again and resolved various warnings and + issues. + +API changes: +* All modules got explicit export lists. Prior to this release, many + modules exported everything they contained, making it difficult to + know what was really intended to be part of the public API. The new + export lists should contain everything that applications need; the + risk of breakage exists but should be minor. Please open a ticket if + you were using something that is no longer exported. It might be that + it was never supposed to be exported to begin with, or it might be + just something we need to export once again. +* Moved the `attributeControl` function from `Graphics.Vty.Input.Loop` + to `Graphics.Vty.Input`. +* Removed the `Graphics.Vty.Image.DisplayText` alias for `Text`. +* Unified the `Image` cropping constructors (thanks Fraser Tweedale) + +5.37 +---- + +* The Xterm backend is now used when `TERM` matches `rxvt` or `tmux`. +* PictureToSpans now uses `error`, not `fail`, to avoid dependence on + soon-to-be-removed `MonadFail` instance for `ST` (#248) + 5.36 ---- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,49 +4,61 @@ interface for doing terminal I/O. Vty is supported on GHC versions 7.10.1 and up. -Install via `git` with: +`vty` and its partner packages are published on +[Hackage](https://hackage.haskell.org/). The `vty` package works in +concert with one or more *platform packages* to do terminal I/O. Each +platform package provides support for terminal I/O on a specific +platform. Known platform packages are: -``` -git clone git://github.com/jtdaugherty/vty.git -``` +* [vty-unix](https://github.com/jtdaugherty/vty-unix) - the Unix + terminal backend for Vty +* [vty-windows](https://github.com/chhackett/vty-windows) - the Windows + terminal backend for Vty +* [vty-crossplatform](https://github.com/jtdaugherty/vty-crossplatform) - + a package that builds `vty-unix` or `vty-windows` based on the build + environment -Install via `cabal` with: +# How to use Vty -``` -cabal install vty -``` +1. Add a package dependency on `vty-unix`, `vty-windows,` or + `vty-crossplatform`, depending on the desired level of platform + support. For example, if an application only supports Unix systems, + it should depend on `vty-unix`. But if an application is intended to + work anywhere Vty works, then `vty-crossplatform` is the best choice. +2. Add a package dependency on `vty`; the core library abstractions, + types, and functions are obtained from `vty` itself. The platform + packages do not re-export the core library's modules. +3. Import `mkVty` from the platform package in step (1) and use that to + construct a `Vty` handle and initialize the terminal. +4. If desired, call `Graphics.Vty.Config.userConfig` to load the Vty + user configuration since this step is not automatic. -# Features +Once you've initialized the terminal and have a `Vty` value, all of the +`vty` package's API is now ready to use to do terminal I/O. -* Supports a large number of terminals, i.e., vt100, ansi, hurd, linux, - `screen`, etc., or anything with a sufficient terminfo entry. +# Implementing support for a new platform -* Automatically handles window resizes. +Although this shouldn't be necessary to do very often (if ever!), if +you would like to implement support for a new platform for Vty, see +`PLATFORM-HOWTO.md`. -* Supports Unicode output on terminals with UTF-8 support. +# Features * Provides an efficient output algorithm. Output buffering and terminal state changes are minimized. +* Automatically handles window resizes. + * Minimizes repaint area, which virtually eliminates the flicker problems that plague ncurses programs. * Provides a pure, compositional interface for efficiently constructing display images. -* Automatically decodes keyboard keys into (key,[modifier]) tuples. - * Automatically supports refresh on Ctrl-L. -* Supports a keypress timeout after for lone ESC. The timeout is - customizable. - * Provides extensible input and output interfaces. -* Supports ANSI graphics modes (SGR as defined in `console_codes(4)`) - with a type-safe interface and graceful fallback for terminals - with limited or nonexistent support for such modes. - * Properly handles cleanup (but not due to signals). * Provides a comprehensive test suite. @@ -68,17 +80,6 @@ Vty uses threads internally, so programs made with Vty need to be compiled with the threaded runtime using the GHC `-threaded` option. -# Platform Support - -## Posix Terminals - -For the most part, Vty uses `terminfo` to determine terminal protocol -with some special rules to handle some omissions from `terminfo`. - -## Windows - -Windows is not supported. - # Multi-Column Character Support Vty supports rendering of multi-column characters such as two-column @@ -104,13 +105,11 @@ disagree with your terminal, Vty provides an API and a command-line tool to generate and install custom tables. -Custom Unicode width tables based on your terminal emulator can be -built by running Vty's built-in tool, `vty-build-width-table`. The tool -works by querying the current terminal emulator to obtain its width -measurements for the entire supported Unicode range. The -results are then saved to a disk file. These custom tables -can also be generated programmatically by using the API in -`Graphics.Vty.UnicodeWidthTable.Query`. +Custom Unicode width tables based on your terminal emulator can +be built by using the API in `Graphics.Vty.UnicodeWidthTable`. +The process works by querying the current terminal environment to +obtain its width measurements for the entire supported Unicode +range. The results are then saved to a disk file. Saved width tables can then be loaded in one of two ways: @@ -144,50 +143,23 @@ program. Once a custom table has been loaded, it cannot be replaced or removed. -Without using a custom width table, users of Vty-based applications -are likely to eventually experience rendering problems with with wide -characters. We recommend that developers of Vty-based applications either: - -* Provide the `vty-build-width-table` tool and documentation for running - it and updating the Vty configuration, or -* Have the application invoke the Vty library's table-building - functionality and load the table at startup without using the Vty - configuration. - -The best option will depend on a number of factors: the user audience, -the amount of risk posed by wide character rendering, the terminal -emulators in use, etc. - # Contributing If you decide to contribute, that's great! Here are some guidelines you should consider to make submitting patches easier for all concerned: + - Patches written completely or partially by AI are unlikely to be + accepted. Please disclose any AI use. - If you want to take on big things, talk to me first; let's have a design/vision discussion before you start coding. Create a GitHub issue and we can use that as the place to hash things out. - If you make changes, make them consistent with the syntactic conventions already used in the codebase. - Please provide Haddock documentation for any changes you make. - -# Known Issues - -* Terminals have numerous quirks and bugs, so mileage may vary. Please - report issues as you encounter them and provide details on your - terminal emulator, operating system, etc. - -* STOP, TERM and INT signals are not handled. - -* 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. - -* Vty uses the `TIOCGWINSZ` ioctl to find the current window size, which - appears to be limited to Linux and BSD. + - Please do NOT include package version changes in your patches. + Package version changes are only done at release time when the full + scope of a release's changes can be evaluated to determine the + appropriate version change. # Further Reading diff --git a/cbits/get_tty_erase.c b/cbits/get_tty_erase.c deleted file mode 100644 --- a/cbits/get_tty_erase.c +++ /dev/null @@ -1,18 +0,0 @@ -#include -#include -#include -#include - -// Given a file descriptor for a terminal, get the ERASE character for -// the terminal. If the terminal info cannot be obtained, this returns -// zero. -char vty_get_tty_erase(int fd) -{ - struct termios trm; - - if (0 == tcgetattr(fd, &trm)) { - return (char) trm.c_cc[VERASE]; - } else { - return (char) 0; - } -} diff --git a/cbits/gwinsz.c b/cbits/gwinsz.c deleted file mode 100644 --- a/cbits/gwinsz.c +++ /dev/null @@ -1,18 +0,0 @@ -#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; -} - -void vty_c_set_window_size(int fd, unsigned long val) { - struct winsize w; - if (ioctl(fd, TIOCGWINSZ, &w) >= 0) { - w.ws_row = val >> 16; - w.ws_col = val & 0xFFFF; - ioctl(fd, TIOCSWINSZ, &w); - } -} diff --git a/cbits/mk_wcwidth.c b/cbits/mk_wcwidth.c --- a/cbits/mk_wcwidth.c +++ b/cbits/mk_wcwidth.c @@ -72,6 +72,9 @@ // built-in tree search logic is used. static uint8_t* custom_table = NULL; +// Unused table cell value. +static uint8_t UNUSED_CELL = 0xff; + // The size of the custom table, in entries. This should only be set // if custom_table is not NULL. Its value should be the size of the // custom_table array. @@ -228,14 +231,24 @@ // Return the width, in terminal cells, of the specified character. // // If the global custom width table is present, that table will be -// consulted for the character's width. If the character is not in -// the table, zero will be returned. If the custom width table is not -// present, the built-in width table will be used. +// consulted for the character's width. If the character is not in the +// table, this will fall back to the built-in table. If the character is +// in neither table, zero will be returned. If the custom width table is +// not present, the built-in width table will be used. HsInt vty_mk_wcwidth(HsChar ch) { if (custom_table_ready) { if ((ch >= 0) && (ch < custom_table_size)) { - return custom_table[ch]; + uint8_t result = custom_table[ch]; + + // The table is filled with UNUSED_CELL values for + // uninitialized ranges so we can defer to the built-in + // table in those cases. + if (result == UNUSED_CELL) { + return builtin_wcwidth(ch); + } else { + return result; + } } else { return -1; } @@ -249,7 +262,7 @@ // This allocates a new character width table of the specified size // (in characters). If a custom table has already been allocated, this // returns 1. Otherwise it allocates a new table, initializes all of its -// entries to 1, and returns zero. +// entries to UNUSED_CELL, and returns zero. // // Note that this does *not* mark the table as ready for use. Until the // table is marked ready, it will not be used by vty_mk_wcwidth. To mark @@ -261,7 +274,7 @@ if (size > 0 && size <= MAX_CUSTOM_TABLE_SIZE) { custom_table_ready = 0; custom_table = malloc(size); - memset(custom_table, 1, size); + memset(custom_table, UNUSED_CELL, size); custom_table_size = size; return 0; } else { diff --git a/cbits/set_term_timing.c b/cbits/set_term_timing.c deleted file mode 100644 --- a/cbits/set_term_timing.c +++ /dev/null @@ -1,13 +0,0 @@ -#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); -} diff --git a/demos/Demo.hs b/demos/Demo.hs deleted file mode 100644 --- a/demos/Demo.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main where - -import Graphics.Vty - -import Control.Applicative hiding ((<|>)) -import Control.Arrow -import Control.Monad.RWS - -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 defaultConfig - else mkVty (defaultConfig { 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 palette." - , "Followed by tones of red using a 24-bit palette." - , "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 ¯\\_(ツ)_/¯" - , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯" - ] - -splitColorImages :: [Image] -> [[Image]] -splitColorImages [] = [] -splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is)) - -fullcolorbox :: Image -fullcolorbox = vertCat $ map horizCat $ splitColorImages colorImages - where - colorImages = map (\i -> string (currentAttr `withBackColor` linearColor i 0 0) " ") [0..255] - -colorbox_240 :: Image -colorbox_240 = vertCat $ map horizCat $ splitColorImages colorImages - where - colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239] - -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 <|> fullcolorbox) - 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 [] - diff --git a/demos/ModeDemo.hs b/demos/ModeDemo.hs deleted file mode 100644 --- a/demos/ModeDemo.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Main where - -import Control.Applicative -import Data.Monoid -import Foreign.C.Types (CInt(..), CChar(..)) -import System.Posix.Types (Fd(..)) - -import Graphics.Vty - -mkUI :: (Bool, Bool, Bool, Bool) -> Maybe Event -> Image -mkUI (m, ms, p, ps) e = - vertCat [ string defAttr $ "Mouse mode supported: " <> show m - , string defAttr $ "Mouse mode status: " <> show ms - , string defAttr " " - , string defAttr $ "Paste mode supported: " <> show p - , string defAttr $ "Paste mode status: " <> show ps - , string defAttr " " - , string defAttr $ "Last event: " <> show e - , string defAttr " " - , string defAttr "Press 'm' to toggle mouse mode, 'p' to toggle paste mode, and 'q' to quit." - ] - -main :: IO () -main = do - cfg <- standardIOConfig - vty <- mkVty cfg - - let renderUI lastE = do - let output = outputIface vty - info <- (,,,) <$> (pure $ supportsMode output Mouse) - <*> getModeStatus output Mouse - <*> (pure $ supportsMode output BracketedPaste) - <*> getModeStatus output BracketedPaste - return $ picForImage $ mkUI info lastE - - let go lastE = do - pic <- renderUI lastE - update vty pic - e <- nextEvent vty - case e of - EvKey (KChar 'q') [] -> return () - EvKey (KChar 'm') [] -> do - let output = outputIface vty - enabled <- getModeStatus output Mouse - setMode output Mouse (not enabled) - go (Just e) - EvKey (KChar 'p') [] -> do - let output = outputIface vty - enabled <- getModeStatus output BracketedPaste - setMode output BracketedPaste (not enabled) - go (Just e) - _ -> go (Just e) - - go Nothing - shutdown vty diff --git a/src/Codec/Binary/UTF8/Debug.hs b/src/Codec/Binary/UTF8/Debug.hs deleted file mode 100644 --- a/src/Codec/Binary/UTF8/Debug.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# 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 (`showHex` "") . utf8FromIso diff --git a/src/Data/Terminfo/Eval.hs b/src/Data/Terminfo/Eval.hs deleted file mode 100644 --- a/src/Data/Terminfo/Eval.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_HADDOCK hide #-} - --- | 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 - --- | 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 <- evalParams <$> get - 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 = mapM_ writeCapOp - -writeCapOp :: CapOp -> Eval () -writeCapOp (Bytes !offset !count) = do - !cap <- evalExpression <$> get - 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 diff --git a/src/Data/Terminfo/Parse.hs b/src/Data/Terminfo/Parse.hs deleted file mode 100644 --- a/src/Data/Terminfo/Parse.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -funbox-strict-fields -O #-} -{-# OPTIONS_HADDOCK hide #-} - -module Data.Terminfo.Parse - ( module Data.Terminfo.Parse - , Text.Parsec.ParseError - ) -where - -import Control.Monad ( liftM ) -import Control.DeepSeq - -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup (Semigroup(..)) -#endif -import Data.Word -import qualified Data.Vector.Unboxed as Vector - -import Numeric (showHex) - -import Text.Parsec - -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 showHex "" - -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 - -- The expression) pairs. %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 :: String -> 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. - , 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 <- nextOffset <$> getState - 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 <- read . pure <$> digit - 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 <- nextOffset <$> getState - 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 Semigroup BuildResults where - v0 <> v1 - = BuildResults - { outParamCount = outParamCount v0 `max` outParamCount v1 - , outCapOps = outCapOps v0 <> outCapOps v1 - , outParamOps = outParamOps v0 <> outParamOps v1 - } - -instance Monoid BuildResults where - mempty = BuildResults 0 [] [] -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif diff --git a/src/Graphics/Vty.hs b/src/Graphics/Vty.hs --- a/src/Graphics/Vty.hs +++ b/src/Graphics/Vty.hs @@ -4,42 +4,48 @@ -- | Vty provides interfaces for both terminal input and terminal -- output. -- --- - Input to the terminal is provided to the Vty application as a +-- - User input to the terminal is provided to the Vty application as a -- sequence of 'Event's. -- --- - Output is provided to Vty by the application in the form of a +-- - Output is provided to by the application to Vty in the form of a -- 'Picture'. A 'Picture' is one or more layers of 'Image's. -- 'Image' values can be built by the various constructors in -- "Graphics.Vty.Image". Output can be syled using 'Attr' (attribute) -- values in the "Graphics.Vty.Attributes" module. -- --- Vty uses threads internally, so programs made with Vty need to be --- compiled with the threaded runtime using the GHC @-threaded@ option. +-- - Each platform on which Vty is supported provides a package that +-- provides Vty with access to the platform-specific terminal +-- interface. For example, on Unix systems, the @vty-unix@ package +-- must be used to initialize Vty with access to a Unix terminal. -- --- @ --- import "Graphics.Vty" +-- As a small example, the following program demonstrates the use of Vty +-- on a Unix system using the @vty-unix@ package: -- --- 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) --- @ +-- > import Graphics.Vty +-- > import Graphics.Vty.Platform.Unix (mkVty) +-- > +-- > main = do +-- > vty <- mkVty defaultConfig +-- > 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) +-- +-- Vty uses threads internally, so programs made with Vty must be +-- compiled with the threaded runtime using the GHC @-threaded@ option. module Graphics.Vty ( Vty(..) - , mkVty , setWindowTitle - , Mode(..) + , installCustomWidthTable + , mkVtyFromPair , module Graphics.Vty.Config , module Graphics.Vty.Input + , module Graphics.Vty.Input.Events , module Graphics.Vty.Output - , module Graphics.Vty.Output.Interface , module Graphics.Vty.Picture , module Graphics.Vty.Image , module Graphics.Vty.Attributes @@ -50,16 +56,12 @@ import Graphics.Vty.Input import Graphics.Vty.Input.Events import Graphics.Vty.Output -import Graphics.Vty.Output.Interface import Graphics.Vty.Picture import Graphics.Vty.Image import Graphics.Vty.Attributes import Graphics.Vty.UnicodeWidthTable.IO import Graphics.Vty.UnicodeWidthTable.Install -import Data.Char (isPrint, showLitChar) -import qualified Data.ByteString.Char8 as BS8 - import qualified Control.Exception as E import Control.Monad (when) import Control.Concurrent.STM @@ -69,26 +71,28 @@ import Data.Semigroup ((<>)) #endif --- | A Vty value represents a handle to the Vty library that the +-- | A 'Vty' value represents a handle to the Vty library that the -- application must create in order to use Vty. -- --- The use of Vty typically follows this process: +-- The use of this library typically follows this process: -- --- 1. Initialize vty with 'mkVty' (this takes control of the terminal). +-- 1. Initialize Vty with the 'mkVty' implementation for your +-- platform's Vty package (e.g. @vty-unix@), or, more generically, with +-- 'mkVtyFromPair'. This takes control of (and sets up) the terminal. -- --- 2. Use 'update' to display a picture. +-- 2. Use 'update' to display a picture. -- --- 3. Use 'nextEvent' to get the next input event. +-- 3. Use 'nextEvent' to get the next input event. -- --- 4. Depending on the event, go to 2 or 5. +-- 4. Depending on the event, go to 2 or 5. -- --- 5. Shutdown vty and restore the terminal state with 'shutdown'. At --- this point the 'Vty' handle cannot be used again. +-- 5. Shutdown Vty and restore the terminal state with 'shutdown'. At +-- this point the 'Vty' handle cannot be used again. -- -- Operations on Vty handles are not thread-safe. data Vty = Vty { update :: Picture -> IO () - -- ^ Outputs the given 'Picture'. + -- ^ Output the given 'Picture' to the terminal. , nextEvent :: IO Event -- ^ Return the next 'Event' or block until one becomes -- available. @@ -110,41 +114,42 @@ , isShutdown :: IO Bool } --- | Create a Vty handle. At most one handle should be created at a time --- for a given terminal device. --- --- The specified configuration is added to the the configuration --- loaded by 'userConfig' with the 'userConfig' configuration taking --- precedence. See "Graphics.Vty.Config". +-- | Attempt to load and install a custom character width table into +-- this process. -- --- For most applications @mkVty defaultConfig@ is sufficient. -mkVty :: Config -> IO Vty -mkVty appConfig = do - config <- (<> appConfig) <$> userConfig - - when (allowCustomUnicodeWidthTables config /= Just False) $ - installCustomWidthTable config - - input <- inputForConfig config - out <- outputForConfig config - internalMkVty input out - -installCustomWidthTable :: Config -> IO () -installCustomWidthTable c = do - let doLog s = case debugLog c of - Nothing -> return () - Just path -> appendFile path $ "installWidthTable: " <> s <> "\n" +-- This looks up the specified terminal name in the specified width +-- table map and, if a map file path is found, the map is loaded and +-- installed. This is exposed for Vty platform package implementors; +-- application developers should never need to call this. +installCustomWidthTable :: Maybe FilePath + -- ^ Optional path to a log file where log + -- messages should be written when attempting to + -- load a width table. + -> Maybe String + -- ^ Optional width table entry name (usually + -- the terminal name, e.g. value of @TERM@ on + -- Unix systems). If omitted, this function does + -- not attempt to load a table. + -> [(String, FilePath)] + -- ^ Mapping from width table entry names to + -- width table file paths. This is usually + -- obtained from 'configTermWidthMaps' of + -- 'VtyUserConfig'. + -> IO () +installCustomWidthTable logPath tblName widthMaps = do + let doLog s = case logPath of + Nothing -> return () + Just path -> appendFile path $ "installWidthTable: " <> s <> "\n" customInstalled <- isCustomTableReady when (not customInstalled) $ do - mTerm <- currentTerminalName - case mTerm of + case tblName of Nothing -> - doLog "No current terminal name available" - Just currentTerm -> - case lookup currentTerm (termWidthMaps c) of + doLog "No terminal name given in the configuration, skipping load" + Just name -> + case lookup name widthMaps of Nothing -> - doLog "Current terminal not found in custom character width mapping list" + doLog $ "Width table " <> show name <> " not found in custom character width mapping list" Just path -> do tableResult <- E.try $ readUnicodeWidthTable path case tableResult of @@ -164,8 +169,13 @@ doLog $ "Successfully installed Unicode width table " <> " from " <> show path -internalMkVty :: Input -> Output -> IO Vty -internalMkVty input out = do +-- | Build a 'Vty' handle from an input/output pair. +-- +-- This is exposed for Vty platform package implementors; application +-- developers should never need to call this, and should instead call +-- @mkVty@ or equivalent from their platform package of choice. +mkVtyFromPair :: Input -> Output -> IO Vty +mkVtyFromPair input out = do reserveDisplay out shutdownVar <- newTVarIO False @@ -176,7 +186,7 @@ releaseDisplay out releaseTerminal out - let shutdownStatus = readTVarIO shutdownVar + shutdownStatus = readTVarIO shutdownVar lastPicRef <- newIORef Nothing lastUpdateRef <- newIORef Nothing @@ -201,7 +211,7 @@ writeIORef lastUpdateRef $ Just updateData writeIORef lastPicRef $ Just inPic - let innerRefresh = do + innerRefresh = do writeIORef lastUpdateRef Nothing bounds <- displayBounds out dc <- displayContext out bounds @@ -209,16 +219,16 @@ mPic <- readIORef lastPicRef maybe (return ()) innerUpdate mPic - let mkResize = uncurry EvResize <$> displayBounds out + mkResize = uncurry EvResize <$> displayBounds out - translateInternalEvent ResumeAfterSignal = mkResize - translateInternalEvent (InputEvent e) = return e + translateInternalEvent ResumeAfterInterrupt = mkResize + translateInternalEvent (InputEvent e) = return e gkey = do - e <- atomically $ readTChan $ _eventChannel input + e <- atomically $ readTChan $ eventChannel input translateInternalEvent e gkey' = do - mEv <- atomically $ tryReadTChan $ _eventChannel input + mEv <- atomically $ tryReadTChan $ eventChannel input case mEv of Just e -> Just <$> translateInternalEvent e Nothing -> return Nothing @@ -234,22 +244,6 @@ } -- | Set the terminal window title string. --- --- This function emits an Xterm-compatible escape sequence that we --- anticipate will work for essentially all modern terminal emulators. --- Ideally we'd use a terminal capability for this, but there does not --- seem to exist a termcap for setting window titles. If you find that --- this function does not work for a given terminal emulator, please --- report the issue. --- --- For details, see: --- --- https://tldp.org/HOWTO/Xterm-Title-3.html setWindowTitle :: Vty -> String -> IO () -setWindowTitle vty title = do - let sanitize :: String -> String - sanitize = concatMap sanitizeChar - sanitizeChar c | not (isPrint c) = showLitChar c "" - | otherwise = [c] - let buf = BS8.pack $ "\ESC]2;" <> sanitize title <> "\007" - outputByteBuffer (outputIface vty) buf +setWindowTitle vty title = + setOutputWindowTitle (outputIface vty) title diff --git a/src/Graphics/Vty/Attributes/Color.hs b/src/Graphics/Vty/Attributes/Color.hs --- a/src/Graphics/Vty/Attributes/Color.hs +++ b/src/Graphics/Vty/Attributes/Color.hs @@ -7,9 +7,6 @@ ( Color(..) , ColorMode(..) - -- * Detecting Terminal Color Support - , detectColorMode - -- ** Fixed Colors -- | Standard 8-color ANSI terminal color codes. -- @@ -49,12 +46,7 @@ import Data.Word import GHC.Generics import Control.DeepSeq -import System.Environment (lookupEnv) -import qualified System.Console.Terminfo as Terminfo -import Control.Exception (catch) -import Data.Maybe - import Graphics.Vty.Attributes.Color240 -- | Abstract data type representing a color. @@ -72,21 +64,21 @@ -- -- The 8 ISO 6429 (ANSI) colors are as follows: -- --- 0. black +-- * black (0) -- --- 1. red +-- * red (1) -- --- 2. green +-- * green (2) -- --- 3. yellow +-- * yellow (3) -- --- 4. blue +-- * blue (4) -- --- 5. magenta +-- * magenta (5) -- --- 6. cyan +-- * cyan (6) -- --- 7. white +-- * white (7) -- -- The mapping from points in the 240 color palette to colors actually -- displayable by the terminal depends on the number of colors the @@ -118,23 +110,7 @@ | ColorMode16 | ColorMode240 !Word8 | FullColor - deriving ( Eq, Show ) - -detectColorMode :: String -> IO ColorMode -detectColorMode termName' = do - term <- catch (Just <$> Terminfo.setupTerm termName') - (\(_ :: Terminfo.SetupTermError) -> return Nothing) - let getCap cap = term >>= \t -> Terminfo.getCapability t cap - termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors") - colorterm <- lookupEnv "COLORTERM" - return $ if - | termColors < 8 -> NoColor - | termColors < 16 -> ColorMode8 - | termColors == 16 -> ColorMode16 - | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16) - | colorterm == Just "truecolor" -> FullColor - | colorterm == Just "24bit" -> FullColor - | otherwise -> ColorMode240 240 + deriving ( Eq, Show, Read ) black, red, green, yellow, blue, magenta, cyan, white :: Color black = ISOColor 0 @@ -157,6 +133,10 @@ brightCyan = ISOColor 14 brightWhite = ISOColor 15 +-- | Create a color value from RGB values in the 0..255 range inclusive. +-- No transformation of the input values is done; a color is created +-- directly from the RGB values specified, unlike the 'srgbColor' and +-- 'color240' functions. linearColor :: Integral i => i -> i -> i -> Color linearColor r g b = RGBColor r' g' b' where @@ -165,11 +145,12 @@ b' = fromIntegral (clamp b) :: Word8 clamp = min 255 . max 0 +-- | Given RGB values in the range 0..255 inclusive, create a color +-- using the sRGB transformation described at +-- +-- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation srgbColor :: Integral i => i -> i -> i -> Color srgbColor r g b = - -- srgb to rgb transformation as described at - -- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation - -- -- TODO: it may be worth translating this to a lookup table, as with color240 let shrink n = fromIntegral n / 255 :: Double -- called gamma^-1 in wiki @@ -185,7 +166,8 @@ color240 r g b = Color240 (rgbColorToColor240 r g b) -- | Create a Vty 'Color' (in the 240 color set) from an RGB triple. --- This function is lossy in the sense that we only internally support 240 colors but the --- #RRGGBB format supports 16^3 colors. +-- This is a synonym for 'color240'. This function is lossy in the sense +-- that we only internally support 240 colors but the #RRGGBB format +-- supports 256^3 colors. rgbColor :: Integral i => i -> i -> i -> Color rgbColor = color240 diff --git a/src/Graphics/Vty/Attributes/Color240.hs b/src/Graphics/Vty/Attributes/Color240.hs --- a/src/Graphics/Vty/Attributes/Color240.hs +++ b/src/Graphics/Vty/Attributes/Color240.hs @@ -11,7 +11,10 @@ -- Note: rgbColor's mapping from RGB to 240 colors was generated from -- 256colres.pl which is forked from xterm 256colres.pl. --- | Create a value in the Color240 set from an RGB triple +-- | Create a value in the Color240 set from an RGB triple. This maps +-- the input arguments to an entry in the 240-color palette depicted at: +-- +-- https://rich.readthedocs.io/en/stable/appendix/colors.html rgbColorToColor240 :: Integral i => i -> i -> i -> Word8 rgbColorToColor240 r g b | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity" diff --git a/src/Graphics/Vty/Config.hs b/src/Graphics/Vty/Config.hs --- a/src/Graphics/Vty/Config.hs +++ b/src/Graphics/Vty/Config.hs @@ -1,18 +1,29 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase, MultiWayIf #-} --- | Vty supports a configuration file format and associated 'Config' --- data type. The 'Config' can be provided to 'mkVty' to customize the +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Vty supports a configuration file format and provides a +-- corresponding 'VtyUserConfig' data type. The 'VtyUserConfig' can be +-- provided to platform packages' @mkVty@ functions to customize the -- application's use of Vty. -- --- Lines in config files that fail to parse are ignored. Later entries --- take precedence over earlier ones. --- -- = Debug -- +-- == @colorMode@ +-- +-- Format: +-- +-- @ +-- colorMode \"|FullColor>\" +-- @ +-- +-- The preferred color mode to use, chosen from the constructors of the +-- 'ColorMode' type. If absent, the backend driver may detect and choose +-- an appropriate color mode. Implementor's note: backend packages +-- should respect this setting when it is present even when their +-- detection indicates that a different color mode should be used. +-- -- == @debugLog@ -- -- Format: @@ -73,27 +84,23 @@ -- widthMap \"xterm\" \"\/home\/user\/.vty\/xterm\_map.dat\" -- @ -- --- This directive specifies the path to a Unicode character width --- map (the second argument) that should be loaded and used when --- the value of TERM matches the first argument. Unicode character --- width maps can be produced either by running the provided binary --- @vty-build-width-table@ or by calling the library routine --- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. The --- 'Graphics.Vty.mkVty' function will use these configuration settings --- to attempt to load and install the specified width map. See the --- documentation for 'Graphics.Vty.mkVty' for details. +-- This directive specifies the path to a Unicode character +-- width map (the second argument) that should correspond to +-- the terminal named by first argument. Unicode character +-- width maps can be produced either by running platform +-- packages' width table tools or by calling the library routine +-- 'Graphics.Vty.UnicodeWidthTable.Query.buildUnicodeWidthTable'. Vty +-- platform packages should use these configuration settings to attempt +-- to load and install the specified width map. module Graphics.Vty.Config ( InputMap - , Config(..) - , VtyConfigurationError(..) + , VtyUserConfig(..) , userConfig , overrideEnvConfig - , standardIOConfig + , currentTerminalName , runParseConfig , parseConfigFile , defaultConfig - , getTtyEraseChar - , currentTerminalName , vtyConfigPath , widthTableFilename @@ -110,7 +117,7 @@ import Control.Applicative hiding (many) -import Control.Exception (catch, IOException, Exception(..), throwIO) +import Control.Exception (catch, IOException) import Control.Monad (liftM, guard, void) import qualified Data.ByteString as BS @@ -120,10 +127,10 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif -import Data.Typeable (Typeable) +import Text.Read (readMaybe) +import Graphics.Vty.Attributes.Color (ColorMode(..)) import Graphics.Vty.Input.Events -import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode) import GHC.Generics @@ -132,111 +139,73 @@ ) import System.Environment (lookupEnv) import System.FilePath ((), takeDirectory) -import System.Posix.IO (stdInput, stdOutput) -import System.Posix.Types (Fd(..)) -import Foreign.C.Types (CInt(..), CChar(..)) import Text.Parsec hiding ((<|>)) import Text.Parsec.Token ( GenLanguageDef(..) ) import qualified Text.Parsec.Token as P --- | Type of errors that can be thrown when configuring VTY -data VtyConfigurationError = - VtyMissingTermEnvVar - -- ^ TERM environment variable not set - deriving (Show, Eq, Typeable) - -instance Exception VtyConfigurationError where - displayException VtyMissingTermEnvVar = "TERM environment variable not set" - -- | 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)] --- | A Vty configuration. -data Config = - Config { vmin :: Maybe Int - -- ^ The default is 1 character. - , vtime :: Maybe Int - -- ^ The default is 100 milliseconds, 0.1 seconds. - , mouseMode :: Maybe Bool - -- ^ The default is False. - , bracketedPasteMode :: Maybe Bool - -- ^ The default is False. - , debugLog :: Maybe FilePath - -- ^ Debug information is appended to this file if not - -- Nothing. - , inputMap :: InputMap - -- ^ 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. - , inputFd :: Maybe Fd - -- ^ The input file descriptor to use. The default is - -- 'System.Posix.IO.stdInput' - , outputFd :: Maybe Fd - -- ^ The output file descriptor to use. The default is - -- 'System.Posix.IO.stdOutput' - , termName :: Maybe String - -- ^ The terminal name used to look up terminfo capabilities. - -- The default is the value of the TERM environment variable. - , termWidthMaps :: [(String, FilePath)] - -- ^ Terminal width map files. - , allowCustomUnicodeWidthTables :: Maybe Bool - -- ^ Whether to permit custom Unicode width table loading by - -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that - -- table loading should not be performed. Other values permit - -- table loading. - -- - -- If a table load is attempted and fails, information - -- about the failure will be logged to the debug log if the - -- configuration specifies one. If no custom table is loaded - -- (or if a load fails), the built-in character width table - -- will be used. - , colorMode :: Maybe ColorMode - -- ^ The color mode used to know how many colors the terminal - -- supports. - } - deriving (Show, Eq) +-- | A Vty core library configuration. Platform-specific details are not +-- included in the VtyUserConfig. +data VtyUserConfig = + VtyUserConfig { configDebugLog :: Maybe FilePath + -- ^ Debug information is appended to this file if not + -- Nothing. + , configInputMap :: InputMap + -- ^ 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. + , configTermWidthMaps :: [(String, FilePath)] + -- ^ Terminal width map files. + , configAllowCustomUnicodeWidthTables :: Maybe Bool + -- ^ Whether to permit custom Unicode width table loading by + -- 'Graphics.Vty.mkVty'. @'Just' 'False'@ indicates that + -- table loading should not be performed. Other values permit + -- table loading. + -- + -- If a table load is attempted and fails, information + -- about the failure will be logged to the debug log if the + -- configuration specifies one. If no custom table is loaded + -- (or if a load fails), the built-in character width table + -- will be used. + , configPreferredColorMode :: Maybe ColorMode + -- ^ Preferred color mode. If set, this should + -- override platform color mode detection. + } + deriving (Show, Eq) -defaultConfig :: Config +defaultConfig :: VtyUserConfig defaultConfig = mempty -instance Semigroup Config where +instance Semigroup VtyUserConfig where c0 <> c1 = -- latter config takes priority for everything but inputMap - Config { vmin = vmin c1 <|> vmin c0 - , vtime = vtime c1 <|> vtime c0 - , mouseMode = mouseMode c1 - , bracketedPasteMode = bracketedPasteMode c1 - , 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 - , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0 - , allowCustomUnicodeWidthTables = - allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0 - , colorMode = colorMode c1 <|> colorMode c0 - } + VtyUserConfig { configDebugLog = + configDebugLog c1 <|> configDebugLog c0 + , configInputMap = + configInputMap c0 <> configInputMap c1 + , configTermWidthMaps = + configTermWidthMaps c1 <|> configTermWidthMaps c0 + , configAllowCustomUnicodeWidthTables = + configAllowCustomUnicodeWidthTables c1 <|> configAllowCustomUnicodeWidthTables c0 + , configPreferredColorMode = + configPreferredColorMode c1 <|> configPreferredColorMode c0 + } -instance Monoid Config where +instance Monoid VtyUserConfig where mempty = - Config { vmin = Nothing - , vtime = Nothing - , mouseMode = Nothing - , bracketedPasteMode = Nothing - , debugLog = mempty - , inputMap = mempty - , inputFd = Nothing - , outputFd = Nothing - , termName = Nothing - , termWidthMaps = [] - , allowCustomUnicodeWidthTables = Nothing - , colorMode = Nothing - } + VtyUserConfig { configDebugLog = mempty + , configInputMap = mempty + , configTermWidthMaps = [] + , configAllowCustomUnicodeWidthTables = Nothing + , configPreferredColorMode = Nothing + } #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif @@ -253,7 +222,8 @@ vtyConfigFileEnvName = "VTY_CONFIG_FILE" -- | Load a configuration from 'vtyConfigPath' and @$VTY_CONFIG_FILE@. -userConfig :: IO Config +-- If none is found, build a default configuration. +userConfig :: IO VtyUserConfig userConfig = do configFile <- vtyConfigPath >>= parseConfigFile overrideConfig <- maybe (return defaultConfig) parseConfigFile =<< @@ -279,37 +249,21 @@ Just term -> do return $ Just $ dataDir widthTableFilename term -overrideEnvConfig :: IO Config +overrideEnvConfig :: IO VtyUserConfig overrideEnvConfig = do d <- lookupEnv "VTY_DEBUG_LOG" - return $ defaultConfig { debugLog = d } - --- | Configures VTY using defaults suitable for terminals. This function --- can raise 'VtyConfigurationError'. -standardIOConfig :: IO Config -standardIOConfig = do - mb <- lookupEnv termVariable - case mb of - Nothing -> throwIO VtyMissingTermEnvVar - Just t -> do - mcolorMode <- detectColorMode t - return defaultConfig - { vmin = Just 1 - , mouseMode = Just False - , bracketedPasteMode = Just False - , vtime = Just 100 - , inputFd = Just stdInput - , outputFd = Just stdOutput - , termName = Just t - , colorMode = Just mcolorMode - } + return $ defaultConfig { configDebugLog = d } -parseConfigFile :: FilePath -> IO Config +-- | Parse a Vty configuration file. +-- +-- Lines in config files that fail to parse are ignored. Later entries +-- take precedence over earlier ones. +parseConfigFile :: FilePath -> IO VtyUserConfig parseConfigFile path = do catch (runParseConfig path <$> BS.readFile path) (\(_ :: IOException) -> return defaultConfig) -runParseConfig :: String -> BS.ByteString -> Config +runParseConfig :: String -> BS.ByteString -> VtyUserConfig runParseConfig name cfgTxt = case runParser parseConfig () name cfgTxt of Right cfg -> cfg @@ -337,7 +291,7 @@ configLexer :: Monad m => P.GenTokenParser BS.ByteString () m configLexer = P.makeTokenParser configLanguage -mapDecl :: Parser Config +mapDecl :: Parser VtyUserConfig mapDecl = do "map" <- P.identifier configLexer termIdent <- (char '_' >> P.whiteSpace configLexer >> return Nothing) @@ -345,28 +299,34 @@ bytes <- P.stringLiteral configLexer key <- parseValue modifiers <- parseValue - return defaultConfig { inputMap = [(termIdent, bytes, EvKey key modifiers)] } + return defaultConfig { configInputMap = [(termIdent, bytes, EvKey key modifiers)] } -debugLogDecl :: Parser Config +debugLogDecl :: Parser VtyUserConfig debugLogDecl = do "debugLog" <- P.identifier configLexer path <- P.stringLiteral configLexer - return defaultConfig { debugLog = Just path } + return defaultConfig { configDebugLog = Just path } -widthMapDecl :: Parser Config +colorModeDecl :: Parser VtyUserConfig +colorModeDecl = do + "colorMode" <- P.identifier configLexer + mode <- P.stringLiteral configLexer + return defaultConfig { configPreferredColorMode = readMaybe mode } + +widthMapDecl :: Parser VtyUserConfig widthMapDecl = do "widthMap" <- P.identifier configLexer tName <- P.stringLiteral configLexer path <- P.stringLiteral configLexer - return defaultConfig { termWidthMaps = [(tName, path)] } + return defaultConfig { configTermWidthMaps = [(tName, path)] } ignoreLine :: Parser () ignoreLine = void $ manyTill anyChar newline -parseConfig :: Parser Config +parseConfig :: Parser VtyUserConfig parseConfig = liftM mconcat $ many $ do P.whiteSpace configLexer - let directives = [try mapDecl, try debugLogDecl, try widthMapDecl] + let directives = [try mapDecl, try debugLogDecl, try widthMapDecl, try colorModeDecl] choice directives <|> (ignoreLine >> return defaultConfig) class Parse a where parseValue :: Parser a @@ -413,32 +373,22 @@ instance GParseAlts V1 where gparseAlts _ = fail "GParse: V1" -foreign import ccall "vty_get_tty_erase" cGetTtyErase :: Fd -> IO CChar - --- | Get the "erase" character for the terminal attached to the --- specified file descriptor. This is the character configured by 'stty --- erase'. If the call to 'tcgetattr' fails, this will return 'Nothing'. --- Otherwise it will return the character that has been configured to --- indicate the canonical mode ERASE behavior. That character can then --- be added to the table of strings that we interpret to mean Backspace. --- --- For more details, see: --- --- * https://www.gnu.org/software/libc/manual/html_node/Canonical-or-Not.html --- * https://www.gsp.com/cgi-bin/man.cgi?section=1&topic=stty --- * https://github.com/matterhorn-chat/matterhorn/issues/565 -getTtyEraseChar :: Fd -> IO (Maybe Char) -getTtyEraseChar fd = do - c <- cGetTtyErase fd - if c /= 0 - then return $ Just $ toEnum $ fromEnum c - else return Nothing - +-- | The result of a configuration change attempt made by +-- 'addConfigWidthMap'. data ConfigUpdateResult = ConfigurationCreated + -- ^ A new configuration file file was written with the new width + -- table entry. | ConfigurationModified + -- ^ An existing configuration file was modified with the new width + -- table entry. | ConfigurationConflict String + -- ^ The attempted width table entry could not be written to the + -- configuration due to a conflict; the argument here is the width + -- table file path for the conflicting entry. | ConfigurationRedundant + -- ^ No change was made because the existing configuration already + -- contains the specified mapping. deriving (Eq, Show) -- | Add a @widthMap@ directive to the Vty configuration file at the @@ -452,8 +402,8 @@ -- If the configuration path does not exist, a new configuration file -- will be created and any directories in the path will also be created. -- --- This returns @True@ if the configuration was created or modified and --- @False@ otherwise. This does not handle exceptions raised by file or +-- This returns a 'ConfigUpdateResult' indicating the change to the +-- configuration. This does not handle exceptions raised by file or -- directory permissions issues. addConfigWidthMap :: FilePath -- ^ The configuration file path of the configuration @@ -479,9 +429,9 @@ updateConfig = do config <- parseConfigFile configPath - if (term, tablePath) `elem` termWidthMaps config + if (term, tablePath) `elem` configTermWidthMaps config then return ConfigurationRedundant - else case lookup term (termWidthMaps config) of + else case lookup term (configTermWidthMaps config) of Just other -> return $ ConfigurationConflict other Nothing -> do appendFile configPath directive diff --git a/src/Graphics/Vty/Debug.hs b/src/Graphics/Vty/Debug.hs --- a/src/Graphics/Vty/Debug.hs +++ b/src/Graphics/Vty/Debug.hs @@ -1,13 +1,18 @@ -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Debug - ( module Graphics.Vty.Debug - , module Graphics.Vty.Debug.Image + ( MockWindow(..) + , SpanConstructLog + , regionForWindow + , allSpansHaveWidth + , spanOpsAffectedColumns + , spanOpsAffectedRows + , rowOpsAffectedColumns + , isSetAttr ) where import Graphics.Vty.Attributes import Graphics.Vty.Image (DisplayRegion) -import Graphics.Vty.Debug.Image import Graphics.Vty.Span import qualified Data.Vector as Vector diff --git a/src/Graphics/Vty/Debug/Image.hs b/src/Graphics/Vty/Debug/Image.hs deleted file mode 100644 --- a/src/Graphics/Vty/Debug/Image.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# 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 diff --git a/src/Graphics/Vty/DisplayAttributes.hs b/src/Graphics/Vty/DisplayAttributes.hs --- a/src/Graphics/Vty/DisplayAttributes.hs +++ b/src/Graphics/Vty/DisplayAttributes.hs @@ -2,7 +2,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -module Graphics.Vty.DisplayAttributes where +module Graphics.Vty.DisplayAttributes + ( DisplayAttrDiff(..) + , StyleStateChange(..) + , DisplayColorDiff(..) + , URLDiff(..) + , fixDisplayAttr + , displayAttrDiffs + ) +where import Graphics.Vty.Attributes diff --git a/src/Graphics/Vty/Error.hs b/src/Graphics/Vty/Error.hs --- a/src/Graphics/Vty/Error.hs +++ b/src/Graphics/Vty/Error.hs @@ -1,4 +1,7 @@ -module Graphics.Vty.Error where +module Graphics.Vty.Error + ( VtyException(..) + ) +where -- | The type of exceptions specific to vty. -- diff --git a/src/Graphics/Vty/Image.hs b/src/Graphics/Vty/Image.hs --- a/src/Graphics/Vty/Image.hs +++ b/src/Graphics/Vty/Image.hs @@ -52,7 +52,6 @@ , wctwidth , wctlwidth -- * Display Regions - , DisplayText , DisplayRegion , regionWidth , regionHeight @@ -258,7 +257,7 @@ translateX :: Int -> Image -> Image translateX x i | x < 0 && (abs x > imageWidth i) = emptyImage - | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i) + | x < 0 = cropLeft (imageWidth i + x) i | x == 0 = i | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h @@ -266,7 +265,7 @@ translateY :: Int -> Image -> Image translateY y i | y < 0 && (abs y > imageHeight i) = emptyImage - | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s) + | y < 0 = cropTop (imageHeight i + y) i | y == 0 = i | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y) @@ -296,12 +295,11 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropBottom {croppedImage, outputWidth, outputHeight}) - | outputHeight <= h = i - | otherwise = CropBottom croppedImage outputWidth h + go i@(Crop {outputHeight}) + = i {outputHeight = min h outputHeight} go i | h >= imageHeight i = i - | otherwise = CropBottom i (imageWidth i) h + | otherwise = Crop i 0 0 (imageWidth i) h -- | Crop an image's width. If the image's width is less than or equal -- to the specified width then this operation has no effect. Otherwise @@ -313,12 +311,11 @@ | otherwise = go inI where go EmptyImage = EmptyImage - go i@(CropRight {croppedImage, outputWidth, outputHeight}) - | outputWidth <= w = i - | otherwise = CropRight croppedImage w outputHeight + go i@(Crop {outputWidth}) + = i {outputWidth = min w outputWidth} go i | w >= imageWidth i = i - | otherwise = CropRight i w (imageHeight i) + | otherwise = Crop i 0 0 w (imageHeight i) -- | Crop an image's width. If the image's width is less than or equal -- to the specified width then this operation has no effect. Otherwise @@ -330,14 +327,13 @@ | 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@(Crop {leftSkip, outputWidth}) = + let delta = max 0 (outputWidth - w) + in i { leftSkip = leftSkip + delta + , outputWidth = outputWidth - delta } go i | imageWidth i <= w = i - | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i) + | otherwise = Crop i (imageWidth i - w) 0 w (imageHeight i) -- | Crop an image's height. If the image's height is less than or equal -- to the specified height then this operation has no effect. Otherwise @@ -349,14 +345,13 @@ | 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@(Crop {topSkip, outputHeight}) = + let delta = max 0 (outputHeight - h) + in i { topSkip = topSkip + delta + , outputHeight = outputHeight - delta } go i | imageHeight i <= h = i - | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h + | otherwise = Crop i 0 (imageHeight i - h) (imageWidth i) h -- | Generic resize. Pads and crops are added to ensure that the -- resulting image matches the specified dimensions. This is biased to diff --git a/src/Graphics/Vty/Image/Internal.hs b/src/Graphics/Vty/Image/Internal.hs --- a/src/Graphics/Vty/Image/Internal.hs +++ b/src/Graphics/Vty/Image/Internal.hs @@ -3,8 +3,18 @@ {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_HADDOCK hide #-} -module Graphics.Vty.Image.Internal where +module Graphics.Vty.Image.Internal + ( Image(..) + , imageHeight + , imageWidth + , horizJoin + , vertJoin + , ppImageStructure + , clipText + ) +where + import Graphics.Vty.Attributes import Graphics.Text.Width @@ -17,10 +27,7 @@ #endif import qualified Data.Text.Lazy as TL --- | A display text is a Data.Text.Lazy -type DisplayText = TL.Text - -clipText :: DisplayText -> Int -> Int -> DisplayText +clipText :: TL.Text -> Int -> Int -> TL.Text clipText txt leftSkip rightClip = -- CPS would clarify this I think let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0 @@ -57,7 +64,7 @@ { attr :: Attr -- | The text to display. The display width of the text is always -- outputWidth. - , displayText :: DisplayText + , displayText :: TL.Text -- | The number of display columns for the text. , outputWidth :: Int -- | the number of characters in the text. @@ -96,42 +103,12 @@ { 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 + -- | Crop an image + | Crop { 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 @@ -159,26 +136,14 @@ = "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" + pp i (Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight}) + = "Crop(" ++ show leftSkip ++ "," ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ 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 (Crop i x y w h) = i `deepseq` x `seq` y `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` () @@ -191,10 +156,7 @@ 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 Crop { outputWidth = w } = w imageWidth EmptyImage = 0 -- | The height of an Image. This is the number of display rows the @@ -204,10 +166,7 @@ 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 Crop { outputHeight = h } = h imageHeight EmptyImage = 0 -- | Append in the 'Semigroup' instance is equivalent to '<->'. diff --git a/src/Graphics/Vty/Inline.hs b/src/Graphics/Vty/Inline.hs --- a/src/Graphics/Vty/Inline.hs +++ b/src/Graphics/Vty/Inline.hs @@ -29,13 +29,11 @@ -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Inline ( module Graphics.Vty.Inline - , withVty ) where import Graphics.Vty import Graphics.Vty.DisplayAttributes -import Graphics.Vty.Inline.Unsafe import Blaze.ByteString.Builder (writeToByteString) @@ -119,8 +117,8 @@ -- output device. -- -- This will flush the terminal output. -putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m () -putAttrChange_ c = liftIO $ withOutput $ \out -> do +putAttrChange_ :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m () +putAttrChange_ out c = liftIO $ do hFlush stdout putAttrChange out c hFlush stdout diff --git a/src/Graphics/Vty/Inline/Unsafe.hs b/src/Graphics/Vty/Inline/Unsafe.hs deleted file mode 100644 --- a/src/Graphics/Vty/Inline/Unsafe.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -module Graphics.Vty.Inline.Unsafe where - -import Graphics.Vty - -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) - -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 $ defaultConfig { 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 diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs --- a/src/Graphics/Vty/Input.hs +++ b/src/Graphics/Vty/Input.hs @@ -1,176 +1,32 @@ -{-# LANGUAGE RecordWildCards, CPP #-} - --- | This module provides the input layer for Vty, including methods --- for initializing an 'Input' structure and reading 'Event's from the --- terminal. --- --- Note that due to the evolution of terminal emulators, some keys --- and combinations will not reliably map to the expected events by --- any terminal program. 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. --- --- = VTY's Implementation --- --- There are two input modes: --- --- 1. 7-bit --- --- 2. 8-bit --- --- The 7-bit input mode is the default and the expected mode 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 7-bit input. Historically 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. For --- example, --- --- * Control-I is 'i', `01101001`, and 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 is `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 which is useless --- for terminal emulators. Some terminal emulators support an 8-bit --- input encoding. While this provides some advantages, the actual usage --- is low. Most systems use 7-bit mode but recognize 8-bit 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@ event from a --- control key, the timing of the input is used. --- --- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of --- 'VMIN' milliseconds. --- --- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte --- is followed by more bytes read within 'VMIN' milliseconds. 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. --- --- == Unicode Input and Escaped Control Key Sequences --- --- The input encoding determines how UTF-8 encoded characters are --- recognized. --- --- * 7-bit mode: UTF-8 can be input unambiguously. 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 and 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 fundamental 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. This would be a --- reasonable option for Vty if everybody used the linux kernel console --- but for obvious reasons this is not possible. --- --- The "Graphics.Vty.Config" module 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. --- --- == See also --- --- * http://www.leonerd.org.uk/hacks/fixterms/ +-- | This module provides the input abstraction for Vty. module Graphics.Vty.Input - ( Key(..) - , Modifier(..) - , Button(..) - , Event(..) - , Input(..) - , inputForConfig + ( Input(..) + , module Graphics.Vty.Input.Events ) 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 Lens.Micro - -import qualified System.Console.Terminfo as Terminfo -import System.Posix.Signals.Exts - -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif - --- | Set up the terminal with file descriptor `inputFd` for input. --- Returns an '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 the configuration's 'inputMap'. --- --- The terminal device's mode flags are configured by the --- 'attributeControl' function. -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 - setAttrs - atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal - _ <- installHandler windowChange pokeIO Nothing - _ <- installHandler continueProcess pokeIO Nothing - - let restore = unsetAttrs +import Control.Concurrent.STM (TChan) - return $ input - { shutdownInput = do - shutdownInput input - _ <- installHandler windowChange Ignore Nothing - _ <- installHandler continueProcess Ignore Nothing - restore - , restoreInputState = restoreInputState input >> restore - } -inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig +-- | The library's input-processing abstraction. Platform-specific +-- implementations must implement an 'Input' and provide it to +-- 'Graphics.Vty.mkVtyFromPair'. +data Input = + Input { eventChannel :: TChan InternalEvent + -- ^ A channel of events generated by input processing. The + -- input implementation must write its input events to this + -- channel; the Vty event loop will read from this channel + -- and provide the events to the user's application via + -- 'nextEvent'. + , shutdownInput :: IO () + -- ^ Shut down the input processing. As part of shutting down + -- the input, this should also restore the input state if + -- appropriate. + , restoreInputState :: IO () + -- ^ Restore the terminal's input state to what it was prior + -- to configuring the input for Vty. This should be done as + -- part of 'shutdownInput' but is exposed in case it needs to + -- be used directly. + , inputLogMsg :: String -> IO () + -- ^ Log the specified message. + } diff --git a/src/Graphics/Vty/Input/Classify.hs b/src/Graphics/Vty/Input/Classify.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Classify.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} --- This makes a kind of trie. Has space efficiency issues with large --- input blocks. Likely building a parser and just applying that would --- be better. -module Graphics.Vty.Input.Classify - ( classify - , KClass(..) - , ClassifierState(..) - ) -where - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Mouse -import Graphics.Vty.Input.Focus -import Graphics.Vty.Input.Paste -import Graphics.Vty.Input.Classify.Types - -import Codec.Binary.UTF8.Generic (decode) - -import Control.Arrow (first) -import qualified Data.Map as M( fromList, lookup ) -import Data.Maybe ( mapMaybe ) -import qualified Data.Set as S( fromList, member ) - -import Data.Word - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import Data.ByteString.Char8 (ByteString) - --- | Whether the classifier is currently processing a chunked format. --- Currently, only bracketed pastes use this. -data ClassifierState - = ClassifierStart - -- ^ Not processing a chunked format. - | ClassifierInChunk ByteString [ByteString] - -- ^ Currently processing a chunked format. The initial chunk is in the - -- first argument and a reversed remainder of the chunks is collected in - -- the second argument. At the end of the processing, the chunks are - -- reversed and concatenated with the final chunk. - -compile :: ClassifyMap -> ByteString -> KClass -compile table = cl' where - -- take all prefixes and create a set of these - prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table - maxValidInputLength = maximum (map (length . fst) table) - eventForInput = M.fromList $ map (first BS8.pack) table - cl' inputBlock | BS8.null inputBlock = 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 BS8.empty - 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 . BS8.inits $ inputBlock - in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of - (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock) - -- neither a prefix or a full event. - [] -> Invalid - -classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass -classify table = process - where - standardClassifier = compile table - - process ClassifierStart s = - case BS.uncons s of - _ | bracketedPasteStarted s -> - if bracketedPasteFinished s - then parseBracketedPaste s - else Chunk - _ | isMouseEvent s -> classifyMouseEvent s - _ | isFocusEvent s -> classifyFocusEvent s - Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs - _ -> standardClassifier s - - process (ClassifierInChunk p ps) s | bracketedPasteStarted p = - if bracketedPasteFinished s - then parseBracketedPaste $ BS.concat $ p:reverse (s:ps) - else Chunk - process ClassifierInChunk{} _ = Invalid - -classifyUtf8 :: Word8 -> ByteString -> KClass -classifyUtf8 c cs = - let n = utf8Length c - (codepoint,rest) = BS8.splitAt (n - 1) cs - - codepoint8 :: [Word8] - codepoint8 = c:BS.unpack codepoint - - in case decode codepoint8 of - _ | n < BS.length codepoint + 1 -> Prefix - Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest - -- something bad happened; just ignore and continue. - Nothing -> Invalid - -utf8Length :: Word8 -> Int -utf8Length c - | c < 0x80 = 1 - | c < 0xE0 = 2 - | c < 0xF0 = 3 - | otherwise = 4 diff --git a/src/Graphics/Vty/Input/Classify/Parse.hs b/src/Graphics/Vty/Input/Classify/Parse.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Classify/Parse.hs +++ /dev/null @@ -1,61 +0,0 @@ --- | This module provides a simple parser for parsing input event --- control sequences. -module Graphics.Vty.Input.Classify.Parse - ( Parser - , runParser - , failParse - , readInt - , readChar - , expectChar - ) -where - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Classify.Types - -import Control.Monad.Trans.Maybe -import Control.Monad.State - -import qualified Data.ByteString.Char8 as BS8 -import Data.ByteString.Char8 (ByteString) - -type Parser a = MaybeT (State ByteString) a - --- | Run a parser on a given input string. If the parser fails, return --- 'Invalid'. Otherwise return the valid event ('Valid') and the --- remaining unparsed characters. -runParser :: ByteString -> Parser Event -> KClass -runParser s parser = - case runState (runMaybeT parser) s of - (Nothing, _) -> Invalid - (Just e, remaining) -> Valid e remaining - --- | Fail a parsing operation. -failParse :: Parser a -failParse = fail "invalid parse" - --- | Read an integer from the input stream. If an integer cannot be --- read, fail parsing. E.g. calling readInt on an input of "123abc" will --- return '123' and consume those characters. -readInt :: Parser Int -readInt = do - s <- BS8.unpack <$> get - case (reads :: ReadS Int) s of - [(i, rest)] -> put (BS8.pack rest) >> return i - _ -> failParse - --- | Read a character from the input stream. If one cannot be read (e.g. --- we are out of characters), fail parsing. -readChar :: Parser Char -readChar = do - s <- get - case BS8.uncons s of - Just (c,rest) -> put rest >> return c - Nothing -> failParse - --- | Read a character from the input stream and fail parsing if it is --- not the specified character. -expectChar :: Char -> Parser () -expectChar c = do - c' <- readChar - if c' == c then return () else failParse diff --git a/src/Graphics/Vty/Input/Classify/Types.hs b/src/Graphics/Vty/Input/Classify/Types.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Classify/Types.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | This module exports the input classification type to avoid import --- cycles between other modules that need this. -{-# LANGUAGE StrictData #-} -module Graphics.Vty.Input.Classify.Types - ( KClass(..) - ) -where - -import Graphics.Vty.Input.Events - -import Data.ByteString.Char8 (ByteString) - -data KClass - = Valid Event ByteString - -- ^ A valid event was parsed. Any unused characters from the input - -- stream are also provided. - | Invalid - -- ^ The input characters did not represent a valid event. - | Prefix - -- ^ The input characters form the prefix of a valid event character - -- sequence. - | Chunk - -- ^ The input characters are either start of a bracketed paste chunk - -- or in the middle of a bracketed paste chunk. - deriving(Show, Eq) diff --git a/src/Graphics/Vty/Input/Events.hs b/src/Graphics/Vty/Input/Events.hs --- a/src/Graphics/Vty/Input/Events.hs +++ b/src/Graphics/Vty/Input/Events.hs @@ -1,6 +1,14 @@ {-# Language DeriveGeneric #-} {-# Language StrictData #-} -module Graphics.Vty.Input.Events where +module Graphics.Vty.Input.Events + ( Key(..) + , Modifier(..) + , Event(..) + , Button(..) + , ClassifyMap + , InternalEvent(..) + ) +where import Control.DeepSeq import Data.ByteString @@ -21,7 +29,7 @@ | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu - deriving (Eq,Show,Read,Ord,Generic) + deriving (Eq, Show, Read, Ord, Generic) instance NFData Key @@ -29,13 +37,22 @@ -- 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,Generic) + deriving (Eq, Show, Read, Ord, Generic) instance NFData Modifier -- | Mouse buttons. -data Button = BLeft | BMiddle | BRight | BScrollUp | BScrollDown - deriving (Eq,Show,Read,Ord,Generic) +data Button + = BLeft + | BMiddle + | BRight + | BScrollUp + | BScrollDown + | BScrollLeft + -- ^ Some terminals (e.g., Kitty, Alacritty) support horizontal + -- scrolling in addition to vertical scrolling. + | BScrollRight + deriving (Eq, Show, Read, Ord, Generic) instance NFData Button @@ -66,7 +83,7 @@ -- ^ The terminal running the application lost input focus. | EvGainedFocus -- ^ The terminal running the application gained input focus. - deriving (Eq,Show,Read,Ord,Generic) + deriving (Eq, Show, Read, Ord, Generic) instance NFData Event @@ -75,9 +92,9 @@ -- | The type of internal events that drive the internal Vty event -- dispatching to the application. data InternalEvent = - ResumeAfterSignal - -- ^ Vty resumed operation after the process was interrupted with a - -- signal. In practice this translates into a screen redraw in the - -- input event loop. + ResumeAfterInterrupt + -- ^ Vty resumed operation after the process was interrupted (e.g. + -- with a signal). In practice this translates into a screen redraw + -- in the input event loop. | InputEvent Event -- ^ An input event was received. diff --git a/src/Graphics/Vty/Input/Focus.hs b/src/Graphics/Vty/Input/Focus.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Focus.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Graphics.Vty.Input.Focus - ( requestFocusEvents - , disableFocusEvents - , isFocusEvent - , classifyFocusEvent - ) -where - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Classify.Types -import Graphics.Vty.Input.Classify.Parse - -import Control.Monad.State - -import qualified Data.ByteString.Char8 as BS8 -import Data.ByteString.Char8 (ByteString) - --- | These sequences set xterm-based terminals to send focus event --- sequences. -requestFocusEvents :: ByteString -requestFocusEvents = BS8.pack "\ESC[?1004h" - --- | These sequences disable focus events. -disableFocusEvents :: ByteString -disableFocusEvents = BS8.pack "\ESC[?1004l" - --- | Does the specified string begin with a focus event? -isFocusEvent :: ByteString -> Bool -isFocusEvent s = BS8.isPrefixOf focusIn s || - BS8.isPrefixOf focusOut s - -focusIn :: ByteString -focusIn = BS8.pack "\ESC[I" - -focusOut :: ByteString -focusOut = BS8.pack "\ESC[O" - --- | Attempt to classify an input string as a focus event. -classifyFocusEvent :: ByteString -> KClass -classifyFocusEvent s = runParser s $ do - when (not $ isFocusEvent s) failParse - - expectChar '\ESC' - expectChar '[' - ty <- readChar - case ty of - 'I' -> return EvGainedFocus - 'O' -> return EvLostFocus - _ -> failParse diff --git a/src/Graphics/Vty/Input/Loop.hs b/src/Graphics/Vty/Input/Loop.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Loop.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_HADDOCK hide #-} --- | 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 Lens.Micro hiding ((<>~)) -import Lens.Micro.Mtl -import Lens.Micro.TH -import Control.Monad (when, mzero, forM_) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.State (StateT(..), evalStateT) -import Control.Monad.State.Class (MonadState, modify) -import Control.Monad.Trans.Reader (ReaderT(..)) - -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString as BS -import Data.ByteString.Char8 (ByteString) -import Data.IORef -import Data.Word (Word8) - -import Foreign (allocaArray) -import Foreign.C.Types (CInt(..)) -import Foreign.Ptr (Ptr, castPtr) - -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 InternalEvent - -- | Shuts down the input processing. As part of shutting down the - -- input, this should also restore the input state. - , shutdownInput :: IO () - -- | Restore the terminal's input state to what it was prior - -- to configuring input for Vty. This should be done as part of - -- 'shutdownInput' but is exposed in case you need to access it - -- directly. - , restoreInputState :: 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 :: ByteString - , _classifierState :: ClassifierState - , _appliedConfig :: Config - , _inputBuffer :: InputBuffer - , _classifier :: ClassifierState -> ByteString -> 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 :: ByteString -> InputM () -addBytesToProcess block = unprocessedBytes <>= block - -emit :: Event -> InputM () -emit event = do - logMsg $ "parsed event: " ++ show event - view eventChannel >>= liftIO . atomically . flip writeTChan (InputEvent 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. -readFromDevice :: InputM ByteString -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 BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead) - else return BS.empty - when (not $ BS.null stringRep) $ - logMsg $ "input bytes: " ++ show (BS8.unpack 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 - s <- use classifierState - b <- use unprocessedBytes - case c s b of - Valid e remaining -> do - logMsg $ "valid parse: " ++ show e - logMsg $ "remaining: " ++ show remaining - classifierState .= ClassifierStart - unprocessedBytes .= remaining - return e - _ -> mzero - -dropInvalid :: InputM () -dropInvalid = do - c <- use classifier - s <- use classifierState - b <- use unprocessedBytes - case c s b of - Chunk -> do - classifierState .= - case s of - ClassifierStart -> ClassifierInChunk b [] - ClassifierInChunk p bs -> ClassifierInChunk p (b:bs) - unprocessedBytes .= BS8.empty - Invalid -> do - logMsg "dropping input bytes" - classifierState .= ClassifierStart - unprocessedBytes .= BS8.empty - _ -> return () - -runInputProcessorLoop :: ClassifyMap -> Input -> IO () -runInputProcessorLoop classifyTable input = do - let bufferSize = 1024 - allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do - s0 <- InputState BS8.empty ClassifierStart - <$> readIORef (_configRef input) - <*> pure (InputBuffer bufferPtr bufferSize) - <*> pure (classify classifyTable) - runReaderT (evalStateT loopInputProcessor s0) input - --- | Construct two IO actions: one to configure the terminal for Vty and --- one to restore the terminal mode flags to the values they had at the --- time this function was called. --- --- This function constructs a configuration action to clear the --- following terminal mode flags: --- --- * IXON disabled: disables software flow control on outgoing data. --- This stops the process from being suspended if the output terminal --- cannot keep up. --- --- * Raw mode is used for input. --- --- * ISIG (enables keyboard combinations that result in --- signals) --- --- * ECHO (input is not echoed to the output) --- --- * ICANON (canonical mode (line mode) input is not used) --- --- * IEXTEN (extended functions are disabled) --- --- The configuration action also explicitly sets these flags: --- --- * ICRNL (input carriage returns are mapped to newlines) -attributeControl :: Fd -> IO (IO (), IO ()) -attributeControl fd = do - original <- getTerminalAttributes fd - let vtyMode = foldl withMode clearedFlags flagsToSet - clearedFlags = foldl withoutMode original flagsToUnset - flagsToSet = [ MapCRtoLF -- ICRNL - ] - flagsToUnset = [ StartStopOutput -- IXON - , KeyboardInterrupts -- ISIG - , EnableEcho -- ECHO - , ProcessInput -- ICANON - , ExtendedFunctions -- IEXTEN - ] - 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 ()) - <*> 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 - -(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m () -l <>= a = modify (l <>~ a) - -(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t -l <>~ n = over l (`mappend` n) diff --git a/src/Graphics/Vty/Input/Mouse.hs b/src/Graphics/Vty/Input/Mouse.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Mouse.hs +++ /dev/null @@ -1,163 +0,0 @@ --- | This module provides parsers for mouse events for both "normal" and --- "extended" modes. This implementation was informed by --- --- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking -module Graphics.Vty.Input.Mouse - ( requestMouseEvents - , disableMouseEvents - , isMouseEvent - , classifyMouseEvent - ) -where - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Classify.Types -import Graphics.Vty.Input.Classify.Parse - -import Control.Monad.State -import Data.Maybe (catMaybes) -import Data.Bits ((.&.)) - -import qualified Data.ByteString.Char8 as BS8 -import Data.ByteString.Char8 (ByteString) - --- A mouse event in SGR extended mode is --- --- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m') --- --- where --- --- * B is the number with button and modifier bits set, --- * X is the X coordinate of the event starting at 1 --- * Y is the Y coordinate of the event starting at 1 --- * the final character is 'M' for a press, 'm' for a release - --- | These sequences set xterm-based terminals to send mouse event --- sequences. -requestMouseEvents :: ByteString -requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h" - --- | These sequences disable mouse events. -disableMouseEvents :: ByteString -disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l" - --- | Does the specified string begin with a mouse event? -isMouseEvent :: ByteString -> Bool -isMouseEvent s = isSGREvent s || isNormalEvent s - -isSGREvent :: ByteString -> Bool -isSGREvent = BS8.isPrefixOf sgrPrefix - -sgrPrefix :: ByteString -sgrPrefix = BS8.pack "\ESC[M" - -isNormalEvent :: ByteString -> Bool -isNormalEvent = BS8.isPrefixOf normalPrefix - -normalPrefix :: ByteString -normalPrefix = BS8.pack "\ESC[<" - --- Modifier bits: -shiftBit :: Int -shiftBit = 4 - -metaBit :: Int -metaBit = 8 - -ctrlBit :: Int -ctrlBit = 16 - --- These bits indicate the buttons involved: -buttonMask :: Int -buttonMask = 67 - -leftButton :: Int -leftButton = 0 - -middleButton :: Int -middleButton = 1 - -rightButton :: Int -rightButton = 2 - -scrollUp :: Int -scrollUp = 64 - -scrollDown :: Int -scrollDown = 65 - -hasBitSet :: Int -> Int -> Bool -hasBitSet val bit = val .&. bit > 0 - --- | Attempt to classify an input string as a mouse event. -classifyMouseEvent :: ByteString -> KClass -classifyMouseEvent s = runParser s $ do - when (not $ isMouseEvent s) failParse - - expectChar '\ESC' - expectChar '[' - ty <- readChar - case ty of - '<' -> classifySGRMouseEvent - 'M' -> classifyNormalMouseEvent - _ -> failParse - --- Given a modifier/button value, determine which button was indicated -getSGRButton :: Int -> Parser Button -getSGRButton mods = - let buttonMap = [ (leftButton, BLeft) - , (middleButton, BMiddle) - , (rightButton, BRight) - , (scrollUp, BScrollUp) - , (scrollDown, BScrollDown) - ] - in case lookup (mods .&. buttonMask) buttonMap of - Nothing -> failParse - Just b -> return b - -getModifiers :: Int -> [Modifier] -getModifiers mods = - catMaybes [ if mods `hasBitSet` shiftBit then Just MShift else Nothing - , if mods `hasBitSet` metaBit then Just MMeta else Nothing - , if mods `hasBitSet` ctrlBit then Just MCtrl else Nothing - ] - --- Attempt to classify a control sequence as a "normal" mouse event. To --- get here we should have already read "\ESC[M" so that will not be --- included in the string to be parsed. -classifyNormalMouseEvent :: Parser Event -classifyNormalMouseEvent = do - statusChar <- readChar - xCoordChar <- readChar - yCoordChar <- readChar - - let xCoord = fromEnum xCoordChar - 32 - yCoord = fromEnum yCoordChar - 32 - status = fromEnum statusChar - modifiers = getModifiers status - - let press = status .&. buttonMask /= 3 - case press of - True -> do - button <- getSGRButton status - return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers - False -> return $ EvMouseUp (xCoord-1) (yCoord-1) Nothing - --- Attempt to classify a control sequence as an SGR mouse event. To --- get here we should have already read "\ESC[<" so that will not be --- included in the string to be parsed. -classifySGRMouseEvent :: Parser Event -classifySGRMouseEvent = do - mods <- readInt - expectChar ';' - xCoord <- readInt - expectChar ';' - yCoord <- readInt - final <- readChar - - let modifiers = getModifiers mods - button <- getSGRButton mods - case final of - 'M' -> return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers - 'm' -> return $ EvMouseUp (xCoord-1) (yCoord-1) (Just button) - _ -> failParse diff --git a/src/Graphics/Vty/Input/Paste.hs b/src/Graphics/Vty/Input/Paste.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Paste.hs +++ /dev/null @@ -1,41 +0,0 @@ --- | This module provides bracketed paste support as described at --- --- http://cirw.in/blog/bracketed-paste -module Graphics.Vty.Input.Paste - ( parseBracketedPaste - , bracketedPasteStarted - , bracketedPasteFinished - ) -where - -import qualified Data.ByteString.Char8 as BS8 -import Data.ByteString.Char8 (ByteString) - -import Graphics.Vty.Input.Events -import Graphics.Vty.Input.Classify.Types - -bracketedPasteStart :: ByteString -bracketedPasteStart = BS8.pack "\ESC[200~" - -bracketedPasteEnd :: ByteString -bracketedPasteEnd = BS8.pack "\ESC[201~" - --- | Does the input start a bracketed paste? -bracketedPasteStarted :: ByteString -> Bool -bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart - --- | Does the input contain a complete bracketed paste? -bracketedPasteFinished :: ByteString -> Bool -bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd - --- | Parse a bracketed paste. This should only be called on a string if --- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return --- 'True'. -parseBracketedPaste :: ByteString -> KClass -parseBracketedPaste s = - Valid (EvPaste p) (BS8.drop endLen rest') - where - startLen = BS8.length bracketedPasteStart - endLen = BS8.length bracketedPasteEnd - (_, rest ) = BS8.breakSubstring bracketedPasteStart s - (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest diff --git a/src/Graphics/Vty/Input/Terminfo.hs b/src/Graphics/Vty/Input/Terminfo.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Terminfo.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# 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 and --- 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 --- --- Terminfo is incomplete. The vim source implies that terminfo is also --- incorrect. Vty assumes that the internal terminfo table added to the --- system-provided terminfo table is correct. --- --- The procedure used here is: --- --- 1. Build terminfo table for all caps. Missing caps are not added. --- --- 2. Add tables for visible chars, esc, del, ctrl, and meta. --- --- 3. Add internally-defined table for given terminal type. --- --- Precedence is currently implicit in the 'compile' algorithm. -classifyMapForTerm :: String -> Terminal -> ClassifyMap -classifyMapForTerm termName term = - concat $ capsClassifyMap term keysFromCapsTable - : universalTable - : termSpecificTables termName - --- | The key table applicable to all terminals. --- --- Note that some of these entries are 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. --- --- Note that this 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. -visibleChars :: ClassifyMap -visibleChars = [ ([x], EvKey (KChar x) []) - | x <- [' ' .. toEnum 0xC1] - ] - --- | Non-printable characters in the ISO-8859-1 and UTF-8 common set --- translated to ctrl + char. --- --- This treats CTRL-i 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 = - [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta]) - , ("\ESC\ESC[6~",EvKey KPageDown [MMeta]) - -- special support for ESC - , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta]) - -- Special support for backspace - , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS []) - -- Special support for Enter - , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter []) - -- explicit support for tab - , ("\t", EvKey (KChar '\t') []) - ] - --- | A classification 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) []) diff --git a/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs b/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs deleted file mode 100644 --- a/src/Graphics/Vty/Input/Terminfo/ANSIVT.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | 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. -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), - -- modifiers and their codes - ([MShift, MCtrl],6), ([MShift, MMeta],4)], - -- directions and their codes - (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] - ] - --- | 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-head nrs+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 --- --- 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 - ] diff --git a/src/Graphics/Vty/Output.hs b/src/Graphics/Vty/Output.hs --- a/src/Graphics/Vty/Output.hs +++ b/src/Graphics/Vty/Output.hs @@ -1,80 +1,128 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards, CPP #-} --- | This module provides functions for accessing the current terminal --- or a specific terminal device. --- --- See also: --- --- 1. "Graphics.Vty.Output": This instantiates an abtract interface --- to the terminal based on the @TERM@ and @COLORTERM@ environment --- variables. --- --- 2. "Graphics.Vty.Output.Interface": Defines the generic interface all --- terminal modules 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. --- --- 4. "Graphics.Vty.Output.XTermColor": This module contains an --- interface suitable for xterm-like terminals. These are the terminals --- where @TERM@ begins with @xterm@. This does use terminfo for as many --- control codes as possible. +-- | This module provides an abstract interface for performing terminal +-- output and functions for accessing the current terminal or a specific +-- terminal device. module Graphics.Vty.Output - ( outputForConfig + ( Output(..) + , AssumedState(..) + , DisplayContext(..) + , Mode(..) + , displayContext + , outputPicture + , initialAssumedState + , limitAttrForDisplay , setCursorPos , hideCursor , showCursor ) where +import Blaze.ByteString.Builder (Write, writeToByteString) +import Blaze.ByteString.Builder.ByteString (writeByteString) import Control.Monad (when) - -import Graphics.Vty.Config -import Graphics.Vty.Image (regionWidth, regionHeight) -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 Data.List (isPrefixOf) - +import qualified Data.ByteString as BS +import Data.IORef +import qualified Data.Vector as Vector #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif - --- | Returns an `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. --- --- 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 contains "xterm" or "screen", use XTermColor. --- * otherwise use the TerminfoBased driver. -outputForConfig :: Config -> IO Output -outputForConfig Config{ outputFd = Just fd, termName = Just termName - , colorMode = Just colorMode, .. } = do - t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName - then XTermColor.reserveTerminal termName fd colorMode - -- Not an xterm-like terminal. try for generic terminfo. - else TerminfoBased.reserveTerminal termName fd colorMode +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL - case mouseMode of - Just s -> setMode t Mouse s - Nothing -> return () +import Graphics.Vty.Attributes +import Graphics.Vty.DisplayAttributes +import Graphics.Vty.Image (DisplayRegion, regionWidth, regionHeight) +import Graphics.Vty.Picture +import Graphics.Vty.PictureToSpans +import Graphics.Vty.Span - case bracketedPasteMode of - Just s -> setMode t BracketedPaste s - Nothing -> return () +-- | Modal terminal features that can be enabled and disabled. +data Mode = Mouse + -- ^ Mouse mode (whether the terminal is configured to provide + -- mouse input events) + | BracketedPaste + -- ^ Paste mode (whether the terminal is configured to provide + -- events on OS pastes) + | Focus + -- ^ Focus-in/focus-out events (whether the terminal is + -- configured to provide events on focus change) + | Hyperlink + -- ^ Hyperlink mode via the 'withURL' attribute modifier (see + -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda). + -- Note that this may not work gracefully in all terminal + -- emulators so be sure to test this mode with the terminals + -- you intend to support. It is off by default. + deriving (Eq, Read, Show) - return t -outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig +-- | The library's device output abstraction. Platform-specific +-- implementations must implement an 'Output' and provide it to +-- 'Graphics.Vty.mkVtyFromPair'. +data Output = Output + { -- | Text identifier for the output device. Used for debugging. + terminalID :: String + -- | Release the terminal just prior to application exit and reset + -- it to its state prior to application startup. + , releaseTerminal :: IO () + -- | Clear the display and initialize the terminal to some initial + -- display state. + -- + -- The expectation of a program is that the display starts in some + -- The initial state. initial state would consist of fixed values: + -- + -- - cursor at top left + -- - UTF-8 character encoding + -- - drawing characteristics are the default + , reserveDisplay :: IO () + -- | Return the display to the state before `reserveDisplay` If no + -- previous state then set the display state to the initial state. + , releaseDisplay :: IO () + -- | Sets the current display bounds (width, height). + , setDisplayBounds :: (Int, Int) -> IO () + -- | Returns the current display bounds. + , displayBounds :: IO DisplayRegion + -- | Output the bytestring to the terminal device. + , outputByteBuffer :: BS.ByteString -> IO () + -- | Specifies whether the cursor can be shown / hidden. + , supportsCursorVisibility :: Bool + -- | Indicates support for terminal modes for this output device. + , supportsMode :: Mode -> Bool + -- | Enables or disables a mode (does nothing if the mode is + -- unsupported). + , setMode :: Mode -> Bool -> IO () + -- | Returns whether a mode is enabled. + , getModeStatus :: Mode -> IO 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 :: Output -> DisplayRegion -> IO DisplayContext + -- | Ring the terminal bell if supported. + , ringTerminalBell :: IO () + -- | Returns whether the terminal has an audio bell feature. + , supportsBell :: IO Bool + -- | Returns whether the terminal supports italicized text. + -- + -- This is terminal-dependent and should make a best effort to + -- determine whether this feature is supported, but even if the + -- terminal advertises support (e.g. via terminfo) that might not + -- be a reliable indicator of whether the feature will work as + -- desired. + , supportsItalics :: IO Bool + -- | Returns whether the terminal supports strikethrough text. + -- + -- This is terminal-dependent and should make a best effort to + -- determine whether this feature is supported, but even if the + -- terminal advertises support (e.g. via terminfo) that might not + -- be a reliable indicator of whether the feature will work as + -- desired. + , supportsStrikethrough :: IO Bool + -- | Returns how many colors the terminal supports. + , outputColorMode :: ColorMode + -- | Set the output's window title, if any. + , setOutputWindowTitle :: String -> IO () + } -- | Sets the cursor position to the given output column and row. -- @@ -105,3 +153,215 @@ bounds <- displayBounds t dc <- displayContext t bounds outputByteBuffer t $ writeToByteString $ writeShowCursor dc + +displayContext :: Output -> DisplayRegion -> IO DisplayContext +displayContext t = 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 + -- Ensure that 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 seperately 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 :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write + -- | Reset the display attributes to the default display attributes. + , writeDefaultAttr :: Bool -> 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`. +-- +-- 1. The image is cropped to the display size. +-- +-- 2. Converted into a sequence of attribute changes and text spans. +-- +-- 3. The cursor is hidden. +-- +-- 4. Serialized to the display. +-- +-- 5. The cursor is then shown and positioned or kept hidden. +outputPicture :: DisplayContext -> Picture -> IO () +outputPicture dc pic = do + urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink + as <- readIORef (assumedStateRef $ contextDevice dc) + let manipCursor = supportsCursorVisibility (contextDevice dc) + r = contextRegion dc + ops = displayOpsForPic pic r + initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing + -- Diff the previous output against the requested output. + -- Differences are currently on a per-row basis. + diffs :: [Bool] = case prevOutputOps as of + Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True + Just previousOps -> if affectedRegion previousOps /= affectedRegion ops + then replicate (displayOpsRows ops) True + else Vector.toList $ Vector.zipWith (/=) previousOps ops + -- build the Write corresponding to the output image + out = (if manipCursor then writeHideCursor dc else mempty) + `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops + `mappend` + (let (w,h) = contextRegion dc + clampX = max 0 . min (w-1) + clampY = max 0 . min (h-1) in + case picCursor pic of + _ | not manipCursor -> mempty + NoCursor -> mempty + AbsoluteCursor x y -> + writeShowCursor dc `mappend` + writeMoveCursor dc (clampX x) (clampY y) + PositionOnly isAbs x y -> + if isAbs + then writeMoveCursor dc (clampX x) (clampY y) + else let (ox, oy) = charToOutputPos m (clampX x, clampY y) + m = cursorOutputMap ops $ picCursor pic + in writeMoveCursor dc (clampX ox) (clampY oy) + Cursor x y -> + let m = cursorOutputMap ops $ picCursor pic + (ox, oy) = charToOutputPos m (clampX x, clampY y) + in writeShowCursor dc `mappend` + writeMoveCursor dc (clampX ox) (clampY oy) + ) + -- ... then serialize + outputByteBuffer (contextDevice dc) (writeToByteString out) + -- Cache the output spans. + let as' = as { prevOutputOps = Just ops } + writeIORef (assumedStateRef $ contextDevice dc) as' + +writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write +writeOutputOps urlsEnabled 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 urlsEnabled 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 :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write +writeSpanOps urlsEnabled 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 urlsEnabled + -- then the span ops are serialized in the order specified + in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of + (opOut, fattr') -> (out `mappend` opOut, fattr') + ) + (start, initialAttr) + spanOps + +writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr) +writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr = + let attr' = limitAttrForDisplay (contextDevice dc) attr + fattr' = fixDisplayAttr fattr attr' + diffs = displayAttrDiffs fattr fattr' + out = writeSetAttr dc urlsEnabled fattr attr' diffs + `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str) + in (out, fattr') +writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip" +writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `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' (outputColorMode t) c + + clampColor' NoColor _ = Default + + clampColor' ColorMode8 (ISOColor v) + | v >= 8 = SetTo $ ISOColor (v - 8) + | otherwise = SetTo $ ISOColor v + clampColor' ColorMode8 _ = Default + + clampColor' ColorMode16 c@(ISOColor _) = SetTo c + clampColor' ColorMode16 _ = Default + + clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c + clampColor' (ColorMode240 colorCount) c@(Color240 n) + | n <= colorCount = SetTo c + | otherwise = Default + clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) = + clampColor' colorMode (color240 r g b) + + clampColor' FullColor c = SetTo c diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs deleted file mode 100644 --- a/src/Graphics/Vty/Output/Interface.hs +++ /dev/null @@ -1,331 +0,0 @@ --- Copyright Corey O'Connor -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides an abstract interface for performing terminal --- output. The only user-facing part of this API is 'Output'. -module Graphics.Vty.Output.Interface - ( Output(..) - , AssumedState(..) - , DisplayContext(..) - , Mode(..) - , displayContext - , outputPicture - , initialAssumedState - , limitAttrForDisplay - ) -where - -import Graphics.Vty.Attributes -import Graphics.Vty.Image (DisplayRegion, regionHeight) -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 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 - --- | Modal terminal features that can be enabled and disabled. -data Mode = Mouse - -- ^ Mouse mode (whether the terminal is configured to provide - -- mouse input events) - | BracketedPaste - -- ^ Paste mode (whether the terminal is configured to provide - -- events on OS pastes) - | Focus - -- ^ Focus-in/focus-out events (whether the terminal is - -- configured to provide events on focus change) - | Hyperlink - -- ^ Hyperlink mode via the 'withURL' attribute modifier (see - -- https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda). - -- Note that this may not work gracefully in all terminal - -- emulators so be sure to test this mode with the terminals - -- you intend to support. It is off by default. - deriving (Eq, Read, Show) - --- | The Vty terminal output interface. -data Output = Output - { -- | Text identifier for the output device. Used for debugging. - terminalID :: String - -- | Release the terminal just prior to application exit and reset - -- it to its state prior to application startup. - , releaseTerminal :: IO () - -- | Clear the display and initialize the terminal to some initial - -- display state. - -- - -- The expectation of a program is that the display starts in some - -- The initial state. initial state would consist of fixed values: - -- - -- - cursor at top left - -- - UTF-8 character encoding - -- - drawing characteristics are the default - , reserveDisplay :: IO () - -- | Return the display to the state before `reserveDisplay` If no - -- previous state then set the display state to the initial state. - , releaseDisplay :: IO () - -- | Sets the current display bounds (width, height). - , setDisplayBounds :: (Int, Int) -> IO () - -- | Returns the current display bounds. - , displayBounds :: IO DisplayRegion - -- | Output the bytestring to the terminal device. - , outputByteBuffer :: BS.ByteString -> IO () - -- | Specifies whether the cursor can be shown / hidden. - , supportsCursorVisibility :: Bool - -- | Indicates support for terminal modes for this output device. - , supportsMode :: Mode -> Bool - -- | Enables or disables a mode (does nothing if the mode is - -- unsupported). - , setMode :: Mode -> Bool -> IO () - -- | Returns whether a mode is enabled. - , getModeStatus :: Mode -> IO 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 :: Output -> DisplayRegion -> IO DisplayContext - -- | Ring the terminal bell if supported. - , ringTerminalBell :: IO () - -- | Returns whether the terminal has an audio bell feature. - , supportsBell :: IO Bool - -- | Returns whether the terminal supports italicized text. - -- - -- This is terminal-dependent and should make a best effort to - -- determine whether this feature is supported, but even if the - -- terminal advertises support (e.g. via terminfo) that might not - -- be a reliable indicator of whether the feature will work as - -- desired. - , supportsItalics :: IO Bool - -- | Returns whether the terminal supports strikethrough text. - -- - -- This is terminal-dependent and should make a best effort to - -- determine whether this feature is supported, but even if the - -- terminal advertises support (e.g. via terminfo) that might not - -- be a reliable indicator of whether the feature will work as - -- desired. - , supportsStrikethrough :: IO Bool - -- | Returns how many colors the terminal supports. - , outputColorMode :: ColorMode - } - -displayContext :: Output -> DisplayRegion -> IO DisplayContext -displayContext t = 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 - -- Ensure that 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 seperately 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 :: Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write - -- | Reset the display attributes to the default display attributes. - , writeDefaultAttr :: Bool -> 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`. --- --- 1. The image is cropped to the display size. --- --- 2. Converted into a sequence of attribute changes and text spans. --- --- 3. The cursor is hidden. --- --- 4. Serialized to the display. --- --- 5. The cursor is then shown and positioned or kept hidden. -outputPicture :: DisplayContext -> Picture -> IO () -outputPicture dc pic = do - urlsEnabled <- getModeStatus (contextDevice dc) Hyperlink - as <- readIORef (assumedStateRef $ contextDevice dc) - let manipCursor = supportsCursorVisibility (contextDevice dc) - r = contextRegion dc - ops = displayOpsForPic pic r - initialAttr = FixedAttr defaultStyleMask Nothing Nothing Nothing - -- Diff the previous output against the requested output. - -- Differences are currently on a per-row basis. - diffs :: [Bool] = case prevOutputOps as of - Nothing -> replicate (fromEnum $ regionHeight $ affectedRegion ops) True - Just previousOps -> if affectedRegion previousOps /= affectedRegion ops - then replicate (displayOpsRows ops) True - else Vector.toList $ Vector.zipWith (/=) previousOps ops - -- build the Write corresponding to the output image - out = (if manipCursor then writeHideCursor dc else mempty) - `mappend` writeOutputOps urlsEnabled dc initialAttr diffs ops - `mappend` - (let (w,h) = contextRegion dc - clampX = max 0 . min (w-1) - clampY = max 0 . min (h-1) in - case picCursor pic of - _ | not manipCursor -> mempty - NoCursor -> mempty - AbsoluteCursor x y -> - writeShowCursor dc `mappend` - writeMoveCursor dc (clampX x) (clampY y) - PositionOnly isAbs x y -> - if isAbs - then writeMoveCursor dc (clampX x) (clampY y) - else let (ox, oy) = charToOutputPos m (clampX x, clampY y) - m = cursorOutputMap ops $ picCursor pic - in writeMoveCursor dc (clampX ox) (clampY oy) - Cursor x y -> - let m = cursorOutputMap ops $ picCursor pic - (ox, oy) = charToOutputPos m (clampX x, clampY y) - in writeShowCursor dc `mappend` - writeMoveCursor dc (clampX ox) (clampY oy) - ) - -- ... then serialize - outputByteBuffer (contextDevice dc) (writeToByteString out) - -- Cache the output spans. - let as' = as { prevOutputOps = Just ops } - writeIORef (assumedStateRef $ contextDevice dc) as' - -writeOutputOps :: Bool -> DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write -writeOutputOps urlsEnabled 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 urlsEnabled 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 :: Bool -> DisplayContext -> Int -> FixedAttr -> SpanOps -> Write -writeSpanOps urlsEnabled 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 urlsEnabled - -- then the span ops are serialized in the order specified - in fst $ Vector.foldl' (\(out, fattr) op -> case writeSpanOp urlsEnabled dc op fattr of - (opOut, fattr') -> (out `mappend` opOut, fattr') - ) - (start, initialAttr) - spanOps - -writeSpanOp :: Bool -> DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr) -writeSpanOp urlsEnabled dc (TextSpan attr _ _ str) fattr = - let attr' = limitAttrForDisplay (contextDevice dc) attr - fattr' = fixDisplayAttr fattr attr' - diffs = displayAttrDiffs fattr fattr' - out = writeSetAttr dc urlsEnabled fattr attr' diffs - `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str) - in (out, fattr') -writeSpanOp _ _ (Skip _) _fattr = error "writeSpanOp for Skip" -writeSpanOp urlsEnabled dc (RowEnd _) fattr = (writeDefaultAttr dc urlsEnabled `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' (outputColorMode t) c - - clampColor' NoColor _ = Default - - clampColor' ColorMode8 (ISOColor v) - | v >= 8 = SetTo $ ISOColor (v - 8) - | otherwise = SetTo $ ISOColor v - clampColor' ColorMode8 _ = Default - - clampColor' ColorMode16 c@(ISOColor _) = SetTo c - clampColor' ColorMode16 _ = Default - - clampColor' (ColorMode240 _) c@(ISOColor _) = SetTo c - clampColor' (ColorMode240 colorCount) c@(Color240 n) - | n <= colorCount = SetTo c - | otherwise = Default - clampColor' colorMode@(ColorMode240 _) (RGBColor r g b) = - clampColor' colorMode (color240 r g b) - - clampColor' FullColor c = SetTo c diff --git a/src/Graphics/Vty/Output/Mock.hs b/src/Graphics/Vty/Output/Mock.hs --- a/src/Graphics/Vty/Output/Mock.hs +++ b/src/Graphics/Vty/Output/Mock.hs @@ -12,7 +12,7 @@ import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16)) -import Graphics.Vty.Output.Interface +import Graphics.Vty.Output import Blaze.ByteString.Builder.Word (writeWord8) @@ -62,6 +62,7 @@ , getModeStatus = const $ return False , assumedStateRef = newAssumedStateRef , outputColorMode = ColorMode16 + , setOutputWindowTitle = const $ return () , mkDisplayContext = \tActual rActual -> return $ DisplayContext { contextRegion = rActual , contextDevice = tActual @@ -87,4 +88,3 @@ } } return (outRef, t) - diff --git a/src/Graphics/Vty/Output/TerminfoBased.hs b/src/Graphics/Vty/Output/TerminfoBased.hs deleted file mode 100644 --- a/src/Graphics/Vty/Output/TerminfoBased.hs +++ /dev/null @@ -1,606 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-} -{-# CFILES gwinsz.c #-} - --- | Terminfo-based terminal output driver. --- --- Copyright Corey O'Connor (coreyoconnor@gmail.com) -module Graphics.Vty.Output.TerminfoBased - ( reserveTerminal - , setWindowSize - ) -where - -import Control.Monad (when) -import Data.Bits (shiftL, (.&.)) -import qualified Data.ByteString as BS -import Data.ByteString.Internal (toForeignPtr) -import Data.Terminfo.Parse -import Data.Terminfo.Eval - -import Graphics.Vty.Attributes -import Graphics.Vty.Image (DisplayRegion) -import Graphics.Vty.DisplayAttributes -import Graphics.Vty.Output.Interface - -import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8) - -import Data.IORef -import Data.Maybe (isJust, isNothing, fromJust) -import Data.Word - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (foldMap) -#endif - -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(..)) - -data TerminfoCaps = TerminfoCaps - { smcup :: Maybe CapExpression - , rmcup :: Maybe CapExpression - , cup :: CapExpression - , cnorm :: Maybe CapExpression - , civis :: Maybe CapExpression - , useAltColorMap :: Bool - , setForeColor :: CapExpression - , setBackColor :: CapExpression - , setDefaultAttr :: CapExpression - , clearScreen :: CapExpression - , clearEol :: CapExpression - , displayAttrCaps :: DisplayAttrCaps - , ringBellAudio :: Maybe CapExpression - } - -data DisplayAttrCaps = DisplayAttrCaps - { setAttrStates :: Maybe CapExpression - , enterStandout :: Maybe CapExpression - , exitStandout :: Maybe CapExpression - , enterItalic :: Maybe CapExpression - , exitItalic :: Maybe CapExpression - , enterStrikethrough :: Maybe CapExpression - , exitStrikethrough :: 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 - --- | Constructs an output driver that 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: --- --- * determining the character encoding supported by the terminal. --- Should this be taken from the LANG environment variable? --- --- * Providing independent string capabilities for all display --- attributes. -reserveTerminal :: String -> Fd -> ColorMode -> IO Output -reserveTerminal termName outFd colorMode = 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 (useAlt, setForeCap) - = case msetaf of - Just setaf -> (False, setaf) - Nothing -> case msetf of - Just setf -> (True, setf) - Nothing -> (True, error $ "no fore color support for terminal " ++ termName) - msetab <- probeCap ti "setab" - msetb <- probeCap ti "setb" - let setBackCap - = case msetab of - Just setab -> setab - Nothing -> case msetb of - Just setb -> setb - Nothing -> error $ "no back color support for terminal " ++ termName - - hyperlinkModeStatus <- newIORef False - newAssumedStateRef <- newIORef initialAssumedState - - let terminfoSetMode m newStatus = do - curStatus <- terminfoModeStatus m - when (newStatus /= curStatus) $ - case m of - Hyperlink -> do - writeIORef hyperlinkModeStatus newStatus - writeIORef newAssumedStateRef initialAssumedState - _ -> return () - terminfoModeStatus m = - case m of - Hyperlink -> readIORef hyperlinkModeStatus - _ -> return False - terminfoModeSupported Hyperlink = True - terminfoModeSupported _ = False - - terminfoCaps <- pure TerminfoCaps - <*> probeCap ti "smcup" - <*> probeCap ti "rmcup" - <*> requireCap ti "cup" - <*> probeCap ti "cnorm" - <*> probeCap ti "civis" - <*> pure useAlt - <*> pure setForeCap - <*> pure setBackCap - <*> requireCap ti "sgr0" - <*> requireCap ti "clear" - <*> requireCap ti "el" - <*> currentDisplayAttrCaps ti - <*> probeCap ti "bel" - let t = Output - { terminalID = termName - , releaseTerminal = do - sendCap setDefaultAttr [] - maybeSendCap cnorm [] - , supportsBell = return $ isJust $ ringBellAudio terminfoCaps - , supportsItalics = return $ (isJust $ enterItalic (displayAttrCaps terminfoCaps)) && - (isJust $ exitItalic (displayAttrCaps terminfoCaps)) - , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) && - (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps)) - , ringTerminalBell = maybeSendCap ringBellAudio [] - , reserveDisplay = 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 = do - maybeSendCap rmcup [] - maybeSendCap cnorm [] - , setDisplayBounds = \(w, h) -> - setWindowSize outFd (w, h) - , displayBounds = do - rawSize <- 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." - , supportsCursorVisibility = isJust $ civis terminfoCaps - , supportsMode = terminfoModeSupported - , setMode = terminfoSetMode - , getModeStatus = terminfoModeStatus - , assumedStateRef = newAssumedStateRef - , outputColorMode = colorMode - -- I think fix would help assure tActual is the only - -- reference. I was having issues tho. - , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps) - } - sendCap s = sendCapToTerminal t (s terminfoCaps) - maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s) - return t - -requireCap :: Terminfo.Terminal -> String -> IO 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 :: Terminfo.Terminal -> String -> IO (Maybe CapExpression) -probeCap ti capName - = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of - Nothing -> return Nothing - Just capStr -> Just <$> parseCap capStr - -parseCap :: String -> IO CapExpression -parseCap capStr = do - case parseCapExpression capStr of - Left e -> fail $ show e - Right cap -> return cap - -currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps -currentDisplayAttrCaps ti - = pure DisplayAttrCaps - <*> probeCap ti "sgr" - <*> probeCap ti "smso" - <*> probeCap ti "rmso" - <*> probeCap ti "sitm" - <*> probeCap ti "ritm" - <*> probeCap ti "smxx" - <*> probeCap ti "rmxx" - <*> 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) - -foreign import ccall "gwinsz.h vty_c_set_window_size" c_setWindowSize :: Fd -> CLong -> IO () - -setWindowSize :: Fd -> (Int, Int) -> IO () -setWindowSize fd (w, h) = do - let val = (h `shiftL` 16) + w - c_setWindowSize fd $ fromIntegral val - -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 = \urlsEnabled -> - writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend` - (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend` - (case exitStrikethrough $ displayAttrCaps terminfoCaps of - Just cap -> writeCapExpr cap [] - Nothing -> mempty - ) - , writeRowEnd = writeCapExpr (clearEol terminfoCaps) [] - , inlineHack = return () - } - --- | Write the escape sequences that are used in some terminals to --- include embedded hyperlinks. As of yet, this information isn't --- included in termcap or terminfo, so this writes them directly --- instead of looking up the appropriate capabilities. -writeURLEscapes :: URLDiff -> Write -writeURLEscapes (LinkTo url) = - foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend` - foldMap writeStorable (BS.unpack url) `mappend` - writeStorable (0x07 :: Word8) -writeURLEscapes EndLink = - foldMap writeStorable (BS.unpack "\x1b]8;;\a") -writeURLEscapes NoLinkChange = - mempty - --- | 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. --- --- Note that this assumes the removal of color changes in the --- display attributes is done as expected with noColors == True. See --- `limitAttrForDisplay`. --- --- Note that this optimizes for fewer state changes followed by fewer --- bytes. -terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write -terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs = - urlAttrs urlsEnabled `mappend` 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 urlsEnabled - `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` setItalics - `mappend` setStrikethrough - `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 Foreground (foreColorDiff diffs) - `mappend` - writeColorDiff Background (backColorDiff diffs) - -- implicitly resets the colors to the defaults - SetState state -> writeCapExpr (fromJust $ setAttrStates - $ displayAttrCaps terminfoCaps - ) - (sgrArgsForState state) - `mappend` setItalics - `mappend` setStrikethrough - `mappend` setColors - where - urlAttrs True = writeURLEscapes (urlDiff diffs) - urlAttrs False = mempty - colorMap = case useAltColorMap terminfoCaps of - False -> ansiColorIndex - True -> altColorIndex - attr = fixDisplayAttr prevAttr reqAttr - - -- italics can't be set via SGR, so here we manually - -- apply the enter and exit sequences as needed after - -- changing the SGR - setItalics - | hasStyle (fixedStyle attr) italic - , Just sitm <- enterItalic (displayAttrCaps terminfoCaps) - = writeCapExpr sitm [] - | otherwise = mempty - setStrikethrough - | hasStyle (fixedStyle attr) strikethrough - , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps) - = writeCapExpr smxx [] - | otherwise = mempty - setColors = - (case fixedForeColor attr of - Just c -> writeColor Foreground c - Nothing -> mempty) - `mappend` - (case fixedBackColor attr of - Just c -> writeColor Background c - Nothing -> mempty) - writeColorDiff _side NoColorChange - = mempty - writeColorDiff _side ColorToDefault - = error "ColorToDefault is not a possible case for applyColorDiffs" - writeColorDiff side (SetColor c) - = writeColor side c - - writeColor side (RGBColor r g b) = - case outputColorMode (contextDevice dc) of - FullColor -> - hardcodeColor side (r, g, b) - _ -> - error "clampColor should remove rgb colors in standard mode" - writeColor side c = - writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c] - --- a color can either be in the foreground or the background -data ColorSide = Foreground | Background - --- get the capability for drawing a color on a specific side -setSideColor :: ColorSide -> TerminfoCaps -> CapExpression -setSideColor Foreground = setForeColor -setSideColor Background = setBackColor - -hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write -hardcodeColor side (r, g, b) = - -- hardcoded color codes are formatted as "\x1b[{side};2;{r};{g};{b}m" - mconcat [ writeStr "\x1b[", sideCode, delimiter, writeChar '2', delimiter - , writeColor r, delimiter, writeColor g, delimiter, writeColor b - , writeChar 'm'] - where - writeChar = writeWord8 . fromIntegral . fromEnum - writeStr = mconcat . map writeChar - writeColor = writeStr . show - delimiter = writeChar ';' - -- 38/48 are used to set whether we should write to the - -- foreground/background. I really don't want to know why. - sideCode = case side of - Foreground -> writeStr "38" - Background -> writeStr "48" - --- | 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 palette to use and --- computes the index into the full 256 color palette. -ansiColorIndex :: Color -> Int -ansiColorIndex (ISOColor v) = fromEnum v -ansiColorIndex (Color240 v) = 16 + fromEnum v -ansiColorIndex (RGBColor _ _ _) = - error $ unlines [ "Attempted to create color index from rgb color." - , "This is currently unsupported, and shouldn't ever happen" - ] - --- | 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 -altColorIndex (RGBColor _ _ _) = - error $ unlines [ "Attempted to create color index from rgb color." - , "This is currently unsupported, and shouldn't ever happen" - ] - -{- | 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 - , applyItalic :: Bool - , applyStrikethrough :: 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 ApplyStrikethrough = isNothing $ enterStrikethrough caps - noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps - noEnterExitCap ApplyItalic = isNothing $ enterItalic caps - noEnterExitCap RemoveItalic = isNothing $ exitItalic caps - 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 ApplyStrikethrough = fromJust $ enterStrikethrough caps - enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps - enterExitCap ApplyItalic = fromJust $ enterItalic caps - enterExitCap RemoveItalic = fromJust $ exitItalic caps - 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 - , applyItalic = isStyleSet italic - , applyStrikethrough = isStyleSet strikethrough - , 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 ApplyItalic italic - , applyIfRequired ApplyStrikethrough strikethrough - , applyIfRequired ApplyReverseVideo reverseVideo - , applyIfRequired ApplyBlink blink - , applyIfRequired ApplyDim dim - , applyIfRequired ApplyBold bold - ] - where - applyIfRequired op flag - = if 0 == (flag .&. s) - then [] - else [op] diff --git a/src/Graphics/Vty/Output/XTermColor.hs b/src/Graphics/Vty/Output/XTermColor.hs deleted file mode 100644 --- a/src/Graphics/Vty/Output/XTermColor.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# Language CPP #-} --- Copyright 2009-2010 Corey O'Connor --- | Xterm output driver. This uses the Terminfo driver with some --- extensions for Xterm. -module Graphics.Vty.Output.XTermColor - ( reserveTerminal - ) -where - -import Graphics.Vty.Output.Interface -import Graphics.Vty.Input.Mouse -import Graphics.Vty.Input.Focus -import Graphics.Vty.Attributes.Color (ColorMode) -import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased - -import Blaze.ByteString.Builder (writeToByteString) -import Blaze.ByteString.Builder.Word (writeWord8) - -import qualified Data.ByteString.Char8 as BS8 -import Data.ByteString.Char8 (ByteString) -import Foreign.Ptr (castPtr) - -import Control.Monad (void, when) -import Control.Monad.Trans -import Data.Char (toLower) -import Data.IORef - -import System.Posix.IO (fdWriteBuf) -import System.Posix.Types (ByteCount, Fd) -import System.Posix.Env (getEnv) - -import Data.List (isInfixOf) -import Data.Maybe (catMaybes) - -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif - --- | Write a 'ByteString' to an 'Fd'. -fdWrite :: Fd -> ByteString -> IO ByteCount -fdWrite fd s = - BS8.useAsCStringLen s $ \(buf,len) -> do - fdWriteBuf fd (castPtr buf) (fromIntegral len) - --- | Construct an Xterm output driver. Initialize the display to UTF-8. -reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output -reserveTerminal variant outFd colorMode = 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 - - utf8a <- utf8Active - when (not utf8a) $ flushedPut setUtf8CharSet - t <- TerminfoBased.reserveTerminal variant' outFd colorMode - - mouseModeStatus <- newIORef False - focusModeStatus <- newIORef False - pasteModeStatus <- newIORef False - - let xtermSetMode t' m newStatus = do - curStatus <- getModeStatus t' m - when (newStatus /= curStatus) $ - case m of - Focus -> liftIO $ do - case newStatus of - True -> flushedPut requestFocusEvents - False -> flushedPut disableFocusEvents - writeIORef focusModeStatus newStatus - Mouse -> liftIO $ do - case newStatus of - True -> flushedPut requestMouseEvents - False -> flushedPut disableMouseEvents - writeIORef mouseModeStatus newStatus - BracketedPaste -> liftIO $ do - case newStatus of - True -> flushedPut enableBracketedPastes - False -> flushedPut disableBracketedPastes - writeIORef pasteModeStatus newStatus - Hyperlink -> setMode t Hyperlink newStatus - - xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus - xtermGetMode Focus = liftIO $ readIORef focusModeStatus - xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus - xtermGetMode Hyperlink = getModeStatus t Hyperlink - - let t' = t - { terminalID = terminalID t ++ " (xterm-color)" - , releaseTerminal = do - when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet - setMode t' BracketedPaste False - setMode t' Mouse False - setMode t' Focus False - releaseTerminal t - , mkDisplayContext = \tActual r -> do - dc <- mkDisplayContext t tActual r - return $ dc { inlineHack = xtermInlineHack t' } - , supportsMode = const True - , getModeStatus = xtermGetMode - , setMode = xtermSetMode t' - } - return t' - -utf8Active :: IO Bool -utf8Active = do - let vars = ["LC_ALL", "LANG", "LC_CTYPE"] - results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars - let matches = filter ("utf8" `isInfixOf`) results <> - filter ("utf-8" `isInfixOf`) results - return $ not $ null matches - --- | Enable bracketed paste mode: --- http://cirw.in/blog/bracketed-paste -enableBracketedPastes :: ByteString -enableBracketedPastes = BS8.pack "\ESC[?2004h" - --- | Disable bracketed paste mode: -disableBracketedPastes :: ByteString -disableBracketedPastes = BS8.pack "\ESC[?2004l" - --- | These sequences set xterm based terminals to UTF-8 output. --- --- There is no known terminfo capability equivalent to this. -setUtf8CharSet, setDefaultCharSet :: ByteString -setUtf8CharSet = BS8.pack "\ESC%G" -setDefaultCharSet = BS8.pack "\ESC%@" - -xtermInlineHack :: Output -> IO () -xtermInlineHack t = do - let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K" - outputByteBuffer t $ writeToByteString writeReset diff --git a/src/Graphics/Vty/PictureToSpans.hs b/src/Graphics/Vty/PictureToSpans.hs --- a/src/Graphics/Vty/PictureToSpans.hs +++ b/src/Graphics/Vty/PictureToSpans.hs @@ -3,10 +3,12 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -- | Transforms an image into rows of operations. -module Graphics.Vty.PictureToSpans where +module Graphics.Vty.PictureToSpans + ( displayOpsForPic + ) +where import Graphics.Vty.Attributes (Attr, currentAttr) import Graphics.Vty.Image @@ -16,7 +18,7 @@ import Lens.Micro import Lens.Micro.Mtl -import Lens.Micro.TH +import Control.Monad import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state ) import Control.Monad.ST.Strict @@ -29,8 +31,6 @@ 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 = @@ -53,15 +53,35 @@ , _remainingRows :: Int } -makeLenses ''BlitState +columnOffset :: Lens' BlitState Int +columnOffset = lens _columnOffset (\e v -> e { _columnOffset = v }) +rowOffset :: Lens' BlitState Int +rowOffset = lens _rowOffset (\e v -> e { _rowOffset = v }) + +skipColumns :: Lens' BlitState Int +skipColumns = lens _skipColumns (\e v -> e { _skipColumns = v }) + +skipRows :: Lens' BlitState Int +skipRows = lens _skipRows (\e v -> e { _skipRows = v }) + +remainingColumns :: Lens' BlitState Int +remainingColumns = lens _remainingColumns (\e v -> e { _remainingColumns = v }) + +remainingRows :: Lens' BlitState Int +remainingRows = lens _remainingRows (\e v -> e { _remainingRows = v }) + data BlitEnv s = BlitEnv { _region :: DisplayRegion , _mrowOps :: MRowOps s } -makeLenses ''BlitEnv +region :: Lens' (BlitEnv s) DisplayRegion +region = lens _region (\e r -> e { _region = r }) +mrowOps :: Lens' (BlitEnv s) (MRowOps s) +mrowOps = lens _mrowOps (\e r -> e { _mrowOps = r }) + type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a -- | Produces the span ops that will render the given picture, possibly @@ -69,13 +89,6 @@ 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. --- --- largely 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. combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s) combinedOpsForLayers pic r @@ -83,7 +96,7 @@ | otherwise = do layerOps <- mapM (`buildSpans` r) (picLayers pic) case layerOps of - [] -> fail "empty picture" + [] -> error "empty picture" [ops] -> substituteSkips (picBackground pic) ops -- instead of merging ops after generation the merging can -- be performed as part of snocOp. @@ -113,7 +126,7 @@ -- 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 | w == 0 -> error $ "invalid background character " ++ show backgroundChar | w == 1 -> do forM_ [0 .. MVector.length ops - 1] $ \row -> do rowOps <- MVector.read ops row @@ -159,7 +172,7 @@ swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps swapSkipsForSingleColumnCharSpan c a = Vector.map f - where f (Skip ow) = let txt = TL.pack $ replicate ow c + where f (Skip ow) = let txt = TL.take (toEnum ow) $ TL.repeat c in TextSpan a ow ow txt f v = v @@ -220,18 +233,18 @@ isOutOfBounds :: Image -> BlitState -> Bool isOutOfBounds i s - | s ^. remainingColumns <= 0 = True - | s ^. remainingRows <= 0 = True + | 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. +-- Crop implementations is odd. They pass the current tests but +-- something seems terribly wrong about all this. +-- addMaybeClipped :: forall s . Image -> BlitM s () addMaybeClipped EmptyImage = return () addMaybeClipped (HorizText a textStr ow _cw) = do @@ -266,23 +279,13 @@ 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 +addMaybeClipped Crop {croppedImage, leftSkip, topSkip, outputWidth, outputHeight} = do + sx <- use skipColumns 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 + modifying remainingColumns (min (outputWidth - sx)) + sy <- use skipRows skipRows += topSkip + modifying remainingRows (min (outputHeight - sy)) addMaybeClipped croppedImage addMaybeClippedJoin :: forall s . String @@ -296,7 +299,7 @@ -> BlitM s () addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do state <- get - when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0" + when (state^.remaining <= 0) $ error $ name ++ " with remaining <= 0" case state^.skip of s | s > size -> put $ state & skip %~ subtract size | s == 0 -> if state^.remaining > i0Dim @@ -316,9 +319,9 @@ | s >= i0Dim -> do put $ state & skip %~ subtract i0Dim addMaybeClipped i1 - _ -> fail $ name ++ " has unhandled skip class" + _ -> error $ name ++ " has unhandled skip class" -addUnclippedText :: Attr -> DisplayText -> BlitM s () +addUnclippedText :: Attr -> TL.Text -> BlitM s () addUnclippedText a txt = do let op = TextSpan a usedDisplayColumns (fromIntegral $ TL.length txt) @@ -344,5 +347,5 @@ ops <- MVector.read theMrowOps row let ops' = Vector.snoc ops op when (spanOpsAffectedColumns ops' > regionWidth theRegion) - $ fail $ "row " ++ show row ++ " now exceeds region width" + $ error $ "row " ++ show row ++ " now exceeds region width" MVector.write theMrowOps row ops' diff --git a/src/Graphics/Vty/Span.hs b/src/Graphics/Vty/Span.hs --- a/src/Graphics/Vty/Span.hs +++ b/src/Graphics/Vty/Span.hs @@ -7,8 +7,23 @@ -- -- A span op sequence will be defined for all rows and columns (and no -- more) of the region provided with the picture to 'spansForPic'. -module Graphics.Vty.Span where +module Graphics.Vty.Span + ( SpanOp(..) + , columnsToCharOffset + , spanOpHasWidth + , SpanOps + , spanOpsAffectedColumns + , splitOpsAt + , dropOps + + , DisplayOps + , displayOpsRows + , displayOpsColumns + , affectedRegion + ) +where + import Graphics.Vty.Attributes (Attr) import Graphics.Vty.Image import Graphics.Vty.Image.Internal ( clipText ) @@ -28,7 +43,7 @@ { textSpanAttr :: !Attr , textSpanOutputWidth :: !Int , textSpanCharWidth :: !Int - , textSpanText :: DisplayText + , textSpanText :: TL.Text } -- | Skips the given number of columns. | Skip !Int diff --git a/src/Graphics/Vty/UnicodeWidthTable/Main.hs b/src/Graphics/Vty/UnicodeWidthTable/Main.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Vty/UnicodeWidthTable/Main.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +-- | This module provides a command-line tool implementation for +-- building Vty character width tables and updating the user's local Vty +-- configuration to load them. +-- +-- The API is parameterized on a platform-specific function to obtain +-- character widths. For example, on Unix platforms, this could be done +-- with a routine that communicates with the terminal to query it for +-- character widths. On other platforms, such a routine might interact +-- with a system library. +-- +-- This tool is provided as a library implementation so that the tool +-- has a consistent interface across platforms and so that it implements +-- the Vty configuration update the same way everywhere. +module Graphics.Vty.UnicodeWidthTable.Main + ( defaultMain + ) +where + +import qualified Control.Exception as E +import Control.Monad (when) +import Data.Maybe (fromMaybe) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup ((<>)) +#endif +import System.Directory (createDirectoryIfMissing) +import System.Environment (getArgs, getProgName) +import System.FilePath (takeDirectory) +import System.Exit (exitFailure) +import System.Console.GetOpt +import Text.Read (readMaybe) + +import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName + , vtyConfigPath, addConfigWidthMap + , ConfigUpdateResult(..) + ) +import Graphics.Vty.UnicodeWidthTable.IO +import Graphics.Vty.UnicodeWidthTable.Query + +data Arg = Help + | OutputPath String + | TableUpperBound String + | UpdateConfig + | VtyConfigPath String + deriving (Eq, Show) + +options :: Config -> [OptDescr Arg] +options config = + [ Option "h" ["help"] (NoArg Help) + "This help output" + , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR") + ("The maximum Unicode code point to test when building the table " <> + "(default: " <> (show $ fromEnum $ configBound config) <> ")") + , Option "p" ["path"] (ReqArg OutputPath "PATH") + ("The output path to write to (default: " <> + fromMaybe "" (configOutputPath config) <> ")") + , Option "u" ["update-config"] (NoArg UpdateConfig) + "Create or update the Vty configuration file to use the new table (default: no)" + , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH") + ("Update the specified Vty configuration file path when -u is set (default: " <> + configPath config <> ")") + ] + +data Config = + Config { configOutputPath :: Maybe FilePath + , configBound :: Char + , configUpdate :: Bool + , configPath :: FilePath + } + deriving (Show) + +mkDefaultConfig :: IO Config +mkDefaultConfig = do + Config <$> terminalWidthTablePath + <*> pure defaultUnicodeTableUpperBound + <*> pure False + <*> vtyConfigPath + +usage :: IO () +usage = do + config <- mkDefaultConfig + pn <- getProgName + putStrLn $ "Usage: " <> pn <> " [options]" + putStrLn "" + putStrLn "This tool queries the terminal on stdout to determine the widths" + putStrLn "of Unicode characters rendered to the terminal. The resulting data" + putStrLn "is written to a table at the specified output path for later" + putStrLn "loading by Vty-based applications." + putStrLn "" + + putStrLn $ usageInfo pn (options config) + +updateConfigFromArg :: Arg -> Config -> Config +updateConfigFromArg Help c = + c +updateConfigFromArg UpdateConfig c = + c { configUpdate = True } +updateConfigFromArg (VtyConfigPath p) c = + c { configPath = p } +updateConfigFromArg (TableUpperBound s) c = + case readMaybe s of + Nothing -> error $ "Invalid table upper bound: " <> show s + Just v -> c { configBound = toEnum v } +updateConfigFromArg (OutputPath p) c = + c { configOutputPath = Just p } + +-- | Run the character width table builder tool using the specified +-- function to obtain character widths. This is intended to be a 'main' +-- implementation, e.g. @main = defaultMain getCharWidth@. +-- +-- The tool queries the local terminal in some way (as determined by +-- the provided function) over a wide range of Unicode code points and +-- generates a table of character widths that can subsequently be loaded +-- by Vty-based applications. +-- +-- The tool respects the following command-line flags, all of which are +-- optional and have sensible defaults: +-- +-- * @-h@/@--help@: help output +-- * @-b@/@--bound@: Unicode code point upper bound to use when building +-- the table. +-- * @-p@/@--path@: the output path where the generated table should be +-- written. +-- * @-u@/@--update-config@: If given, create or update the user's Vty +-- configuration file to use the new table. +-- * @-c@/@--config-path@: the path to the user's Vty configuration. +defaultMain :: (Char -> IO Int) -> IO () +defaultMain charWidth = do + defConfig <- mkDefaultConfig + strArgs <- getArgs + let (args, unused, errors) = getOpt Permute (options defConfig) strArgs + + when (not $ null errors) $ do + mapM_ putStrLn errors + exitFailure + + when ((not $ null unused) || (Help `elem` args)) $ do + usage + exitFailure + + let config = foldr updateConfigFromArg defConfig args + + outputPath <- case configOutputPath config of + Nothing -> do + putStrLn "Error: could not obtain terminal width table path" + exitFailure + Just path -> return path + + putStrLn "Querying terminal:" + builtTable <- buildUnicodeWidthTable charWidth $ configBound config + + let dir = takeDirectory outputPath + createDirectoryIfMissing True dir + writeUnicodeWidthTable outputPath builtTable + + putStrLn $ "\nOutput table written to " <> outputPath + + when (configUpdate config) $ do + let cPath = configPath config + Just tName <- currentTerminalName + + result <- E.try $ addConfigWidthMap cPath tName outputPath + + case result of + Left (e::E.SomeException) -> do + putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <> + show e + exitFailure + Right ConfigurationCreated -> do + putStrLn $ "Configuration file created: " <> cPath + Right ConfigurationModified -> do + putStrLn $ "Configuration file updated: " <> cPath + Right (ConfigurationConflict other) -> do + putStrLn $ "Configuration file not updated: uses a different table " <> + "for TERM=" <> tName <> ": " <> other + Right ConfigurationRedundant -> do + putStrLn $ "Configuration file not updated: configuration " <> + cPath <> " already uses table " <> outputPath <> + " for TERM=" <> tName diff --git a/src/Graphics/Vty/UnicodeWidthTable/Query.hs b/src/Graphics/Vty/UnicodeWidthTable/Query.hs --- a/src/Graphics/Vty/UnicodeWidthTable/Query.hs +++ b/src/Graphics/Vty/UnicodeWidthTable/Query.hs @@ -7,8 +7,6 @@ import Control.Monad (forM) import Data.Char (generalCategory, GeneralCategory(..)) -import System.Console.ANSI (getCursorPosition) -import Text.Printf (printf) import Graphics.Vty.UnicodeWidthTable.Types @@ -20,13 +18,6 @@ Surrogate -> False _ -> True -charWidth :: Char -> IO Int -charWidth c = do - printf "\r" - putChar c - Just (_, col) <- getCursorPosition - return col - -- | Convert a sequence of character/width pairs into a list of -- run-length encoded ranges. This function assumes the pairs come -- sorted by character ordinal value. It does not require that the @@ -57,21 +48,21 @@ defaultUnicodeTableUpperBound :: Char defaultUnicodeTableUpperBound = '\xe0000' --- | Construct a unicode character width table by querying the terminal --- connected to stdout. This works by emitting characters to stdout --- and then querying the terminal to determine the resulting cursor --- position in order to measure character widths. Consequently this will --- generate a lot of output and may take a while, depending on your --- system performance. This should not be run in a terminal while it is --- controlled by Vty. +-- | Construct a unicode character width table. This works by using the +-- provided function to obtain the appropriate width for each character +-- in a wide range of Unicode code points, which on some platforms +-- may perform local terminal operations or may interact with system +-- libraries. Depending on how the provided width function works, this +-- may need to be run only in a terminal that is not actively controlled +-- by a Vty handle. -- --- The argument specifies the upper bound code point to test when --- building the table. This allows callers to decide how much of the --- Unicode code point space to scan when building the table. +-- The character argument specifies the upper bound code point to test +-- when building the table. This allows callers to decide how much of +-- the Unicode code point space to scan when building the table. -- -- This does not handle exceptions. -buildUnicodeWidthTable :: Char -> IO UnicodeWidthTable -buildUnicodeWidthTable tableUpperBound = do +buildUnicodeWidthTable :: (Char -> IO Int) -> Char -> IO UnicodeWidthTable +buildUnicodeWidthTable charWidth tableUpperBound = do pairs <- forM (filter shouldConsider ['\0'..tableUpperBound]) $ \i -> (i,) <$> charWidth i diff --git a/test/Verify.hs b/test/Verify.hs deleted file mode 100644 --- a/test/Verify.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# 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 - -data Bench where - Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench diff --git a/test/Verify/Data/Terminfo/Parse.hs b/test/Verify/Data/Terminfo/Parse.hs deleted file mode 100644 --- a/test/Verify/Data/Terminfo/Parse.hs +++ /dev/null @@ -1,112 +0,0 @@ -module Verify.Data.Terminfo.Parse - ( module Verify.Data.Terminfo.Parse - , module Data.Terminfo.Parse - ) -where - -import Data.Terminfo.Parse -import Data.Terminfo.Eval -import Verify - -import Data.Word -import 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 - ++ "]" - } diff --git a/test/Verify/Graphics/Vty/Attributes.hs b/test/Verify/Graphics/Vty/Attributes.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Attributes.hs +++ /dev/null @@ -1,73 +0,0 @@ -module 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 diff --git a/test/Verify/Graphics/Vty/DisplayAttributes.hs b/test/Verify/Graphics/Vty/DisplayAttributes.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/DisplayAttributes.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Verify.Graphics.Vty.DisplayAttributes - ( module Verify.Graphics.Vty.DisplayAttributes - , module Graphics.Vty.DisplayAttributes - ) -where - -import Graphics.Vty.DisplayAttributes -import Verify diff --git a/test/Verify/Graphics/Vty/Image.hs b/test/Verify/Graphics/Vty/Image.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Image.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# 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' diff --git a/test/Verify/Graphics/Vty/Output.hs b/test/Verify/Graphics/Vty/Output.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Output.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Verify.Graphics.Vty.Output where - -import Control.Applicative ((<$>)) - -import Graphics.Vty.Output.Mock - -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 diff --git a/test/Verify/Graphics/Vty/Picture.hs b/test/Verify/Graphics/Vty/Picture.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Picture.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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 diff --git a/test/Verify/Graphics/Vty/Prelude.hs b/test/Verify/Graphics/Vty/Prelude.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Prelude.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Verify.Graphics.Vty.Prelude - ( module Verify.Graphics.Vty.Prelude - , MockWindow(..) - ) -where - -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 - diff --git a/test/Verify/Graphics/Vty/Span.hs b/test/Verify/Graphics/Vty/Span.hs deleted file mode 100644 --- a/test/Verify/Graphics/Vty/Span.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# 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 -> (spanOpsAffectedColumns 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 - } diff --git a/test/VerifyColor240.hs b/test/VerifyColor240.hs deleted file mode 100644 --- a/test/VerifyColor240.hs +++ /dev/null @@ -1,269 +0,0 @@ -module VerifyColor240 where - -import Data.Word(Word8) -import Verify - -import Graphics.Vty.Attributes.Color240(rgbColorToColor240) - -oldRgbColorToColor240 :: Integral i => i -> i -> i -> Word8 -oldRgbColorToColor240 r g b - | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity" - | r == 8 && g == 8 && b == 8 = 216 - | r == 18 && g == 18 && b == 18 = 217 - | r == 28 && g == 28 && b == 28 = 218 - | r == 38 && g == 38 && b == 38 = 219 - | r == 48 && g == 48 && b == 48 = 220 - | r == 58 && g == 58 && b == 58 = 221 - | r == 68 && g == 68 && b == 68 = 222 - | r == 78 && g == 78 && b == 78 = 223 - | r == 88 && g == 88 && b == 88 = 224 - | r == 98 && g == 98 && b == 98 = 225 - | r == 108 && g == 108 && b == 108 = 226 - | r == 118 && g == 118 && b == 118 = 227 - | r == 128 && g == 128 && b == 128 = 228 - | r == 138 && g == 138 && b == 138 = 229 - | r == 148 && g == 148 && b == 148 = 230 - | r == 158 && g == 158 && b == 158 = 231 - | r == 168 && g == 168 && b == 168 = 232 - | r == 178 && g == 178 && b == 178 = 233 - | r == 188 && g == 188 && b == 188 = 234 - | r == 198 && g == 198 && b == 198 = 235 - | r == 208 && g == 208 && b == 208 = 236 - | r == 218 && g == 218 && b == 218 = 237 - | r == 228 && g == 228 && b == 228 = 238 - | r == 238 && g == 238 && b == 238 = 239 - | r <= 0 && g <= 0 && b <= 0 = 0 - | r <= 0 && g <= 0 && b <= 95 = 1 - | r <= 0 && g <= 0 && b <= 135 = 2 - | r <= 0 && g <= 0 && b <= 175 = 3 - | r <= 0 && g <= 0 && b <= 215 = 4 - | r <= 0 && g <= 0 && b <= 255 = 5 - | r <= 0 && g <= 95 && b <= 0 = 6 - | r <= 0 && g <= 95 && b <= 95 = 7 - | r <= 0 && g <= 95 && b <= 135 = 8 - | r <= 0 && g <= 95 && b <= 175 = 9 - | r <= 0 && g <= 95 && b <= 215 = 10 - | r <= 0 && g <= 95 && b <= 255 = 11 - | r <= 0 && g <= 135 && b <= 0 = 12 - | r <= 0 && g <= 135 && b <= 95 = 13 - | r <= 0 && g <= 135 && b <= 135 = 14 - | r <= 0 && g <= 135 && b <= 175 = 15 - | r <= 0 && g <= 135 && b <= 215 = 16 - | r <= 0 && g <= 135 && b <= 255 = 17 - | r <= 0 && g <= 175 && b <= 0 = 18 - | r <= 0 && g <= 175 && b <= 95 = 19 - | r <= 0 && g <= 175 && b <= 135 = 20 - | r <= 0 && g <= 175 && b <= 175 = 21 - | r <= 0 && g <= 175 && b <= 215 = 22 - | r <= 0 && g <= 175 && b <= 255 = 23 - | r <= 0 && g <= 215 && b <= 0 = 24 - | r <= 0 && g <= 215 && b <= 95 = 25 - | r <= 0 && g <= 215 && b <= 135 = 26 - | r <= 0 && g <= 215 && b <= 175 = 27 - | r <= 0 && g <= 215 && b <= 215 = 28 - | r <= 0 && g <= 215 && b <= 255 = 29 - | r <= 0 && g <= 255 && b <= 0 = 30 - | r <= 0 && g <= 255 && b <= 95 = 31 - | r <= 0 && g <= 255 && b <= 135 = 32 - | r <= 0 && g <= 255 && b <= 175 = 33 - | r <= 0 && g <= 255 && b <= 215 = 34 - | r <= 0 && g <= 255 && b <= 255 = 35 - | r <= 95 && g <= 0 && b <= 0 = 36 - | r <= 95 && g <= 0 && b <= 95 = 37 - | r <= 95 && g <= 0 && b <= 135 = 38 - | r <= 95 && g <= 0 && b <= 175 = 39 - | r <= 95 && g <= 0 && b <= 215 = 40 - | r <= 95 && g <= 0 && b <= 255 = 41 - | r <= 95 && g <= 95 && b <= 0 = 42 - | r <= 95 && g <= 95 && b <= 95 = 43 - | r <= 95 && g <= 95 && b <= 135 = 44 - | r <= 95 && g <= 95 && b <= 175 = 45 - | r <= 95 && g <= 95 && b <= 215 = 46 - | r <= 95 && g <= 95 && b <= 255 = 47 - | r <= 95 && g <= 135 && b <= 0 = 48 - | r <= 95 && g <= 135 && b <= 95 = 49 - | r <= 95 && g <= 135 && b <= 135 = 50 - | r <= 95 && g <= 135 && b <= 175 = 51 - | r <= 95 && g <= 135 && b <= 215 = 52 - | r <= 95 && g <= 135 && b <= 255 = 53 - | r <= 95 && g <= 175 && b <= 0 = 54 - | r <= 95 && g <= 175 && b <= 95 = 55 - | r <= 95 && g <= 175 && b <= 135 = 56 - | r <= 95 && g <= 175 && b <= 175 = 57 - | r <= 95 && g <= 175 && b <= 215 = 58 - | r <= 95 && g <= 175 && b <= 255 = 59 - | r <= 95 && g <= 215 && b <= 0 = 60 - | r <= 95 && g <= 215 && b <= 95 = 61 - | r <= 95 && g <= 215 && b <= 135 = 62 - | r <= 95 && g <= 215 && b <= 175 = 63 - | r <= 95 && g <= 215 && b <= 215 = 64 - | r <= 95 && g <= 215 && b <= 255 = 65 - | r <= 95 && g <= 255 && b <= 0 = 66 - | r <= 95 && g <= 255 && b <= 95 = 67 - | r <= 95 && g <= 255 && b <= 135 = 68 - | r <= 95 && g <= 255 && b <= 175 = 69 - | r <= 95 && g <= 255 && b <= 215 = 70 - | r <= 95 && g <= 255 && b <= 255 = 71 - | r <= 135 && g <= 0 && b <= 0 = 72 - | r <= 135 && g <= 0 && b <= 95 = 73 - | r <= 135 && g <= 0 && b <= 135 = 74 - | r <= 135 && g <= 0 && b <= 175 = 75 - | r <= 135 && g <= 0 && b <= 215 = 76 - | r <= 135 && g <= 0 && b <= 255 = 77 - | r <= 135 && g <= 95 && b <= 0 = 78 - | r <= 135 && g <= 95 && b <= 95 = 79 - | r <= 135 && g <= 95 && b <= 135 = 80 - | r <= 135 && g <= 95 && b <= 175 = 81 - | r <= 135 && g <= 95 && b <= 215 = 82 - | r <= 135 && g <= 95 && b <= 255 = 83 - | r <= 135 && g <= 135 && b <= 0 = 84 - | r <= 135 && g <= 135 && b <= 95 = 85 - | r <= 135 && g <= 135 && b <= 135 = 86 - | r <= 135 && g <= 135 && b <= 175 = 87 - | r <= 135 && g <= 135 && b <= 215 = 88 - | r <= 135 && g <= 135 && b <= 255 = 89 - | r <= 135 && g <= 175 && b <= 0 = 90 - | r <= 135 && g <= 175 && b <= 95 = 91 - | r <= 135 && g <= 175 && b <= 135 = 92 - | r <= 135 && g <= 175 && b <= 175 = 93 - | r <= 135 && g <= 175 && b <= 215 = 94 - | r <= 135 && g <= 175 && b <= 255 = 95 - | r <= 135 && g <= 215 && b <= 0 = 96 - | r <= 135 && g <= 215 && b <= 95 = 97 - | r <= 135 && g <= 215 && b <= 135 = 98 - | r <= 135 && g <= 215 && b <= 175 = 99 - | r <= 135 && g <= 215 && b <= 215 = 100 - | r <= 135 && g <= 215 && b <= 255 = 101 - | r <= 135 && g <= 255 && b <= 0 = 102 - | r <= 135 && g <= 255 && b <= 95 = 103 - | r <= 135 && g <= 255 && b <= 135 = 104 - | r <= 135 && g <= 255 && b <= 175 = 105 - | r <= 135 && g <= 255 && b <= 215 = 106 - | r <= 135 && g <= 255 && b <= 255 = 107 - | r <= 175 && g <= 0 && b <= 0 = 108 - | r <= 175 && g <= 0 && b <= 95 = 109 - | r <= 175 && g <= 0 && b <= 135 = 110 - | r <= 175 && g <= 0 && b <= 175 = 111 - | r <= 175 && g <= 0 && b <= 215 = 112 - | r <= 175 && g <= 0 && b <= 255 = 113 - | r <= 175 && g <= 95 && b <= 0 = 114 - | r <= 175 && g <= 95 && b <= 95 = 115 - | r <= 175 && g <= 95 && b <= 135 = 116 - | r <= 175 && g <= 95 && b <= 175 = 117 - | r <= 175 && g <= 95 && b <= 215 = 118 - | r <= 175 && g <= 95 && b <= 255 = 119 - | r <= 175 && g <= 135 && b <= 0 = 120 - | r <= 175 && g <= 135 && b <= 95 = 121 - | r <= 175 && g <= 135 && b <= 135 = 122 - | r <= 175 && g <= 135 && b <= 175 = 123 - | r <= 175 && g <= 135 && b <= 215 = 124 - | r <= 175 && g <= 135 && b <= 255 = 125 - | r <= 175 && g <= 175 && b <= 0 = 126 - | r <= 175 && g <= 175 && b <= 95 = 127 - | r <= 175 && g <= 175 && b <= 135 = 128 - | r <= 175 && g <= 175 && b <= 175 = 129 - | r <= 175 && g <= 175 && b <= 215 = 130 - | r <= 175 && g <= 175 && b <= 255 = 131 - | r <= 175 && g <= 215 && b <= 0 = 132 - | r <= 175 && g <= 215 && b <= 95 = 133 - | r <= 175 && g <= 215 && b <= 135 = 134 - | r <= 175 && g <= 215 && b <= 175 = 135 - | r <= 175 && g <= 215 && b <= 215 = 136 - | r <= 175 && g <= 215 && b <= 255 = 137 - | r <= 175 && g <= 255 && b <= 0 = 138 - | r <= 175 && g <= 255 && b <= 95 = 139 - | r <= 175 && g <= 255 && b <= 135 = 140 - | r <= 175 && g <= 255 && b <= 175 = 141 - | r <= 175 && g <= 255 && b <= 215 = 142 - | r <= 175 && g <= 255 && b <= 255 = 143 - | r <= 215 && g <= 0 && b <= 0 = 144 - | r <= 215 && g <= 0 && b <= 95 = 145 - | r <= 215 && g <= 0 && b <= 135 = 146 - | r <= 215 && g <= 0 && b <= 175 = 147 - | r <= 215 && g <= 0 && b <= 215 = 148 - | r <= 215 && g <= 0 && b <= 255 = 149 - | r <= 215 && g <= 95 && b <= 0 = 150 - | r <= 215 && g <= 95 && b <= 95 = 151 - | r <= 215 && g <= 95 && b <= 135 = 152 - | r <= 215 && g <= 95 && b <= 175 = 153 - | r <= 215 && g <= 95 && b <= 215 = 154 - | r <= 215 && g <= 95 && b <= 255 = 155 - | r <= 215 && g <= 135 && b <= 0 = 156 - | r <= 215 && g <= 135 && b <= 95 = 157 - | r <= 215 && g <= 135 && b <= 135 = 158 - | r <= 215 && g <= 135 && b <= 175 = 159 - | r <= 215 && g <= 135 && b <= 215 = 160 - | r <= 215 && g <= 135 && b <= 255 = 161 - | r <= 215 && g <= 175 && b <= 0 = 162 - | r <= 215 && g <= 175 && b <= 95 = 163 - | r <= 215 && g <= 175 && b <= 135 = 164 - | r <= 215 && g <= 175 && b <= 175 = 165 - | r <= 215 && g <= 175 && b <= 215 = 166 - | r <= 215 && g <= 175 && b <= 255 = 167 - | r <= 215 && g <= 215 && b <= 0 = 168 - | r <= 215 && g <= 215 && b <= 95 = 169 - | r <= 215 && g <= 215 && b <= 135 = 170 - | r <= 215 && g <= 215 && b <= 175 = 171 - | r <= 215 && g <= 215 && b <= 215 = 172 - | r <= 215 && g <= 215 && b <= 255 = 173 - | r <= 215 && g <= 255 && b <= 0 = 174 - | r <= 215 && g <= 255 && b <= 95 = 175 - | r <= 215 && g <= 255 && b <= 135 = 176 - | r <= 215 && g <= 255 && b <= 175 = 177 - | r <= 215 && g <= 255 && b <= 215 = 178 - | r <= 215 && g <= 255 && b <= 255 = 179 - | r <= 255 && g <= 0 && b <= 0 = 180 - | r <= 255 && g <= 0 && b <= 95 = 181 - | r <= 255 && g <= 0 && b <= 135 = 182 - | r <= 255 && g <= 0 && b <= 175 = 183 - | r <= 255 && g <= 0 && b <= 215 = 184 - | r <= 255 && g <= 0 && b <= 255 = 185 - | r <= 255 && g <= 95 && b <= 0 = 186 - | r <= 255 && g <= 95 && b <= 95 = 187 - | r <= 255 && g <= 95 && b <= 135 = 188 - | r <= 255 && g <= 95 && b <= 175 = 189 - | r <= 255 && g <= 95 && b <= 215 = 190 - | r <= 255 && g <= 95 && b <= 255 = 191 - | r <= 255 && g <= 135 && b <= 0 = 192 - | r <= 255 && g <= 135 && b <= 95 = 193 - | r <= 255 && g <= 135 && b <= 135 = 194 - | r <= 255 && g <= 135 && b <= 175 = 195 - | r <= 255 && g <= 135 && b <= 215 = 196 - | r <= 255 && g <= 135 && b <= 255 = 197 - | r <= 255 && g <= 175 && b <= 0 = 198 - | r <= 255 && g <= 175 && b <= 95 = 199 - | r <= 255 && g <= 175 && b <= 135 = 200 - | r <= 255 && g <= 175 && b <= 175 = 201 - | r <= 255 && g <= 175 && b <= 215 = 202 - | r <= 255 && g <= 175 && b <= 255 = 203 - | r <= 255 && g <= 215 && b <= 0 = 204 - | r <= 255 && g <= 215 && b <= 95 = 205 - | r <= 255 && g <= 215 && b <= 135 = 206 - | r <= 255 && g <= 215 && b <= 175 = 207 - | r <= 255 && g <= 215 && b <= 215 = 208 - | r <= 255 && g <= 215 && b <= 255 = 209 - | r <= 255 && g <= 255 && b <= 0 = 210 - | r <= 255 && g <= 255 && b <= 95 = 211 - | r <= 255 && g <= 255 && b <= 135 = 212 - | r <= 255 && g <= 255 && b <= 175 = 213 - | r <= 255 && g <= 255 && b <= 215 = 214 - | r <= 255 && g <= 255 && b <= 255 = 215 - | otherwise = error (printf "RGB color %d %d %d does not map to 240 palette." - (fromIntegral r :: Int) - (fromIntegral g :: Int) - (fromIntegral b :: Int)) - -sameColor :: Int -> Int -> Int -> Bool -sameColor r g b = oldRgbColorToColor240 r g b == rgbColorToColor240 r g b - -genVal :: Gen Int -genVal = chooseInt (0, 255) - -sameColorCheck :: Property -sameColorCheck = forAll genVal (\r -> forAll genVal (\g -> forAll genVal (sameColor r g))) - -tests :: IO [Test] -tests = return - [ verify "check rgbColorToColor240 optimization is correct" sameColorCheck - ] - diff --git a/test/VerifyConfig.hs b/test/VerifyConfig.hs deleted file mode 100644 --- a/test/VerifyConfig.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Main where - -import Graphics.Vty.Config -import Graphics.Vty.Input.Events - -import Data.String.QQ -import qualified Data.ByteString.Char8 as B - -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit hiding (Test) - -exampleConfig :: B.ByteString -exampleConfig = B.pack [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 = defaultConfig - { 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 - ] diff --git a/test/VerifyCropSpanGeneration.hs b/test/VerifyCropSpanGeneration.hs deleted file mode 100644 --- a/test/VerifyCropSpanGeneration.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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 - ] diff --git a/test/VerifyDisplayAttributes.hs b/test/VerifyDisplayAttributes.hs deleted file mode 100644 --- a/test/VerifyDisplayAttributes.hs +++ /dev/null @@ -1,9 +0,0 @@ -module VerifyDisplayAttributes where - -import Verify.Graphics.Vty.DisplayAttributes -import Verify.Graphics.Vty.Attributes - -import Verify - -tests :: IO [Test] -tests = return [] diff --git a/test/VerifyEmptyImageProps.hs b/test/VerifyEmptyImageProps.hs deleted file mode 100644 --- a/test/VerifyEmptyImageProps.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module VerifyEmptyImageProps where - -import Verify - --- should be exported by Graphics.Vty.Picture -import Graphics.Vty.Image ( Image, emptyImage ) - -tests :: IO [Test] -tests = do - -- should provide an image type. - let _ :: Image = emptyImage - return [] - diff --git a/test/VerifyEvalTerminfoCaps.hs b/test/VerifyEvalTerminfoCaps.hs deleted file mode 100644 --- a/test/VerifyEvalTerminfoCaps.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -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 - -- 1 MB should be big enough for any termcaps ;-) - evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) - 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 diff --git a/test/VerifyImageOps.hs b/test/VerifyImageOps.hs deleted file mode 100644 --- a/test/VerifyImageOps.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module 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) - --- ridiculous 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 - ] diff --git a/test/VerifyImageTrans.hs b/test/VerifyImageTrans.hs deleted file mode 100644 --- a/test/VerifyImageTrans.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# 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 - ] - diff --git a/test/VerifyInline.hs b/test/VerifyInline.hs deleted file mode 100644 --- a/test/VerifyInline.hs +++ /dev/null @@ -1,31 +0,0 @@ -module 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" - } - ]) diff --git a/test/VerifyLayersSpanGeneration.hs b/test/VerifyLayersSpanGeneration.hs deleted file mode 100644 --- a/test/VerifyLayersSpanGeneration.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -module VerifyLayersSpanGeneration where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Attributes -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 - ] diff --git a/test/VerifyOutput.hs b/test/VerifyOutput.hs deleted file mode 100644 --- a/test/VerifyOutput.hs +++ /dev/null @@ -1,58 +0,0 @@ --- We setup the environment to invoke certain terminals of interest. --- This assumes appropriate definitions exist in the current environment --- for the terminals of interest. -{-# LANGUAGE ScopedTypeVariables #-} -module VerifyOutput where - -import Verify - -import Graphics.Vty - -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Output - -import Control.Monad - -import qualified System.Console.Terminfo as Terminfo -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 $ defaultConfig - { outputFd = Just nullOut - , termName = Just termName - , colorMode = Just NoColor - } - -- 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 - diff --git a/test/VerifyParseTerminfoCaps.hs b/test/VerifyParseTerminfoCaps.hs deleted file mode 100644 --- a/test/VerifyParseTerminfoCaps.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -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 diff --git a/test/VerifySimpleSpanGeneration.hs b/test/VerifySimpleSpanGeneration.hs deleted file mode 100644 --- a/test/VerifySimpleSpanGeneration.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# 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 ( spanOpsAffectedRows 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 ( spanOpsAffectedRows 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 spanOpsAffectedRows 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 = spanOpsAffectedRows 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 = spanOpsAffectedRows 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 = spanOpsAffectedRows 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 ( spanOpsAffectedRows ops == h ) && ( allSpansHaveWidth ops w ) - -spanOpsActuallyFillRows :: DefaultPic -> Bool -spanOpsActuallyFillRows (DefaultPic pic win) = - let ops = displayOpsForPic pic (regionForWindow win) - expectedRowCount = regionHeight (regionForWindow win) - actualRowCount = spanOpsAffectedRows 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 - ] - diff --git a/test/VerifyUsingMockInput.hs b/test/VerifyUsingMockInput.hs deleted file mode 100644 --- a/test/VerifyUsingMockInput.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} --- 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.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Lens.Micro ((^.)) -import Control.Monad - -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 = defaultConfig { 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 - case e of - InputEvent ev -> modifyIORef eventsRef ((:) ev) - ResumeAfterSignal -> return () - 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 $ \terminalName -> monadic $ do - term <- setupTerm terminalName - 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 $ \terminalName -> monadic $ do - term <- setupTerm terminalName - let table = classifyMapForTerm terminalName 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 $ \terminalName -> monadic $ do - term <- setupTerm terminalName - let table = classifyMapForTerm terminalName 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 - ] - diff --git a/test/VerifyUsingMockTerminal.hs b/test/VerifyUsingMockTerminal.hs deleted file mode 100644 --- a/test/VerifyUsingMockTerminal.hs +++ /dev/null @@ -1,108 +0,0 @@ -module VerifyUsingMockTerminal where - -import Verify.Graphics.Vty.Prelude - -import Verify.Graphics.Vty.Picture -import Verify.Graphics.Vty.Image -import Verify.Graphics.Vty.Attributes -import Verify.Graphics.Vty.Span -import Verify.Graphics.Vty.Output -import Graphics.Vty.Output -import Graphics.Vty.Output.Interface -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 - ] diff --git a/test/VerifyUtf8Width.hs b/test/VerifyUtf8Width.hs deleted file mode 100644 --- a/test/VerifyUtf8Width.hs +++ /dev/null @@ -1,30 +0,0 @@ -module VerifyUtf8Width where - -import Verify - -import Graphics.Text.Width -import Graphics.Vty.Attributes -import Graphics.Vty.Picture -import Graphics.Vty.Image - -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 - ] - diff --git a/tools/BuildWidthTable.hs b/tools/BuildWidthTable.hs deleted file mode 100644 --- a/tools/BuildWidthTable.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -module Main where - -import qualified Control.Exception as E -import Control.Monad (when) -import Data.Maybe (fromMaybe) -#if !(MIN_VERSION_base(4,11,0)) -import Data.Semigroup ((<>)) -#endif -import System.Directory (createDirectoryIfMissing) -import System.Environment (getArgs, getProgName) -import System.FilePath (takeDirectory) -import System.Exit (exitFailure) -import System.Console.GetOpt -import Text.Read (readMaybe) - -import Graphics.Vty.Config ( terminalWidthTablePath, currentTerminalName - , vtyConfigPath, addConfigWidthMap - , ConfigUpdateResult(..) - ) -import Graphics.Vty.UnicodeWidthTable.IO -import Graphics.Vty.UnicodeWidthTable.Query - -data Arg = Help - | OutputPath String - | TableUpperBound String - | UpdateConfig - | VtyConfigPath String - deriving (Eq, Show) - -options :: Config -> [OptDescr Arg] -options config = - [ Option "h" ["help"] (NoArg Help) - "This help output" - , Option "b" ["bound"] (ReqArg TableUpperBound "MAX_CHAR") - ("The maximum Unicode code point to test when building the table " <> - "(default: " <> (show $ fromEnum $ configBound config) <> ")") - , Option "p" ["path"] (ReqArg OutputPath "PATH") - ("The output path to write to (default: " <> - fromMaybe "" (configOutputPath config) <> ")") - , Option "u" ["update-config"] (NoArg UpdateConfig) - "Create or update the Vty configuration file to use the new table (default: no)" - , Option "c" ["config-path"] (ReqArg VtyConfigPath "PATH") - ("Update the specified Vty configuration file path when -u is set (default: " <> - configPath config <> ")") - ] - -data Config = - Config { configOutputPath :: Maybe FilePath - , configBound :: Char - , configUpdate :: Bool - , configPath :: FilePath - } - deriving (Show) - -mkDefaultConfig :: IO Config -mkDefaultConfig = do - Config <$> terminalWidthTablePath - <*> pure defaultUnicodeTableUpperBound - <*> pure False - <*> vtyConfigPath - -usage :: IO () -usage = do - config <- mkDefaultConfig - pn <- getProgName - putStrLn $ "Usage: " <> pn <> " [options]" - putStrLn "" - putStrLn "This tool queries the terminal on stdout to determine the widths" - putStrLn "of Unicode characters rendered to the terminal. The resulting data" - putStrLn "is written to a table at the specified output path for later" - putStrLn "loading by Vty-based applications." - putStrLn "" - - putStrLn $ usageInfo pn (options config) - -updateConfigFromArg :: Arg -> Config -> Config -updateConfigFromArg Help c = - c -updateConfigFromArg UpdateConfig c = - c { configUpdate = True } -updateConfigFromArg (VtyConfigPath p) c = - c { configPath = p } -updateConfigFromArg (TableUpperBound s) c = - case readMaybe s of - Nothing -> error $ "Invalid table upper bound: " <> show s - Just v -> c { configBound = toEnum v } -updateConfigFromArg (OutputPath p) c = - c { configOutputPath = Just p } - -main :: IO () -main = do - defConfig <- mkDefaultConfig - strArgs <- getArgs - let (args, unused, errors) = getOpt Permute (options defConfig) strArgs - - when (not $ null errors) $ do - mapM_ putStrLn errors - exitFailure - - when ((not $ null unused) || (Help `elem` args)) $ do - usage - exitFailure - - let config = foldr updateConfigFromArg defConfig args - - outputPath <- case configOutputPath config of - Nothing -> do - putStrLn "Error: could not obtain terminal width table path" - exitFailure - Just path -> return path - - putStrLn "Querying terminal:" - builtTable <- buildUnicodeWidthTable $ configBound config - - let dir = takeDirectory outputPath - createDirectoryIfMissing True dir - writeUnicodeWidthTable outputPath builtTable - - putStrLn $ "\nOutput table written to " <> outputPath - - when (configUpdate config) $ do - let cPath = configPath config - Just tName <- currentTerminalName - - result <- E.try $ addConfigWidthMap cPath tName outputPath - - case result of - Left (e::E.SomeException) -> do - putStrLn $ "Error updating Vty configuration at " <> cPath <> ": " <> - show e - exitFailure - Right ConfigurationCreated -> do - putStrLn $ "Configuration file created: " <> cPath - Right ConfigurationModified -> do - putStrLn $ "Configuration file updated: " <> cPath - Right (ConfigurationConflict other) -> do - putStrLn $ "Configuration file not updated: uses a different table " <> - "for TERM=" <> tName <> ": " <> other - Right ConfigurationRedundant -> do - putStrLn $ "Configuration file not updated: configuration " <> - cPath <> " already uses table " <> outputPath <> - " for TERM=" <> tName diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,5 +1,5 @@ name: vty -version: 5.36 +version: 6.6 license: BSD3 license-file: LICENSE author: AUTHORS @@ -9,15 +9,10 @@ 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. - . - See the @vty-examples@ package as well as the program - @test/interactive_terminal_test.hs@ included in the @vty@ package for - examples on how to use the library. + be easy to use and to provide good support for common terminal types. . - Import the "Graphics.Vty" convenience module to get access to the core - parts of the library. + See the example programs in the @vty-crossplatform@ package examples + on how to use the library. . © 2006-2007 Stefan O'Rear; BSD3 license. . @@ -30,7 +25,9 @@ AUTHORS, CHANGELOG.md, LICENSE -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5 +tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, + GHC==9.0.2, GHC==9.2.8, GHC==9.4.8, GHC==9.6.6, GHC==9.8.4, GHC==9.10.1, + GHC==9.12.1 source-repository head type: git @@ -38,596 +35,52 @@ library default-language: Haskell2010 + include-dirs: cbits + hs-source-dirs: src + ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10 + ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10 build-depends: base >= 4.8 && < 5, blaze-builder >= 0.3.3.2 && < 0.5, bytestring, - containers, - deepseq >= 1.1 && < 1.5, - directory, - filepath >= 1.0 && < 2.0, - microlens < 0.4.14, + deepseq >= 1.1 && < 1.6, + microlens < 0.6, microlens-mtl, - microlens-th, - hashable >= 1.2, - mtl >= 1.1.1.0 && < 2.3, - parallel >= 2.2 && < 3.3, - parsec >= 2 && < 4, + mtl >= 1.1.1.0 && < 2.4, stm, - terminfo >= 0.3 && < 0.5, - transformers >= 0.3.0.0, text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, + utf8-string >= 0.3.1 && < 1.1, vector >= 0.7, binary, - ansi-terminal >= 0.10.3 + parsec, + filepath, + directory if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16, fail - exposed-modules: Graphics.Vty + exposed-modules: Graphics.Text.Width + Graphics.Vty Graphics.Vty.Attributes - Graphics.Vty.Attributes.Color + Graphics.Vty.Attributes.Color Graphics.Vty.Attributes.Color240 Graphics.Vty.Config + Graphics.Vty.Debug + Graphics.Vty.DisplayAttributes Graphics.Vty.Error Graphics.Vty.Image + Graphics.Vty.Image.Internal Graphics.Vty.Inline - Graphics.Vty.Inline.Unsafe Graphics.Vty.Input Graphics.Vty.Input.Events - Graphics.Vty.Picture Graphics.Vty.Output - Graphics.Text.Width - 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.Classify.Types - Graphics.Vty.Input.Classify.Parse - Graphics.Vty.Input.Loop - Graphics.Vty.Input.Mouse - Graphics.Vty.Input.Focus - Graphics.Vty.Input.Paste - Graphics.Vty.Input.Terminfo + Graphics.Vty.Output.Mock + Graphics.Vty.Picture Graphics.Vty.PictureToSpans Graphics.Vty.Span - Graphics.Vty.Output.Mock - Graphics.Vty.Output.Interface - Graphics.Vty.Output.XTermColor - Graphics.Vty.Output.TerminfoBased - Graphics.Vty.UnicodeWidthTable.Types Graphics.Vty.UnicodeWidthTable.IO - Graphics.Vty.UnicodeWidthTable.Query Graphics.Vty.UnicodeWidthTable.Install - - other-modules: Graphics.Vty.Debug.Image - Graphics.Vty.Input.Terminfo.ANSIVT - - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/get_tty_erase.c - cbits/mk_wcwidth.c - - include-dirs: cbits - - hs-source-dirs: src - - ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10 - - ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10 - -executable vty-build-width-table - main-is: BuildWidthTable.hs - hs-source-dirs: tools - - default-language: Haskell2010 - ghc-options: -threaded -Wall - - if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.16 - - build-depends: vty, - directory, - filepath, - base >= 4.8 && < 5 - -executable vty-mode-demo - main-is: ModeDemo.hs - hs-source-dirs: demos - - default-language: Haskell2010 - ghc-options: -threaded - - build-depends: vty, - base >= 4.8 && < 5, - containers, - microlens, - microlens-mtl, - mtl >= 1.1.1.0 && < 2.3 - -executable vty-demo - main-is: Demo.hs - hs-source-dirs: demos - - default-language: Haskell2010 - ghc-options: -threaded - - build-depends: vty, - base >= 4.8 && < 5, - containers, - microlens, - microlens-mtl, - mtl >= 1.1.1.0 && < 2.3 - -test-suite verify-using-mock-terminal - default-language: Haskell2010 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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-display-attributes - default-language: Haskell2010 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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-color-mapping - default-language: Haskell2010 - - type: detailed-0.9 - - hs-source-dirs: test - - test-module: VerifyColor240 - - other-modules: Verify - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - random >= 1.0 && < 1.3, - base >= 4.8 && < 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 - - 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.3, - base >= 4.8 && < 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 - - type: exitcode-stdio-1.0 - - hs-source-dirs: test - - main-is: VerifyUsingMockInput.hs - - other-modules: Verify.Graphics.Vty.Output - - build-depends: vty, - Cabal >= 1.20, - QuickCheck >= 2.7, - smallcheck == 1.*, - quickcheck-assertions >= 0.1.1, - test-framework == 0.8.*, - test-framework-smallcheck == 0.2.*, - random >= 1.0 && < 1.3, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - microlens, - microlens-mtl, - 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 - - type: exitcode-stdio-1.0 - - hs-source-dirs: test - - main-is: VerifyConfig.hs - - build-depends: vty, - Cabal >= 1.20, - 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.3, - base >= 4.8 && < 5, - bytestring, - containers, - deepseq >= 1.1 && < 1.5, - microlens, - microlens-mtl, - 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 + Graphics.Vty.UnicodeWidthTable.Main + Graphics.Vty.UnicodeWidthTable.Query + Graphics.Vty.UnicodeWidthTable.Types + c-sources: cbits/mk_wcwidth.c