git.iko.soy/vty
on 0bbc339 help sign in
vty/test/VerifyUsingMockInput.hs
244 lines 11 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.Output
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 :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool
86compare_events input_spec expected_events out_events = compare_events' expected_events out_events
87 where
88 compare_events' [] [] = return True
89 compare_events' [] out_events' = do
90 printf "extra events %s\n" (show out_events') :: IO ()
91 return False
92 compare_events' expected_events' [] = do
93 printf "events %s were not produced for input %s\n" (show expected_events') (show input_spec) :: IO ()
94 printf "expected events %s\n" (show expected_events) :: IO ()
95 printf "received events %s\n" (show out_events) :: IO ()
96 return False
97 compare_events' (e : expected_events') (o : out_events')
98 | e == o = compare_events' expected_events' out_events'
99 | otherwise = do
100 printf "%s expected not %s for input %s\n" (show e) (show o) (show input_spec) :: IO ()
101 printf "expected events %s\n" (show expected_events) :: IO ()
102 printf "received events %s\n" (show out_events) :: IO ()
103 return False
105assert_events_from_syn_input :: ClassifyTableV1 -> InputSpec -> ExpectedSpec -> IO Bool
106assert_events_from_syn_input table input_spec expected_events = do
107 let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
108 event_count = length expected_events
109 (output_fd, input_fd) <- createPipe
110 (output, shutdown_event_processing) <- initInputForFd test_esc_sample_delay table output_fd
111 events_ref <- newIORef []
112 let write_wait_close = do
113 synthesize_input input_spec input_fd
114 threadDelay min_detectable_delay
115 shutdown_event_processing
116 threadDelay min_detectable_delay
117 closeFd input_fd
118 closeFd output_fd
119 -- drain output pipe
120 let read_events = read_loop event_count
121 read_loop 0 = return ()
122 read_loop n = do
123 e <- readChan output
124 modifyIORef events_ref ((:) e)
125 read_loop (n - 1)
126 gen_events_using_io_actions max_duration write_wait_close read_events
127 out_events <- reverse <$> readIORef events_ref
128 compare_events input_spec expected_events out_events
130assert_events_from_input_block :: ClassifyTableV1 -> InputSpec -> ExpectedSpec -> IO Bool
131assert_events_from_input_block table input_spec expected_events = do
132 let classifier = classify table
133 max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
134 input <- newChan
135 output <- newChan
136 gen_events_using_io_actions
137 max_duration
138 (write_input_spec_to_chan input_spec input)
139 (inputToEventThread classifier input output)
140 -- TODO: use STM TChan?
141 -- assures reading "length expected_events" from the channel does not block.
142 let min_event_count = length expected_events
143 writeList2Chan output $ replicate min_event_count undefined
144 out_events <- take min_event_count <$> getChanContents output
145 return $ out_events == expected_events
147write_input_spec_to_chan :: InputSpec -> Chan Char -> IO ()
148write_input_spec_to_chan [] chan = do
149 writeChan chan '\xFFFD'
150write_input_spec_to_chan (Bytes str : input_spec') chan = do
151 writeList2Chan chan str
152 write_input_spec_to_chan input_spec' chan
153write_input_spec_to_chan (Delay _t : input_spec') chan = do
154 writeChan chan '\xFFFE'
155 write_input_spec_to_chan input_spec' chan
157newtype InputBlocksUsingTable event
158 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
160instance Show (InputBlocksUsingTable event) where
161 show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
163instance Monad m => Serial m (InputBlocksUsingTable event) where
164 series = do
165 n :: Int <- localDepth (const max_table_size) series
166 return $ InputBlocksUsingTable $ \table -> concat (take n (selections table))
167 where
168 selections [] = []
169 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
171verify_simple_input_block_to_event :: Property IO
172verify_simple_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do
173 let input_seq = gen simple_chars
174 input = Bytes $ concat [s | (s,_) <- input_seq]
175 events = [e | (_,(k,ms)) <- input_seq, let e = EvKey k ms]
176 monadic $ assert_events_from_input_block simple_chars [input] events
178verify_keys_from_caps_table_block_to_event :: Property IO
179verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable gen) ->
180 forEachOf terminals_of_interest $ \term_name -> monadic $ do
181 term <- setupTerm term_name
182 let table = caps_classify_table term keys_from_caps_table
183 input_seq = gen table
184 events = [e | (_,e) <- input_seq]
185 keydowns = [Bytes s | (s,_) <- input_seq]
186 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
187 assert_events_from_input_block (map_to_legacy_table table) input events
189verify_simple_syn_input_to_event :: Property IO
190verify_simple_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
191 let table = simple_chars
192 input_seq = gen table
193 events = [EvKey k ms | (_,(k,ms)) <- input_seq]
194 keydowns = [Bytes s | (s,_) <- input_seq]
195 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
196 assert_events_from_syn_input (concat ansi_classify_table) input events
198verify_caps_syn_input_to_event :: Property IO
199verify_caps_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
200 forEachOf terminals_of_interest $ \term_name -> monadic $ do
201 term <- setupTerm term_name
202 let table = caps_classify_table term keys_from_caps_table
203 input_seq = gen table
204 events = [e | (_,e) <- input_seq]
205 keydowns = [Bytes s | (s,_) <- input_seq]
206 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
207 assert_events_from_syn_input (map_to_legacy_table table) input events
209verify_special_syn_input_to_event :: Property IO
210verify_special_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
211 let table = function_keys_1 ++ function_keys_2
212 input_seq = gen table
213 events = [EvKey k ms | (_,(k,ms)) <- input_seq]
214 keydowns = [Bytes s | (s,_) <- input_seq]
215 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
216 assert_events_from_syn_input (concat ansi_classify_table) input events
218verify_full_syn_input_to_event :: Property IO
219verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
220 forEachOf terminals_of_interest $ \term_name -> monadic $ do
221 term <- setupTerm term_name
222 let table = classify_table_for_term term
223 input_seq = gen table
224 events = [EvKey k ms | (_,(k,ms)) <- input_seq]
225 keydowns = [Bytes s | (s,_) <- input_seq]
226 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
227 assert_events_from_syn_input table input events
229main :: IO ()
230main = defaultMain
231 [ testProperty "basic block generated from a single visible chars to event translation"
232 verify_simple_input_block_to_event
233 , testProperty "key sequences read from caps table map to expected events"
234 verify_keys_from_caps_table_block_to_event
235 , testProperty "synthesized typing from single visible chars translates to expected events"
236 verify_simple_syn_input_to_event
237 , testProperty "synthesized typing from keys from capabilities tables translates to expected events"
238 verify_caps_syn_input_to_event
239 , testProperty "synthesized typing from hard coded special keys translates to expected events"
240 verify_special_syn_input_to_event
241 , testProperty "synthesized typing from any key in the table translates to expected events"
242 verify_full_syn_input_to_event
243 ]