git.iko.soy/vty
on master help sign in
refactor the input layer for testing. build first test that actually simulate typing
849fc71Corey O'Connor
src/Graphics/Vty/Input.hs+8−65
compare with master
unifiedsplit
@@ -32,38 +32,21 @@ import Graphics.Vty.Input.Data
32import Graphics.Vty.Input.Internal
32import Graphics.Vty.Input.Internal
33import Graphics.Vty.Input.Terminfo
33import Graphics.Vty.Input.Terminfo
34
34
35−import Data.Char
36−import Data.IORef
37−import Data.Word
38−
39−import Control.Monad (when, void)
40import Control.Concurrent
35import Control.Concurrent
41−import Control.Exception
42−
43−import qualified GHC.Event as GHC
44
36
45import System.Console.Terminfo
37import System.Console.Terminfo
46
38
47import System.Posix.Signals.Exts
39import System.Posix.Signals.Exts
48import System.Posix.Terminal
40import System.Posix.Terminal
49−import System.Posix.IO ( stdInput
41+import System.Posix.IO (stdInput)
50− , fdReadBuf
51− , setFdOption
52− , FdOption(..)
53− )
54−
55−import Foreign ( alloca, poke, peek, Ptr )
56
42
57defaultEscDelay :: Int
43defaultEscDelay :: Int
58−defaultEscDelay = 0
44+defaultEscDelay = 4000
59
45
60-- | Set up the terminal for input. Returns a function which reads key
46-- | Set up the terminal for input. Returns a function which reads key
61-- events, and a function for shutting down the terminal access.
47-- events, and a function for shutting down the terminal access.
62initTermInput :: Int -> Terminal -> IO (IO Event, IO ())
48initTermInput :: Int -> Terminal -> IO (IO Event, IO ())
63initTermInput escDelay terminal = do
49initTermInput escDelay terminal = do
64− eventChannel <- newChan
65− inputChannel <- newChan
66− hadInput <- newEmptyMVar
67 attr <- getTerminalAttributes stdInput
50 attr <- getTerminalAttributes stdInput
68 -- disable IXON,
51 -- disable IXON,
69 let attr' = foldl withoutMode attr [ StartStopOutput, KeyboardInterrupts
52 let attr' = foldl withoutMode attr [ StartStopOutput, KeyboardInterrupts
@@ -71,59 +54,19 @@ initTermInput escDelay terminal = do
71 ]
54 ]
72 setTerminalAttributes stdInput attr' Immediately
55 setTerminalAttributes stdInput attr' Immediately
73 set_term_timing
56 set_term_timing
74− let finishAtomicInput = writeChan inputChannel '\xFFFE'
75− inputThread :: IO ()
76− inputThread = do
77− _ <- alloca $ \(input_buffer :: Ptr Word8) -> do
78− let loop = do
79− setFdOption stdInput NonBlockingRead False
80− threadWaitRead stdInput
81− setFdOption stdInput NonBlockingRead True
82− _ <- try readAll :: IO (Either IOException ())
83− when (escDelay == 0) finishAtomicInput
84− loop
85− readAll = do
86− poke input_buffer 0
87− bytes_read <- fdReadBuf stdInput input_buffer 1
88− input_char <- fmap (chr . fromIntegral) $ peek input_buffer
89− when (bytes_read > 0) $ do
90− _ <- tryPutMVar hadInput () -- signal input
91− writeChan inputChannel input_char
92− readAll
93− loop
94− return ()
95− -- | If there is no input for some time, this thread puts '\xFFFE' in the
96− -- inputChannel.
97− noInputThread :: IO ()
98− noInputThread = when (escDelay > 0) loop
99− where loop = do
100− takeMVar hadInput -- wait for some input
101− threadDelay escDelay -- microseconds
102− hadNoInput <- isEmptyMVar hadInput -- no input yet?
103− -- TODO(corey): there is a race between here and the inputThread.
104− when hadNoInput finishAtomicInput
105− loop
106−
107− caps_legacy_table = map_to_legacy_table $ caps_classify_table terminal keys_from_caps_table
57+ let caps_legacy_table = map_to_legacy_table $ caps_classify_table terminal keys_from_caps_table
108− term_event_classify_table = concat $ caps_legacy_table : ansi_classify_table
58+ classify_table = concat $ caps_legacy_table : ansi_classify_table
109− term_event_classifier = classify term_event_classify_table
59+ (eventChannel, shutdown_input) <- initInputForFd escDelay classify_table stdInput
110−
111− eventThreadId <- forkIO $ void $ inputToEventThread term_event_classifier inputChannel eventChannel
112− inputThreadId <- forkIO $ inputThread
113− noInputThreadId <- forkIO $ noInputThread
114 let pokeIO = Catch $ do
60 let pokeIO = Catch $ do
115 let e = error "(getsize in input layer)"
61 let e = error "(getsize in input layer)"
116 setTerminalAttributes stdInput attr' Immediately
62 setTerminalAttributes stdInput attr' Immediately
117 writeChan eventChannel (EvResize e e)
63 writeChan eventChannel (EvResize e e)
118 _ <- installHandler windowChange pokeIO Nothing
64 _ <- installHandler windowChange pokeIO Nothing
119 _ <- installHandler continueProcess pokeIO Nothing
65 _ <- installHandler continueProcess pokeIO Nothing
120− -- TODO(corey): killThread is a bit risky for my tastes.
66+ let shutdown_input' = do
121− let uninit = do
67+ shutdown_input
122− killThread eventThreadId
123− killThread inputThreadId
124− killThread noInputThreadId
125 _ <- installHandler windowChange Ignore Nothing
68 _ <- installHandler windowChange Ignore Nothing
126 _ <- installHandler continueProcess Ignore Nothing
69 _ <- installHandler continueProcess Ignore Nothing
127 setTerminalAttributes stdInput attr Immediately
70 setTerminalAttributes stdInput attr Immediately
128− return (readChan eventChannel, uninit)
71+ return (readChan eventChannel, shutdown_input')
129
72
src/Graphics/Vty/Input/Internal.hs+61−1
@@ -4,6 +4,8 @@ import Graphics.Vty.Input.Data
4
4
5import Codec.Binary.UTF8.Generic (decode)
5import Codec.Binary.UTF8.Generic (decode)
6import Control.Concurrent
6import Control.Concurrent
7+import Control.Exception (try, IOException(..))
8+import Control.Monad (when, void)
7
9
8import Data.Char
10import Data.Char
9import Data.List( inits )
11import Data.List( inits )
@@ -12,6 +14,14 @@ import Data.Maybe ( mapMaybe )
12import qualified Data.Set as S( fromList, member )
14import qualified Data.Set as S( fromList, member )
13import Data.Word
15import Data.Word
14
16
17+import Foreign ( alloca, poke, peek, Ptr )
18+
19+import System.Posix.IO ( fdReadBuf
20+ , setFdOption
21+ , FdOption(..)
22+ )
23+import System.Posix.Types (Fd(..))
24+
15data KClass
25data KClass
16 = Valid Key [Modifier]
26 = Valid Key [Modifier]
17 | Invalid
27 | Invalid
@@ -22,7 +32,7 @@ data KClass
22
32
23inputToEventThread :: (String -> KClass) -> Chan Char -> Chan Event -> IO ()
33inputToEventThread :: (String -> KClass) -> Chan Char -> Chan Event -> IO ()
24inputToEventThread classifier inputChannel eventChannel = loop []
34inputToEventThread classifier inputChannel eventChannel = loop []
25− where loop kb = case (classifier kb) of
35+ where loop kb = case classifier kb of
26 Prefix -> do
36 Prefix -> do
27 c <- readChan inputChannel
37 c <- readChan inputChannel
28 if c == '\xFFFD'
38 if c == '\xFFFD'
@@ -88,4 +98,54 @@ utf8Length c
88 | c < 0xF0 = 3
98 | c < 0xF0 = 3
89 | otherwise = 4
99 | otherwise = 4
90
100
101+initInputForFd :: Int -> ClassifyTable -> Fd -> IO (Chan Event, IO ())
102+initInputForFd escDelay classify_table input_fd = do
103+ inputChannel <- newChan
104+ eventChannel <- newChan
105+ hadInput <- newEmptyMVar
106+ let finishAtomicInput = writeChan inputChannel '\xFFFE'
107+ inputThread :: IO ()
108+ inputThread = do
109+ _ <- alloca $ \(input_buffer :: Ptr Word8) -> do
110+ let loop = do
111+ setFdOption input_fd NonBlockingRead False
112+ threadWaitRead input_fd
113+ setFdOption input_fd NonBlockingRead True
114+ _ <- try readAll :: IO (Either IOException ())
115+ when (escDelay == 0) finishAtomicInput
116+ loop
117+ readAll = do
118+ poke input_buffer 0
119+ bytes_read <- fdReadBuf input_fd input_buffer 1
120+ input_char <- fmap (chr . fromIntegral) $ peek input_buffer
121+ when (bytes_read > 0) $ do
122+ _ <- tryPutMVar hadInput () -- signal input
123+ writeChan inputChannel input_char
124+ readAll
125+ loop
126+ return ()
127+ -- | If there is no input for some time, this thread puts '\xFFFE' in the
128+ -- inputChannel.
129+ noInputThread :: IO ()
130+ noInputThread = when (escDelay > 0) loop
131+ where loop = do
132+ takeMVar hadInput -- wait for some input
133+ threadDelay escDelay -- microseconds
134+ hadNoInput <- isEmptyMVar hadInput -- no input yet?
135+ -- TODO(corey): there is a race between here and the inputThread.
136+ when hadNoInput finishAtomicInput
137+ loop
138+ classifier = classify classify_table
139+ eventThreadId <- forkIO $ void $ inputToEventThread classifier inputChannel eventChannel
140+ inputThreadId <- forkIO $ inputThread
141+ noInputThreadId <- forkIO $ noInputThread
142+ -- TODO(corey): killThread is a bit risky for my tastes.
143+ -- H - somewhat mitigated by sending a magic terminate character?
144+ let shutdown_input = do
145+ writeChan inputChannel '\xFFFD'
146+ killThread noInputThreadId
147+ killThread eventThreadId
148+ killThread inputThreadId
149+ return (eventChannel, shutdown_input)
150+
91foreign import ccall "vty_set_term_timing" set_term_timing :: IO ()
151foreign import ccall "vty_set_term_timing" set_term_timing :: IO ()
test/VerifyUsingMockInput.hs+92−29
@@ -11,7 +11,6 @@ import Verify.Graphics.Vty.Terminal
11import Data.List (intersperse, permutations)
11import Data.List (intersperse, permutations)
12
12
13import Graphics.Vty hiding (resize)
13import Graphics.Vty hiding (resize)
14−import Graphics.Vty.Input
15import Graphics.Vty.Input.Data
14import Graphics.Vty.Input.Data
16import Graphics.Vty.Input.Internal
15import Graphics.Vty.Input.Internal
17import Graphics.Vty.Input.Terminfo
16import Graphics.Vty.Input.Terminfo
@@ -21,8 +20,12 @@ import Control.Concurrent
21import Control.Exception
20import Control.Exception
22import Control.Monad
21import Control.Monad
23
22
23+import Data.IORef
24+
24import System.Console.Terminfo
25import System.Console.Terminfo
25−import System.IO
26+import System.Posix.IO
27+import System.Posix.Types
28+import System.Timeout
26
29
27import Test.Framework.Providers.SmallCheck
30import Test.Framework.Providers.SmallCheck
28import Test.Framework
31import Test.Framework
@@ -38,48 +41,95 @@ forEachOf l = over (generate (\n -> take n l))
38
41
39data InputEvent
42data InputEvent
40 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
43 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.
41− | Delay Int -- | millisecond delay
44+ | Delay Int -- | microsecond delay
42 deriving Show
45 deriving Show
43
46
44type InputSpec = [InputEvent]
47type InputSpec = [InputEvent]
45
48
46type ExpectedSpec = [Event]
49type ExpectedSpec = [Event]
47
50
48−exec_input_spec :: InputSpec -> Handle -> IO ()
51+synthesize_input :: InputSpec -> Fd -> IO ()
49−exec_input_spec input out_handle = forM_ input f
52+synthesize_input input out_handle = forM_ input f >> (void $ fdWrite out_handle "\xFFFD")
50 where
53 where
51− f (Bytes str) = hPutStr out_handle str >> hFlush out_handle
54+ f (Bytes str) = void $ fdWrite out_handle str
52− f (Delay t) = threadDelay (t*1000)
55+ f (Delay t) = threadDelay t
56+
57+min_detectable_delay :: Int
58+min_detectable_delay = 1000
59+
60+min_timout :: Int
61+min_timout = 4000000
62+
63+test_key_delay :: Int
64+test_key_delay = min_detectable_delay * 4
65+
66+test_esc_sample_delay :: Int
67+test_esc_sample_delay = min_detectable_delay * 2
68+
69+gen_events_using_io_actions :: Int -> IO () -> IO () -> IO ()
70+gen_events_using_io_actions max_duration input_action output_action = do
71+ let max_duration' = max min_timout max_duration
72+ read_complete <- newEmptyMVar
73+ write_complete <- newEmptyMVar
74+ _ <- forkIO $ input_action `finally` putMVar write_complete ()
75+ _ <- forkIO $ output_action `finally` putMVar read_complete ()
76+ Just () <- timeout max_duration' $ takeMVar write_complete
77+ Just () <- timeout max_duration' $ takeMVar read_complete
78+ return ()
79+
80+assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
81+assert_events_from_syn_input table input_spec expected_events = do
82+ let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
83+ event_count = length expected_events
84+ -- create pipe
85+ (output_fd, input_fd) <- createPipe
86+ (output, shutdown_input) <- initInputForFd test_esc_sample_delay table output_fd
87+ events_ref <- newIORef []
88+ let write_wait_close = do
89+ synthesize_input input_spec input_fd
90+ threadDelay min_detectable_delay
91+ shutdown_input
92+ threadDelay min_detectable_delay
93+ closeFd input_fd
94+ closeFd output_fd
95+ -- drain output pipe
96+ let read_all_events = read_loop event_count
97+ read_loop 0 = return ()
98+ read_loop n = do
99+ e <- readChan output
100+ modifyIORef events_ref ((:) e)
101+ read_loop (n - 1)
102+ gen_events_using_io_actions max_duration write_wait_close read_all_events
103+ out_events <- reverse <$> readIORef events_ref
104+ print (input_spec, expected_events, out_events)
105+ return $ out_events == expected_events
53
106
54assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
107assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
55assert_events_from_input_block table input_spec expected_events = do
108assert_events_from_input_block table input_spec expected_events = do
56− print input_spec
57 let classifier = classify table
109 let classifier = classify table
110+ max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
58 input <- newChan
111 input <- newChan
59 output <- newChan
112 output <- newChan
60− read_complete <- newEmptyMVar
113+ gen_events_using_io_actions
61− write_complete <- newEmptyMVar
114+ max_duration
62− _ <- forkIO $ write_input_spec_to_chan input input_spec
115+ (write_input_spec_to_chan input_spec input)
63− `finally` putMVar write_complete ()
64− _ <- forkIO $ inputToEventThread classifier input output
116+ (inputToEventThread classifier input output)
65− `finally` putMVar read_complete ()
66− () <- takeMVar write_complete
67− () <- takeMVar read_complete
68− -- TODO: use STM channel
117+ -- TODO: use STM TChan?
69− -- assures the next line does not block.
118+ -- assures reading "length expected_events" from the channel does not block.
119+ let min_event_count = length expected_events
70− writeList2Chan output $ replicate (length expected_events) undefined
120+ writeList2Chan output $ replicate min_event_count undefined
71− out_events <- take (length expected_events) <$> getChanContents output
121+ out_events <- take min_event_count <$> getChanContents output
72 return $ out_events == expected_events
122 return $ out_events == expected_events
73
123
74−write_input_spec_to_chan :: Chan Char -> InputSpec -> IO ()
124+write_input_spec_to_chan :: InputSpec -> Chan Char -> IO ()
75−write_input_spec_to_chan chan [] = do
125+write_input_spec_to_chan [] chan = do
76 writeChan chan '\xFFFD'
126 writeChan chan '\xFFFD'
77−write_input_spec_to_chan chan (Bytes str : input_spec') = do
127+write_input_spec_to_chan (Bytes str : input_spec') chan = do
78 writeList2Chan chan str
128 writeList2Chan chan str
79− write_input_spec_to_chan chan input_spec'
129+ write_input_spec_to_chan input_spec' chan
80−write_input_spec_to_chan chan (Delay _t : input_spec') = do
130+write_input_spec_to_chan (Delay _t : input_spec') chan = do
81 writeChan chan '\xFFFE'
131 writeChan chan '\xFFFE'
82− write_input_spec_to_chan chan input_spec'
132+ write_input_spec_to_chan input_spec' chan
83
133
84newtype InputBlocksUsingTable event
134newtype InputBlocksUsingTable event
85 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
135 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])
@@ -107,14 +157,27 @@ verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable ge
107 input_seq = gen table
157 input_seq = gen table
108 events = [e | (_,e) <- input_seq]
158 events = [e | (_,e) <- input_seq]
109 keydowns = [Bytes s | (s,_) <- input_seq]
159 keydowns = [Bytes s | (s,_) <- input_seq]
110− input = intersperse (Delay defaultEscDelay) keydowns
160+ input = intersperse (Delay test_key_delay) keydowns
111 assert_events_from_input_block (map_to_legacy_table table) input events
161 assert_events_from_input_block (map_to_legacy_table table) input events
112
162
163+verify_simple_syn_input_to_event :: Property IO
164+verify_simple_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
165+ forEachOf terminals_of_interest $ \term_name -> monadic $ do
166+ term <- setupTerm term_name
167+ let table = caps_classify_table term keys_from_caps_table
168+ input_seq = gen table
169+ events = [e | (_,e) <- input_seq]
170+ keydowns = [Bytes s | (s,_) <- input_seq]
171+ input = intersperse (Delay test_key_delay) keydowns
172+ assert_events_from_syn_input (map_to_legacy_table table) input events
173+
113main :: IO ()
174main :: IO ()
114main = defaultMain
175main = defaultMain
115 [ testProperty "basic block generated from a single ansi chars to event translation"
176 [ testProperty "basic block generated from a single ansi chars to event translation"
116− verify_simple_input_block_to_event
177+ verify_simple_input_block_to_event
117 , testProperty "key sequences read from caps table map to expected events"
178 , testProperty "key sequences read from caps table map to expected events"
118− verify_keys_from_caps_table_block_to_event
179+ verify_keys_from_caps_table_block_to_event
180+ , testProperty "synthesized typing from basic blocks translates to expected events"
181+ verify_simple_syn_input_to_event
119 ]
182 ]
120
183