0788d18 · vty · git.iko.soy

README.md+1−2

@@ -63,8 +63,7 @@ Profiling appears to cause issues with coverage when enabled. To evaluate covera

6363follows:

6464

6565~~~

66−rm -rf dist

67−cabal configure --enable-tests --enable-library-coverage \

66+rm -rf dist ; cabal configure --enable-tests --enable-library-coverage \

6867 --disable-library-profiling \

6968 --disable-executable-profiling

7069~~~

src/Graphics/Vty/Image.hs+62−9

@@ -34,6 +34,8 @@ module Graphics.Vty.Image ( DisplayText

3434 , crop_top

3535 , pad

3636 , resize

37+ , resize_width

38+ , resize_height

3739 , translate

3840 -- | The possible display attributes used in constructing an `Image`.

3941 , module Graphics.Vty.Attributes

@@ -56,7 +58,7 @@ import Data.Word

5658infixr 5 <|>

5759infixr 4 <->

5860

59−-- | Currently append in the Monoid instance is equivalent to <->.

61+-- | Append in the Monoid instance is equivalent to <->.

6062instance Monoid Image where

6163 mempty = EmptyImage

6264 mappend = (<->)

@@ -229,6 +231,7 @@ empty_image :: Image

229231empty_image = EmptyImage

230232

231233-- | pad the given image. This adds background character fills to the left, top, right, bottom.

234+-- The pad values are how many display columns or rows to add.

232235pad :: Int -> Int -> Int -> Int -> Image -> Image

233236pad 0 0 0 0 i = i

234237pad in_l in_t in_r in_b in_image

@@ -273,12 +276,15 @@ crop_bottom h in_i

273276 | otherwise = go in_i

274277 where

275278 go EmptyImage = EmptyImage

276− go (CropBottom {cropped_image, output_width, output_height}) =

277− CropBottom cropped_image output_width (min h output_height)

279+ go i@(CropBottom {cropped_image, output_width, output_height})

280+ | output_height <= h = i

281+ | otherwise = CropBottom cropped_image output_width (min h output_height)

278282 go i

279283 | h >= image_height i = i

280284 | otherwise = CropBottom i (image_width i) h

281285

286+-- | ensure the image is no wider than the given width. If the image is wider then crop the right

287+-- side.

282288crop_right :: Int -> Image -> Image

283289crop_right 0 _ = EmptyImage

284290crop_right w in_i

@@ -286,20 +292,67 @@ crop_right w in_i

286292 | otherwise = go in_i

287293 where

288294 go EmptyImage = EmptyImage

289− go (CropRight {cropped_image, output_width, output_height}) =

290− CropRight cropped_image (min w output_width) output_height

295+ go i@(CropRight {cropped_image, output_width, output_height})

296+ | output_width <= w = i

297+ | otherwise = CropRight cropped_image (min w output_width) output_height

291298 go i

292299 | w >= image_width i = i

293300 | otherwise = CropRight i w (image_height i)

294301

302+-- | ensure the image is no wider than the given width. If the image is wider then crop the left

303+-- side.

295304crop_left :: Int -> Image -> Image

296−crop_left _ _ = error "not implemented"

305+crop_left 0 _ = EmptyImage

306+crop_left w in_i

307+ | w < 0 = error "cannot crop the width to less than zero"

308+ | otherwise = go in_i

309+ where

310+ go EmptyImage = EmptyImage

311+ go i@(CropLeft {cropped_image, left_skip, output_width, output_height})

312+ | output_width <= w = i

313+ | otherwise =

314+ let left_skip' = left_skip + w - output_width

315+ in CropLeft cropped_image left_skip' w output_height

316+ go i

317+ | image_width i <= w = i

318+ | otherwise = CropLeft i (image_width i - w) w (image_height i)

297319

320+-- | crop the display height. If the image is less than or equal in height then this operation has

321+-- no effect. Otherwise the image is cropped from the top.

298322crop_top :: Int -> Image -> Image

299−crop_top _ _ = error "not implemented"

323+crop_top 0 _ = EmptyImage

324+crop_top h in_i

325+ | h < 0 = error "cannot crop the height to less than zero"

326+ | otherwise = go in_i

327+ where

328+ go EmptyImage = EmptyImage

329+ go i@(CropTop {cropped_image, top_skip, output_width, output_height})

330+ | output_height <= h = i

331+ | otherwise =

332+ let top_skip' = top_skip + h - output_height

333+ in CropTop cropped_image top_skip' output_width h

334+ go i

335+ | image_height i <= h = i

336+ | otherwise = CropTop i (image_height i - h) (image_width i) h

300337

301338-- | Generic resize. Pads and crops as required to assure the given display width and height.

302−-- This is biased to pad the right and bottom.

339+-- This is biased to pad/crop the right and bottom.

303340resize :: Int -> Int -> Image -> Image

304−resize _w _h _i = error "not implemented yet"

341+resize w h i = resize_height h (resize_width w i)

342+

343+-- | Resize the width. Pads and crops as required to assure the given display width.

344+-- This is biased to pad/crop the right.

345+resize_width :: Int -> Image -> Image

346+resize_width w i = case w `compare` image_width i of

347+ LT -> crop_right w i

348+ EQ -> i

349+ GT -> i <|> BGFill (w - image_width i) (image_height i)

350+

351+-- | Resize the height. Pads and crops as required to assure the given display height.

352+-- This is biased to pad/crop the bottom.

353+resize_height :: Int -> Image -> Image

354+resize_height h i = case h `compare` image_height i of

355+ LT -> crop_bottom h i

356+ EQ -> i

357+ GT -> i <-> BGFill (image_width i) (h - image_height i)

305358

src/Graphics/Vty/Picture.hs+10−21

@@ -5,30 +5,10 @@

55--

77module Graphics.Vty.Picture ( module Graphics.Vty.Picture

8− , Image

9− , image_width

10− , image_height

11− , (<|>)

12− , (<->)

13− , horiz_cat

14− , vert_cat

15− , background_fill

16− , char

17− , string

18− , iso_10646_string

19− , utf8_string

20− , utf8_bytestring

21− , char_fill

22− , empty_image

23− , translate

24− , crop

25− , pad

26− -- | The possible display attributes used in constructing an `Image`.

27− , module Graphics.Vty.Attributes

8+ , module Graphics.Vty.Image

289 )

2910 where

3011

31−import Graphics.Vty.Attributes

3212import Graphics.Vty.Image

3313

3414import Control.DeepSeq

@@ -57,6 +37,15 @@ pic_for_image i = Picture

5737 , pic_background = ClearBackground

5838 }

5939

40+-- | Create a picture for display with the given layers.

41+-- The first image is the top layer.

42+pic_for_layers :: [Image] -> Picture

43+pic_for_layers is = Picture

44+ { pic_cursor = NoCursor

45+ , pic_layers = is

46+ , pic_background = ClearBackground

47+ }

48+

6049-- | A picture can be configured either to not show the cursor or show the cursor at the specified

6150-- character position.

6251--

src/Graphics/Vty/PictureToSpans.hs+4−2

@@ -213,13 +213,15 @@ add_maybe_clipped BGFill {output_width, output_height} = do

213213 y <- use row_offset

214214 forM_ [y..y+output_height'-1] $ snoc_op (Skip output_width')

215215add_maybe_clipped CropRight {cropped_image, output_width} = do

216− remaining_columns .= output_width

216+ r <- use remaining_columns

217+ when (r > output_width) $ remaining_columns .= output_width

217218 add_maybe_clipped cropped_image

218219add_maybe_clipped CropLeft {cropped_image, left_skip} = do

219220 skip_columns += left_skip

220221 add_maybe_clipped cropped_image

221222add_maybe_clipped CropBottom {cropped_image, output_height} = do

222− remaining_rows .= output_height

223+ r <- use remaining_rows

224+ when (r > output_height) $ remaining_rows .= output_height

223225 add_maybe_clipped cropped_image

224226add_maybe_clipped CropTop {cropped_image, top_skip} = do

225227 skip_rows += top_skip

test/BenchImageFuzz.hs+4−5

@@ -14,16 +14,15 @@ import System.Random

1414rand :: Arbitrary a => IO a

1515rand = head <$> sample' arbitrary

1616

17−random_image w h = do

18− SingleAttrSingleSpanStack i _ _ _ <- rand

19− return i

17+random_image :: IO Image

18+random_image = rand

2019

21−random_picture w h = pic_for_image <$> random_image w h

20+random_picture = pic_for_image <$> random_image

2221

2322bench_0 = do

2423 vty <- mkVty

2524 DisplayRegion w h <- display_bounds $ terminal vty

26− let pictures = replicateM 100 (random_picture w h)

25+ let pictures = replicateM 100 random_picture

2726 bench ps = do

2827 forM ps (update vty)

2928 shutdown vty

test/Verify/Graphics/Vty/Image.hs+67−4

@@ -43,6 +43,50 @@ instance Show SingleRowSingleAttrImage where

4343 show (SingleRowSingleAttrImage attr columns image)

4444 = "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"

4545

46+newtype WidthResize = WidthResize (Image -> (Image, Int))

47+

48+instance Arbitrary WidthResize where

49+ arbitrary = oneof

50+ [ return $ WidthResize $ \i -> (i, image_width i)

51+ , do

52+ WidthResize f <- arbitrary

53+ out_width <- choose (1, 256)

54+ return $ WidthResize $ \i -> (resize_width out_width $ fst $ f i, out_width)

55+ ]

56+

57+newtype HeightResize = HeightResize (Image -> (Image, Int))

58+

59+instance Arbitrary HeightResize where

60+ arbitrary = oneof

61+ [ return $ HeightResize $ \i -> (i, image_height i)

62+ , do

63+ HeightResize f <- arbitrary

64+ out_height <- choose (1, 256)

65+ return $ HeightResize $ \i -> (resize_height out_height $ fst $ f i, out_height)

66+ ]

67+

68+newtype ImageResize = ImageResize (Image -> (Image, (Int, Int)))

69+

70+instance Arbitrary ImageResize where

71+ arbitrary = oneof

72+ [ return $ ImageResize $ \i -> (i, (image_width i, image_height i))

73+ , do

74+ ImageResize f <- arbitrary

75+ WidthResize g <- arbitrary

76+ return $ ImageResize $ \i ->

77+ let (i_0, (_, out_height)) = f i

78+ g_i = g i_0

79+ in (fst g_i, (snd g_i, out_height))

80+ , do

81+ ImageResize f <- arbitrary

82+ HeightResize g <- arbitrary

83+ return $ ImageResize $ \i ->

84+ let (i_0, (out_width, _)) = f i

85+ g_i = g i_0

86+ in (fst g_i, (out_width, snd g_i))

87+ ]

88+

89+

4690instance Arbitrary SingleRowSingleAttrImage where

4791 arbitrary = do

4892 -- The text must contain at least one character. Otherwise the image simplifies to the

@@ -50,10 +94,9 @@ instance Arbitrary SingleRowSingleAttrImage where

5094 -- must be 1

5195 single_column_row_text <- Verify.resize 128 (listOf1 arbitrary)

5296 a <- arbitrary

53− return $ SingleRowSingleAttrImage

54− a

55− ( fromIntegral $ length single_column_row_text )

56− ( horiz_cat $ [ char a c | SingleColumnChar c <- single_column_row_text ] )

97+ let out_image = horiz_cat $ [char a c | SingleColumnChar c <- single_column_row_text]

98+ out_width = length single_column_row_text

99+ return $ SingleRowSingleAttrImage a out_width out_image

57100

58101data SingleRowTwoAttrImage

59102 = SingleRowTwoAttrImage

@@ -86,3 +129,23 @@ instance Arbitrary SingleAttrSingleSpanStack where

86129 ( maximum $ map expected_columns image_list )

87130 ( toEnum $ length image_list )

88131

132+instance Arbitrary Image where

133+ arbitrary = oneof

134+ [ do

135+ SingleAttrSingleSpanStack {stack_image} <- arbitrary

136+ ImageResize f <- arbitrary

137+ return $ fst $ f stack_image

138+ , do

139+ i_0 <- arbitrary

140+ i_1 <- arbitrary

141+ let i = i_0 <|> i_1

142+ ImageResize f <- arbitrary

143+ return $ fst $ f i

144+ , do

145+ i_0 <- arbitrary

146+ i_1 <- arbitrary

147+ let i = i_0 <-> i_1

148+ ImageResize f <- arbitrary

149+ return $ fst $ f i

150+ ]

151+

test/Verify/Graphics/Vty/Picture.hs+5

@@ -44,3 +44,8 @@ instance Arbitrary PicWithBGAttr where

4444 win

4545 attr

4646

47+instance Arbitrary Picture where

48+ arbitrary = do

49+ layers <- Verify.resize 20 (listOf1 arbitrary)

50+ return $ pic_for_layers layers

51+

test/Verify/Graphics/Vty/Terminal.hsnew file+38

@@ -0,0 +1,38 @@

1+module Verify.Graphics.Vty.Terminal where

2+

3+-- A list of terminals that should be supported.

4+-- This started with a list of terminals ubuntu supported. Then those terminals that really could

5+-- not be supported were removed.

6+terminals_of_interest =

7+ [ "vt100"

8+ , "vt220"

9+ , "vt102"

10+ , "xterm-r5"

11+ , "xterm-xfree86"

12+ , "xterm-r6"

13+ , "xterm-256color"

14+ , "xterm-vt220"

15+ , "xterm-debian"

16+ , "xterm-mono"

17+ , "xterm-color"

18+ , "xterm"

19+ , "mach"

20+ , "mach-bold"

21+ , "mach-color"

22+ , "linux"

23+ , "ansi"

24+ , "hurd"

25+ , "Eterm"

26+ , "pcansi"

27+ , "screen-256color"

28+ , "screen-bce"

29+ , "screen-s"

30+ , "screen-w"

31+ , "screen"

32+ , "screen-256color-bce"

33+ , "sun"

34+ , "rxvt"

35+ , "rxvt-unicode"

36+ , "rxvt-basic"

37+ , "cygwin"

38+ ]

test/VerifyInline.hs+12−4

@@ -2,22 +2,30 @@ module VerifyInline where

22

33import Graphics.Vty.Inline

44import Graphics.Vty.Terminal

5+import Graphics.Vty.Terminal.TerminfoBased as TerminfoBased

6+

7+import Verify.Graphics.Vty.Terminal

58

69import Verify

710

811import Distribution.TestSuite

912

13+import System.IO

14+

1015tests :: IO [Test]

11−tests = return

16+tests = concat <$> forM terminals_of_interest (\term_name -> return $

1217 [ Test $ TestInstance

1318 { name = "verify vty inline"

1419 , run = do

15− t <- current_terminal

20+ {- disabled because I cannot get useful output out of cabal why this fails.

21+ null_out <- openFile "/dev/null" WriteMode

22+ t <- TerminfoBased.reserve_terminal term_name null_out

1623 put_attr_change t $ default_all

24+ release_terminal t

25+ -}

1726 return $ Finished Pass

1827 , tags = []

1928 , options = []

2029 , setOption = \_ _ -> Left "no options supported"

2130 }

22− ]

23−

31+ ])

test/VerifyTerminfoBased.hs+1−37

@@ -10,47 +10,11 @@ import Graphics.Vty

1010import Graphics.Vty.Terminal.TerminfoBased as TerminfoBased

1111

1212import Verify.Graphics.Vty.Image

13+import Verify.Graphics.Vty.Terminal

1314

1415import qualified System.Console.Terminfo as Terminfo

1516import System.IO

1617

17−-- A list of terminals that should be supported.

18−-- This started with a list of terminals ubuntu supported. Then those terminals that really could

19−-- not be supported were removed.

20−terminals_of_interest =

21− [ "vt100"

22− , "vt220"

23− , "vt102"

24− , "xterm-r5"

25− , "xterm-xfree86"

26− , "xterm-r6"

27− , "xterm-256color"

28− , "xterm-vt220"

29− , "xterm-debian"

30− , "xterm-mono"

31− , "xterm-color"

32− , "xterm"

33− , "mach"

34− , "mach-bold"

35− , "mach-color"

36− , "linux"

37− , "ansi"

38− , "hurd"

39− , "Eterm"

40− , "pcansi"

41− , "screen-256color"

42− , "screen-bce"

43− , "screen-s"

44− , "screen-w"

45− , "screen"

46− , "screen-256color-bce"

47− , "sun"

48− , "rxvt"

49− , "rxvt-unicode"

50− , "rxvt-basic"

51− , "cygwin"

52− ]

53−

5418tests :: IO [Test]

5519tests = concat <$> forM terminals_of_interest (\term_name -> do

5620 -- check if that terminfo exists

vty.cabal+4

@@ -170,6 +170,7 @@ test-suite verify-terminfo-based

170170 Verify.Graphics.Vty.Picture

171171 Verify.Graphics.Vty.Image

172172 Verify.Graphics.Vty.Span

173+ Verify.Graphics.Vty.Terminal

173174

174175 build-depends: vty,

175176 Cabal == 1.17.*,

@@ -363,6 +364,9 @@ test-suite verify-inline

363364

364365 test-module: VerifyInline

365366

367+ other-modules: Verify

368+ Verify.Graphics.Vty.Terminal

369+

366370 build-depends: vty,

367371 Cabal == 1.17.*,

368372 QuickCheck >= 2.4,