ilyakooo0/vty
1
0
Fork 0
mirror of https://github.com/ilyakooo0/vty.git synced 2024-10-04 03:07:07 +03:00
Code Issues Projects Releases Wiki Activity

adding example of Graphics.Vty.Inline to test

Browse Source 
Ignore-this: e82f6a3b8eec33ab55fd04a51f4d9873

darcs-hash:20091228233218-f0a0d-345ddcbee616acc4f39d9d12393bdea5982f34d9.gz
This commit is contained in:
coreyoconnor 2009-12-28 15:32:18 -08:00
parent 3360a497d3
commit f6c3cbfa01
30 changed files with 447 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
CHANGELOG
View File

@ -17,6 +17,32 @@
coincidence.
4.0.0
* API changes:
* "getSize" has been removed. Use "terminal vty >>= display_bounds" where "vty" is an
instance of the Vty data structure.
* added a "terminal" field to the Vty data structure. Accesses the TerminalHandle associated
with the Vty instance.
* Graphics.Vty.Types has undergone a number of changes. Summary:
* Partitioned into Graphics.Vty.Attributes for display attributes. Graphics.Vty.Image for
image combinators. Graphics.Vty.Picture for final picture construction.
* Graphics.Vty.Attributes:
* "setFG" and "setBG" are now "with_fore_color" and "with_back_color"
* All other "set.." equations similarly replaced.
* "attr" is now "def_attr", short for "default display attributes" Also added a
"current_attr" for "currently applied display attributes"
* Graphics.Vty.Image:
* "horzcat" is now "horiz_cat"
* "vertcat" is now "vert_cat"
* "renderBS" is now "utf8_bytestring"
* "renderChar" is now "char"
* "renderFill" is now "char_fill"
* added a "utf8_string" and "string" (AKA "iso_10464_string") for UTF-8 encoded Strings
and ISO-10464 encoded Strings. String literals in GHC have an ISO-10464 runtime
representation.
* Graphics.Vty.Picture:
* exports Graphics.Vty.Image
* "pic" is now "pic_for_image"
* added API for setting background fill pattern.
* Completely rewritten output backend.
* Efficient, scanline style output span generator. Has not been fully optimized, but good
enough.

32
DESIGN Normal file
View File

@ -0,0 +1,32 @@
On the design of vty
It appears to me that there are two kinds of graphical
applications, regardless of the output form; the synchronous and the
asynchronous. Synchronous displays update as changes occur; a good
example of this type is nethack, with its many newsym() calls embedded
in the logic. Synchronous applications use very little abstractable
code, and in practice all use low level interfaces such as terminfo.
Asynchronous screen programs, OTOH, do not have update code within
the main logic. Instead, they perform output "lazily", only computing
it at periodic refresh points. Because "backtracking" is not
rendered, asynchronous screen programs use less bandwidth, and can
(but usually don't) use less CPU. Asynchronous programs have their
update logic centralized in such a way that it can be abstracted as a
library; this is what both vty and curses are.
In the past, vty has had considerable confusion and race
conditions due to the fact that screen resizes can occur
asynchronously with respect to output. Vty 3.0 handles this in an
very elegant (IMO) way, by treating resizes as just another input
event; the size of the picture being output at any time need have no
relation to the screen, though of course corruption will result if
they are different.
On a "real" terminal (termcap, not xcurses), output and input can
be completely separated; they can occur concurrently, and do not
effect each other. Because of this we simplify the internal structure
by using entirely different mechanisms for input and output. This is
also a great benefit because of the differing characteristics of input
code (complicated, best table driven, etc) versus output code
(performance critical).

26
TODO
View File

@ -1,13 +1,15 @@
Minor:
- input parser uses similar interface to DisplayHandle. Derive instance from terminfo
- Improve input handling performance.
- xterm cursor foreground handling.
- specific color
- reverse video
- auto
- position cursor correctly.
Major:
- Remove size fields in resize constr
- Improve input handling
- base off of haskeline input system. The haskeline input system appears to be excellent and
satisfy all of Vty's input requirements. The current haskeline distribution does not appear to
export the required modules. Either:
0. Add the required exports to the haskeline distribution.
- fine for development but complicates the UI for production clients. Though, exposing
the modules would only complicate the appearance of haskeline's interface.
1. Partition the backend of haskeline into a separate package usable by both vty and
haskeline.
- use compact-string for character encoding handling
- Custom cursor appearance handling?
- specific color?
- reverse video?
- auto?

24
src/Codec/Binary/UTF8/Width.hs
View File

@ -1,6 +1,6 @@
-- Copyright 2009 Corey O'Connor
{-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}
{-# INCLUDE <wchar.h> #-}
module Codec.Binary.UTF8.Width ( wcwidth
, wcswidth
@ -10,23 +10,31 @@ module Codec.Binary.UTF8.Width ( wcwidth
import Foreign.C.Types
import Foreign.C.String
import Foreign.Storable
import Foreign.Ptr
import Numeric ( showHex )
-- import Numeric ( showHex )
import System.IO.Unsafe
wcwidth :: Char -> Int
wcwidth c = unsafePerformIO (withCWString [c] $ \ws -> do
wcwidth c = unsafePerformIO (withCWString [c] $! \ws -> do
wc <- peek ws
putStr $ "wcwidth(0x" ++ showHex (fromEnum wc) "" ++ ")"
w <- wcwidth' wc >>= return . fromIntegral
putStrLn $ " -> " ++ show w
-- putStr $ "wcwidth(0x" ++ showHex (fromEnum wc) "" ++ ")"
let !w = fromIntegral $! wcwidth' wc
-- putStrLn $ " -> " ++ show w
return w
)
{-# NOINLINE wcwidth #-}
foreign import ccall "mk_wcwidth" wcwidth' :: CWchar -> IO CInt
foreign import ccall unsafe "mk_wcwidth" wcwidth' :: CWchar -> CInt
wcswidth :: String -> Int
wcswidth str = sum $ map wcwidth str
wcswidth str = unsafePerformIO (withCWStringLen str $! \(ws, ws_len) -> do
-- putStr $ "wcswidth(...)"
let !w = fromIntegral $! wcswidth' ws (fromIntegral ws_len)
-- putStrLn $ " -> " ++ show w
return w
)
{-# NOINLINE wcswidth #-}
foreign import ccall unsafe "mk_wcswidth" wcswidth' :: Ptr CWchar -> CSize -> CInt

68
src/Data/Terminfo/Eval.hs
View File

@ -92,52 +92,61 @@ cap_op_required_bytes (PushValue v) = do
return 0
cap_op_required_bytes (Conditional expr parts) = do
c_expr <- cap_ops_required_bytes expr
c_parts <- foldM cond_parts_required_bytes 0 parts
c_parts <- cond_parts_required_bytes parts
return $ c_expr + c_parts
where
cond_parts_required_bytes in_c (true_ops, false_ops) = do
cond_parts_required_bytes [] = return 0
cond_parts_required_bytes ( (true_ops, false_ops) : false_parts ) = do
-- (man 5 terminfo)
-- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
-- stack, testing if it is nonzero (true). If it is zero (false), control
-- passes to the %e (else) part.
v <- pop
c_branch <- if v /= 0
then cap_ops_required_bytes true_ops
else cap_ops_required_bytes false_ops
return $ in_c + c_branch
c_total <- if v /= 0
then cap_ops_required_bytes true_ops
else do
c_false <- cap_ops_required_bytes false_ops
c_remain <- cond_parts_required_bytes false_parts
return $ c_false + c_remain
return c_total
cap_op_required_bytes BitwiseOr = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ v_0 .|. v_1
return 0
cap_op_required_bytes BitwiseAnd = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ v_0 .&. v_1
return 0
cap_op_required_bytes BitwiseXOr = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ v_0 `xor` v_1
return 0
cap_op_required_bytes ArithPlus = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ v_0 + v_1
return 0
cap_op_required_bytes CompareEq = do
v_0 <- pop
cap_op_required_bytes ArithMinus = do
v_1 <- pop
v_0 <- pop
push $ v_0 - v_1
return 0
cap_op_required_bytes CompareEq = do
v_1 <- pop
v_0 <- pop
push $ if v_0 == v_1 then 1 else 0
return 0
cap_op_required_bytes CompareLt = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ if v_0 < v_1 then 1 else 0
return 0
cap_op_required_bytes CompareGt = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ if v_0 > v_1 then 1 else 0
return 0
@ -175,19 +184,23 @@ serialize_cap_op out_ptr (PushValue v) = do
return out_ptr
serialize_cap_op out_ptr (Conditional expr parts) = do
out_ptr' <- serialize_cap_ops out_ptr expr
out_ptr'' <- foldM serialize_cond_parts out_ptr' parts
out_ptr'' <- serialize_cond_parts out_ptr' parts
return out_ptr''
where
serialize_cond_parts ptr (true_ops, false_ops) = do
serialize_cond_parts ptr [] = return ptr
serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = do
-- (man 5 terminfo)
-- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
-- stack, testing if it is nonzero (true). If it is zero (false), control
-- passes to the %e (else) part.
v <- pop
ptr' <- if v /= 0
ptr'' <- if v /= 0
then serialize_cap_ops ptr true_ops
else serialize_cap_ops ptr false_ops
return ptr'
else do
ptr' <- serialize_cap_ops ptr false_ops
serialize_cond_parts ptr' false_parts
return ptr''
serialize_cap_op out_ptr BitwiseOr = do
v_0 <- pop
v_1 <- pop
@ -199,28 +212,33 @@ serialize_cap_op out_ptr BitwiseAnd = do
push $ v_0 .&. v_1
return out_ptr
serialize_cap_op out_ptr BitwiseXOr = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ v_0 `xor` v_1
return out_ptr
serialize_cap_op out_ptr ArithPlus = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ v_0 + v_1
return out_ptr
serialize_cap_op out_ptr CompareEq = do
v_0 <- pop
serialize_cap_op out_ptr ArithMinus = do
v_1 <- pop
v_0 <- pop
push $ v_0 - v_1
return out_ptr
serialize_cap_op out_ptr CompareEq = do
v_1 <- pop
v_0 <- pop
push $ if v_0 == v_1 then 1 else 0
return out_ptr
serialize_cap_op out_ptr CompareLt = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ if v_0 < v_1 then 1 else 0
return out_ptr
serialize_cap_op out_ptr CompareGt = do
v_0 <- pop
v_1 <- pop
v_0 <- pop
push $ if v_0 > v_1 then 1 else 0
return out_ptr

18
src/Data/Terminfo/Parse.hs
View File

@ -50,7 +50,7 @@ data CapOp =
, conditional_parts :: ![(CapOps, CapOps)]
}
| BitwiseOr | BitwiseXOr | BitwiseAnd
| ArithPlus
| ArithPlus | ArithMinus
| CompareEq | CompareLt | CompareGt
deriving ( Show )
@ -229,10 +229,18 @@ bitwise_xor_parser = do
return $ BuildResults 0 [ BitwiseXOr ] [ ]
arith_op_parser :: CapParser BuildResults
arith_op_parser = do
char '+'
inc_offset 1
return $ BuildResults 0 [ ArithPlus ] [ ]
arith_op_parser
= plus_op
<|> minus_op
where
plus_op = do
char '+'
inc_offset 1
return $ BuildResults 0 [ ArithPlus ] [ ]
minus_op = do
char '-'
inc_offset 1
return $ BuildResults 0 [ ArithMinus ] [ ]
literal_int_op_parser :: CapParser BuildResults
literal_int_op_parser = do

24
src/Graphics/Vty.hs
View File

@ -26,11 +26,10 @@ import Graphics.Vty.DisplayRegion
import Graphics.Vty.LLInput
import Data.IORef
import Control.Concurrent
import Data.Maybe ( maybe )
import System.Console.Terminfo
import qualified System.Console.Terminfo as Terminfo
import System.IO
-- | The main object. At most one should be created.
@ -49,9 +48,6 @@ data Vty = Vty
-- | Get one Event object, blocking if necessary.
, next_event :: IO Event
-- | Handle to the terminal interface. See `Terminal`
--
-- todo: provide a similar abstraction for input. Use haskeline's input backend for
-- implementation.
--
-- The use of Vty typically follows this process:
--
@ -61,13 +57,16 @@ data Vty = Vty
--
-- 2. repeat
--
-- 3. shutdown vty. todo: remove? Automate release of resources as much as possible.
-- 3. shutdown vty.
--
-- This version currently supports the same interface.
-- todo: provide a similar abstraction to Graphics.Vty.Terminal for input. Use haskeline's
-- input backend for implementation.
--
-- todo: remove explicit `shutdown` requirement.
, terminal :: TerminalHandle
-- | Refresh the display. Normally the library takes care of refreshing.
-- Nonetheless, some other program might output to the terminal and mess the display.
-- In that case the user might want to force a refresh.
-- | Refresh the display. Normally the library takes care of refreshing. Nonetheless, some
-- other program might output to the terminal and mess the display. In that case the user
-- might want to force a refresh.
, refresh :: IO ()
-- | Clean up after vty.
, shutdown :: IO ()
@ -80,7 +79,7 @@ mkVty = mkVtyEscDelay 0
mkVtyEscDelay :: Int -> IO Vty
mkVtyEscDelay escDelay = do
term_info <- setupTermFromEnv
term_info <- Terminfo.setupTermFromEnv
t <- terminal_handle
reserve_display t
(kvar, endi) <- initTermInput escDelay term_info
@ -112,7 +111,8 @@ intMkVty kvar fend t = do
writeIORef last_pic_ref $ Just in_pic
let inner_refresh
= readIORef last_pic_ref
= writeIORef last_update_ref Nothing
>> readIORef last_pic_ref
>>= maybe ( return () ) ( \pic -> inner_update pic )
let gkey = do k <- kvar

3
src/Graphics/Vty/Debug.hs
View File

@ -6,7 +6,6 @@ where
import Graphics.Vty.Attributes
import Graphics.Vty.Image
import Graphics.Vty.Image.Debug
import Graphics.Vty.Picture
import Graphics.Vty.Span
import Graphics.Vty.DisplayRegion
@ -21,7 +20,7 @@ instance Show SpanOpSequence where
instance Show SpanOp where
show (AttributeChange attr) = show attr
show (TextSpan width _) = "TextSpan " ++ show width
show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw
row_ops_effected_columns :: SpanOpSequence -> [Word]
row_ops_effected_columns spans

22
src/Graphics/Vty/Image.hs
View File

@ -10,8 +10,6 @@ module Graphics.Vty.Image ( Image(..)
, (<->)
, horiz_cat
, vert_cat
, horzcat
, vertcat
, background_fill
, char
, string
@ -72,8 +70,8 @@ data Image =
, char_width :: !Word -- >= 1
}
-- A horizontal join can be constructed between any two images. However a HorizJoin instance is
-- required to be between two images of equal height. The horiz_join constructor adds blanks to
-- the provided images that assure this is true for the HorizJoin value produced.
-- required to be between two images of equal height. The horiz_join constructor adds background
-- filles to the provided images that assure this is true for the HorizJoin value produced.
| HorizJoin
{ part_left :: Image
, part_right :: Image
@ -81,8 +79,8 @@ data Image =
, output_height :: !Word -- >= 1
}
-- A veritical join can be constructed between any two images. However a VertJoin instance is
-- required to be between two images of equal width. The horiz_join constructor adds blanks to
-- the provides images that assure this is true for the HorizJoin value produced.
-- required to be between two images of equal width. The vert_join constructor adds background
-- fills to the provides images that assure this is true for the VertJoin value produced.
| VertJoin
{ part_top :: Image
, part_bottom :: Image
@ -125,7 +123,7 @@ instance Monoid Image where
horiz_text :: Attr -> StringSeq -> Word -> Image
horiz_text a txt ow
| ow == 0 = EmptyImage
| otherwise = HorizText a txt (toEnum $ Seq.length txt) ow
| otherwise = HorizText a txt ow (toEnum $ Seq.length txt)
horiz_join :: Image -> Image -> Word -> Word -> Image
horiz_join i_0 i_1 w h
@ -264,16 +262,10 @@ im_t <-> im_b
horiz_cat :: [Image] -> Image
horiz_cat = foldr (<|>) EmptyImage
horzcat :: [Image] -> Image
horzcat = horiz_cat
-- | Compose any number of images vertically.
vert_cat :: [Image] -> Image
vert_cat = foldr (<->) EmptyImage
vertcat :: [Image] -> Image
vertcat = vert_cat
-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in
-- the ISO-10646 encoding.
char :: Attr -> Char -> Image
@ -307,12 +299,12 @@ utf8_string !a !str = string a ( decode str )
safe_wcwidth :: Char -> Word
safe_wcwidth c = case wcwidth c of
i | i < 0 -> error "negative wcwidth"
i | i < 0 -> 0 -- error "negative wcwidth"
| otherwise -> toEnum i
safe_wcswidth :: String -> Word
safe_wcswidth str = case wcswidth str of
i | i < 0 -> error "negative wcswidth"
i | i < 0 -> 0 -- error "negative wcswidth"
| otherwise -> toEnum i
-- | Renders a UTF-8 encoded bytestring.

53
src/Graphics/Vty/LLInput.hs
View File

@ -35,7 +35,7 @@ import System.Posix.IO ( stdInput
)
-- |Representations of non-modifier keys.
data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns
data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns
| KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu
| KLeft | KDown | KRight | KEnter
deriving (Eq,Show,Ord)
@ -67,7 +67,7 @@ initTermInput escDelay terminal = do
hadInput <- newEmptyMVar
oattr <- getTerminalAttributes stdInput
let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts,
EnableEcho, ProcessInput]
EnableEcho, ProcessInput, ExtendedFunctions]
setTerminalAttributes stdInput nattr Immediately
set_term_timing
let inputToEventThread :: IO ()
@ -88,7 +88,7 @@ initTermInput escDelay terminal = do
setFdOption stdInput NonBlockingRead False
threadWaitRead stdInput
setFdOption stdInput NonBlockingRead True
try readAll
try readAll :: IO (Either IOException ())
when (escDelay == 0) finishAtomicInput
loop
readAll = do
@ -141,32 +141,60 @@ initTermInput escDelay terminal = do
caps_tabls = [("khome", (KHome, [])),
("kend", (KEnd, [])),
("cbt", (KBackTab, [])),
("kcud1", (KDown, [])),
("kcuu1", (KUp, [])),
("kcuf1", (KRight, [])),
("kcub1", (KLeft, [])),
("kcud1", (KDown, [])),
("kcuu1", (KUp, [])),
("kcuf1", (KRight, [])),
("kcub1", (KLeft, []))
("kLFT", (KLeft, [MShift])),
("kRIT", (KRight, [MShift]))
]
caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls]
ansi_classify_table :: [[([Char], (Key, [Modifier]))]]
ansi_classify_table =
[ let k c s = ("\ESC["++c,(s,[])) in
[ k "G" KNP5, k "P" KPause ],
[ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5, k "P" KPause, k "A" KUp, k "B" KDown, k "C" KRight, k "D" KLeft ],
-- Support for arrows
[("\ESC[" ++ charCnt ++ show mc++c,(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
(c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft)] -- directions and their codes
],
let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [2::Int,3,5,6] [KIns,KDel,KPageUp,KPageDown],
-- Support for simple characters.
[ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],
-- Support for function keys (should use terminfo)
[ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ],
let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in
concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ],
[ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ],
-- Ctrl+Char
[ ([toEnum x],(KASCII y,[MCtrl]))
| (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),
y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
],
-- Ctrl+Meta+Char
[ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],
[ ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])) , ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),
("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] ]
-- Special support
[ -- special support for ESC
("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])),
-- Special support for backspace
("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),
-- Special support for Enter
("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ]
]
eventThreadId <- forkIO $ inputToEventThread
inputThreadId <- forkIO $ inputThread
@ -184,9 +212,10 @@ initTermInput escDelay terminal = do
setTerminalAttributes stdInput oattr Immediately
return (readChan eventChannel, uninit)
first :: (a -> b) -> (a,c) -> (b,c)
first f (x,y) = (f x, y)
utf8Length :: (Num t, Ord a, Num a) => a -> t
utf8Length c
| c < 0x80 = 1
| c < 0xE0 = 2

3
src/Graphics/Vty/Picture.hs
View File

@ -1,13 +1,12 @@
-- Copyright 2009 Corey O'Connor
module Graphics.Vty.Picture ( module Graphics.Vty.Picture
, Image
, image_width
, image_height
, (<|>)
, (<->)
, horiz_cat
, vert_cat
, horzcat
, vertcat
, background_fill
, char
, string

23
src/Graphics/Vty/Span.hs
View File

@ -221,26 +221,3 @@ snoc_op !mrow_ops !row !op = do
writeSTArray mrow_ops row ops'
return ()
data StateTransition =
NextSpan BuildState
| NextRow BuildState
deriving Show
data BuildState = BuildState
{ current_column :: !Word
, current_row_build_ops :: [BuildOp]
, next_row_build_ops :: [BuildOp]
}
deriving Show
-- A build op is a (column, row) offset into an image and the image.
data BuildOp = BuildOp !Word !Word Image
deriving Show
initial_state :: Image -> BuildState
initial_state i = BuildState 0 [BuildOp 0 0 i] []
-- The first op for each row is to the set the current attribute. Which will either be
-- 0. the background attribute if the span starts out with the background or is undefined.
-- 1. the attributes of the first text row.

1
src/Graphics/Vty/Terminal.hs
View File

@ -13,7 +13,6 @@
--
--
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal
, Terminal(..)
, TerminalHandle(..)

4
src/Graphics/Vty/Terminal/Debug.hs
View File

@ -103,10 +103,10 @@ instance DisplayTerminal DebugDisplay where
return $ ptr `plusPtr` 1
-- | An attr change is always visualized as the single character 'A'
attr_required_bytes _d _fattr _attr = 1
attr_required_bytes _d _fattr _diffs _attr = 1
-- | An attr change is always visualized as the single character 'A'
serialize_set_attr _d _fattr _attr ptr = do
serialize_set_attr _d _fattr _diffs _attr ptr = do
liftIO $ poke ptr (toEnum $ fromEnum 'A')
return $ ptr `plusPtr` 1

2
src/Graphics/Vty/Terminal/Generic.hs
View File

@ -1,7 +1,7 @@
-- Copyright 2009 Corey O'Connor
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ExistentialQuantification #-}
-- Copyright 2009 Corey O'Connor
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
module Graphics.Vty.Terminal.Generic ( module Graphics.Vty.Terminal.Generic

15
src/Graphics/Vty/Terminal/MacOSX.hs
View File

@ -24,6 +24,7 @@ import System.IO
data Term = Term
{ super_term :: TerminalHandle
, term_app :: String
}
-- for Terminal.app use "xterm". For iTerm.app use "xterm-256color"
@ -32,7 +33,7 @@ terminal_instance v = do
let base_term "iTerm.app" = "xterm-256color"
base_term _ = "xterm"
t <- TerminfoBased.terminal_instance (base_term v) >>= new_terminal_handle
return $ Term t
return $ Term t v
flushed_put :: MonadIO m => String -> m ()
flushed_put str = do
@ -40,19 +41,25 @@ flushed_put str = do
liftIO $ hFlush stdout
-- Terminal.app really does want the xterm-color smcup and rmcup caps. Not the generic xterm ones.
smcup_str, rmcup_str :: String
smcup_str = "\ESC7\ESC[?47h"
rmcup_str = "\ESC[2J\ESC[?47l\ESC8"
-- iTerm needs a clear screen after smcup as well?
clear_screen_str :: String
clear_screen_str = "\ESC[H\ESC[2J"
instance Terminal Term where
terminal_ID t = "Terminal.app :: MacOSX"
terminal_ID t = term_app t ++ " :: MacOSX"
release_terminal t = do
release_terminal $ super_term t
reserve_display t = do
reserve_display _t = do
flushed_put smcup_str
flushed_put clear_screen_str
release_display t = do
release_display _t = do
flushed_put rmcup_str
display_terminal_instance t b c = do

123
src/Graphics/Vty/Terminal/TerminfoBased.hs
View File

@ -1,9 +1,7 @@
-- Copyright 2009 Corey O'Connor
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance
)
where
@ -21,8 +19,7 @@ import Control.Monad ( foldM )
import Control.Monad.Trans
import Data.Bits ( (.&.) )
import Data.Maybe ( fromJust )
import Data.Monoid
import Data.Maybe ( isJust, isNothing, fromJust )
import Data.Word
import Foreign.C.Types ( CLong )
@ -124,7 +121,9 @@ current_display_attr_caps ti
instance Terminal Term where
terminal_ID t = term_info_ID t ++ " :: TerminfoBased"
release_terminal _t = do
release_terminal t = do
marshall_cap_to_terminal t set_default_attr []
marshall_cap_to_terminal t cnorm []
return ()
reserve_display t = do
@ -132,6 +131,8 @@ instance Terminal Term where
then marshall_cap_to_terminal t (fromJust . smcup) []
else return ()
-- Screen on OS X does not appear to support smcup?
-- To approximate the expected behavior: clear the screen and then move the mouse to the
-- home position.
marshall_cap_to_terminal t clear_screen []
return ()
@ -319,30 +320,12 @@ ansi_color_index (Color240 v) = 16 + ( toEnum $ fromEnum v )
- 4. If the display attribute state is being set then just update the arguments to that for any
- apply/remove.
-
- The style diffs each imply either the enter/exit control code or a reset to defaults ; set state
- sequence. This mapping satisfies the communitive monoid properties:
- - no diff * diff == diff
- - diff * no diff == diff
- - (diff_0 * diff_1) * diff_2 == diff_0 * ( diff_1 * diff_2 )
- - diff_0 * diff_1 == diff_1 * diff_0
- so the mapping is a sequence of mappend's applied to mempty. Where the monoid points appended
- depend on the diff. The accumulated value is the monad point that represents the final sequence
- to apply. The application (*) operator assures all the rules are followed.
-
- The diff implies an enter/exit control code if:
- - The current
-}
data DisplayAttrSeq v
= EnterExitSeq [v]
data DisplayAttrSeq
= EnterExitSeq [CapExpression]
| SetState DisplayAttrState
instance Monoid (DisplayAttrSeq v) where
mempty = EnterExitSeq []
SetState s `mappend` _ = SetState s
_ `mappend` SetState s = SetState s
(EnterExitSeq caps_0) `mappend` (EnterExitSeq caps_1) = EnterExitSeq (caps_0 `mappend` caps_1)
data DisplayAttrState = DisplayAttrState
{ apply_standout :: Bool
, apply_underline :: Bool
@ -365,59 +348,41 @@ sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)
, False -- alt char set
]
req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq CapExpression
req_display_cap_seq_for caps s diffs =
-- First pass: concat the monoid points that are implied by the diffs
let base = mconcat $ map diff_point diffs
-- Second pass: Apply the capability restrictions.
in apply_caps base
where
set_state = SetState $ state_for_style s
diff_point ApplyStandout = EnterExitSeq [ApplyStandout]
diff_point ApplyUnderline = EnterExitSeq [ApplyUnderline]
diff_point ApplyReverseVideo = EnterExitSeq [ApplyReverseVideo]
diff_point ApplyBlink = set_state
diff_point ApplyDim = EnterExitSeq [ApplyDim]
diff_point ApplyBold = EnterExitSeq [ApplyBold]
diff_point RemoveStandout = EnterExitSeq [RemoveStandout]
diff_point RemoveUnderline = EnterExitSeq [RemoveUnderline]
diff_point RemoveReverseVideo = set_state
diff_point RemoveBlink = set_state
diff_point RemoveDim = set_state
diff_point RemoveBold = set_state
apply_caps ( SetState _ )
= case set_attr_states caps of
Nothing -> EnterExitSeq []
Just _ -> set_state
apply_caps (EnterExitSeq [])
= EnterExitSeq []
apply_caps (EnterExitSeq (diff : diffs'))
= case apply_caps' diff of
SetState _ -> set_state
p -> p `mappend` apply_caps (EnterExitSeq diffs')
apply_caps' ApplyStandout = m $ enter_standout caps
apply_caps' ApplyUnderline = m $ enter_underline caps
apply_caps' ApplyReverseVideo = m $ enter_reverse_video caps
apply_caps' ApplyBlink = set_state
apply_caps' ApplyDim = m $ enter_dim_mode caps
apply_caps' ApplyBold = m $ enter_bold_mode caps
apply_caps' RemoveStandout = m $ exit_standout caps
apply_caps' RemoveUnderline = m $ exit_underline caps
apply_caps' RemoveReverseVideo = set_state
apply_caps' RemoveBlink = set_state
apply_caps' RemoveDim = set_state
apply_caps' RemoveBold = set_state
m = maybe set_state (EnterExitSeq . return)
{-
set_style_required_bytes caps style diffs reset_cap =
let state = state_for_style style
req_seq = req_seq_for caps style diffs
in case req_seq of
EnterExitSeq caps -> sum $ map (\cap -> cap_expression_required_bytes cap []) caps
SetState -> cap_expression_required_bytes ( fromJust $ set_attr_states $ caps )
( sgr_args_for_state state )
-}
req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
req_display_cap_seq_for caps s diffs
-- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
-- then either the state needs to be set or the attribute change ignored.
= case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of
-- If all the diffs have an enter-exit cap then just use those
( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs
-- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
-- all unsupported diffs and just apply the rest
( True, False ) -> EnterExitSeq $ map enter_exit_cap
$ filter (not . no_enter_exit_cap) diffs
-- if not all the diffs have an enter-exit can and there is a set state cap then just use
-- the set state cap.
( True, True ) -> SetState $ state_for_style s
where
no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps
no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps
no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps
no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps
no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps
no_enter_exit_cap RemoveReverseVideo = True
no_enter_exit_cap ApplyBlink = True
no_enter_exit_cap RemoveBlink = True
no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps
no_enter_exit_cap RemoveDim = True
no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps
no_enter_exit_cap RemoveBold = True
enter_exit_cap ApplyStandout = fromJust $ enter_standout caps
enter_exit_cap RemoveStandout = fromJust $ exit_standout caps
enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps
enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps
enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps
enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps
enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps
enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."
state_for_style :: Style -> DisplayAttrState
state_for_style s = DisplayAttrState
@ -431,7 +396,7 @@ state_for_style s = DisplayAttrState
where is_style_set = has_style s
style_to_apply_seq :: Style -> [StyleStateChange]
style_to_apply_seq s = mconcat
style_to_apply_seq s = concat
[ apply_if_required ApplyStandout standout
, apply_if_required ApplyUnderline underline
, apply_if_required ApplyReverseVideo reverse_video

2
test/Makefile
View File

@ -23,6 +23,8 @@ yi_issue_264 \
vty_issue_18 \
$(VERIF_TESTS)
$(shell mkdir -p objects )
# TODO: Tests should also be buildable referencing the currently installed vty
GHC_ARGS=--make -i../src -package parallel-1.1.0.1 -hide-package transformers -hide-package monads-fd -hide-package monads-tf -package QuickCheck-2.1.0.2 -ignore-package vty ../cbits/gwinsz.c ../cbits/set_term_timing.c ../cbits/mk_wcwidth.c -O -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr -odir objects -hidir objects

1
test/Test2.hs
View File

@ -6,6 +6,7 @@ main = do
(sx,sy) <- getSize vty
update vty (pic { pImage = renderFill (setBG red attr) 'X' sx sy })
refresh vty
getEvent vty
shutdown vty
putStrLn "Done!"
return ()

6
test/Verify.hs
View File

@ -51,8 +51,10 @@ run_test t = do
results <- readIORef $ results_ref s'
let fail_results = [ fail_result | fail_result@(QC.Failure {}) <- results ]
case fail_results of
[] -> putStrLn "PASS"
_ -> putStrLn "FAIL"
[] -> putStrLn "state: PASS"
rs -> do
putStrLn "state: FAIL"
putStrLn $ "fail_count: " ++ show (length rs)
verify :: Testable prop => String -> prop -> Test QC.Result
verify prop_name prop = do

4
test/Verify/Graphics/Vty/DisplayRegion.hs
View File

@ -21,7 +21,7 @@ instance Show EmptyWindow where
instance Arbitrary DebugWindow where
arbitrary = do
w <- arbitrary
h <- arbitrary
w <- suchThat arbitrary (/= 0)
h <- suchThat arbitrary (/= 0)
return $ DebugWindow w h

26
test/Verify/Graphics/Vty/Image.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image
, module Graphics.Vty.Image
)
@ -33,7 +35,12 @@ instance Arbitrary DefaultImage where
i <- return $ char def_attr 'X' -- elements forward_image_ops >>= return . (\op -> op empty_image)
return $ DefaultImage i []
data SingleRowSingleAttrImage = SingleRowSingleAttrImage Attr Word Image
data SingleRowSingleAttrImage
= SingleRowSingleAttrImage
{ expected_attr :: Attr
, expected_columns :: Word
, row_image :: Image
}
instance Show SingleRowSingleAttrImage where
show (SingleRowSingleAttrImage attr columns image)
@ -41,13 +48,28 @@ instance Show SingleRowSingleAttrImage where
instance Arbitrary SingleRowSingleAttrImage where
arbitrary = do
single_column_row_text <- arbitrary
-- The text must contain at least one character. Otherwise the image simplifies to the
-- IdImage which has a height of 0. If this is to represent a single row then the height
-- must be 1
single_column_row_text <- listOf1 arbitrary
attr <- arbitrary
return $ SingleRowSingleAttrImage
attr
( fromIntegral $ length single_column_row_text )
( horiz_cat $ [ char attr c | SingleColumnChar c <- single_column_row_text ] )
data SingleRowTwoAttrImage
= SingleRowTwoAttrImage
{ part_0 :: SingleRowSingleAttrImage
, part_1 :: SingleRowSingleAttrImage
, join_image :: Image
} deriving Show
instance Arbitrary SingleRowTwoAttrImage where
arbitrary = do
p0 <- arbitrary
p1 <- arbitrary
return $ SingleRowTwoAttrImage p0 p1 (row_image p0 <|> row_image p1)
data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack
{ stack_image :: Image

75
test/interactive_terminal_test.hs
View File

@ -32,7 +32,7 @@ print_intro = do
putStr $ [$heredoc|
This is an interactive verification program for the terminal input and output
support of the VTY library. This will ask a series of questions about what you
see onscreen. The goal is to verify that VTY's output and input support
see on screen. The goal is to verify that VTY's output and input support
performs as expected with your terminal.
This program produces a file named
@ -43,7 +43,7 @@ support for your terminal. No personal information is contained in the report.
Each test follows, more or less, the following format:
0. A description of the test is printed which will include a detailed
description of what VTY is going to try and what the expected results are.
description of what VTY is going to try and what the expected results are.
Press return to move on.
1. The program will produce some output or ask for you to press a key.
2. You will then be asked to confirm if the behavior matched the provided
@ -62,15 +62,24 @@ All the tests assume the following about the terminal display:
a good range of the unicode characters. Each test involving unicode display
describes the expected appearance of each glyph.
Thanks for the help! :-D
Thanks for the help! :-D
To exit the test early enter "q" anytime at the following menu screen. Even if
you exit the test early please email the test_results.list file to
coreyoconnor@gmail.com. The results file will still contain information useful
to debug terminal support.
|]
wait_for_return
results <- do_test_menu 1
env_attributes <- mapM ( \env_name -> catch ( Env.getEnv env_name >>= return . (,) env_name )
( const $ return (env_name, "") )
)
[ "TERM", "COLORTERM", "LANG" ]
let results_txt = show env_attributes ++ "\n" ++ show results ++ "\n"
[ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
t <- terminal_handle
let results_txt = show env_attributes ++ "\n"
++ terminal_ID t ++ "\n"
++ show results ++ "\n"
release_terminal t
writeFile output_file_path results_txt
wait_for_return = do
@ -179,11 +188,11 @@ reserve_output_test = Test
, print_summary = do
putStr $ [$heredoc|
Once return is pressed:
The screen will be cleared.
The cursor should be visible and at the top left corner.
Four lines of text should be visible.
0. The screen will be cleared.
1. Four lines of text should be visible.
1. The cursor should be visible and at the start of the fifth line.
After enter is pressed for the second time this test then:
After return is pressed for the second time this test then:
* The screen containing the test summary should be restored;
* The cursor is visible.
|]
@ -377,6 +386,7 @@ unicode_single_width_0 = Test
, test_action = do
t <- terminal_handle
reserve_display t
hide_cursor t
withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout)
hPutStr stdout "\n"
hPutStr stdout "0123456789\n"
@ -458,6 +468,7 @@ unicode_double_width_0 = Test
, test_action = do
t <- terminal_handle
reserve_display t
hide_cursor t
withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout)
hPutStr stdout "\n"
hPutStr stdout "012345\n"
@ -517,8 +528,12 @@ After return is pressed for the second time:
1. The cursor should be visible.
|]
all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white, def ]
[ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white", "default" ]
all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
[ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
all_bright_colors
= zip [ bright_black, bright_red, bright_green, bright_yellow, bright_blue, bright_magenta, bright_cyan, bright_white ]
[ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
attributes_test_0 = Test
{ test_name = "Character attributes: foreground colors."
@ -531,7 +546,7 @@ attributes_test_0 = Test
column_0 = vert_cat $ map line_with_color all_colors
border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
column_1 = vert_cat $ map (string def_attr . snd) all_colors
line_with_color (c_value, c_name) = string (setFG c_value def_attr) c_name
line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name
d <- display_bounds t >>= display_context t
output_picture d pic
getLine
@ -577,7 +592,7 @@ attributes_test_1 = Test
column_0 = vert_cat $ map line_with_color all_colors
border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
column_1 = vert_cat $ map (string def_attr . snd) all_colors
line_with_color (c_value, c_name) = string (setBG c_value def_attr) c_name
line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name
d <- display_bounds t >>= display_context t
output_picture d pic
getLine
@ -592,7 +607,7 @@ Once return is pressed:
2. 9 lines of text in two columns will be drawn. The first column will
contain be a name of a standard color for an 8 color terminal rendered with
the default foreground color with a background the named color. For
instance, one line will contain be the word "magenta" and that words should
instance, one line will contain be the word "magenta" and the word should
be rendered in the default foreground color over a magenta background. The
second column will be the name of a standard color rendered with the default
attributes.
@ -631,10 +646,10 @@ attributes_test_2 = Test
image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
column_0 = vert_cat $ map line_with_color_0 all_colors
column_1 = vert_cat $ map line_with_color_1 all_colors
column_1 = vert_cat $ map line_with_color_1 all_bright_colors
column_2 = vert_cat $ map (string def_attr . snd) all_colors
line_with_color_0 (c_value, c_name) = string (setFG c_value def_attr) c_name
line_with_color_1 (c_value, c_name) = string (setFGVivid c_value def_attr) c_name
line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name
line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name
d <- display_bounds t >>= display_context t
output_picture d pic
getLine
@ -681,7 +696,7 @@ Did the test output match the description?
}
attributes_test_3 = Test
{ test_name = "Character attributes: vivid background colors."
{ test_name = "Character attributes: Vivid background colors."
, test_ID = "attributes_test_3"
, test_action = do
t <- terminal_handle
@ -690,10 +705,10 @@ attributes_test_3 = Test
image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
column_0 = vert_cat $ map line_with_color_0 all_colors
column_1 = vert_cat $ map line_with_color_1 all_colors
column_1 = vert_cat $ map line_with_color_1 all_bright_colors
column_2 = vert_cat $ map (string def_attr . snd) all_colors
line_with_color_0 (c_value, c_name) = string (setBG c_value def_attr) c_name
line_with_color_1 (c_value, c_name) = string (setBGVivid c_value def_attr) c_name
line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name
line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name
d <- display_bounds t >>= display_context t
output_picture d pic
getLine
@ -715,7 +730,7 @@ Once return is pressed:
c. The third column will be the name of a standard color rendered with
the default attributes.
For instance, one line will contain be the word "magenta" and that words should
For instance, one line will contain be the word "magenta" and the word should
be rendered in the default foreground color over a magenta background.
I'm not actually sure exactly what "vivid" means in this context. For xterm the
@ -748,14 +763,14 @@ Did the test output match the description?
}
attr_combos =
[ ("default", id)
, ("bold", setBold)
, ("blink", setBlink)
, ("underline", setUnderline)
, ("bold + blink", setBlink . setBold)
, ("bold + underline", setUnderline . setBold)
, ("underline + blink", setBlink . setUnderline)
, ("bold + blink + underline", setUnderline . setBlink . setBold)
[ ( "default", id )
, ( "bold", flip with_style bold )
, ( "blink", flip with_style blink )
, ( "underline", flip with_style underline )
, ( "bold + blink", flip with_style (bold + blink) )
, ( "bold + underline", flip with_style (bold + underline) )
, ( "underline + blink", flip with_style (underline + blink) )
, ( "bold + blink + underline", flip with_style (bold + blink + underline) )
]
attributes_test_4 = Test

31
test/make_tests.sh
View File

@ -1,31 +0,0 @@
#!/bin/bash
set -e
GHC_ARGS='--make -i../src -ignore-package vty ../cbits/gwinsz.c ../cbits/set_term_timing.c -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr'
rm -f Bench.o Bench.hi Bench
ghc $GHC_ARGS '-prof' '-auto-all' Bench.hs
rm -f Bench2.o Bench2.hi Bench2
ghc $GHC_ARGS '-prof' '-auto-all' Bench2.hs
rm -f BenchRenderChar.o BenchRenderChar.hi BenchRenderChar
ghc $GHC_ARGS '-prof' '-auto-all' BenchRenderChar
rm -f Test.o Test.hi Test
ghc $GHC_ARGS Test
rm -f Test2.o Test2.hi Test2
ghc $GHC_ARGS Test2
rm -f BenchmarkImageOps.hi BenchmarkImageOps.o BenchmarkImageOps
ghc $GHC_ARGS BenchmarkImageOps
rm -f ControlTable.hi ControlTable.o ControlTable
ghc $GHC_ARGS ControlTable
rm -f yi_issue_264.hi yi_issue_264.o yi_issue_264
ghc $GHC_ARGS yi_issue_264
rm -f vty_issue_18.hi vty_issue_18.o vty_issue_18
ghc $GHC_ARGS vty_issue_18

69
test/verify_image_ops.hs
View File

@ -1,9 +1,12 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Graphics.Vty.Attributes
import Graphics.Vty.Image
import Verify.Graphics.Vty.Image
import Verify
import Data.Word
two_sw_horiz_concat :: SingleColumnChar -> SingleColumnChar -> Bool
two_sw_horiz_concat (SingleColumnChar c1) (SingleColumnChar c2) =
image_width (char def_attr c1 <|> char def_attr c2) == 2
@ -44,6 +47,64 @@ horiz_concat_dw_assoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnC
==
char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)
vert_contat_single_row :: NonEmptyList SingleRowSingleAttrImage -> Bool
vert_contat_single_row (NonEmpty stack) =
let expected_height :: Word = fromIntegral $ length stack
stack_image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack ]
in image_height stack_image == expected_height
disjoint_height_horiz_join :: NonEmptyList SingleRowSingleAttrImage
-> NonEmptyList SingleRowSingleAttrImage
-> Bool
disjoint_height_horiz_join (NonEmpty stack_0) (NonEmpty stack_1) =
let expected_height :: Word = fromIntegral $ max (length stack_0) (length stack_1)
stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
in image_height (stack_image_0 <|> stack_image_1) == expected_height
disjoint_height_horiz_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage
-> NonEmptyList SingleRowSingleAttrImage
-> Bool
disjoint_height_horiz_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =
let stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
image = stack_image_0 <|> stack_image_1
expected_height = image_height image
in case image of
HorizJoin {} -> ( expected_height == (image_height $ part_left image) )
&&
( expected_height == (image_height $ part_right image) )
_ -> True
disjoint_width_vert_join :: NonEmptyList SingleRowSingleAttrImage
-> NonEmptyList SingleRowSingleAttrImage
-> Bool
disjoint_width_vert_join (NonEmpty stack_0) (NonEmpty stack_1) =
let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)
stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
stack_0_image = vert_cat stack_0_images
stack_1_image = vert_cat stack_1_images
image = stack_0_image <-> stack_1_image
in image_width image == expected_width
disjoint_width_vert_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage
-> NonEmptyList SingleRowSingleAttrImage
-> Bool
disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =
let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)
stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]
stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]
stack_0_image = vert_cat stack_0_images
stack_1_image = vert_cat stack_1_images
image = stack_0_image <-> stack_1_image
in case image of
VertJoin {} -> ( expected_width == (image_width $ part_top image) )
&&
( expected_width == (image_width $ part_bottom image) )
_ -> True
main = run_test $ do
verify "two_sw_horiz_concat" two_sw_horiz_concat
verify "many_sw_horiz_concat" many_sw_horiz_concat
@ -53,5 +114,11 @@ main = run_test $ do
verify "two_dw_horiz_concat" two_dw_horiz_concat
verify "two_dw_vert_concat" two_dw_vert_concat
verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc
liftIO $ putStrLn $ replicate 80 '-'
verify "single row vert concats to correct height" vert_contat_single_row
verify "disjoint_height_horiz_join" disjoint_height_horiz_join
verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill
verify "disjoint_width_vert_join" disjoint_width_vert_join
verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill
return ()

13
test/verify_image_trans.hs
View File

@ -9,20 +9,21 @@ import Verify
import Data.Word
is_horiz_text_of_columns :: Image -> Word -> Bool
is_horiz_text_of_columns (HorizText { columns = in_w }) expected_w = in_w == expected_w
is_horiz_text_of_columns (HorizBlank { columns = in_w }) expected_w = in_w == expected_w
is_horiz_text_of_columns (HorizText { output_width = in_w }) expected_w = in_w == expected_w
is_horiz_text_of_columns (BGFill { output_width = in_w }) expected_w = in_w == expected_w
is_horiz_text_of_columns _image _expected_w = False
verify_horiz_contat_wo_attr_change_simplifies :: SingleRowSingleAttrImage -> Bool
verify_horiz_contat_wo_attr_change_simplifies (SingleRowSingleAttrImage _attr char_count image) =
is_horiz_text_of_columns image char_count
verify_horiz_contat_w_attr_change_simplifies :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Bool
verify_horiz_contat_w_attr_change_simplifies (SingleRowSingleAttrImage attr0 char_count0 image0)
(SingleRowSingleAttrImage attr1 char_count1 image1)
verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool
verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 image0)
(SingleRowSingleAttrImage attr1 char_count1 image1)
i
)
| char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1)
| otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1)
where i = image0 <|> image1
main = run_test $ do
verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies

12
test/vty_inline_example.hs Normal file
View File

@ -0,0 +1,12 @@
import Graphics.Vty
import Graphics.Vty.Inline
main = do
t <- terminal_handle
putStr "Not styled. "
put_attr_change t $ back_color red >> apply_style underline
putStr " Styled! "
put_attr_change t $ default_all
putStrLn "Not styled."
release_terminal t
return ()

7
test/vty_issue_18.hs
View File

@ -23,13 +23,6 @@ play vty sx sy =
getEvent vty
shutdown vty
return ()
{-
k <- getEvent vty
case k of
EvKey KEsc [] -> shutdown vty >> return ()
EvResize nx ny -> play vty nx ny
_ -> shutdown vty
-}
box :: Int -> Int -> Image
box w h =

12
test/yi_issue_264.hs Normal file
View File

@ -0,0 +1,12 @@
module Main where
import Graphics.Vty
import Control.Exception
catchLog = handle (\except -> do putStrLn $ show (except :: IOException))
main = do
vty <- mkVty
catchLog $ update vty pic { pImage = empty, pCursor = NoCursor }
catchLog $ update vty pic { pImage = empty, pCursor = NoCursor }
shutdown vty

8
vty.cabal
View File

@ -4,6 +4,7 @@ License: BSD3
License-file: LICENSE
Author: Stefan O'Rear, Corey O'Connor
Maintainer: Corey O'Connor (coreyoconnor@gmail.com)
Homepage: http://trac.haskell.org/vty/
Category: User Interfaces
Synopsis: A simple terminal access library
Description:
@ -20,11 +21,13 @@ Description:
terminal;
.
You can 'darcs get' it from <http://code.haskell.org/vty/>
.
&#169; 2006-2007 Stefan O'Rear; BSD3 license.
.
&#169; 2008-2009 Corey O'Connor; BSD3 license.
Build-Depends: base >= 4 && < 5, bytestring, containers, unix, uvector
Build-Depends: terminfo >= 0.2 && < 0.3
Build-Depends: base >= 4 && < 5, bytestring, containers, unix
Build-Depends: terminfo >= 0.3 && < 0.4
Build-Depends: utf8-string >= 0.3 && < 0.4
Build-Depends: mtl >= 1.1.0.0 && < 1.2
Build-Depends: ghc-prim, parallel < 2
@ -49,6 +52,7 @@ other-modules: Codec.Binary.UTF8.Width
Graphics.Vty.Image
Graphics.Vty.Span
Graphics.Vty.Terminal.Generic
Graphics.Vty.Terminal.MacOSX
Graphics.Vty.Terminal.XTermColor
Graphics.Vty.Terminal.TerminfoBased