98b2a83 · vty · git.iko.soy

git.iko.soy/vty

perf: Use `ByteString` instead of `[Char]` for input parsing.

NOTE: This breaks lots of internal APIs, many of which are actually exposed as public API. `brick` does not break, but client code that depends on constants containing escape sequences will need to adapt. There's really no point in using `[Char]` here. The first thing the code did was convert all the bytes individually to `Char` and putting them into a linked list. Then, when actually parsing utf-8, it turns those `Char`s back into `Word8`s. All the other code is generally concerned with bytes and goes out of its way to deal with `[Char]` instead. The code is now simpler and much faster. Overall this gives another order of magnitude speedup over the previous speedup totalling roughly a 200x speedup over 2 commits ago for the 300KB case (it's less for smaller cases and much more for larger cases, because we already made one `n^2` algorithm `n`). This does not fix the polynomial time complexity, but at this point we can comfortably paste a low number of megabytes into the terminal and process it reasonably quickly. This is sufficient to support small file uploads via bracketed paste. Some timing: * 100KB: unmeasurable by hand (basically instant) * 1000KB: 2 seconds * 1500KB: 3 seconds * 2000KB: 5 seconds * 3000KB: 10 seconds * 4000KB: 17 seconds

commit98b2a83da787438658e8f19903df37d42a8192d0 authoriphydf <iphydf@users.noreply.github.com> dateWed 9 Mar 2022, 21:33 (5 years ago) parentecee2cd

8 files changed+124−98

compare with master

unifiedsplit

src/Graphics/Vty/Input/Classify.hs+27−24 src/Graphics/Vty/Input/Classify/Parse.hs+10−7 src/Graphics/Vty/Input/Classify/Types.hs+3−1 src/Graphics/Vty/Input/Focus.hs+15−13 src/Graphics/Vty/Input/Loop.hs+18−13 src/Graphics/Vty/Input/Mouse.hs+17−15 src/Graphics/Vty/Input/Paste.hs+15−16 src/Graphics/Vty/Output/XTermColor.hs+19−9

src/Graphics/Vty/Input/Classify.hs+27−24

@@ -1,5 +1,5 @@

11{-# OPTIONS_HADDOCK hide #-}

2−-- This makes a kind of tri. Has space efficiency issues with large

2+-- This makes a kind of trie. Has space efficiency issues with large

33-- input blocks. Likely building a parser and just applying that would

44-- be better.

55module Graphics.Vty.Input.Classify

@@ -16,25 +16,28 @@ import Graphics.Vty.Input.Classify.Types

1616

1717import Codec.Binary.UTF8.Generic (decode)

1818

19−import Data.List (inits)

19+import Control.Arrow (first)

2020import qualified Data.Map as M( fromList, lookup )

2121import Data.Maybe ( mapMaybe )

2222import qualified Data.Set as S( fromList, member )

2323

24−import Data.Char

2524import Data.Word

2625

27−compile :: ClassifyMap -> String -> KClass

26+import qualified Data.ByteString as BS

27+import qualified Data.ByteString.Char8 as BS8

28+import Data.ByteString.Char8 (ByteString)

29+

30+compile :: ClassifyMap -> ByteString -> KClass

2831compile table = cl' where

2932 -- take all prefixes and create a set of these

30− prefixSet = S.fromList $ concatMap (init . inits . fst) table

33+ prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table

3134 maxValidInputLength = maximum (map (length . fst) table)

32− eventForInput = M.fromList table

33− cl' [] = Prefix

35+ eventForInput = M.fromList $ map (first BS8.pack) table

36+ cl' inputBlock | BS8.null inputBlock = Prefix

3437 cl' inputBlock = case M.lookup inputBlock eventForInput of

3538 -- if the inputBlock is exactly what is expected for an

3639 -- event then consume the whole block and return the event

37− Just e -> Valid e []

40+ Just e -> Valid e BS8.empty

3841 Nothing -> case S.member inputBlock prefixSet of

3942 True -> Prefix

4043 -- look up progressively smaller tails of the input

@@ -45,40 +48,40 @@ compile table = cl' where

4548 -- H: There will always be one match. The prefixSet

4649 -- contains, by definition, all prefixes of an event.

4750 False ->

48− let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock

51+ let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock

4952 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of

50− (s,e) : _ -> Valid e (drop (length s) inputBlock)

53+ (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)

5154 -- neither a prefix or a full event.

5255 [] -> Invalid

5356

54−classify :: ClassifyMap -> String -> KClass

57+classify :: ClassifyMap -> ByteString -> KClass

5558classify table =

5659 let standardClassifier = compile table

57− in \s -> case s of

60+ in \s -> case BS.uncons s of

5861 _ | bracketedPasteStarted s ->

5962 if bracketedPasteFinished s

6063 then parseBracketedPaste s

6164 else Prefix

62− _ | isMouseEvent s -> classifyMouseEvent s

63− _ | isFocusEvent s -> classifyFocusEvent s

64− c:cs | ord c >= 0xC2 -> classifyUtf8 c cs

65− _ -> standardClassifier s

65+ _ | isMouseEvent s -> classifyMouseEvent s

66+ _ | isFocusEvent s -> classifyFocusEvent s

67+ Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs

68+ _ -> standardClassifier s

6669

67−classifyUtf8 :: Char -> String -> KClass

70+classifyUtf8 :: Word8 -> ByteString -> KClass

6871classifyUtf8 c cs =

69− let n = utf8Length (ord c)

70− (codepoint,rest) = splitAt n (c:cs)

72+ let n = utf8Length c

73+ (codepoint,rest) = BS8.splitAt (n - 1) cs

7174

7275 codepoint8 :: [Word8]

73− codepoint8 = map (fromIntegral . ord) codepoint

76+ codepoint8 = c:BS.unpack codepoint

7477

7578 in case decode codepoint8 of

76− _ | n < length codepoint -> Prefix

77− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest

79+ _ | n < BS.length codepoint + 1 -> Prefix

80+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest

7881 -- something bad happened; just ignore and continue.

79− Nothing -> Invalid

82+ Nothing -> Invalid

8083

81−utf8Length :: (Num t, Ord a, Num a) => a -> t

84+utf8Length :: Word8 -> Int

8285utf8Length c

8386 | c < 0x80 = 1

8487 | c < 0xE0 = 2

src/Graphics/Vty/Input/Classify/Parse.hs+10−7

@@ -16,12 +16,15 @@ import Graphics.Vty.Input.Classify.Types

1616import Control.Monad.Trans.Maybe

1717import Control.Monad.State

1818

19−type Parser a = MaybeT (State String) a

19+import qualified Data.ByteString.Char8 as BS8

20+import Data.ByteString.Char8 (ByteString)

21+

22+type Parser a = MaybeT (State ByteString) a

2023

2124-- | Run a parser on a given input string. If the parser fails, return

2225-- 'Invalid'. Otherwise return the valid event ('Valid') and the

2326-- remaining unparsed characters.

24−runParser :: String -> Parser Event -> KClass

27+runParser :: ByteString -> Parser Event -> KClass

2528runParser s parser =

2629 case runState (runMaybeT parser) s of

2730 (Nothing, _) -> Invalid

@@ -36,9 +39,9 @@ failParse = fail "invalid parse"

3639-- return '123' and consume those characters.

3740readInt :: Parser Int

3841readInt = do

39− s <- get

42+ s <- BS8.unpack <$> get

4043 case (reads :: ReadS Int) s of

41− [(i, rest)] -> put rest >> return i

44+ [(i, rest)] -> put (BS8.pack rest) >> return i

4245 _ -> failParse

4346

4447-- | Read a character from the input stream. If one cannot be read (e.g.

@@ -46,9 +49,9 @@ readInt = do

4649readChar :: Parser Char

4750readChar = do

4851 s <- get

49− case s of

50− c:rest -> put rest >> return c

51− _ -> failParse

52+ case BS8.uncons s of

53+ Just (c,rest) -> put rest >> return c

54+ Nothing -> failParse

5255

5356-- | Read a character from the input stream and fail parsing if it is

5457-- not the specified character.

src/Graphics/Vty/Input/Classify/Types.hs+3−1

@@ -8,8 +8,10 @@ where

99import Graphics.Vty.Input.Events

1010

11+import Data.ByteString.Char8 (ByteString)

12+

1113data KClass

12− = Valid Event String

14+ = Valid Event ByteString

1315 -- ^ A valid event was parsed. Any unused characters from the input

1416 -- stream are also provided.

1517 | Invalid

src/Graphics/Vty/Input/Focus.hs+15−13

@@ -11,30 +11,32 @@ import Graphics.Vty.Input.Classify.Types

1111import Graphics.Vty.Input.Classify.Parse

1212

1313import Control.Monad.State

14−import Data.List (isPrefixOf)

14+

15+import qualified Data.ByteString.Char8 as BS8

16+import Data.ByteString.Char8 (ByteString)

1517

1618-- | These sequences set xterm-based terminals to send focus event

1719-- sequences.

18−requestFocusEvents :: String

19−requestFocusEvents = "\ESC[?1004h"

20+requestFocusEvents :: ByteString

21+requestFocusEvents = BS8.pack "\ESC[?1004h"

2022

2123-- | These sequences disable focus events.

22−disableFocusEvents :: String

23−disableFocusEvents = "\ESC[?1004l"

24+disableFocusEvents :: ByteString

25+disableFocusEvents = BS8.pack "\ESC[?1004l"

2426

2527-- | Does the specified string begin with a focus event?

26−isFocusEvent :: String -> Bool

27−isFocusEvent s = isPrefixOf focusIn s ||

28− isPrefixOf focusOut s

28+isFocusEvent :: ByteString -> Bool

29+isFocusEvent s = BS8.isPrefixOf focusIn s ||

30+ BS8.isPrefixOf focusOut s

2931

30−focusIn :: String

31−focusIn = "\ESC[I"

32+focusIn :: ByteString

33+focusIn = BS8.pack "\ESC[I"

3234

33−focusOut :: String

34−focusOut = "\ESC[O"

35+focusOut :: ByteString

36+focusOut = BS8.pack "\ESC[O"

3537

3638-- | Attempt to classify an input string as a focus event.

37−classifyFocusEvent :: String -> KClass

39+classifyFocusEvent :: ByteString -> KClass

3840classifyFocusEvent s = runParser s $ do

3941 when (not $ isFocusEvent s) failParse

4042

src/Graphics/Vty/Input/Loop.hs+18−13

@@ -33,12 +33,15 @@ import Control.Monad.Trans.State (StateT(..), evalStateT)

3333import Control.Monad.State.Class (MonadState, modify)

3434import Control.Monad.Trans.Reader (ReaderT(..))

3535

36−import Data.Char

36+import qualified Data.ByteString.Char8 as BS8

37+import qualified Data.ByteString as BS

38+import Data.ByteString.Char8 (ByteString)

3739import Data.IORef

3840import Data.Word (Word8)

3941

40−import Foreign ( allocaArray, peekArray, Ptr )

42+import Foreign (allocaArray)

4143import Foreign.C.Types (CInt(..))

44+import Foreign.Ptr (Ptr, castPtr)

4245

4346import System.IO

4447import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))

@@ -76,10 +79,10 @@ data InputBuffer = InputBuffer

7679makeLenses ''InputBuffer

7780

7881data InputState = InputState

79− { _unprocessedBytes :: String

82+ { _unprocessedBytes :: ByteString

8083 , _appliedConfig :: Config

8184 , _inputBuffer :: InputBuffer

82− , _classifier :: String -> KClass

85+ , _classifier :: ByteString -> KClass

8386 }

8487

8588makeLenses ''InputState

@@ -104,7 +107,7 @@ loopInputProcessor = do

104107 dropInvalid

105108 loopInputProcessor

106109

107−addBytesToProcess :: String -> InputM ()

110+addBytesToProcess :: ByteString -> InputM ()

108111addBytesToProcess block = unprocessedBytes <>= block

109112

110113emit :: Event -> InputM ()

@@ -117,7 +120,7 @@ emit event = do

117120--

118121-- Precondition: Under the threaded runtime. Only current use is from a

119122-- forkOS thread. That case satisfies precondition.

120−readFromDevice :: InputM String

123+readFromDevice :: InputM ByteString

121124readFromDevice = do

122125 newConfig <- view configRef >>= liftIO . readIORef

123126 oldConfig <- use appliedConfig

@@ -137,9 +140,10 @@ readFromDevice = do

137140 threadWaitRead fd

138141 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

139142 if bytesRead > 0

140− then map (chr . fromIntegral) <$> peekArray (fromIntegral bytesRead) bufferPtr

141− else return []

142− when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep

143+ then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead)

144+ else return BS.empty

145+ when (not $ BS.null stringRep) $

146+ logMsg $ "input bytes: " ++ show (BS8.unpack stringRep)

143147 return stringRep

144148

145149applyConfig :: Fd -> Config -> IO ()

@@ -165,15 +169,16 @@ dropInvalid = do

165169 b <- use unprocessedBytes

166170 when (c b == Invalid) $ do

167171 logMsg "dropping input bytes"

168− unprocessedBytes .= []

172+ unprocessedBytes .= BS8.empty

169173

170174runInputProcessorLoop :: ClassifyMap -> Input -> IO ()

171175runInputProcessorLoop classifyTable input = do

172176 let bufferSize = 1024

173177 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do

174− s0 <- InputState [] <$> readIORef (_configRef input)

175− <*> pure (InputBuffer bufferPtr bufferSize)

176− <*> pure (classify classifyTable)

178+ s0 <- InputState BS8.empty

179+ <$> readIORef (_configRef input)

180+ <*> pure (InputBuffer bufferPtr bufferSize)

181+ <*> pure (classify classifyTable)

177182 runReaderT (evalStateT loopInputProcessor s0) input

178183

179184-- | Construct two IO actions: one to configure the terminal for Vty and

src/Graphics/Vty/Input/Mouse.hs+17−15

@@ -15,10 +15,12 @@ import Graphics.Vty.Input.Classify.Types

1515import Graphics.Vty.Input.Classify.Parse

1616

1717import Control.Monad.State

18−import Data.List (isPrefixOf)

1918import Data.Maybe (catMaybes)

2019import Data.Bits ((.&.))

2120

21+import qualified Data.ByteString.Char8 as BS8

22+import Data.ByteString.Char8 (ByteString)

23+

2224-- A mouse event in SGR extended mode is

2325--

2426-- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m')

@@ -32,28 +34,28 @@ import Data.Bits ((.&.))

3234

3335-- | These sequences set xterm-based terminals to send mouse event

3436-- sequences.

35−requestMouseEvents :: String

36−requestMouseEvents = "\ESC[?1000h\ESC[?1002h\ESC[?1006h"

37+requestMouseEvents :: ByteString

38+requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h"

3739

3840-- | These sequences disable mouse events.

39−disableMouseEvents :: String

40−disableMouseEvents = "\ESC[?1000l\ESC[?1002l\ESC[?1006l"

41+disableMouseEvents :: ByteString

42+disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l"

4143

4244-- | Does the specified string begin with a mouse event?

43−isMouseEvent :: String -> Bool

45+isMouseEvent :: ByteString -> Bool

4446isMouseEvent s = isSGREvent s || isNormalEvent s

4547

46−isSGREvent :: String -> Bool

47−isSGREvent = isPrefixOf sgrPrefix

48+isSGREvent :: ByteString -> Bool

49+isSGREvent = BS8.isPrefixOf sgrPrefix

4850

49−sgrPrefix :: String

50−sgrPrefix = "\ESC[M"

51+sgrPrefix :: ByteString

52+sgrPrefix = BS8.pack "\ESC[M"

5153

52−isNormalEvent :: String -> Bool

53−isNormalEvent = isPrefixOf normalPrefix

54+isNormalEvent :: ByteString -> Bool

55+isNormalEvent = BS8.isPrefixOf normalPrefix

5456

55−normalPrefix :: String

56−normalPrefix = "\ESC[<"

57+normalPrefix :: ByteString

58+normalPrefix = BS8.pack "\ESC[<"

5759

5860-- Modifier bits:

5961shiftBit :: Int

@@ -88,7 +90,7 @@ hasBitSet :: Int -> Int -> Bool

8890hasBitSet val bit = val .&. bit > 0

8991

9092-- | Attempt to lassify an input string as a mouse event.

91−classifyMouseEvent :: String -> KClass

93+classifyMouseEvent :: ByteString -> KClass

9294classifyMouseEvent s = runParser s $ do

9395 when (not $ isMouseEvent s) failParse

9496

src/Graphics/Vty/Input/Paste.hs+15−16

@@ -9,34 +9,33 @@ module Graphics.Vty.Input.Paste

99where

1010

1111import qualified Data.ByteString.Char8 as BS8

12+import Data.ByteString.Char8 (ByteString)

1213

1314import Graphics.Vty.Input.Events

1415import Graphics.Vty.Input.Classify.Types

1516

16−import Data.List (isPrefixOf, isInfixOf)

17+bracketedPasteStart :: ByteString

18+bracketedPasteStart = BS8.pack "\ESC[200~"

1719

18−bracketedPasteStart :: String

19−bracketedPasteStart = "\ESC[200~"

20−

21−bracketedPasteEnd :: String

22−bracketedPasteEnd = "\ESC[201~"

20+bracketedPasteEnd :: ByteString

21+bracketedPasteEnd = BS8.pack "\ESC[201~"

2322

2423-- | Does the input start a bracketed paste?

25−bracketedPasteStarted :: String -> Bool

26−bracketedPasteStarted = isPrefixOf bracketedPasteStart

24+bracketedPasteStarted :: ByteString -> Bool

25+bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart

2726

2827-- | Does the input contain a complete bracketed paste?

29−bracketedPasteFinished :: String -> Bool

30−bracketedPasteFinished = isInfixOf bracketedPasteEnd

28+bracketedPasteFinished :: ByteString -> Bool

29+bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd

3130

3231-- | Parse a bracketed paste. This should only be called on a string if

3332-- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return

3433-- 'True'.

35−parseBracketedPaste :: String -> KClass

34+parseBracketedPaste :: ByteString -> KClass

3635parseBracketedPaste s =

37− Valid (EvPaste p) (BS8.unpack $ BS8.drop (BS8.length end) rest')

36+ Valid (EvPaste p) (BS8.drop endLen rest')

3837 where

39− start = BS8.pack bracketedPasteStart

40− end = BS8.pack bracketedPasteEnd

41− (_, rest ) = BS8.breakSubstring start . BS8.pack $ s

42− (p, rest') = BS8.breakSubstring end . BS8.drop (BS8.length start) $ rest

38+ startLen = BS8.length bracketedPasteStart

39+ endLen = BS8.length bracketedPasteEnd

40+ (_, rest ) = BS8.breakSubstring bracketedPasteStart s

41+ (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest

src/Graphics/Vty/Output/XTermColor.hs+19−9

@@ -15,13 +15,17 @@ import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

1515import Blaze.ByteString.Builder (writeToByteString)

1616import Blaze.ByteString.Builder.Word (writeWord8)

1717

18+import qualified Data.ByteString.Char8 as BS8

19+import Data.ByteString.Char8 (ByteString)

20+import Foreign.Ptr (castPtr)

21+

1822import Control.Monad (void, when)

1923import Control.Monad.Trans

2024import Data.Char (toLower)

2125import Data.IORef

2226

23−import System.Posix.IO (fdWrite)

24−import System.Posix.Types (Fd)

27+import System.Posix.IO (fdWriteBuf)

28+import System.Posix.Types (ByteCount, Fd)

2529import System.Posix.Env (getEnv)

2630

2731import Data.List (isInfixOf)

@@ -31,6 +35,12 @@ import Data.Maybe (catMaybes)

3135import Data.Monoid ((<>))

3236#endif

3337

38+-- | Write a 'ByteString' to an 'Fd'.

39+fdWrite :: Fd -> ByteString -> IO ByteCount

40+fdWrite fd s =

41+ BS8.useAsCStringLen s $ \(buf,len) -> do

42+ fdWriteBuf fd (castPtr buf) (fromIntegral len)

43+

3444-- | Construct an Xterm output driver. Initialize the display to UTF-8.

3545reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output

3646reserveTerminal variant outFd = liftIO $ do

@@ -100,19 +110,19 @@ utf8Active = do

100110

101111-- | Enable bracketed paste mode:

102112-- http://cirw.in/blog/bracketed-paste

103−enableBracketedPastes :: String

104−enableBracketedPastes = "\ESC[?2004h"

113+enableBracketedPastes :: ByteString

114+enableBracketedPastes = BS8.pack "\ESC[?2004h"

105115

106116-- | Disable bracketed paste mode:

107−disableBracketedPastes :: String

108−disableBracketedPastes = "\ESC[?2004l"

117+disableBracketedPastes :: ByteString

118+disableBracketedPastes = BS8.pack "\ESC[?2004l"

109119

110120-- | These sequences set xterm based terminals to UTF-8 output.

111121--

112122-- There is no known terminfo capability equivalent to this.

113−setUtf8CharSet, setDefaultCharSet :: String

114−setUtf8CharSet = "\ESC%G"

115−setDefaultCharSet = "\ESC%@"

123+setUtf8CharSet, setDefaultCharSet :: ByteString

124+setUtf8CharSet = BS8.pack "\ESC%G"

125+setDefaultCharSet = BS8.pack "\ESC%@"

116126

117127xtermInlineHack :: Output -> IO ()

118128xtermInlineHack t = do