mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-11-30 02:13:36 +03:00
resolve compilation issues and test failures
This commit is contained in:
Corey O'Connor
parent
451b12eee9
commit
888b6d2589
@ -2,7 +2,7 @@
|
||||
* removed the typeclass based terminal and display context interface in favor of a data
|
||||
structure of properties interface.
|
||||
* input handling changes
|
||||
* KASCII is not KChar
|
||||
* KASCII is now KChar
|
||||
* KPN5 is now KCenter
|
||||
* tests exist.
|
||||
* the default amount of time between ESC and a subsequent character that causes VTY to
|
||||
|
||||
@ -50,7 +50,6 @@ import Graphics.Text.Width
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Monoid
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
@ -60,75 +59,6 @@ import Data.Word
|
||||
infixr 5 <|>
|
||||
infixr 4 <->
|
||||
|
||||
-- | Append in the Monoid instance is equivalent to <->.
|
||||
instance Monoid Image where
|
||||
mempty = EmptyImage
|
||||
mappend = vert_join
|
||||
|
||||
-- | combines two images side by side
|
||||
--
|
||||
-- Combines text chunks where possible. Assures output_width and output_height properties are not
|
||||
-- violated.
|
||||
--
|
||||
-- The result image will have a width equal to the sum of the two images width. And the height will
|
||||
-- equal the largest height of the two images. The area not defined in one image due to a height
|
||||
-- missmatch will be filled with the background pattern.
|
||||
--
|
||||
-- TODO: the bg fill is biased towards top to bottom languages(?)
|
||||
horiz_join :: Image -> Image -> Image
|
||||
horiz_join EmptyImage i = i
|
||||
horiz_join i EmptyImage = i
|
||||
horiz_join i_0@(HorizText a_0 t_0 w_0 cw_0) i_1@(HorizText a_1 t_1 w_1 cw_1)
|
||||
| a_0 == a_1 = HorizText a_0 (TL.append t_0 t_1) (w_0 + w_1) (cw_0 + cw_1)
|
||||
-- TODO: assumes horiz text height is always 1
|
||||
| otherwise = HorizJoin i_0 i_1 (w_0 + w_1) 1
|
||||
horiz_join i_0 i_1
|
||||
-- If the images are of the same height then no padding is required
|
||||
| h_0 == h_1 = HorizJoin i_0 i_1 w h_0
|
||||
-- otherwise one of the images needs to be padded to the right size.
|
||||
| h_0 < h_1 -- Pad i_0
|
||||
= let pad_amount = h_1 - h_0
|
||||
in HorizJoin (VertJoin i_0 (BGFill w_0 pad_amount) w_0 h_1) i_1 w h_1
|
||||
| h_0 > h_1 -- Pad i_1
|
||||
= let pad_amount = h_0 - h_1
|
||||
in HorizJoin i_0 (VertJoin i_1 (BGFill w_1 pad_amount) w_1 h_0) w h_0
|
||||
where
|
||||
w_0 = image_width i_0
|
||||
w_1 = image_width i_1
|
||||
w = w_0 + w_1
|
||||
h_0 = image_height i_0
|
||||
h_1 = image_height i_1
|
||||
horiz_join _ _ = error "horiz_join applied to undefined values."
|
||||
|
||||
-- | combines two images vertically
|
||||
--
|
||||
-- The result image will have a height equal to the sum of the heights of both images.
|
||||
-- The width will equal the largest width of the two images.
|
||||
-- The area not defined in one image due to a width missmatch will be filled with the background
|
||||
-- pattern.
|
||||
--
|
||||
-- TODO: the bg fill is biased towards right to left languages(?)
|
||||
vert_join :: Image -> Image -> Image
|
||||
vert_join EmptyImage i = i
|
||||
vert_join i EmptyImage = i
|
||||
vert_join i_0 i_1
|
||||
-- If the images are of the same width then no background padding is required
|
||||
| w_0 == w_1 = VertJoin i_0 i_1 w_0 h
|
||||
-- Otherwise one of the images needs to be padded to the size of the other image.
|
||||
| w_0 < w_1
|
||||
= let pad_amount = w_1 - w_0
|
||||
in VertJoin (HorizJoin i_0 (BGFill pad_amount h_0) w_1 h_0) i_1 w_1 h
|
||||
| w_0 > w_1
|
||||
= let pad_amount = w_0 - w_1
|
||||
in VertJoin i_0 (HorizJoin i_1 (BGFill pad_amount h_1) w_0 h_1) w_0 h
|
||||
where
|
||||
w_0 = image_width i_0
|
||||
w_1 = image_width i_1
|
||||
h_0 = image_height i_0
|
||||
h_1 = image_height i_1
|
||||
h = h_0 + h_1
|
||||
vert_join _ _ = error "vert_join applied to undefined values."
|
||||
|
||||
-- | An area of the picture's bacground (See Background) of w columns and h rows.
|
||||
background_fill :: Int -> Int -> Image
|
||||
background_fill w h
|
||||
|
||||
@ -7,6 +7,7 @@ import Graphics.Text.Width
|
||||
|
||||
import Control.DeepSeq
|
||||
|
||||
import Data.Monoid
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
-- | A display text is a Data.Text.Lazy
|
||||
@ -221,3 +222,72 @@ image_height CropBottom { output_height = h } = h
|
||||
image_height CropTop { output_height = h } = h
|
||||
image_height EmptyImage = 0
|
||||
|
||||
-- | Append in the Monoid instance is equivalent to <->.
|
||||
instance Monoid Image where
|
||||
mempty = EmptyImage
|
||||
mappend = vert_join
|
||||
|
||||
-- | combines two images side by side
|
||||
--
|
||||
-- Combines text chunks where possible. Assures output_width and output_height properties are not
|
||||
-- violated.
|
||||
--
|
||||
-- The result image will have a width equal to the sum of the two images width. And the height will
|
||||
-- equal the largest height of the two images. The area not defined in one image due to a height
|
||||
-- missmatch will be filled with the background pattern.
|
||||
--
|
||||
-- TODO: the bg fill is biased towards top to bottom languages(?)
|
||||
horiz_join :: Image -> Image -> Image
|
||||
horiz_join EmptyImage i = i
|
||||
horiz_join i EmptyImage = i
|
||||
horiz_join i_0@(HorizText a_0 t_0 w_0 cw_0) i_1@(HorizText a_1 t_1 w_1 cw_1)
|
||||
| a_0 == a_1 = HorizText a_0 (TL.append t_0 t_1) (w_0 + w_1) (cw_0 + cw_1)
|
||||
-- TODO: assumes horiz text height is always 1
|
||||
| otherwise = HorizJoin i_0 i_1 (w_0 + w_1) 1
|
||||
horiz_join i_0 i_1
|
||||
-- If the images are of the same height then no padding is required
|
||||
| h_0 == h_1 = HorizJoin i_0 i_1 w h_0
|
||||
-- otherwise one of the images needs to be padded to the right size.
|
||||
| h_0 < h_1 -- Pad i_0
|
||||
= let pad_amount = h_1 - h_0
|
||||
in HorizJoin (VertJoin i_0 (BGFill w_0 pad_amount) w_0 h_1) i_1 w h_1
|
||||
| h_0 > h_1 -- Pad i_1
|
||||
= let pad_amount = h_0 - h_1
|
||||
in HorizJoin i_0 (VertJoin i_1 (BGFill w_1 pad_amount) w_1 h_0) w h_0
|
||||
where
|
||||
w_0 = image_width i_0
|
||||
w_1 = image_width i_1
|
||||
w = w_0 + w_1
|
||||
h_0 = image_height i_0
|
||||
h_1 = image_height i_1
|
||||
horiz_join _ _ = error "horiz_join applied to undefined values."
|
||||
|
||||
-- | combines two images vertically
|
||||
--
|
||||
-- The result image will have a height equal to the sum of the heights of both images.
|
||||
-- The width will equal the largest width of the two images.
|
||||
-- The area not defined in one image due to a width missmatch will be filled with the background
|
||||
-- pattern.
|
||||
--
|
||||
-- TODO: the bg fill is biased towards right to left languages(?)
|
||||
vert_join :: Image -> Image -> Image
|
||||
vert_join EmptyImage i = i
|
||||
vert_join i EmptyImage = i
|
||||
vert_join i_0 i_1
|
||||
-- If the images are of the same width then no background padding is required
|
||||
| w_0 == w_1 = VertJoin i_0 i_1 w_0 h
|
||||
-- Otherwise one of the images needs to be padded to the size of the other image.
|
||||
| w_0 < w_1
|
||||
= let pad_amount = w_1 - w_0
|
||||
in VertJoin (HorizJoin i_0 (BGFill pad_amount h_0) w_1 h_0) i_1 w_1 h
|
||||
| w_0 > w_1
|
||||
= let pad_amount = w_0 - w_1
|
||||
in VertJoin i_0 (HorizJoin i_1 (BGFill pad_amount h_1) w_0 h_1) w_0 h
|
||||
where
|
||||
w_0 = image_width i_0
|
||||
w_1 = image_width i_1
|
||||
h_0 = image_height i_0
|
||||
h_1 = image_height i_1
|
||||
h = h_0 + h_1
|
||||
vert_join _ _ = error "vert_join applied to undefined values."
|
||||
|
||||
|
||||
@ -89,7 +89,7 @@ input_for_name_and_io escDelay term_name term_in = do
|
||||
]
|
||||
setTerminalAttributes term_in attr' Immediately
|
||||
set_term_timing term_in
|
||||
let classify_table = classify_table_for_term terminal
|
||||
let classify_table = classify_table_for_term term_name terminal
|
||||
(eventChannel, shutdown_event_processing) <- initInputForFd escDelay classify_table term_in
|
||||
let pokeIO = Catch $ do
|
||||
let e = error "(getsize in input layer)"
|
||||
|
||||
@ -38,15 +38,5 @@ data Event
|
||||
| EvResize Int Int
|
||||
deriving (Eq,Show,Ord)
|
||||
|
||||
-- | representation of mapping from input bytes to key and modifier.
|
||||
--
|
||||
-- Deprecated. Only used internally
|
||||
type ClassifyTableV1 = [(String, (Key, [Modifier]))]
|
||||
|
||||
-- | representation of mapping from input bytes to event
|
||||
type ClassifyTable = [(String, Event)]
|
||||
|
||||
map_to_legacy_table :: ClassifyTable -> ClassifyTableV1
|
||||
map_to_legacy_table = map f
|
||||
where f (s, EvKey k mods) = (s, (k, mods))
|
||||
f _ = error "no mapping for mouse or resize events"
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
-- Much of the input layer used to be in a single module with a few large functions. I've refactored
|
||||
-- the input layer into many small bits. Now, I think, the code is a better position to be
|
||||
-- incrementally refined. Still, until there are proper tests in place much of the refinement must
|
||||
-- wait.
|
||||
module Graphics.Vty.Input.Internal where
|
||||
|
||||
import Graphics.Vty.Input.Events
|
||||
@ -15,6 +19,7 @@ import qualified Data.Set as S( fromList, member )
|
||||
import Data.Word
|
||||
|
||||
import Foreign ( alloca, poke, peek, Ptr )
|
||||
import Foreign.C.Types (CInt(..))
|
||||
|
||||
import System.Posix.IO ( fdReadBuf
|
||||
, setFdOption
|
||||
@ -52,6 +57,10 @@ inputToEventThread classifier inputChannel eventChannel = loop []
|
||||
if c == '\xFFFD'
|
||||
then return ()
|
||||
else loop (kb ++ [c])
|
||||
-- drop the entirety of invalid sequences. Probably better to drop only the first
|
||||
-- character. However, the read behavior of terminals (a single read corresponds to the
|
||||
-- bytes of a single event) might mean this results in quicker error recovery from a
|
||||
-- users perspective.
|
||||
Invalid -> do
|
||||
c <- readChan inputChannel
|
||||
if c == '\xFFFD'
|
||||
@ -61,7 +70,12 @@ inputToEventThread classifier inputChannel eventChannel = loop []
|
||||
MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s
|
||||
Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""
|
||||
|
||||
compile :: ClassifyTableV1 -> [Char] -> KClass
|
||||
-- This makes a kind of tri. Has space efficiency issues with large input blocks.
|
||||
-- Likely building a parser and just applying that would be better.
|
||||
-- I did not write this so I might just rewrite it for better understanding. Not the best of
|
||||
-- reasons...
|
||||
-- TODO: measure and rewrite if required.
|
||||
compile :: ClassifyTable -> [Char] -> KClass
|
||||
compile table = cl' where
|
||||
-- take all prefixes and create a set of these
|
||||
prefix_set = S.fromList $ concatMap (init . inits . fst) $ table
|
||||
@ -73,19 +87,18 @@ compile table = cl' where
|
||||
-- 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
|
||||
Just (EvKey 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
|
||||
(s,EvKey k m) : _ -> MisPfx k m (drop (length s) input_block)
|
||||
-- neither a prefix or a full event. Might be interesting to log.
|
||||
[] -> error $ show input_block
|
||||
|
||||
classify, classifyTab :: ClassifyTableV1 -> [Char] -> KClass
|
||||
classify, classifyTab :: ClassifyTable -> [Char] -> KClass
|
||||
|
||||
-- As soon as
|
||||
classify _table "\xFFFD" = EndLoop
|
||||
@ -97,7 +110,7 @@ classify table other
|
||||
|
||||
classifyUtf8 :: [Char] -> KClass
|
||||
classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
|
||||
Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []
|
||||
Just (unicodeChar, _) -> Valid (KChar unicodeChar) []
|
||||
_ -> Invalid -- something bad happened; just ignore and continue.
|
||||
|
||||
classifyTab table = compile table
|
||||
@ -112,7 +125,15 @@ utf8Length c
|
||||
| c < 0xF0 = 3
|
||||
| otherwise = 4
|
||||
|
||||
initInputForFd :: Int -> ClassifyTableV1 -> Fd -> IO (Chan Event, IO ())
|
||||
-- I gave a quick shot at replacing this code with some that removed the "odd" bits. The "obvious"
|
||||
-- changes all failed testing. This is timing sensitive code.
|
||||
-- I now think I can replace this wil code that makes the time sensitivity explicit. I am waiting
|
||||
-- until I have a good set of characterization tests to verify the input to event timing is still
|
||||
-- correct for a user. I estimate the current tests cover ~70% of the required cases.
|
||||
--
|
||||
-- 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 :: Int -> ClassifyTable -> Fd -> IO (Chan Event, IO ())
|
||||
initInputForFd escDelay classify_table input_fd = do
|
||||
inputChannel <- newChan
|
||||
eventChannel <- newChan
|
||||
|
||||
@ -1,9 +1,10 @@
|
||||
module Graphics.Vty.Input.Terminfo where
|
||||
|
||||
import Graphics.Vty.Input.Events
|
||||
import qualified Graphics.Vty.Input.Terminfo.VT100 as VT100
|
||||
import qualified Graphics.Vty.Input.Terminfo.ANSI as ANSI
|
||||
import qualified Graphics.Vty.Input.Terminfo.XTerm7Bit as XTerm7Bit
|
||||
|
||||
import Control.Arrow
|
||||
import System.Console.Terminfo
|
||||
|
||||
-- | queries the terminal for all capability based input sequences then adds on a terminal dependent
|
||||
@ -33,21 +34,23 @@ import System.Console.Terminfo
|
||||
--
|
||||
-- \todo terminfo meta is not supported.
|
||||
-- \todo no 8bit
|
||||
classify_table_for_term :: String -> Terminal -> ClassifyTableV1
|
||||
classify_table_for_term :: String -> Terminal -> ClassifyTable
|
||||
classify_table_for_term term_name term =
|
||||
concatMap map_to_legacy_table
|
||||
$ caps_classify_table term keys_from_caps_table
|
||||
: visible_chars
|
||||
: ctrl_chars
|
||||
: ctrl_meta_chars
|
||||
: special_support_keys
|
||||
: internal_tables term_name
|
||||
concat $ caps_classify_table term keys_from_caps_table
|
||||
: universal_table
|
||||
: term_specific_tables term_name
|
||||
|
||||
caps_classify_table :: Terminal -> [(String,Event)] -> [(String,Event)]
|
||||
-- | key table assumed to be applicable to all terminals.
|
||||
universal_table :: ClassifyTable
|
||||
universal_table = concat [visible_chars, ctrl_chars, ctrl_meta_chars, special_support_keys]
|
||||
|
||||
caps_classify_table :: Terminal -> [(String,Event)] -> ClassifyTable
|
||||
caps_classify_table terminal table = [(x,y) | (Just x,y) <- map extract_cap table]
|
||||
where extract_cap = first (getCapability terminal . tiGetStr)
|
||||
|
||||
internal_tables term_name
|
||||
-- | tables specific to a given terminal that are not derivable from terminfo.
|
||||
term_specific_tables :: String -> [ClassifyTable]
|
||||
term_specific_tables term_name
|
||||
| ANSI.supports term_name = ANSI.tables
|
||||
| XTerm7Bit.supports term_name = XTerm7Bit.tables
|
||||
| otherwise = []
|
||||
@ -64,19 +67,20 @@ visible_chars = [ ([x], EvKey (KChar x) [])
|
||||
| x <- [' ' .. toEnum 0xC1]
|
||||
]
|
||||
|
||||
-- | Non visible cahracters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char.
|
||||
-- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char.
|
||||
--
|
||||
-- \todo resolve CTRL-i is the same as tab
|
||||
ctrl_chars :: ClassifyTable
|
||||
ctrl_chars =
|
||||
[ ([toEnum x],EvKey (KChar y) [MCtrl])
|
||||
| (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),
|
||||
y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
|
||||
y /= 'i', -- Resolve issue #3 where CTRL-i hides TAB.
|
||||
y /= 'h' -- CTRL-h should not hide BS
|
||||
]
|
||||
|
||||
-- | Ctrl+Meta+Char
|
||||
ctrl_meta_chars :: ClassifyTable
|
||||
ctrl_meta_chars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m)))
|
||||
ctrl_meta_chars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrl_chars
|
||||
|
||||
-- | esc, meta esc, delete, meta delete, enter, meta enter
|
||||
special_support_keys :: ClassifyTable
|
||||
@ -88,7 +92,7 @@ special_support_keys =
|
||||
-- Special support for Enter
|
||||
, ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter [])
|
||||
-- explicit support for tab
|
||||
, ("\t", EvKey KChar '\t' []
|
||||
, ("\t", EvKey (KChar '\t') [])
|
||||
]
|
||||
|
||||
-- | classify table directly generated from terminfo cap strings
|
||||
|
||||
@ -24,7 +24,7 @@ nav_keys_0 =
|
||||
-- | VT 100 (?) encoding for shift, meta and ctrl plus arrows/home/end
|
||||
nav_keys_1 :: ClassifyTable
|
||||
nav_keys_1 =
|
||||
[("\ESC[" ++ charCnt ++ show mc++c,(s,m))
|
||||
[("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)
|
||||
| charCnt <- ["1;", ""], -- we can have a count or not
|
||||
(m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
|
||||
([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes
|
||||
@ -33,16 +33,16 @@ nav_keys_1 =
|
||||
]
|
||||
|
||||
-- | VT 100 (?) encoding for ins, del, pageup, pagedown, home, end
|
||||
nav_keys_2 :: ClassifyTableV1
|
||||
nav_keys_2 :: ClassifyTable
|
||||
nav_keys_2 =
|
||||
let k n s = ("\ESC["++show n++"~",(s,[]))
|
||||
let k n s = ("\ESC["++show n++"~",EvKey s [])
|
||||
in zipWith k [2::Int,3,5,6,1,4]
|
||||
[KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
|
||||
|
||||
-- | VT 100 (?) encoding for ctrl + ins, del, pageup, pagedown, home, end
|
||||
nav_keys_3 :: ClassifyTableV1
|
||||
nav_keys_3 :: ClassifyTable
|
||||
nav_keys_3 =
|
||||
let k n s = ("\ESC["++show n++";5~",(s,[MCtrl]))
|
||||
let k n s = ("\ESC["++show n++";5~", EvKey s [MCtrl])
|
||||
in zipWith k [2::Int,3,5,6,1,4]
|
||||
[KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
|
||||
|
||||
@ -55,9 +55,9 @@ nav_keys_3 =
|
||||
-- ``meta mode'' on and off, they can be given as smm and rmm."
|
||||
--
|
||||
-- That is more complex than below. I cannot fault the original author for just hard coding a table.
|
||||
function_keys_1 :: ClassifyTableV1
|
||||
function_keys_1 :: ClassifyTable
|
||||
function_keys_1 =
|
||||
let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in
|
||||
let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in
|
||||
concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
|
||||
|
||||
-- | VT 100 (?) encoding for meta plus char
|
||||
@ -69,11 +69,13 @@ function_keys_1 =
|
||||
-- the same as ESC should examine km and current encoding.
|
||||
-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by
|
||||
-- special_support_keys.
|
||||
function_keys_2 :: ClassifyTableV1
|
||||
function_keys_2 = [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\t':[' ' .. '~'],
|
||||
x /= '[']
|
||||
function_keys_2 :: ClassifyTable
|
||||
function_keys_2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])
|
||||
| x <- '\t':[' ' .. '~']
|
||||
, x /= '['
|
||||
]
|
||||
|
||||
tables :: [ClassifyTableV1]
|
||||
tables :: [ClassifyTable]
|
||||
tables =
|
||||
[ nav_keys_0
|
||||
, nav_keys_1
|
||||
|
||||
@ -1,17 +1,20 @@
|
||||
module Graphics.Vty.Input.Terminfo.XTerm where
|
||||
module Graphics.Vty.Input.Terminfo.XTerm7Bit where
|
||||
|
||||
import Graphics.Vty.Input.Events
|
||||
|
||||
import Data.List (isInfixOf, isPrefixOf)
|
||||
|
||||
-- | The built in input augmentation for XTerm supports any TERM starting with xterm except those
|
||||
-- containing 8bit.
|
||||
supports term_name = "xterm" `isPrefixOf` term_name && !("8bit" `isInfixOf` term_name)
|
||||
supports :: String -> Bool
|
||||
supports term_name = "xterm" `isPrefixOf` term_name && not ("8bit" `isInfixOf` term_name)
|
||||
|
||||
-- | Encoding for navigation keys.
|
||||
--
|
||||
-- TODO: This is not the same as the input bytes pulled from teh caps table.
|
||||
nav_keys_0 :: ClassifyTableV1
|
||||
nav_keys_0 :: ClassifyTable
|
||||
nav_keys_0 =
|
||||
[ k "G" KNP5
|
||||
[ k "G" KCenter
|
||||
, k "P" KPause
|
||||
, k "A" KUp
|
||||
, k "B" KDown
|
||||
@ -21,12 +24,12 @@ nav_keys_0 =
|
||||
, k "F" KEnd
|
||||
, k "E" KBegin
|
||||
]
|
||||
where k c s = ("\ESC["++c,(s,[]))
|
||||
where k c s = ("\ESC["++c,EvKey s [])
|
||||
|
||||
-- | VT 100 (?) encoding for shift, meta and ctrl plus arrows/home/end
|
||||
nav_keys_1 :: ClassifyTableV1
|
||||
nav_keys_1 :: ClassifyTable
|
||||
nav_keys_1 =
|
||||
[("\ESC[" ++ charCnt ++ show mc++c,(s,m))
|
||||
[("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)
|
||||
| charCnt <- ["1;", ""], -- we can have a count or not
|
||||
(m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
|
||||
([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes
|
||||
@ -34,16 +37,16 @@ nav_keys_1 =
|
||||
]
|
||||
|
||||
-- | VT 100 (?) encoding for ins, del, pageup, pagedown, home, end
|
||||
nav_keys_2 :: ClassifyTableV1
|
||||
nav_keys_2 :: ClassifyTable
|
||||
nav_keys_2 =
|
||||
let k n s = ("\ESC["++show n++"~",(s,[]))
|
||||
let k n s = ("\ESC["++show n++"~",EvKey s [])
|
||||
in zipWith k [2::Int,3,5,6,1,4]
|
||||
[KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
|
||||
|
||||
-- | VT 100 (?) encoding for ctrl + ins, del, pageup, pagedown, home, end
|
||||
nav_keys_3 :: ClassifyTableV1
|
||||
nav_keys_3 :: ClassifyTable
|
||||
nav_keys_3 =
|
||||
let k n s = ("\ESC["++show n++";5~",(s,[MCtrl]))
|
||||
let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl])
|
||||
in zipWith k [2::Int,3,5,6,1,4]
|
||||
[KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
|
||||
|
||||
@ -56,9 +59,9 @@ nav_keys_3 =
|
||||
-- ``meta mode'' on and off, they can be given as smm and rmm."
|
||||
--
|
||||
-- That is more complex than below. I cannot fault the original author for just hard coding a table.
|
||||
function_keys_1 :: ClassifyTableV1
|
||||
function_keys_1 :: ClassifyTable
|
||||
function_keys_1 =
|
||||
let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in
|
||||
let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in
|
||||
concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]
|
||||
|
||||
-- | VT 100 (?) encoding for meta plus char
|
||||
@ -70,12 +73,14 @@ function_keys_1 =
|
||||
-- the same as ESC should examine km and current encoding.
|
||||
-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by
|
||||
-- special_support_keys.
|
||||
function_keys_2 :: ClassifyTableV1
|
||||
function_keys_2 = [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\t':[' ' .. '~'],
|
||||
x /= '[']
|
||||
function_keys_2 :: ClassifyTable
|
||||
function_keys_2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])
|
||||
| x <- '\t':[' ' .. '~']
|
||||
, x /= '['
|
||||
]
|
||||
|
||||
-- | classify table for ANSI terminals
|
||||
tables :: [ClassifyTableV1]
|
||||
tables :: [ClassifyTable]
|
||||
tables =
|
||||
[ nav_keys_0
|
||||
, nav_keys_1
|
||||
|
||||
@ -93,7 +93,7 @@ process_event = do
|
||||
then return True
|
||||
else do
|
||||
case k of
|
||||
EvKey (KASCII 'r') [MCtrl] -> ask >>= liftIO . refresh
|
||||
EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh
|
||||
EvKey KLeft [] -> move_dude (-1) 0
|
||||
EvKey KRight [] -> move_dude 1 0
|
||||
EvKey KUp [] -> move_dude 0 (-1)
|
||||
|
||||
@ -11,7 +11,7 @@ import Verify.Graphics.Vty.Output
|
||||
import Data.List (intersperse)
|
||||
|
||||
import Graphics.Vty hiding (resize)
|
||||
import Graphics.Vty.Input.Data
|
||||
import Graphics.Vty.Input.Events
|
||||
import Graphics.Vty.Input.Internal
|
||||
import Graphics.Vty.Input.Terminfo
|
||||
|
||||
@ -102,7 +102,7 @@ compare_events input_spec expected_events out_events = compare_events' expected_
|
||||
printf "received events %s\n" (show out_events) :: IO ()
|
||||
return False
|
||||
|
||||
assert_events_from_syn_input :: ClassifyTableV1 -> InputSpec -> ExpectedSpec -> IO Bool
|
||||
assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool
|
||||
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
|
||||
@ -127,7 +127,7 @@ assert_events_from_syn_input table input_spec expected_events = do
|
||||
out_events <- reverse <$> readIORef events_ref
|
||||
compare_events input_spec expected_events out_events
|
||||
|
||||
assert_events_from_input_block :: ClassifyTableV1 -> InputSpec -> ExpectedSpec -> IO Bool
|
||||
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
|
||||
@ -168,12 +168,12 @@ instance Monad m => Serial m (InputBlocksUsingTable event) where
|
||||
selections [] = []
|
||||
selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)
|
||||
|
||||
verify_simple_input_block_to_event :: Property IO
|
||||
verify_simple_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do
|
||||
let input_seq = gen simple_chars
|
||||
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 = [e | (_,(k,ms)) <- input_seq, let e = EvKey k ms]
|
||||
monadic $ assert_events_from_input_block simple_chars [input] events
|
||||
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) ->
|
||||
@ -181,19 +181,19 @@ verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable ge
|
||||
term <- setupTerm term_name
|
||||
let table = caps_classify_table term keys_from_caps_table
|
||||
input_seq = gen table
|
||||
events = [e | (_,e) <- input_seq]
|
||||
keydowns = [Bytes s | (s,_) <- input_seq]
|
||||
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 (map_to_legacy_table table) input events
|
||||
assert_events_from_input_block table input events
|
||||
|
||||
verify_simple_syn_input_to_event :: Property IO
|
||||
verify_simple_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
|
||||
let table = simple_chars
|
||||
verify_visible_syn_input_to_event :: Property IO
|
||||
verify_visible_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
|
||||
let table = visible_chars
|
||||
input_seq = gen table
|
||||
events = [EvKey k ms | (_,(k,ms)) <- input_seq]
|
||||
keydowns = [Bytes s | (s,_) <- input_seq]
|
||||
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_syn_input (concat ansi_classify_table) input events
|
||||
assert_events_from_syn_input universal_table input events
|
||||
|
||||
verify_caps_syn_input_to_event :: Property IO
|
||||
verify_caps_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
|
||||
@ -201,39 +201,39 @@ verify_caps_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
|
||||
term <- setupTerm term_name
|
||||
let table = caps_classify_table term keys_from_caps_table
|
||||
input_seq = gen table
|
||||
events = [e | (_,e) <- input_seq]
|
||||
keydowns = [Bytes s | (s,_) <- input_seq]
|
||||
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_syn_input (map_to_legacy_table table) input events
|
||||
assert_events_from_syn_input table input events
|
||||
|
||||
verify_special_syn_input_to_event :: Property IO
|
||||
verify_special_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do
|
||||
let table = function_keys_1 ++ function_keys_2
|
||||
let table = special_support_keys
|
||||
input_seq = gen table
|
||||
events = [EvKey k ms | (_,(k,ms)) <- input_seq]
|
||||
keydowns = [Bytes s | (s,_) <- input_seq]
|
||||
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_syn_input (concat ansi_classify_table) input events
|
||||
assert_events_from_syn_input universal_table input events
|
||||
|
||||
verify_full_syn_input_to_event :: Property IO
|
||||
verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->
|
||||
forEachOf terminals_of_interest $ \term_name -> monadic $ do
|
||||
term <- setupTerm term_name
|
||||
let table = classify_table_for_term term
|
||||
let table = classify_table_for_term term_name term
|
||||
input_seq = gen table
|
||||
events = [EvKey k ms | (_,(k,ms)) <- input_seq]
|
||||
keydowns = [Bytes s | (s,_) <- input_seq]
|
||||
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_syn_input table input events
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
[ testProperty "basic block generated from a single visible chars to event translation"
|
||||
verify_simple_input_block_to_event
|
||||
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"
|
||||
verify_simple_syn_input_to_event
|
||||
verify_visible_syn_input_to_event
|
||||
, testProperty "synthesized typing from keys from capabilities tables translates to expected events"
|
||||
verify_caps_syn_input_to_event
|
||||
, testProperty "synthesized typing from hard coded special keys translates to expected events"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user