git.iko.soy/vty
on ce9515a help sign in
vty/test/VerifyUsingMockInput.hs
212 lines 8.5 kB history raw
1{-# LANGUAGE MultiParamTypeClasses #-}
2{-# LANGUAGE FlexibleInstances #-}
3{- Generate some input bytes and delays between blocks of input bytes. Verify the events produced
4 - are as expected.
5 -}
6module Main where
8import Verify.Graphics.Vty.Output
10import Data.List (intersperse)
12import Graphics.Vty hiding (resize)
13import Graphics.Vty.Input.Events
14import Graphics.Vty.Input.Loop
15import Graphics.Vty.Input.Terminfo
17import Control.Applicative
18import Control.Concurrent
19import Control.Exception
20import Control.Lens ((^.))
21import Control.Monad
23import Data.Default
24import Data.IORef
26import System.Console.Terminfo
27import System.Posix.IO
28import System.Posix.Terminal (openPseudoTerminal)
29import System.Posix.Types
30import System.Timeout
32import Test.Framework.Providers.SmallCheck
33import Test.Framework
34import Test.SmallCheck
35import Test.SmallCheck.Series
37import Text.Printf
39-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
40maxBlockSize :: Int
41maxBlockSize = 16
43maxTableSize :: Int
44maxTableSize = 28
46forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
47forEachOf l = over (generate (\n -> take n l))
49data InputEvent
50 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
51 | Delay Int -- | microsecond delay
52 deriving Show
54type InputSpec = [InputEvent]
56type ExpectedSpec = [Event]
58synthesizeInput :: InputSpec -> Fd -> IO ()
59synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD")
60 where
61 f (Bytes str) = void $ fdWrite outHandle str
62 f (Delay t) = threadDelay t
64minDetectableDelay :: Int
65minDetectableDelay = 4000
67minTimout :: Int
68minTimout = 4000000
70testKeyDelay :: Int
71testKeyDelay = minDetectableDelay * 4
73testEscSampleDelay :: Int
74testEscSampleDelay = minDetectableDelay * 2
76genEventsUsingIoActions :: Int -> IO () -> IO () -> IO ()
77genEventsUsingIoActions maxDuration inputAction outputAction = do
78 let maxDuration' = max minTimout maxDuration
79 readComplete <- newEmptyMVar
80 writeComplete <- newEmptyMVar
81 _ <- forkOS $ inputAction `finally` putMVar writeComplete ()
82 _ <- forkOS $ outputAction `finally` putMVar readComplete ()
83 Just () <- timeout maxDuration' $ takeMVar writeComplete
84 Just () <- timeout maxDuration' $ takeMVar readComplete
85 return ()
87compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool
88compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents
89 where
90 compareEvents' [] [] = return True
91 compareEvents' [] outEvents' = do
92 printf "extra events %s\n" (show outEvents') :: IO ()
93 return False
94 compareEvents' expectedEvents' [] = do
95 printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO ()
96 printf "expected events %s\n" (show expectedEvents) :: IO ()
97 printf "received events %s\n" (show outEvents) :: IO ()
98 return False
99 compareEvents' (e : expectedEvents') (o : outEvents')
100 | e == o = compareEvents' expectedEvents' outEvents'
101 | otherwise = do
102 printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO ()
103 printf "expected events %s\n" (show expectedEvents) :: IO ()
104 printf "received events %s\n" (show outEvents) :: IO ()
105 return False
107assertEventsFromSynInput :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
108assertEventsFromSynInput table inputSpec expectedEvents = do
109 let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay
110 eventCount = length expectedEvents
111 (writeFd, readFd) <- openPseudoTerminal
112 (setTermAttr,_) <- attributeControl readFd
113 setTermAttr
114 input <- initInputForFd def table readFd
115 eventsRef <- newIORef []
116 let writeWaitClose = do
117 synthesizeInput inputSpec writeFd
118 threadDelay minDetectableDelay
119 shutdownInput input
120 threadDelay minDetectableDelay
121 closeFd writeFd
122 closeFd readFd
123 -- drain output pipe
124 let readEvents = readLoop eventCount
125 readLoop 0 = return ()
126 readLoop n = do
127 e <- readChan $ input^.eventChannel
128 modifyIORef eventsRef ((:) e)
129 readLoop (n - 1)
130 genEventsUsingIoActions maxDuration writeWaitClose readEvents
131 outEvents <- reverse <$> readIORef eventsRef
132 compareEvents inputSpec expectedEvents outEvents
134newtype InputBlocksUsingTable event
135 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
137instance Show (InputBlocksUsingTable event) where
138 show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
140instance Monad m => Serial m (InputBlocksUsingTable event) where
141 series = do
142 n :: Int <- localDepth (const maxTableSize) series
143 return $ InputBlocksUsingTable $ \table -> concat (take n (selections table))
144 where
145 selections [] = []
146 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
148verifyVisibleSynInputToEvent :: Property IO
149verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
150 let table = visibleChars
151 inputSeq = gen table
152 events = map snd inputSeq
153 keydowns = map (Bytes . fst) inputSeq
154 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
155 assertEventsFromSynInput universalTable input events
157verifyCapsSynInputToEvent :: Property IO
158verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
159 forEachOf terminalsOfInterest $ \termName -> monadic $ do
160 term <- setupTerm termName
161 let table = capsClassifyTable term keysFromCapsTable
162 inputSeq = gen table
163 events = map snd inputSeq
164 keydowns = map (Bytes . fst) inputSeq
165 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
166 assertEventsFromSynInput table input events
168verifySpecialSynInputToEvent :: Property IO
169verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
170 let table = specialSupportKeys
171 inputSeq = gen table
172 events = map snd inputSeq
173 keydowns = map (Bytes . fst) inputSeq
174 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
175 assertEventsFromSynInput universalTable input events
177verifyFullSynInputToEvent :: Property IO
178verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
179 forEachOf terminalsOfInterest $ \termName -> monadic $ do
180 term <- setupTerm termName
181 let table = classifyTableForTerm termName term
182 inputSeq = gen table
183 events = map snd inputSeq
184 keydowns = map (Bytes . fst) inputSeq
185 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
186 assertEventsFromSynInput table input events
188verifyFullSynInputToEvent_2x :: Property IO
189verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
190 forEachOf terminalsOfInterest $ \termName -> monadic $ do
191 term <- setupTerm termName
192 let table = classifyTableForTerm termName term
193 inputSeq = gen table
194 events = concatMap ((\s -> [s,s]) . snd) inputSeq
195 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
196 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
197 assertEventsFromSynInput table input events
199main :: IO ()
200main = defaultMain
201 [ testProperty "synthesized typing of single visible chars translates to expected events"
202 verifyVisibleSynInputToEvent
203 , testProperty "synthesized typing of keys from capabilities tables translates to expected events"
204 verifyCapsSynInputToEvent
205 , testProperty "synthesized typing of hard coded special keys translates to expected events"
206 verifySpecialSynInputToEvent
207 , testProperty "synthesized typing of any key in the table translates to its paired event"
208 verifyFullSynInputToEvent
209 , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"
210 verifyFullSynInputToEvent_2x
211 ]