vty 5.34 → 5.35
raw patch · 28 files changed
+440/−222 lines, 28 files
Files
- CHANGELOG.md +32/−0
- demos/Demo.hs +11/−3
- src/Data/Terminfo/Parse.hs +2/−1
- src/Graphics/Vty.hs +12/−8
- src/Graphics/Vty/Attributes/Color.hs +66/−2
- src/Graphics/Vty/Config.hs +11/−2
- src/Graphics/Vty/Input.hs +1/−2
- src/Graphics/Vty/Input/Classify.hs +53/−29
- src/Graphics/Vty/Input/Classify/Parse.hs +10/−7
- src/Graphics/Vty/Input/Classify/Types.hs +7/−1
- src/Graphics/Vty/Input/Events.hs +15/−6
- src/Graphics/Vty/Input/Focus.hs +15/−13
- src/Graphics/Vty/Input/Loop.hs +41/−22
- src/Graphics/Vty/Input/Mouse.hs +17/−15
- src/Graphics/Vty/Input/Paste.hs +16/−24
- src/Graphics/Vty/Input/Terminfo.hs +1/−1
- src/Graphics/Vty/Output.hs +4/−3
- src/Graphics/Vty/Output/Interface.hs +23/−17
- src/Graphics/Vty/Output/Mock.hs +2/−1
- src/Graphics/Vty/Output/TerminfoBased.hs +64/−31
- src/Graphics/Vty/Output/XTermColor.hs +23/−12
- test/VerifyEmptyImageProps.hs +1/−0
- test/VerifyEvalTerminfoCaps.hs +1/−0
- test/VerifyImageOps.hs +1/−0
- test/VerifyOutput.hs +6/−1
- test/VerifyParseTerminfoCaps.hs +1/−0
- test/VerifyUsingMockInput.hs +1/−0
- vty.cabal +3/−21
CHANGELOG.md view
@@ -1,4 +1,36 @@ +5.35+----++New features:+ * Add support for 24-bit color (thanks @u-quark). This change+ updates Vty to look at the `COLORTERM` environment variable that is+ conventionally used to advertise support for truecolor escape+ sequences. The change also updates the Vty demo to demonstrate+ 24-bit colors. This change also adds a new data type, `ColorMode`,+ to represent the color mode in use, as well as an `Output` interface+ field, `outputColorMode`, to track the active color mode and use it+ to clamp emitted color escape sequences to the active color range.++API changes:+ * All types in `Graphics.Vty.Input.Events` now have strict constructor+ fields.+ * Internal events are now wrapped in a new `InternalEvent` type to+ improve how signal handling is done. This change modifies the `Input`+ type's event channel API to produce `InternalEvents`, not `Events`.+ The new `InternalEvent` either wraps `Event` with the `InputEvent`+ constructor (the previous behavior) or indicates that Vty resumed+ after handling a signal using the `ResumeAfterSignal` constructor.+ This change avoids the previous use of `EvResize` with lazy exception+ arguments as a sentinel value for `ResumeAfterSignal`.++Other enhancements:+ * Bracketed paste parsing performance has been greatly improved thanks+ to benchmarking and optimization work by @iphydf. As part of that+ work, Vty now uses bytestrings rather than Strings internally when+ parsing input to look for events.+ * The `\b` value is now interpreted as `KBS` (thanks @vglfr)+ 5.34 ----
demos/Demo.hs view
@@ -32,6 +32,7 @@ , "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 pallete."+ , "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"@@ -42,12 +43,19 @@ , "¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯ ¯\\_(ツ)_/¯" ] +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]- splitColorImages [] = []- splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is)) colorbox_16 :: Image colorbox_16 = border <|> column0 <|> border <|> column1 <|> border <|> column2 <|> border@@ -70,7 +78,7 @@ "Press ESC to exit. Events for keys below." eventLog <- foldMap (string defAttr) <$> get let pic = picForImage (info <-> eventLog)- `addToBottom` (introText <-> colorbox_240 <|> colorbox_16)+ `addToBottom` (introText <-> colorbox_240 <|> colorbox_16 <|> fullcolorbox) vty <- ask liftIO $ update vty pic
src/Data/Terminfo/Parse.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -funbox-strict-fields -O #-}+{-# OPTIONS_HADDOCK hide #-} module Data.Terminfo.Parse ( module Data.Terminfo.Parse
src/Graphics/Vty.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Vty provides interfaces for both terminal input and terminal -- output.@@ -47,6 +48,7 @@ import Graphics.Vty.Config import Graphics.Vty.Input+import Graphics.Vty.Input.Events import Graphics.Vty.Output import Graphics.Vty.Output.Interface import Graphics.Vty.Picture@@ -208,16 +210,18 @@ maybe (return ()) innerUpdate mPic let mkResize = uncurry EvResize <$> displayBounds out++ translateInternalEvent ResumeAfterSignal = mkResize+ translateInternalEvent (InputEvent e) = return e+ gkey = do- k <- atomically $ readTChan $ _eventChannel input- case k of- (EvResize _ _) -> mkResize- _ -> return k+ e <- atomically $ readTChan $ _eventChannel input+ translateInternalEvent e gkey' = do- k <- atomically $ tryReadTChan $ _eventChannel input- case k of- (Just (EvResize _ _)) -> Just <$> mkResize- _ -> return k+ mEv <- atomically $ tryReadTChan $ _eventChannel input+ case mEv of+ Just e -> Just <$> translateInternalEvent e+ Nothing -> return Nothing return $ Vty { update = innerUpdate , nextEvent = gkey
src/Graphics/Vty/Attributes/Color.hs view
@@ -1,9 +1,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-} module Graphics.Vty.Attributes.Color ( Color(..)+ , ColorMode(..) + -- * Detecting Terminal Color Support+ , detectColorMode+ -- ** Fixed Colors -- | Standard 8-color ANSI terminal color codes. --@@ -32,7 +38,10 @@ , brightCyan , brightWhite -- ** Creating Colors From RGB+ , linearColor+ , srgbColor , rgbColor+ , color240 , module Graphics.Vty.Attributes.Color240 ) where@@ -40,7 +49,12 @@ 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.@@ -95,9 +109,33 @@ -- terminfo but I don't know it. -- -- Seriously, terminal color support is INSANE.-data Color = ISOColor !Word8 | Color240 !Word8+data Color = ISOColor !Word8 | Color240 !Word8 | RGBColor !Word8 !Word8 !Word8 deriving ( Eq, Show, Read, Generic, NFData ) +data ColorMode+ = NoColor+ | ColorMode8+ | ColorMode16+ | ColorMode240 !Word8+ | FullColor+ deriving ( Eq, Show )++detectColorMode :: String -> IO ColorMode+detectColorMode termName' = do+ term <- catch (Just <$> Terminfo.setupTerm termName')+ (\(_ :: Terminfo.SetupTermError) -> return Nothing)+ let getCap cap = term >>= \t -> Terminfo.getCapability t cap+ termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors")+ colorterm <- lookupEnv "COLORTERM"+ return $ if+ | termColors < 8 -> NoColor+ | termColors < 16 -> ColorMode8+ | termColors == 16 -> ColorMode16+ | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16)+ | colorterm == Just "truecolor" -> FullColor+ | colorterm == Just "24bit" -> FullColor+ | otherwise -> ColorMode240 240+ black, red, green, yellow, blue, magenta, cyan, white :: Color black = ISOColor 0 red = ISOColor 1@@ -119,9 +157,35 @@ brightCyan = ISOColor 14 brightWhite = ISOColor 15 +linearColor :: Integral i => i -> i -> i -> Color+linearColor r g b = RGBColor r' g' b'+ where+ r' = fromIntegral (clamp r) :: Word8+ g' = fromIntegral (clamp g) :: Word8+ b' = fromIntegral (clamp b) :: Word8+ clamp = min 255 . max 0 +srgbColor :: Integral i => i -> i -> i -> Color+srgbColor r g b =+ -- srgb to rgb transformation as described at+ -- https://en.wikipedia.org/wiki/SRGB#The_reverse_transformation+ --+ -- TODO: it may be worth translating this to a lookup table, as with color240+ let shrink n = fromIntegral n / 255 :: Double+ -- called gamma^-1 in wiki+ gamma u+ | u <= 0.04045 = u/12.92+ | otherwise = ((u + 0.055) / 1.055) ** 2.4+ -- TODO: this is a slightly inaccurate conversion. is it worth doing proterly?+ expand n = round (255 * n)+ convert = expand . gamma . shrink+ in RGBColor (convert r) (convert g) (convert b)++color240 :: Integral i => i -> i -> i -> Color+color240 r g b = Color240 (rgbColorToColor240 r g b)+ -- | Create a Vty 'Color' (in the 240 color set) from an RGB triple. -- This function is lossy in the sense that we only internally support 240 colors but the -- #RRGGBB format supports 16^3 colors. rgbColor :: Integral i => i -> i -> i -> Color-rgbColor r g b = Color240 (rgbColorToColor240 r g b)+rgbColor = color240
src/Graphics/Vty/Config.hs view
@@ -3,6 +3,7 @@ {-# 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 -- application's use of Vty.@@ -54,7 +55,7 @@ -- If a debug log is requested then vty will output the current input -- table to the log in the above format. A workflow for using this is -- to set @VTY_DEBUG_LOG@. Run the application. Check the debug log for--- incorrect mappings. Add corrected mappings to @$HOME/.vty/config@.+-- incorrect mappings. Add corrected mappings to @$HOME\/.vty\/config@. -- -- = Unicode Character Width Maps --@@ -122,6 +123,7 @@ import Data.Typeable (Typeable) import Graphics.Vty.Input.Events+import Graphics.Vty.Attributes.Color (ColorMode(..), detectColorMode) import GHC.Generics @@ -193,6 +195,9 @@ -- 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) @@ -214,6 +219,7 @@ , termWidthMaps = termWidthMaps c1 <|> termWidthMaps c0 , allowCustomUnicodeWidthTables = allowCustomUnicodeWidthTables c1 <|> allowCustomUnicodeWidthTables c0+ , colorMode = colorMode c1 <|> colorMode c0 } instance Monoid Config where@@ -229,6 +235,7 @@ , termName = Nothing , termWidthMaps = [] , allowCustomUnicodeWidthTables = Nothing+ , colorMode = Nothing } #if !(MIN_VERSION_base(4,11,0)) mappend = (<>)@@ -284,7 +291,8 @@ mb <- lookupEnv termVariable case mb of Nothing -> throwIO VtyMissingTermEnvVar- Just t ->+ Just t -> do+ mcolorMode <- detectColorMode t return defaultConfig { vmin = Just 1 , mouseMode = Just False@@ -293,6 +301,7 @@ , inputFd = Just stdInput , outputFd = Just stdOutput , termName = Just t+ , colorMode = Just mcolorMode } parseConfigFile :: FilePath -> IO Config
src/Graphics/Vty/Input.hs view
@@ -158,9 +158,8 @@ setAttrs input <- initInput config activeInputMap let pokeIO = Catch $ do- let e = error "vty internal failure: this value should not propagate to users" setAttrs- atomically $ writeTChan (input^.eventChannel) (EvResize e e)+ atomically $ writeTChan (input^.eventChannel) ResumeAfterSignal _ <- installHandler windowChange pokeIO Nothing _ <- installHandler continueProcess pokeIO Nothing
src/Graphics/Vty/Input/Classify.hs view
@@ -1,10 +1,11 @@ {-# OPTIONS_HADDOCK hide #-}--- This makes a kind of tri. Has space efficiency issues with large+-- 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 @@ -16,25 +17,39 @@ import Codec.Binary.UTF8.Generic (decode) -import Data.List (inits)+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.Char import Data.Word -compile :: ClassifyMap -> String -> KClass+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 . inits . fst) table+ prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table maxValidInputLength = maximum (map (length . fst) table)- eventForInput = M.fromList table- cl' [] = Prefix+ 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 []+ Just e -> Valid e BS8.empty Nothing -> case S.member inputBlock prefixSet of True -> Prefix -- look up progressively smaller tails of the input@@ -45,40 +60,49 @@ -- H: There will always be one match. The prefixSet -- contains, by definition, all prefixes of an event. False ->- let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock+ 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 (drop (length s) inputBlock)+ (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock) -- neither a prefix or a full event. [] -> Invalid -classify :: ClassifyMap -> String -> KClass-classify table =- let standardClassifier = compile table- in \s -> case s of- _ | bracketedPasteStarted s ->+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 s- else Prefix- _ | isMouseEvent s -> classifyMouseEvent s- _ | isFocusEvent s -> classifyFocusEvent s- c:cs | ord c >= 0xC2 -> classifyUtf8 c cs- _ -> standardClassifier s+ then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)+ else Chunk+ process ClassifierInChunk{} _ = Invalid -classifyUtf8 :: Char -> String -> KClass+classifyUtf8 :: Word8 -> ByteString -> KClass classifyUtf8 c cs =- let n = utf8Length (ord c)- (codepoint,rest) = splitAt n (c:cs)+ let n = utf8Length c+ (codepoint,rest) = BS8.splitAt (n - 1) cs codepoint8 :: [Word8]- codepoint8 = map (fromIntegral . ord) codepoint+ codepoint8 = c:BS.unpack codepoint in case decode codepoint8 of- _ | n < length codepoint -> Prefix- Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest+ _ | n < BS.length codepoint + 1 -> Prefix+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest -- something bad happened; just ignore and continue.- Nothing -> Invalid+ Nothing -> Invalid -utf8Length :: (Num t, Ord a, Num a) => a -> t+utf8Length :: Word8 -> Int utf8Length c | c < 0x80 = 1 | c < 0xE0 = 2
src/Graphics/Vty/Input/Classify/Parse.hs view
@@ -16,12 +16,15 @@ import Control.Monad.Trans.Maybe import Control.Monad.State -type Parser a = MaybeT (State String) a+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 :: String -> Parser Event -> KClass+runParser :: ByteString -> Parser Event -> KClass runParser s parser = case runState (runMaybeT parser) s of (Nothing, _) -> Invalid@@ -36,9 +39,9 @@ -- return '123' and consume those characters. readInt :: Parser Int readInt = do- s <- get+ s <- BS8.unpack <$> get case (reads :: ReadS Int) s of- [(i, rest)] -> put rest >> return i+ [(i, rest)] -> put (BS8.pack rest) >> return i _ -> failParse -- | Read a character from the input stream. If one cannot be read (e.g.@@ -46,9 +49,9 @@ readChar :: Parser Char readChar = do s <- get- case s of- c:rest -> put rest >> return c- _ -> failParse+ 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.
src/Graphics/Vty/Input/Classify/Types.hs view
@@ -1,5 +1,6 @@ -- | 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(..) )@@ -7,8 +8,10 @@ import Graphics.Vty.Input.Events +import Data.ByteString.Char8 (ByteString)+ data KClass- = Valid Event String+ = Valid Event ByteString -- ^ A valid event was parsed. Any unused characters from the input -- stream are also provided. | Invalid@@ -16,4 +19,7 @@ | 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
@@ -1,4 +1,5 @@ {-# Language DeriveGeneric #-}+{-# Language StrictData #-} module Graphics.Vty.Input.Events where import Control.DeepSeq@@ -15,10 +16,10 @@ -- -- * Actually, support for most of these but KEsc, KChar, KBS, and -- KEnter vary by terminal and keyboard.-data Key = KEsc | KChar Char | KBS | KEnter+data Key = KEsc | KChar {-# UNPACK #-} Char | KBS | KEnter | KLeft | KRight | KUp | KDown | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter- | KFun Int | KBackTab | KPrtScr | KPause | KIns+ | KFun {-# UNPACK #-} Int | KBackTab | KPrtScr | KPause | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu deriving (Eq,Show,Read,Ord,Generic) @@ -51,10 +52,8 @@ -- without specifying which one; in that case, Nothing is provided. -- Otherwise Just the button released is included in the event. | EvResize Int Int- -- ^ If read from 'eventChannel' this is the size at the time of the- -- signal. If read from 'nextEvent' this is the size at the time the- -- event was processed by Vty. Typically these are the same, but if- -- somebody is resizing the terminal quickly they can be different.+ -- The terminal window was resized and the size is provided in the+ -- integer fields (width, height). | EvPaste ByteString -- ^ A paste event occurs when a bracketed paste input sequence is -- received. For terminals that support bracketed paste mode, these@@ -72,3 +71,13 @@ instance NFData Event type ClassifyMap = [(String,Event)]++-- | 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.+ | InputEvent Event+ -- ^ An input event was received.
src/Graphics/Vty/Input/Focus.hs view
@@ -11,30 +11,32 @@ import Graphics.Vty.Input.Classify.Parse import Control.Monad.State-import Data.List (isPrefixOf) +import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.Char8 (ByteString)+ -- | These sequences set xterm-based terminals to send focus event -- sequences.-requestFocusEvents :: String-requestFocusEvents = "\ESC[?1004h"+requestFocusEvents :: ByteString+requestFocusEvents = BS8.pack "\ESC[?1004h" -- | These sequences disable focus events.-disableFocusEvents :: String-disableFocusEvents = "\ESC[?1004l"+disableFocusEvents :: ByteString+disableFocusEvents = BS8.pack "\ESC[?1004l" -- | Does the specified string begin with a focus event?-isFocusEvent :: String -> Bool-isFocusEvent s = isPrefixOf focusIn s ||- isPrefixOf focusOut s+isFocusEvent :: ByteString -> Bool+isFocusEvent s = BS8.isPrefixOf focusIn s ||+ BS8.isPrefixOf focusOut s -focusIn :: String-focusIn = "\ESC[I"+focusIn :: ByteString+focusIn = BS8.pack "\ESC[I" -focusOut :: String-focusOut = "\ESC[O"+focusOut :: ByteString+focusOut = BS8.pack "\ESC[O" -- | Attempt to classify an input string as a focus event.-classifyFocusEvent :: String -> KClass+classifyFocusEvent :: ByteString -> KClass classifyFocusEvent s = runParser s $ do when (not $ isFocusEvent s) failParse
src/Graphics/Vty/Input/Loop.hs view
@@ -1,8 +1,9 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}+{-# 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@@ -33,12 +34,15 @@ import Control.Monad.State.Class (MonadState, modify) import Control.Monad.Trans.Reader (ReaderT(..)) -import Data.Char+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, peekArray, Ptr )+import Foreign (allocaArray) import Foreign.C.Types (CInt(..))+import Foreign.Ptr (Ptr, castPtr) import System.IO import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))@@ -51,7 +55,7 @@ { -- | Channel of events direct from input processing. Unlike -- 'nextEvent' this will not refresh the display if the next event -- is an 'EvResize'.- _eventChannel :: TChan Event+ _eventChannel :: TChan InternalEvent -- | Shuts down the input processing. As part of shutting down the -- input, this should also restore the input state. , shutdownInput :: IO ()@@ -76,10 +80,11 @@ makeLenses ''InputBuffer data InputState = InputState- { _unprocessedBytes :: String+ { _unprocessedBytes :: ByteString+ , _classifierState :: ClassifierState , _appliedConfig :: Config , _inputBuffer :: InputBuffer- , _classifier :: String -> KClass+ , _classifier :: ClassifierState -> ByteString -> KClass } makeLenses ''InputState@@ -104,20 +109,20 @@ dropInvalid loopInputProcessor -addBytesToProcess :: String -> InputM ()+addBytesToProcess :: ByteString -> InputM () addBytesToProcess block = unprocessedBytes <>= block emit :: Event -> InputM () emit event = do logMsg $ "parsed event: " ++ show event- view eventChannel >>= liftIO . atomically . flip writeTChan 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 String+readFromDevice :: InputM ByteString readFromDevice = do newConfig <- view configRef >>= liftIO . readIORef oldConfig <- use appliedConfig@@ -137,9 +142,10 @@ threadWaitRead fd bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes) if bytesRead > 0- then map (chr . fromIntegral) <$> peekArray (fromIntegral bytesRead) bufferPtr- else return []- when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep+ 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 ()@@ -150,30 +156,43 @@ parseEvent :: InputM Event parseEvent = do c <- use classifier+ s <- use classifierState b <- use unprocessedBytes- case c b of+ 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+ _ -> mzero dropInvalid :: InputM () dropInvalid = do c <- use classifier+ s <- use classifierState b <- use unprocessedBytes- when (c b == Invalid) $ do- logMsg "dropping input bytes"- 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 [] <$> readIORef (_configRef input)- <*> pure (InputBuffer bufferPtr bufferSize)- <*> pure (classify classifyTable)+ s0 <- InputState BS8.empty ClassifierStart+ <$> readIORef (_configRef input)+ <*> pure (InputBuffer bufferPtr bufferSize)+ <*> pure (classify classifyTable) runReaderT (evalStateT loopInputProcessor s0) input -- | Construct two IO actions: one to configure the terminal for Vty and
src/Graphics/Vty/Input/Mouse.hs view
@@ -15,10 +15,12 @@ import Graphics.Vty.Input.Classify.Parse import Control.Monad.State-import Data.List (isPrefixOf) 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')@@ -32,28 +34,28 @@ -- | These sequences set xterm-based terminals to send mouse event -- sequences.-requestMouseEvents :: String-requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h"+requestMouseEvents :: ByteString+requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h" -- | These sequences disable mouse events.-disableMouseEvents :: String-disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l"+disableMouseEvents :: ByteString+disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l" -- | Does the specified string begin with a mouse event?-isMouseEvent :: String -> Bool+isMouseEvent :: ByteString -> Bool isMouseEvent s = isSGREvent s || isNormalEvent s -isSGREvent :: String -> Bool-isSGREvent = isPrefixOf sgrPrefix+isSGREvent :: ByteString -> Bool+isSGREvent = BS8.isPrefixOf sgrPrefix -sgrPrefix :: String-sgrPrefix = "\ESC[M"+sgrPrefix :: ByteString+sgrPrefix = BS8.pack "\ESC[M" -isNormalEvent :: String -> Bool-isNormalEvent = isPrefixOf normalPrefix+isNormalEvent :: ByteString -> Bool+isNormalEvent = BS8.isPrefixOf normalPrefix -normalPrefix :: String-normalPrefix = "\ESC[<"+normalPrefix :: ByteString+normalPrefix = BS8.pack "\ESC[<" -- Modifier bits: shiftBit :: Int@@ -88,7 +90,7 @@ hasBitSet val bit = val .&. bit > 0 -- | Attempt to lassify an input string as a mouse event.-classifyMouseEvent :: String -> KClass+classifyMouseEvent :: ByteString -> KClass classifyMouseEvent s = runParser s $ do when (not $ isMouseEvent s) failParse
src/Graphics/Vty/Input/Paste.hs view
@@ -9,41 +9,33 @@ where import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.Char8 (ByteString) import Graphics.Vty.Input.Events import Graphics.Vty.Input.Classify.Types -import Data.List (isPrefixOf, isInfixOf)--bracketedPasteStart :: String-bracketedPasteStart = "\ESC[200~"+bracketedPasteStart :: ByteString+bracketedPasteStart = BS8.pack "\ESC[200~" -bracketedPasteEnd :: String-bracketedPasteEnd = "\ESC[201~"+bracketedPasteEnd :: ByteString+bracketedPasteEnd = BS8.pack "\ESC[201~" -- | Does the input start a bracketed paste?-bracketedPasteStarted :: String -> Bool-bracketedPasteStarted = isPrefixOf bracketedPasteStart+bracketedPasteStarted :: ByteString -> Bool+bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart -- | Does the input contain a complete bracketed paste?-bracketedPasteFinished :: String -> Bool-bracketedPasteFinished = isInfixOf bracketedPasteEnd+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 :: String -> KClass+parseBracketedPaste :: ByteString -> KClass parseBracketedPaste s =- let (p, rest) = takeUntil (drop (length bracketedPasteStart) s) bracketedPasteEnd- rest' = if bracketedPasteEnd `isPrefixOf` rest- then drop (length bracketedPasteEnd) rest- else rest- in Valid (EvPaste $ BS8.pack p) rest'--takeUntil :: (Eq a) => [a] -> [a] -> ([a],[a])-takeUntil [] _ = ([], [])-takeUntil cs sub- | length cs < length sub = (cs, [])- | take (length sub) cs == sub = ([], drop (length sub) cs)- | otherwise = let (pre, suf) = takeUntil (tail cs) sub- in (head cs:pre, suf)+ 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 view
@@ -91,7 +91,7 @@ -- special support for ESC , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta]) -- Special support for backspace- , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta])+ , ("\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
src/Graphics/Vty/Output.hs view
@@ -58,11 +58,12 @@ -- * If TERM contains "xterm" or "screen", use XTermColor. -- * otherwise use the TerminfoBased driver. outputForConfig :: Config -> IO Output-outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do+outputForConfig Config{ outputFd = Just fd, termName = Just termName+ , colorMode = Just colorMode, .. } = do t <- if "xterm" `isPrefixOf` termName || "screen" `isPrefixOf` termName- then XTermColor.reserveTerminal termName fd+ then XTermColor.reserveTerminal termName fd colorMode -- Not an xterm-like terminal. try for generic terminfo.- else TerminfoBased.reserveTerminal termName fd+ else TerminfoBased.reserveTerminal termName fd colorMode case mouseMode of Just s -> setMode t Mouse s
src/Graphics/Vty/Output/Interface.hs view
@@ -3,6 +3,7 @@ {-# 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@@ -78,9 +79,6 @@ , displayBounds :: IO DisplayRegion -- | Output the bytestring to the terminal device. , outputByteBuffer :: BS.ByteString -> IO ()- -- | Specifies the maximum number of colors supported by the- -- context.- , contextColorCount :: Int -- | Specifies whether the cursor can be shown / hidden. , supportsCursorVisibility :: Bool -- | Indicates support for terminal modes for this output device.@@ -116,6 +114,8 @@ -- 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@@ -309,17 +309,23 @@ where clampColor Default = Default clampColor KeepCurrent = KeepCurrent- clampColor (SetTo c) = clampColor' c- clampColor' (ISOColor v)- | contextColorCount t < 8 = Default- | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)- | otherwise = SetTo $ ISOColor v- clampColor' (Color240 v)- -- Should we choose closest ISO color?- | contextColorCount t < 8 = Default- | contextColorCount t < 16 = Default- | contextColorCount t <= 256 = SetTo $ Color240 v- | otherwise- = let p :: Double = fromIntegral v / 240.0- v' = floor $ p * (fromIntegral $ contextColorCount t)- in SetTo $ Color240 v'+ 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
@@ -11,6 +11,7 @@ where import Graphics.Vty.Image (DisplayRegion)+import Graphics.Vty.Attributes.Color (ColorMode(ColorMode16)) import Graphics.Vty.Output.Interface import Blaze.ByteString.Builder.Word (writeWord8)@@ -55,12 +56,12 @@ , outputByteBuffer = \bytes -> do putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes" writeIORef outRef $ UTF8.fromRep bytes- , contextColorCount = 16 , supportsCursorVisibility = True , supportsMode = const False , setMode = const $ const $ return () , getModeStatus = const $ return False , assumedStateRef = newAssumedStateRef+ , outputColorMode = ColorMode16 , mkDisplayContext = \tActual rActual -> return $ DisplayContext { contextRegion = rActual , contextDevice = tActual
src/Graphics/Vty/Output/TerminfoBased.hs view
@@ -25,7 +25,7 @@ import Graphics.Vty.DisplayAttributes import Graphics.Vty.Output.Interface -import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable)+import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8) import Data.IORef import Data.Maybe (isJust, isNothing, fromJust)@@ -49,7 +49,6 @@ , cup :: CapExpression , cnorm :: Maybe CapExpression , civis :: Maybe CapExpression- , supportsNoColors :: Bool , useAltColorMap :: Bool , setForeColor :: CapExpression , setBackColor :: CapExpression@@ -104,28 +103,28 @@ -- -- * Providing independent string capabilities for all display -- attributes.-reserveTerminal :: String -> Fd -> IO Output-reserveTerminal termName outFd = do+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 (noColors, useAlt, setForeCap)+ let (useAlt, setForeCap) = case msetaf of- Just setaf -> (False, False, setaf)+ Just setaf -> (False, setaf) Nothing -> case msetf of- Just setf -> (False, True, setf)- Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)+ Just setf -> (True, setf)+ Nothing -> (True, error $ "no fore color support for terminal " ++ termName) msetab <- probeCap ti "setab" msetb <- probeCap ti "setb"- let set_back_cap+ let setBackCap = case msetab of+ Just setab -> setab Nothing -> case msetb of Just setb -> setb Nothing -> error $ "no back color support for terminal " ++ termName- Just setab -> setab hyperlinkModeStatus <- newIORef False newAssumedStateRef <- newIORef initialAssumedState@@ -151,10 +150,9 @@ <*> requireCap ti "cup" <*> probeCap ti "cnorm" <*> probeCap ti "civis"- <*> pure noColors <*> pure useAlt <*> pure setForeCap- <*> pure set_back_cap+ <*> pure setBackCap <*> requireCap ti "sgr0" <*> requireCap ti "clear" <*> requireCap ti "el"@@ -194,17 +192,12 @@ when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer " ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen ++ " Please report this bug to vty project."- , contextColorCount- = case supportsNoColors terminfoCaps of- False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of- Nothing -> 8- Just v -> toEnum v- True -> 1 , 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)@@ -302,7 +295,7 @@ -- | 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+-- 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.@@ -341,9 +334,9 @@ -- 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+ True -> do case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)- (fixedStyle attr )+ (fixedStyle attr) (styleToApplySeq $ fixedStyle attr) of -- only way to reset a color to the defaults EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled@@ -376,9 +369,9 @@ -- applied states. EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps `mappend`- writeColorDiff setForeColor (foreColorDiff diffs)+ writeColorDiff Foreground (foreColorDiff diffs) `mappend`- writeColorDiff setBackColor (backColorDiff diffs)+ writeColorDiff Background (backColorDiff diffs) -- implicitly resets the colors to the defaults SetState state -> writeCapExpr (fromJust $ setAttrStates $ displayAttrCaps terminfoCaps@@ -410,21 +403,53 @@ | otherwise = mempty setColors = (case fixedForeColor attr of- Just c -> writeCapExpr (setForeColor terminfoCaps)- [toEnum $ colorMap c]+ Just c -> writeColor Foreground c Nothing -> mempty) `mappend` (case fixedBackColor attr of- Just c -> writeCapExpr (setBackColor terminfoCaps)- [toEnum $ colorMap c]+ Just c -> writeColor Background c Nothing -> mempty)- writeColorDiff _f NoColorChange+ writeColorDiff _side NoColorChange = mempty- writeColorDiff _f ColorToDefault+ writeColorDiff _side ColorToDefault = error "ColorToDefault is not a possible case for applyColorDiffs"- writeColorDiff f (SetColor c)- = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]+ 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. --@@ -433,6 +458,10 @@ 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 --@@ -449,6 +478,10 @@ 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.
src/Graphics/Vty/Output/XTermColor.hs view
@@ -10,18 +10,23 @@ 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 (fdWrite)-import System.Posix.Types (Fd)+import System.Posix.IO (fdWriteBuf)+import System.Posix.Types (ByteCount, Fd) import System.Posix.Env (getEnv) import Data.List (isInfixOf)@@ -31,9 +36,15 @@ 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 -> m Output-reserveTerminal variant outFd = liftIO $ do+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.@@ -41,7 +52,7 @@ utf8a <- utf8Active when (not utf8a) $ flushedPut setUtf8CharSet- t <- TerminfoBased.reserveTerminal variant' outFd+ t <- TerminfoBased.reserveTerminal variant' outFd colorMode mouseModeStatus <- newIORef False focusModeStatus <- newIORef False@@ -100,19 +111,19 @@ -- | Enable bracketed paste mode: -- http://cirw.in/blog/bracketed-paste-enableBracketedPastes :: String-enableBracketedPastes = "\ESC[?2004h"+enableBracketedPastes :: ByteString+enableBracketedPastes = BS8.pack "\ESC[?2004h" -- | Disable bracketed paste mode:-disableBracketedPastes :: String-disableBracketedPastes = "\ESC[?2004l"+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 :: String-setUtf8CharSet = "\ESC%G"-setDefaultCharSet = "\ESC%@"+setUtf8CharSet, setDefaultCharSet :: ByteString+setUtf8CharSet = BS8.pack "\ESC%G"+setDefaultCharSet = BS8.pack "\ESC%@" xtermInlineHack :: Output -> IO () xtermInlineHack t = do
test/VerifyEmptyImageProps.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} module VerifyEmptyImageProps where import Verify
test/VerifyEvalTerminfoCaps.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-} module VerifyEvalTerminfoCaps where import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)
test/VerifyImageOps.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} module VerifyImageOps where import Graphics.Vty.Attributes
test/VerifyOutput.hs view
@@ -1,6 +1,7 @@ -- We setup the environment to envoke certain terminals of interest. -- This assumes appropriate definitions exist in the current environment -- for the terminals of interest.+{-# LANGUAGE ScopedTypeVariables #-} module VerifyOutput where import Verify@@ -34,7 +35,11 @@ smokeTestTerm :: String -> Image -> IO Result smokeTestTerm termName i = do nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags- t <- outputForConfig $ defaultConfig { outputFd = Just nullOut, termName = Just termName }+ t <- outputForConfig $ defaultConfig+ { outputFd = Just nullOut+ , termName = Just termName+ , colorMode = Just NoColor+ } -- putStrLn $ "context color count: " ++ show (contextColorCount t) reserveDisplay t dc <- displayContext t (100,100)
test/VerifyParseTerminfoCaps.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-} module VerifyParseTerminfoCaps where import Prelude hiding ( catch )
test/VerifyUsingMockInput.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} -- Generate some input bytes and delays between blocks of input bytes. -- Verify the events produced are as expected. module Main where
vty.cabal view
@@ -1,5 +1,5 @@ name: vty-version: 5.34+version: 5.35 license: BSD3 license-file: LICENSE author: AUTHORS@@ -117,8 +117,6 @@ hs-source-dirs: src - default-extensions: ScopedTypeVariables- ghc-options: -O2 -funbox-strict-fields -Wall -fspec-constr -fspec-constr-count=10 ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fspec-constr -fspec-constr-count=10@@ -143,7 +141,6 @@ hs-source-dirs: demos default-language: Haskell2010- default-extensions: ScopedTypeVariables ghc-options: -threaded build-depends: vty,@@ -158,7 +155,6 @@ hs-source-dirs: demos default-language: Haskell2010- default-extensions: ScopedTypeVariables ghc-options: -threaded build-depends: vty,@@ -170,7 +166,6 @@ test-suite verify-using-mock-terminal default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -203,7 +198,6 @@ test-suite verify-terminal default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -236,7 +230,6 @@ test-suite verify-display-attributes default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -268,7 +261,6 @@ test-suite verify-empty-image-props default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -294,7 +286,6 @@ test-suite verify-eval-terminfo-caps default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -323,7 +314,6 @@ test-suite verify-image-ops default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -351,7 +341,6 @@ test-suite verify-image-trans default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -379,7 +368,6 @@ test-suite verify-inline default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -406,7 +394,6 @@ test-suite verify-parse-terminfo-caps default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -435,7 +422,6 @@ test-suite verify-simple-span-generation default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -467,7 +453,6 @@ test-suite verify-crop-span-generation default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -499,7 +484,6 @@ test-suite verify-layers-span-generation default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -530,7 +514,6 @@ test-suite verify-color-mapping default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -556,7 +539,6 @@ test-suite verify-utf8-width default-language: Haskell2010- default-extensions: ScopedTypeVariables type: detailed-0.9 @@ -582,7 +564,6 @@ test-suite verify-using-mock-input default-language: Haskell2010- default-extensions: ScopedTypeVariables type: exitcode-stdio-1.0 @@ -590,6 +571,8 @@ main-is: VerifyUsingMockInput.hs + other-modules: Verify.Graphics.Vty.Output+ build-depends: vty, Cabal >= 1.20, QuickCheck >= 2.7,@@ -616,7 +599,6 @@ test-suite verify-config default-language: Haskell2010- default-extensions: ScopedTypeVariables type: exitcode-stdio-1.0