f9619d0 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

finish test for verifying the parsing of the keys read from the capabilities file

f9619d0Corey O'Connor13 years ago

src/Graphics/Vty/Input.hs+2−2

compare with master

unifiedsplit

@@ -15,7 +15,7 @@ import Graphics.Vty.Input.Terminfo

15import Data.Char

16import Data.Word

18−import Control.Monad (when)

18+import Control.Monad (when, void)

19import Control.Concurrent

20import Control.Exception

@@ -85,7 +85,7 @@ initTermInput escDelay terminal = do

85 term_event_classify_table = concat $ caps_legacy_table : ansi_classify_table

86 term_event_classifier = classify term_event_classify_table

88− eventThreadId <- forkIO $ inputToEventThread term_event_classifier inputChannel eventChannel

88+ eventThreadId <- forkIO $ void $ inputToEventThread term_event_classifier inputChannel eventChannel

89 inputThreadId <- forkIO $ inputThread

90 noInputThreadId <- forkIO $ noInputThread

91 let pokeIO = Catch $ do

src/Graphics/Vty/Input/Internal.hs+22−17

@@ -17,10 +17,14 @@ inputToEventThread classifier inputChannel eventChannel = loop []

17 where loop kb = case (classifier kb) of

18 Prefix -> do

19 c <- readChan inputChannel

20+ if c == '\xFFFD'

21+ then return ()

20− loop (kb ++ [c])

22+ else loop (kb ++ [c])

21 Invalid -> do

23 Invalid -> do

22 c <- readChan inputChannel

24 c <- readChan inputChannel

25+ if c == '\xFFFD'

26+ then return ()

23− loop [c]

27+ else loop [c]

24 EndLoop -> return ()

28 EndLoop -> return ()

25 MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s

29 MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s

26 Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""

30 Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""

@@ -28,25 +32,26 @@ inputToEventThread classifier inputChannel eventChannel = loop []

28compile :: ClassifyTable -> [Char] -> KClass

32compile :: ClassifyTable -> [Char] -> KClass

29compile table = cl' where

33compile table = cl' where

30 -- take all prefixes and create a set of these

34 -- take all prefixes and create a set of these

31− -- including inserting [] into the set many times.. hm

32 prefix_set = S.fromList $ concatMap (init . inits . fst) $ table

35 prefix_set = S.fromList $ concatMap (init . inits . fst) $ table

33 -- create a map from strings to event

36 -- create a map from strings to event

34 event_for_input = flip M.lookup (M.fromList table)

37 event_for_input = flip M.lookup (M.fromList table)

38+ cl' [] = Prefix

35 cl' input_block = case S.member input_block prefix_set of

39 cl' input_block = case S.member input_block prefix_set of

36− True -> Prefix

40+ True -> Prefix

37− -- if the input_block is exactly what is expected for an event then consume the whole block

41+ -- if the input_block is exactly what is expected for an event then consume the whole

38− -- and return the event

42+ -- block and return the event

39− False -> case event_for_input input_block of

43+ False -> case event_for_input input_block of

40− Just (k,m) -> Valid k m

44+ Just (k,m) -> Valid k m

41− -- look up progressively large prefixes of the input block until an event is found

45+ -- look up progressively large prefixes of the input block until an event is found

42− -- H: There will always be one match. The prefix_set contains, by definition, all

46+ -- H: There will always be one match. The prefix_set contains, by definition, all

43− -- prefixes of an event.

47+ -- prefixes of an event.

44− Nothing ->

48+ Nothing ->

45− let input_prefixes = init $ inits input_block

49+ let input_prefixes = init $ inits input_block

46− in case mapMaybe (\s -> (,) s `fmap` event_for_input s) input_prefixes of

50+ in case mapMaybe (\s -> (,) s `fmap` event_for_input s) input_prefixes of

47− (s,(k,m)) : _ -> MisPfx k m (drop (length s) input_block)

51+ (s,(k,m)) : _ -> MisPfx k m (drop (length s) input_block)

52+ [] -> error $ "vty internal inconsistency - "

48− [] -> error $ "vty internal inconsistency - input not a prefix nor contains any event data "

53+ ++ "input not a prefix nor contains any event data "

49− ++ show input_block

54+ ++ show input_block

51classify, classifyTab :: ClassifyTable -> [Char] -> KClass

56classify, classifyTab :: ClassifyTable -> [Char] -> KClass

test/VerifyUsingMockInput.hs+28−36

@@ -23,7 +23,6 @@ import Control.Monad

24import System.Console.Terminfo

25import System.IO

26−import System.Posix.Env

28import Test.Framework.Providers.SmallCheck

27import Test.Framework.Providers.SmallCheck

29import Test.Framework

28import Test.Framework

@@ -36,6 +35,7 @@ max_bytes_size = 16

36data InputEvent

35data InputEvent

37 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.

36 = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.

38 | Delay Int -- | millisecond delay

37 | Delay Int -- | millisecond delay

38+ deriving Show

40type InputSpec = [InputEvent]

@@ -49,46 +49,38 @@ exec_input_spec input out_handle = forM_ input f

50assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool

51assert_events_from_input_block table input_spec expected_events = do

52+ print input_spec

52 let classifier = classify table

53 let classifier = classify table

53 input <- newChan

54 input <- newChan

54 output <- newChan

55 output <- newChan

56+ read_complete <- newEmptyMVar

57+ write_complete <- newEmptyMVar

55− forkIO $ write_input_spec_to_chan input input_spec

58+ _ <- forkIO $ write_input_spec_to_chan input input_spec

59+ `finally` putMVar write_complete ()

56− inputToEventThread classifier input output

60+ _ <- forkIO $ inputToEventThread classifier input output

57− -- H: all events are available in output channel

61+ `finally` putMVar read_complete ()

58− -- TODO: switch to using explicit control events. Currently the channel is passing around a

62+ () <- takeMVar write_complete

59− -- magic FFFX characters

63+ () <- takeMVar read_complete

60 -- TODO: use STM channel

64 -- TODO: use STM channel

61− let collect_events = handle (\(e :: BlockedIndefinitelyOnMVar) -> return [])

65+ -- assures the next line does not block.

62− ((:) <$> readChan output <*> collect_events)

66+ writeList2Chan output $ replicate (length expected_events) undefined

63− out_events <- collect_events

67+ out_events <- take (length expected_events) <$> getChanContents output

64 return $ out_events == expected_events

68 return $ out_events == expected_events

66write_input_spec_to_chan :: Chan Char -> InputSpec -> IO ()

70write_input_spec_to_chan :: Chan Char -> InputSpec -> IO ()

67−write_input_spec_to_chan chan [] = writeChan chan '\xFFFD'

71+write_input_spec_to_chan chan [] = do

72+ writeChan chan '\xFFFD'

68−write_input_spec_to_chan chan (Bytes str : input_spec')

73+write_input_spec_to_chan chan (Bytes str : input_spec') = do

74+ writeList2Chan chan str

69− = writeList2Chan chan str >> write_input_spec_to_chan chan input_spec'

75+ write_input_spec_to_chan chan input_spec'

70−write_input_spec_to_chan chan (Delay t : input_spec')

76+write_input_spec_to_chan chan (Delay _t : input_spec') = do

77+ writeChan chan '\xFFFE'

71− = writeChan chan '\xFFFE' >> write_input_spec_to_chan chan input_spec'

78+ write_input_spec_to_chan chan input_spec'

72−

73−{-

74−

75−tests :: IO [Test]

76−tests = do

77− mappend

78− <$> pure [ verify "basic block generated from single ansi chars to event translation" ]

79− <*> mapM terminals_of_interest

80− verify_simple_input_block_to_event

81− , verify "keys from caps table are parsed to the same key"

82− verify_keys_from_caps_table

83− ]

84−-}

85−

86−-- how to make this data dependent?

88newtype EventBlock event = EventBlock ([(String,event)] -> [(String, event)])

80newtype EventBlock event = EventBlock ([(String,event)] -> [(String, event)])

90instance Show (EventBlock event) where

82instance Show (EventBlock event) where

91− show (EventBlock g) = "EventBlock(* -> *)"

83+ show (EventBlock g) = "EventBlock(*->*)"

93instance Monad m => Serial m (EventBlock event) where

85instance Monad m => Serial m (EventBlock event) where

94 series = do

86 series = do

@@ -106,12 +98,12 @@ verify_keys_from_caps_table_block_to_event :: Property IO

106verify_keys_from_caps_table_block_to_event = forAll $ \(EventBlock block_gen) ->

98verify_keys_from_caps_table_block_to_event = forAll $ \(EventBlock block_gen) ->

107 over (generate (\n -> take n terminals_of_interest)) $ \term_name -> monadic $ do

99 over (generate (\n -> take n terminals_of_interest)) $ \term_name -> monadic $ do

108 terminal <- setupTerm term_name

100 terminal <- setupTerm term_name

101+ let table = caps_classify_table terminal keys_from_caps_table

109− let caps_seq :: [(String, Event)] = block_gen keys_from_caps_table

102+ input_seq :: [(String, Event)] = block_gen table

110− let bytes_seq = caps_classify_table terminal caps_seq

103+ input_bytes = [Bytes s | (s,_) <- input_seq]

111− input = [Bytes s | (s,_) <- bytes_seq]

112− escaped_sequence = intersperse (Delay defaultEscDelay) input

104+ input = intersperse (Delay defaultEscDelay) input_bytes

113− return True :: IO Bool

105+ events = [e | (_,e) <- input_seq]

114− -- cap <- elements keys_from_caps_table

106+ assert_events_from_input_block (map_to_legacy_table table) input events

115

107

116main = defaultMain

108main = defaultMain

117 [ testProperty "basic block generated from a single ansi chars to event translation"

109 [ testProperty "basic block generated from a single ansi chars to event translation"

vty.cabal+3−2

@@ -95,9 +95,9 @@ library

95 default-extensions: ScopedTypeVariables

96 ForeignFunctionInterface

98− ghc-options: -O2 -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10

98+ ghc-options: -O2 -funbox-strict-fields -threaded -Wall -fspec-constr -fspec-constr-count=10

100− ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10

100+ ghc-prof-options: -O2 -funbox-strict-fields -threaded -caf-all -Wall -fspec-constr -fspec-constr-count=10

101

102 cc-options: -O2

103

@@ -534,6 +534,7 @@ test-suite verify-using-mock-input

534 utf8-string >= 0.3 && < 0.4,

535 vector >= 0.7

536

537+ ghc-options: -threaded -Wall

537

538

538executable vty-interactive-terminal-test

539executable vty-interactive-terminal-test

539 main-is: interactive_terminal_test.hs

540 main-is: interactive_terminal_test.hs