git.iko.soy/vty
on master help sign in
add an event to end the event processing loop. finish simple_chars test
dc74901Corey O'Connor
src/Graphics/Vty/Input.hs+1−54
compare with master
unifiedsplit
@@ -8,16 +8,10 @@ module Graphics.Vty.Input ( Key(..)
8 where
8 where
9
9
10import Graphics.Vty.Input.Data
10import Graphics.Vty.Input.Data
11+import Graphics.Vty.Input.Internal
11
12
12import Data.Char
13import Data.Char
13−import Data.Maybe ( mapMaybe
14− )
15−import Data.List( inits )
16import Data.Word
14import Data.Word
17−import qualified Data.Map as M( fromList, lookup )
18−import qualified Data.Set as S( fromList, member )
19−
20−import Codec.Binary.UTF8.Generic (decode)
21
15
22import Control.Monad (when)
16import Control.Monad (when)
23import Control.Concurrent
17import Control.Concurrent
@@ -106,50 +100,3 @@ initTermInput escDelay terminal = do
106 setTerminalAttributes stdInput oattr Immediately
100 setTerminalAttributes stdInput oattr Immediately
107 return (readChan eventChannel, uninit)
101 return (readChan eventChannel, uninit)
108
102
109−inputToEventThread :: (String -> KClass) -> Chan Char -> Chan Event -> IO ()
110−inputToEventThread classifier inputChannel eventChannel = loop []
111− where loop kb = case (classifier kb) of
112− Prefix -> do c <- readChan inputChannel
113− loop (kb ++ [c])
114− Invalid -> do c <- readChan inputChannel
115− loop [c]
116− MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s
117− Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""
118−
119−compile :: ClassifyTable -> [Char] -> KClass
120−compile table = cl' where
121− pfx = S.fromList $ concatMap (init . inits . fst) $ table
122− mlst = M.fromList table
123− cl' str = case S.member str pfx of
124− True -> Prefix
125− False -> case M.lookup str mlst of
126− Just (k,m) -> Valid k m
127− Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of
128− (s,(k,m)) -> MisPfx k m (drop (length s) str)
129−
130−classify, classifyTab :: ClassifyTable -> [Char] -> KClass
131−
132−-- As soon as
133−classify _table "\xFFFE" = Invalid
134−classify _table s@(c:_) | ord c >= 0xC2
135− = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
136−classify table other
137− = classifyTab table other
138−
139−classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
140− Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []
141− _ -> Invalid -- something bad happened; just ignore and continue.
142−
143−classifyTab table = compile table
144−
145−first :: (a -> b) -> (a,c) -> (b,c)
146−first f (x,y) = (f x, y)
147−
148−utf8Length :: (Num t, Ord a, Num a) => a -> t
149−utf8Length c
150− | c < 0x80 = 1
151− | c < 0xE0 = 2
152− | c < 0xF0 = 3
153− | otherwise = 4
154−
155−foreign import ccall "vty_set_term_timing" set_term_timing :: IO ()
src/Graphics/Vty/Input/Data.hs+9−2
@@ -22,7 +22,12 @@ data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier]
22 | EvResize Int Int
22 | EvResize Int Int
23 deriving (Eq,Show,Ord)
23 deriving (Eq,Show,Ord)
24
24
25+data KClass
26+ = Valid Key [Modifier]
27+ | Invalid
28+ | EndLoop
29+ | Prefix
25−data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char]
30+ | MisPfx Key [Modifier] [Char]
26 deriving(Show)
31 deriving(Show)
27
32
28type ClassifyTable = [(String, (Key, [Modifier]))]
33type ClassifyTable = [(String, (Key, [Modifier]))]
@@ -83,8 +88,10 @@ nav_keys_3 =
83 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
88 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
84
89
85-- Support for simple characters.
90-- Support for simple characters.
91+-- we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this
92+-- classify table is reached.
86simple_chars :: ClassifyTable
93simple_chars :: ClassifyTable
87−simple_chars = [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ]
94+simple_chars = [ (x:[],(KASCII x,[])) | x <- map toEnum [0..0xC1] ]
88
95
89-- Support for function keys (should use terminfo)
96-- Support for function keys (should use terminfo)
90function_keys_0 :: ClassifyTable
97function_keys_0 :: ClassifyTable
src/Graphics/Vty/Input/Internal.hsnew file+78
@@ -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 ()
test/VerifyUsingMockInput.hs+37−10
@@ -3,17 +3,26 @@
3 - interest.
3 - interest.
4 -}
4 -}
5module VerifyUsingMockInput where
5module VerifyUsingMockInput where
6−import Verify
6+import Verify hiding (classify)
7
7
8−import Graphics.Vty
8+import Graphics.Vty hiding (resize)
9+import Graphics.Vty.Input
9import Graphics.Vty.Input.Data
10import Graphics.Vty.Input.Data
11+import Graphics.Vty.Input.Internal
10
12
11import Control.Concurrent
13import Control.Concurrent
14+import Control.Exception
12import Control.Monad
15import Control.Monad
13
16
14import System.Posix.Env
17import System.Posix.Env
15import System.IO
18import System.IO
16
19
20+import Test.QuickCheck.Assertions
21+import Test.QuickCheck.Property ( morallyDubiousIOProperty )
22+
23+-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
24+max_bytes_size = 16
25+
17data InputEvent
26data InputEvent
18 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
27 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
19 | Delay Int -- | millisecond delay
28 | Delay Int -- | millisecond delay
@@ -31,19 +40,37 @@ exec_input_spec input out_handle = forM_ input f
31assert_events_from_IO_reads :: InputSpec -> ExpectedSpec -> IO Result
40assert_events_from_IO_reads :: InputSpec -> ExpectedSpec -> IO Result
32assert_events_from_IO_reads input events = undefined
41assert_events_from_IO_reads input events = undefined
33
42
34−assert_events_from_input_block :: InputSpec -> ExpectedSpec -> Result
43+assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Result
35−assert_events_from_input_block input events = undefined
44+assert_events_from_input_block table input_spec expected_events = do
45+ let classifier = classify table
46+ input <- newChan
47+ output <- newChan
48+ forkIO $ write_input_spec_to_chan input input_spec
49+ handle (\(e :: BlockedIndefinitelyOnMVar) ->
50+ return $ failed { reason = show expected_events ++ " -> " ++ show e }
51+ ) $ do
52+ inputToEventThread classifier input output
53+ out_events <- replicateM (length expected_events) (readChan output)
54+ return $ out_events ?== expected_events
55+
56+write_input_spec_to_chan :: Chan Char -> InputSpec -> IO ()
57+write_input_spec_to_chan chan [] = writeChan chan '\xFFFD'
58+write_input_spec_to_chan chan (Bytes str : input_spec')
59+ = writeList2Chan chan str >> write_input_spec_to_chan chan input_spec'
60+write_input_spec_to_chan chan (Delay t : input_spec')
61+ = writeChan chan '\xFFFE' >> write_input_spec_to_chan chan input_spec'
36
62
37−verify_ansi_table_input_block_to_event :: Gen Result
63+verify_simple_input_block_to_event :: Property
38−verify_ansi_table_input_block_to_event = do
64+verify_simple_input_block_to_event = do
39− Positive block_length <- arbitrary
65+ Positive block_length <- resize 16 $ arbitrary
40− block_event_pairs <- vectorOf block_length $ elements $ concat ansi_classify_table
66+ block_event_pairs <- vectorOf block_length $ elements $ simple_chars
41 let input = [Bytes $ concatMap fst block_event_pairs]
67 let input = [Bytes $ concatMap fst block_event_pairs]
42 events = map (\(k,ms) -> EvKey k ms) $ map snd block_event_pairs
68 events = map (\(k,ms) -> EvKey k ms) $ map snd block_event_pairs
43− return $ assert_events_from_input_block input events
69+ morallyDubiousIOProperty $ assert_events_from_input_block simple_chars input events
44
70
45tests :: IO [Test]
71tests :: IO [Test]
46tests = return
72tests = return
47− [ verify "basic input block to event translation" verify_ansi_table_input_block_to_event
73+ [ verify "basic block generated from ansi table to event translation"
74+ verify_simple_input_block_to_event
48 ]
75 ]
49
76
vty.cabal+2
@@ -61,6 +61,7 @@ library
61 Graphics.Vty.Inline.Unsafe
61 Graphics.Vty.Inline.Unsafe
62 Graphics.Vty.Input
62 Graphics.Vty.Input
63 Graphics.Vty.Input.Data
63 Graphics.Vty.Input.Data
64+ Graphics.Vty.Input.Internal
64 Graphics.Vty.Picture
65 Graphics.Vty.Picture
65 Graphics.Vty.Terminal
66 Graphics.Vty.Terminal
66 Graphics.Text.Width
67 Graphics.Text.Width
@@ -515,6 +516,7 @@ test-suite verify-using-mock-input
515 build-depends: vty,
516 build-depends: vty,
516 Cabal == 1.18.*,
517 Cabal == 1.18.*,
517 QuickCheck >= 2.4,
518 QuickCheck >= 2.4,
519+ quickcheck-assertions >= 0.1.1,
518 random == 1.0.*,
520 random == 1.0.*,
519 base >= 4 && < 5,
521 base >= 4 && < 5,
520 bytestring,
522 bytestring,