git.iko.soy/vty
on 635f971 help sign in
vty/test/VerifyUsingMockInput.hs
115 lines 4.4 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, permutations)
13import Graphics.Vty hiding (resize)
14import Graphics.Vty.Input
15import Graphics.Vty.Input.Data
16import Graphics.Vty.Input.Internal
17import Graphics.Vty.Input.Terminfo
19import Control.Applicative
20import Control.Concurrent
21import Control.Exception
22import Control.Monad
24import System.Console.Terminfo
25import System.IO
27import Test.Framework.Providers.SmallCheck
28import Test.Framework
29import Test.SmallCheck
30import Test.SmallCheck.Series
32-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
33max_block_size :: Int
34max_block_size = 16
36data InputEvent
37 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
38 | Delay Int -- | millisecond delay
39 deriving Show
41type InputSpec = [InputEvent]
43type ExpectedSpec = [Event]
45exec_input_spec :: InputSpec -> Handle -> IO ()
46exec_input_spec input out_handle = forM_ input f
47 where
48 f (Bytes str) = hPutStr out_handle str >> hFlush out_handle
49 f (Delay t) = threadDelay (t*1000)
51assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
52assert_events_from_input_block table input_spec expected_events = do
53 print input_spec
54 let classifier = classify table
55 input <- newChan
56 output <- newChan
57 read_complete <- newEmptyMVar
58 write_complete <- newEmptyMVar
59 _ <- forkIO $ write_input_spec_to_chan input input_spec
60 `finally` putMVar write_complete ()
61 _ <- forkIO $ inputToEventThread classifier input output
62 `finally` putMVar read_complete ()
63 () <- takeMVar write_complete
64 () <- takeMVar read_complete
65 -- TODO: use STM channel
66 -- assures the next line does not block.
67 writeList2Chan output $ replicate (length expected_events) undefined
68 out_events <- take (length expected_events) <$> getChanContents output
69 return $ out_events == expected_events
71write_input_spec_to_chan :: Chan Char -> InputSpec -> IO ()
72write_input_spec_to_chan chan [] = do
73 writeChan chan '\xFFFD'
74write_input_spec_to_chan chan (Bytes str : input_spec') = do
75 writeList2Chan chan str
76 write_input_spec_to_chan chan input_spec'
77write_input_spec_to_chan chan (Delay _t : input_spec') = do
78 writeChan chan '\xFFFE'
79 write_input_spec_to_chan chan input_spec'
81newtype EventBlock event = EventBlock ([(String,event)] -> [(String, event)])
83instance Show (EventBlock event) where
84 show (EventBlock g) = "EventBlock(*->*)"
86instance Monad m => Serial m (EventBlock event) where
87 series = do
88 n :: Int <- localDepth (max max_block_size) series -- what elements to select from the table
89 return $ EventBlock $ \table -> concat (take n (permutations table))
91verify_simple_input_block_to_event :: Property IO
92verify_simple_input_block_to_event = forAll $ \(EventBlock block_gen) -> do
93 let simple_input_seq = block_gen simple_chars
94 input = Bytes $ concat [s | (s,_) <- simple_input_seq]
95 events = [e | (_,(k,ms)) <- simple_input_seq, let e = EvKey k ms]
96 monadic $ assert_events_from_input_block simple_chars [input] events
98verify_keys_from_caps_table_block_to_event :: Property IO
99verify_keys_from_caps_table_block_to_event = forAll $ \(EventBlock block_gen) ->
100 over (generate (\n -> take n terminals_of_interest)) $ \term_name -> monadic $ do
101 terminal <- setupTerm term_name
102 let table = caps_classify_table terminal keys_from_caps_table
103 input_seq :: [(String, Event)] = block_gen table
104 input_bytes = [Bytes s | (s,_) <- input_seq]
105 input = intersperse (Delay defaultEscDelay) input_bytes
106 events = [e | (_,e) <- input_seq]
107 assert_events_from_input_block (map_to_legacy_table table) input events
109main = defaultMain
110 [ testProperty "basic block generated from a single ansi chars to event translation"
111 verify_simple_input_block_to_event
112 , testProperty "key sequences read from caps table map to expected events"
113 verify_keys_from_caps_table_block_to_event
114 ]