git.iko.soy/vty
on d64ff96 help sign in
vty/src/Graphics/Vty/Input/Classify.hs
86 lines 3.2 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.Focus
14import Graphics.Vty.Input.Paste
15import Graphics.Vty.Input.Classify.Types
17import Codec.Binary.UTF8.Generic (decode)
19import Data.List (inits)
20import qualified Data.Map as M( fromList, lookup )
21import Data.Maybe ( mapMaybe )
22import qualified Data.Set as S( fromList, member )
24import Data.Char
25import Data.Word
27compile :: ClassifyMap -> [Char] -> KClass
28compile table = cl' where
29 -- take all prefixes and create a set of these
30 prefixSet = S.fromList $ concatMap (init . inits . fst) $ table
31 maxValidInputLength = maximum (map (length . fst) table)
32 eventForInput = M.fromList table
33 cl' [] = Prefix
34 cl' inputBlock = case M.lookup inputBlock eventForInput of
35 -- if the inputBlock is exactly what is expected for an
36 -- event then consume the whole block and return the event
37 Just e -> Valid e []
38 Nothing -> case S.member inputBlock prefixSet of
39 True -> Prefix
40 -- look up progressively smaller tails of the input
41 -- block until an event is found The assumption is that
42 -- the event that consumes the most input bytes should
43 -- be produced.
44 -- The test verifyFullSynInputToEvent2x verifies this.
45 -- H: There will always be one match. The prefixSet
46 -- contains, by definition, all prefixes of an event.
47 False ->
48 let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
49 in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
50 (s,e) : _ -> Valid e (drop (length s) inputBlock)
51 -- neither a prefix or a full event.
52 [] -> Invalid
54classify :: ClassifyMap -> [Char] -> KClass
55classify table =
56 let standardClassifier = compile table
57 in \s -> case s of
58 _ | bracketedPasteStarted s ->
59 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
67classifyUtf8 :: Char -> [Char] -> KClass
68classifyUtf8 c cs =
69 let n = utf8Length (ord c)
70 (codepoint,rest) = splitAt n (c:cs)
72 codepoint8 :: [Word8]
73 codepoint8 = map (fromIntegral . ord) codepoint
75 in case decode codepoint8 of
76 _ | n < length codepoint -> Prefix
77 Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest
78 -- something bad happened; just ignore and continue.
79 Nothing -> Invalid
81utf8Length :: (Num t, Ord a, Num a) => a -> t
82utf8Length c
83 | c < 0x80 = 1
84 | c < 0xE0 = 2
85 | c < 0xF0 = 3
86 | otherwise = 4