git.iko.soy/vty
on c231f47 help sign in
vty/test/VerifyUsingMockInput.hs
210 lines 8.6 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
35-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
36max_block_size :: Int
37max_block_size = 16
39max_table_size :: Int
40max_table_size = 28
42forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
43forEachOf l = over (generate (\n -> take n l))
45data InputEvent
46 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
47 | Delay Int -- | microsecond delay
48 deriving Show
50type InputSpec = [InputEvent]
52type ExpectedSpec = [Event]
54synthesize_input :: InputSpec -> Fd -> IO ()
55synthesize_input input out_handle = forM_ input f >> (void $ fdWrite out_handle "\xFFFD")
56 where
57 f (Bytes str) = void $ fdWrite out_handle str
58 f (Delay t) = threadDelay t
60min_detectable_delay :: Int
61min_detectable_delay = 1000
63min_timout :: Int
64min_timout = 4000000
66test_key_delay :: Int
67test_key_delay = min_detectable_delay * 4
69test_esc_sample_delay :: Int
70test_esc_sample_delay = min_detectable_delay * 2
72gen_events_using_io_actions :: Int -> IO () -> IO () -> IO ()
73gen_events_using_io_actions max_duration input_action output_action = do
74 let max_duration' = max min_timout max_duration
75 read_complete <- newEmptyMVar
76 write_complete <- newEmptyMVar
77 _ <- forkIO $ input_action `finally` putMVar write_complete ()
78 _ <- forkIO $ output_action `finally` putMVar read_complete ()
79 Just () <- timeout max_duration' $ takeMVar write_complete
80 Just () <- timeout max_duration' $ takeMVar read_complete
81 return ()
83assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
84assert_events_from_syn_input table input_spec expected_events = do
85 let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
86 event_count = length expected_events
87 (output_fd, input_fd) <- createPipe
88 (output, shutdown_input) <- initInputForFd test_esc_sample_delay table output_fd
89 events_ref <- newIORef []
90 let write_wait_close = do
91 synthesize_input input_spec input_fd
92 threadDelay min_detectable_delay
93 shutdown_input
94 threadDelay min_detectable_delay
95 closeFd input_fd
96 closeFd output_fd
97 -- drain output pipe
98 let read_events = read_loop event_count
99 read_loop 0 = return ()
100 read_loop n = do
101 e <- readChan output
102 modifyIORef events_ref ((:) e)
103 read_loop (n - 1)
104 gen_events_using_io_actions max_duration write_wait_close read_events
105 out_events <- reverse <$> readIORef events_ref
106 print (input_spec, expected_events, out_events)
107 return $ out_events == expected_events
109assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
110assert_events_from_input_block table input_spec expected_events = do
111 let classifier = classify table
112 max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
113 input <- newChan
114 output <- newChan
115 gen_events_using_io_actions
116 max_duration
117 (write_input_spec_to_chan input_spec input)
118 (inputToEventThread classifier input output)
119 -- TODO: use STM TChan?
120 -- assures reading "length expected_events" from the channel does not block.
121 let min_event_count = length expected_events
122 writeList2Chan output $ replicate min_event_count undefined
123 out_events <- take min_event_count <$> getChanContents output
124 return $ out_events == expected_events
126write_input_spec_to_chan :: InputSpec -> Chan Char -> IO ()
127write_input_spec_to_chan [] chan = do
128 writeChan chan '\xFFFD'
129write_input_spec_to_chan (Bytes str : input_spec') chan = do
130 writeList2Chan chan str
131 write_input_spec_to_chan input_spec' chan
132write_input_spec_to_chan (Delay _t : input_spec') chan = do
133 writeChan chan '\xFFFE'
134 write_input_spec_to_chan input_spec' chan
136newtype InputBlocksUsingTable event
137 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
139instance Show (InputBlocksUsingTable event) where
140 show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
142instance Monad m => Serial m (InputBlocksUsingTable event) where
143 series = do
144 n :: Int <- localDepth (const max_table_size) series
145 return $ InputBlocksUsingTable $ \table -> concat (take n (selections table))
146 where
147 selections [] = []
148 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
150verify_simple_input_block_to_event :: Property IO
151verify_simple_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do
152 let input_seq = gen simple_chars
153 input = Bytes $ concat [s | (s,_) <- input_seq]
154 events = [e | (_,(k,ms)) <- input_seq, let e = EvKey k ms]
155 monadic $ assert_events_from_input_block simple_chars [input] events
157verify_keys_from_caps_table_block_to_event :: Property IO
158verify_keys_from_caps_table_block_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 = [e | (_,e) <- input_seq]
164 keydowns = [Bytes s | (s,_) <- input_seq]
165 input = intersperse (Delay test_key_delay) keydowns
166 assert_events_from_input_block (map_to_legacy_table table) input events
168verify_simple_syn_input_to_event :: Property IO
169verify_simple_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
170 let table = simple_chars
171 input_seq = gen table
172 events = [EvKey k ms | (_,(k,ms)) <- input_seq]
173 keydowns = [Bytes s | (s,_) <- input_seq]
174 input = intersperse (Delay test_key_delay) keydowns
175 assert_events_from_syn_input (concat ansi_classify_table) input events
177verify_caps_syn_input_to_event :: Property IO
178verify_caps_syn_input_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
186 assert_events_from_syn_input (map_to_legacy_table table) input events
188verify_special_syn_input_to_event :: Property IO
189verify_special_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
190 let table = function_keys_1 ++ function_keys_2
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
195 assert_events_from_syn_input (concat ansi_classify_table) input events
197main :: IO ()
198main = defaultMain
199 [ testProperty "basic block generated from a single visible chars to event translation"
200 verify_simple_input_block_to_event
201 , testProperty "key sequences read from caps table map to expected events"
202 verify_keys_from_caps_table_block_to_event
203 , testProperty "synthesized typing from single visible chars translates to expected events"
204 verify_simple_syn_input_to_event
205 , testProperty "synthesized typing from keys from capabilities tables translates to expected events"
206 verify_caps_syn_input_to_event
207 , testProperty "synthesized typing from hard coded special keys translates to expected events"
208 verify_special_syn_input_to_event
209 ]