052cee9 · vty · git.iko.soy

src/Graphics/Vty/Error.hs+1−1

compare with master

unifiedsplit

@@ -8,4 +8,4 @@ import Control.Exception

8--

9-- These have fully qualified names by default since, IMO, exception handling requires this.

10data VtyException

11− = VtyFailure String -- | Uncategorized failure specific to vty.

11+ = VtyFailure String -- ^ Uncategorized failure specific to vty.

src/Graphics/Vty/Image.hs+18−6

@@ -37,6 +37,8 @@ import Codec.Binary.UTF8.Width

37

38import Codec.Binary.UTF8.String ( decode )

39

40+import Control.DeepSeq

41+

40import qualified Data.ByteString as BS

42import qualified Data.ByteString as BS

41import Data.Monoid

43import Data.Monoid

42import qualified Data.Sequence as Seq

44import qualified Data.Sequence as Seq

@@ -69,7 +71,7 @@ type DisplayString = Seq.Seq (Char, Word)

69--

71--

70-- todo: increase the number of encoded bytestring formats supported.

72-- todo: increase the number of encoded bytestring formats supported.

71data Image =

73data Image =

72− -- A horizontal text span is always >= 1 column and has a row height of 1.

74+ -- | A horizontal text span is always >= 1 column and has a row height of 1.

73 HorizText

75 HorizText

74 { attr :: !Attr

76 { attr :: !Attr

75 -- All character data is stored as Char sequences with the ISO-10646 encoding.

77 -- All character data is stored as Char sequences with the ISO-10646 encoding.

@@ -77,7 +79,7 @@ data Image =

77 , output_width :: !Word -- >= 0

79 , output_width :: !Word -- >= 0

78 , char_width :: !Word -- >= 1

80 , char_width :: !Word -- >= 1

79 }

81 }

80− -- A horizontal join can be constructed between any two images. However a HorizJoin instance is

82+ -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is

81 -- required to be between two images of equal height. The horiz_join constructor adds background

83 -- required to be between two images of equal height. The horiz_join constructor adds background

82 -- filles to the provided images that assure this is true for the HorizJoin value produced.

84 -- filles to the provided images that assure this is true for the HorizJoin value produced.

83 | HorizJoin

85 | HorizJoin

@@ -86,7 +88,7 @@ data Image =

86 , output_width :: !Word -- >= 1

88 , output_width :: !Word -- >= 1

87 , output_height :: !Word -- >= 1

89 , output_height :: !Word -- >= 1

88 }

90 }

89− -- A veritical join can be constructed between any two images. However a VertJoin instance is

91+ -- | A veritical join can be constructed between any two images. However a VertJoin instance is

90 -- required to be between two images of equal width. The vert_join constructor adds background

92 -- required to be between two images of equal width. The vert_join constructor adds background

91 -- fills to the provides images that assure this is true for the VertJoin value produced.

93 -- fills to the provides images that assure this is true for the VertJoin value produced.

92 | VertJoin

94 | VertJoin

@@ -95,13 +97,13 @@ data Image =

95 , output_width :: !Word -- >= 1

97 , output_width :: !Word -- >= 1

96 , output_height :: !Word -- >= 1

98 , output_height :: !Word -- >= 1

97 }

99 }

98− -- A background fill will be filled with the background pattern. The background pattern is

100+ -- | A background fill will be filled with the background pattern. The background pattern is

99 -- defined as a property of the Picture this Image is used to form.

101 -- defined as a property of the Picture this Image is used to form.

100 | BGFill

102 | BGFill

101 { output_width :: !Word -- >= 1

103 { output_width :: !Word -- >= 1

102 , output_height :: !Word -- >= 1

104 , output_height :: !Word -- >= 1

103 }

105 }

104− -- The combining operators identity constant.

106+ -- | The combining operators identity constant.

105 -- EmptyImage <|> a = a

107 -- EmptyImage <|> a = a

106 -- EmptyImage <-> a = a

108 -- EmptyImage <-> a = a

107 --

109 --

@@ -135,7 +137,17 @@ instance Show Image where

135instance Monoid Image where

137instance Monoid Image where

136 mempty = empty_image

138 mempty = empty_image

137 mappend = (<->)

139 mappend = (<->)

138−

140+

141+instance NFData Image where

142+ rnf EmptyImage = ()

143+ rnf (Translation s i) = s `deepseq` i `deepseq` ()

144+ rnf (ImagePad s i) = s `deepseq` i `deepseq` ()

145+ rnf (ImageCrop s i) = s `deepseq` i `deepseq` ()

146+ rnf (BGFill !w !h) = ()

147+ rnf (VertJoin t b !w !h) = t `deepseq` b `deepseq` ()

148+ rnf (HorizJoin l r !w !h) = l `deepseq` r `deepseq` ()

149+ rnf (HorizText !a s !w !cw) = s `deepseq` ()

150+

139-- A horizontal text image of 0 characters in width simplifies to the EmptyImage

151-- A horizontal text image of 0 characters in width simplifies to the EmptyImage

140horiz_text :: Attr -> DisplayString -> Word -> Image

152horiz_text :: Attr -> DisplayString -> Word -> Image

141horiz_text a txt ow

153horiz_text a txt ow

src/Graphics/Vty/Picture.hs+12

@@ -1,3 +1,4 @@

1+{-# LANGUAGE BangPatterns #-}

1-- | The Picture data structure is representative of the final terminal view.

2-- | The Picture data structure is representative of the final terminal view.

2--

3--

3-- This module re-exports most of the Graphics.Vty.Image and Graphics.Vty.Attributes modules.

4-- This module re-exports most of the Graphics.Vty.Image and Graphics.Vty.Attributes modules.

@@ -30,6 +31,7 @@ module Graphics.Vty.Picture ( module Graphics.Vty.Picture

30import Graphics.Vty.Attributes

31import Graphics.Vty.Attributes

31import Graphics.Vty.Image hiding ( attr )

32import Graphics.Vty.Image hiding ( attr )

32

33

34+import Control.DeepSeq

33import Data.Word

35import Data.Word

34

36

35-- | The type of images to be displayed using 'update'.

37-- | The type of images to be displayed using 'update'.

@@ -44,6 +46,9 @@ data Picture = Picture

44instance Show Picture where

46instance Show Picture where

45 show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??"

47 show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??"

46

48

49+instance NFData Picture where

50+ rnf (Picture c i b) = c `deepseq` i `deepseq` b `deepseq` ()

51+

47-- | Create a picture for display for the given image. The picture will not have a displayed cursor

52-- | Create a picture for display for the given image. The picture will not have a displayed cursor

48-- and the background display attribute will be `current_attr`.

53-- and the background display attribute will be `current_attr`.

49pic_for_image :: Image -> Picture

54pic_for_image :: Image -> Picture

@@ -65,6 +70,10 @@ data Cursor =

65 NoCursor

70 NoCursor

66 | Cursor Word Word

71 | Cursor Word Word

67

72

73+instance NFData Cursor where

74+ rnf NoCursor = ()

75+ rnf (Cursor !w !h) = ()

76+

68-- | Unspecified regions are filled with the picture's background pattern. The background pattern

77-- | Unspecified regions are filled with the picture's background pattern. The background pattern

69-- can specify a character and a display attribute. If the display attribute used previously should

78-- can specify a character and a display attribute. If the display attribute used previously should

70-- be used for a background fill then use `current_attr` for the background attribute. This is the

79-- be used for a background fill then use `current_attr` for the background attribute. This is the

@@ -79,3 +88,6 @@ data Background = Background

79 , background_attr :: Attr

88 , background_attr :: Attr

80 }

89 }

81

90

91+instance NFData Background where

92+ rnf (Background !c !a) = ()

93+

test/BenchImageFuzz.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# LANGUAGE MultiWayIf #-}

2+module BenchImageFuzz where

3+import Graphics.Vty

4+import Graphics.Vty.Debug

5+

6+import Verify.Graphics.Vty.Image

7+import Verify

8+

9+import Control.Applicative

10+import Control.Monad

11+

12+import System.Random

13+

14+rand :: Arbitrary a => IO a

15+rand = head <$> sample' arbitrary

16+

17+random_image w h = do

18+ SingleAttrSingleSpanStack i _ _ _ <- rand

19+ return i

20+

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

22+

23+bench_0 = do

24+ vty <- mkVty

25+ DisplayRegion w h <- display_bounds $ terminal vty

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

27+ bench ps = do

28+ forM ps (update vty)

29+ shutdown vty

30+ return $ Bench pictures bench

31+

test/BenchNoDiffOpt.hs+8−4

@@ -3,6 +3,7 @@ module BenchNoDiffOpt where

3

4{-# LANGUAGE BangPatterns #-}

5import Graphics.Vty

6+import Verify

6

7

7import Control.Concurrent( threadDelay )

8import Control.Concurrent( threadDelay )

8import Control.Monad( liftM2 )

9import Control.Monad( liftM2 )

@@ -19,10 +20,13 @@ bench_0 = do

19 setStdGen fixed_gen

20 setStdGen fixed_gen

20 vty <- mkVty

21 vty <- mkVty

21 DisplayRegion w h <- display_bounds $ terminal vty

22 DisplayRegion w h <- display_bounds $ terminal vty

23+ let images = return $ (image_0, image_1)

22− let image_0 = char_fill def_attr 'X' w h

24+ image_0 = char_fill def_attr 'X' w h

23− let image_1 = char_fill def_attr '0' w h

25+ image_1 = char_fill def_attr '0' w h

26+ bench d = do

24− flip_out vty 300 image_0 image_1

27+ flip_out vty 300 image_0 image_1

25− shutdown vty

28+ shutdown vty

29+ return $ Bench images bench

26

30

27flip_out vty n image_0 image_1 =

31flip_out vty n image_0 image_1 =

28 let !p_left = pic_for_image image_0

32 let !p_left = pic_for_image image_0

test/BenchRenderChar.hs+17−12

@@ -5,18 +5,21 @@

5module BenchRenderChar where

6

7import Graphics.Vty

8+import Verify

8

9

9import Control.Monad ( forM_ )

10import Control.Monad ( forM_ )

10

11

11bench_0 = do

12bench_0 = do

12 vty <- mkVty

13 vty <- mkVty

13 DisplayRegion w h <- display_bounds $ terminal vty

14 DisplayRegion w h <- display_bounds $ terminal vty

14− let test_chars = take 500 $ cycle $ [ c | c <- ['a'..'z']]

15+ let test_chars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

16+ bench d = do

15− forM_ test_chars $ \test_char -> do

17+ forM_ d $ \test_char -> do

16− let test_image = test_image_using_char test_char w h

18+ let test_image = test_image_using_char test_char w h

17− out_pic = pic_for_image test_image

19+ out_pic = pic_for_image test_image

18− update vty out_pic

20+ update vty out_pic

19− shutdown vty

21+ shutdown vty

22+ return $ Bench test_chars bench

20

23

21test_image_using_char c w h

24test_image_using_char c w h

22 = vert_cat $ replicate (fromIntegral h)

25 = vert_cat $ replicate (fromIntegral h)

@@ -25,9 +28,11 @@ test_image_using_char c w h

25bench_1 = do

28bench_1 = do

26 vty <- mkVty

29 vty <- mkVty

27 DisplayRegion w h <- display_bounds $ terminal vty

30 DisplayRegion w h <- display_bounds $ terminal vty

28− let test_chars = take 500 $ cycle $ [ c | c <- ['a'..'z']]

31+ let test_chars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

32+ bench d = do

29− forM_ test_chars $ \test_char -> do

33+ forM_ d $ \test_char -> do

30− let test_image = char_fill def_attr test_char w h

34+ let test_image = char_fill def_attr test_char w h

31− out_pic = pic_for_image test_image

35+ out_pic = pic_for_image test_image

32− update vty out_pic

36+ update vty out_pic

33− shutdown vty

37+ shutdown vty

38+ return $ Bench test_chars bench

test/BenchVerticalScroll.hs+2−2

@@ -1,6 +1,7 @@

1module BenchVerticalScroll where

2

3import Graphics.Vty hiding ( pad )

4+import Verify

4

5

5import Control.Concurrent( threadDelay )

6import Control.Concurrent( threadDelay )

6import Control.Monad( liftM2 )

7import Control.Monad( liftM2 )

@@ -12,11 +13,10 @@ import System.Environment( getArgs )

12import System.IO

13import System.IO

13import System.Random

14import System.Random

14

15

15−

16bench_0 = do

17 let fixed_gen = mkStdGen 0

18 setStdGen fixed_gen

19− mkVty >>= liftM2 (>>) run shutdown

19+ return $ Bench (return ()) (\() -> mkVty >>= liftM2 (>>) run shutdown)

20

21run vt = mapM_ (\p -> update vt p) . benchgen =<< display_bounds (terminal vt)

22

test/Makefile+2−5

@@ -14,9 +14,7 @@ verify_inline \

14

15

16TESTS :=\

17−Bench \

17+benchmark \

18−Bench2 \

19−BenchRenderChar \

20Test \

18Test \

21Test2 \

19Test2 \

22yi_issue_264 \

20yi_issue_264 \

@@ -28,9 +26,8 @@ $(shell mkdir -p objects )

28# TODO: Tests should also be buildable referencing the currently installed vty

26# TODO: Tests should also be buildable referencing the currently installed vty

29GHC_ARGS=--make -i../src \

27GHC_ARGS=--make -i../src \

30 -package parallel \

28 -package parallel \

31− -package deepseq-1.3.0.0 \

29+ -package deepseq-1.3.0.1 \

32 -hide-package transformers \

30 -hide-package transformers \

33− -hide-package monads-tf \

34 -package QuickCheck \

31 -package QuickCheck \

35 -ignore-package vty \

32 -ignore-package vty \

36 ../cbits/gwinsz.c ../cbits/set_term_timing.c ../cbits/mk_wcwidth.c \

33 ../cbits/gwinsz.c ../cbits/set_term_timing.c ../cbits/mk_wcwidth.c \

test/Verify.hs+6

@@ -1,3 +1,4 @@

1+{-# LANGUAGE GADTs #-}

1{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE RecordWildCards #-}

2{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE CPP #-}

4{-# LANGUAGE CPP #-}

@@ -7,6 +8,7 @@

7{-# LANGUAGE DisambiguateRecordFields #-}

8{-# LANGUAGE DisambiguateRecordFields #-}

8{-# LANGUAGE NamedFieldPuns #-}

9{-# LANGUAGE NamedFieldPuns #-}

9module Verify ( module Verify

10module Verify ( module Verify

11+ , module Control.DeepSeq

10 , module Test.QuickCheck

12 , module Test.QuickCheck

11 , succeeded

13 , succeeded

12 , failed

14 , failed

@@ -30,6 +32,7 @@ import Test.QuickCheck.Monadic ( monadicIO )

30

32

31import qualified Codec.Binary.UTF8.String as UTF8

33import qualified Codec.Binary.UTF8.String as UTF8

32

34

35+import Control.DeepSeq

33import Control.Monad.State.Strict

36import Control.Monad.State.Strict

34

37

35import Data.IORef

38import Data.IORef

@@ -83,3 +86,6 @@ instance Random Word where

83 in (toEnum i, g')

86 in (toEnum i, g')

84#endif

87#endif

85

88

89+data Bench where

90+ Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench

91+

test/Verify/Graphics/Vty/Attributes.hs+37−4

@@ -8,12 +8,43 @@ import Verify

8

9import Data.List ( delete )

10

11+all_colors :: [Color]

12+all_colors =

13+ [ black

14+ , red

15+ , green

16+ , yellow

17+ , blue

18+ , magenta

19+ , cyan

20+ , white

21+ , bright_black

22+ , bright_red

23+ , bright_green

24+ , bright_yellow

25+ , bright_blue

26+ , bright_magenta

27+ , bright_cyan

28+ , bright_white

29+ ] ++ map Color240 [0..239]

30+

31+all_styles :: [Style]

32+all_styles =

33+ [ standout

34+ , underline

35+ , reverse_video

36+ , blink

37+ , dim

38+ , bold

39+ ]

40+

11-- Limit the possible attributes to just a few for now.

41-- Limit the possible attributes to just a few for now.

12possible_attr_mods :: [ AttrOp ]

42possible_attr_mods :: [ AttrOp ]

13possible_attr_mods =

43possible_attr_mods =

14− [ set_bold_op

15− , id_op

44+ [ id_op

16− ]

45+ ] ++ map set_fore_color_op all_colors

46+ ++ map set_back_color_op all_colors

47+ ++ map set_style_op all_styles

17

48

18instance Arbitrary Attr where

49instance Arbitrary Attr where

19 arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr

50 arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr

@@ -32,7 +63,9 @@ data AttrOp = AttrOp String (Attr -> Attr)

32instance Eq AttrOp where

63instance Eq AttrOp where

33 AttrOp n0 _ == AttrOp n1 _ = n0 == n1

64 AttrOp n0 _ == AttrOp n1 _ = n0 == n1

34

65

35−set_bold_op = AttrOp "set_bold" (flip with_style bold)

66+set_style_op s = AttrOp "set_style" (flip with_style s)

67+set_fore_color_op c = AttrOp "set_fore_color" (flip with_fore_color c)

68+set_back_color_op c = AttrOp "set_back_color" (flip with_back_color c)

36id_op = AttrOp "id" id

69id_op = AttrOp "id" id

37

70

38apply_op :: AttrOp -> Attr -> Attr

71apply_op :: AttrOp -> Attr -> Attr

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

@@ -18,7 +18,8 @@ data UnitImage = UnitImage Char Image

18instance Arbitrary UnitImage where

19 arbitrary = do

20 SingleColumnChar c <- arbitrary

21+ a <- arbitrary

21− return $ UnitImage c (char def_attr c)

22+ return $ UnitImage c (char a c)

22

23

23instance Show UnitImage where

24instance Show UnitImage where

24 show (UnitImage c _) = "UnitImage " ++ show c

25 show (UnitImage c _) = "UnitImage " ++ show c

@@ -51,11 +52,11 @@ instance Arbitrary SingleRowSingleAttrImage where

51 -- IdImage which has a height of 0. If this is to represent a single row then the height

52 -- IdImage which has a height of 0. If this is to represent a single row then the height

52 -- must be 1

53 -- must be 1

53 single_column_row_text <- resize 128 (listOf1 arbitrary)

54 single_column_row_text <- resize 128 (listOf1 arbitrary)

54− attr <- arbitrary

55+ a <- arbitrary

55 return $ SingleRowSingleAttrImage

56 return $ SingleRowSingleAttrImage

56− attr

57+ a

57 ( fromIntegral $ length single_column_row_text )

58 ( fromIntegral $ length single_column_row_text )

58− ( horiz_cat $ [ char attr c | SingleColumnChar c <- single_column_row_text ] )

59+ ( horiz_cat $ [ char attr c | (SingleColumnChar c, attr) <- single_column_row_text ] )

59

60

60data SingleRowTwoAttrImage

61data SingleRowTwoAttrImage

61 = SingleRowTwoAttrImage

62 = SingleRowTwoAttrImage

test/benchmark.hs+16−10

@@ -4,6 +4,7 @@ module Main where

4

5import Graphics.Vty

6

7+import qualified BenchImageFuzz

7import qualified BenchNoDiffOpt

8import qualified BenchNoDiffOpt

8import qualified BenchRenderChar

9import qualified BenchRenderChar

9import qualified BenchVerticalScroll

10import qualified BenchVerticalScroll

@@ -16,12 +17,15 @@ import Data.List

16import System.Environment

17import System.Environment

17import System.Posix.Process

18import System.Posix.Process

18

19

20+import Verify

21+

19main = do

22main = do

20 args <- getArgs

23 args <- getArgs

21 let benches = [ ("no-diff-opt-0", BenchNoDiffOpt.bench_0)

24 let benches = [ ("no-diff-opt-0", BenchNoDiffOpt.bench_0)

22 , ("render-char-0", BenchRenderChar.bench_0)

25 , ("render-char-0", BenchRenderChar.bench_0)

23 , ("render-char-1", BenchRenderChar.bench_1)

26 , ("render-char-1", BenchRenderChar.bench_1)

24− , ("vertical-scroll-0", BenchVerticalScroll.bench_0)]

27+ , ("vertical-scroll-0", BenchVerticalScroll.bench_0)

28+ , ("image-fuzz-0", BenchImageFuzz.bench_0) ]

25 help = forM_ benches $ \(b,_) -> putStrLn $ "--" ++ b

29 help = forM_ benches $ \(b,_) -> putStrLn $ "--" ++ b

26 case args of

30 case args of

27 ["--help"] -> help

31 ["--help"] -> help

@@ -31,21 +35,23 @@ main = do

31 then args

35 then args

32 else map fst benches

36 else map fst benches

33 -- drop the dash-dash "--"

37 -- drop the dash-dash "--"

34− results <- forM args' $ \(_ : _ : b) -> do

38+ results <- forM args' $ \(_ : _ : b_name) -> do

35− case lookup b benches of

39+ case lookup b_name benches of

36− Just f -> bench b f

40+ Just b -> bench b_name b

37− Nothing -> fail $ "No benchmark named " ++ b

41+ Nothing -> fail $ "No benchmark named " ++ b_name

38 print results

42 print results

39 return ()

43 return ()

40

44

41−bench b f = do

45+bench b_name b = do

42− putStrLn $ "starting " ++ b

46+ putStrLn $ "starting " ++ b_name

47+ Bench b_data_gen b_proc <- b

48+ b_data <- b_data_gen

43− start_times <- getProcessTimes

49+ start_times <- b_data `deepseq` getProcessTimes

44− f

50+ b_proc b_data

45 end_times <- getProcessTimes

51 end_times <- getProcessTimes

46 let user_time = userTime end_times - userTime start_times

52 let user_time = userTime end_times - userTime start_times

47 system_time = systemTime end_times - systemTime start_times

53 system_time = systemTime end_times - systemTime start_times

48 putStrLn $ "user time: " ++ show user_time

54 putStrLn $ "user time: " ++ show user_time

49 putStrLn $ "system time: " ++ show system_time

55 putStrLn $ "system time: " ++ show system_time

50− return (b, user_time, system_time)

56+ return (b_name, user_time, system_time)

51

57

vty.cabal+3−1

@@ -30,7 +30,7 @@ description:

30-- the test suites require >= 1.17.0

31cabal-version: >= 1.14.0

32build-type: Simple

33−data-files: README,

33+data-files: README.md,

34 TODO,

35 AUTHORS,

36 CHANGELOG,

@@ -634,12 +634,14 @@ executable vty-benchmark

634

635 build-depends: base >= 4 && < 5,

636 bytestring,

637+ Cabal == 1.17.*,

637 containers,

638 containers,

638 deepseq >= 1.1 && < 1.4,

639 deepseq >= 1.1 && < 1.4,

639 ghc-prim,

640 ghc-prim,

640 mtl >= 1.1.1.0 && < 2.2,

641 mtl >= 1.1.1.0 && < 2.2,

641 parallel >= 2.2 && < 3.3,

642 parallel >= 2.2 && < 3.3,

642 parsec >= 2 && < 4,

643 parsec >= 2 && < 4,

644+ QuickCheck >= 2.4,

643 random == 1.0.*,

645 random == 1.0.*,

644 string-qq,

646 string-qq,

645 terminfo >= 0.3 && < 0.4,

647 terminfo >= 0.3 && < 0.4,