mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-10-04 03:07:07 +03:00
224 lines
8.8 KiB
Haskell
224 lines
8.8 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
-- Generate some input bytes and delays between blocks of input bytes.
|
|
-- Verify the events produced are as expected.
|
|
module Main where
|
|
|
|
import Verify.Graphics.Vty.Output
|
|
|
|
import Graphics.Vty hiding (resize)
|
|
import Graphics.Vty.Input.Events
|
|
import Graphics.Vty.Input.Loop
|
|
import Graphics.Vty.Input.Terminfo
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.STM
|
|
import Control.Exception
|
|
import Lens.Micro ((^.))
|
|
import Control.Monad
|
|
|
|
import Data.IORef
|
|
import Data.List (intersperse, reverse, nubBy)
|
|
|
|
import System.Console.Terminfo
|
|
import System.Posix.IO
|
|
import System.Posix.Terminal (openPseudoTerminal)
|
|
import System.Posix.Types
|
|
import System.Timeout
|
|
|
|
import Test.Framework.Providers.SmallCheck
|
|
import Test.Framework
|
|
import Test.SmallCheck
|
|
import Test.SmallCheck.Series
|
|
|
|
import Text.Printf
|
|
|
|
-- processing a block of 16 chars is the largest I can do without taking
|
|
-- too long to run the test.
|
|
maxBlockSize :: Int
|
|
maxBlockSize = 16
|
|
|
|
maxTableSize :: Int
|
|
maxTableSize = 28
|
|
|
|
forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m
|
|
forEachOf l = over (generate (\n -> take n l))
|
|
|
|
data InputEvent
|
|
= Bytes String
|
|
-- ^ Input sequence encoded as a string. Regardless, the input is
|
|
-- read a byte at a time.
|
|
| Delay Int
|
|
-- ^ Microsecond delay
|
|
deriving Show
|
|
|
|
type InputSpec = [InputEvent]
|
|
|
|
type ExpectedSpec = [Event]
|
|
|
|
synthesizeInput :: InputSpec -> Fd -> IO ()
|
|
synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD")
|
|
where
|
|
f (Bytes str) = void $ fdWrite outHandle str
|
|
f (Delay t) = threadDelay t
|
|
|
|
minDetectableDelay :: Int
|
|
minDetectableDelay = 4000
|
|
|
|
minTimout :: Int
|
|
minTimout = 4000000
|
|
|
|
testKeyDelay :: Int
|
|
testKeyDelay = minDetectableDelay * 4
|
|
|
|
testEscSampleDelay :: Int
|
|
testEscSampleDelay = minDetectableDelay * 2
|
|
|
|
genEventsUsingIoActions :: Int -> IO () -> IO () -> IO ()
|
|
genEventsUsingIoActions maxDuration inputAction outputAction = do
|
|
let maxDuration' = max minTimout maxDuration
|
|
readComplete <- newEmptyMVar
|
|
writeComplete <- newEmptyMVar
|
|
_ <- forkOS $ inputAction `finally` putMVar writeComplete ()
|
|
_ <- forkOS $ outputAction `finally` putMVar readComplete ()
|
|
Just () <- timeout maxDuration' $ takeMVar writeComplete
|
|
Just () <- timeout maxDuration' $ takeMVar readComplete
|
|
return ()
|
|
|
|
compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool
|
|
compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents
|
|
where
|
|
compareEvents' [] [] = return True
|
|
compareEvents' [] outEvents' = do
|
|
printf "extra events %s\n" (show outEvents') :: IO ()
|
|
return False
|
|
compareEvents' expectedEvents' [] = do
|
|
printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO ()
|
|
printf "expected events %s\n" (show expectedEvents) :: IO ()
|
|
printf "received events %s\n" (show outEvents) :: IO ()
|
|
return False
|
|
compareEvents' (e : expectedEvents') (o : outEvents')
|
|
| e == o = compareEvents' expectedEvents' outEvents'
|
|
| otherwise = do
|
|
printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO ()
|
|
printf "expected events %s\n" (show expectedEvents) :: IO ()
|
|
printf "received events %s\n" (show outEvents) :: IO ()
|
|
return False
|
|
|
|
assertEventsFromSynInput :: ClassifyMap -> InputSpec -> ExpectedSpec -> IO Bool
|
|
assertEventsFromSynInput table inputSpec expectedEvents = do
|
|
let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay
|
|
eventCount = length expectedEvents
|
|
(writeFd, readFd) <- openPseudoTerminal
|
|
(setTermAttr,_) <- attributeControl readFd
|
|
setTermAttr
|
|
let testConfig = defaultConfig { inputFd = Just readFd
|
|
, termName = Just "dummy"
|
|
, vmin = Just 1
|
|
, vtime = Just 100
|
|
}
|
|
input <- initInput testConfig table
|
|
eventsRef <- newIORef []
|
|
let writeWaitClose = do
|
|
synthesizeInput inputSpec writeFd
|
|
threadDelay minDetectableDelay
|
|
shutdownInput input
|
|
threadDelay minDetectableDelay
|
|
closeFd writeFd
|
|
closeFd readFd
|
|
-- drain output pipe
|
|
let readEvents = readLoop eventCount
|
|
readLoop 0 = return ()
|
|
readLoop n = do
|
|
e <- atomically $ readTChan $ input^.eventChannel
|
|
case e of
|
|
InputEvent ev -> modifyIORef eventsRef ((:) ev)
|
|
ResumeAfterSignal -> return ()
|
|
readLoop (n - 1)
|
|
genEventsUsingIoActions maxDuration writeWaitClose readEvents
|
|
outEvents <- reverse <$> readIORef eventsRef
|
|
compareEvents inputSpec expectedEvents outEvents
|
|
|
|
newtype InputBlocksUsingTable event
|
|
= InputBlocksUsingTable ([(String,event)] -> [(String, event)])
|
|
|
|
instance Show (InputBlocksUsingTable event) where
|
|
show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"
|
|
|
|
instance Monad m => Serial m (InputBlocksUsingTable event) where
|
|
series = do
|
|
n :: Int <- localDepth (const maxTableSize) series
|
|
return $ InputBlocksUsingTable $ \raw_table ->
|
|
let table = reverse $ nubBy (\(s0,_) (s1,_) -> s0 == s1) $ reverse raw_table
|
|
in concat (take n (selections table))
|
|
where
|
|
selections [] = []
|
|
selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
|
|
|
|
verifyVisibleSynInputToEvent :: Property IO
|
|
verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
|
|
let table = visibleChars
|
|
inputSeq = gen table
|
|
events = map snd inputSeq
|
|
keydowns = map (Bytes . fst) inputSeq
|
|
input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
|
|
assertEventsFromSynInput universalTable input events
|
|
|
|
verifyCapsSynInputToEvent :: Property IO
|
|
verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
|
|
forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
|
|
term <- setupTerm terminalName
|
|
let table = capsClassifyMap term keysFromCapsTable
|
|
inputSeq = gen table
|
|
events = map snd inputSeq
|
|
keydowns = map (Bytes . fst) inputSeq
|
|
input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
|
|
assertEventsFromSynInput table input events
|
|
|
|
verifySpecialSynInputToEvent :: Property IO
|
|
verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
|
|
let table = specialSupportKeys
|
|
inputSeq = gen table
|
|
events = map snd inputSeq
|
|
keydowns = map (Bytes . fst) inputSeq
|
|
input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
|
|
assertEventsFromSynInput universalTable input events
|
|
|
|
verifyFullSynInputToEvent :: Property IO
|
|
verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->
|
|
forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
|
|
term <- setupTerm terminalName
|
|
let table = classifyMapForTerm terminalName term
|
|
inputSeq = gen table
|
|
events = map snd inputSeq
|
|
keydowns = map (Bytes . fst) inputSeq
|
|
input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
|
|
assertEventsFromSynInput table input events
|
|
|
|
verifyFullSynInputToEvent_2x :: Property IO
|
|
verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->
|
|
forEachOf terminalsOfInterest $ \terminalName -> monadic $ do
|
|
term <- setupTerm terminalName
|
|
let table = classifyMapForTerm terminalName term
|
|
inputSeq = gen table
|
|
events = concatMap ((\s -> [s,s]) . snd) inputSeq
|
|
keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq
|
|
input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]
|
|
assertEventsFromSynInput table input events
|
|
|
|
main :: IO ()
|
|
main = defaultMain
|
|
[ testProperty "synthesized typing of single visible chars translates to expected events"
|
|
verifyVisibleSynInputToEvent
|
|
, testProperty "synthesized typing of keys from capabilities tables translates to expected events"
|
|
verifyCapsSynInputToEvent
|
|
, testProperty "synthesized typing of hard coded special keys translates to expected events"
|
|
verifySpecialSynInputToEvent
|
|
, testProperty "synthesized typing of any key in the table translates to its paired event"
|
|
verifyFullSynInputToEvent
|
|
, testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"
|
|
verifyFullSynInputToEvent_2x
|
|
]
|
|
|