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 pull request #1 from jtdaugherty/master

Browse Source 
sync
This commit is contained in:
Willem Van Onsem 2021-02-16 12:19:13 +01:00 committed by GitHub
commit 598b0148b6
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
16 changed files with 122 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
CHANGELOG.md
View File

@ -1,4 +1,32 @@
5.32
----
New features:
* Meta-PageUp and Meta-PageDown are now supported (#193)
* Added `supportsItalics` and `supportsStrikethrough` functions to
check for feature support in terminfo
Bug fixes:
* Detect utf-8 mode in `LANG` regardless of case (thanks Emeka
Nkurumeh)
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
----

2
src/Data/Sequence/Extra.hs
View File

@ -7,7 +7,7 @@ import Data.Sequence
import Control.Parallel.Strategies
instance NFData a => NFData (Seq a) where
rnf = \v -> rnf' (viewl v)
rnf = rnf' . viewl
where
rnf' EmptyL = ()
rnf' (a :< r) = rnf a >| rnf' (viewl r)

10
src/Data/Terminfo/Parse.hs
View File

@ -39,7 +39,7 @@ instance Show CapExpression where
++ " <= " ++ show (sourceString c)
where
hexDump :: [Word8] -> String
hexDump = foldr (\b s -> showHex b s) ""
hexDump = foldr showHex ""
instance NFData CapExpression where
rnf (CapExpression ops !_bytes !str !c !pOps)
@ -99,7 +99,7 @@ parseCapExpression capString =
Left e -> Left e
Right buildResults -> Right $ constructCapExpression capString buildResults
constructCapExpression :: [Char] -> BuildResults -> CapExpression
constructCapExpression :: String -> BuildResults -> CapExpression
constructCapExpression capString buildResults =
let expr = CapExpression
{ capOps = outCapOps buildResults
@ -336,9 +336,9 @@ data BuildResults = BuildResults
instance Semigroup BuildResults where
v0 <> v1
= BuildResults
{ outParamCount = (outParamCount v0) `max` (outParamCount v1)
, outCapOps = (outCapOps v0) <> (outCapOps v1)
, outParamOps = (outParamOps v0) <> (outParamOps v1)
{ outParamCount = outParamCount v0 `max` outParamCount v1
, outCapOps = outCapOps v0 <> outCapOps v1
, outParamOps = outParamOps v0 <> outParamOps v1
}
instance Monoid BuildResults where

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

@ -1,7 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
@ -43,6 +40,7 @@ module Graphics.Vty.Attributes
, withStyle
, standout
, italic
, strikethrough
, underline
, reverseVideo
, blink
@ -145,20 +143,14 @@ data FixedAttr = FixedAttr
-- | The style and color attributes can either be the terminal defaults.
-- Or be equivalent to the previously applied style. Or be a specific
-- value.
data MaybeDefault v where
Default :: MaybeDefault v
KeepCurrent :: MaybeDefault v
SetTo :: forall v . ( Eq v, Show v, Read v ) => !v -> MaybeDefault v
data MaybeDefault v = Default | KeepCurrent | SetTo !v
deriving (Eq, Read, Show)
instance (NFData v) => NFData (MaybeDefault v) where
rnf Default = ()
rnf KeepCurrent = ()
rnf (SetTo v) = rnf v
deriving instance Eq v => Eq (MaybeDefault v)
deriving instance Eq v => Show (MaybeDefault v)
deriving instance (Eq v, Show v, Read v) => Read (MaybeDefault v)
instance Eq v => Semigroup (MaybeDefault v) where
Default <> Default = Default
Default <> KeepCurrent = Default
@ -181,7 +173,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 +189,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 +201,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

6
src/Graphics/Vty/Input/Classify.hs
View File

@ -24,7 +24,7 @@ import qualified Data.Set as S( fromList, member )
import Data.Char
import Data.Word
compile :: ClassifyMap -> [Char] -> KClass
compile :: ClassifyMap -> String -> KClass
compile table = cl' where
-- take all prefixes and create a set of these
prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
@ -51,7 +51,7 @@ compile table = cl' where
-- neither a prefix or a full event.
[] -> Invalid
classify :: ClassifyMap -> [Char] -> KClass
classify :: ClassifyMap -> String -> KClass
classify table =
let standardClassifier = compile table
in \s -> case s of
@ -64,7 +64,7 @@ classify table =
c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
_ -> standardClassifier s
classifyUtf8 :: Char -> [Char] -> KClass
classifyUtf8 :: Char -> String -> KClass
classifyUtf8 c cs =
let n = utf8Length (ord c)
(codepoint,rest) = splitAt n (c:cs)

2
src/Graphics/Vty/Input/Classify/Types.hs
View File

@ -8,7 +8,7 @@ where
import Graphics.Vty.Input.Events
data KClass
= Valid Event [Char]
= Valid Event String
-- ^ A valid event was parsed. Any unused characters from the input
-- stream are also provided.
| Invalid

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

@ -224,7 +224,7 @@ logInitialInputState input classifyTable = case _inputDebug input of
Just h -> do
Config{ vmin = Just theVmin
, vtime = Just theVtime
, termName = Just theTerm, .. } <- readIORef $ _configRef input
, 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)

8
src/Graphics/Vty/Input/Terminfo.hs
View File

@ -74,7 +74,7 @@ visibleChars = [ ([x], EvKey (KChar x) [])
ctrlChars :: ClassifyMap
ctrlChars =
[ ([toEnum x],EvKey (KChar y) [MCtrl])
| (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_'])
| (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
]
@ -86,8 +86,10 @@ ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars
-- | Esc, meta-esc, delete, meta-delete, enter, meta-enter.
specialSupportKeys :: ClassifyMap
specialSupportKeys =
[ -- special support for ESC
("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])
[ ("\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])
-- Special support for Enter

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

@ -101,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
@ -191,6 +207,12 @@ outputPicture dc pic = do
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)

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

@ -48,6 +48,8 @@ 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

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

@ -68,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
@ -166,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
@ -203,7 +209,7 @@ reserveTerminal termName outFd = do
, assumedStateRef = newAssumedStateRef
-- I think fix would help assure tActual is the only
-- reference. I was having issues tho.
, mkDisplayContext = \tActual -> terminfoDisplayContext tActual terminfoCaps
, mkDisplayContext = (`terminfoDisplayContext` terminfoCaps)
}
sendCap s = sendCapToTerminal t (s terminfoCaps)
maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)
@ -235,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"
@ -270,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 ()
}
@ -348,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.
@ -375,6 +388,7 @@ terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs =
)
(sgrArgsForState state)
`mappend` setItalics
`mappend` setStrikethrough
`mappend` setColors
where
urlAttrs True = writeURLEscapes (urlDiff diffs)
@ -392,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)
@ -460,6 +479,7 @@ data DisplayAttrState = DisplayAttrState
{ applyStandout :: Bool
, applyUnderline :: Bool
, applyItalic :: Bool
, applyStrikethrough :: Bool
, applyReverseVideo :: Bool
, applyBlink :: Bool
, applyDim :: Bool
@ -496,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
@ -510,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
@ -526,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
@ -538,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

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

@ -17,6 +17,7 @@ import Blaze.ByteString.Builder.Word (writeWord8)
import Control.Monad (void, when)
import Control.Monad.Trans
import Data.Char (toLower)
import Data.IORef
import System.Posix.IO (fdWrite)
@ -92,9 +93,9 @@ reserveTerminal variant outFd = liftIO $ do
utf8Active :: IO Bool
utf8Active = do
let vars = ["LC_ALL", "LANG", "LC_CTYPE"]
results <- catMaybes <$> mapM getEnv vars
let matches = filter ("UTF8" `isInfixOf`) results <>
filter ("UTF-8" `isInfixOf`) results
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:

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

@ -82,6 +82,14 @@ data Cursor =
NoCursor
-- | Show the cursor at the given logical column accounting for
-- character width in the presence of multi-column characters.
| PositionOnly !Bool !Int !Int
-- | Set the terminal's cursor position without displaying a cursor
-- character. This is important for accessibility with screen
-- readers where a cursor position needs to be reported but we may
-- not want to show a block cursor in that location for cosmetic
-- reasons. The boolean argument indicates whether the positioning
-- should be absolute as with 'AbsoluteCursor' ('True') or logical
-- as with 'Cursor' ('False').
| Cursor !Int !Int
-- | Show the cursor at the given absolute terminal column and row
| AbsoluteCursor !Int !Int

2
src/Graphics/Vty/PictureToSpans.hs
View File

@ -81,7 +81,7 @@ combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)
combinedOpsForLayers pic r
| regionWidth r == 0 || regionHeight r == 0 = MVector.new 0
| otherwise = do
layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)
layerOps <- mapM (`buildSpans` layer) (picLayers pic)
case layerOps of
[] -> fail "empty picture"
[ops] -> substituteSkips (picBackground pic) ops

4
vty.cabal
View File

@ -1,5 +1,5 @@
name: vty
version: 5.30
version: 5.32
license: BSD3
license-file: LICENSE
author: AUTHORS
@ -45,7 +45,7 @@ library
deepseq >= 1.1 && < 1.5,
directory,
filepath >= 1.0 && < 2.0,
microlens < 0.4.12,
microlens < 0.4.13,
microlens-mtl,
microlens-th,
hashable >= 1.2,