git.iko.soy/vty
on dbb8ff9 help sign in
vty/test/VerifyUsingMockInput.hs
212 lines 8.8 kB history raw
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
3{- Generate some input bytes and delays between blocks of input bytes. Verify the events produced
4 - are as expected.
5 -}
6module Main where
8import Verify.Graphics.Vty.Output
10import Data.List (intersperse)
12import Graphics.Vty hiding (resize)
13import Graphics.Vty.Input.Events
14import Graphics.Vty.Input.Internal
15import Graphics.Vty.Input.Terminfo
17import Control.Applicative
18import Control.Concurrent
19import Control.Exception
20import Control.Lens ((^.))
21import Control.Monad
23import Data.Default
24import Data.IORef
26import System.Console.Terminfo
27import System.Posix.IO
28import System.Posix.Terminal (openPseudoTerminal)
29import System.Posix.Types
30import System.Timeout
32import Test.Framework.Providers.SmallCheck
33import Test.Framework
34import Test.SmallCheck
35import Test.SmallCheck.Series
37import Text.Printf
39-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
40max_block_size :: Int
41max_block_size = 16
43max_table_size :: Int
44max_table_size = 28
46forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
47forEachOf l = over (generate (\n -> take n l))
49data InputEvent
50 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
51 | Delay Int -- | microsecond delay
52 deriving Show
54type InputSpec = [InputEvent]
56type ExpectedSpec = [Event]
58synthesize_input :: InputSpec -> Fd -> IO ()
59synthesize_input input out_handle = forM_ input f >> (void $ fdWrite out_handle "\xFFFD")
60 where
61 f (Bytes str) = void $ fdWrite out_handle str
62 f (Delay t) = threadDelay t
64min_detectable_delay :: Int
65min_detectable_delay = 4000
67min_timout :: Int
68min_timout = 4000000
70test_key_delay :: Int
71test_key_delay = min_detectable_delay * 4
73test_esc_sample_delay :: Int
74test_esc_sample_delay = min_detectable_delay * 2
76gen_events_using_io_actions :: Int -> IO () -> IO () -> IO ()
77gen_events_using_io_actions max_duration input_action output_action = do
78 let max_duration' = max min_timout max_duration
79 read_complete <- newEmptyMVar
80 write_complete <- newEmptyMVar
81 _ <- forkOS $ input_action `finally` putMVar write_complete ()
82 _ <- forkOS $ output_action `finally` putMVar read_complete ()
83 Just () <- timeout max_duration' $ takeMVar write_complete
84 Just () <- timeout max_duration' $ takeMVar read_complete
85 return ()
87compare_events :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool
88compare_events input_spec expected_events out_events = compare_events' expected_events out_events
89 where
90 compare_events' [] [] = return True
91 compare_events' [] out_events' = do
92 printf "extra events %s\n" (show out_events') :: IO ()
93 return False
94 compare_events' expected_events' [] = do
95 printf "events %s were not produced for input %s\n" (show expected_events') (show input_spec) :: IO ()
96 printf "expected events %s\n" (show expected_events) :: IO ()
97 printf "received events %s\n" (show out_events) :: IO ()
98 return False
99 compare_events' (e : expected_events') (o : out_events')
100 | e == o = compare_events' expected_events' out_events'
101 | otherwise = do
102 printf "%s expected not %s for input %s\n" (show e) (show o) (show input_spec) :: IO ()
103 printf "expected events %s\n" (show expected_events) :: IO ()
104 printf "received events %s\n" (show out_events) :: IO ()
105 return False
107assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
108assert_events_from_syn_input table input_spec expected_events = do
109 let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
110 event_count = length expected_events
111 (write_fd, read_fd) <- openPseudoTerminal
112 (set_term_attr,_) <- attributeControl read_fd
113 set_term_attr
114 input <- initInputForFd def table read_fd
115 events_ref <- newIORef []
116 let write_wait_close = do
117 synthesize_input input_spec write_fd
118 threadDelay min_detectable_delay
119 shutdown_input input
120 threadDelay min_detectable_delay
121 closeFd write_fd
122 closeFd read_fd
123 -- drain output pipe
124 let read_events = read_loop event_count
125 read_loop 0 = return ()
126 read_loop n = do
127 e <- readChan $ input^.event_channel
128 modifyIORef events_ref ((:) e)
129 read_loop (n - 1)
130 gen_events_using_io_actions max_duration write_wait_close read_events
131 out_events <- reverse <$> readIORef events_ref
132 compare_events input_spec expected_events out_events
134newtype InputBlocksUsingTable event
135 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
137instance Show (InputBlocksUsingTable event) where
138 show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
140instance Monad m => Serial m (InputBlocksUsingTable event) where
141 series = do
142 n :: Int <- localDepth (const max_table_size) series
143 return $ InputBlocksUsingTable $ \table -> concat (take n (selections table))
144 where
145 selections [] = []
146 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
148verify_visible_syn_input_to_event :: Property IO
149verify_visible_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
150 let table = visible_chars
151 input_seq = gen table
152 events = map snd input_seq
153 keydowns = map (Bytes . fst) input_seq
154 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
155 assert_events_from_syn_input universal_table input events
157verify_caps_syn_input_to_event :: Property IO
158verify_caps_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
159 forEachOf terminals_of_interest $ \term_name -> monadic $ do
160 term <- setupTerm term_name
161 let table = caps_classify_table term keys_from_caps_table
162 input_seq = gen table
163 events = map snd input_seq
164 keydowns = map (Bytes . fst) input_seq
165 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
166 assert_events_from_syn_input table input events
168verify_special_syn_input_to_event :: Property IO
169verify_special_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
170 let table = special_support_keys
171 input_seq = gen table
172 events = map snd input_seq
173 keydowns = map (Bytes . fst) input_seq
174 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
175 assert_events_from_syn_input universal_table input events
177verify_full_syn_input_to_event :: Property IO
178verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
179 forEachOf terminals_of_interest $ \term_name -> monadic $ do
180 term <- setupTerm term_name
181 let table = classify_table_for_term term_name term
182 input_seq = gen table
183 events = map snd input_seq
184 keydowns = map (Bytes . fst) input_seq
185 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
186 assert_events_from_syn_input table input events
188verify_full_syn_input_to_event_2x :: Property IO
189verify_full_syn_input_to_event_2x = forAll $ \(InputBlocksUsingTable gen) ->
190 forEachOf terminals_of_interest $ \term_name -> monadic $ do
191 term <- setupTerm term_name
192 let table = classify_table_for_term term_name term
193 input_seq = gen table
194 events = concatMap ((\s -> [s,s]) . snd) input_seq
195 keydowns = map (Bytes . (\s -> s ++ s) . fst) input_seq
196 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
197 assert_events_from_syn_input table input events
199main :: IO ()
200main = defaultMain
201 [ testProperty "synthesized typing of single visible chars translates to expected events"
202 verify_visible_syn_input_to_event
203 , testProperty "synthesized typing of keys from capabilities tables translates to expected events"
204 verify_caps_syn_input_to_event
205 , testProperty "synthesized typing of hard coded special keys translates to expected events"
206 verify_special_syn_input_to_event
207 , testProperty "synthesized typing of any key in the table translates to its paired event"
208 verify_full_syn_input_to_event
209 , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"
210 verify_full_syn_input_to_event_2x
211 ]