mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-10-04 19:27:08 +03:00
Merge branch 'master' of github.com:coreyoconnor/vty
This commit is contained in:
commit
3da7ed057e
27
CHANGELOG
27
CHANGELOG
@ -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:
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 = ()
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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'
|
||||
|
||||
|
@ -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'
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
}
|
||||
|
||||
|
@ -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
|
||||
|
@ -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 = []
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 )
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
BIN
test/interactive_terminal_test
Executable file
Binary file not shown.
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user