git.iko.soy/vty
on 11db66e help sign in
vty/test/VerifyUsingMockInput.hs
243 lines 10 kB history raw
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
3{- We setup the environment to envoke certain terminals of interest.
4 - This assumes appropriate definitions exist in the current environment for the terminals of
5 - interest.
6 -}
7module Main where
9import Verify.Graphics.Vty.Terminal
11import Data.List (intersperse)
13import Graphics.Vty hiding (resize)
14import Graphics.Vty.Input.Data
15import Graphics.Vty.Input.Internal
16import Graphics.Vty.Input.Terminfo
18import Control.Applicative
19import Control.Concurrent
20import Control.Exception
21import Control.Monad
23import Data.IORef
25import System.Console.Terminfo
26import System.Posix.IO
27import System.Posix.Types
28import System.Timeout
30import Test.Framework.Providers.SmallCheck
31import Test.Framework
32import Test.SmallCheck
33import Test.SmallCheck.Series
35import Text.Printf
37-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
38max_block_size :: Int
39max_block_size = 16
41max_table_size :: Int
42max_table_size = 28
44forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
45forEachOf l = over (generate (\n -> take n l))
47data InputEvent
48 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
49 | Delay Int -- | microsecond delay
50 deriving Show
52type InputSpec = [InputEvent]
54type ExpectedSpec = [Event]
56synthesize_input :: InputSpec -> Fd -> IO ()
57synthesize_input input out_handle = forM_ input f >> (void $ fdWrite out_handle "\xFFFD")
58 where
59 f (Bytes str) = void $ fdWrite out_handle str
60 f (Delay t) = threadDelay t
62min_detectable_delay :: Int
63min_detectable_delay = 4000
65min_timout :: Int
66min_timout = 4000000
68test_key_delay :: Int
69test_key_delay = min_detectable_delay * 4
71test_esc_sample_delay :: Int
72test_esc_sample_delay = min_detectable_delay * 2
74gen_events_using_io_actions :: Int -> IO () -> IO () -> IO ()
75gen_events_using_io_actions max_duration input_action output_action = do
76 let max_duration' = max min_timout max_duration
77 read_complete <- newEmptyMVar
78 write_complete <- newEmptyMVar
79 _ <- forkIO $ input_action `finally` putMVar write_complete ()
80 _ <- forkIO $ output_action `finally` putMVar read_complete ()
81 Just () <- timeout max_duration' $ takeMVar write_complete
82 Just () <- timeout max_duration' $ takeMVar read_complete
83 return ()
85compare_events input_spec expected_events out_events = compare_events' expected_events out_events
86 where
87 compare_events' [] [] = return True
88 compare_events' [] out_events' = do
89 printf "extra events %s\n" (show out_events) :: IO ()
90 return False
91 compare_events' expected_events' [] = do
92 printf "events %s were not produced for input %s\n" (show expected_events') (show input_spec) :: IO ()
93 printf "expected events %s\n" (show expected_events) :: IO ()
94 printf "received events %s\n" (show out_events) :: IO ()
95 return False
96 compare_events' (e : expected_events') (o : out_events')
97 | e == o = compare_events' expected_events' out_events'
98 | otherwise = do
99 printf "%s expected not %s for input %s\n" (show e) (show o) (show input_spec) :: IO ()
100 printf "expected events %s\n" (show expected_events) :: IO ()
101 printf "received events %s\n" (show out_events) :: IO ()
102 return False
104assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
105assert_events_from_syn_input table input_spec expected_events = do
106 let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
107 event_count = length expected_events
108 (output_fd, input_fd) <- createPipe
109 (output, shutdown_input) <- initInputForFd test_esc_sample_delay table output_fd
110 events_ref <- newIORef []
111 let write_wait_close = do
112 synthesize_input input_spec input_fd
113 threadDelay min_detectable_delay
114 shutdown_input
115 threadDelay min_detectable_delay
116 closeFd input_fd
117 closeFd output_fd
118 -- drain output pipe
119 let read_events = read_loop event_count
120 read_loop 0 = return ()
121 read_loop n = do
122 e <- readChan output
123 modifyIORef events_ref ((:) e)
124 read_loop (n - 1)
125 gen_events_using_io_actions max_duration write_wait_close read_events
126 out_events <- reverse <$> readIORef events_ref
127 compare_events input_spec expected_events out_events
129assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
130assert_events_from_input_block table input_spec expected_events = do
131 let classifier = classify table
132 max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
133 input <- newChan
134 output <- newChan
135 gen_events_using_io_actions
136 max_duration
137 (write_input_spec_to_chan input_spec input)
138 (inputToEventThread classifier input output)
139 -- TODO: use STM TChan?
140 -- assures reading "length expected_events" from the channel does not block.
141 let min_event_count = length expected_events
142 writeList2Chan output $ replicate min_event_count undefined
143 out_events <- take min_event_count <$> getChanContents output
144 return $ out_events == expected_events
146write_input_spec_to_chan :: InputSpec -> Chan Char -> IO ()
147write_input_spec_to_chan [] chan = do
148 writeChan chan '\xFFFD'
149write_input_spec_to_chan (Bytes str : input_spec') chan = do
150 writeList2Chan chan str
151 write_input_spec_to_chan input_spec' chan
152write_input_spec_to_chan (Delay _t : input_spec') chan = do
153 writeChan chan '\xFFFE'
154 write_input_spec_to_chan input_spec' chan
156newtype InputBlocksUsingTable event
157 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
159instance Show (InputBlocksUsingTable event) where
160 show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
162instance Monad m => Serial m (InputBlocksUsingTable event) where
163 series = do
164 n :: Int <- localDepth (const max_table_size) series
165 return $ InputBlocksUsingTable $ \table -> concat (take n (selections table))
166 where
167 selections [] = []
168 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
170verify_simple_input_block_to_event :: Property IO
171verify_simple_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do
172 let input_seq = gen simple_chars
173 input = Bytes $ concat [s | (s,_) <- input_seq]
174 events = [e | (_,(k,ms)) <- input_seq, let e = EvKey k ms]
175 monadic $ assert_events_from_input_block simple_chars [input] events
177verify_keys_from_caps_table_block_to_event :: Property IO
178verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable gen) ->
179 forEachOf terminals_of_interest $ \term_name -> monadic $ do
180 term <- setupTerm term_name
181 let table = caps_classify_table term keys_from_caps_table
182 input_seq = gen table
183 events = [e | (_,e) <- input_seq]
184 keydowns = [Bytes s | (s,_) <- input_seq]
185 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
186 assert_events_from_input_block (map_to_legacy_table table) input events
188verify_simple_syn_input_to_event :: Property IO
189verify_simple_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
190 let table = simple_chars
191 input_seq = gen table
192 events = [EvKey k ms | (_,(k,ms)) <- input_seq]
193 keydowns = [Bytes s | (s,_) <- input_seq]
194 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
195 assert_events_from_syn_input (concat ansi_classify_table) input events
197verify_caps_syn_input_to_event :: Property IO
198verify_caps_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
199 forEachOf terminals_of_interest $ \term_name -> monadic $ do
200 term <- setupTerm term_name
201 let table = caps_classify_table term keys_from_caps_table
202 input_seq = gen table
203 events = [e | (_,e) <- input_seq]
204 keydowns = [Bytes s | (s,_) <- input_seq]
205 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
206 assert_events_from_syn_input (map_to_legacy_table table) input events
208verify_special_syn_input_to_event :: Property IO
209verify_special_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
210 let table = function_keys_1 ++ function_keys_2
211 input_seq = gen table
212 events = [EvKey k ms | (_,(k,ms)) <- input_seq]
213 keydowns = [Bytes s | (s,_) <- input_seq]
214 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
215 assert_events_from_syn_input (concat ansi_classify_table) input events
217verify_full_syn_input_to_event :: Property IO
218verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
219 forEachOf terminals_of_interest $ \term_name -> monadic $ do
220 term <- setupTerm term_name
221 let table = classify_table_for_term term
222 input_seq = gen table
223 events = [EvKey k ms | (_,(k,ms)) <- input_seq]
224 keydowns = [Bytes s | (s,_) <- input_seq]
225 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
226 assert_events_from_syn_input table input events
228main :: IO ()
229main = defaultMain
230 [ testProperty "basic block generated from a single visible chars to event translation"
231 verify_simple_input_block_to_event
232 , testProperty "key sequences read from caps table map to expected events"
233 verify_keys_from_caps_table_block_to_event
234 , testProperty "synthesized typing from single visible chars translates to expected events"
235 verify_simple_syn_input_to_event
236 , testProperty "synthesized typing from keys from capabilities tables translates to expected events"
237 verify_caps_syn_input_to_event
238 , testProperty "synthesized typing from hard coded special keys translates to expected events"
239 verify_special_syn_input_to_event
240 , testProperty "synthesized typing from any key in the table translates to expected events"
241 verify_full_syn_input_to_event
242 ]