diff --git a/CHANGELOG.md b/CHANGELOG.md index 36e7f95..e06e831 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/src/Data/Sequence/Extra.hs b/src/Data/Sequence/Extra.hs index cab9b9c..70a9c3e 100644 --- a/src/Data/Sequence/Extra.hs +++ b/src/Data/Sequence/Extra.hs @@ -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) diff --git a/src/Data/Terminfo/Parse.hs b/src/Data/Terminfo/Parse.hs index d2be1c5..f4a1d61 100644 --- a/src/Data/Terminfo/Parse.hs +++ b/src/Data/Terminfo/Parse.hs @@ -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 diff --git a/src/Graphics/Vty/Attributes.hs b/src/Graphics/Vty/Attributes.hs index 9cdba7c..929f8aa 100644 --- a/src/Graphics/Vty/Attributes.hs +++ b/src/Graphics/Vty/Attributes.hs @@ -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 diff --git a/src/Graphics/Vty/DisplayAttributes.hs b/src/Graphics/Vty/DisplayAttributes.hs index c2f0936..240f132 100644 --- a/src/Graphics/Vty/DisplayAttributes.hs +++ b/src/Graphics/Vty/DisplayAttributes.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Classify.hs b/src/Graphics/Vty/Input/Classify.hs index b498a45..4895ddf 100644 --- a/src/Graphics/Vty/Input/Classify.hs +++ b/src/Graphics/Vty/Input/Classify.hs @@ -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) diff --git a/src/Graphics/Vty/Input/Classify/Types.hs b/src/Graphics/Vty/Input/Classify/Types.hs index 4e3ac1b..ab19a4a 100644 --- a/src/Graphics/Vty/Input/Classify/Types.hs +++ b/src/Graphics/Vty/Input/Classify/Types.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Loop.hs b/src/Graphics/Vty/Input/Loop.hs index e106256..da23d68 100644 --- a/src/Graphics/Vty/Input/Loop.hs +++ b/src/Graphics/Vty/Input/Loop.hs @@ -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) diff --git a/src/Graphics/Vty/Input/Terminfo.hs b/src/Graphics/Vty/Input/Terminfo.hs index 0a6a7cf..26cd022 100644 --- a/src/Graphics/Vty/Input/Terminfo.hs +++ b/src/Graphics/Vty/Input/Terminfo.hs @@ -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 diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs index 42ff289..8321333 100644 --- a/src/Graphics/Vty/Output/Interface.hs +++ b/src/Graphics/Vty/Output/Interface.hs @@ -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) diff --git a/src/Graphics/Vty/Output/Mock.hs b/src/Graphics/Vty/Output/Mock.hs index c33d93f..733314c 100644 --- a/src/Graphics/Vty/Output/Mock.hs +++ b/src/Graphics/Vty/Output/Mock.hs @@ -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 diff --git a/src/Graphics/Vty/Output/TerminfoBased.hs b/src/Graphics/Vty/Output/TerminfoBased.hs index 4c722ef..26a1552 100644 --- a/src/Graphics/Vty/Output/TerminfoBased.hs +++ b/src/Graphics/Vty/Output/TerminfoBased.hs @@ -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 diff --git a/src/Graphics/Vty/Output/XTermColor.hs b/src/Graphics/Vty/Output/XTermColor.hs index 7864e11..9a17a11 100644 --- a/src/Graphics/Vty/Output/XTermColor.hs +++ b/src/Graphics/Vty/Output/XTermColor.hs @@ -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: diff --git a/src/Graphics/Vty/Picture.hs b/src/Graphics/Vty/Picture.hs index f872929..f8e4c60 100644 --- a/src/Graphics/Vty/Picture.hs +++ b/src/Graphics/Vty/Picture.hs @@ -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 diff --git a/src/Graphics/Vty/PictureToSpans.hs b/src/Graphics/Vty/PictureToSpans.hs index 17a6f87..9994bb8 100644 --- a/src/Graphics/Vty/PictureToSpans.hs +++ b/src/Graphics/Vty/PictureToSpans.hs @@ -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 diff --git a/vty.cabal b/vty.cabal index 441b91f..113fa39 100644 --- a/vty.cabal +++ b/vty.cabal @@ -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,