diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,203 @@ +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 ---- 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,52 +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: - - Please ensure that the examples and test suites build along with the - library by running `build.sh` in the repository. + - 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,91 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Main where - -import Graphics.Vty - -import Control.Applicative hiding ((<|>)) -import Control.Arrow -import Control.Monad -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/Data/Terminfo/Eval.hs b/src/Data/Terminfo/Eval.hs deleted file mode 100644 --- a/src/Data/Terminfo/Eval.hs +++ /dev/null @@ -1,133 +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 -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 @@ -192,6 +168,6 @@ -- | Create a Vty 'Color' (in the 240 color set) from an RGB triple. -- 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 16^3 colors. +-- supports 256^3 colors. rgbColor :: Integral i => i -> i -> i -> Color rgbColor = color240 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,10 +1,13 @@ -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Debug ( MockWindow(..) + , SpanConstructLog , regionForWindow , allSpansHaveWidth , spanOpsAffectedColumns , spanOpsAffectedRows + , rowOpsAffectedColumns + , isSetAttr ) where 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,63 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -module Graphics.Vty.Inline.Unsafe - ( withOutput - , withVty - ) -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,221 +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 - , attributeControl + ( 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 -import System.Posix.Terminal -import System.Posix.Types (Fd(..)) - -#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 - - return $ input - { shutdownInput = do - shutdownInput input - _ <- installHandler windowChange Ignore Nothing - _ <- installHandler continueProcess Ignore Nothing - restore - , restoreInputState = restoreInputState input >> restore - } -inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig +import Control.Concurrent.STM (TChan) --- | 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) +-- | 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 @@ -29,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 @@ -37,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 @@ -74,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 @@ -83,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,50 +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 -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,249 +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 - ( Input(..) - , eventChannel - - , initInput - ) -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.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 - -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,164 +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 -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,194 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -module Graphics.Vty.Input.Terminfo - ( classifyMapForTerm - , specialSupportKeys - , capsClassifyMap - , keysFromCapsTable - , universalTable - , visibleChars - ) -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,91 +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 - ( classifyTable - ) -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,92 +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 starts with "xterm", "screen" or "tmux", 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 isXtermLike termName - then XTermColor.reserveTerminal termName fd colorMode - -- Not an xterm-like terminal. try for generic terminfo. - else TerminfoBased.reserveTerminal termName fd colorMode - - case mouseMode of - Just s -> setMode t Mouse s - Nothing -> return () - - case bracketedPasteMode of - Just s -> setMode t BracketedPaste s - Nothing -> return () +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL - return t -outputForConfig config = (<> config) <$> standardIOConfig >>= outputForConfig +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 -isXtermLike :: String -> Bool -isXtermLike termName = - any (`isPrefixOf` termName) xtermLikeTerminalNamePrefixes +-- | 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) -xtermLikeTerminalNamePrefixes :: [String] -xtermLikeTerminalNamePrefixes = - [ "xterm" - , "screen" - , "tmux" - , "rxvt" - ] +-- | 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. -- @@ -117,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,7 +3,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -- | Transforms an image into rows of operations. module Graphics.Vty.PictureToSpans @@ -19,7 +18,6 @@ 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 ) @@ -55,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 @@ -154,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 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/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.38 +version: 6.6 license: BSD3 license-file: LICENSE author: AUTHORS @@ -11,12 +11,8 @@ vty is terminal GUI library in the niche of ncurses. It is intended to be easy to use and to provide good support for common terminal types. . - See the @vty-examples@ package as well as the program - @examples/interactive_terminal_test.hs@ included in the @vty@ - repository for examples on how to use the library. - . - 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. . @@ -29,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 @@ -44,106 +42,45 @@ 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, mtl >= 1.1.1.0 && < 2.4, - parsec >= 2 && < 4, stm, - terminfo >= 0.3 && < 0.5, - transformers >= 0.3.0.0, text >= 0.11.3, - unix, - utf8-string >= 0.3 && < 1.1, + 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.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 - 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.Input.Terminfo.ANSIVT - c-sources: cbits/gwinsz.c - cbits/set_term_timing.c - cbits/get_tty_erase.c - cbits/mk_wcwidth.c - -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: base, - vty, - directory, - filepath - -executable vty-mode-demo - main-is: ModeDemo.hs - hs-source-dirs: demos - default-language: Haskell2010 - ghc-options: -threaded - build-depends: base, - vty, - containers, - microlens, - microlens-mtl, - mtl - -executable vty-demo - main-is: Demo.hs - hs-source-dirs: demos - default-language: Haskell2010 - ghc-options: -threaded - build-depends: base, - vty, - containers, - microlens, - microlens-mtl, - mtl + Graphics.Vty.UnicodeWidthTable.Main + Graphics.Vty.UnicodeWidthTable.Query + Graphics.Vty.UnicodeWidthTable.Types + c-sources: cbits/mk_wcwidth.c