diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/demos/Demo.hs b/demos/Demo.hs --- a/demos/Demo.hs +++ b/demos/Demo.hs @@ -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 diff --git a/src/Data/Terminfo/Parse.hs b/src/Data/Terminfo/Parse.hs --- a/src/Data/Terminfo/Parse.hs +++ b/src/Data/Terminfo/Parse.hs @@ -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 diff --git a/src/Graphics/Vty.hs b/src/Graphics/Vty.hs --- a/src/Graphics/Vty.hs +++ b/src/Graphics/Vty.hs @@ -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 diff --git a/src/Graphics/Vty/Attributes/Color.hs b/src/Graphics/Vty/Attributes/Color.hs --- a/src/Graphics/Vty/Attributes/Color.hs +++ b/src/Graphics/Vty/Attributes/Color.hs @@ -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 diff --git a/src/Graphics/Vty/Config.hs b/src/Graphics/Vty/Config.hs --- a/src/Graphics/Vty/Config.hs +++ b/src/Graphics/Vty/Config.hs @@ -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 diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs --- a/src/Graphics/Vty/Input.hs +++ b/src/Graphics/Vty/Input.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Classify.hs b/src/Graphics/Vty/Input/Classify.hs --- a/src/Graphics/Vty/Input/Classify.hs +++ b/src/Graphics/Vty/Input/Classify.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Classify/Parse.hs b/src/Graphics/Vty/Input/Classify/Parse.hs --- a/src/Graphics/Vty/Input/Classify/Parse.hs +++ b/src/Graphics/Vty/Input/Classify/Parse.hs @@ -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. diff --git a/src/Graphics/Vty/Input/Classify/Types.hs b/src/Graphics/Vty/Input/Classify/Types.hs --- a/src/Graphics/Vty/Input/Classify/Types.hs +++ b/src/Graphics/Vty/Input/Classify/Types.hs @@ -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) diff --git a/src/Graphics/Vty/Input/Events.hs b/src/Graphics/Vty/Input/Events.hs --- a/src/Graphics/Vty/Input/Events.hs +++ b/src/Graphics/Vty/Input/Events.hs @@ -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. diff --git a/src/Graphics/Vty/Input/Focus.hs b/src/Graphics/Vty/Input/Focus.hs --- a/src/Graphics/Vty/Input/Focus.hs +++ b/src/Graphics/Vty/Input/Focus.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Loop.hs b/src/Graphics/Vty/Input/Loop.hs --- a/src/Graphics/Vty/Input/Loop.hs +++ b/src/Graphics/Vty/Input/Loop.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Mouse.hs b/src/Graphics/Vty/Input/Mouse.hs --- a/src/Graphics/Vty/Input/Mouse.hs +++ b/src/Graphics/Vty/Input/Mouse.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Paste.hs b/src/Graphics/Vty/Input/Paste.hs --- a/src/Graphics/Vty/Input/Paste.hs +++ b/src/Graphics/Vty/Input/Paste.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Terminfo.hs b/src/Graphics/Vty/Input/Terminfo.hs --- a/src/Graphics/Vty/Input/Terminfo.hs +++ b/src/Graphics/Vty/Input/Terminfo.hs @@ -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 diff --git a/src/Graphics/Vty/Output.hs b/src/Graphics/Vty/Output.hs --- a/src/Graphics/Vty/Output.hs +++ b/src/Graphics/Vty/Output.hs @@ -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 diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs --- a/src/Graphics/Vty/Output/Interface.hs +++ b/src/Graphics/Vty/Output/Interface.hs @@ -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 diff --git a/src/Graphics/Vty/Output/Mock.hs b/src/Graphics/Vty/Output/Mock.hs --- a/src/Graphics/Vty/Output/Mock.hs +++ b/src/Graphics/Vty/Output/Mock.hs @@ -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 diff --git a/src/Graphics/Vty/Output/TerminfoBased.hs b/src/Graphics/Vty/Output/TerminfoBased.hs --- a/src/Graphics/Vty/Output/TerminfoBased.hs +++ b/src/Graphics/Vty/Output/TerminfoBased.hs @@ -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. diff --git a/src/Graphics/Vty/Output/XTermColor.hs b/src/Graphics/Vty/Output/XTermColor.hs --- a/src/Graphics/Vty/Output/XTermColor.hs +++ b/src/Graphics/Vty/Output/XTermColor.hs @@ -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 diff --git a/test/VerifyEmptyImageProps.hs b/test/VerifyEmptyImageProps.hs --- a/test/VerifyEmptyImageProps.hs +++ b/test/VerifyEmptyImageProps.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module VerifyEmptyImageProps where import Verify diff --git a/test/VerifyEvalTerminfoCaps.hs b/test/VerifyEvalTerminfoCaps.hs --- a/test/VerifyEvalTerminfoCaps.hs +++ b/test/VerifyEvalTerminfoCaps.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} module VerifyEvalTerminfoCaps where import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound) diff --git a/test/VerifyImageOps.hs b/test/VerifyImageOps.hs --- a/test/VerifyImageOps.hs +++ b/test/VerifyImageOps.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module VerifyImageOps where import Graphics.Vty.Attributes diff --git a/test/VerifyOutput.hs b/test/VerifyOutput.hs --- a/test/VerifyOutput.hs +++ b/test/VerifyOutput.hs @@ -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) diff --git a/test/VerifyParseTerminfoCaps.hs b/test/VerifyParseTerminfoCaps.hs --- a/test/VerifyParseTerminfoCaps.hs +++ b/test/VerifyParseTerminfoCaps.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} module VerifyParseTerminfoCaps where import Prelude hiding ( catch ) diff --git a/test/VerifyUsingMockInput.hs b/test/VerifyUsingMockInput.hs --- a/test/VerifyUsingMockInput.hs +++ b/test/VerifyUsingMockInput.hs @@ -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 diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -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