ilyakooo0/vty
1
0
Fork 0
mirror of https://github.com/ilyakooo0/vty.git synced 2024-11-29 08:49:40 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' of github.com:jtdaugherty/vty into master

Browse Source
This commit is contained in:
Jonathan Daugherty 2020-11-04 18:11:48 -08:00
commit 0b4fa6410b
14 changed files with 208 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
CHANGELOG.md
View File

@ -1,4 +1,48 @@
5.31
----
New features and API changes:
* Added support for strikethrough mode. This change adds a new
`strikethrough` `Style` value and uses the `smxx` and `rmxx`
Terminfo capabilities to activate and deactivate strikethrough mode,
respectively. If the terminfo does not report those capabilities,
this style is ignored.
* `Output`: added the `setDisplayBounds` field to set the output
dimensions of the output handle; added an implementation of this for
the `TerminfoBased` backend.
Other changes:
* The C prototype for `vty_c_get_window_size` in `gwinsz.h` was fixed.
5.30
----
New features:
* Added `Graphics.Vty.setWindowTitle` to emit an escape
sequence to set the window title, provide the terminal emulator
accepts Xterm-style title sequences. For details, see:
https://tldp.org/HOWTO/Xterm-Title-3.html
5.29
----
API changes:
* The Input type got a new field, 'restoreInputState'. This field
allows the end user to have direct access to the logic needed to
restore the terminal's input state flags. Prior to having this field,
this state restoration logic could only be invoked as part of calling
'shutdownInput', but since that function does other things (like
killing threads) it is not advisable to call it repeatedly (which is
necessary in the use case this change is intended to support). This
can be called directly to restore the input state flags as needed,
although this is not required if 'shutdown' (or 'shutdownInput') is
called.
Other changes:
* attributeControl: explicitly enable the ICRNL terminal mode flag (see
#187 and c572ad).
5.28.2
------

2
LICENSE
View File

@ -1,3 +1,5 @@
BSD 3-Clause License
Copyright Stefan O'Rear 2006, Corey O'Connor 2008, Corey O'Connor 2009
All rights reserved.

19
cbits/gwinsz.c
View File

@ -1,9 +1,18 @@
#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;
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);
}
}

3
cbits/gwinsz.h
View File

@ -1 +1,2 @@
unsigned long vty_c_get_window_size(void);
unsigned long vty_c_get_window_size(int fd);
unsigned long vty_c_set_window_size(int fd, unsigned long val);

25
src/Graphics/Vty.hs
View File

@ -33,6 +33,7 @@
module Graphics.Vty
( Vty(..)
, mkVty
, setWindowTitle
, Mode(..)
, module Graphics.Vty.Config
, module Graphics.Vty.Input
@ -54,6 +55,9 @@ 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
@ -224,3 +228,24 @@ internalMkVty input out = do
, shutdown = shutdownIo
, isShutdown = shutdownStatus
}
-- | 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

8
src/Graphics/Vty/Attributes.hs
View File

@ -43,6 +43,7 @@ module Graphics.Vty.Attributes
, withStyle
, standout
, italic
, strikethrough
, underline
, reverseVideo
, blink
@ -181,7 +182,7 @@ instance Eq v => Monoid ( MaybeDefault v ) where
-- if the style attribute should not be applied.
type Style = Word8
-- | The 7 possible style attributes:
-- | Valid style attributes include:
--
-- * standout
--
@ -197,9 +198,11 @@ type Style = Word8
--
-- * italic
--
-- * strikethrough (via the smxx/rmxx terminfo capabilities)
--
-- (The invisible, protect, and altcharset display attributes some
-- terminals support are not supported via VTY.)
standout, underline, reverseVideo, blink, dim, bold, italic :: Style
standout, underline, reverseVideo, blink, dim, bold, italic, strikethrough :: Style
standout = 0x01
underline = 0x02
reverseVideo = 0x04
@ -207,6 +210,7 @@ blink = 0x08
dim = 0x10
bold = 0x20
italic = 0x40
strikethrough = 0x80
defaultStyleMask :: Style
defaultStyleMask = 0x00

3
src/Graphics/Vty/DisplayAttributes.hs
View File

@ -96,6 +96,8 @@ data StyleStateChange
| RemoveStandout
| ApplyItalic
| RemoveItalic
| ApplyStrikethrough
| RemoveStrikethrough
| ApplyUnderline
| RemoveUnderline
| ApplyReverseVideo
@ -144,6 +146,7 @@ diffStyles prev cur
[ styleDiff standout ApplyStandout RemoveStandout
, styleDiff underline ApplyUnderline RemoveUnderline
, styleDiff italic ApplyItalic RemoveItalic
, styleDiff strikethrough ApplyStrikethrough RemoveStrikethrough
, styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo
, styleDiff blink ApplyBlink RemoveBlink
, styleDiff dim ApplyDim RemoveDim

26
src/Graphics/Vty/Input.hs
View File

@ -143,22 +143,8 @@ import Data.Monoid ((<>))
-- bytes comes from 'classifyMapForTerm' which is then overridden by
-- the the applicable entries from the configuration's 'inputMap'.
--
-- The terminal device is configured with the attributes:
--
-- * IXON disabled: disables software flow control on outgoing data.
-- This stops the process from being suspended if the output terminal
-- cannot keep up.
--
-- * Raw mode is used for input.
--
-- * ISIG disabled (enables keyboard combinations that result in
-- signals)
--
-- * ECHO disabled (input is not echoed to the output)
--
-- * ICANON disabled (canonical mode (line mode) input is not used)
--
-- * IEXTEN disabled (extended functions are disabled)
-- 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
@ -168,7 +154,7 @@ inputForConfig config@Config{ termName = Just termName
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, unsetAttrs) <- attributeControl termFd
setAttrs
input <- initInput config activeInputMap
let pokeIO = Catch $ do
@ -177,11 +163,15 @@ inputForConfig config@Config{ termName = Just termName
atomically $ writeTChan (input^.eventChannel) (EvResize e e)
_ <- 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
unsetAttrs
restore
, restoreInputState = restoreInputState input >> restore
}
inputForConfig config = (<> config) <$> standardIOConfig >>= inputForConfig

50
src/Graphics/Vty/Input/Loop.hs
View File

@ -52,9 +52,14 @@ data Input = Input
-- 'nextEvent' this will not refresh the display if the next event
-- is an 'EvResize'.
_eventChannel :: TChan Event
-- | Shuts down the input processing. This should return the
-- terminal input state to before he input initialized.
-- | 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
@ -171,15 +176,47 @@ runInputProcessorLoop classifyTable input = do
<*> pure (classify classifyTable)
runReaderT (evalStateT loopInputProcessor s0) input
-- | Construct two IO actions: one to configure the terminal for Vty and
-- one to restore the terminal mode flags to the values they had at the
-- time this function was called.
--
-- This function constructs a configuration action to clear the
-- following terminal mode flags:
--
-- * IXON disabled: disables software flow control on outgoing data.
-- This stops the process from being suspended if the output terminal
-- cannot keep up.
--
-- * Raw mode is used for input.
--
-- * ISIG (enables keyboard combinations that result in
-- signals)
--
-- * ECHO (input is not echoed to the output)
--
-- * ICANON (canonical mode (line mode) input is not used)
--
-- * IEXTEN (extended functions are disabled)
--
-- The configuration action also explicitly sets these flags:
--
-- * ICRNL (input carriage returns are mapped to newlines)
attributeControl :: Fd -> IO (IO (), IO ())
attributeControl fd = do
original <- getTerminalAttributes fd
let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
, EnableEcho, ProcessInput, ExtendedFunctions
]
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)
return (setAttrs, unsetAttrs)
logInitialInputState :: Input -> ClassifyMap -> IO()
logInitialInputState input classifyTable = case _inputDebug input of
@ -203,6 +240,7 @@ initInput config classifyTable = do
applyConfig fd config
stopSync <- newEmptyMVar
input <- Input <$> atomically newTChan
<*> pure (return ())
<*> pure (return ())
<*> newIORef config
<*> maybe (return Nothing)

18
src/Graphics/Vty/Output/Interface.hs
View File

@ -73,6 +73,8 @@ data Output = Output
-- | 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.
@ -99,6 +101,22 @@ data Output = Output
, 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
}
displayContext :: Output -> DisplayRegion -> IO DisplayContext

3
src/Graphics/Vty/Output/Mock.hs
View File

@ -48,6 +48,9 @@ mockTerminal r = liftIO $ do
, releaseDisplay = return ()
, ringTerminalBell = return ()
, supportsBell = return False
, supportsItalics = return False
, supportsStrikethrough = return False
, setDisplayBounds = const $ return ()
, displayBounds = return r
, outputByteBuffer = \bytes -> do
putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"

39
src/Graphics/Vty/Output/TerminfoBased.hs
View File

@ -10,10 +10,12 @@
-- 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
@ -66,6 +68,8 @@ data DisplayAttrCaps = DisplayAttrCaps
, exitStandout :: Maybe CapExpression
, enterItalic :: Maybe CapExpression
, exitItalic :: Maybe CapExpression
, enterStrikethrough :: Maybe CapExpression
, exitStrikethrough :: Maybe CapExpression
, enterUnderline :: Maybe CapExpression
, exitUnderline :: Maybe CapExpression
, enterReverseVideo :: Maybe CapExpression
@ -164,6 +168,10 @@ reserveTerminal termName outFd = 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
@ -174,6 +182,8 @@ reserveTerminal termName outFd = do
, releaseDisplay = do
maybeSendCap rmcup []
maybeSendCap cnorm []
, setDisplayBounds = \(w, h) ->
setWindowSize outFd (w, h)
, displayBounds = do
rawSize <- getWindowSize outFd
case rawSize of
@ -231,6 +241,8 @@ currentDisplayAttrCaps ti
<*> probeCap ti "rmso"
<*> probeCap ti "sitm"
<*> probeCap ti "ritm"
<*> probeCap ti "smxx"
<*> probeCap ti "rmxx"
<*> probeCap ti "smul"
<*> probeCap ti "rmul"
<*> probeCap ti "rev"
@ -244,6 +256,13 @@ 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
@ -259,7 +278,11 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
, writeSetAttr = terminfoWriteSetAttr dc terminfoCaps
, writeDefaultAttr = \urlsEnabled ->
writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend`
(if urlsEnabled then writeURLEscapes EndLink else mempty)
(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 ()
}
@ -337,6 +360,7 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
)
(sgrArgsForState state)
`mappend` setItalics
`mappend` setStrikethrough
`mappend` setColors
-- Otherwise the display colors are not changing or changing
-- between two non-default points.
@ -364,6 +388,7 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
)
(sgrArgsForState state)
`mappend` setItalics
`mappend` setStrikethrough
`mappend` setColors
where
urlAttrs True = writeURLEscapes (urlDiff diffs)
@ -381,6 +406,11 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
, 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 -> writeCapExpr (setForeColor terminfoCaps)
@ -449,6 +479,7 @@ data DisplayAttrState = DisplayAttrState
{ applyStandout :: Bool
, applyUnderline :: Bool
, applyItalic :: Bool
, applyStrikethrough :: Bool
, applyReverseVideo :: Bool
, applyBlink :: Bool
, applyDim :: Bool
@ -485,6 +516,8 @@ reqDisplayCapSeqFor caps s diffs
-- 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
@ -499,6 +532,8 @@ reqDisplayCapSeqFor caps s diffs
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
@ -515,6 +550,7 @@ stateForStyle s = DisplayAttrState
{ applyStandout = isStyleSet standout
, applyUnderline = isStyleSet underline
, applyItalic = isStyleSet italic
, applyStrikethrough = isStyleSet strikethrough
, applyReverseVideo = isStyleSet reverseVideo
, applyBlink = isStyleSet blink
, applyDim = isStyleSet dim
@ -527,6 +563,7 @@ styleToApplySeq s = concat
[ applyIfRequired ApplyStandout standout
, applyIfRequired ApplyUnderline underline
, applyIfRequired ApplyItalic italic
, applyIfRequired ApplyStrikethrough strikethrough
, applyIfRequired ApplyReverseVideo reverseVideo
, applyIfRequired ApplyBlink blink
, applyIfRequired ApplyDim dim

3
src/Graphics/Vty/Output/XTermColor.hs
View File

@ -113,9 +113,6 @@ setUtf8CharSet, setDefaultCharSet :: String
setUtf8CharSet = "\ESC%G"
setDefaultCharSet = "\ESC%@"
-- | I think xterm is broken: Reseting the background color as the first
-- bytes serialized on a new line does not effect the background color
-- xterm uses to clear the line. Which is used *after* the next newline.
xtermInlineHack :: Output -> IO ()
xtermInlineHack t = do
let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"

2
vty.cabal
View File

@ -1,5 +1,5 @@
name: vty
version: 5.28.2
version: 5.31
license: BSD3
license-file: LICENSE
author: AUTHORS