git.iko.soy/vty
on ccb1b24 help sign in
vty/test/VerifyUsingMockInput.hs
200 lines 8.1 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.Events
15import Graphics.Vty.Input.Internal
16import Graphics.Vty.Input.Terminfo
18import Control.Applicative
19import Control.Concurrent
20import Control.Exception
21import Control.Lens ((^.))
22import Control.Monad
24import Data.Default
25import Data.IORef
27import System.Console.Terminfo
28import System.Posix.IO
29import System.Posix.Terminal (openPseudoTerminal)
30import System.Posix.Types
31import System.Timeout
33import Test.Framework.Providers.SmallCheck
34import Test.Framework
35import Test.SmallCheck
36import Test.SmallCheck.Series
38import Text.Printf
40-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
41max_block_size :: Int
42max_block_size = 16
44max_table_size :: Int
45max_table_size = 28
47forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
48forEachOf l = over (generate (\n -> take n l))
50data InputEvent
51 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
52 | Delay Int -- | microsecond delay
53 deriving Show
55type InputSpec = [InputEvent]
57type ExpectedSpec = [Event]
59synthesize_input :: InputSpec -> Fd -> IO ()
60synthesize_input input out_handle = forM_ input f >> (void $ fdWrite out_handle "\xFFFD")
61 where
62 f (Bytes str) = void $ fdWrite out_handle str
63 f (Delay t) = threadDelay t
65min_detectable_delay :: Int
66min_detectable_delay = 4000
68min_timout :: Int
69min_timout = 4000000
71test_key_delay :: Int
72test_key_delay = min_detectable_delay * 4
74test_esc_sample_delay :: Int
75test_esc_sample_delay = min_detectable_delay * 2
77gen_events_using_io_actions :: Int -> IO () -> IO () -> IO ()
78gen_events_using_io_actions max_duration input_action output_action = do
79 let max_duration' = max min_timout max_duration
80 read_complete <- newEmptyMVar
81 write_complete <- newEmptyMVar
82 _ <- forkOS $ input_action `finally` putMVar write_complete ()
83 _ <- forkOS $ output_action `finally` putMVar read_complete ()
84 Just () <- timeout max_duration' $ takeMVar write_complete
85 Just () <- timeout max_duration' $ takeMVar read_complete
86 return ()
88compare_events :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool
89compare_events input_spec expected_events out_events = compare_events' expected_events out_events
90 where
91 compare_events' [] [] = return True
92 compare_events' [] out_events' = do
93 printf "extra events %s\n" (show out_events') :: IO ()
94 return False
95 compare_events' expected_events' [] = do
96 printf "events %s were not produced for input %s\n" (show expected_events') (show input_spec) :: IO ()
97 printf "expected events %s\n" (show expected_events) :: IO ()
98 printf "received events %s\n" (show out_events) :: IO ()
99 return False
100 compare_events' (e : expected_events') (o : out_events')
101 | e == o = compare_events' expected_events' out_events'
102 | otherwise = do
103 printf "%s expected not %s for input %s\n" (show e) (show o) (show input_spec) :: IO ()
104 printf "expected events %s\n" (show expected_events) :: IO ()
105 printf "received events %s\n" (show out_events) :: IO ()
106 return False
108assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
109assert_events_from_syn_input table input_spec expected_events = do
110 let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
111 event_count = length expected_events
112 (write_fd, read_fd) <- openPseudoTerminal
113 (set_term_attr,_) <- attributeControl read_fd
114 set_term_attr
115 input <- initInputForFd def table read_fd
116 events_ref <- newIORef []
117 let write_wait_close = do
118 synthesize_input input_spec write_fd
119 threadDelay min_detectable_delay
120 shutdown_input input
121 threadDelay min_detectable_delay
122 closeFd write_fd
123 closeFd read_fd
124 -- drain output pipe
125 let read_events = read_loop event_count
126 read_loop 0 = return ()
127 read_loop n = do
128 e <- readChan $ input^.event_channel
129 modifyIORef events_ref ((:) e)
130 read_loop (n - 1)
131 gen_events_using_io_actions max_duration write_wait_close read_events
132 out_events <- reverse <$> readIORef events_ref
133 compare_events input_spec expected_events out_events
135newtype InputBlocksUsingTable event
136 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
138instance Show (InputBlocksUsingTable event) where
139 show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
141instance Monad m => Serial m (InputBlocksUsingTable event) where
142 series = do
143 n :: Int <- localDepth (const max_table_size) series
144 return $ InputBlocksUsingTable $ \table -> concat (take n (selections table))
145 where
146 selections [] = []
147 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
149verify_visible_syn_input_to_event :: Property IO
150verify_visible_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
151 let table = visible_chars
152 input_seq = gen table
153 events = map snd input_seq
154 keydowns = map (Bytes . fst) input_seq
155 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
156 assert_events_from_syn_input universal_table input events
158verify_caps_syn_input_to_event :: Property IO
159verify_caps_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
160 forEachOf terminals_of_interest $ \term_name -> monadic $ do
161 term <- setupTerm term_name
162 let table = caps_classify_table term keys_from_caps_table
163 input_seq = gen table
164 events = map snd input_seq
165 keydowns = map (Bytes . fst) input_seq
166 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
167 assert_events_from_syn_input table input events
169verify_special_syn_input_to_event :: Property IO
170verify_special_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
171 let table = special_support_keys
172 input_seq = gen table
173 events = map snd input_seq
174 keydowns = map (Bytes . fst) input_seq
175 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
176 assert_events_from_syn_input universal_table input events
178verify_full_syn_input_to_event :: Property IO
179verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
180 forEachOf terminals_of_interest $ \term_name -> monadic $ do
181 term <- setupTerm term_name
182 let table = classify_table_for_term term_name term
183 input_seq = gen table
184 events = map snd input_seq
185 keydowns = map (Bytes . fst) input_seq
186 input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
187 assert_events_from_syn_input table input events
189main :: IO ()
190main = defaultMain
191 [ testProperty "synthesized typing from single visible chars translates to expected events"
192 verify_visible_syn_input_to_event
193 , testProperty "synthesized typing from keys from capabilities tables translates to expected events"
194 verify_caps_syn_input_to_event
195 , testProperty "synthesized typing from hard coded special keys translates to expected events"
196 verify_special_syn_input_to_event
197 , testProperty "synthesized typing from any key in the table translates to expected events"
198 verify_full_syn_input_to_event
199 ]