ilyakooo0/vty
1
0
Fork 0
mirror of https://github.com/ilyakooo0/vty.git synced 2024-11-29 16:54:42 +03:00
Code Issues Projects Releases Wiki Activity

in progress

Browse Source
This commit is contained in:
Corey O'Connor 2013-05-16 13:44:04 -07:00
parent 052cee932a
commit e973a0de7f
8 changed files with 552 additions and 465 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/Codec/Binary/UTF8/Width.hs
View File

@ -1,33 +0,0 @@
-- Copyright 2009 Corey O'Connor
{-# OPTIONS_GHC -D_XOPEN_SOURCE -fno-cse #-}
{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}
module Codec.Binary.UTF8.Width ( wcwidth
, wcswidth
)
where
import Foreign.C.Types
import Foreign.C.String
import Foreign.Storable
import Foreign.Ptr
import System.IO.Unsafe
wcwidth :: Char -> Int
wcwidth c = unsafePerformIO (withCWString [c] $! \ws -> do
wc <- peek ws
let !w = fromIntegral $! wcwidth' wc
return w
)
{-# NOINLINE wcwidth #-}
foreign import ccall unsafe "vty_mk_wcwidth" wcwidth' :: CWchar -> CInt
wcswidth :: String -> Int
wcswidth str = unsafePerformIO (withCWStringLen str $! \(ws, ws_len) -> do
let !w = fromIntegral $! wcswidth' ws (fromIntegral ws_len)
return w
)
{-# NOINLINE wcswidth #-}
foreign import ccall unsafe "vty_mk_wcswidth" wcswidth' :: Ptr CWchar -> CSize -> CInt

34
src/Graphics/Text/Width.hs Normal file
View File

@ -0,0 +1,34 @@
-- Copyright 2009 Corey O'Connor
{-# OPTIONS_GHC -D_XOPEN_SOURCE #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Graphics.Text.Width ( wcwidth
, wcswidth
, safe_wcwidth
, safe_wcswidth
)
where
foreign import ccall unsafe "vty_mk_wcwidth" wcwidth :: Char -> Int
wcswidth :: String -> Int
wcswidth = sum . map wcwidth
-- XXX: Characters with unknown widths occupy 1 column?
--
-- Not sure if this is actually correct. I presume there is a replacement character that is output
-- by the terminal instead of the character and this replacement character is 1 column wide. If this
-- is not true for all terminals then a per-terminal replacement character width needs to be
-- implemented.
-- | Returns the display width of a character. Assumes all characters with unknown widths are 1 width
safe_wcwidth :: Char -> Int
safe_wcwidth c = case wcwidth c of
i | i < 0 -> 1
| otherwise -> i
-- | Returns the display width of a string. Assumes all characters with unknown widths are 1 width
safe_wcswidth :: String -> Int
safe_wcswidth str = case wcswidth str of
i | i < 0 -> 1
| otherwise -> i

478
src/Graphics/Vty/Image.hs
View File

@ -2,294 +2,140 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Graphics.Vty.Image ( DisplayString
, Image(..)
module Graphics.Vty.Image ( DisplayText
, Image
, image_width
, image_height
, horiz_join
, (<|>)
, vert_join
, (<->)
, horiz_cat
, vert_cat
, background_fill
, text
, strict_text
, char
, string
, iso_10646_string
, utf8_string
, utf8_bytestring
, utf8_strict_bytestring
, char_fill
, empty_image
, translate
, safe_wcwidth
, safe_wcswidth
, wcwidth
, wcswidth
, crop
, crop_right
, crop_left
, crop_bottom
, crop_top
, pad
, resize
, translate
-- | The possible display attributes used in constructing an `Image`.
, module Graphics.Vty.Attributes
)
where
import Graphics.Vty.Attributes
import Graphics.Vty.Image.Internal
import Graphics.Text.Width
import Codec.Binary.UTF8.Width
import Codec.Binary.UTF8.String ( decode )
import Control.DeepSeq
import qualified Data.ByteString as BS
import Data.Monoid
import qualified Data.Sequence as Seq
import qualified Data.String.UTF8 as UTF8
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Data.Word
infixr 5 <|>
infixr 4 <->
-- | We pair each character with it's display length. This way we only compute the length once per
-- character.
-- * Though currently the width of some strings is still compute multiple times.
type DisplayString = Seq.Seq (Char, Word)
-- | An image in VTY defines:
-- | combines two images side by side
--
-- * properties required to display the image. These are properties that effect the output image
-- but are independent of position
-- Combines text chunks where possible. Assures output_width and output_height properties are not
-- violated.
--
-- * A set of position-dependent text and attribute regions. The possible regions are:
-- The result image will have a width equal to the sum of the two images width. And the height will
-- equal the largest height of the two images. The area not defined in one image due to a height
-- missmatch will be filled with the background pattern.
--
-- * a point. ( char )
-- TODO: the bg fill is biased towards top to bottom languages(?)
horiz_join :: Image -> Image -> Image
horiz_join EmptyImage i = i
horiz_join i EmptyImage = i
horiz_join i_0@(HorizText a_0 t_0 w_0 cw_0) i_1@(HorizText a_1 t_1 w_1 cw_1)
| a_0 == a_1 = HorizText a_0 (TL.append t_0 t_1) (w_0 + w_1) (cw_0 + cw_1)
| otherwise = HorizJoin i_0 i_1 (w_0 + w_1) (image_height i_0 + image_height i_1)
horiz_join i_0 i_1
-- If the images are of the same height then no padding is required
| h_0 == h_1 = HorizJoin i_0 i_1 w h_0
-- otherwise one of the images needs to be padded to the right size.
| h_0 < h_1 -- Pad i_0
= let pad_amount = h_1 - h_0
in HorizJoin (VertJoin i_0 (BGFill w_0 pad_amount) w_0 h_1) i_1 w h_1
| h_0 > h_1 -- Pad i_1
= let pad_amount = h_0 - h_1
in HorizJoin i_0 (VertJoin i_1 (BGFill w_1 pad_amount) w_1 h_0) w h_0
where
w_0 = image_width i_0
w_1 = image_width i_1
w = w_0 + w_1
h_0 = image_height i_0
h_1 = image_height i_1
horiz_join _ _ = error "horiz_join applied to undefined values."
-- | combines two images vertically
--
-- * a horizontal line of characters with a single attribute. (string, utf8_string,
-- utf8_bytestring )
-- The result image will have a height equal to the sum of the heights of both images.
-- The width will equal the largest width of the two images.
-- The area not defined in one image due to a width missmatch will be filled with the background
-- pattern.
--
-- * a fill of a single character. (char_fill)
--
-- * a fill of the picture's background. (background_fill)
--
-- todo: increase the number of encoded bytestring formats supported.
data Image =
-- | A horizontal text span is always >= 1 column and has a row height of 1.
HorizText
{ attr :: !Attr
-- All character data is stored as Char sequences with the ISO-10646 encoding.
, text :: DisplayString
, output_width :: !Word -- >= 0
, char_width :: !Word -- >= 1
}
-- | A horizontal join can be constructed between any two images. However a HorizJoin instance is
-- required to be between two images of equal height. The horiz_join constructor adds background
-- filles to the provided images that assure this is true for the HorizJoin value produced.
| HorizJoin
{ part_left :: Image
, part_right :: Image
, output_width :: !Word -- >= 1
, output_height :: !Word -- >= 1
}
-- | A veritical join can be constructed between any two images. However a VertJoin instance is
-- required to be between two images of equal width. The vert_join constructor adds background
-- fills to the provides images that assure this is true for the VertJoin value produced.
| VertJoin
{ part_top :: Image
, part_bottom :: Image
, output_width :: !Word -- >= 1
, output_height :: !Word -- >= 1
}
-- | A background fill will be filled with the background pattern. The background pattern is
-- defined as a property of the Picture this Image is used to form.
| BGFill
{ output_width :: !Word -- >= 1
, output_height :: !Word -- >= 1
}
-- | The combining operators identity constant.
-- EmptyImage <|> a = a
-- EmptyImage <-> a = a
--
-- Any image of zero size equals the empty image.
| EmptyImage
| Translation (Int, Int) Image
-- Crop an image to a size
| ImageCrop (Word, Word) Image
-- Pad an image up to a size
| ImagePad (Word, Word) Image
deriving Eq
instance Show Image where
show ( HorizText { output_width = ow, text = txt } )
= "HorizText [" ++ show ow ++ "] (" ++ show (fmap fst txt) ++ ")"
show ( BGFill { output_width = c, output_height = r } )
= "BGFill (" ++ show c ++ "," ++ show r ++ ")"
show ( HorizJoin { part_left = l, part_right = r, output_width = c } )
= "HorizJoin " ++ show c ++ " ( " ++ show l ++ " <|> " ++ show r ++ " )"
show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } )
= "VertJoin (" ++ show c ++ ", " ++ show r ++ ") ( " ++ show t ++ " ) <-> ( " ++ show b ++ " )"
show ( Translation offset i )
= "Translation " ++ show offset ++ " ( " ++ show i ++ " )"
show ( ImageCrop size i )
= "ImageCrop " ++ show size ++ " ( " ++ show i ++ " )"
show ( ImagePad size i )
= "ImagePad " ++ show size ++ " ( " ++ show i ++ " )"
show ( EmptyImage ) = "EmptyImage"
-- | Currently append in the Monoid instance is equivalent to <->.
instance Monoid Image where
mempty = empty_image
mappend = (<->)
instance NFData Image where
rnf EmptyImage = ()
rnf (Translation s i) = s `deepseq` i `deepseq` ()
rnf (ImagePad s i) = s `deepseq` i `deepseq` ()
rnf (ImageCrop s i) = s `deepseq` i `deepseq` ()
rnf (BGFill !w !h) = ()
rnf (VertJoin t b !w !h) = t `deepseq` b `deepseq` ()
rnf (HorizJoin l r !w !h) = l `deepseq` r `deepseq` ()
rnf (HorizText !a s !w !cw) = s `deepseq` ()
-- A horizontal text image of 0 characters in width simplifies to the EmptyImage
horiz_text :: Attr -> DisplayString -> Word -> Image
horiz_text a txt ow
| ow == 0 = EmptyImage
| otherwise = HorizText a txt ow (toEnum $ Seq.length txt)
horiz_join :: Image -> Image -> Word -> Word -> Image
horiz_join i_0 i_1 w h
-- A horiz join of two 0 width images simplifies to the EmptyImage
| w == 0 = EmptyImage
-- A horizontal join where either part is 0 columns in width simplifies to the other part.
-- This covers the case where one part is the EmptyImage.
| image_width i_0 == 0 = i_1
| image_width i_1 == 0 = i_0
-- If the images are of the same height then no BG padding is required
| image_height i_0 == image_height i_1 = HorizJoin i_0 i_1 w h
-- otherwise one of the imagess needs to be padded to the right size.
| image_height i_0 < image_height i_1 -- Pad i_0
= let pad_amount = image_height i_1 - image_height i_0
in horiz_join ( vert_join i_0
( BGFill ( image_width i_0 ) pad_amount )
( image_width i_0 )
( image_height i_1 )
)
i_1
w h
| image_height i_0 > image_height i_1 -- Pad i_1
= let pad_amount = image_height i_0 - image_height i_1
in horiz_join i_0
( vert_join i_1
( BGFill ( image_width i_1 ) pad_amount )
( image_width i_1 )
( image_height i_0 )
)
w h
horiz_join _ _ _ _ = error "horiz_join applied to undefined values."
vert_join :: Image -> Image -> Word -> Word -> Image
vert_join i_0 i_1 w h
-- A vertical join of two 0 height images simplifies to the EmptyImage
| h == 0 = EmptyImage
-- A vertical join where either part is 0 rows in height simplifies to the other part.
-- This covers the case where one part is the EmptyImage
| image_height i_0 == 0 = i_1
| image_height i_1 == 0 = i_0
-- TODO: the bg fill is biased towards right to left languages(?)
vert_join :: Image -> Image -> Image
vert_join EmptyImage i = i
vert_join i EmptyImage = i
vert_join i_0 i_1
-- If the images are of the same height then no background padding is required
| image_width i_0 == image_width i_1 = VertJoin i_0 i_1 w h
| w_0 == w_1 = VertJoin i_0 i_1 w_0 h
-- Otherwise one of the images needs to be padded to the size of the other image.
| image_width i_0 < image_width i_1
= let pad_amount = image_width i_1 - image_width i_0
in vert_join ( horiz_join i_0
( BGFill pad_amount ( image_height i_0 ) )
( image_width i_1 )
( image_height i_0 )
)
i_1
w h
| image_width i_0 > image_width i_1
= let pad_amount = image_width i_0 - image_width i_1
in vert_join i_0
( horiz_join i_1
( BGFill pad_amount ( image_height i_1 ) )
( image_width i_0 )
( image_height i_1 )
)
w h
vert_join _ _ _ _ = error "vert_join applied to undefined values."
| w_0 < w_1
= let pad_amount = w_1 - w_0
in VertJoin (HorizJoin i_0 (BGFill pad_amount h_0) w_1 h_0) i_1 w_1 h
| w_0 > w_1
= let pad_amount = w_0 - w_1
in VertJoin i_0 (HorizJoin i_1 (BGFill pad_amount h_1) w_0 h_1) w_0 h
where
w_0 = image_width i_0
w_1 = image_width i_1
h_0 = image_height i_0
h_1 = image_height i_1
h = h_0 + h_1
vert_join _ _ = error "vert_join applied to undefined values."
-- | An area of the picture's bacground (See Background) of w columns and h rows.
background_fill :: Word -> Word -> Image
background_fill :: Int -> Int -> Image
background_fill w h
| w == 0 = EmptyImage
| h == 0 = EmptyImage
| otherwise = BGFill w h
-- | The width of an Image. This is the number display columns the image will occupy.
image_width :: Image -> Word
image_width HorizText { output_width = w } = w
image_width HorizJoin { output_width = w } = w
image_width VertJoin { output_width = w } = w
image_width BGFill { output_width = w } = w
image_width EmptyImage = 0
image_width ( Translation v i ) = toEnum $ max 0 $ (fst v +) $ fromEnum $ image_width i
image_width ( ImageCrop v i ) = min (image_width i) $ fst v
image_width ( ImagePad v i ) = max (image_width i) $ fst v
-- | The height of an Image. This is the number of display rows the image will occupy.
image_height :: Image -> Word
image_height HorizText {} = 1
image_height HorizJoin { output_height = r } = r
image_height VertJoin { output_height = r } = r
image_height BGFill { output_height = r } = r
image_height EmptyImage = 0
image_height ( Translation v i ) = toEnum $ max 0 $ (snd v +) $ fromEnum $ image_height i
image_height ( ImageCrop v i ) = min (image_height i) $ snd v
image_height ( ImagePad v i ) = max (image_height i) $ snd v
-- | Combines two images side by side.
-- | Combines two images horizontally. Alias for horiz_join
--
-- The result image will have a width equal to the sum of the two images width. And the height will
-- equal the largest height of the two images. The area not defined in one image due to a height
-- missmatch will be filled with the background pattern.
-- infixr 5
(<|>) :: Image -> Image -> Image
(<|>) = horiz_join
-- Two horizontal text spans with the same attributes can be merged.
h0@(HorizText attr_0 text_0 ow_0 _) <|> h1@(HorizText attr_1 text_1 ow_1 _)
| attr_0 == attr_1 = horiz_text attr_0 (text_0 Seq.>< text_1) (ow_0 + ow_1)
| otherwise = horiz_join h0 h1 (ow_0 + ow_1) 1
-- Anything placed to the right of a join wil be joined to the right sub image.
-- The total columns for the join is the sum of the two arguments columns
h0@( HorizJoin {} ) <|> h1
= horiz_join ( part_left h0 )
( part_right h0 <|> h1 )
( image_width h0 + image_width h1 )
( max (image_height h0) (image_height h1) )
-- Anything but a join placed to the left of a join wil be joined to the left sub image.
-- The total columns for the join is the sum of the two arguments columns
h0 <|> h1@( HorizJoin {} )
= horiz_join ( h0 <|> part_left h1 )
( part_right h1 )
( image_width h0 + image_width h1 )
( max (image_height h0) (image_height h1) )
h0 <|> h1
= horiz_join h0
h1
( image_width h0 + image_width h1 )
( max (image_height h0) (image_height h1) )
-- | Combines two images vertically.
-- The result image will have a height equal to the sum of the heights of both images.
-- The width will equal the largest width of the two images.
-- The area not defined in one image due to a width missmatch will be filled with the background
-- pattern.
-- | Combines two images vertically. Alias for vert_join
--
-- infixr 4
(<->) :: Image -> Image -> Image
im_t <-> im_b
= vert_join im_t
im_b
( max (image_width im_t) (image_width im_b) )
( image_height im_t + image_height im_b )
(<->) = vert_join
-- | Compose any number of images horizontally.
horiz_cat :: [Image] -> Image
@ -299,12 +145,26 @@ horiz_cat = foldr (<|>) EmptyImage
vert_cat :: [Image] -> Image
vert_cat = foldr (<->) EmptyImage
-- | A Data.Text.Lazy value
text :: Attr -> TL.Text -> Image
text a txt
| TL.length txt == 0 = EmptyImage
| otherwise = let display_width = safe_wcswidth (TL.unpack txt)
in HorizText a txt display_width (fromIntegral $! TL.length txt)
-- | A Data.Text value
strict_text :: Attr -> T.Text -> Image
strict_text a txt
| T.length txt == 0 = EmptyImage
| otherwise = let display_width = safe_wcswidth (T.unpack txt)
in HorizText a (TL.fromStrict txt) display_width (T.length txt)
-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in
-- the ISO-10646 encoding.
char :: Attr -> Char -> Image
char !a !c =
char a c =
let display_width = safe_wcwidth c
in HorizText a (Seq.singleton (c, display_width)) display_width 1
in HorizText a (TL.singleton c) display_width 1
-- | A string of characters layed out on a single row with the same display attribute. The string is
-- assumed to be a sequence of ISO-10646 characters.
@ -316,9 +176,9 @@ char !a !c =
-- directly to iso_10646_string or string.
--
iso_10646_string :: Attr -> String -> Image
iso_10646_string !a !str =
let display_text = Seq.fromList $ map (\c -> (c, safe_wcwidth c)) str
in horiz_text a display_text (safe_wcswidth str)
iso_10646_string a str =
let display_width = safe_wcswidth str
in HorizText a (TL.pack str) display_width (length str)
-- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is
-- represented internally as a list of ISO 10646 31 bit characters.
@ -329,62 +189,110 @@ iso_10646_string !a !str =
string :: Attr -> String -> Image
string = iso_10646_string
-- | A string of characters layed out on a single row. The string is assumed to be a sequence of
-- UTF-8 characters.
-- | A string of characters layed out on a single row. The input is assumed to be the bytes for
-- UTF-8 encoded text.
utf8_string :: Attr -> [Word8] -> Image
utf8_string !a !str = string a ( decode str )
utf8_string a bytes = utf8_bytestring a (BL.pack bytes)
-- XXX: Characters with unknown widths occupy 1 column?
--
-- Not sure if this is actually correct. I presume there is a replacement character that is output
-- by the terminal instead of the character and this replacement character is 1 column wide. If this
-- is not true for all terminals then a per-terminal replacement character width needs to be
-- implemented.
-- | Renders a UTF-8 encoded lazy bytestring.
utf8_bytestring :: Attr -> BL.ByteString -> Image
utf8_bytestring a bs = text a (TL.decodeUtf8 bs)
-- | Returns the display width of a character. Assumes all characters with unknown widths are 1 width
safe_wcwidth :: Char -> Word
safe_wcwidth c = case wcwidth c of
i | i < 0 -> 1
| otherwise -> toEnum i
-- | Returns the display width of a string. Assumes all characters with unknown widths are 1 width
safe_wcswidth :: String -> Word
safe_wcswidth str = case wcswidth str of
i | i < 0 -> 1
| otherwise -> toEnum i
-- | Renders a UTF-8 encoded bytestring.
utf8_bytestring :: Attr -> BS.ByteString -> Image
utf8_bytestring !a !bs = string a (UTF8.toString $ UTF8.fromRep bs)
-- | Renders a UTF-8 encoded strict bytestring.
utf8_strict_bytestring :: Attr -> B.ByteString -> Image
utf8_strict_bytestring a bs = strict_text a (T.decodeUtf8 bs)
-- | creates a fill of the specified character. The dimensions are in number of characters wide and
-- number of rows high.
--
-- Unlike the Background fill character this character can have double column display width.
char_fill :: Enum d => Attr -> Char -> d -> d -> Image
char_fill !a !c w h =
vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) $ char a c
char_fill :: Integral d => Attr -> Char -> d -> d -> Image
char_fill _a _c 0 _h = EmptyImage
char_fill _a _c _w 0 = EmptyImage
char_fill a c w h =
vert_cat $ replicate (fromIntegral h) $ HorizText a txt display_width char_width
where
txt = TL.replicate (fromIntegral w) (TL.singleton c)
display_width = safe_wcwidth c * (fromIntegral w)
char_width = fromIntegral w
-- | The empty image. Useful for fold combinators. These occupy no space nor define any display
-- attributes.
empty_image :: Image
empty_image = EmptyImage
-- | Apply the given offset to the image.
translate :: (Int, Int) -> Image -> Image
translate v i = Translation v i
-- | pad the given image. This adds background character fills to the left, top, right, bottom.
pad :: Int -> Int -> Int -> Int -> Image -> Image
pad 0 0 0 0 i = i
pad in_l in_t in_r in_b in_image
| in_l < 0 || in_t < 0 || in_r < 0 || in_b < 0 = error "cannot pad by negative amount"
| otherwise = go in_l in_t in_r in_b in_image
where
-- TODO: uh.
go 0 0 0 0 i = i
go 0 0 0 b i = VertJoin i (BGFill w b) w h
where w = image_width i
h = image_height i + b
go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h
where w = image_width i + r
h = image_height i
go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h
where w = image_width i
h = image_height i + t
go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h
where w = image_width i + l
h = image_height i
-- | Ensure an image is no larger than the provided size. If the image is larger then crop.
crop :: (Word, Word) -> Image -> Image
crop (0,_) _ = EmptyImage
crop (_,0) _ = EmptyImage
crop v (ImageCrop _size i) = ImageCrop (min (fst v) (fst _size), min (snd v) (snd _size)) i
crop v i = ImageCrop v i
-- | "translates" an image by padding the top and left.
translate :: Int -> Int -> Image -> Image
translate x y i = pad x y 0 0 i
-- | Ensure an image is at least the provided size. If the image is smaller then pad.
pad :: (Word, Word) -> Image -> Image
pad (0,_) _ = EmptyImage
pad (_,0) _ = EmptyImage
pad v (ImagePad _size i) = ImagePad (max (fst v) (fst _size), max (snd v) (snd _size)) i
pad v i = ImagePad v i
-- | Ensure an image is no larger than the provided size. If the image is larger then crop the right
-- or bottom.
--
-- This is transformed to a vertical crop from the bottom followed by horizontal crop from the
-- right.
crop :: Int -> Int -> Image -> Image
crop 0 _ _ = EmptyImage
crop _ 0 _ = EmptyImage
crop w h i = crop_bottom h (crop_right w i)
-- | crop the display height. If the image is less than or equal in height then this operation has
-- no effect. Otherwise the image is cropped from the bottom.
crop_bottom :: Int -> Image -> Image
crop_bottom 0 _ = EmptyImage
crop_bottom h in_i
| h < 0 = error "cannot crop height to less than zero"
| otherwise = go in_i
where
go EmptyImage = EmptyImage
go (CropBottom {cropped_image, output_width, output_height}) =
CropBottom cropped_image output_width (min h output_height)
go i
| h >= image_height i = i
| otherwise = CropBottom i (image_width i) h
crop_right :: Int -> Image -> Image
crop_right 0 _ = EmptyImage
crop_right w in_i
| w < 0 = error "cannot crop width to less than zero"
| otherwise = go in_i
where
go EmptyImage = EmptyImage
go (CropRight {cropped_image, output_width, output_height}) =
CropRight cropped_image (min w output_width) output_height
go i
| w >= image_width i = i
| otherwise = CropRight i w (image_height i)
crop_left :: Int -> Image -> Image
crop_left _ _ = error "not implemented"
crop_top :: Int -> Image -> Image
crop_top _ _ = error "not implemented"
-- | Generic resize. Pads and crops as required to assure the given display width and height.
-- This is biased to pad the right and bottom.
resize :: Int -> Int -> Image -> Image
resize _w _h _i = error "not implemented yet"

162
src/Graphics/Vty/Image/Internal.hs Normal file
View File

@ -0,0 +1,162 @@
{-# LANGUAGE NamedFieldPuns #-}
module Graphics.Vty.Image.Internal where
import Graphics.Vty.Attributes
import Control.DeepSeq
import qualified Data.Text.Lazy as TL
-- | A display text is a Data.Text.Lazy
--
-- TODO(corey): hm. there is an explicit equation for each type which goes to a lazy text. Each
-- application probably uses a single type. Perhaps parameterize the entire vty interface by the
-- input text type?
type DisplayText = TL.Text
-- | An image in VTY is
--
-- * a horizontal line of characters with a single attribute.
-- * a fill of the picture's background. (background_fill)
-- * a horizontal and vertical crops from both directions.
-- * horizontal and vertical combinations
data Image =
-- | A horizontal text span is always >= 1 column and has a row height of 1.
HorizText
{ attr :: Attr
-- | The text to display. The display width of the text is always output_width.
, display_text :: DisplayText
-- | The number of display columns for the text.
, output_width :: Int
-- | the number of characters in the text.
, char_width :: Int
}
-- | 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.
| HorizJoin
{ part_left :: Image
, part_right :: Image
, output_width :: Int -- ^ image_width part_left == image_width part_right. Always > 1
, output_height :: Int -- ^ image_height part_left == image_height part_right. Always > 0
}
-- | A veritical join can be constructed between any two images. However a VertJoin instance is
-- required to be between two images of equal width. The vert_join constructor adds background
-- fills to the provides images that assure this is true for the VertJoin value produced.
| VertJoin
{ part_top :: Image
, part_bottom :: Image
, output_width :: Int -- ^ image_width part_top == image_width part_bottom. always > 0
, output_height :: Int -- ^ image_height part_top == image_height part_bottom. always > 1
}
-- | A background fill will be filled with the background char. The background char is
-- defined as a property of the Picture this Image is used to form.
| BGFill
{ output_width :: Int -- ^ always > 0
, output_height :: Int -- ^ always > 0
}
-- | Crop an image horizontally to a size by reducing the size from the right.
| CropRight
{ cropped_image :: Image
-- | Always < image_width cropped_image > 0
, output_width :: Int
, output_height :: Int -- ^ image_height cropped_image
}
-- | Crop an image horizontally to a size by reducing the size from the left.
| CropLeft
{ cropped_image :: Image
-- | Always < image_width cropped_image > 0
, left_skip :: Int
-- | Always < image_width cropped_image > 0
, output_width :: Int
, output_height :: Int
}
-- | Crop an image vertically to a size by reducing the size from the bottom
| CropBottom
{ cropped_image :: Image
-- | image_width cropped_image
, output_width :: Int
-- | height image is cropped to. Always < image_height cropped_image > 0
, output_height :: Int
}
-- | Crop an image vertically to a size by reducing the size from the top
| CropTop
{ cropped_image :: Image
-- | Always < image_height cropped_image > 0
, top_skip :: Int
-- | image_width cropped_image
, output_width :: Int
-- | Always < image_height cropped_image > 0
, output_height :: Int
}
-- | The empty image
--
-- The combining operators identity constant.
-- EmptyImage <|> a = a
-- EmptyImage <-> a = a
--
-- Any image of zero size equals the empty image.
| EmptyImage
deriving Eq
instance Show Image where
show ( HorizText { attr, display_text, output_width, char_width } )
= "HorizText \"" ++ show display_text ++ "\""
++ "@(" ++ show attr ++ ","
++ show output_width ++ ","
++ show char_width ++ ")"
show ( BGFill { output_width, output_height } )
= "BGFill (" ++ show output_width ++ "," ++ show output_height ++ ")"
show ( HorizJoin { part_left = l, part_right = r, output_width = c } )
= "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"
show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } )
= "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"
show ( CropRight { cropped_image, output_width, output_height } )
= "CropRight [" ++ show output_width ++ "," ++ show output_height ++ "]"
++ " (" ++ show cropped_image ++ ")"
show ( CropLeft { cropped_image, left_skip, output_width, output_height } )
= "CropLeft [" ++ show left_skip ++ "," ++ show output_width ++ "," ++ show output_height ++ "]"
++ " (" ++ show cropped_image ++ ")"
show ( CropBottom { cropped_image, output_width, output_height } )
= "CropBottom [" ++ show output_width ++ "," ++ show output_height ++ "]"
++ " (" ++ show cropped_image ++ ")"
show ( CropTop { cropped_image, top_skip, output_width, output_height } )
= "CropTop [" ++ show top_skip ++ "," ++ show output_width ++ "," ++ show output_height ++ "]"
++ " (" ++ show cropped_image ++ ")"
show ( EmptyImage ) = "EmptyImage"
instance NFData Image where
rnf EmptyImage = ()
rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` ()
rnf (CropLeft i s w h) = i `deepseq` s `seq` w `seq` h `seq` ()
rnf (CropBottom i w h) = i `deepseq` w `seq` h `seq` ()
rnf (CropTop i s w h) = i `deepseq` s `seq` w `seq` h `seq` ()
rnf (BGFill w h) = w `seq` h `seq` ()
rnf (VertJoin t b w h) = t `deepseq` b `deepseq` w `seq` h `seq` ()
rnf (HorizJoin l r w h) = l `deepseq` r `deepseq` w `seq` h `seq` ()
rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` ()
-- | The width of an Image. This is the number display columns the image will occupy.
image_width :: Image -> Int
image_width HorizText { output_width = w } = w
image_width HorizJoin { output_width = w } = w
image_width VertJoin { output_width = w } = w
image_width BGFill { output_width = w } = w
image_width CropRight { output_width = w } = w
image_width CropLeft { output_width = w } = w
image_width CropBottom { output_width = w } = w
image_width CropTop { output_width = w } = w
image_width EmptyImage = 0
-- | The height of an Image. This is the number of display rows the image will occupy.
image_height :: Image -> Int
image_height HorizText {} = 1
image_height HorizJoin { output_height = h } = h
image_height VertJoin { output_height = h } = h
image_height BGFill { output_height = h } = h
image_height CropRight { output_height = h } = h
image_height CropLeft { output_height = h } = h
image_height CropBottom { output_height = h } = h
image_height CropTop { output_height = h } = h
image_height EmptyImage = 0

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

@ -83,8 +83,10 @@ instance NFData Cursor where
-- 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
{ background_char :: Char
{ background_char :: Char
, background_attr :: Attr
}

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

@ -1,3 +1,5 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}
-- Copyright 2009-2010 Corey O'Connor
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
@ -10,28 +12,37 @@ module Graphics.Vty.Span
where
import Graphics.Vty.Image
import Graphics.Vty.Image.Internal
import Graphics.Vty.Picture
import Graphics.Vty.DisplayRegion
import Graphics.Text.Width
import Codec.Binary.UTF8.String ( encode )
import Control.Lens
import Control.Monad ( forM_ )
import Control.Monad.Reader.Strict
import Control.Monad.State.Strict
import Control.Monad.ST.Strict hiding ( unsafeIOToST )
import Control.Monad.ST.Unsafe ( unsafeIOToST )
import Data.Monoid
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 B
import qualified Data.ByteString.Internal as BInt
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Internal as BLInt
import qualified Data.Foldable as Foldable
import qualified Data.String.UTF8 as UTF8
import qualified Data.Text.Lazy as TL
import Data.Word
import Foreign.Storable ( pokeByteOff )
-- | Currently append in the Monoid instance is equivalent to <->.
instance Monoid Image where
mempty = EmptyImage
mappend = (<->)
{- | A picture is translated into a sequences of state changes and character spans.
- State changes are currently limited to new attribute values. The attribute is applied to all
- following spans. Including spans of the next row. The nth element of the sequence represents the
@ -96,19 +107,19 @@ data SpanOp =
-- | 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 !Word !Word (UTF8.UTF8 B.ByteString)
| TextSpan !Int !Int BL.ByteString
deriving Eq
-- | The width of a single SpanOp in columns
span_op_has_width :: SpanOp -> Maybe (Word, Word)
span_op_has_width :: SpanOp -> Maybe (Int, Int)
span_op_has_width (TextSpan ow cw _) = Just (cw, ow)
span_op_has_width _ = Nothing
-- | returns the number of columns to the character at the given position in the span op
columns_to_char_offset :: Word -> SpanOp -> Word
columns_to_char_offset :: Int -> SpanOp -> Int
columns_to_char_offset cx (TextSpan _ _ utf8_str) =
let str = UTF8.toString utf8_str
in toEnum $! sum $! map wcwidth $! take (fromEnum cx) str
let str = TL.unpack (TL.decodeUtf8 utf8_str)
in wcswidth (take cx str)
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
@ -116,13 +127,41 @@ columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op
spans_for_pic :: Picture -> DisplayRegion -> DisplayOps
spans_for_pic pic r = DisplayOps r $ Vector.create (build_spans pic r)
-- transform plus clip. More or less.
newtype BlitState = BlitState
-- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset
{ _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
newtype 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
-- | Builds a vector of row operations that will output the given picture to the terminal.
--
-- Crops to the given display region.
build_spans :: Picture -> DisplayRegion -> ST s (MRowOps s)
build_spans pic region = do
-- First we create a mutable vector for each rows output operations.
mrow_ops <- Vector.replicate (fromEnum $ region_height region) Vector.empty
mrow_ops <- Vector.replicate (region_height 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.
@ -140,16 +179,13 @@ build_spans pic region = do
-- 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.
-- The skip dimensions provided do....???
_ <- row_ops_for_image mrow_ops
(pic_image pic)
(pic_background pic)
region
(0,0)
0
(region_width region)
(fromEnum $ region_height region)
_ <- runStateT (runReaderT (start_image_build $ pic_image pic)
(BlitEnv (pic_background pic) region mrow_ops)
)
(BlitState 0 0 0 0 (region_width region) (region_height region))
-- Fill in any unspecified columns with the background pattern.
forM_ [0 .. (fromEnum $ region_height region - 1)] $! \row -> do
-- todo: If there is no background pattern defined then skip
forM_ [0 .. (region_height region - 1)] $! \row -> do
end_x <- Vector.read mrow_ops row >>= return . span_ops_effected_columns
if end_x < region_width region
then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row
@ -157,31 +193,39 @@ build_spans pic region = do
else return ()
return mrow_ops
-- | Add the operations required to build a given image to the current set of row operations.
row_ops_for_image :: MRowOps s -> Image -> Background -> DisplayRegion -> (Word, Word) -> Int -> Word -> Int -> ST s (Word, Word)
row_ops_for_image mrow_ops -- the image to output the ops to
image -- the image to rasterize in column order to mrow_ops
bg -- the background fill
region -- ???
skip_dim@(skip_row,skip_col) -- the number of rows
y -- ???
remaining_columns -- ???
remain_rows
| remaining_columns == 0 = return skip_dim
| remain_rows == 0 = return skip_dim
| y >= fromEnum (region_height region) = return skip_dim
| otherwise = case image of
EmptyImage -> return skip_dim
-- The width provided is the number of columns this text span will occupy when displayed.
-- if this is greater than the number of remaining columsn the output has to be produced a
-- character at a time.
HorizText a text_str _ _ -> do
if skip_row > 0
then return (skip_row - 1, skip_col)
else do
skip_col' <- snoc_text_span a text_str mrow_ops skip_col y remaining_columns
return (skip_row, skip_col')
VertJoin top_image bottom_image _ _ -> do
-- | 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 image <$> get
if out_of_bounds
then return (0,0)
else add_maybe_clipped image
is_out_of_bounds :: Image -> BlitState -> Bool
is_out_of_bounds image s
| s ^. remaining_columns <= 0 = True
| s ^. remain_rows <= 0 = True
| otherwise = False
add_maybe_clipped :: Image -> BlitM s ()
add_maybe_clipped EmptyImage = return ()
-- The width provided is the number of columns this text span will occupy when displayed.
-- if this is greater than the number of remaining columsn the output has to be produced a
-- character at a time.
--
-- TODO: prove this cannot be called in fully clipped case
add_maybe_clipped (HorizText text_str _ow _cw) =
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 left_clip right_clip
in render_unclipped_text_span text_str'
else render_unclipped_text_span text_str
process_image (VertJoin top_image bottom_image _ _) = do
(skip_row',skip_col') <- row_ops_for_image mrow_ops
top_image
bg
@ -190,7 +234,7 @@ row_ops_for_image mrow_ops -- the image to output the ops t
y
remaining_columns
remain_rows
let top_height = (fromEnum $! image_height top_image) - (fromEnum $! skip_row - skip_row')
let top_height = (image_height top_image) - (skip_row - skip_row')
(skip_row'',skip_col'') <- row_ops_for_image mrow_ops
bottom_image
bg
@ -210,9 +254,9 @@ row_ops_for_image mrow_ops -- the image to output the ops t
(skip_row'',skip_col'') <- row_ops_for_image mrow_ops r bg region (skip_row, skip_col') y (remaining_columns - image_width l + (skip_col - skip_col')) remain_rows
return (min skip_row' skip_row'', skip_col'')
BGFill width height -> do
let min_height = if y + (fromEnum height) > (fromEnum $! region_height region)
then region_height region - (toEnum y)
else min height (toEnum remain_rows)
let min_height = if y + height > (region_height region)
then region_height region - y
else min height remain_rows
min_width = min width remaining_columns
actual_height = if skip_row > min_height
then 0
@ -220,7 +264,7 @@ row_ops_for_image mrow_ops -- the image to output the ops t
actual_width = if skip_col > min_width
then 0
else min_width - skip_col
forM_ [y .. y + fromEnum actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y'
forM_ [y .. y + actual_height - 1] $! \y' -> snoc_bg_fill mrow_ops bg actual_width y'
let skip_row' = if actual_height > skip_row
then 0
else skip_row - min_height
@ -228,101 +272,37 @@ row_ops_for_image mrow_ops -- the image to output the ops t
then 0
else skip_col - min_width
return (skip_row',skip_col')
Translation (dx,dy) i -> do
if dx < 0
-- Translation left
-- Extract the delta and add it to skip_col.
then row_ops_for_image mrow_ops (translate (0, dy) i) bg region (skip_row, skip_col + dw) y remaining_columns remain_rows
-- Translation right
else if dy < 0
-- Translation up
-- Extract the delta and add it to skip_row.
then row_ops_for_image mrow_ops (translate (dx, 0) i) bg region (skip_row + dh, skip_col) y remaining_columns remain_rows
-- Translation down
-- Pad the start of lines and above the image with a
-- background_fill image
else row_ops_for_image mrow_ops (background_fill ow dh <-> (background_fill dw ih <|> i)) bg region skip_dim y remaining_columns remain_rows
where
dw = toEnum $ abs dx
dh = toEnum $ abs dy
ow = image_width image
ih = image_height i
ImageCrop (max_w,max_h) i ->
row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w) (min remain_rows $ fromEnum max_h)
ImagePad (min_w,min_h) i -> do
let hpad = if image_width i < min_w
then background_fill (min_w - image_width i) (image_height i)
else empty_image
let vpad = if image_height i < min_h
then background_fill (image_width i) (min_h - image_height i)
else empty_image
row_ops_for_image mrow_ops ((i <|> hpad) <-> vpad) bg region skip_dim y remaining_columns remain_rows
row_ops_for_image mrow_ops i bg region skip_dim y (min remaining_columns max_w) (min remain_rows max_h)
snoc_text_span :: Attr -- the display attributes of the text span
-> DisplayString -- the text to output
-> MRowOps s -- the display operations to add to
-> Word -- the number of display columns in the text span to
-- skip before outputting
-> Int -- the row of the display operations to add to
-> Word -- the number of columns from the next column to be
-- defined to the end of the display for the row.
-> ST s Word
snoc_text_span a text_str mrow_ops columns_to_skip y remaining_columns = do
{-# SCC "snoc_text_span-pre" #-} snoc_op mrow_ops y $! AttributeChange a
-- At most a text span will consist of remaining_columns characters
-- we keep track of the position of the next character.
let max_len :: Int = fromEnum remaining_columns
mspan_chars <- Vector.new max_len
( used_display_columns, display_columns_skipped, used_char_count )
<- {-# SCC "snoc_text_span-foldlM" #-} Foldable.foldlM (build_text_span mspan_chars) ( 0, 0, 0 ) text_str
-- once all characters have been output to mspan_chars we grab the used head
out_text <- Vector.unsafeFreeze $! Vector.take used_char_count mspan_chars
-- convert to UTF8 bytestring.
-- This could be made faster. Hopefully the optimizer does a fair job at fusing the fold
-- contained in fromString with the unfold in toList. No biggy right now then.
{-# SCC "snoc_text_span-post" #-} snoc_op mrow_ops y $! TextSpan used_display_columns (toEnum used_char_count)
$! UTF8.fromString
$! Vector.toList out_text
return $ columns_to_skip - display_columns_skipped
where
build_text_span mspan_chars (!used_display_columns, !display_columns_skipped, !used_char_count)
(out_char, char_display_width) = {-# SCC "build_text_span" #-}
-- Only valid if the maximum width of a character is 2 display columns.
-- XXX: Optimize into a skip pass then clipped fill pass
if display_columns_skipped == columns_to_skip
then if used_display_columns == remaining_columns
then return $! ( used_display_columns, display_columns_skipped, used_char_count )
else if ( used_display_columns + char_display_width ) > remaining_columns
then do
Vector.unsafeWrite mspan_chars used_char_count '…'
return $! ( used_display_columns + 1
, display_columns_skipped
, used_char_count + 1
)
else do
Vector.unsafeWrite mspan_chars used_char_count out_char
return $! ( used_display_columns + char_display_width
, display_columns_skipped
, used_char_count + 1
)
else if (display_columns_skipped + char_display_width) > columns_to_skip
then do
Vector.unsafeWrite mspan_chars used_char_count '…'
return $! ( used_display_columns + 1
, columns_to_skip
, used_char_count + 1
)
else return $ ( used_display_columns
, display_columns_skipped + char_display_width
, used_char_count
)
render_clipped_text_span :: DisplayString -> Int -> Int -> BlitM ()
render_clipped_text_span txt left_skip right_clip = do
use row_offset >>= snoc_op (AttributeChange a)
-- TODO: store a skip list in HorizText
let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0
txt' = TL.append (if pad_prefix then TL.singleton '…' else TL.empty) (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 1 t n
| wcwidth (TL.head t) == 1 = (n+1, False)
| otherwise = (n, True)
clip_for_char_width lc t n
= apply_left_clip (lc - wcwidth (TL.head t)) (TL.rest t) (n + 1)
render_unclipped_text_span a txt''
render_unclipped_text_span :: DisplayString -> BlitM ()
render_unclipped_text_span txt = do
let op = TextSpan used_display_columns (TL.length txt) (TL.encodeUtf8 txt)
used_display_columns = wcswidth $ TL.unpack txt
use row_offset >>= snoc_op op
-- | Add a background fill of the given column width to the row display operations.
--
-- This has a fast path for background characters that are a single column and a single byte.
-- Otherwise this has to compute the width of the background character and replicate a sequence of
-- bytes to fill in the required width.
snoc_bg_fill :: MRowOps s -> Background -> Word -> Int -> ST s ()
snoc_bg_fill :: MRowOps s -> Background -> Int -> Int -> ST s ()
snoc_bg_fill _row_ops _bg 0 _row
= return ()
snoc_bg_fill mrow_ops (Background c back_attr) fill_length row
@ -334,21 +314,23 @@ snoc_bg_fill mrow_ops (Background c back_attr) fill_length row
then
let !(c_byte :: Word8) = BInt.c2w c
in unsafeIOToST $ do
BInt.create ( fromEnum fill_length )
BInt.create fill_length
$ \ptr -> mapM_ (\i -> pokeByteOff ptr i c_byte)
[0 .. fromEnum (fill_length - 1)]
[0 .. (fill_length - 1)]
else
let !(c_bytes :: [Word8]) = encode [c]
in unsafeIOToST $ do
BInt.create (fromEnum fill_length * length c_bytes)
BInt.create (fill_length * length c_bytes)
$ \ptr -> mapM_ (\(i,b) -> pokeByteOff ptr i b)
$ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)
$ zip [0 .. (fill_length - 1)] (cycle c_bytes)
snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)
-- | snocs the operation to the operations for the given row.
snoc_op :: MRowOps s -> Int -> SpanOp -> ST s ()
snoc_op !mrow_ops !row !op = do
ops <- Vector.read mrow_ops row
let ops' = Vector.snoc ops op
Vector.write mrow_ops row ops'
snoc_op :: SpanOp -> Int -> BlitM s ()
snoc_op !op !row = do
the_mrow_ops <- view mrow_ops
lift $ do
ops <- Vector.read the_mrow_ops row
let ops' = Vector.snoc ops op
Vector.write the_mrow_ops row ops'

16
test/current_benchmark_results.txt Normal file
View File

@ -0,0 +1,16 @@
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
[("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)]

16
vty.cabal
View File

@ -43,6 +43,7 @@ library
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -99,6 +100,7 @@ test-suite verify-attribute-ops
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -150,6 +152,7 @@ test-suite verify-using-mock-terminal
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -201,6 +204,7 @@ test-suite verify-display-attributes
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -229,6 +233,7 @@ test-suite verify-empty-image-props
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -260,6 +265,7 @@ test-suite verify-eval-terminfo-caps
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -303,6 +309,7 @@ test-suite verify-image-ops
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -340,6 +347,7 @@ test-suite verify-image-trans
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -387,6 +395,7 @@ test-suite verify-inline
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -418,6 +427,7 @@ test-suite verify-parse-terminfo-caps
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -448,6 +458,7 @@ test-suite verify-picture-ops
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -499,6 +510,7 @@ test-suite verify-picture-to-span
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -550,6 +562,7 @@ test-suite verify-span-ops
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -584,6 +597,7 @@ test-suite verify-utf8-width
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -610,6 +624,7 @@ executable vty-interactive-terminal-test
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,
@ -638,6 +653,7 @@ executable vty-benchmark
containers,
deepseq >= 1.1 && < 1.4,
ghc-prim,
lens,
mtl >= 1.1.1.0 && < 2.2,
parallel >= 2.2 && < 3.3,
parsec >= 2 && < 4,