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