adding example of Graphics.Vty.Inline to test

Ignore-this: e82f6a3b8eec33ab55fd04a51f4d9873

darcs-hash:20091228233218-f0a0d-345ddcbee616acc4f39d9d12393bdea5982f34d9.gz

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.

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).

TODO

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

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) "" ++ ")"
+    -- putStr $ "wcwidth(0x" ++ showHex (fromEnum wc) "" ++ ")"
-    w <- wcwidth' wc  >>= return . fromIntegral
+    let !w = fromIntegral $! wcwidth' wc
-    putStrLn $ " -> " ++ show w
+    -- 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

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
+            c_total <- if v /= 0
-                            then cap_ops_required_bytes true_ops
+                        then cap_ops_required_bytes true_ops
-                            else cap_ops_required_bytes false_ops
+                        else do
-            return $ in_c + c_branch
+                            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_0 <- pop
     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
+                        else do
-            return ptr'
+                            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_0 <- pop
     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
 

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
+arith_op_parser 
-    char '+'
+    =   plus_op 
-    inc_offset 1
+    <|> minus_op 
-    return $ BuildResults 0 [ ArithPlus ] [ ]
+    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

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. 
       -- 
-      -- 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. 
+      -- | Refresh the display. Normally the library takes care of refreshing.  Nonetheless, some
-      -- Nonetheless, some other program might output to the terminal and mess the display.
+      -- other program might output to the terminal and mess the display.  In that case the user
-      -- In that case the user might want to force a refresh.
+      -- 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

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 

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
+    -- required to be between two images of equal height. The horiz_join constructor adds background
-    -- the provided images that assure this is true for the HorizJoin value produced.
+    -- 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
+    -- required to be between two images of equal width. The vert_join constructor adds background
-    -- the provides images that assure this is true for the HorizJoin value produced.
+    -- 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. 

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,  [])),
+                    ("cbt",   (KBackTab, [])),
+                    ("kcud1", (KDown,  [])),
+                    ("kcuu1", (KUp,  [])),
+                    ("kcuf1", (KRight,  [])),
+                    ("kcub1", (KLeft,  [])),
 
-                    ("kcud1",  (KDown,  [])),
+                    ("kLFT", (KLeft, [MShift])),
-                    ("kcuu1",  (KUp,  [])),
+                    ("kRIT", (KRight, [MShift]))
-                    ("kcuf1",  (KRight,  [])),
-                    ("kcub1",  (KLeft,  []))
                    ]
    
       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
+         [ 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 ],
-           [ k "G" KNP5, k "P" KPause ],
+
+           -- 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

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

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.
-

src/Graphics/Vty/Terminal.hs

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

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
 

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

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

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.Maybe ( isJust, isNothing, fromJust )
-import Data.Monoid 
 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
+data DisplayAttrSeq
-    = EnterExitSeq [v]
+    = 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 :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq
-req_display_cap_seq_for caps s diffs =
+req_display_cap_seq_for caps s diffs
-    -- First pass: concat the monoid points that are implied by the diffs
+    -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap
-    let base = mconcat $ map diff_point diffs
+    -- then either the state needs to be set or the attribute change ignored.
-    -- Second pass: Apply the capability restrictions. 
+    = case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of
-    in apply_caps base
+        -- If all the diffs have an enter-exit cap then just use those
-    where 
+        ( False, _    ) -> EnterExitSeq $ map enter_exit_cap diffs
-        set_state = SetState $ state_for_style s
+        -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
-        diff_point ApplyStandout = EnterExitSeq [ApplyStandout]
+        -- all unsupported diffs and just apply the rest
-        diff_point ApplyUnderline = EnterExitSeq [ApplyUnderline] 
+        ( True, False ) -> EnterExitSeq $ map enter_exit_cap 
-        diff_point ApplyReverseVideo = EnterExitSeq [ApplyReverseVideo]
+                                        $ filter (not . no_enter_exit_cap) diffs
-        diff_point ApplyBlink = set_state
+        -- if not all the diffs have an enter-exit can and there is a set state cap then just use
-        diff_point ApplyDim = EnterExitSeq [ApplyDim]
+        -- the set state cap.
-        diff_point ApplyBold = EnterExitSeq [ApplyBold]
+        ( True, True  ) -> SetState $ state_for_style s
-        diff_point RemoveStandout = EnterExitSeq [RemoveStandout]
+    where
-        diff_point RemoveUnderline = EnterExitSeq [RemoveUnderline]
+        no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps
-        diff_point RemoveReverseVideo = set_state
+        no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps
-        diff_point RemoveBlink = set_state
+        no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps
-        diff_point RemoveDim = set_state
+        no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps
-        diff_point RemoveBold = set_state
+        no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps
-        apply_caps ( SetState _ )
+        no_enter_exit_cap RemoveReverseVideo = True
-            = case set_attr_states caps of
+        no_enter_exit_cap ApplyBlink = True
-                Nothing -> EnterExitSeq []
+        no_enter_exit_cap RemoveBlink = True
-                Just _ -> set_state
+        no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps
-        apply_caps (EnterExitSeq []) 
+        no_enter_exit_cap RemoveDim = True
-            = EnterExitSeq []
+        no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps
-        apply_caps (EnterExitSeq (diff : diffs'))
+        no_enter_exit_cap RemoveBold = True
-            = case apply_caps' diff of
+        enter_exit_cap ApplyStandout = fromJust $ enter_standout caps
-                SetState _ -> set_state
+        enter_exit_cap RemoveStandout = fromJust $ exit_standout caps
-                p          -> p `mappend` apply_caps (EnterExitSeq diffs')
+        enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps
-        apply_caps' ApplyStandout = m $ enter_standout caps
+        enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps
-        apply_caps' ApplyUnderline = m $ enter_underline caps
+        enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps
-        apply_caps' ApplyReverseVideo = m $ enter_reverse_video caps
+        enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps
-        apply_caps' ApplyBlink = set_state
+        enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps
-        apply_caps' ApplyDim = m $ enter_dim_mode caps
+        enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."
-        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 )
--}
 
 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

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
 

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 ()

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 "state: PASS"
-        _  -> putStrLn "FAIL"
+        rs  -> do
+            putStrLn "state: FAIL"
+            putStrLn $ "fail_count: " ++ show (length rs)
 
 verify :: Testable prop => String -> prop -> Test QC.Result
 verify prop_name prop = do

test/Verify/Graphics/Vty/DisplayRegion.hs

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

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 

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" ]
+                           [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
-    let results_txt = show env_attributes ++ "\n" ++ show results ++ "\n"
+    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. 
+    0. The screen will be cleared. 
-The cursor should be visible and at the top left corner.
+    1. Four lines of text should be visible.
-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 ]
+all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
-                 [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white", "default" ]
+                 [ "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_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name
-            line_with_color_1 (c_value, c_name) = string (setFGVivid c_value def_attr) 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_0 (c, c_name) = string (def_attr `with_back_color` c) c_name
-            line_with_color_1 (c_value, c_name) = string (setBGVivid c_value def_attr) 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)
+    [ ( "default", id )
-    , ("bold", setBold)
+    , ( "bold", flip with_style bold )
-    , ("blink", setBlink)
+    , ( "blink", flip with_style blink )
-    , ("underline", setUnderline)
+    , ( "underline", flip with_style underline )
-    , ("bold + blink", setBlink . setBold)
+    , ( "bold + blink", flip with_style (bold + blink) )
-    , ("bold + underline", setUnderline . setBold)
+    , ( "bold + underline", flip with_style (bold + underline) )
-    , ("underline + blink", setBlink . setUnderline)
+    , ( "underline + blink", flip with_style (underline + blink) )
-    , ("bold + blink + underline", setUnderline . setBlink . setBold)
+    , ( "bold + blink + underline", flip with_style (bold + blink + underline) )
     ]
 
 attributes_test_4 = Test 

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
-

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 ()
 

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 (HorizText { output_width = 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 (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 :: SingleRowTwoAttrImage -> Bool
-verify_horiz_contat_w_attr_change_simplifies (SingleRowSingleAttrImage attr0 char_count0 image0) 
+verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 image0)
-                                             (SingleRowSingleAttrImage attr1 char_count1 image1) 
+                                                                     (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

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 ()

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 =

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
+

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:       base >= 4 && < 5, bytestring, containers, unix
-Build-Depends:       terminfo >= 0.2 && < 0.3
+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