Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

adding example of Graphics.Vty.Inline to test

Ignore-this: e82f6a3b8eec33ab55fd04a51f4d9873

darcs-hash:20091228233218-f0a0d-345ddcbee616acc4f39d9d12393bdea5982f34d9.gz
  • Loading branch information...
commit f6c3cbfa01909a61d0a64c080f842d3f3fb1920f 1 parent 3360a49
@coreyoconnor authored
Showing with 446 additions and 285 deletions.
  1. +26 −0 CHANGELOG
  2. +32 −0 DESIGN
  3. +14 −12 TODO
  4. +16 −8 src/Codec/Binary/UTF8/Width.hs
  5. +41 −23 src/Data/Terminfo/Eval.hs
  6. +13 −5 src/Data/Terminfo/Parse.hs
  7. +12 −12 src/Graphics/Vty.hs
  8. +1 −2  src/Graphics/Vty/Debug.hs
  9. +7 −15 src/Graphics/Vty/Image.hs
  10. +42 −13 src/Graphics/Vty/LLInput.hs
  11. +1 −2  src/Graphics/Vty/Picture.hs
  12. +0 −23 src/Graphics/Vty/Span.hs
  13. +0 −1  src/Graphics/Vty/Terminal.hs
  14. +2 −2 src/Graphics/Vty/Terminal/Debug.hs
  15. +1 −1  src/Graphics/Vty/Terminal/Generic.hs
  16. +11 −4 src/Graphics/Vty/Terminal/MacOSX.hs
  17. +44 −79 src/Graphics/Vty/Terminal/TerminfoBased.hs
  18. +2 −0  test/Makefile
  19. +1 −0  test/Test2.hs
  20. +4 −2 test/Verify.hs
  21. +2 −2 test/Verify/Graphics/Vty/DisplayRegion.hs
  22. +24 −2 test/Verify/Graphics/Vty/Image.hs
  23. +45 −30 test/interactive_terminal_test.hs
  24. +0 −31 test/make_tests.sh
  25. +68 −1 test/verify_image_ops.hs
  26. +7 −6 test/verify_image_trans.hs
  27. +12 −0 test/vty_inline_example.hs
  28. +0 −7 test/vty_issue_18.hs
  29. +12 −0 test/yi_issue_264.hs
  30. +6 −2 vty.cabal
View
26 CHANGELOG
@@ -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.
View
32 DESIGN
@@ -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).
View
26 TODO
@@ -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?
View
24 src/Codec/Binary/UTF8/Width.hs
@@ -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
View
64 src/Data/Terminfo/Eval.hs
@@ -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
+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
+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
View
18 src/Data/Terminfo/Parse.hs
@@ -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
View
24 src/Graphics/Vty.hs
@@ -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.
+ --
+ -- todo: provide a similar abstraction to Graphics.Vty.Terminal for input. Use haskeline's
+ -- input backend for implementation.
--
- -- This version currently supports the same interface.
+ -- 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
View
3  src/Graphics/Vty/Debug.hs
@@ -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
View
22 src/Graphics/Vty/Image.hs
@@ -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.
View
55 src/Graphics/Vty/LLInput.hs
@@ -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, [])),
-
- ("kcud1", (KDown, [])),
- ("kcuu1", (KUp, [])),
- ("kcuf1", (KRight, [])),
- ("kcub1", (KLeft, []))
+ ("cbt", (KBackTab, [])),
+ ("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
View
3  src/Graphics/Vty/Picture.hs
@@ -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
View
23 src/Graphics/Vty/Span.hs
@@ -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.
-
View
1  src/Graphics/Vty/Terminal.hs
@@ -13,7 +13,6 @@
--
--
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE GADTs #-}
module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal
, Terminal(..)
, TerminalHandle(..)
View
4 src/Graphics/Vty/Terminal/Debug.hs
@@ -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
View
2  src/Graphics/Vty/Terminal/Generic.hs
@@ -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
View
15 src/Graphics/Vty/Terminal/MacOSX.hs
@@ -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
View
123 src/Graphics/Vty/Terminal/TerminfoBased.hs
@@ -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
View
2  test/Makefile
@@ -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
View
1  test/Test2.hs
@@ -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 ()
View
6 test/Verify.hs
@@ -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
View
4 test/Verify/Graphics/Vty/DisplayRegion.hs
@@ -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
View
26 test/Verify/Graphics/Vty/Image.hs
@@ -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
View
75 test/interactive_terminal_test.hs
@@ -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
View
31 test/make_tests.sh
@@ -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
-
View
69 test/verify_image_ops.hs
@@ -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 ()
View
13 test/verify_image_trans.hs
@@ -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
View
12 test/vty_inline_example.hs
@@ -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 ()
View
7 test/vty_issue_18.hs
@@ -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 =
View
12 test/yi_issue_264.hs
@@ -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
+
View
8 vty.cabal
@@ -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
Please sign in to comment.
Something went wrong with that request. Please try again.