git.iko.soy/vty
on da216cb help sign in
vty/test/VerifyUsingMockInput.hs
213 lines 8.6 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.Exception
18import Control.Lens ((^.))
19import Control.Monad
21import Data.Default
22import Data.IORef
23import Data.List (intersperse, reverse, nubBy)
25import System.Console.Terminfo
26import System.Posix.IO
27import System.Posix.Terminal (openPseudoTerminal)
28import System.Posix.Types
29import System.Timeout
31import Test.Framework.Providers.SmallCheck
32import Test.Framework
33import Test.SmallCheck
34import Test.SmallCheck.Series
36import Text.Printf
38-- processing a block of 16 chars is the largest I can do without taking too long to run the test.
39maxBlockSize :: Int
40maxBlockSize = 16
42maxTableSize :: Int
43maxTableSize = 28
45forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
46forEachOf l = over (generate (\n -> take n l))
48data InputEvent
49 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
50 | Delay Int -- | microsecond delay
51 deriving Show
53type InputSpec = [InputEvent]
55type ExpectedSpec = [Event]
57synthesizeInput :: InputSpec -> Fd -> IO ()
58synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD")
59 where
60 f (Bytes str) = void $ fdWrite outHandle str
61 f (Delay t) = threadDelay t
63minDetectableDelay :: Int
64minDetectableDelay = 4000
66minTimout :: Int
67minTimout = 4000000
69testKeyDelay :: Int
70testKeyDelay = minDetectableDelay * 4
72testEscSampleDelay :: Int
73testEscSampleDelay = minDetectableDelay * 2
75genEventsUsingIoActions :: Int -> IO () -> IO () -> IO ()
76genEventsUsingIoActions maxDuration inputAction outputAction = do
77 let maxDuration' = max minTimout maxDuration
78 readComplete <- newEmptyMVar
79 writeComplete <- newEmptyMVar
80 _ <- forkOS $ inputAction `finally` putMVar writeComplete ()
81 _ <- forkOS $ outputAction `finally` putMVar readComplete ()
82 Just () <- timeout maxDuration' $ takeMVar writeComplete
83 Just () <- timeout maxDuration' $ takeMVar readComplete
84 return ()
86compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool
87compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents
88 where
89 compareEvents' [] [] = return True
90 compareEvents' [] outEvents' = do
91 printf "extra events %s\n" (show outEvents') :: IO ()
92 return False
93 compareEvents' expectedEvents' [] = do
94 printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO ()
95 printf "expected events %s\n" (show expectedEvents) :: IO ()
96 printf "received events %s\n" (show outEvents) :: IO ()
97 return False
98 compareEvents' (e : expectedEvents') (o : outEvents')
99 | e == o = compareEvents' expectedEvents' outEvents'
100 | otherwise = do
101 printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO ()
102 printf "expected events %s\n" (show expectedEvents) :: IO ()
103 printf "received events %s\n" (show outEvents) :: IO ()
104 return False
106assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool
107assertEventsFromSynInput table inputSpec expectedEvents = do
108 let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay
109 eventCount = length expectedEvents
110 (writeFd, readFd) <- openPseudoTerminal
111 (setTermAttr,_) <- attributeControl readFd
112 setTermAttr
113 input <- initInputForFd def "dummy" table readFd
114 eventsRef <- newIORef []
115 let writeWaitClose = do
116 synthesizeInput inputSpec writeFd
117 threadDelay minDetectableDelay
118 shutdownInput input
119 threadDelay minDetectableDelay
120 closeFd writeFd
121 closeFd readFd
122 -- drain output pipe
123 let readEvents = readLoop eventCount
124 readLoop 0 = return ()
125 readLoop n = do
126 e <- readChan $ input^.eventChannel
127 modifyIORef eventsRef ((:) e)
128 readLoop (n - 1)
129 genEventsUsingIoActions maxDuration writeWaitClose readEvents
130 outEvents <- reverse <$> readIORef eventsRef
131 compareEvents inputSpec expectedEvents outEvents
133newtype InputBlocksUsingTable event
134 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
136instance Show (InputBlocksUsingTable event) where
137 show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
139instance Monad m => Serial m (InputBlocksUsingTable event) where
140 series = do
141 n :: Int <- localDepth (const maxTableSize) series
142 return $ InputBlocksUsingTable $ \raw_table ->
143 let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table
144 in concat (take n (selections table))
145 where
146 selections [] = []
147 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
149verifyVisibleSynInputToEvent :: Property IO
150verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
151 let table = visibleChars
152 inputSeq = gen table
153 events = map snd inputSeq
154 keydowns = map (Bytes . fst) inputSeq
155 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
156 assertEventsFromSynInput universalTable input events
158verifyCapsSynInputToEvent :: Property IO
159verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
160 forEachOf terminalsOfInterest $ \termName -> monadic $ do
161 term <- setupTerm termName
162 let table = capsClassifyMap term keysFromCapsTable
163 inputSeq = gen table
164 events = map snd inputSeq
165 keydowns = map (Bytes . fst) inputSeq
166 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
167 assertEventsFromSynInput table input events
169verifySpecialSynInputToEvent :: Property IO
170verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
171 let table = specialSupportKeys
172 inputSeq = gen table
173 events = map snd inputSeq
174 keydowns = map (Bytes . fst) inputSeq
175 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
176 assertEventsFromSynInput universalTable input events
178verifyFullSynInputToEvent :: Property IO
179verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
180 forEachOf terminalsOfInterest $ \termName -> monadic $ do
181 term <- setupTerm termName
182 let table = classifyMapForTerm termName term
183 inputSeq = gen table
184 events = map snd inputSeq
185 keydowns = map (Bytes . fst) inputSeq
186 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
187 assertEventsFromSynInput table input events
189verifyFullSynInputToEvent_2x :: Property IO
190verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
191 forEachOf terminalsOfInterest $ \termName -> monadic $ do
192 term <- setupTerm termName
193 let table = classifyMapForTerm termName term
194 inputSeq = gen table
195 events = concatMap ((\s -> [s,s]) . snd) inputSeq
196 keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
197 input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
198 assertEventsFromSynInput table input events
200main :: IO ()
201main = defaultMain
202 [ testProperty "synthesized typing of single visible chars translates to expected events"
203 verifyVisibleSynInputToEvent
204 , testProperty "synthesized typing of keys from capabilities tables translates to expected events"
205 verifyCapsSynInputToEvent
206 , testProperty "synthesized typing of hard coded special keys translates to expected events"
207 verifySpecialSynInputToEvent
208 , testProperty "synthesized typing of any key in the table translates to its paired event"
209 verifyFullSynInputToEvent
210 , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"
211 verifyFullSynInputToEvent_2x
212 ]