git.iko.soy/vty
on ff9f4e6 help sign in
vty/test/VerifyUsingMockInput.hs
219 lines 8.8 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 Graphics.Vty hiding (resize)
11import Graphics.Vty.Input.Events
12import Graphics.Vty.Input.Loop
13import Graphics.Vty.Input.Terminfo
15import Control.Applicative
16import Control.Concurrent
17import Control.Concurrent.STM
18import Control.Exception
19import Lens.Micro ((^.))
20import Control.Monad
22import Data.Default
23import Data.IORef
24import Data.List (intersperse, reverse, nubBy)
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 :: ClassifyMap -> 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 let testConfig = def { inputFd = Just readFd
115 , termName = Just "dummy"
116 , vmin = Just 1
117 , vtime = Just 100
118 }
119 input <- initInput testConfig table
120 eventsRef <- newIORef []
121 let writeWaitClose = do
122 synthesizeInput inputSpec writeFd
123 threadDelay minDetectableDelay
124 shutdownInput input
125 threadDelay minDetectableDelay
126 closeFd writeFd
127 closeFd readFd
128 -- drain output pipe
129 let readEvents = readLoop eventCount
130 readLoop 0 = return ()
131 readLoop n = do
132 e <- atomically $ readTChan $ input^.eventChannel
133 modifyIORef eventsRef ((:) e)
134 readLoop (n - 1)
135 genEventsUsingIoActions maxDuration writeWaitClose readEvents
136 outEvents <- reverse <$> readIORef eventsRef
137 compareEvents inputSpec expectedEvents outEvents
139newtype InputBlocksUsingTable event
140 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
142instance Show (InputBlocksUsingTable event) where
143 show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
145instance Monad m => Serial m (InputBlocksUsingTable event) where
146 series = do
147 n :: Int <- localDepth (const maxTableSize) series
148 return $ InputBlocksUsingTable $ \raw_table ->
149 let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table
150 in concat (take n (selections table))
151 where
152 selections [] = []
153 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
155verifyVisibleSynInputToEvent :: Property IO
156verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
157 let table = visibleChars
158 inputSeq = gen table
159 events = map snd inputSeq
160 keydowns = map (Bytes . fst) inputSeq
161 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
162 assertEventsFromSynInput universalTable input events
164verifyCapsSynInputToEvent :: Property IO
165verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
166 forEachOf terminalsOfInterest $ \termName -> monadic $ do
167 term <- setupTerm termName
168 let table = capsClassifyMap term keysFromCapsTable
169 inputSeq = gen table
170 events = map snd inputSeq
171 keydowns = map (Bytes . fst) inputSeq
172 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
173 assertEventsFromSynInput table input events
175verifySpecialSynInputToEvent :: Property IO
176verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
177 let table = specialSupportKeys
178 inputSeq = gen table
179 events = map snd inputSeq
180 keydowns = map (Bytes . fst) inputSeq
181 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
182 assertEventsFromSynInput universalTable input events
184verifyFullSynInputToEvent :: Property IO
185verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
186 forEachOf terminalsOfInterest $ \termName -> monadic $ do
187 term <- setupTerm termName
188 let table = classifyMapForTerm termName term
189 inputSeq = gen table
190 events = map snd inputSeq
191 keydowns = map (Bytes . fst) inputSeq
192 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
193 assertEventsFromSynInput table input events
195verifyFullSynInputToEvent_2x :: Property IO
196verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
197 forEachOf terminalsOfInterest $ \termName -> monadic $ do
198 term <- setupTerm termName
199 let table = classifyMapForTerm termName term
200 inputSeq = gen table
201 events = concatMap ((\s -> [s,s]) . snd) inputSeq
202 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
203 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
204 assertEventsFromSynInput table input events
206main :: IO ()
207main = defaultMain
208 [ testProperty "synthesized typing of single visible chars translates to expected events"
209 verifyVisibleSynInputToEvent
210 , testProperty "synthesized typing of keys from capabilities tables translates to expected events"
211 verifyCapsSynInputToEvent
212 , testProperty "synthesized typing of hard coded special keys translates to expected events"
213 verifySpecialSynInputToEvent
214 , testProperty "synthesized typing of any key in the table translates to its paired event"
215 verifyFullSynInputToEvent
216 , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"
217 verifyFullSynInputToEvent_2x
218 ]