ilyakooo0/vty
1
0
Fork 0
mirror of https://github.com/ilyakooo0/vty.git synced 2024-11-30 02:13:36 +03:00
Code Issues Projects Releases Wiki Activity

resolve test compile failures

Browse Source
This commit is contained in:
Corey O'Connor 2014-01-31 01:13:24 -08:00
parent 76bffb44d8
commit ccb1b2487c
4 changed files with 47 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/Graphics/Vty/Input.hs
View File

@ -49,13 +49,11 @@ import Graphics.Vty.Input.Internal
import Graphics.Vty.Input.Terminfo
import Control.Concurrent
import Data.IORef
import Control.Lens
import qualified System.Console.Terminfo as Terminfo
import System.Environment
import System.Posix.Signals.Exts
import System.Posix.Terminal
import System.Posix.IO (stdInput)
import System.Posix.Types (Fd)
@ -94,18 +92,14 @@ input_for_current_terminal config = do
input_for_name_and_io :: Config -> String -> Fd -> IO Input
input_for_name_and_io config term_name term_fd = do
terminal <- Terminfo.setupTerm term_name
attr <- getTerminalAttributes term_fd
let attr' = foldl withoutMode attr [ StartStopOutput, KeyboardInterrupts
, EnableEcho, ProcessInput, ExtendedFunctions
]
setTerminalAttributes term_fd attr' Immediately
let classify_table = classify_table_for_term term_name terminal
apply_timing_config term_fd config
input <- newIORef config >>= \ref -> initInputForFd ref classify_table term_fd
(set_attrs,unset_attrs) <- attributeControl term_fd
set_attrs
input <- initInputForFd config classify_table term_fd
let pokeIO = Catch $ do
let e = error "(getsize in input layer)"
setTerminalAttributes term_fd attr' Immediately
writeChan (_event_channel input) (EvResize e e)
set_attrs
writeChan (input^.event_channel) (EvResize e e)
_ <- installHandler windowChange pokeIO Nothing
_ <- installHandler continueProcess pokeIO Nothing
return $ input
@ -113,5 +107,5 @@ input_for_name_and_io config term_name term_fd = do
shutdown_input input
_ <- installHandler windowChange Ignore Nothing
_ <- installHandler continueProcess Ignore Nothing
setTerminalAttributes term_fd attr Immediately
unset_attrs
}

32
src/Graphics/Vty/Input/Internal.hs
View File

@ -30,6 +30,7 @@ import Foreign ( allocaArray, peekArray, Ptr )
import Foreign.C.Types (CInt(..))
import System.Posix.IO (fdReadBuf)
import System.Posix.Terminal
import System.Posix.Types (Fd(..))
data Config = Config
@ -57,7 +58,7 @@ data Input = Input
makeLenses ''Input
data KClass
= Valid Key [Modifier] [Char]
= Valid Event [Char]
| Invalid
| Prefix
deriving(Show, Eq)
@ -126,9 +127,9 @@ parse_event = do
c <- use classifier
b <- use unprocessed_bytes
case c b of
Valid k m remaining -> do
Valid e remaining -> do
unprocessed_bytes .= remaining
return $ EvKey k m
return e
_ -> mzero
drop_invalid :: InputM ()
@ -154,7 +155,7 @@ compile table = cl' where
event_for_input = M.fromList table
cl' [] = Prefix
cl' input_block = case M.lookup input_block event_for_input of
Just (EvKey k m) -> Valid k m []
Just e -> Valid e []
Nothing -> 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
@ -165,7 +166,7 @@ compile table = cl' where
False ->
let input_prefixes = init $ inits input_block
in case mapMaybe (\s -> (,) s `fmap` M.lookup s event_for_input) input_prefixes of
(s,EvKey k m) : _ -> Valid k m (drop (length s) input_block)
(s,e) : _ -> Valid e (drop (length s) input_block)
-- neither a prefix or a full event. Might be interesting to log.
[] -> Invalid
@ -179,7 +180,7 @@ classify table other
classifyUtf8 :: [Char] -> KClass
classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
Just (unicodeChar, _) -> Valid (KChar unicodeChar) [] []
Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) []
_ -> Invalid -- something bad happened; just ignore and continue.
classifyTab table = compile table
@ -204,15 +205,26 @@ run_input_processor_loop classify_table input stop_flag = do
<*> pure (classify classify_table)
runReaderT (evalStateT loop_input_processor s0) input
attributeControl :: Fd -> IO (IO (), IO ())
attributeControl fd = do
original <- getTerminalAttributes fd
let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
, EnableEcho, ProcessInput, ExtendedFunctions
]
let set_attrs = setTerminalAttributes fd vtyMode Immediately
unset_attrs = setTerminalAttributes fd original Immediately
return (set_attrs,unset_attrs)
-- This is an example of an algorithm where code coverage could be high, even 100%, but the
-- algorithm still under tested. I should collect more of these examples...
initInputForFd :: IORef Config -> ClassifyTable -> Fd -> IO Input
initInputForFd in_config_ref classify_table in_input_fd = do
initInputForFd :: Config -> ClassifyTable -> Fd -> IO Input
initInputForFd config classify_table in_fd = do
apply_timing_config in_fd config
stop_flag <- newIORef False
input <- Input <$> newChan
<*> pure (writeIORef stop_flag True)
<*> pure in_config_ref
<*> pure in_input_fd
<*> newIORef config
<*> pure in_fd
_ <- forkOS $ run_input_processor_loop classify_table input stop_flag
return input

74
test/VerifyUsingMockInput.hs
View File

@ -18,12 +18,15 @@ import Graphics.Vty.Input.Terminfo
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Lens ((^.))
import Control.Monad
import Data.Default
import Data.IORef
import System.Console.Terminfo
import System.Posix.IO
import System.Posix.Terminal (openPseudoTerminal)
import System.Posix.Types
import System.Timeout
@ -76,8 +79,8 @@ gen_events_using_io_actions max_duration input_action output_action = do
let max_duration' = max min_timout max_duration
read_complete <- newEmptyMVar
write_complete <- newEmptyMVar
_ <- forkIO $ input_action `finally` putMVar write_complete ()
_ <- forkIO $ output_action `finally` putMVar read_complete ()
_ <- forkOS $ input_action `finally` putMVar write_complete ()
_ <- forkOS $ output_action `finally` putMVar read_complete ()
Just () <- timeout max_duration' $ takeMVar write_complete
Just () <- timeout max_duration' $ takeMVar read_complete
return ()
@ -106,54 +109,29 @@ assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO
assert_events_from_syn_input table input_spec expected_events = do
let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
event_count = length expected_events
(output_fd, input_fd) <- createPipe
(output, shutdown_event_processing) <- initInputForFd test_esc_sample_delay table output_fd
(write_fd, read_fd) <- openPseudoTerminal
(set_term_attr,_) <- attributeControl read_fd
set_term_attr
input <- initInputForFd def table read_fd
events_ref <- newIORef []
let write_wait_close = do
synthesize_input input_spec input_fd
synthesize_input input_spec write_fd
threadDelay min_detectable_delay
shutdown_event_processing
shutdown_input input
threadDelay min_detectable_delay
closeFd input_fd
closeFd output_fd
closeFd write_fd
closeFd read_fd
-- drain output pipe
let read_events = read_loop event_count
read_loop 0 = return ()
read_loop n = do
e <- readChan output
e <- readChan $ input^.event_channel
modifyIORef events_ref ((:) e)
read_loop (n - 1)
gen_events_using_io_actions max_duration write_wait_close read_events
out_events <- reverse <$> readIORef events_ref
compare_events input_spec expected_events out_events
assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
assert_events_from_input_block table input_spec expected_events = do
let classifier = classify table
max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay
input <- newChan
output <- newChan
gen_events_using_io_actions
max_duration
(write_input_spec_to_chan input_spec input)
(inputToEventThread classifier input output)
-- TODO: use STM TChan?
-- assures reading "length expected_events" from the channel does not block.
let min_event_count = length expected_events
writeList2Chan output $ replicate min_event_count undefined
out_events <- take min_event_count <$> getChanContents output
return $ out_events == expected_events
write_input_spec_to_chan :: InputSpec -> Chan Char -> IO ()
write_input_spec_to_chan [] chan = do
writeChan chan '\xFFFD'
write_input_spec_to_chan (Bytes str : input_spec') chan = do
writeList2Chan chan str
write_input_spec_to_chan input_spec' chan
write_input_spec_to_chan (Delay _t : input_spec') chan = do
writeChan chan '\xFFFE'
write_input_spec_to_chan input_spec' chan
newtype InputBlocksUsingTable event
= InputBlocksUsingTable ([(String,event)] -> [(String, event)])
@ -168,24 +146,6 @@ instance Monad m => Serial m (InputBlocksUsingTable event) where
selections [] = []
selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
verify_visible_input_block_to_event :: Property IO
verify_visible_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do
let input_seq = gen visible_chars
input = Bytes $ concat [s | (s,_) <- input_seq]
events = map snd input_seq
monadic $ assert_events_from_input_block visible_chars [input] events
verify_keys_from_caps_table_block_to_event :: Property IO
verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable gen) ->
forEachOf terminals_of_interest $ \term_name -> monadic $ do
term <- setupTerm term_name
let table = caps_classify_table term keys_from_caps_table
input_seq = gen table
events = map snd input_seq
keydowns = map (Bytes . fst) input_seq
input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]
assert_events_from_input_block table input events
verify_visible_syn_input_to_event :: Property IO
verify_visible_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
let table = visible_chars
@ -228,11 +188,7 @@ verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
main :: IO ()
main = defaultMain
[ testProperty "basic block generated from a single visible chars to event translation"
verify_visible_input_block_to_event
, testProperty "key sequences read from caps table map to expected events"
verify_keys_from_caps_table_block_to_event
, testProperty "synthesized typing from single visible chars translates to expected events"
[ testProperty "synthesized typing from single visible chars translates to expected events"
verify_visible_syn_input_to_event
, testProperty "synthesized typing from keys from capabilities tables translates to expected events"
verify_caps_syn_input_to_event

4
vty.cabal
View File

@ -44,7 +44,7 @@ library
containers,
data-default >= 0.5.3,
deepseq >= 1.1 && < 1.4,
lens >= 3.9.0.2,
lens >= 3.9.0.2 && < 4.0,
-- required for nice installation with yi
hashable >= 1.2,
mtl >= 1.1.1.0 && < 2.2,
@ -525,6 +525,7 @@ test-suite verify-using-mock-input
build-depends: vty,
Cabal == 1.18.*,
data-default >= 0.5.3,
QuickCheck >= 2.4,
smallcheck == 1.*,
quickcheck-assertions >= 0.1.1,
@ -535,6 +536,7 @@ test-suite verify-using-mock-input
bytestring,
containers,
deepseq >= 1.1 && < 1.4,
lens >= 3.9.0.2 && < 4.0,
mtl >= 1.1.1.0 && < 2.2,
terminfo >= 0.3 && < 0.4,
text >= 0.11.3,