@@ -1,10 +1,11 @@
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
66 ( classify
77 , KClass(..)
8+ , ClassifierState(..)
89 )
910where
1011
@@ -16,25 +17,39 @@ import Graphics.Vty.Input.Classify.Types
1617
1718import Codec.Binary.UTF8.Generic (decode)
1819
19−import Data.List (inits)
20+import Control.Arrow (first)
2021import qualified Data.Map as M( fromList, lookup )
2122import Data.Maybe ( mapMaybe )
2223import qualified Data.Set as S( fromList, member )
2324
24−import Data.Char
2525import Data.Word
2626
27−compile :: ClassifyMap -> String -> KClass
27+import qualified Data.ByteString as BS
28+import qualified Data.ByteString.Char8 as BS8
29+import Data.ByteString.Char8 (ByteString)
30+
31+-- | Whether the classifier is currently processing a chunked format.
32+-- Currently, only bracketed pastes use this.
33+data ClassifierState
34+ = ClassifierStart
35+ -- ^ Not processing a chunked format.
36+ | ClassifierInChunk ByteString [ByteString]
37+ -- ^ Currently processing a chunked format. The initial chunk is in the
38+ -- first argument and a reversed remainder of the chunks is collected in
39+ -- the second argument. At the end of the processing, the chunks are
40+ -- reversed and concatenated with the final chunk.
41+
42+compile :: ClassifyMap -> ByteString -> KClass
2843compile table = cl' where
2944 -- take all prefixes and create a set of these
30− prefixSet = S.fromList $ concatMap (init . inits . fst) table
45+ prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table
3146 maxValidInputLength = maximum (map (length . fst) table)
32− eventForInput = M.fromList table
33− cl' [] = Prefix
47+ eventForInput = M.fromList $ map (first BS8.pack) table
48+ cl' inputBlock | BS8.null inputBlock = Prefix
3449 cl' inputBlock = case M.lookup inputBlock eventForInput of
3550 -- if the inputBlock is exactly what is expected for an
3651 -- event then consume the whole block and return the event
37− Just e -> Valid e []
52+ Just e -> Valid e BS8.empty
3853 Nothing -> case S.member inputBlock prefixSet of
3954 True -> Prefix
4055 -- look up progressively smaller tails of the input
@@ -45,40 +60,49 @@ compile table = cl' where
4560 -- H: There will always be one match. The prefixSet
4661 -- contains, by definition, all prefixes of an event.
4762 False ->
48− let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
63+ let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock
4964 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
50− (s,e) : _ -> Valid e (drop (length s) inputBlock)
65+ (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock)
5166 -- neither a prefix or a full event.
5267 [] -> Invalid
5368
54−classify :: ClassifyMap -> String -> KClass
55−classify table =
56− let standardClassifier = compile table
57− in \s -> case s of
58− _ | bracketedPasteStarted s ->
69+classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass
70+classify table = process
71+ where
72+ standardClassifier = compile table
73+
74+ process ClassifierStart s =
75+ case BS.uncons s of
76+ _ | bracketedPasteStarted s ->
77+ if bracketedPasteFinished s
78+ then parseBracketedPaste s
79+ else Chunk
80+ _ | isMouseEvent s -> classifyMouseEvent s
81+ _ | isFocusEvent s -> classifyFocusEvent s
82+ Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs
83+ _ -> standardClassifier s
84+
85+ process (ClassifierInChunk p ps) s | bracketedPasteStarted p =
5986 if bracketedPasteFinished s
60− then parseBracketedPaste s
61− else Prefix
62− _ | isMouseEvent s -> classifyMouseEvent s
63− _ | isFocusEvent s -> classifyFocusEvent s
64− c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
65− _ -> standardClassifier s
87+ then parseBracketedPaste $ BS.concat $ p:reverse (s:ps)
88+ else Chunk
89+ process ClassifierInChunk{} _ = Invalid
6690
67−classifyUtf8 :: Char -> String -> KClass
91+classifyUtf8 :: Word8 -> ByteString -> KClass
6892classifyUtf8 c cs =
69− let n = utf8Length (ord c)
70− (codepoint,rest) = splitAt n (c:cs)
93+ let n = utf8Length c
94+ (codepoint,rest) = BS8.splitAt (n - 1) cs
7195
7296 codepoint8 :: [Word8]
73− codepoint8 = map (fromIntegral . ord) codepoint
97+ codepoint8 = c:BS.unpack codepoint
7498
7599 in case decode codepoint8 of
76− _ | n < length codepoint -> Prefix
77− Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
100+ _ | n < BS.length codepoint + 1 -> Prefix
101+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
78102 -- something bad happened; just ignore and continue.
79− Nothing -> Invalid
103+ Nothing -> Invalid
80104
81−utf8Length :: (Num t, Ord a, Num a) => a -> t
105+utf8Length :: Word8 -> Int
82106utf8Length c
83107 | c < 0x80 = 1
84108 | c < 0xE0 = 2