From f9619d04eb648008eee92c43c445fb16e331bce5 Mon Sep 17 00:00:00 2001 From: Corey O'Connor Date: Tue, 22 Oct 2013 17:48:22 -0700 Subject: [PATCH] finish test for verifying the parsing of the keys read from the capabilities file --- src/Graphics/Vty/Input.hs | 4 +- src/Graphics/Vty/Input/Internal.hs | 39 ++++++++++-------- test/VerifyUsingMockInput.hs | 64 +++++++++++++----------------- vty.cabal | 5 ++- 4 files changed, 55 insertions(+), 57 deletions(-) diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs index 8fe310a..0a7b4c9 100644 --- a/src/Graphics/Vty/Input.hs +++ b/src/Graphics/Vty/Input.hs @@ -15,7 +15,7 @@ import Graphics.Vty.Input.Terminfo import Data.Char import Data.Word -import Control.Monad (when) +import Control.Monad (when, void) import Control.Concurrent import Control.Exception @@ -85,7 +85,7 @@ initTermInput escDelay terminal = do term_event_classify_table = concat $ caps_legacy_table : ansi_classify_table term_event_classifier = classify term_event_classify_table - eventThreadId <- forkIO $ inputToEventThread term_event_classifier inputChannel eventChannel + eventThreadId <- forkIO $ void $ inputToEventThread term_event_classifier inputChannel eventChannel inputThreadId <- forkIO $ inputThread noInputThreadId <- forkIO $ noInputThread let pokeIO = Catch $ do diff --git a/src/Graphics/Vty/Input/Internal.hs b/src/Graphics/Vty/Input/Internal.hs index c5a2ab5..725db95 100644 --- a/src/Graphics/Vty/Input/Internal.hs +++ b/src/Graphics/Vty/Input/Internal.hs @@ -17,10 +17,14 @@ inputToEventThread classifier inputChannel eventChannel = loop [] where loop kb = case (classifier kb) of Prefix -> do c <- readChan inputChannel - loop (kb ++ [c]) + if c == '\xFFFD' + then return () + else loop (kb ++ [c]) Invalid -> do c <- readChan inputChannel - loop [c] + if c == '\xFFFD' + then return () + else loop [c] EndLoop -> return () MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s Valid k m -> writeChan eventChannel (EvKey k m) >> loop "" @@ -28,25 +32,26 @@ inputToEventThread classifier inputChannel eventChannel = loop [] compile :: ClassifyTable -> [Char] -> KClass compile table = cl' where -- take all prefixes and create a set of these - -- including inserting [] into the set many times.. hm prefix_set = S.fromList $ concatMap (init . inits . fst) $ table -- create a map from strings to event event_for_input = flip M.lookup (M.fromList table) + cl' [] = Prefix cl' input_block = case S.member input_block prefix_set of - True -> Prefix - -- if the input_block is exactly what is expected for an event then consume the whole block - -- and return the event - False -> case event_for_input input_block of - Just (k,m) -> Valid k m - -- look up progressively large prefixes of the input block until an event is found - -- H: There will always be one match. The prefix_set contains, by definition, all - -- prefixes of an event. - Nothing -> - let input_prefixes = init $ inits input_block - in case mapMaybe (\s -> (,) s `fmap` event_for_input s) input_prefixes of - (s,(k,m)) : _ -> MisPfx k m (drop (length s) input_block) - [] -> error $ "vty internal inconsistency - input not a prefix nor contains any event data " - ++ show input_block + True -> Prefix + -- if the input_block is exactly what is expected for an event then consume the whole + -- block and return the event + False -> case event_for_input input_block of + Just (k,m) -> Valid k m + -- look up progressively large prefixes of the input block until an event is found + -- H: There will always be one match. The prefix_set contains, by definition, all + -- prefixes of an event. + Nothing -> + let input_prefixes = init $ inits input_block + in case mapMaybe (\s -> (,) s `fmap` event_for_input s) input_prefixes of + (s,(k,m)) : _ -> MisPfx k m (drop (length s) input_block) + [] -> error $ "vty internal inconsistency - " + ++ "input not a prefix nor contains any event data " + ++ show input_block classify, classifyTab :: ClassifyTable -> [Char] -> KClass diff --git a/test/VerifyUsingMockInput.hs b/test/VerifyUsingMockInput.hs index b8a7503..4c2cb4f 100644 --- a/test/VerifyUsingMockInput.hs +++ b/test/VerifyUsingMockInput.hs @@ -23,7 +23,6 @@ import Control.Monad import System.Console.Terminfo import System.IO -import System.Posix.Env import Test.Framework.Providers.SmallCheck import Test.Framework @@ -36,6 +35,7 @@ max_bytes_size = 16 data InputEvent = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time. | Delay Int -- | millisecond delay + deriving Show type InputSpec = [InputEvent] @@ -49,46 +49,38 @@ exec_input_spec input out_handle = forM_ input f assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool assert_events_from_input_block table input_spec expected_events = do + print input_spec let classifier = classify table input <- newChan output <- newChan - forkIO $ write_input_spec_to_chan input input_spec - inputToEventThread classifier input output - -- H: all events are available in output channel - -- TODO: switch to using explicit control events. Currently the channel is passing around a - -- magic FFFX characters + read_complete <- newEmptyMVar + write_complete <- newEmptyMVar + _ <- forkIO $ write_input_spec_to_chan input input_spec + `finally` putMVar write_complete () + _ <- forkIO $ inputToEventThread classifier input output + `finally` putMVar read_complete () + () <- takeMVar write_complete + () <- takeMVar read_complete -- TODO: use STM channel - let collect_events = handle (\(e :: BlockedIndefinitelyOnMVar) -> return []) - ((:) <$> readChan output <*> collect_events) - out_events <- collect_events + -- assures the next line does not block. + writeList2Chan output $ replicate (length expected_events) undefined + out_events <- take (length expected_events) <$> getChanContents output return $ out_events == expected_events write_input_spec_to_chan :: Chan Char -> InputSpec -> IO () -write_input_spec_to_chan chan [] = writeChan chan '\xFFFD' -write_input_spec_to_chan chan (Bytes str : input_spec') - = writeList2Chan chan str >> write_input_spec_to_chan chan input_spec' -write_input_spec_to_chan chan (Delay t : input_spec') - = writeChan chan '\xFFFE' >> write_input_spec_to_chan chan input_spec' - -{- - -tests :: IO [Test] -tests = do - mappend - <$> pure [ verify "basic block generated from single ansi chars to event translation" ] - <*> mapM terminals_of_interest - verify_simple_input_block_to_event - , verify "keys from caps table are parsed to the same key" - verify_keys_from_caps_table - ] --} - --- how to make this data dependent? +write_input_spec_to_chan chan [] = do + writeChan chan '\xFFFD' +write_input_spec_to_chan chan (Bytes str : input_spec') = do + writeList2Chan chan str + write_input_spec_to_chan chan input_spec' +write_input_spec_to_chan chan (Delay _t : input_spec') = do + writeChan chan '\xFFFE' + write_input_spec_to_chan chan input_spec' newtype EventBlock event = EventBlock ([(String,event)] -> [(String, event)]) instance Show (EventBlock event) where - show (EventBlock g) = "EventBlock(* -> *)" + show (EventBlock g) = "EventBlock(*->*)" instance Monad m => Serial m (EventBlock event) where series = do @@ -106,12 +98,12 @@ verify_keys_from_caps_table_block_to_event :: Property IO verify_keys_from_caps_table_block_to_event = forAll $ \(EventBlock block_gen) -> over (generate (\n -> take n terminals_of_interest)) $ \term_name -> monadic $ do terminal <- setupTerm term_name - let caps_seq :: [(String, Event)] = block_gen keys_from_caps_table - let bytes_seq = caps_classify_table terminal caps_seq - input = [Bytes s | (s,_) <- bytes_seq] - escaped_sequence = intersperse (Delay defaultEscDelay) input - return True :: IO Bool - -- cap <- elements keys_from_caps_table + let table = caps_classify_table terminal keys_from_caps_table + input_seq :: [(String, Event)] = block_gen table + input_bytes = [Bytes s | (s,_) <- input_seq] + input = intersperse (Delay defaultEscDelay) input_bytes + events = [e | (_,e) <- input_seq] + assert_events_from_input_block (map_to_legacy_table table) input events main = defaultMain [ testProperty "basic block generated from a single ansi chars to event translation" diff --git a/vty.cabal b/vty.cabal index a76f671..76c304d 100644 --- a/vty.cabal +++ b/vty.cabal @@ -95,9 +95,9 @@ library default-extensions: ScopedTypeVariables ForeignFunctionInterface - ghc-options: -O2 -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10 + ghc-options: -O2 -funbox-strict-fields -threaded -Wall -fspec-constr -fspec-constr-count=10 - ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10 + ghc-prof-options: -O2 -funbox-strict-fields -threaded -caf-all -Wall -fspec-constr -fspec-constr-count=10 cc-options: -O2 @@ -534,6 +534,7 @@ test-suite verify-using-mock-input utf8-string >= 0.3 && < 0.4, vector >= 0.7 + ghc-options: -threaded -Wall executable vty-interactive-terminal-test main-is: interactive_terminal_test.hs