git.iko.soy/vty
on 175c235 help sign in
vty/src/Graphics/Vty/Input/Classify.hs
84 lines 3.1 kB history raw
1{-# OPTIONS_HADDOCK hide #-}
2-- This makes a kind of tri. Has space efficiency issues with large
3-- input blocks. Likely building a parser and just applying that would
4-- be better.
5module Graphics.Vty.Input.Classify
6 ( classify
7 , KClass(..)
8 )
9where
11import Graphics.Vty.Input.Events
12import Graphics.Vty.Input.Mouse
13import Graphics.Vty.Input.Paste
14import Graphics.Vty.Input.Classify.Types
16import Codec.Binary.UTF8.Generic (decode)
18import Data.List (inits)
19import qualified Data.Map as M( fromList, lookup )
20import Data.Maybe ( mapMaybe )
21import qualified Data.Set as S( fromList, member )
23import Data.Char
24import Data.Word
26compile :: ClassifyMap -> [Char] -> KClass
27compile table = cl' where
28 -- take all prefixes and create a set of these
29 prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
30 maxValidInputLength = maximum (map (length . fst) table)
31 eventForInput = M.fromList table
32 cl' [] = Prefix
33 cl' inputBlock = case M.lookup inputBlock eventForInput of
34 -- if the inputBlock is exactly what is expected for an
35 -- event then consume the whole block and return the event
36 Just e -> Valid e []
37 Nothing -> case S.member inputBlock prefixSet of
38 True -> Prefix
39 -- look up progressively smaller tails of the input
40 -- block until an event is found The assumption is that
41 -- the event that consumes the most input bytes should
42 -- be produced.
43 -- The test verifyFullSynInputToEvent2x verifies this.
44 -- H: There will always be one match. The prefixSet
45 -- contains, by definition, all prefixes of an event.
46 False ->
47 let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
48 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
49 (s,e) : _ -> Valid e (drop (length s) inputBlock)
50 -- neither a prefix or a full event.
51 [] -> Invalid
53classify :: ClassifyMap -> [Char] -> KClass
54classify table =
55 let standardClassifier = compile table
56 in \s -> case s of
57 _ | bracketedPasteStarted s ->
58 if bracketedPasteFinished s
59 then parseBracketedPaste s
60 else Prefix
61 _ | isMouseEvent s -> classifyMouseEvent s
62 c:cs | ord c >= 0xC2 -> classifyUtf8 c cs
63 _ -> standardClassifier s
65classifyUtf8 :: Char -> [Char] -> KClass
66classifyUtf8 c cs =
67 let n = utf8Length (ord c)
68 (codepoint,rest) = splitAt n (c:cs)
70 codepoint8 :: [Word8]
71 codepoint8 = map (fromIntegral . ord) codepoint
73 in case decode codepoint8 of
74 _ | n < length codepoint -> Prefix
75 Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
76 -- something bad happened; just ignore and continue.
77 Nothing -> Invalid
79utf8Length :: (Num t, Ord a, Num a) => a -> t
80utf8Length c
81 | c < 0x80 = 1
82 | c < 0xE0 = 2
83 | c < 0xF0 = 3
84 | otherwise = 4