vty 4.2.1.0 → 4.4.0.0
raw patch · 34 files changed
+531/−275 lines, 34 filesdep +deepseqdep ~parallel
Dependencies added: deepseq
Dependency ranges changed: parallel
Files
- cbits/output_buffer.c +18/−0
- cbits/output_buffer.h +5/−0
- src/Codec/Binary/UTF8/Width.hs +0/−1
- src/Data/Marshalling.hs +0/−1
- src/Data/Terminfo/Eval.hs +41/−37
- src/Data/Terminfo/Parse.hs +76/−55
- src/Graphics/Vty.hs +23/−8
- src/Graphics/Vty/Attributes.hs +1/−1
- src/Graphics/Vty/Debug.hs +1/−1
- src/Graphics/Vty/DisplayAttributes.hs +2/−0
- src/Graphics/Vty/Image.hs +4/−3
- src/Graphics/Vty/Inline.hs +48/−4
- src/Graphics/Vty/LLInput.hs +20/−11
- src/Graphics/Vty/Picture.hs +1/−1
- src/Graphics/Vty/Span.hs +2/−4
- src/Graphics/Vty/Terminal.hs +24/−16
- src/Graphics/Vty/Terminal/Debug.hs +5/−1
- src/Graphics/Vty/Terminal/Generic.hs +16/−9
- src/Graphics/Vty/Terminal/MacOSX.hs +3/−1
- src/Graphics/Vty/Terminal/TerminfoBased.hs +68/−45
- src/Graphics/Vty/Terminal/XTermColor.hs +11/−4
- test/Makefile +1/−1
- test/Verify.hs +1/−0
- test/Verify/Data/Terminfo/Parse.hs +15/−8
- test/Verify/Graphics/Vty/Span.hs +7/−7
- test/interactive_terminal_test.hs +24/−1
- test/verify_debug_terminal.hs +4/−4
- test/verify_display_attributes.hs +9/−0
- test/verify_empty_image_props.hs +13/−0
- test/verify_eval_terminfo_caps.hs +27/−22
- test/verify_inline.hs +11/−0
- test/verify_parse_terminfo_caps.hs +16/−14
- test/vty_inline_example.hs +12/−0
- vty.cabal +22/−15
+ cbits/output_buffer.c view
@@ -0,0 +1,18 @@+#define _XOPEN_SOURCE 500+#include <unistd.h>++#include "output_buffer.h"++void stdout_output_buffer ( int out_fd, uint8_t* buffer, size_t buffer_size )+{+ while ( buffer_size )+ {+ const ssize_t r = write( out_fd, (void*) buffer, buffer_size );++ buffer_size -= (size_t) r;+ buffer += (size_t) r;+ }++ fdatasync( out_fd );+}+
+ cbits/output_buffer.h view
@@ -0,0 +1,5 @@+#define _XOPEN_SOURCE 500+#include <unistd.h>+#include <stdint.h>++void stdout_output_buffer ( int out_fd, uint8_t* buffer, size_t buffer_size );
src/Codec/Binary/UTF8/Width.hs view
@@ -1,7 +1,6 @@ -- Copyright 2009 Corey O'Connor {-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-} {-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}-{-# INCLUDE <wchar.h> #-} module Codec.Binary.UTF8.Width ( wcwidth , wcswidth )
src/Data/Marshalling.hs view
@@ -16,7 +16,6 @@ import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Marshal-import Foreign.Marshal.Array import Foreign.Storable type OutputBuffer = Ptr Word8
src/Data/Terminfo/Eval.hs view
@@ -5,50 +5,59 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NamedFieldPuns #-}-{-# OPTIONS_GHC -funbox-strict-fields -O #-}+{-# OPTIONS_GHC -funbox-strict-fields #-} {- Evaluates the paramaterized terminfo string capability with the given parameters. - - todo: This can be greatly simplified. -} module Data.Terminfo.Eval ( cap_expression_required_bytes , serialize_cap_expression- , bytes_for_range ) where +import Data.ByteString.Internal ( memcpy ) import Data.Marshalling import Data.Terminfo.Parse import Control.Monad.Identity-import Control.Monad.Reader import Control.Monad.State.Strict-import Control.Monad.Trans -import Data.Array.Unboxed import Data.Bits ( (.|.), (.&.), xor ) import Data.List import GHC.Prim import GHC.Word -type EvalT m a = ReaderT (CapExpression,[CapParam]) (StateT [CapParam] m) a+data EvalState = EvalState+ { eval_stack :: ![ CapParam ]+ , eval_expression :: !CapExpression+ , eval_params :: ![ CapParam ]+ }++type EvalT m a = StateT EvalState m a type Eval a = EvalT Identity a -pop :: MonadState [CapParam] m => m CapParam+{-# SPECIALIZE pop :: EvalT IO CapParam #-}+pop :: Monad m => EvalT m CapParam pop = do- v : stack <- get- put stack+ s <- get+ let v : stack' = eval_stack s+ s' = s { eval_stack = stack' }+ put s' return v -read_param :: MonadReader (CapExpression, [CapParam]) m => Word -> m CapParam+{-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-}+read_param :: Monad m => Word -> EvalT m CapParam read_param pn = do- (_,params) <- ask+ !params <- get >>= return . eval_params return $! genericIndex params pn -push :: MonadState [CapParam] m => CapParam -> m ()+{-# SPECIALIZE push :: CapParam -> EvalT IO () #-}+push :: Monad m => CapParam -> EvalT m () push !v = do- stack <- get- put (v : stack)+ s <- get+ let s' = s { eval_stack = v : eval_stack s }+ put s' apply_param_ops :: CapExpression -> [CapParam] -> [CapParam] apply_param_ops cap params = foldl apply_param_op params (param_ops cap)@@ -56,20 +65,11 @@ apply_param_op :: [CapParam] -> ParamOp -> [CapParam] apply_param_op params IncFirstTwo = map (+ 1) params --- | range is 0-based offset into cap_bytes and count--- --- todo: The returned list is not assured to have a length st. length == count-bytes_for_range :: CapExpression -> Word8 -> Word8 -> [Word8]-bytes_for_range cap !offset !count - = take (fromEnum count) - $ drop (fromEnum offset) - $ elems - $ cap_bytes cap- cap_expression_required_bytes :: CapExpression -> [CapParam] -> Word cap_expression_required_bytes cap params = let params' = apply_param_ops cap params- in fst $! runIdentity $ runStateT (runReaderT (cap_ops_required_bytes $ cap_ops cap) (cap, params')) []+ s_0 = EvalState [] cap params'+ in fst $! runIdentity $! runStateT ( cap_ops_required_bytes $! cap_ops cap ) s_0 cap_ops_required_bytes :: CapOps -> Eval Word cap_ops_required_bytes ops = do@@ -77,12 +77,12 @@ return $ sum counts cap_op_required_bytes :: CapOp -> Eval Word-cap_op_required_bytes (Bytes _ c) = return $ toEnum $ fromEnum c+cap_op_required_bytes (Bytes _ _ c) = return $ toEnum c cap_op_required_bytes DecOut = do p <- pop return $ toEnum $ length $ show p cap_op_required_bytes CharOut = do- pop+ _ <- pop return 1 cap_op_required_bytes (PushParam pn) = do read_param pn >>= push@@ -150,20 +150,24 @@ push $ if v_0 > v_1 then 1 else 0 return 0 -serialize_cap_expression :: MonadIO m => CapExpression -> [CapParam] -> OutputBuffer -> m OutputBuffer+serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer serialize_cap_expression cap params out_ptr = do let params' = apply_param_ops cap params- (!out_ptr', _) <- runStateT (runReaderT (serialize_cap_ops out_ptr (cap_ops cap)) (cap, params')) []- return out_ptr'+ s_0 = EvalState [] cap params'+ (!out_ptr', _) <- runStateT ( serialize_cap_ops out_ptr (cap_ops cap) ) s_0+ return $! out_ptr' -serialize_cap_ops :: MonadIO m => OutputBuffer -> CapOps -> EvalT m OutputBuffer+serialize_cap_ops :: OutputBuffer -> CapOps -> EvalT IO OutputBuffer serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops -serialize_cap_op :: MonadIO m => OutputBuffer -> CapOp -> EvalT m OutputBuffer-serialize_cap_op out_ptr (Bytes offset c) = do- (cap, _) <- ask- let out_bytes = bytes_for_range cap offset c- serialize_bytes out_bytes out_ptr+serialize_cap_op :: OutputBuffer -> CapOp -> EvalT IO OutputBuffer+serialize_cap_op !out_ptr ( Bytes !offset !byte_count !next_offset ) = do+ !cap <- get >>= return . eval_expression+ let ( !start_ptr, _ ) = cap_bytes cap+ !src_ptr = start_ptr `plusPtr` offset+ !out_ptr' = out_ptr `plusPtr` next_offset+ liftIO $! memcpy out_ptr src_ptr byte_count+ return $! out_ptr' serialize_cap_op out_ptr DecOut = do p <- pop let out_str = show p@@ -171,7 +175,7 @@ serialize_bytes out_bytes out_ptr serialize_cap_op out_ptr CharOut = do W# p <- pop- -- todo? Truncate the character value to a single byte?+ -- XXX Truncate the character value to a single byte? let !out_byte = W8# (and# p 0xFF##) !out_ptr' = out_ptr `plusPtr` 1 liftIO $ poke out_ptr out_byte
src/Data/Terminfo/Parse.hs view
@@ -9,18 +9,21 @@ ) where +import Control.Applicative ( Applicative(..), pure, (<*>) ) import Control.Monad ( liftM )-import Control.Parallel.Strategies+import Control.Monad.Trans+import Control.DeepSeq -import Data.Array.Unboxed import Data.Monoid import Data.Word +import Foreign.C.Types+import Foreign.Marshal.Array+import Foreign.Ptr+ import Text.ParserCombinators.Parsec -type BytesLength = Word8-type BytesOffset = Word8-type CapBytes = UArray Word8 Word8+type CapBytes = ( Ptr Word8, CSize ) data CapExpression = CapExpression { cap_ops :: !CapOps@@ -31,14 +34,14 @@ } instance NFData CapExpression where- rnf (CapExpression ops !_bytes !_str !_c !_p_ops) - = rnf ops + rnf (CapExpression ops !_bytes !str !c !p_ops) + = rnf ops `seq` rnf str `seq` rnf c `seq` rnf p_ops type CapParam = Word type CapOps = [CapOp] data CapOp = - Bytes !BytesOffset !BytesLength+ Bytes !Int !CSize !Int | DecOut | CharOut -- This stores a 0-based index to the parameter. However the operation that implies this op is -- 1-based@@ -55,39 +58,57 @@ deriving ( Show ) instance NFData CapOp where- rnf (Bytes offset c) = rnf offset >| rnf c- rnf (PushParam !_pn) = ()- rnf (PushValue !_v) = ()- rnf (Conditional c_expr c_parts) = rnf c_expr >| rnf c_parts- rnf _ = ()+ rnf (Bytes offset _count next_offset) = rnf offset `seq` rnf next_offset+ rnf (PushParam pn) = rnf pn+ rnf (PushValue v) = rnf v + rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts + rnf BitwiseOr = ()+ rnf BitwiseXOr = ()+ rnf BitwiseAnd = ()+ rnf ArithPlus = ()+ rnf ArithMinus = ()+ rnf CompareEq = ()+ rnf CompareLt = ()+ rnf CompareGt = ()+ rnf DecOut = ()+ rnf CharOut = () type ParamOps = [ParamOp] data ParamOp = IncFirstTwo deriving ( Show ) -parse_cap_expression :: String -> Either ParseError CapExpression+instance NFData ParamOp where+ rnf IncFirstTwo = ()++parse_cap_expression :: ( Applicative m+ , MonadIO m+ )+ => String + -> m ( Either ParseError CapExpression ) parse_cap_expression cap_string = let v = runParser cap_expression_parser initial_build_state "terminfo cap" cap_string in case v of- Left e -> Left e- Right build_results -> - Right $! ( CapExpression- { cap_ops = out_cap_ops build_results- -- The cap bytes are the lower 8 bits of the input string's characters.- -- \todo Verify the input string actually contains an 8bit byte per character.- , cap_bytes = listArray (0, toEnum $ length cap_string - 1) - $ map (toEnum . fromEnum) cap_string- , source_string = cap_string- , param_count = out_param_count build_results- , param_ops = out_param_ops build_results- } - `using` rnf- )+ Left e -> return $ Left e+ Right build_results -> pure Right <*> construct_cap_expression cap_string build_results +construct_cap_expression :: MonadIO m => [Char] -> BuildResults -> m CapExpression+construct_cap_expression cap_string build_results = do+ byte_array <- liftIO $ newArray (map ( toEnum . fromEnum ) cap_string )+ let expr = CapExpression+ { cap_ops = out_cap_ops build_results+ -- The cap bytes are the lower 8 bits of the input string's characters.+ -- \todo Verify the input string actually contains an 8bit byte per character.+ , cap_bytes = ( byte_array, toEnum $! length cap_string )+ , source_string = cap_string+ , param_count = out_param_count build_results+ , param_ops = out_param_ops build_results+ } + return $! rnf expr `seq` expr+ type CapParser a = GenParser Char BuildState a cap_expression_parser :: CapParser BuildResults@@ -97,16 +118,16 @@ param_escape_parser :: CapParser BuildResults param_escape_parser = do- char '%'+ _ <- char '%' inc_offset 1 literal_percent_parser <|> param_op_parser literal_percent_parser :: CapParser BuildResults literal_percent_parser = do- char '%'+ _ <- char '%' start_offset <- getState >>= return . next_offset inc_offset 1- return $ BuildResults 0 [Bytes start_offset 1] []+ return $ BuildResults 0 [Bytes start_offset 1 1] [] param_op_parser :: CapParser BuildResults param_op_parser@@ -123,32 +144,32 @@ increment_op_parser :: CapParser BuildResults increment_op_parser = do- char 'i'+ _ <- char 'i' inc_offset 1 return $ BuildResults 0 [] [ IncFirstTwo ] push_op_parser :: CapParser BuildResults push_op_parser = do- char 'p'+ _ <- char 'p' param_n <- digit >>= return . (\d -> read [d]) inc_offset 2 return $ BuildResults param_n [ PushParam $ param_n - 1 ] [] dec_out_parser :: CapParser BuildResults dec_out_parser = do- char 'd'+ _ <- char 'd' inc_offset 1 return $ BuildResults 0 [ DecOut ] [] char_out_parser :: CapParser BuildResults char_out_parser = do- char 'c'+ _ <- char 'c' inc_offset 1 return $ BuildResults 0 [ CharOut ] [] conditional_op_parser :: CapParser BuildResults conditional_op_parser = do- char '?'+ _ <- char '?' inc_offset 1 cond_part <- many_expr conditional_true_parser parts <- many_p @@ -191,17 +212,17 @@ conditional_true_parser :: CapParser () conditional_true_parser = do- string "%t"+ _ <- string "%t" inc_offset 2 conditional_false_parser :: CapParser () conditional_false_parser = do- string "%e"+ _ <- string "%e" inc_offset 2 conditional_end_parser :: CapParser () conditional_end_parser = do- string "%;"+ _ <- string "%;" inc_offset 2 bitwise_op_parser :: CapParser BuildResults@@ -212,19 +233,19 @@ bitwise_or_parser :: CapParser BuildResults bitwise_or_parser = do- char '|'+ _ <- char '|' inc_offset 1 return $ BuildResults 0 [ BitwiseOr ] [ ] bitwise_and_parser :: CapParser BuildResults bitwise_and_parser = do- char '&'+ _ <- char '&' inc_offset 1 return $ BuildResults 0 [ BitwiseAnd ] [ ] bitwise_xor_parser :: CapParser BuildResults bitwise_xor_parser = do- char '^'+ _ <- char '^' inc_offset 1 return $ BuildResults 0 [ BitwiseXOr ] [ ] @@ -234,22 +255,22 @@ <|> minus_op where plus_op = do- char '+'+ _ <- char '+' inc_offset 1 return $ BuildResults 0 [ ArithPlus ] [ ] minus_op = do- char '-'+ _ <- char '-' inc_offset 1 return $ BuildResults 0 [ ArithMinus ] [ ] literal_int_op_parser :: CapParser BuildResults literal_int_op_parser = do- char '{'+ _ <- char '{' inc_offset 1 n_str <- many1 digit inc_offset $ toEnum $ length n_str let n :: Word = read n_str- char '}'+ _ <- char '}' inc_offset 1 return $ BuildResults 0 [ PushValue n ] [ ] @@ -260,15 +281,15 @@ <|> compare_gt_op where compare_eq_op = do- char '='+ _ <- char '=' inc_offset 1 return $ BuildResults 0 [ CompareEq ] [ ] compare_lt_op = do- char '<'+ _ <- char '<' inc_offset 1 return $ BuildResults 0 [ CompareLt ] [ ] compare_gt_op = do- char '>'+ _ <- char '>' inc_offset 1 return $ BuildResults 0 [ CompareGt ] [ ] @@ -276,25 +297,25 @@ bytes_op_parser = do bytes <- many1 $ satisfy (/= '%') start_offset <- getState >>= return . next_offset- let !c = toEnum $ length bytes+ let !c = length bytes !s <- getState let s' = s { next_offset = start_offset + c } setState s'- return $ BuildResults 0 [Bytes start_offset c] []+ return $ BuildResults 0 [Bytes start_offset ( toEnum c ) c ] [] char_const_parser :: CapParser BuildResults char_const_parser = do- char '\''+ _ <- char '\'' char_value <- liftM (toEnum . fromEnum) anyChar - char '\''+ _ <- char '\'' inc_offset 3 return $ BuildResults 0 [ PushValue char_value ] [ ] data BuildState = BuildState - { next_offset :: Word8+ { next_offset :: Int } -inc_offset :: Word8 -> CapParser ()+inc_offset :: Int -> CapParser () inc_offset n = do s <- getState let s' = s { next_offset = next_offset s + n }
src/Graphics/Vty.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ForeignFunctionInterface, BangPatterns, UnboxedTuples #-} {-# CFILES gwinsz.c #-} @@ -27,10 +27,7 @@ import Data.IORef -import Data.Maybe ( maybe )- import qualified System.Console.Terminfo as Terminfo-import System.IO -- | The main object. At most one should be created. -- An alternative is to use unsafePerformIO to automatically create a singleton Vty instance when@@ -77,6 +74,9 @@ mkVty :: IO Vty mkVty = mkVtyEscDelay 0 +-- | Set up the state object for using vty. At most one state object should be+-- created at a time. The delay, in microseconds, specifies the period of time to wait for a key+-- following reading ESC from the terminal before considering the ESC key press as a discrete event. mkVtyEscDelay :: Int -> IO Vty mkVtyEscDelay escDelay = do term_info <- Terminfo.setupTermFromEnv @@ -92,23 +92,38 @@ let inner_update in_pic = do b <- display_bounds t+ let DisplayRegion w h = b+ cursor = pic_cursor in_pic+ in_pic' = case cursor of+ Cursor x y ->+ let+ x' = case x of+ _ | x >= 0x80000000 -> 0+ | x >= w -> w - 1+ | otherwise -> x+ y' = case y of+ _ | y >= 0x80000000 -> 0+ | y >= h -> h - 1+ | otherwise -> y+ in in_pic { pic_cursor = Cursor x' y' }+ _ -> in_pic mlast_update <- readIORef last_update_ref update_data <- case mlast_update of Nothing -> do d <- display_context t b- output_picture d in_pic+ output_picture d in_pic' return (b, d) Just (last_bounds, last_context) -> do if b /= last_bounds then do d <- display_context t b- output_picture d in_pic+ output_picture d in_pic' return (b, d) else do- output_picture last_context in_pic+ output_picture last_context in_pic' return (b, last_context) writeIORef last_update_ref $ Just update_data- writeIORef last_pic_ref $ Just in_pic+ writeIORef last_pic_ref $ Just in_pic' let inner_refresh = writeIORef last_update_ref Nothing
src/Graphics/Vty/Attributes.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor -- Display attributes -- -- For efficiency this can be, in the future, encoded into a single 32 bit word. The 32 bit word is
src/Graphics/Vty/Debug.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ScopedTypeVariables #-} module Graphics.Vty.Debug ( module Graphics.Vty.Debug )
src/Graphics/Vty/DisplayAttributes.hs view
@@ -1,3 +1,4 @@+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} module Graphics.Vty.DisplayAttributes where@@ -42,6 +43,7 @@ simplify_style_diffs :: [ StyleStateChange ] -> [ StyleStateChange ] -> [ StyleStateChange ] simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1 +simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff simplify_color_diffs _cd ColorToDefault = ColorToDefault simplify_color_diffs cd NoColorChange = cd simplify_color_diffs _cd ( SetColor !c ) = SetColor c
src/Graphics/Vty/Image.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DisambiguateRecordFields #-}@@ -30,7 +30,6 @@ import Codec.Binary.UTF8.String ( decode ) -import Data.AffineSpace import qualified Data.ByteString as BS import Data.Monoid import qualified Data.Sequence as Seq@@ -111,6 +110,8 @@ = "HorizJoin " ++ show c ++ " ( " ++ show l ++ " <|> " ++ show r ++ " )" show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } ) = "VertJoin (" ++ show c ++ ", " ++ show r ++ ") ( " ++ show t ++ " ) <-> ( " ++ show b ++ " )"+ show ( Translation offset i )+ = "Translation ( " ++ show offset ++ ", " ++ show i ++ " )" show ( EmptyImage ) = "EmptyImage" -- | Currently append in the Monoid instance is equivalent to <->. Future versions will just stack@@ -210,7 +211,7 @@ image_height VertJoin { output_height = r } = r image_height BGFill { output_height = r } = r image_height EmptyImage = 0-image_height ( Translation _v i ) = image_width i+image_height ( Translation _v i ) = image_height i -- | Combines two images side by side. --
src/Graphics/Vty/Inline.hs view
@@ -1,3 +1,31 @@+-- | The inline module provides a limited interface to changing the style of terminal output. The+-- intention is for this interface to be used inline with other output systems. +--+-- The changes specified by the InlineM monad are applied to the terminals display attributes. These+-- display attributes effect the display of all following text output to the terminal file+-- descriptor.+--+-- For example, in an IO monad the following code with print the text \"Not styled. \" Followed by the+-- text \" Styled! \" drawn over a red background and underlined.+--+-- @+-- t <- terminal_handle+-- putStr \"Not styled. \"+-- put_attr_change t $ do+-- back_color red +-- apply_style underline+-- putStr \" Styled! \"+-- put_attr_change t $ default_all+-- putStrLn \"Not styled.\"+-- release_terminal t+-- @+--+-- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate+-- of the 'stdout' handle when the 'terminal_handle' was (first) acquired. If 'stdout' has since been+-- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than+-- 'put_attr_change'+--+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} module Graphics.Vty.Inline ( module Graphics.Vty.Inline )@@ -9,23 +37,33 @@ import Control.Applicative import Control.Monad.State.Strict-import Control.Monad.Trans import Data.Bits ( (.&.), complement ) import Data.IORef import Data.Monoid ( mappend ) +import System.IO+ type InlineM v = State Attr v +-- | Set the background color to the provided 'Color' back_color :: Color -> InlineM () back_color c = modify $ flip mappend ( current_attr `with_back_color` c ) +-- | Set the foreground color to the provided 'Color' fore_color :: Color -> InlineM () fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c ) +-- | Attempt to change the 'Style' of the following text.+--+-- If the terminal does not support the style change no error is produced. The style can still be+-- removed. apply_style :: Style -> InlineM () apply_style s = modify $ flip mappend ( current_attr `with_style` s ) +-- | Attempt to remove the specified 'Style' from the display of the following text.+--+-- This will fail if apply_style for the given style has not been previously called. remove_style :: Style -> InlineM () remove_style s_mask = modify $ \attr -> let style' = case attr_style attr of@@ -34,9 +72,13 @@ SetTo s -> s .&. complement s_mask in attr { attr_style = SetTo style' } +-- | Reset the display attributes default_all :: InlineM () default_all = put def_attr +-- | Apply the provided display attribute changes to the terminal.+--+-- This also flushes the 'stdout' handle. put_attr_change :: ( Applicative m, MonadIO m ) => TerminalHandle -> InlineM () -> m () put_attr_change t c = do bounds <- display_bounds t@@ -44,15 +86,17 @@ mfattr <- liftIO $ known_fattr <$> readIORef ( state_ref t ) fattr <- case mfattr of Nothing -> do- marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d) + liftIO $ marshall_to_terminal t (default_attr_required_bytes d) (serialize_default_attr d) return $ FixedAttr default_style_mask Nothing Nothing Just v -> return v let attr = execState c current_attr attr' = limit_attr_for_display d attr fattr' = fix_display_attr fattr attr' diffs = display_attr_diffs fattr fattr'- marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )- ( serialize_set_attr d fattr attr' diffs )+ liftIO $ hFlush stdout+ liftIO $ marshall_to_terminal t ( attr_required_bytes d fattr attr' diffs )+ ( serialize_set_attr d fattr attr' diffs ) liftIO $ modifyIORef ( state_ref t ) $ \s -> s { known_fattr = Just fattr' } inline_hack d+ liftIO $ hFlush stdout
src/Graphics/Vty/LLInput.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE ForeignFunctionInterface #-} module Graphics.Vty.LLInput ( Key(..)@@ -26,7 +26,6 @@ import System.Console.Terminfo import System.Posix.Signals.Exts-import System.Posix.Signals import System.Posix.Terminal import System.Posix.IO ( stdInput ,fdRead@@ -36,7 +35,7 @@ -- |Representations of non-modifier keys. data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns- | KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu+ | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KNP5 | KUp | KMenu | KLeft | KDown | KRight | KEnter deriving (Eq,Show,Ord) @@ -88,13 +87,13 @@ setFdOption stdInput NonBlockingRead False threadWaitRead stdInput setFdOption stdInput NonBlockingRead True- try readAll :: IO (Either IOException ())+ _ <- try readAll :: IO (Either IOException ()) when (escDelay == 0) finishAtomicInput loop readAll = do (bytes, bytes_read) <- fdRead stdInput 1 when (bytes_read > 0) $ do- tryPutMVar hadInput () -- signal input+ _ <- tryPutMVar hadInput () -- signal input writeChan inputChannel (head bytes) readAll -- | If there is no input for some time, this thread puts '\xFFFE' in the@@ -155,7 +154,16 @@ ansi_classify_table :: [[([Char], (Key, [Modifier]))]] ansi_classify_table =- [ 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 ],+ [ 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 "H" KHome+ , k "F" KEnd+ , k "E" KBegin+ ], -- Support for arrows [("\ESC[" ++ charCnt ++ show mc++c,(s,m)) @@ -165,7 +173,8 @@ (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],+ let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [2::Int,3,5,6,1,4] + [KIns,KDel,KPageUp,KPageDown,KHome,KEnd], -- Support for simple characters. [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],@@ -202,13 +211,13 @@ let pokeIO = (Catch $ do let e = error "(getsize in input layer)" setTerminalAttributes stdInput nattr Immediately writeChan eventChannel (EvResize e e))- installHandler windowChange pokeIO Nothing- installHandler continueProcess pokeIO Nothing+ _ <- installHandler windowChange pokeIO Nothing+ _ <- installHandler continueProcess pokeIO Nothing let uninit = do killThread eventThreadId killThread inputThreadId killThread noInputThreadId- installHandler windowChange Ignore Nothing- installHandler continueProcess Ignore Nothing+ _ <- installHandler windowChange Ignore Nothing+ _ <- installHandler continueProcess Ignore Nothing setTerminalAttributes stdInput oattr Immediately return (readChan eventChannel, uninit)
src/Graphics/Vty/Picture.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor module Graphics.Vty.Picture ( module Graphics.Vty.Picture , Image , image_width
src/Graphics/Vty/Span.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-}@@ -24,8 +24,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Internal as BInt import qualified Data.Foldable as Foldable-import Data.Function-import Data.List import Data.Word import qualified Data.ByteString.UTF8 as BSUTF8 import qualified Data.String.UTF8 as UTF8@@ -153,7 +151,7 @@ then remaining_columns else width forM_ [y .. y + actual_height - 1] $ \y' -> snoc_bg_fill mrow_ops bg actual_width y'- Translation v i -> ops_for_row mrow_ops bg region i y remaining_columns+ Translation _offset i -> ops_for_row mrow_ops bg region i y remaining_columns snoc_text_span :: (Foldable.Foldable t) => Attr
src/Graphics/Vty/Terminal.hs view
@@ -1,17 +1,23 @@--- Copyright 2009 Corey O'Connor--- * Graphics.Vty.Terminal: This instantiates an abtract interface to the terminal interface--- based on the TERM and COLORTERM environment variables. --- * Graphics.Vty.Terminal.Generic: Defines the generic interface all terminals need to implement.--- * Graphics.Vty.Terminal.TerminfoBased: Defines a terminal instance that uses terminfo for all--- control strings. --- - No attempt is made to change the character set to UTF-8 for these terminals. I don't--- know a way to reliably determine if that is required or how to do so.--- * Graphics.Vty.Terminal.XTermColor: This module contains an interface suitable for--- xterm-like terminals. These are the terminals where TERM == xterm. This does use terminfo--- for as many control codes as possible. H: This should derive functionality from the--- TerminfoBased terminal.+-- | Generic Terminal interface. --+-- Defines the common interface supported by all terminals. --+-- See also:+--+-- 1. Graphics.Vty.Terminal: This instantiates an abtract interface to the terminal interface based+-- on the TERM and COLORTERM environment variables. +-- +-- 2. Graphics.Vty.Terminal.Generic: Defines the generic interface all terminals need to implement.+--+-- 3. Graphics.Vty.Terminal.TerminfoBased: Defines a terminal instance that uses terminfo for all+-- control strings. No attempt is made to change the character set to UTF-8 for these terminals.+-- I don't know a way to reliably determine if that is required or how to do so.+--+-- 4. Graphics.Vty.Terminal.XTermColor: This module contains an interface suitable for xterm-like+-- terminals. These are the terminals where TERM == xterm. This does use terminfo for as many+-- control codes as possible. +--+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ScopedTypeVariables #-} module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal , Terminal(..)@@ -32,7 +38,6 @@ import Control.Exception ( SomeException, try ) import Control.Monad.Trans -import Data.Either import Data.List ( isPrefixOf ) import Data.Word @@ -68,6 +73,9 @@ -- environment variables (I think?) this assumes that XTERM_VERSION will never be set for a true -- Terminal.app or iTerm.app session. --+--+-- The file descriptor used for output will a duplicate of the current stdout file descriptor.+-- -- todo: add an implementation for windows that does not depend on terminfo. Should be installable -- with only what is provided in the haskell platform. --@@ -111,19 +119,19 @@ set_cursor_pos t x y = do bounds <- display_bounds t d <- display_context t bounds- marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y)+ liftIO $ marshall_to_terminal t (move_cursor_required_bytes d x y) (serialize_move_cursor d x y) -- | Hides the cursor hide_cursor :: MonadIO m => TerminalHandle -> m () hide_cursor t = do bounds <- display_bounds t d <- display_context t bounds- marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d) + liftIO $ marshall_to_terminal t (hide_cursor_required_bytes d) (serialize_hide_cursor d) -- | Shows the cursor show_cursor :: MonadIO m => TerminalHandle -> m () show_cursor t = do bounds <- display_bounds t d <- display_context t bounds- marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d) + liftIO $ marshall_to_terminal t (show_cursor_required_bytes d) (serialize_show_cursor d)
src/Graphics/Vty/Terminal/Debug.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} module Graphics.Vty.Terminal.Debug ( DebugTerminal(..)@@ -26,6 +26,8 @@ import Foreign.Ptr ( plusPtr ) import Foreign.Storable ( poke ) +import System.IO+ import Unsafe.Coerce -- | The debug display terminal produces a string representation of the requested picture. There is@@ -61,6 +63,8 @@ peekArray (fromEnum buffer_size) out_buffer >>= return . UTF8.fromRep . BSCore.pack >>= writeIORef (debug_terminal_last_output t)++ output_handle t = return stdout data DebugDisplay = DebugDisplay { debug_display_bounds :: DisplayRegion
src/Graphics/Vty/Terminal/Generic.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ExistentialQuantification #-}@@ -24,9 +24,10 @@ import qualified Data.ByteString.Internal as BSCore import Data.Foldable import Data.IORef-import Data.Word import Data.String.UTF8 hiding ( foldl ) +import System.IO+ data TerminalHandle where TerminalHandle :: Terminal t => t -> IORef TerminalState -> TerminalHandle @@ -81,8 +82,11 @@ -- | Output the byte buffer of the specified size to the terminal device. The size is equal to -- end_ptr - start_ptr- output_byte_buffer :: MonadIO m => t -> OutputBuffer -> Word -> m ()+ output_byte_buffer :: t -> OutputBuffer -> Word -> IO () + -- | Handle of output device+ output_handle :: t -> IO Handle+ instance Terminal TerminalHandle where terminal_ID (TerminalHandle t _) = terminal_ID t release_terminal (TerminalHandle t _) = release_terminal t@@ -91,6 +95,7 @@ display_bounds (TerminalHandle t _) = display_bounds t display_terminal_instance (TerminalHandle t _) = display_terminal_instance t output_byte_buffer (TerminalHandle t _) = output_byte_buffer t+ output_handle (TerminalHandle t _) = output_handle t data DisplayHandle where DisplayHandle :: DisplayTerminal d => d -> TerminalHandle -> DisplayState -> DisplayHandle@@ -224,8 +229,10 @@ + required_bytes d initial_attr diffs ops + case pic_cursor pic of NoCursor -> 0- Cursor x y -> show_cursor_required_bytes d- + move_cursor_required_bytes d x y+ Cursor x y -> let m = cursor_output_map ops $ pic_cursor pic+ ( ox, oy ) = char_to_output_pos m ( x, y )+ in show_cursor_required_bytes d+ + move_cursor_required_bytes d ox oy -- ... then serialize liftIO $ allocaBytes (fromEnum total) $ \start_ptr -> do@@ -332,10 +339,10 @@ out_ptr' <- serialize_utf8_text str out_ptr return (out_ptr', fattr) -marshall_to_terminal :: ( MonadIO m, Terminal t )- => t -> Word -> (Ptr Word8 -> m (Ptr Word8)) -> m ()+marshall_to_terminal :: ( Terminal t )+ => t -> Word -> (Ptr Word8 -> IO (Ptr Word8)) -> IO () marshall_to_terminal t c f = do- start_ptr <- liftIO $ mallocBytes (fromEnum c)+ start_ptr <- mallocBytes (fromEnum c) -- -- todo: capture exceptions? end_ptr <- f start_ptr@@ -343,7 +350,7 @@ count | count < 0 -> fail "End pointer before start pointer." | toEnum count > c -> fail $ "End pointer past end of buffer by " ++ show (toEnum count - c) | otherwise -> output_byte_buffer t start_ptr (toEnum count)- liftIO $ free start_ptr+ free start_ptr return () data CursorOutputMap = CursorOutputMap
src/Graphics/Vty/Terminal/MacOSX.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor -- The standard Mac OS X terminals Terminal.app and iTerm both declare themselves to be -- "xterm-color" by default. However the terminfo database for xterm-color included with OS X is -- incomplete. @@ -69,6 +69,8 @@ display_bounds t = display_bounds (super_term t) output_byte_buffer t = output_byte_buffer (super_term t)++ output_handle t = output_handle (super_term t) data DisplayContext = DisplayContext { super_display :: DisplayHandle
src/Graphics/Vty/Terminal/TerminfoBased.hs view
@@ -1,7 +1,8 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-} module Graphics.Vty.Terminal.TerminfoBased ( terminal_instance ) where@@ -24,6 +25,8 @@ import Foreign.C.Types ( CLong ) +import GHC.IO.Handle+ import qualified System.Console.Terminfo as Terminfo import System.IO @@ -40,6 +43,7 @@ , set_default_attr :: CapExpression , clear_screen :: CapExpression , display_attr_caps :: DisplayAttrCaps+ , term_handle :: Handle } data DisplayAttrCaps = DisplayAttrCaps@@ -53,7 +57,7 @@ , enter_bold_mode :: Maybe CapExpression } -marshall_cap_to_terminal :: MonadIO m => Term -> (Term -> CapExpression) -> [CapParam] -> m ()+marshall_cap_to_terminal :: Term -> (Term -> CapExpression) -> [CapParam] -> IO () marshall_cap_to_terminal t cap_selector cap_params = do marshall_to_terminal t ( cap_expression_required_bytes (cap_selector t) cap_params ) ( serialize_cap_expression (cap_selector t) cap_params )@@ -75,15 +79,20 @@ let require_cap str = case Terminfo.getCapability ti (Terminfo.tiGetStr str) of Nothing -> fail $ "Terminal does not define required capability \"" ++ str ++ "\""- Just cap_str -> case parse_cap_expression cap_str of- Left e -> fail $ show e- Right cap -> return cap+ Just cap_str -> do+ parse_result <- parse_cap_expression cap_str + case parse_result of + Left e -> fail $ show e+ Right cap -> return cap probe_cap cap_name = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of Nothing -> return Nothing- Just cap_str -> case parse_cap_expression cap_str of- Left e -> fail $ show e- Right cap -> return $ Just cap+ Just cap_str -> do+ parse_result <- parse_cap_expression cap_str+ case parse_result of+ Left e -> fail $ show e+ Right cap -> return $ Just cap+ the_handle <- liftIO $ hDuplicate stdout pure Term <*> pure in_ID <*> pure ti@@ -97,6 +106,7 @@ <*> require_cap "sgr0" <*> require_cap "clear" <*> current_display_attr_caps ti+ <*> pure the_handle current_display_attr_caps :: ( Applicative m, MonadIO m ) => Terminfo.Terminal @@ -114,33 +124,37 @@ where probe_cap cap_name = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of Nothing -> return Nothing- Just cap_str -> case parse_cap_expression cap_str of- Left e -> fail $ show e- Right cap -> return $ Just cap+ Just cap_str -> do+ parse_result <- parse_cap_expression cap_str+ case parse_result of+ Left e -> fail $ show e+ Right cap -> return $ Just cap instance Terminal Term where terminal_ID t = term_info_ID t ++ " :: TerminfoBased" release_terminal t = do - marshall_cap_to_terminal t set_default_attr []- marshall_cap_to_terminal t cnorm []+ liftIO $ marshall_cap_to_terminal t set_default_attr []+ liftIO $ marshall_cap_to_terminal t cnorm []+ liftIO $ hClose $ term_handle t return () reserve_display t = do if (isJust $ smcup t)- then marshall_cap_to_terminal t (fromJust . smcup) []+ then liftIO $ 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 []+ liftIO $ hFlush stdout+ liftIO $ marshall_cap_to_terminal t clear_screen [] return () release_display t = do if (isJust $ rmcup t)- then marshall_cap_to_terminal t (fromJust . rmcup) []+ then liftIO $ marshall_cap_to_terminal t (fromJust . rmcup) [] else return ()- marshall_cap_to_terminal t cnorm []+ liftIO $ marshall_cap_to_terminal t cnorm [] return () display_terminal_instance t b c = do@@ -156,15 +170,24 @@ ( w, h ) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size | otherwise -> return $ DisplayRegion (toEnum w) (toEnum h) - -- Output the byte buffer of the specified size to the terminal device.- output_byte_buffer _t out_ptr out_byte_count = do- if out_byte_count == 0- then return ()- else liftIO $ hPutBuf stdout out_ptr (fromEnum out_byte_count) - liftIO $ hFlush stdout+ -- | Output the byte buffer of the specified size to the terminal device.+ output_byte_buffer t out_ptr out_byte_count = do+ -- if the out fd is actually the same as stdout's then a+ -- flush is required *before* the c_output_byte_buffer call+ -- otherwise there may still be data in GHC's internal stdout buffer.+ -- _ <- handleToFd stdout+ hPutBuf (term_handle t) out_ptr (fromEnum out_byte_count)+ hFlush (term_handle t) -foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size :: IO CLong+ output_handle t = return (term_handle t) +-- foreign import ccall unsafe "output_buffer.h stdout_output_buffer" c_output_byte_buffer +-- :: CInt -> Ptr Word8 -> CSize -> IO ()+foreign import ccall "gwinsz.h c_get_window_size" c_get_window_size + :: IO CLong+-- foreign import ccall "fdatasync" c_fdatasync +-- :: CInt -> IO CInt+ get_window_size :: IO (Int,Int) get_window_size = do (a,b) <- (`divMod` 65536) `fmap` c_get_window_size@@ -184,17 +207,17 @@ move_cursor_required_bytes d x y = cap_expression_required_bytes (cup $ term d) [y, x] serialize_move_cursor d x y out_ptr - = serialize_cap_expression (cup $ term d) [y, x] out_ptr+ = liftIO $ serialize_cap_expression (cup $ term d) [y, x] out_ptr show_cursor_required_bytes d = cap_expression_required_bytes (cnorm $ term d) [] serialize_show_cursor d out_ptr - = serialize_cap_expression (cnorm $ term d) [] out_ptr+ = liftIO $ serialize_cap_expression (cnorm $ term d) [] out_ptr hide_cursor_required_bytes d = cap_expression_required_bytes (civis $ term d) [] serialize_hide_cursor d out_ptr - = serialize_cap_expression (civis $ term d) [] out_ptr+ = liftIO $ serialize_cap_expression (civis $ term d) [] out_ptr -- Instead of evaluating all the rules related to setting display attributes twice (once in -- required bytes and again in serialize) or some memoization scheme just return a size@@ -236,16 +259,16 @@ EnterExitSeq caps -- only way to reset a color to the defaults -> serialize_default_attr d out_ptr- >>= (\out_ptr' -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps)+ >>= (\out_ptr' -> liftIO $ foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr' caps) >>= set_colors SetState state -- implicitly resets the colors to the defaults- -> serialize_cap_expression ( fromJust $ set_attr_states + -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states $ display_attr_caps $ term d - )- ( sgr_args_for_state state )- out_ptr+ )+ ( sgr_args_for_state state )+ out_ptr >>= set_colors -- Otherwise the display colors are not changing or changing between two non-default -- points.@@ -262,28 +285,28 @@ -- Changes the style and color states according to the differences with the -- currently applied states. EnterExitSeq caps - -> foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps+ -> liftIO ( foldM (\ptr cap -> serialize_cap_expression cap [] ptr) out_ptr caps ) >>= apply_color_diff set_fore_color ( fore_color_diff diffs ) >>= apply_color_diff set_back_color ( back_color_diff diffs ) SetState state -- implicitly resets the colors to the defaults- -> serialize_cap_expression ( fromJust $ set_attr_states - $ display_attr_caps- $ term d- )- ( sgr_args_for_state state )- out_ptr+ -> liftIO $ serialize_cap_expression ( fromJust $ set_attr_states + $ display_attr_caps+ $ term d+ )+ ( sgr_args_for_state state )+ out_ptr >>= set_colors where attr = fix_display_attr prev_attr req_attr set_colors ptr = do ptr' <- case fixed_fore_color attr of- Just c -> serialize_cap_expression ( set_fore_color $ term d ) + Just c -> liftIO $ serialize_cap_expression ( set_fore_color $ term d ) [ ansi_color_index c ] ptr Nothing -> return ptr ptr'' <- case fixed_back_color attr of- Just c -> serialize_cap_expression ( set_back_color $ term d ) + Just c -> liftIO $ serialize_cap_expression ( set_back_color $ term d ) [ ansi_color_index c ] ptr' Nothing -> return ptr'@@ -293,14 +316,14 @@ apply_color_diff _f ColorToDefault _ptr = fail "ColorToDefault is not a possible case for apply_color_diffs" apply_color_diff f ( SetColor c ) ptr- = serialize_cap_expression ( f $ term d ) - [ ansi_color_index c ]- ptr+ = liftIO $ serialize_cap_expression ( f $ term d ) + [ ansi_color_index c ]+ ptr default_attr_required_bytes d = cap_expression_required_bytes (set_default_attr $ term d) [] serialize_default_attr d out_ptr = do- serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr+ liftIO $ serialize_cap_expression ( set_default_attr $ term d ) [] out_ptr ansi_color_index :: Color -> Word ansi_color_index (ISOColor v) = toEnum $ fromEnum v
src/Graphics/Vty/Terminal/XTermColor.hs view
@@ -1,4 +1,4 @@--- Copyright 2009 Corey O'Connor+-- Copyright 2009-2010 Corey O'Connor {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-}@@ -14,6 +14,8 @@ import Control.Applicative import Control.Monad.Trans +import qualified Data.String.UTF8 as UTF8+ import System.IO data XTermColor = XTermColor @@ -61,6 +63,8 @@ output_byte_buffer t = output_byte_buffer (super_term t) + output_handle t = output_handle (super_term t)+ data DisplayContext = DisplayContext { super_display :: DisplayHandle }@@ -88,7 +92,10 @@ -- I think xterm is broken: Reseting the background color as the first bytes serialized on a new -- line does not effect the background color xterm uses to clear the line. Which is used *after* -- the next newline.- inline_hack _d = do- liftIO $ hPutStr stdout "\ESC[K"- liftIO $ hFlush stdout+ inline_hack d = do+ let t = case super_display d of+ DisplayHandle _ t_ _ -> t_+ let s_utf8 = UTF8.fromString "\ESC[K"+ liftIO $ marshall_to_terminal t ( utf8_text_required_bytes s_utf8)+ ( serialize_utf8_text s_utf8 )
test/Makefile view
@@ -26,7 +26,7 @@ $(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+GHC_ARGS=--make -i../src -package parallel -package deepseq-1.1.0.0 -hide-package transformers -hide-package monads-fd -hide-package monads-tf -package QuickCheck-2.1.1.1 -ignore-package vty ../cbits/gwinsz.c ../cbits/output_buffer.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 GHC_PROF_ARGS=-prof -auto-all $(GHC_ARGS)
test/Verify.hs view
@@ -7,6 +7,7 @@ , module Test.QuickCheck , succeeded , failed+ , result , Result(..) , monadicIO , liftIO
test/Verify/Data/Terminfo/Parse.hs view
@@ -16,11 +16,11 @@ instance Show CapExpression where show c = "CapExpression { " ++ show (cap_ops c) ++ " }"- ++ " <- [" ++ hex_dump (cap_bytes c) ++ "]"+ ++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! source_string c ) ++ "]" ++ " <= " ++ show (source_string c) -hex_dump :: CapBytes -> String-hex_dump bytes = foldr (\b s -> showHex b s) "" $ elems bytes+hex_dump :: [Word8] -> String+hex_dump bytes = foldr (\b s -> showHex b s) "" bytes data NonParamCapString = NonParamCapString String deriving Show@@ -95,20 +95,27 @@ is_bytes_op (Bytes {}) = True -- is_bytes_op _ = False +bytes_for_range cap offset c+ = take (fromEnum c)+ $ drop (fromEnum offset)+ $ ( map ( toEnum . fromEnum ) $! source_string cap )+ collect_bytes :: CapExpression -> [Word8] collect_bytes e = concat [ bytes - | Bytes offset c <- cap_ops e+ | Bytes offset c _ <- cap_ops e , let bytes = bytes_for_range e offset c ]+ +verify_bytes_equal :: [Word8] -> [Word8] -> Result verify_bytes_equal out_bytes expected_bytes = if out_bytes == expected_bytes- then liftResult succeeded- else liftResult $ failed + then succeeded+ else failed $ result { reason = "out_bytes [" - ++ hex_dump ( listArray (0, toEnum $ length out_bytes - 1) out_bytes )+ ++ hex_dump out_bytes ++ "] /= expected_bytes ["- ++ hex_dump ( listArray (0, toEnum $ length expected_bytes - 1) expected_bytes )+ ++ hex_dump expected_bytes ++ "]" }
test/Verify/Graphics/Vty/Span.hs view
@@ -20,10 +20,10 @@ verify_all_spans_have_width i spans w = case all_spans_have_width spans w of True -> succeeded- False -> failed { reason = "Not all spans contained operations defining exactly " - ++ show w- ++ " columns of output -\n"- ++ show i- ++ "\n->\n"- ++ show spans- }+ False -> failed $ result { reason = "Not all spans contained operations defining exactly " + ++ show w+ ++ " columns of output -\n"+ ++ show i+ ++ "\n->\n"+ ++ show spans+ }
test/interactive_terminal_test.hs view
@@ -3,7 +3,6 @@ module Main where import Graphics.Vty.Attributes-import Graphics.Vty.Image import Graphics.Vty.Inline import Graphics.Vty.Picture import Graphics.Vty.Terminal@@ -168,6 +167,7 @@ , attributes_test_5 , inline_test_0 , inline_test_1+ , inline_test_2 ] reserve_output_test = Test @@ -237,8 +237,10 @@ forM_ [1 .. h - 2] $ \y -> do set_cursor_pos t 0 y putStr "X"+ hFlush stdout set_cursor_pos t (w - 1) y putStr "X"+ hFlush stdout set_cursor_pos t 0 (h - 1) let row_h = replicate (fromEnum w - 1) 'X' putStr row_h@@ -288,8 +290,10 @@ forM_ [1 .. h - 2] $ \y -> do set_cursor_pos t 0 y putStr "X"+ hFlush stdout set_cursor_pos t (w - 1) y putStr "X"+ hFlush stdout set_cursor_pos t 0 (h - 1) let row_h = row_0 putStr row_h@@ -901,3 +905,22 @@ , confirm_results = generic_output_match_confirm }++inline_test_2 = Test+ { test_name = "Verify styled output can be performed without clearing the screen."+ , test_ID = "inline_test_1"+ , test_action = 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+ putStr "Not styled.\n"+ release_terminal t+ return ()+ , print_summary = putStr $ [$heredoc|+|]++ , confirm_results = generic_output_match_confirm+ }+
test/verify_debug_terminal.hs view
@@ -50,7 +50,7 @@ ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes- then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }+ then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows :: DebugWindow -> Property@@ -67,7 +67,7 @@ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes- then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }+ then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows_cropped_width :: DebugWindow -> Property@@ -84,7 +84,7 @@ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes- then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }+ then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded many_T_rows_cropped_height :: DebugWindow -> Property@@ -101,7 +101,7 @@ let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T') expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected if out_bytes /= expected_bytes- then return $ failed { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes }+ then return $ failed $ result { reason = "\n" ++ show out_bytes ++ "\n\n" ++ show expected_bytes } else return succeeded main = run_test $ do
+ test/verify_display_attributes.hs view
@@ -0,0 +1,9 @@+module Main where++import Verify.Graphics.Vty.DisplayAttributes+import Verify.Graphics.Vty.Attributes++import Verify++main = run_test $ do+ return ()
+ test/verify_empty_image_props.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Verify++-- should be exported by Graphics.Vty.Picture+import Graphics.Vty.Picture ( Image, empty_image )++main = run_test $ do+ -- should provide an image type.+ let _ :: Image = empty_image+ return ()+
test/verify_eval_terminfo_caps.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns #-} module Main where@@ -6,6 +7,7 @@ import Data.Terminfo.Eval import Data.Terminfo.Parse+import Control.DeepSeq import qualified System.Console.Terminfo as Terminfo @@ -87,6 +89,7 @@ main = do run_test $ do+ eval_buffer :: Ptr Word8 <- liftIO $ mallocBytes (1024 * 1024) -- Should be big enough for all termcaps ;-) forM_ terminals_of_interest $ \term_name -> do liftIO $ putStrLn $ "testing parsing of caps for terminal: " ++ term_name mti <- liftIO $ try $ Terminfo.setupTerm term_name@@ -98,32 +101,34 @@ liftIO $ putStrLn $ "\tevaluating cap: " ++ cap_name case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of Just cap_def -> do- verify ( "\teval cap " ++ cap_name ++ " -> " ++ show cap_def )- ( verify_eval_cap cap_def )+ parse_result <- parse_cap_expression cap_def+ let test_name = "\teval cap " ++ cap_name ++ " -> " ++ show cap_def+ _ <- case parse_result of+ Left error -> verify test_name ( liftResult $ failed + $ result { reason = "prase error " ++ show error } )+ Right !cap_expr -> verify test_name ( verify_eval_cap eval_buffer cap_expr ) return () Nothing -> do return () return () return () -verify_eval_cap cap_string- = case parse_cap_expression cap_string of- Left error -> - liftResult $ failed { reason = "parse error " ++ show error }- Right expr -> - forAll (vector 9) $ \input_values -> - let byte_count = cap_expression_required_bytes expr input_values- in liftIOResult $ do- start_ptr :: Ptr Word8 <- mallocBytes (fromEnum byte_count)- end_ptr <- serialize_cap_expression expr input_values start_ptr- free start_ptr- case end_ptr `minusPtr` start_ptr of- count | count < 0 -> - return $ failed { reason = "End pointer before start pointer." }- | toEnum count > byte_count -> - return $ failed { reason = "End pointer past end of buffer by " - ++ show (toEnum count - byte_count) - }- | otherwise -> - return succeeded+{-# NOINLINE verify_eval_cap #-}+verify_eval_cap :: Ptr Word8 -> CapExpression -> Int -> Property+verify_eval_cap eval_buffer expr !junk_int = do+ forAll (vector 9) $ \input_values -> + let !byte_count = cap_expression_required_bytes expr input_values+ in liftIOResult $ do+ let start_ptr :: Ptr Word8 = eval_buffer+ forM_ [0..100] $ \i -> serialize_cap_expression expr input_values start_ptr+ end_ptr <- serialize_cap_expression expr input_values start_ptr+ case end_ptr `minusPtr` start_ptr of+ count | count < 0 -> + return $ failed $ result { reason = "End pointer before start pointer." }+ | toEnum count > byte_count -> + return $ failed $ result { reason = "End pointer past end of buffer by " + ++ show (toEnum count - byte_count) + }+ | otherwise -> + return succeeded
+ test/verify_inline.hs view
@@ -0,0 +1,11 @@+module Main where++import Graphics.Vty.Inline+import Graphics.Vty.Terminal++import Verify++main = run_test $ do+ t <- terminal_handle+ put_attr_change t $ default_all+ return ()
test/verify_parse_terminfo_caps.hs view
@@ -4,8 +4,6 @@ import Prelude hiding ( catch ) -import Data.Terminfo.Eval ( bytes_for_range )- import qualified System.Console.Terminfo as Terminfo import Verify.Data.Terminfo.Parse@@ -98,7 +96,7 @@ case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of Just cap_def -> do verify ( "\tparse cap " ++ cap_name ++ " -> " ++ show cap_def )- ( verify_parse_cap cap_def $ const (liftResult succeeded) ) + ( verify_parse_cap cap_def $ const ( return succeeded ) ) return () Nothing -> do return ()@@ -110,9 +108,10 @@ return () return () -verify_parse_cap cap_string on_parse = do- case parse_cap_expression cap_string of- Left error -> liftResult $ failed { reason = "parse error " ++ show error }+verify_parse_cap cap_string on_parse = liftIOResult $ do+ parse_result <- parse_cap_expression cap_string+ case parse_result of+ Left error -> return $ failed $ result { reason = "parse error " ++ show error } Right e -> on_parse e non_paramaterized_caps (NonParamCapString cap) = do@@ -120,39 +119,42 @@ let expected_count :: Word8 = toEnum $ length cap expected_bytes = map (toEnum . fromEnum) cap out_bytes = bytes_for_range e 0 expected_count- in verify_bytes_equal out_bytes expected_bytes+ in return $ verify_bytes_equal out_bytes expected_bytes literal_percent_caps (LiteralPercentCap cap_string expected_bytes) = do verify_parse_cap cap_string $ \e -> let expected_count :: Word8 = toEnum $ length expected_bytes out_bytes = collect_bytes e- in verify_bytes_equal out_bytes expected_bytes+ in return $ verify_bytes_equal out_bytes expected_bytes inc_first_two_caps (IncFirstTwoCap cap_string expected_bytes) = do verify_parse_cap cap_string $ \e -> let expected_count :: Word8 = toEnum $ length expected_bytes out_bytes = collect_bytes e- in verify_bytes_equal out_bytes expected_bytes+ in return $ verify_bytes_equal out_bytes expected_bytes push_param_caps (PushParamCap cap_string expected_param_count expected_bytes) = do verify_parse_cap cap_string $ \e -> let expected_count :: Word8 = toEnum $ length expected_bytes out_bytes = collect_bytes e out_param_count = param_count e- in verify_bytes_equal out_bytes expected_bytes- .&. out_param_count == expected_param_count+ in return $ if out_param_count == expected_param_count+ then verify_bytes_equal out_bytes expected_bytes+ else failed $ result { reason = "out param count /= expected param count" } dec_print_param_caps (DecPrintCap cap_string expected_param_count expected_bytes) = do verify_parse_cap cap_string $ \e -> let expected_count :: Word8 = toEnum $ length expected_bytes out_bytes = collect_bytes e out_param_count = param_count e- in verify_bytes_equal out_bytes expected_bytes- .&. out_param_count == expected_param_count+ in return $ if out_param_count == expected_param_count+ then verify_bytes_equal out_bytes expected_bytes+ else failed $ result { reason = "out param count /= expected param count" } print_cap ti cap_name = do putStrLn $ cap_name ++ ": " ++ show (from_capname ti cap_name) print_expression ti cap_name = do- putStrLn $ cap_name ++ ": " ++ show (parse_cap_expression $ from_capname ti cap_name)+ parse_result <- parse_cap_expression $ from_capname ti cap_name+ putStrLn $ cap_name ++ ": " ++ show parse_result
+ test/vty_inline_example.hs view
@@ -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 ()
vty.cabal view
@@ -1,5 +1,5 @@ Name: vty-Version: 4.2.1.0+Version: 4.4.0.0 License: BSD3 License-file: LICENSE Author: Stefan O'Rear, Corey O'Connor@@ -24,13 +24,13 @@ . © 2006-2007 Stefan O'Rear; BSD3 license. .- © 2008-2009 Corey O'Connor; BSD3 license.+ © 2008-2010 Corey O'Connor; BSD3 license. 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+Build-Depends: ghc-prim, parallel >= 2.2 && < 2.3, deepseq >= 1.1 && < 1.2 Build-Depends: array Build-Depends: parsec >= 2 && < 4 Build-Depends: vector-space >= 0.5 && < 0.6@@ -59,36 +59,42 @@ C-Sources: cbits/gwinsz.c cbits/set_term_timing.c cbits/mk_wcwidth.c+ cbits/output_buffer.c+ Include-Dirs: cbits hs-source-dirs: src Extra-Source-Files: test/Makefile- test/Bench2.hs test/Bench.hs+ test/Bench2.hs test/BenchRenderChar.hs test/ControlTable.hs test/HereDoc.hs- test/interactive_terminal_test.hs- test/Test2.hs test/Test.hs+ test/Test2.hs+ test/Verify.hs+ test/Verify/Data/Terminfo/Parse.hs+ test/Verify/Graphics/Vty/Attributes.hs+ test/Verify/Graphics/Vty/DisplayRegion.hs+ test/Verify/Graphics/Vty/Image.hs+ test/Verify/Graphics/Vty/Picture.hs+ test/Verify/Graphics/Vty/Span.hs+ test/interactive_terminal_test.hs test/verify_attribute_ops.hs test/verify_debug_terminal.hs+ test/verify_display_attributes.hs+ test/verify_empty_image_props.hs test/verify_eval_terminfo_caps.hs- test/Verify.hs test/verify_image_ops.hs test/verify_image_trans.hs+ test/verify_inline.hs test/verify_parse_terminfo_caps.hs test/verify_picture_ops.hs test/verify_picture_to_span.hs test/verify_span_ops.hs test/verify_utf8_width.hs+ test/vty_inline_example.hs test/vty_issue_18.hs test/yi_issue_264.hs- test/Verify/Graphics/Vty/Attributes.hs- test/Verify/Graphics/Vty/Picture.hs- test/Verify/Graphics/Vty/Span.hs- test/Verify/Graphics/Vty/DisplayRegion.hs- test/Verify/Graphics/Vty/Image.hs- test/Verify/Data/Terminfo/Parse.hs src/Codec/Binary/UTF8/Debug.hs src/Graphics/Vty/Terminal/Debug.hs src/Graphics/Vty/Debug.hs@@ -96,7 +102,8 @@ cbits/mk_wcwidth.c cbits/set_term_timing.c cbits/gwinsz.h+ cbits/output_buffer.h -ghc-options: -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr-ghc-prof-options: -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr+ghc-options: -O2 -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr+ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr