@@ -11,7 +11,6 @@ import Verify.Graphics.Vty.Terminal
1111import Data.List (intersperse, permutations)
1212
1313import Graphics.Vty hiding (resize)
14−import Graphics.Vty.Input
1514import Graphics.Vty.Input.Data
1615import Graphics.Vty.Input.Internal
1716import Graphics.Vty.Input.Terminfo
@@ -21,8 +20,12 @@ import Control.Concurrent
2120import Control.Exception
2221import Control.Monad
2322
23+import Data.IORef
24+
2425import System.Console.Terminfo
25−import System.IO
26+import System.Posix.IO
27+import System.Posix.Types
28+import System.Timeout
2629
2730import Test.Framework.Providers.SmallCheck
2831import Test.Framework
@@ -38,48 +41,95 @@ forEachOf l = over (generate (\n -> take n l))
3841
3942data InputEvent
4043 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
41− | Delay Int -- | millisecond delay
44+ | Delay Int -- | microsecond delay
4245 deriving Show
4346
4447type InputSpec = [InputEvent]
4548
4649type ExpectedSpec = [Event]
4750
48−exec_input_spec :: InputSpec -> Handle -> IO ()
49−exec_input_spec input out_handle = forM_ input f
51+synthesize_input :: InputSpec -> Fd -> IO ()
52+synthesize_input input out_handle = forM_ input f >> (void $ fdWrite out_handle "\xFFFD")
5053 where
51− f (Bytes str) = hPutStr out_handle str >> hFlush out_handle
52− f (Delay t) = threadDelay (t*1000)
54+ f (Bytes str) = void $ fdWrite out_handle str
55+ f (Delay t) = threadDelay t
56+
57+min_detectable_delay :: Int
58+min_detectable_delay = 1000
59+
60+min_timout :: Int
61+min_timout = 4000000
62+
63+test_key_delay :: Int
64+test_key_delay = min_detectable_delay * 4
65+
66+test_esc_sample_delay :: Int
67+test_esc_sample_delay = min_detectable_delay * 2
68+
69+gen_events_using_io_actions :: Int -> IO () -> IO () -> IO ()
70+gen_events_using_io_actions max_duration input_action output_action = do
71+ let max_duration' = max min_timout max_duration
72+ read_complete <- newEmptyMVar
73+ write_complete <- newEmptyMVar
74+ _ <- forkIO $ input_action `finally` putMVar write_complete ()
75+ _ <- forkIO $ output_action `finally` putMVar read_complete ()
76+ Just () <- timeout max_duration' $ takeMVar write_complete
77+ Just () <- timeout max_duration' $ takeMVar read_complete
78+ return ()
79+
80+assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
81+assert_events_from_syn_input table input_spec expected_events = do
82+ let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
83+ event_count = length expected_events
84+ -- create pipe
85+ (output_fd, input_fd) <- createPipe
86+ (output, shutdown_input) <- initInputForFd test_esc_sample_delay table output_fd
87+ events_ref <- newIORef []
88+ let write_wait_close = do
89+ synthesize_input input_spec input_fd
90+ threadDelay min_detectable_delay
91+ shutdown_input
92+ threadDelay min_detectable_delay
93+ closeFd input_fd
94+ closeFd output_fd
95+ -- drain output pipe
96+ let read_all_events = read_loop event_count
97+ read_loop 0 = return ()
98+ read_loop n = do
99+ e <- readChan output
100+ modifyIORef events_ref ((:) e)
101+ read_loop (n - 1)
102+ gen_events_using_io_actions max_duration write_wait_close read_all_events
103+ out_events <- reverse <$> readIORef events_ref
104+ print (input_spec, expected_events, out_events)
105+ return $ out_events == expected_events
53106
54107assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
55108assert_events_from_input_block table input_spec expected_events = do
56− print input_spec
57109 let classifier = classify table
110+ max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
58111 input <- newChan
59112 output <- newChan
60− read_complete <- newEmptyMVar
61− write_complete <- newEmptyMVar
62− _ <- forkIO $ write_input_spec_to_chan input input_spec
63− `finally` putMVar write_complete ()
64− _ <- forkIO $ inputToEventThread classifier input output
65− `finally` putMVar read_complete ()
66− () <- takeMVar write_complete
67− () <- takeMVar read_complete
68− -- TODO: use STM channel
69− -- assures the next line does not block.
70− writeList2Chan output $ replicate (length expected_events) undefined
71− out_events <- take (length expected_events) <$> getChanContents output
113+ gen_events_using_io_actions
114+ max_duration
115+ (write_input_spec_to_chan input_spec input)
116+ (inputToEventThread classifier input output)
117+ -- TODO: use STM TChan?
118+ -- assures reading "length expected_events" from the channel does not block.
119+ let min_event_count = length expected_events
120+ writeList2Chan output $ replicate min_event_count undefined
121+ out_events <- take min_event_count <$> getChanContents output
72122 return $ out_events == expected_events
73123
74−write_input_spec_to_chan :: Chan Char -> InputSpec -> IO ()
75−write_input_spec_to_chan chan [] = do
124+write_input_spec_to_chan :: InputSpec -> Chan Char -> IO ()
125+write_input_spec_to_chan [] chan = do
76126 writeChan chan '\xFFFD'
77−write_input_spec_to_chan chan (Bytes str : input_spec') = do
127+write_input_spec_to_chan (Bytes str : input_spec') chan = do
78128 writeList2Chan chan str
79− write_input_spec_to_chan chan input_spec'
80−write_input_spec_to_chan chan (Delay _t : input_spec') = do
129+ write_input_spec_to_chan input_spec' chan
130+write_input_spec_to_chan (Delay _t : input_spec') chan = do
81131 writeChan chan '\xFFFE'
82− write_input_spec_to_chan chan input_spec'
132+ write_input_spec_to_chan input_spec' chan
83133
84134newtype InputBlocksUsingTable event
85135 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
@@ -107,14 +157,27 @@ verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable ge
107157 input_seq = gen table
108158 events = [e | (_,e) <- input_seq]
109159 keydowns = [Bytes s | (s,_) <- input_seq]
110− input = intersperse (Delay defaultEscDelay) keydowns
160+ input = intersperse (Delay test_key_delay) keydowns
111161 assert_events_from_input_block (map_to_legacy_table table) input events
112162
163+verify_simple_syn_input_to_event :: Property IO
164+verify_simple_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
165+ forEachOf terminals_of_interest $ \term_name -> monadic $ do
166+ term <- setupTerm term_name
167+ let table = caps_classify_table term keys_from_caps_table
168+ input_seq = gen table
169+ events = [e | (_,e) <- input_seq]
170+ keydowns = [Bytes s | (s,_) <- input_seq]
171+ input = intersperse (Delay test_key_delay) keydowns
172+ assert_events_from_syn_input (map_to_legacy_table table) input events
173+
113174main :: IO ()
114175main = defaultMain
115176 [ testProperty "basic block generated from a single ansi chars to event translation"
116− verify_simple_input_block_to_event
177+ verify_simple_input_block_to_event
117178 , testProperty "key sequences read from caps table map to expected events"
118− verify_keys_from_caps_table_block_to_event
179+ verify_keys_from_caps_table_block_to_event
180+ , testProperty "synthesized typing from basic blocks translates to expected events"
181+ verify_simple_syn_input_to_event
119182 ]
120183