052cee9 · vty · git.iko.soy

git.iko.soy/vty

add new benchmark and improve benchmarking in general.

commit052cee932a42fdf67fcc333449e13757fed8f354 authorCorey O'Connor <coreyoconnor@gmail.com> dateFri 10 May 2013, 23:23 (13 years ago) parentef0de4f

13 files changed+158−49

compare with master

unifiedsplit

src/Graphics/Vty/Error.hs+1−1 src/Graphics/Vty/Image.hs+18−6 src/Graphics/Vty/Picture.hs+12 test/BenchImageFuzz.hs+31 test/BenchNoDiffOpt.hs+8−4 test/BenchRenderChar.hs+17−12 test/BenchVerticalScroll.hs+2−2 test/Makefile+2−5 test/Verify.hs+6 test/Verify/Graphics/Vty/Attributes.hs+37−4 test/Verify/Graphics/Vty/Image.hs+5−4 test/benchmark.hs+16−10 vty.cabal+3−1

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

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

88--

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

1010data 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

3737

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

3939

40+import Control.DeepSeq

41+

4042import qualified Data.ByteString as BS

4143import Data.Monoid

4244import qualified Data.Sequence as Seq

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

6971--

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

7173data 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.

7375 HorizText

7476 { attr :: !Attr

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

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

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

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

7981 }

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

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

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

8385 | HorizJoin

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

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

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

8890 }

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

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

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

9294 | VertJoin

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

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

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

9799 }

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

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

100102 | BGFill

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

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

103105 }

104− -- The combining operators identity constant.

106+ -- | The combining operators identity constant.

105107 -- EmptyImage <|> a = a

106108 -- EmptyImage <-> a = a

107109 --

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

135137instance Monoid Image where

136138 mempty = empty_image

137139 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+

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

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

141153horiz_text a txt ow

src/Graphics/Vty/Picture.hs+12

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

1+{-# LANGUAGE BangPatterns #-}

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

23--

34-- 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

3031import Graphics.Vty.Attributes

3132import Graphics.Vty.Image hiding ( attr )

3233

34+import Control.DeepSeq

3335import Data.Word

3436

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

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

4446instance Show Picture where

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

4648

49+instance NFData Picture where

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

51+

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

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

4954pic_for_image :: Image -> Picture

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

6570 NoCursor

6671 | Cursor Word Word

6772

73+instance NFData Cursor where

74+ rnf NoCursor = ()

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

76+

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

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

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

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

7988 , background_attr :: Attr

8089 }

8190

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

6+import Verify.Graphics.Vty.Image

7+import Verify

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

44{-# LANGUAGE BangPatterns #-}

55import Graphics.Vty

6+import Verify

78import Control.Concurrent( threadDelay )

89import Control.Monad( liftM2 )

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

1920 setStdGen fixed_gen

2021 vty <- mkVty

2122 DisplayRegion w h <- display_bounds $ terminal vty

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

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

24− flip_out vty 300 image_0 image_1

25− shutdown vty

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

24+ image_0 = char_fill def_attr 'X' w h

25+ image_1 = char_fill def_attr '0' w h

26+ bench d = do

27+ flip_out vty 300 image_0 image_1

28+ shutdown vty

29+ return $ Bench images bench

2630

2731flip_out vty n image_0 image_1 =

2832 let !p_left = pic_for_image image_0

test/BenchRenderChar.hs+17−12

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

55module BenchRenderChar where

77import Graphics.Vty

8+import Verify

910import Control.Monad ( forM_ )

1011

1112bench_0 = do

1213 vty <- mkVty

1314 DisplayRegion w h <- display_bounds $ terminal vty

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

15− forM_ test_chars $ \test_char -> do

16− let test_image = test_image_using_char test_char w h

17− out_pic = pic_for_image test_image

18− update vty out_pic

19− shutdown vty

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

16+ bench d = do

17+ forM_ d $ \test_char -> do

18+ let test_image = test_image_using_char test_char w h

19+ out_pic = pic_for_image test_image

20+ update vty out_pic

21+ shutdown vty

22+ return $ Bench test_chars bench

2023

2124test_image_using_char c w h

2225 = vert_cat $ replicate (fromIntegral h)

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

2528bench_1 = do

2629 vty <- mkVty

2730 DisplayRegion w h <- display_bounds $ terminal vty

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

29− forM_ test_chars $ \test_char -> do

30− let test_image = char_fill def_attr test_char w h

31− out_pic = pic_for_image test_image

32− update vty out_pic

33− shutdown vty

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

32+ bench d = do

33+ forM_ d $ \test_char -> do

34+ let test_image = char_fill def_attr test_char w h

35+ out_pic = pic_for_image test_image

36+ update vty out_pic

37+ shutdown vty

38+ return $ Bench test_chars bench

test/BenchVerticalScroll.hs+2−2

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

11module BenchVerticalScroll where

33import Graphics.Vty hiding ( pad )

4+import Verify

56import Control.Concurrent( threadDelay )

67import Control.Monad( liftM2 )

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

1213import System.IO

1314import System.Random

1415

15−

1616bench_0 = do

1717 let fixed_gen = mkStdGen 0

1818 setStdGen fixed_gen

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

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

2020

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

2222

test/Makefile+2−5

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

1414

1515

1616TESTS :=\

17−Bench \

18−Bench2 \

19−BenchRenderChar \

17+benchmark \

2018Test \

2119Test2 \

2220yi_issue_264 \

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

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

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

3028 -package parallel \

31− -package deepseq-1.3.0.0 \

29+ -package deepseq-1.3.0.1 \

3230 -hide-package transformers \

33− -hide-package monads-tf \

3431 -package QuickCheck \

3532 -ignore-package vty \

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

test/Verify.hs+6

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

1+{-# LANGUAGE GADTs #-}

12{-# LANGUAGE RecordWildCards #-}

23{-# LANGUAGE ScopedTypeVariables #-}

34{-# LANGUAGE CPP #-}

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

78{-# LANGUAGE DisambiguateRecordFields #-}

89{-# LANGUAGE NamedFieldPuns #-}

910module Verify ( module Verify

11+ , module Control.DeepSeq

1012 , module Test.QuickCheck

1113 , succeeded

1214 , failed

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

3032

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

3234

35+import Control.DeepSeq

3336import Control.Monad.State.Strict

3437

3538import Data.IORef

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

8386 in (toEnum i, g')

8487#endif

8588

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

99import Data.List ( delete )

1010

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+

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

1242possible_attr_mods :: [ AttrOp ]

1343possible_attr_mods =

14− [ set_bold_op

15− , id_op

16− ]

44+ [ id_op

45+ ] ++ map set_fore_color_op all_colors

46+ ++ map set_back_color_op all_colors

47+ ++ map set_style_op all_styles

1748

1849instance Arbitrary Attr where

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

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

3263instance Eq AttrOp where

3364 AttrOp n0 _ == AttrOp n1 _ = n0 == n1

3465

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)

3669id_op = AttrOp "id" id

3770

3871apply_op :: AttrOp -> Attr -> Attr

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

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

1818instance Arbitrary UnitImage where

1919 arbitrary = do

2020 SingleColumnChar c <- arbitrary

21− return $ UnitImage c (char def_attr c)

21+ a <- arbitrary

22+ return $ UnitImage c (char a c)

2223

2324instance Show UnitImage where

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

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

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

5253 -- must be 1

5354 single_column_row_text <- resize 128 (listOf1 arbitrary)

54− attr <- arbitrary

55+ a <- arbitrary

5556 return $ SingleRowSingleAttrImage

56− attr

57+ a

5758 ( 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 ] )

5960

6061data SingleRowTwoAttrImage

6162 = SingleRowTwoAttrImage

test/benchmark.hs+16−10

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

55import Graphics.Vty

7+import qualified BenchImageFuzz

78import qualified BenchNoDiffOpt

89import qualified BenchRenderChar

910import qualified BenchVerticalScroll

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

1617import System.Environment

1718import System.Posix.Process

1819

20+import Verify

21+

1922main = do

2023 args <- getArgs

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

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

2326 , ("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) ]

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

2630 case args of

2731 ["--help"] -> help

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

3135 then args

3236 else map fst benches

3337 -- drop the dash-dash "--"

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

35− case lookup b benches of

36− Just f -> bench b f

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

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

39+ case lookup b_name benches of

40+ Just b -> bench b_name b

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

3842 print results

3943 return ()

4044

41−bench b f = do

42− putStrLn $ "starting " ++ b

43− start_times <- getProcessTimes

44− f

45+bench b_name b = do

46+ putStrLn $ "starting " ++ b_name

47+ Bench b_data_gen b_proc <- b

48+ b_data <- b_data_gen

49+ start_times <- b_data `deepseq` getProcessTimes

50+ b_proc b_data

4551 end_times <- getProcessTimes

4652 let user_time = userTime end_times - userTime start_times

4753 system_time = systemTime end_times - systemTime start_times

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

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

50− return (b, user_time, system_time)

56+ return (b_name, user_time, system_time)

5157

vty.cabal+3−1

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

3030-- the test suites require >= 1.17.0

3131cabal-version: >= 1.14.0

3232build-type: Simple

33−data-files: README,

33+data-files: README.md,

3434 TODO,

3535 AUTHORS,

3636 CHANGELOG,

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

634634

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

636636 bytestring,

637+ Cabal == 1.17.*,

637638 containers,

638639 deepseq >= 1.1 && < 1.4,

639640 ghc-prim,

640641 mtl >= 1.1.1.0 && < 2.2,

641642 parallel >= 2.2 && < 3.3,

642643 parsec >= 2 && < 4,

644+ QuickCheck >= 2.4,

643645 random == 1.0.*,

644646 string-qq,

645647 terminfo >= 0.3 && < 0.4,