git.iko.soy/vty
on ffe6de2 help sign in
vty/src/Graphics/Vty/Input/Internal.hs
83 lines 3.3 kB history raw
1module Graphics.Vty.Input.Internal where
3import Graphics.Vty.Input.Data
5import Codec.Binary.UTF8.Generic (decode)
6import Control.Concurrent
8import Data.Char
9import Data.List( inits )
10import qualified Data.Map as M( fromList, lookup )
11import Data.Maybe ( mapMaybe )
12import qualified Data.Set as S( fromList, member )
13import Data.Word
15inputToEventThread :: (String -> KClass) -> Chan Char -> Chan Event -> IO ()
16inputToEventThread classifier inputChannel eventChannel = loop []
17 where loop kb = case (classifier kb) of
18 Prefix -> do
19 c <- readChan inputChannel
20 if c == '\xFFFD'
21 then return ()
22 else loop (kb ++ [c])
23 Invalid -> do
24 c <- readChan inputChannel
25 if c == '\xFFFD'
26 then return ()
27 else loop [c]
28 EndLoop -> return ()
29 MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s
30 Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""
32compile :: ClassifyTable -> [Char] -> KClass
33compile table = cl' where
34 -- take all prefixes and create a set of these
35 prefix_set = S.fromList $ concatMap (init . inits . fst) $ table
36 -- create a map from strings to event
37 event_for_input = flip M.lookup (M.fromList table)
38 cl' [] = Prefix
39 cl' input_block = case S.member input_block prefix_set of
40 True -> Prefix
41 -- if the input_block is exactly what is expected for an event then consume the whole
42 -- block and return the event
43 False -> case event_for_input input_block of
44 Just (k,m) -> Valid k m
45 -- look up progressively large prefixes of the input block until an event is found
46 -- H: There will always be one match. The prefix_set contains, by definition, all
47 -- prefixes of an event.
48 Nothing ->
49 let input_prefixes = init $ inits input_block
50 in case mapMaybe (\s -> (,) s `fmap` event_for_input s) input_prefixes of
51 (s,(k,m)) : _ -> MisPfx k m (drop (length s) input_block)
52 [] -> error $ "vty internal inconsistency - "
53 ++ "input not a prefix nor contains any event data "
54 ++ show input_block
56classify, classifyTab :: ClassifyTable -> [Char] -> KClass
58-- As soon as
59classify _table "\xFFFD" = EndLoop
60classify _table "\xFFFE" = Invalid
61classify _table s@(c:_) | ord c >= 0xC2
62 = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
63classify table other
64 = classifyTab table other
66classifyUtf8 :: [Char] -> KClass
67classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
68 Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []
69 _ -> Invalid -- something bad happened; just ignore and continue.
71classifyTab table = compile table
73first :: (a -> b) -> (a,c) -> (b,c)
74first f (x,y) = (f x, y)
76utf8Length :: (Num t, Ord a, Num a) => a -> t
77utf8Length c
78 | c < 0x80 = 1
79 | c < 0xE0 = 2
80 | c < 0xF0 = 3
81 | otherwise = 4
83foreign import ccall "vty_set_term_timing" set_term_timing :: IO ()