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

Merge branch 'master' of github.com:coreyoconnor/vty

Browse Source
This commit is contained in:
Corey O'Connor 2013-07-26 21:29:32 -07:00
commit 3da7ed057e
21 changed files with 432 additions and 355 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
CHANGELOG
View File

@ -1,12 +1,25 @@
5.0.0
* API changes:
* removed the typeclass based terminal and display context interface in favor of a data
structure of properties interface.
* removed the typeclass based terminal and display context interface in favor of a data
structure of properties interface.
* The default picture for an image now uses the "clear" background. This background fills
background spans with spaces or just ends the line.
* Previously the background defaulted to the space character. This causes issues copying
text from a text editor. The text would end up with many extra spaces at the end of the
line.
* Layer support
* Each layer is an image.
* The layers for a picture are a list of images.
* The first image is the top-most layer.
* The final rendering is as if the bottom layer (last image) was rendered, then the next
(second to last image) etc.
* The transparent areas for a layer are the background image components.
* If the background is clear there is no background layer.
* If there is a background character then the bottom layer is the background layer.
* compatibility improvements:
* terminfo based terminals with no cursor support are now silently accepted. The cursor
visibility changes in the Picture will have no effect.
* alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a
guess.
* terminfo based terminals with no cursor support are silently accepted. The cursor
visibility changes in the Picture will have no effect.
* alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a
guess.
4.7.0.0
* API changes:

1
README.md
View File

@ -63,6 +63,7 @@ Profiling appears to cause issues with coverage when enabled. To evaluate covera
follows:
~~~
rm -rf dist
cabal configure --enable-tests --enable-library-coverage \
--disable-library-profiling \
--disable-executable-profiling

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

@ -162,7 +162,7 @@ serialize_cap_ops :: OutputBuffer -> CapOps -> EvalT IO OutputBuffer
serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops
serialize_cap_op :: OutputBuffer -> CapOp -> EvalT IO OutputBuffer
serialize_cap_op !out_ptr ( Bytes !offset !byte_count !next_offset ) = do
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

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

@ -21,6 +21,8 @@ import Foreign.C.Types
import Foreign.Marshal.Array
import Foreign.Ptr
import Numeric (showHex)
import Text.ParserCombinators.Parsec
type CapBytes = ( Ptr Word8, CSize )
@ -31,7 +33,16 @@ data CapExpression = CapExpression
, source_string :: !String
, param_count :: !Word
, param_ops :: !ParamOps
}
} deriving (Eq)
instance Show CapExpression where
show c
= "CapExpression { " ++ show (cap_ops c) ++ " }"
++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! source_string c ) ++ "]"
++ " <= " ++ show (source_string c)
where
hex_dump :: [Word8] -> String
hex_dump = foldr (\b s -> showHex b s) ""
instance NFData CapExpression where
rnf (CapExpression ops !_bytes !str !c !p_ops)
@ -55,7 +66,7 @@ data CapOp =
| BitwiseOr | BitwiseXOr | BitwiseAnd
| ArithPlus | ArithMinus
| CompareEq | CompareLt | CompareGt
deriving ( Show )
deriving (Show, Eq)
instance NFData CapOp where
rnf (Bytes offset _count next_offset) = rnf offset `seq` rnf next_offset
@ -76,7 +87,7 @@ instance NFData CapOp where
type ParamOps = [ParamOp]
data ParamOp =
IncFirstTwo
deriving ( Show )
deriving (Show, Eq)
instance NFData ParamOp where
rnf IncFirstTwo = ()

4
src/Graphics/Vty.hs
View File

@ -80,8 +80,8 @@ mkVty = mkVtyEscDelay 0
-- following reading ESC from the terminal before considering the ESC key press as a discrete event.
-- \todo move input init into terminal interface
mkVtyEscDelay :: Int -> IO Vty
mkVtyEscDelay escDelay = do
term_info <- Terminfo.setupTermFromEnv
mkVtyEscDelay escDelay = do
term_info <- Terminfo.setupTermFromEnv
t <- current_terminal
reserve_display t
(kvar, endi) <- initTermInput escDelay term_info

2
src/Graphics/Vty/Image/Internal.hs
View File

@ -33,7 +33,7 @@ data Image =
}
-- | 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 background
-- filles to the provided images that assure this is true for the HorizJoin value produced.
-- fills to the provided images that assure this is true for the HorizJoin value produced.
| HorizJoin
{ part_left :: Image
, part_right :: Image

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

@ -54,7 +54,7 @@ pic_for_image :: Image -> Picture
pic_for_image i = Picture
{ pic_cursor = NoCursor
, pic_layers = [i]
, pic_background = Background ' ' current_attr
, pic_background = ClearBackground
}
-- | A picture can be configured either to not show the cursor or show the cursor at the specified
@ -80,17 +80,23 @@ instance NFData Cursor where
--
-- \todo The current attribute is always set to the default attributes at the start of updating the
-- screen to a picture.
--
-- \todo The background character *must* occupy a single column and no more.
--
-- \todo background char should be optional
data Background = Background
data Background
= Background
{ background_char :: Char
, background_attr :: Attr
}
-- | The background is:
--
-- * the space character if there are remaining non-skip ops
-- * (?) nothing if there are no remaining non-skip ops.
--
-- Might require the terminal interface to do a line clear?
-- Or should the nothing case be switched with crlf?
| ClearBackground
instance NFData Background where
rnf (Background c a) = c `seq` a `seq` ()
rnf ClearBackground = ()
-- | Compatibility with applications that do not use more than a single layer.
pic_image :: Picture -> Image

306
src/Graphics/Vty/PictureToSpans.hs
View File

@ -1,4 +1,304 @@
-- Copyright 2009-2010 Corey O'Connor
module Graphics.Vty.PictureToSpans
where
-- Copyright Corey O'Connor<coreyoconnor@gmail.com>
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
module Graphics.Vty.PictureToSpans where
import Graphics.Vty.DisplayRegion
import Graphics.Vty.Image
import Graphics.Vty.Image.Internal
import Graphics.Vty.Picture
import Graphics.Vty.Span
import Control.Applicative
import Control.Lens hiding ( op )
import Control.Monad.Reader
import Control.Monad.State.Strict hiding ( state )
import Control.Monad.ST.Strict hiding ( unsafeIOToST )
import qualified Data.Vector as Vector hiding ( take, replicate )
import Data.Vector.Mutable ( MVector(..))
import qualified Data.Vector.Mutable as MVector
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
type MRowOps s = MVector s SpanOps
type MSpanOps s = MVector s SpanOp
-- transform plus clip. More or less.
data BlitState = BlitState
-- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset
{ _column_offset :: Int
, _row_offset :: Int
-- clip coordinate space is in image space. Which means it's >= 0 and < image_width.
, _skip_columns :: Int
-- >= 0 and < image_height
, _skip_rows :: Int
-- includes consideration of skip_columns. In display space.
-- The number of columns from the next column to be defined to the end of the display for the
-- row.
, _remaining_columns :: Int
-- includes consideration of skip_rows. In display space.
, _remaining_rows :: Int
}
makeLenses ''BlitState
data BlitEnv s = BlitEnv
{ _region :: DisplayRegion
, _mrow_ops :: MRowOps s
}
makeLenses ''BlitEnv
type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the
-- specified region.
spans_for_pic :: Picture -> DisplayRegion -> DisplayOps
spans_for_pic pic r = DisplayOps r $ Vector.create (combined_spans_for_layers pic r)
-- | Produces the span ops for each layer then combines them.
--
-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire
-- region.
combined_spans_for_layers :: Picture -> DisplayRegion -> ST s (MRowOps s)
combined_spans_for_layers pic r
| region_width r == 0 || region_height r == 0 = MVector.new 0
| otherwise = do
layer_ops <- mapM (\layer -> build_spans layer r) (pic_layers pic)
case layer_ops of
[] -> fail "empty picture"
[ops] -> substitute_skips (pic_background pic) ops
_ -> fail "TODO: picture with more than one layer not supported"
substitute_skips :: Background -> MRowOps s -> ST s (MRowOps s)
substitute_skips ClearBackground ops = do
forM_ [0 .. MVector.length ops - 1] $ \row -> do
row_ops <- MVector.read ops row
-- the image operations assure that background fills are combined.
-- clipping a background fill does not split the background fill.
-- merging of image layers can split a skip, but only by the insertion of a non skip.
-- all this combines to mean we can check the last operation and remove it if it's a skip
-- todo: or does it?
let row_ops' = case Vector.last row_ops of
Skip w -> Vector.init row_ops `Vector.snoc` RowEnd w
_ -> row_ops
-- now all the skips can be replaced by replications of ' ' of the required width.
let row_ops'' = swap_skips_for_single_column_char_span ' ' current_attr row_ops'
MVector.write ops row row_ops''
return ops
substitute_skips (Background {background_char, background_attr}) ops = do
-- At this point we decide if the background character is single column or not.
-- obviously, single column is easier.
case safe_wcwidth background_char of
w | w == 0 -> fail $ "invalid background character " ++ show background_char
| w == 1 -> do
forM_ [0 .. MVector.length ops - 1] $ \row -> do
row_ops <- MVector.read ops row
let row_ops' = swap_skips_for_single_column_char_span background_char background_attr row_ops
MVector.write ops row row_ops'
| otherwise -> do
forM_ [0 .. MVector.length ops - 1] $ \row -> do
row_ops <- MVector.read ops row
let row_ops' = swap_skips_for_char_span w background_char background_attr row_ops
MVector.write ops row row_ops'
return ops
swap_skips_for_single_column_char_span :: Char -> Attr -> SpanOps -> SpanOps
swap_skips_for_single_column_char_span c a = Vector.concatMap f
where f (Skip ow) = let txt = T.pack $ replicate ow c
in Vector.cons (AttributeChange a)
(Vector.singleton $ TextSpan ow ow (T.encodeUtf8 txt))
f v = Vector.singleton v
swap_skips_for_char_span :: Int -> Char -> Attr -> SpanOps -> SpanOps
swap_skips_for_char_span w c a = Vector.concatMap f
where
f (Skip ow) = let txt_0_cw = ow `div` w
txt_0 = T.pack $ replicate txt_0_cw c
txt_1_cw = ow `mod` w
txt_1 = T.pack $ replicate txt_1_cw '…'
cw = txt_0_cw + txt_1_cw
txt = txt_0 `T.append` txt_1
in Vector.cons (AttributeChange a)
(Vector.singleton $ TextSpan ow cw $ T.encodeUtf8 txt)
f v = Vector.singleton v
-- | Builds a vector of row operations that will output the given picture to the terminal.
--
-- Crops to the given display region.
--
-- TODO: I'm pretty sure there is an algorithm that does not require a mutable buffer.
build_spans :: Image -> DisplayRegion -> ST s (MRowOps s)
build_spans image out_region = do
-- First we create a mutable vector for each rows output operations.
out_ops <- MVector.replicate (region_height out_region) Vector.empty
-- \todo I think building the span operations in display order would provide better performance.
-- However, I got stuck trying to implement an algorithm that did this. This will be considered
-- as a possible future optimization.
--
-- A depth first traversal of the image is performed. ordered according to the column range
-- defined by the image from least to greatest. The output row ops will at least have the
-- region of the image specified. Iterate over all output rows and output background fills for
-- all unspecified columns.
--
-- The images are made into span operations from left to right. It's possible that this could
-- easily be made to assure top to bottom output as well.
when (region_height out_region > 0 && region_width out_region > 0) $ do
-- The ops builder recursively descends the image and outputs span ops that would
-- display that image. The number of columns remaining in this row before exceeding the
-- bounds is also provided. This is used to clip the span ops produced to the display.
let full_build = do
start_image_build image
-- Fill in any unspecified columns with a skip.
forM_ [0 .. (region_height out_region - 1)] (add_row_completion out_region)
init_env = BlitEnv out_region out_ops
init_state = BlitState 0 0 0 0 (region_width out_region) (region_height out_region)
_ <- runStateT (runReaderT full_build init_env) init_state
return ()
return out_ops
-- | Add the operations required to build a given image to the current set of row operations
-- returns the number of columns and rows contributed to the output.
start_image_build :: Image -> BlitM s ()
start_image_build image = do
out_of_bounds <- is_out_of_bounds <$> get
when (not out_of_bounds) $ add_maybe_clipped image
is_out_of_bounds :: BlitState -> Bool
is_out_of_bounds s
| s ^. remaining_columns <= 0 = True
| s ^. remaining_rows <= 0 = True
| otherwise = False
-- TODO: prove this cannot be called in an out of bounds case.
add_maybe_clipped :: forall s . Image -> BlitM s ()
add_maybe_clipped EmptyImage = return ()
add_maybe_clipped (HorizText a text_str ow _cw) = do
-- TODO: assumption that text spans are only 1 row high.
s <- use skip_rows
when (s < 1) $ do
use row_offset >>= snoc_op (AttributeChange a)
left_clip <- use skip_columns
right_clip <- use remaining_columns
let left_clipped = left_clip > 0
right_clipped = (ow - left_clip) > right_clip
if left_clipped || right_clipped
then let text_str' = clip_text text_str left_clip right_clip
in add_unclipped_text text_str'
else add_unclipped_text text_str
add_maybe_clipped (VertJoin top_image bottom_image _ow oh) = do
add_maybe_clipped_join "vert_join" skip_rows remaining_rows row_offset
(image_height top_image)
top_image
bottom_image
oh
add_maybe_clipped (HorizJoin left_image right_image ow _oh) = do
add_maybe_clipped_join "horiz_join" skip_columns remaining_columns column_offset
(image_width left_image)
left_image
right_image
ow
add_maybe_clipped BGFill {output_width, output_height} = do
s <- get
let output_width' = min (output_width - s^.skip_columns) (s^.remaining_columns)
output_height' = min (output_height - s^.skip_rows ) (s^.remaining_rows)
y <- use row_offset
forM_ [y..y+output_height'-1] $ snoc_op (Skip output_width')
add_maybe_clipped CropRight {cropped_image, output_width} = do
remaining_columns .= output_width
add_maybe_clipped cropped_image
add_maybe_clipped CropLeft {cropped_image, left_skip} = do
skip_columns += left_skip
add_maybe_clipped cropped_image
add_maybe_clipped CropBottom {cropped_image, output_height} = do
remaining_rows .= output_height
add_maybe_clipped cropped_image
add_maybe_clipped CropTop {cropped_image, top_skip} = do
skip_rows += top_skip
add_maybe_clipped cropped_image
add_maybe_clipped_join :: forall s . String
-> Lens BlitState BlitState Int Int
-> Lens BlitState BlitState Int Int
-> Lens BlitState BlitState Int Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do
state <- get
when (state^.remaining == 0) $ fail $ name ++ " with remaining == 0"
case state^.skip of
s | s >= size -> fail $ name ++ " on fully clipped"
-- TODO: check if clipped in other dim. if not use add_unclipped
| s == 0 -> case state^.remaining of
r | r > i0_dim -> do
add_maybe_clipped i0
put $ state & offset +~ i0_dim & remaining -~ i0_dim
add_maybe_clipped i1
| otherwise -> add_maybe_clipped i0
| s >= i0_dim -> do
put $ state & skip -~ i0_dim
add_maybe_clipped i1
| otherwise -> case i0_dim - s of
i0_dim' | state^.remaining <= i0_dim' -> add_maybe_clipped i0
| otherwise -> do
add_maybe_clipped i0
put $ state & offset +~ i0_dim' & remaining -~ i0_dim'
add_maybe_clipped i1
-- TODO: store a skip list in HorizText(?)
-- TODO: represent display strings containing chars that are not 1 column chars as a separate
-- display string value?
-- TODO: assumes max column width is 2
clip_text :: DisplayText -> Int -> Int -> DisplayText
clip_text txt left_skip right_clip =
-- CPS would clarify this I think
let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0
txt' = if pad_prefix then TL.cons '…' (TL.drop (to_drop+1) txt) else TL.drop to_drop txt
(to_take,pad_suffix) = clip_for_char_width right_clip txt' 0
txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty)
clip_for_char_width 0 _ n = (n, False)
clip_for_char_width w t n
| w < cw = (n, True)
| w == cw = (n+1, False)
| w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)
where cw = safe_wcwidth (TL.head t)
clip_for_char_width _ _ _ = error "clip_for_char_width applied to undefined"
in txt''
add_unclipped_text :: DisplayText -> BlitM s ()
add_unclipped_text txt = do
let op = TextSpan used_display_columns
(fromIntegral $ TL.length txt)
(T.encodeUtf8 $ TL.toStrict txt)
used_display_columns = wcswidth $ TL.unpack txt
use row_offset >>= snoc_op op
add_row_completion :: DisplayRegion -> Int -> BlitM s ()
add_row_completion display_region row = do
all_row_ops <- view mrow_ops
row_ops <- lift $ lift $ MVector.read all_row_ops row
let end_x = span_ops_effected_columns row_ops
when (end_x < region_width display_region) $ do
let ow = region_width display_region - end_x
snoc_op (Skip ow) row
-- | snocs the operation to the operations for the given row.
snoc_op :: SpanOp -> Int -> BlitM s ()
snoc_op !op !row = do
the_mrow_ops <- view mrow_ops
lift $ lift $ do
ops <- MVector.read the_mrow_ops row
let ops' = Vector.snoc ops op
MVector.write the_mrow_ops row ops'

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

@ -1,8 +1,5 @@
{-# LANGUAGE RankNTypes #-}
-- Copyright Corey O'Connor
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -20,39 +17,33 @@
module Graphics.Vty.Span
where
import Graphics.Vty.Image
import Graphics.Vty.Image.Internal
import Graphics.Vty.Picture
import Graphics.Vty.DisplayRegion
import Control.Applicative
import Control.Lens hiding ( op )
import Control.Monad.Reader
import Control.Monad.State.Strict hiding ( state )
import Control.Monad.ST.Strict hiding ( unsafeIOToST )
import Graphics.Vty.Image
import Data.Vector (Vector)
import qualified Data.Vector as Vector hiding ( take, replicate )
import Data.Vector.Mutable ( MVector(..))
import qualified Data.Vector.Mutable as Vector
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
-- | This represents an operation on the terminal. Either an attribute change or the output of a
-- text string.
--
-- todo: This type may need to be restructured to increase sharing in the bytestring
--
-- todo: Make foldable
data SpanOp =
AttributeChange !Attr
-- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
-- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width
-- TextSpan [output width in columns] [number of characters] [data]
| TextSpan !Int !Int BS.ByteString
-- | Skips the given number of columns
-- A skip is transparent.... maybe? I am not sure how attribute changes interact.
-- todo: separate from this type.
| Skip !Int
-- | Marks the end of a row. specifies how many columns are remaining. These columns will not be
-- explicitly overwritten with the span ops. The terminal is require to assure the remaining
-- columns are clear.
-- todo: separate from this type.
| RowEnd !Int
deriving Eq
-- | vector of span operations. executed in succession. This represents the operations required to
@ -69,46 +60,15 @@ data DisplayOps = DisplayOps
-- | vector of span operation vectors. One per row of the screen.
type RowOps = Vector SpanOps
type MRowOps s = MVector s SpanOps
type MSpanOps s = MVector s SpanOp
instance Show DisplayOps where
show (DisplayOps _ the_row_ops)
= "{ " ++ (show $ Vector.map (\ops -> show ops ++ "; " ) the_row_ops) ++ " }"
instance Show SpanOp where
show (AttributeChange attr) = show attr
show (TextSpan ow cw _) = "TextSpan " ++ show ow ++ " " ++ show cw
-- transform plus clip. More or less.
data BlitState = BlitState
-- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset
{ _column_offset :: Int
, _row_offset :: Int
-- clip coordinate space is in image space. Which means it's >= 0 and < image_width.
, _skip_columns :: Int
-- >= 0 and < image_height
, _skip_rows :: Int
-- includes consideration of skip_columns. In display space.
-- The number of columns from the next column to be defined to the end of the display for the
-- row.
, _remaining_columns :: Int
-- includes consideration of skip_rows. In display space.
, _remaining_rows :: Int
}
makeLenses ''BlitState
data BlitEnv s = BlitEnv
{ _bg :: Background
, _region :: DisplayRegion
, _mrow_ops :: MRowOps s
}
makeLenses ''BlitEnv
type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a
show (TextSpan ow cw _) = "TextSpan(" ++ show ow ++ ", " ++ show cw ++ ")"
show (Skip ow) = "Skip(" ++ show ow ++ ")"
show (RowEnd ow) = "RowEnd(" ++ show ow ++ ")"
-- | Number of columns the DisplayOps are defined for
span_ops_columns :: DisplayOps -> Int
@ -123,11 +83,15 @@ span_ops_effected_columns :: SpanOps -> Int
span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops
where
span_ops_effected_columns' t (TextSpan w _ _ ) = t + w
span_ops_effected_columns' t (Skip w) = t + w
span_ops_effected_columns' t (RowEnd w) = t + w
span_ops_effected_columns' t _ = t
-- | The width of a single SpanOp in columns
span_op_has_width :: SpanOp -> Maybe (Int, Int)
span_op_has_width (TextSpan ow cw _) = Just (cw, ow)
span_op_has_width (Skip ow) = Just (ow,ow)
span_op_has_width (RowEnd ow) = Just (ow,ow)
span_op_has_width _ = Nothing
-- | returns the number of columns to the character at the given position in the span op
@ -135,239 +99,7 @@ columns_to_char_offset :: Int -> SpanOp -> Int
columns_to_char_offset cx (TextSpan _ _ utf8_str) =
let str = T.unpack (T.decodeUtf8 utf8_str)
in wcswidth (take cx str)
columns_to_char_offset cx (Skip _) = cx
columns_to_char_offset cx (RowEnd _) = cx
columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"
-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the
-- specified region.
spans_for_pic :: Picture -> DisplayRegion -> DisplayOps
spans_for_pic pic r = DisplayOps r $ Vector.create (combined_spans_for_layers pic r)
-- | Produces the span ops for each layer then combines them.
--
-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire
-- region.
combined_spans_for_layers :: Picture -> DisplayRegion -> ST s (MRowOps s)
combined_spans_for_layers pic r = do
layer_ops <- mapM (\layer -> build_spans layer r (pic_background pic)) (pic_layers pic)
case layer_ops of
[] -> fail "empty picture"
[ops] -> return ops
_ -> fail "TODO: picture with more than one layer not supported"
-- | Builds a vector of row operations that will output the given picture to the terminal.
--
-- Crops to the given display region.
--
-- TODO: I'm pretty sure there is an algorithm that does not require a mutable buffer.
build_spans :: Image -> DisplayRegion -> Background -> ST s (MRowOps s)
build_spans image out_region background = do
-- First we create a mutable vector for each rows output operations.
out_ops <- Vector.replicate (region_height out_region) Vector.empty
-- \todo I think building the span operations in display order would provide better performance.
-- However, I got stuck trying to implement an algorithm that did this. This will be considered
-- as a possible future optimization.
--
-- A depth first traversal of the image is performed. ordered according to the column range
-- defined by the image from least to greatest. The output row ops will at least have the
-- region of the image specified. Iterate over all output rows and output background fills for
-- all unspecified columns.
--
-- The images are made into span operations from left to right. It's possible that this could
-- easily be made to assure top to bottom output as well.
when (region_height out_region > 0 && region_width out_region > 0) $ do
-- The ops builder recursively descends the image and outputs span ops that would
-- display that image. The number of columns remaining in this row before exceeding the
-- bounds is also provided. This is used to clip the span ops produced to the display.
let full_build = do
start_image_build image
-- Fill in any unspecified columns with the background pattern.
forM_ [0 .. (region_height out_region - 1)] (add_row_completion out_region)
init_env = BlitEnv background out_region out_ops
init_state = BlitState 0 0 0 0 (region_width out_region) (region_height out_region)
_ <- runStateT (runReaderT full_build init_env) init_state
return ()
return out_ops
-- | Add the operations required to build a given image to the current set of row operations
-- returns the number of columns and rows contributed to the output.
start_image_build :: Image -> BlitM s ()
start_image_build image = do
out_of_bounds <- is_out_of_bounds <$> get
when (not out_of_bounds) $ add_maybe_clipped image
is_out_of_bounds :: BlitState -> Bool
is_out_of_bounds s
| s ^. remaining_columns <= 0 = True
| s ^. remaining_rows <= 0 = True
| otherwise = False
-- TODO: prove skip_columns, skip_rows == 0
-- TODO: prove remaining_columns >= image_width
-- TODO: prove remaining_rows >= image_height
add_unclipped :: Image -> BlitM s ()
add_unclipped EmptyImage = return ()
add_unclipped (HorizText a text_str _ow _cw) = do
use row_offset >>= snoc_op (AttributeChange a)
add_unclipped_text text_str
add_unclipped (HorizJoin part_left part_right _ow _oh) = do
-- TODO: push into env and use
y <- use row_offset
add_unclipped part_left
row_offset .= y
add_unclipped part_right
add_unclipped (VertJoin part_top part_bottom _ow _oh) = do
y <- use row_offset
add_unclipped part_top
row_offset .= y + image_height part_top
add_unclipped part_bottom
-- TODO: assumes background character is 1 column
add_unclipped (BGFill ow oh) = do
Background c a <- view bg
y <- use row_offset
let op = TextSpan ow ow (T.encodeUtf8 $ T.replicate (fromIntegral ow) (T.singleton c))
forM_ [y..y+oh-1] $ \row -> do
snoc_op (AttributeChange a) row
snoc_op op row
-- TODO: we know it's clipped actually, the equations that are exposed that introduce a
-- Crop all assure the image exceeds the crop in the relevant direction.
add_unclipped CropRight {cropped_image, output_width} = do
remaining_columns .= output_width
add_maybe_clipped cropped_image
add_unclipped CropLeft {cropped_image, left_skip} = do
skip_columns .= left_skip
add_maybe_clipped cropped_image
add_unclipped CropBottom {cropped_image, output_height} = do
remaining_rows .= output_height
add_maybe_clipped cropped_image
add_unclipped CropTop {cropped_image, top_skip} = do
skip_rows .= top_skip
add_maybe_clipped cropped_image
-- TODO: prove this cannot be called in an out of bounds case.
add_maybe_clipped :: forall s . Image -> BlitM s ()
add_maybe_clipped EmptyImage = return ()
add_maybe_clipped (HorizText a text_str ow _cw) = do
-- TODO: assumption that text spans are only 1 row high.
s <- use skip_rows
when (s < 1) $ do
use row_offset >>= snoc_op (AttributeChange a)
left_clip <- use skip_columns
right_clip <- use remaining_columns
let left_clipped = left_clip > 0
right_clipped = (ow - left_clip) > right_clip
if left_clipped || right_clipped
then let text_str' = clip_text text_str left_clip right_clip
in add_unclipped_text text_str'
else add_unclipped_text text_str
add_maybe_clipped (VertJoin top_image bottom_image _ow oh) = do
add_maybe_clipped_join "vert_join" skip_rows remaining_rows row_offset
(image_height top_image)
top_image
bottom_image
oh
add_maybe_clipped (HorizJoin left_image right_image ow _oh) = do
add_maybe_clipped_join "horiz_join" skip_columns remaining_columns column_offset
(image_width left_image)
left_image
right_image
ow
add_maybe_clipped BGFill {output_width, output_height} = do
s <- get
let output_width' = min (output_width - s^.skip_columns) (s^.remaining_columns)
output_height' = min (output_height - s^.skip_rows ) (s^.remaining_rows)
add_unclipped (BGFill output_width' output_height')
add_maybe_clipped CropRight {cropped_image, output_width} = do
remaining_columns .= output_width
add_maybe_clipped cropped_image
add_maybe_clipped CropLeft {cropped_image, left_skip} = do
skip_columns += left_skip
add_maybe_clipped cropped_image
add_maybe_clipped CropBottom {cropped_image, output_height} = do
remaining_rows .= output_height
add_maybe_clipped cropped_image
add_maybe_clipped CropTop {cropped_image, top_skip} = do
skip_rows += top_skip
add_maybe_clipped cropped_image
add_maybe_clipped_join :: forall s . String
-> Lens BlitState BlitState Int Int
-> Lens BlitState BlitState Int Int
-> Lens BlitState BlitState Int Int
-> Int
-> Image
-> Image
-> Int
-> BlitM s ()
add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do
state <- get
when (state^.remaining == 0) $ fail $ name ++ " with remaining == 0"
case state^.skip of
s | s >= size -> fail $ name ++ " on fully clipped"
-- TODO: check if clipped in other dim. if not use add_unclipped
| s == 0 -> case state^.remaining of
r | r > i0_dim -> do
add_maybe_clipped i0
put $ state & offset +~ i0_dim & remaining -~ i0_dim
add_maybe_clipped i1
| otherwise -> add_maybe_clipped i0
| s >= i0_dim -> do
put $ state & skip -~ i0_dim
add_maybe_clipped i1
| otherwise -> case i0_dim - s of
i0_dim' | state^.remaining <= i0_dim' -> add_maybe_clipped i0
| otherwise -> do
add_maybe_clipped i0
put $ state & offset +~ i0_dim' & remaining -~ i0_dim'
add_maybe_clipped i1
-- TODO: store a skip list in HorizText(?)
-- TODO: represent display strings containing chars that are not 1 column chars as a separate
-- display string value?
-- TODO: assumes max column width is 2
clip_text :: DisplayText -> Int -> Int -> DisplayText
clip_text txt left_skip right_clip =
-- CPS would clarify this I think
let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0
txt' = if pad_prefix then TL.cons '…' (TL.drop (to_drop+1) txt) else TL.drop to_drop txt
(to_take,pad_suffix) = clip_for_char_width right_clip txt' 0
txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty)
clip_for_char_width 0 _ n = (n, False)
clip_for_char_width w t n
| w < cw = (n, True)
| w == cw = (n+1, False)
| w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)
where cw = safe_wcwidth (TL.head t)
clip_for_char_width _ _ _ = error "clip_for_char_width applied to undefined"
in txt''
add_unclipped_text :: DisplayText -> BlitM s ()
add_unclipped_text txt = do
let op = TextSpan used_display_columns
(fromIntegral $ TL.length txt)
(T.encodeUtf8 $ TL.toStrict txt)
used_display_columns = wcswidth $ TL.unpack txt
use row_offset >>= snoc_op op
-- todo: If there is no background pattern defined then skip to next line.
-- todo: assumes background character is 1 column
add_row_completion :: DisplayRegion -> Int -> BlitM s ()
add_row_completion display_region row = do
all_row_ops <- view mrow_ops
Background c a <- view bg
row_ops <- lift $ lift $ Vector.read all_row_ops row
let end_x = span_ops_effected_columns row_ops
when (end_x < region_width display_region) $ do
let ow = region_width display_region - end_x
op = TextSpan ow ow (T.encodeUtf8 $ T.replicate (fromIntegral ow) (T.singleton c))
snoc_op (AttributeChange a) row
snoc_op op row
-- | snocs the operation to the operations for the given row.
snoc_op :: SpanOp -> Int -> BlitM s ()
snoc_op !op !row = do
the_mrow_ops <- view mrow_ops
lift $ lift $ do
ops <- Vector.read the_mrow_ops row
let ops' = Vector.snoc ops op
Vector.write the_mrow_ops row ops'

13
src/Graphics/Vty/Terminal/Interface.hs
View File

@ -14,6 +14,7 @@ module Graphics.Vty.Terminal.Interface ( module Graphics.Vty.Terminal.Interface
import Data.Marshalling
import Graphics.Vty.Picture
import Graphics.Vty.PictureToSpans
import Graphics.Vty.Span
import Graphics.Vty.DisplayRegion
@ -87,6 +88,8 @@ display_context t r = liftIO $ do
, serialize_set_attr = serialize_set_attr self
, default_attr_required_bytes = default_attr_required_bytes self
, serialize_default_attr = serialize_default_attr self
, row_end_required_bytes = row_end_required_bytes self
, serialize_row_end = serialize_row_end self
, inline_hack = return ()
}
mfix (mk_display_context t . def_context)
@ -119,6 +122,8 @@ data DisplayContext = DisplayContext
-- | Reset the display attributes to the default display attributes
, default_attr_required_bytes :: Int
, serialize_default_attr :: OutputBuffer -> IO OutputBuffer
, row_end_required_bytes :: Int
, serialize_row_end :: OutputBuffer -> IO OutputBuffer
-- | See Graphics.Vty.Terminal.XTermColor.inline_hack
, inline_hack :: IO ()
}
@ -234,6 +239,8 @@ span_op_required_bytes dc fattr (AttributeChange attr) =
fattr' = fix_display_attr fattr attr'
in (c, fattr')
span_op_required_bytes _dc fattr (TextSpan _ _ str) = (utf8_text_required_bytes str, fattr)
span_op_required_bytes _dc _fattr (Skip _) = error "span_op_required_bytes for Skip."
span_op_required_bytes dc fattr (RowEnd _) = (row_end_required_bytes dc, fattr)
serialize_output_ops :: DisplayContext
-> OutputBuffer
@ -269,6 +276,8 @@ serialize_span_ops dc y out_ptr in_fattr span_ops = do
(out_ptr', in_fattr)
span_ops
-- |
-- TODO: move this into the terminal implementation?
serialize_span_op :: DisplayContext
-> SpanOp
-> OutputBuffer
@ -283,6 +292,10 @@ serialize_span_op dc (AttributeChange attr) out_ptr fattr = do
serialize_span_op _dc (TextSpan _ _ str) out_ptr fattr = do
out_ptr' <- serialize_utf8_text str out_ptr
return (out_ptr', fattr)
serialize_span_op _dc (Skip _) _out_ptr _fattr = error "serialize_span_op for Skip"
serialize_span_op dc (RowEnd _) out_ptr fattr = do
out_ptr' <- serialize_row_end dc out_ptr
return (out_ptr', fattr)
send_to_terminal :: Terminal -> Int -> (Ptr Word8 -> IO (Ptr Word8)) -> IO ()
send_to_terminal t c f = allocaBytes (fromEnum c) $ \start_ptr -> do

5
src/Graphics/Vty/Terminal/Mock.hs
View File

@ -79,6 +79,11 @@ mock_terminal r = liftIO $ do
, serialize_default_attr = \ptr -> do
poke ptr (toEnum $ fromEnum 'D')
return $ ptr `plusPtr` 1
-- row end is always visualized as the single character 'E'
, row_end_required_bytes = 1
, serialize_row_end = \ptr -> do
poke ptr (toEnum $ fromEnum 'E')
return $ ptr `plusPtr` 1
}
}

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

@ -47,6 +47,7 @@ data TerminfoCaps = TerminfoCaps
, set_back_color :: CapExpression
, set_default_attr :: CapExpression
, clear_screen :: CapExpression
, clear_eol :: CapExpression
, display_attr_caps :: DisplayAttrCaps
}
@ -109,6 +110,7 @@ reserve_terminal in_ID out_handle = liftIO $ mfix $ \self -> do
<*> pure set_back_cap
<*> require_cap ti "sgr0"
<*> require_cap ti "clear"
<*> require_cap ti "el"
<*> current_display_attr_caps ti
let send_cap s = send_cap_to_terminal self (s terminfo_caps)
maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)
@ -212,7 +214,9 @@ mk_terminfo_display_context terminfo_caps self = do
, attr_required_bytes = \_prev_attr _req_attr _diffs -> assumed_attr_required_bytes
, serialize_set_attr = terminfo_serialize_set_attr self terminfo_caps
, default_attr_required_bytes = cap_expression_required_bytes (set_default_attr terminfo_caps) []
, serialize_default_attr = \out_ptr -> serialize_cap_expression (set_default_attr terminfo_caps) [] out_ptr
, serialize_default_attr = serialize_cap_expression (set_default_attr terminfo_caps) []
, row_end_required_bytes = cap_expression_required_bytes (clear_eol terminfo_caps) []
, serialize_row_end = serialize_cap_expression (clear_eol terminfo_caps) []
}
-- | Instead of evaluating all the rules related to setting display attributes twice (once in

1
test/Verify.hs
View File

@ -59,6 +59,7 @@ verify test_name p = Test $ TestInstance
qc_result <- quickCheckResult p
case qc_result of
QC.Success {..} -> return $ Finished TS.Pass
QC.Failure {output} -> return $ Finished $ TS.Fail output
_ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"
, tags = []
, options = []

6
test/Verify/Data/Terminfo/Parse.hs
View File

@ -12,12 +12,6 @@ import Data.Word
import Numeric
instance Show CapExpression where
show c
= "CapExpression { " ++ show (cap_ops c) ++ " }"
++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! source_string c ) ++ "]"
++ " <= " ++ show (source_string c)
hex_dump :: [Word8] -> String
hex_dump bytes = foldr (\b s -> showHex b s) "" bytes

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

@ -80,9 +80,9 @@ instance Arbitrary SingleAttrSingleSpanStack where
arbitrary = do
image_list <- Verify.resize 128 (listOf1 arbitrary)
let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ]
return $ SingleAttrSingleSpanStack
image
image_list
return $ SingleAttrSingleSpanStack
image
image_list
( maximum $ map expected_columns image_list )
( toEnum $ length image_list )

7
test/VerifySpanOps.hs
View File

@ -2,12 +2,13 @@
{-# LANGUAGE NamedFieldPuns #-}
module VerifySpanOps where
import Verify.Graphics.Vty.Picture
import Verify.Graphics.Vty.Image
import Verify.Graphics.Vty.Span
import Verify.Graphics.Vty.DisplayRegion
import Verify.Graphics.Vty.Image
import Verify.Graphics.Vty.Picture
import Verify.Graphics.Vty.Span
import Graphics.Vty.Debug
import Graphics.Vty.PictureToSpans
import Verify

24
test/VerifyTerminal.hs
View File

@ -18,6 +18,14 @@ import qualified Data.String.UTF8 as UTF8
import System.IO
compare_bytes out_bytes expected_bytes =
if out_bytes /= expected_bytes
then return $ failed { reason = "bytes\n" ++ show out_bytes
++ "\nare not the expected bytes\n"
++ show expected_bytes
}
else return succeeded
unit_image_unit_bounds :: UnitImage -> Property
unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do
(_,t) <- mock_terminal (DisplayRegion 1 1)
@ -49,9 +57,7 @@ single_T_row (MockWindow w h) = liftIOResult $ do
-- character
++ 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 }
else return succeeded
compare_bytes out_bytes expected_bytes
many_T_rows :: MockWindow -> Property
many_T_rows (MockWindow w h) = liftIOResult $ do
@ -66,9 +72,7 @@ many_T_rows (MockWindow w h) = liftIOResult $ do
-- attribute change. 'A', followed by w 'T's
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 }
else return succeeded
compare_bytes out_bytes expected_bytes
many_T_rows_cropped_width :: MockWindow -> Property
many_T_rows_cropped_width (MockWindow w h) = liftIOResult $ do
@ -83,9 +87,7 @@ many_T_rows_cropped_width (MockWindow w h) = liftIOResult $ do
-- attribute change. 'A', followed by w 'T's
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 }
else return succeeded
compare_bytes out_bytes expected_bytes
many_T_rows_cropped_height :: MockWindow -> Property
many_T_rows_cropped_height (MockWindow w h) = liftIOResult $ do
@ -100,9 +102,7 @@ many_T_rows_cropped_height (MockWindow w h) = liftIOResult $ do
-- attribute change. 'A', followed by w count 'T's
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 }
else return succeeded
compare_bytes out_bytes expected_bytes
tests :: IO [Test]
tests = return [ verify "unit_image_unit_bounds" unit_image_unit_bounds

4
test/benchmark.hs
View File

@ -32,10 +32,10 @@ main = do
["-h" ] -> help
_ -> do
let args' = if args /= []
then args
then map (drop 2) args
else map fst benches
-- drop the dash-dash "--"
results <- forM args' $ \(_ : _ : b_name) -> do
results <- forM args' $ \b_name -> do
case lookup b_name benches of
Just b -> bench b_name b
Nothing -> fail $ "No benchmark named " ++ b_name

30
test/current_benchmark_results.txt
View File

@ -1,20 +1,16 @@
pre-release 5.0
no unclipped opt 5.0
on toast
[("no-diff-opt-0",147,8),("render-char-0",332,18),("render-char-1",277,16),("vertical-scroll-0",1503,61),("image-fuzz-0",46,3)]
[("no-diff-opt-0",137,11),("render-char-0",470,18),("render-char-1",254,18),("vertical-scroll-0",1240,56),("image-fuzz-0",46,3)]
release 4.7
starting no-diff-opt-0
user time: 226
system time: 13
starting render-char-0
user time: 411
system time: 22
starting render-char-1
user time: 386
system time: 21
starting vertical-scroll-0
user time: 1930
system time: 96
starting image-fuzz-0
user time: 1225
system time: 52
on ooyala, no screen, iTerm:
* 5.0 initial:
* [("no-diff-opt-0",24,3),("render-char-0",102,8),("render-char-1",41,4),("vertical-scroll-0",226,24),("image-fuzz-0",17,1)]
* post background span replacement:
* [("no-diff-opt-0",26,3),("render-char-0",109,8),("render-char-1",44,5),("vertical-scroll-0",244,26),("image-fuzz-0",17,2)]
* [("no-diff-opt-0",25,4),("render-char-0",110,7),("render-char-1",43,6),("vertical-scroll-0",239,24),("image-fuzz-0",17,2)]
release 4.7 on toast
[("no-diff-opt-0",226,13),("render-char-0",411,22),("render-char-1",386,21),("vertical-scroll-0",1930,96),("image-fuzz-0",1225,52)]

BIN
test/interactive_terminal_test Executable file
View File

Binary file not shown.

2
vty.cabal
View File

@ -58,6 +58,7 @@ library
Graphics.Vty.Error
Graphics.Vty.Image
Graphics.Vty.Inline
Graphics.Vty.Inline.Unsafe
Graphics.Vty.LLInput
Graphics.Vty.Picture
Graphics.Vty.Terminal
@ -79,7 +80,6 @@ library
Graphics.Vty.Terminal.XTermColor
Graphics.Vty.Terminal.TerminfoBased
other-modules: Graphics.Vty.Inline.Hack
c-sources: cbits/gwinsz.c
cbits/set_term_timing.c