ccb1b24 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

resolve test compile failures

ccb1b24Corey O'Connor13 years ago

src/Graphics/Vty/Input.hs+7−13

compare with master

unifiedsplit

@@ -49,13 +49,11 @@ import Graphics.Vty.Input.Internal

49import Graphics.Vty.Input.Terminfo

51import Control.Concurrent

52−

52+import Control.Lens

53−import Data.IORef

55import qualified System.Console.Terminfo as Terminfo

54import qualified System.Console.Terminfo as Terminfo

56import System.Environment

55import System.Environment

57import System.Posix.Signals.Exts

56import System.Posix.Signals.Exts

58−import System.Posix.Terminal

59import System.Posix.IO (stdInput)

57import System.Posix.IO (stdInput)

60import System.Posix.Types (Fd)

58import System.Posix.Types (Fd)

@@ -94,18 +92,14 @@ input_for_current_terminal config = do

94input_for_name_and_io :: Config -> String -> Fd -> IO Input

92input_for_name_and_io :: Config -> String -> Fd -> IO Input

95input_for_name_and_io config term_name term_fd = do

93input_for_name_and_io config term_name term_fd = do

96 terminal <- Terminfo.setupTerm term_name

94 terminal <- Terminfo.setupTerm term_name

97− attr <- getTerminalAttributes term_fd

98− let attr' = foldl withoutMode attr [ StartStopOutput, KeyboardInterrupts

99− , EnableEcho, ProcessInput, ExtendedFunctions

100− ]

101− setTerminalAttributes term_fd attr' Immediately

102 let classify_table = classify_table_for_term term_name terminal

95 let classify_table = classify_table_for_term term_name terminal

103− apply_timing_config term_fd config

96+ (set_attrs,unset_attrs) <- attributeControl term_fd

97+ set_attrs

104− input <- newIORef config >>= \ref -> initInputForFd ref classify_table term_fd

98+ input <- initInputForFd config classify_table term_fd

105 let pokeIO = Catch $ do

99 let pokeIO = Catch $ do

106 let e = error "(getsize in input layer)"

100 let e = error "(getsize in input layer)"

107− setTerminalAttributes term_fd attr' Immediately

101+ set_attrs

108− writeChan (_event_channel input) (EvResize e e)

102+ writeChan (input^.event_channel) (EvResize e e)

109 _ <- installHandler windowChange pokeIO Nothing

103 _ <- installHandler windowChange pokeIO Nothing

110 _ <- installHandler continueProcess pokeIO Nothing

104 _ <- installHandler continueProcess pokeIO Nothing

111 return $ input

105 return $ input

@@ -113,5 +107,5 @@ input_for_name_and_io config term_name term_fd = do

113 shutdown_input input

107 shutdown_input input

114 _ <- installHandler windowChange Ignore Nothing

108 _ <- installHandler windowChange Ignore Nothing

115 _ <- installHandler continueProcess Ignore Nothing

109 _ <- installHandler continueProcess Ignore Nothing

116− setTerminalAttributes term_fd attr Immediately

110+ unset_attrs

117 }

111 }

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

@@ -30,6 +30,7 @@ import Foreign ( allocaArray, peekArray, Ptr )

30import Foreign.C.Types (CInt(..))

32import System.Posix.IO (fdReadBuf)

33+import System.Posix.Terminal

33import System.Posix.Types (Fd(..))

34import System.Posix.Types (Fd(..))

35data Config = Config

36data Config = Config

@@ -57,7 +58,7 @@ data Input = Input

57makeLenses ''Input

58makeLenses ''Input

59data KClass

60data KClass

60− = Valid Key [Modifier] [Char]

61+ = Valid Event [Char]

61 | Invalid

62 | Invalid

62 | Prefix

63 | Prefix

63 deriving(Show, Eq)

64 deriving(Show, Eq)

@@ -126,9 +127,9 @@ parse_event = do

126 c <- use classifier

127 c <- use classifier

127 b <- use unprocessed_bytes

128 b <- use unprocessed_bytes

128 case c b of

129 case c b of

129− Valid k m remaining -> do

130+ Valid e remaining -> do

130 unprocessed_bytes .= remaining

131 unprocessed_bytes .= remaining

131− return $ EvKey k m

132+ return e

132 _ -> mzero

133 _ -> mzero

133

134

134drop_invalid :: InputM ()

135drop_invalid :: InputM ()

@@ -154,7 +155,7 @@ compile table = cl' where

154 event_for_input = M.fromList table

155 event_for_input = M.fromList table

155 cl' [] = Prefix

156 cl' [] = Prefix

156 cl' input_block = case M.lookup input_block event_for_input of

157 cl' input_block = case M.lookup input_block event_for_input of

157− Just (EvKey k m) -> Valid k m []

158+ Just e -> Valid e []

158 Nothing -> case S.member input_block prefix_set of

159 Nothing -> case S.member input_block prefix_set of

159 True -> Prefix

160 True -> Prefix

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

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

@@ -165,7 +166,7 @@ compile table = cl' where

165 False ->

166 False ->

166 let input_prefixes = init $ inits input_block

167 let input_prefixes = init $ inits input_block

167 in case mapMaybe (\s -> (,) s `fmap` M.lookup s event_for_input) input_prefixes of

168 in case mapMaybe (\s -> (,) s `fmap` M.lookup s event_for_input) input_prefixes of

168− (s,EvKey k m) : _ -> Valid k m (drop (length s) input_block)

169+ (s,e) : _ -> Valid e (drop (length s) input_block)

169 -- neither a prefix or a full event. Might be interesting to log.

170 -- neither a prefix or a full event. Might be interesting to log.

170 [] -> Invalid

171 [] -> Invalid

171

172

@@ -179,7 +180,7 @@ classify table other

179

180

180classifyUtf8 :: [Char] -> KClass

181classifyUtf8 :: [Char] -> KClass

181classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of

182classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of

182− Just (unicodeChar, _) -> Valid (KChar unicodeChar) [] []

183+ Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) []

183 _ -> Invalid -- something bad happened; just ignore and continue.

184 _ -> Invalid -- something bad happened; just ignore and continue.

184

185

185classifyTab table = compile table

186classifyTab table = compile table

@@ -204,15 +205,26 @@ run_input_processor_loop classify_table input stop_flag = do

204 <*> pure (classify classify_table)

205 <*> pure (classify classify_table)

205 runReaderT (evalStateT loop_input_processor s0) input

206 runReaderT (evalStateT loop_input_processor s0) input

206

207

208+attributeControl :: Fd -> IO (IO (), IO ())

209+attributeControl fd = do

210+ original <- getTerminalAttributes fd

211+ let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts

212+ , EnableEcho, ProcessInput, ExtendedFunctions

213+ ]

214+ let set_attrs = setTerminalAttributes fd vtyMode Immediately

215+ unset_attrs = setTerminalAttributes fd original Immediately

216+ return (set_attrs,unset_attrs)

217+

207-- This is an example of an algorithm where code coverage could be high, even 100%, but the

218-- This is an example of an algorithm where code coverage could be high, even 100%, but the

208-- algorithm still under tested. I should collect more of these examples...

219-- algorithm still under tested. I should collect more of these examples...

209−initInputForFd :: IORef Config -> ClassifyTable -> Fd -> IO Input

220+initInputForFd :: Config -> ClassifyTable -> Fd -> IO Input

210−initInputForFd in_config_ref classify_table in_input_fd = do

221+initInputForFd config classify_table in_fd = do

222+ apply_timing_config in_fd config

211 stop_flag <- newIORef False

223 stop_flag <- newIORef False

212 input <- Input <$> newChan

224 input <- Input <$> newChan

213 <*> pure (writeIORef stop_flag True)

225 <*> pure (writeIORef stop_flag True)

214− <*> pure in_config_ref

226+ <*> newIORef config

215− <*> pure in_input_fd

227+ <*> pure in_fd

216 _ <- forkOS $ run_input_processor_loop classify_table input stop_flag

228 _ <- forkOS $ run_input_processor_loop classify_table input stop_flag

217 return input

229 return input

218

230

test/VerifyUsingMockInput.hs+15−59

@@ -18,12 +18,15 @@ import Graphics.Vty.Input.Terminfo

18import Control.Applicative

19import Control.Concurrent

20import Control.Exception

21+import Control.Lens ((^.))

21import Control.Monad

22import Control.Monad

24+import Data.Default

23import Data.IORef

25import Data.IORef

25import System.Console.Terminfo

27import System.Console.Terminfo

26import System.Posix.IO

28import System.Posix.IO

29+import System.Posix.Terminal (openPseudoTerminal)

27import System.Posix.Types

30import System.Posix.Types

28import System.Timeout

31import System.Timeout

@@ -76,8 +79,8 @@ gen_events_using_io_actions max_duration input_action output_action = do

76 let max_duration' = max min_timout max_duration

79 let max_duration' = max min_timout max_duration

77 read_complete <- newEmptyMVar

80 read_complete <- newEmptyMVar

78 write_complete <- newEmptyMVar

81 write_complete <- newEmptyMVar

79− _ <- forkIO $ input_action `finally` putMVar write_complete ()

82+ _ <- forkOS $ input_action `finally` putMVar write_complete ()

80− _ <- forkIO $ output_action `finally` putMVar read_complete ()

83+ _ <- forkOS $ output_action `finally` putMVar read_complete ()

81 Just () <- timeout max_duration' $ takeMVar write_complete

84 Just () <- timeout max_duration' $ takeMVar write_complete

82 Just () <- timeout max_duration' $ takeMVar read_complete

85 Just () <- timeout max_duration' $ takeMVar read_complete

83 return ()

86 return ()

@@ -106,54 +109,29 @@ assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO

106assert_events_from_syn_input table input_spec expected_events = do

109assert_events_from_syn_input table input_spec expected_events = do

107 let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay

110 let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay

108 event_count = length expected_events

111 event_count = length expected_events

109− (output_fd, input_fd) <- createPipe

112+ (write_fd, read_fd) <- openPseudoTerminal

110− (output, shutdown_event_processing) <- initInputForFd test_esc_sample_delay table output_fd

113+ (set_term_attr,_) <- attributeControl read_fd

114+ set_term_attr

115+ input <- initInputForFd def table read_fd

111 events_ref <- newIORef []

116 events_ref <- newIORef []

112 let write_wait_close = do

117 let write_wait_close = do

113− synthesize_input input_spec input_fd

118+ synthesize_input input_spec write_fd

114 threadDelay min_detectable_delay

119 threadDelay min_detectable_delay

115− shutdown_event_processing

120+ shutdown_input input

116 threadDelay min_detectable_delay

121 threadDelay min_detectable_delay

117− closeFd input_fd

122+ closeFd write_fd

118− closeFd output_fd

123+ closeFd read_fd

119 -- drain output pipe

124 -- drain output pipe

120 let read_events = read_loop event_count

125 let read_events = read_loop event_count

121 read_loop 0 = return ()

126 read_loop 0 = return ()

122 read_loop n = do

127 read_loop n = do

123− e <- readChan output

128+ e <- readChan $ input^.event_channel

124 modifyIORef events_ref ((:) e)

129 modifyIORef events_ref ((:) e)

125 read_loop (n - 1)

130 read_loop (n - 1)

126 gen_events_using_io_actions max_duration write_wait_close read_events

131 gen_events_using_io_actions max_duration write_wait_close read_events

127 out_events <- reverse <$> readIORef events_ref

132 out_events <- reverse <$> readIORef events_ref

128 compare_events input_spec expected_events out_events

133 compare_events input_spec expected_events out_events

129

134

130−assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool

131−assert_events_from_input_block table input_spec expected_events = do

132− let classifier = classify table

133− max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay

134− input <- newChan

135− output <- newChan

136− gen_events_using_io_actions

137− max_duration

138− (write_input_spec_to_chan input_spec input)

139− (inputToEventThread classifier input output)

140− -- TODO: use STM TChan?

141− -- assures reading "length expected_events" from the channel does not block.

142− let min_event_count = length expected_events

143− writeList2Chan output $ replicate min_event_count undefined

144− out_events <- take min_event_count <$> getChanContents output

145− return $ out_events == expected_events

146−

147−write_input_spec_to_chan :: InputSpec -> Chan Char -> IO ()

148−write_input_spec_to_chan [] chan = do

149− writeChan chan '\xFFFD'

150−write_input_spec_to_chan (Bytes str : input_spec') chan = do

151− writeList2Chan chan str

152− write_input_spec_to_chan input_spec' chan

153−write_input_spec_to_chan (Delay _t : input_spec') chan = do

154− writeChan chan '\xFFFE'

155− write_input_spec_to_chan input_spec' chan

156−

157newtype InputBlocksUsingTable event

135newtype InputBlocksUsingTable event

158 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])

136 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])

159

137

@@ -168,24 +146,6 @@ instance Monad m => Serial m (InputBlocksUsingTable event) where

168 selections [] = []

146 selections [] = []

169 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)

147 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)

170

148

171−verify_visible_input_block_to_event :: Property IO

172−verify_visible_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do

173− let input_seq = gen visible_chars

174− input = Bytes $ concat [s | (s,_) <- input_seq]

175− events = map snd input_seq

176− monadic $ assert_events_from_input_block visible_chars [input] events

177−

178−verify_keys_from_caps_table_block_to_event :: Property IO

179−verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable gen) ->

180− forEachOf terminals_of_interest $ \term_name -> monadic $ do

181− term <- setupTerm term_name

182− let table = caps_classify_table term keys_from_caps_table

183− input_seq = gen table

184− events = map snd input_seq

185− keydowns = map (Bytes . fst) input_seq

186− input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]

187− assert_events_from_input_block table input events

188−

189verify_visible_syn_input_to_event :: Property IO

149verify_visible_syn_input_to_event :: Property IO

190verify_visible_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do

150verify_visible_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do

191 let table = visible_chars

151 let table = visible_chars

@@ -228,11 +188,7 @@ verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->

228

188

229main :: IO ()

189main :: IO ()

230main = defaultMain

190main = defaultMain

231− [ testProperty "basic block generated from a single visible chars to event translation"

232− verify_visible_input_block_to_event

233− , testProperty "key sequences read from caps table map to expected events"

234− verify_keys_from_caps_table_block_to_event

235− , testProperty "synthesized typing from single visible chars translates to expected events"

191+ [ testProperty "synthesized typing from single visible chars translates to expected events"

236 verify_visible_syn_input_to_event

192 verify_visible_syn_input_to_event

237 , testProperty "synthesized typing from keys from capabilities tables translates to expected events"

193 , testProperty "synthesized typing from keys from capabilities tables translates to expected events"

238 verify_caps_syn_input_to_event

194 verify_caps_syn_input_to_event

vty.cabal+3−1

@@ -44,7 +44,7 @@ library

44 containers,

45 data-default >= 0.5.3,

46 deepseq >= 1.1 && < 1.4,

47− lens >= 3.9.0.2,

47+ lens >= 3.9.0.2 && < 4.0,

48 -- required for nice installation with yi

49 hashable >= 1.2,

50 mtl >= 1.1.1.0 && < 2.2,

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

525

526 build-depends: vty,

527 Cabal == 1.18.*,

528+ data-default >= 0.5.3,

528 QuickCheck >= 2.4,

529 QuickCheck >= 2.4,

529 smallcheck == 1.*,

530 smallcheck == 1.*,

530 quickcheck-assertions >= 0.1.1,

531 quickcheck-assertions >= 0.1.1,

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

535 bytestring,

536 bytestring,

536 containers,

537 containers,

537 deepseq >= 1.1 && < 1.4,

538 deepseq >= 1.1 && < 1.4,

539+ lens >= 3.9.0.2 && < 4.0,

538 mtl >= 1.1.1.0 && < 2.2,

540 mtl >= 1.1.1.0 && < 2.2,

539 terminfo >= 0.3 && < 0.4,

541 terminfo >= 0.3 && < 0.4,

540 text >= 0.11.3,

542 text >= 0.11.3,