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