vty 5.39 → 6.0
raw patch · 37 files changed
+917/−3785 lines, 37 filesdep −ansi-terminaldep −containersdep −terminfodep ~basedep ~deepseqdep ~filepath
Dependencies removed: ansi-terminal, containers, terminfo, transformers, unix, vty
Dependency ranges changed: base, deepseq, filepath, microlens, mtl, parsec
Files
- CHANGELOG.md +121/−0
- README.md +39/−73
- cbits/get_tty_erase.c +0/−18
- cbits/gwinsz.c +0/−18
- cbits/set_term_timing.c +0/−13
- demos/Demo.hs +0/−91
- demos/ModeDemo.hs +0/−55
- src/Data/Terminfo/Eval.hs +0/−133
- src/Data/Terminfo/Parse.hs +0/−348
- src/Graphics/Vty.hs +84/−90
- src/Graphics/Vty/Attributes/Color.hs +9/−33
- src/Graphics/Vty/Config.hs +93/−189
- src/Graphics/Vty/Debug.hs +3/−0
- src/Graphics/Vty/Inline.hs +2/−4
- src/Graphics/Vty/Inline/Unsafe.hs +0/−63
- src/Graphics/Vty/Input.hs +26/−216
- src/Graphics/Vty/Input/Classify.hs +0/−110
- src/Graphics/Vty/Input/Classify/Parse.hs +0/−61
- src/Graphics/Vty/Input/Classify/Types.hs +0/−25
- src/Graphics/Vty/Input/Events.hs +8/−8
- src/Graphics/Vty/Input/Focus.hs +0/−50
- src/Graphics/Vty/Input/Loop.hs +0/−249
- src/Graphics/Vty/Input/Mouse.hs +0/−164
- src/Graphics/Vty/Input/Paste.hs +0/−41
- src/Graphics/Vty/Input/Terminfo.hs +0/−194
- src/Graphics/Vty/Input/Terminfo/ANSIVT.hs +0/−91
- src/Graphics/Vty/Output.hs +322/−74
- src/Graphics/Vty/Output/Interface.hs +0/−331
- src/Graphics/Vty/Output/Mock.hs +2/−2
- src/Graphics/Vty/Output/TerminfoBased.hs +0/−606
- src/Graphics/Vty/Output/XTermColor.hs +0/−131
- src/Graphics/Vty/UnicodeWidthTable/Main.hs +180/−0
- src/Graphics/Vty/UnicodeWidthTable/Query.hs +12/−21
- tools/BuildWidthTable.hs +0/−144
- tools/CrashFix.hs +0/−29
- tools/CrashTest.hs +0/−8
- vty.cabal +16/−102
CHANGELOG.md view
@@ -1,4 +1,125 @@ +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.++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`.+ * The `VtyUserConfig` type's fields got a `config` field name prefix.+* 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 ----
README.md view
@@ -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,20 +143,6 @@ 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@@ -171,25 +156,6 @@ - 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. # Further Reading
− cbits/get_tty_erase.c
@@ -1,18 +0,0 @@-#include <termios.h>-#include <stdio.h>-#include <unistd.h>-#include <stdlib.h>--// 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;- }-}
− cbits/gwinsz.c
@@ -1,18 +0,0 @@-#include <sys/ioctl.h>--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);- }-}
− cbits/set_term_timing.c
@@ -1,13 +0,0 @@-#include <termios.h>-#include <stdio.h>-#include <unistd.h>-#include <stdlib.h>--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);-}
− demos/Demo.hs
@@ -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 []-
− demos/ModeDemo.hs
@@ -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
− src/Data/Terminfo/Eval.hs
@@ -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
− src/Data/Terminfo/Parse.hs
@@ -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
src/Graphics/Vty.hs view
@@ -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
src/Graphics/Vty/Attributes/Color.hs view
@@ -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@@ -120,22 +112,6 @@ | 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- black, red, green, yellow, blue, magenta, cyan, white :: Color black = ISOColor 0 red = ISOColor 1@@ -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
src/Graphics/Vty/Config.hs view
@@ -1,16 +1,13 @@ {-# 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 -- -- == @debugLog@@@ -73,27 +70,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,8 +103,8 @@ import Control.Applicative hiding (many) -import Control.Exception (catch, IOException, Exception(..), throwIO)-import Control.Monad (liftM, guard, void, when)+import Control.Exception (catch, IOException)+import Control.Monad (liftM, guard, void) import qualified Data.ByteString as BS #if !(MIN_VERSION_base(4,8,0))@@ -120,10 +113,8 @@ #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif-import Data.Typeable (Typeable) import Graphics.Vty.Input.Events-import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode) import GHC.Generics @@ -132,112 +123,67 @@ ) import System.Environment (lookupEnv) import System.FilePath ((</>), takeDirectory)-import System.IO (Handle, BufferMode(..), hReady, hSetBuffering, hGetChar, stdin)-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.+ }+ 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+ } -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+ } #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif@@ -254,7 +200,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 =<<@@ -280,38 +227,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- flushInput stdin- 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@@ -339,7 +269,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)@@ -347,25 +277,25 @@ 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+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]@@ -415,32 +345,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@@ -454,8 +374,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@@ -481,26 +401,10 @@ 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 return ConfigurationModified--flushInput :: Handle -> IO ()-flushInput h = do- hSetBuffering h NoBuffering- whileM $ consume h--whileM :: (Monad m) => m Bool -> m ()-whileM act = do- continue <- act- when continue $ whileM act--consume :: Handle -> IO Bool-consume h = do- avail <- hReady h- when avail $ void $ hGetChar h- return avail
src/Graphics/Vty/Debug.hs view
@@ -1,10 +1,13 @@ -- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Debug ( MockWindow(..)+ , SpanConstructLog , regionForWindow , allSpansHaveWidth , spanOpsAffectedColumns , spanOpsAffectedRows+ , rowOpsAffectedColumns+ , isSetAttr ) where
src/Graphics/Vty/Inline.hs view
@@ -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
− src/Graphics/Vty/Inline/Unsafe.hs
@@ -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
src/Graphics/Vty/Input.hs view
@@ -1,222 +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.+ }
− src/Graphics/Vty/Input/Classify.hs
@@ -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
− src/Graphics/Vty/Input/Classify/Parse.hs
@@ -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
− src/Graphics/Vty/Input/Classify/Types.hs
@@ -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)
src/Graphics/Vty/Input/Events.hs view
@@ -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,13 @@ -- 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)+ deriving (Eq, Show, Read, Ord, Generic) instance NFData Button @@ -74,7 +74,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 +83,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.
− src/Graphics/Vty/Input/Focus.hs
@@ -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
− src/Graphics/Vty/Input/Loop.hs
@@ -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)
− src/Graphics/Vty/Input/Mouse.hs
@@ -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
− src/Graphics/Vty/Input/Paste.hs
@@ -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
− src/Graphics/Vty/Input/Terminfo.hs
@@ -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) [])
− src/Graphics/Vty/Input/Terminfo/ANSIVT.hs
@@ -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- ]
src/Graphics/Vty/Output.hs view
@@ -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
− src/Graphics/Vty/Output/Interface.hs
@@ -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
src/Graphics/Vty/Output/Mock.hs view
@@ -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)-
− src/Graphics/Vty/Output/TerminfoBased.hs
@@ -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]
− src/Graphics/Vty/Output/XTermColor.hs
@@ -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
+ src/Graphics/Vty/UnicodeWidthTable/Main.hs view
@@ -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 "<none>" (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
src/Graphics/Vty/UnicodeWidthTable/Query.hs view
@@ -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
− tools/BuildWidthTable.hs
@@ -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 "<none>" (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
− tools/CrashFix.hs
@@ -1,29 +0,0 @@-module Main (main) where--import Control.Monad (when, void)-import Graphics.Vty-import System.IO--main :: IO ()-main = do- flushInput stdin- vty <- mkVty defaultConfig- shutdown vty--flushInput :: Handle -> IO ()-flushInput h = do- mode <- hGetBuffering h- hSetBuffering h NoBuffering- whileM $ consume h- hSetBuffering h mode--whileM :: (Monad m) => m Bool -> m ()-whileM act = do- continue <- act- when continue $ whileM act--consume :: Handle -> IO Bool-consume h = do- ava <- hReady h- when ava $ void $ hGetChar h- pure ava
− tools/CrashTest.hs
@@ -1,8 +0,0 @@-module Main (main) where--import Graphics.Vty--main :: IO ()-main = do- vty <- mkVty defaultConfig- shutdown vty
vty.cabal view
@@ -1,5 +1,5 @@ name: vty-version: 5.39+version: 6.0 license: BSD3 license-file: LICENSE author: AUTHORS@@ -29,7 +29,7 @@ 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.5, GHC==9.6.2 source-repository head type: git@@ -44,132 +44,46 @@ 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, 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, 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-crash-test- main-is: CrashTest.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-crash-fix- main-is: CrashFix.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--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