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