add new benchmark and improve benchmarking in general.

src/Graphics/Vty/Error.hs

@@ -8,4 +8,4 @@ import Control.Exception
 --
 -- These have fully qualified names by default since, IMO, exception handling requires this.
 data VtyException
-    =  VtyFailure String -- | Uncategorized failure specific to vty.
+    =  VtyFailure String -- ^ Uncategorized failure specific to vty.

src/Graphics/Vty/Image.hs

@@ -37,6 +37,8 @@ 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
@@ -69,7 +71,7 @@ type DisplayString = Seq.Seq (Char, Word)
 --
 -- 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.
+    -- | 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.
@@ -77,7 +79,7 @@ data Image =
       , output_width :: !Word -- >= 0
       , char_width :: !Word -- >= 1
       }
-    -- A horizontal join can be constructed between any two images. However a HorizJoin instance is
+    -- | 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
@@ -86,7 +88,7 @@ data Image =
       , output_width :: !Word -- >= 1
       , output_height :: !Word -- >= 1
       }
-    -- A veritical join can be constructed between any two images. However a VertJoin instance is
+    -- | 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
@@ -95,13 +97,13 @@ data Image =
       , output_width :: !Word -- >= 1
       , output_height :: !Word -- >= 1
       }
-    -- A background fill will be filled with the background pattern. The background pattern is
+    -- | 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. 
+    -- | The combining operators identity constant. 
     -- EmptyImage <|> a = a
     -- EmptyImage <-> a = a
     -- 
@@ -135,7 +137,17 @@ instance Show Image where
 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

src/Graphics/Vty/Picture.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 -- | The Picture data structure is representative of the final terminal view.
 --
 -- 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
 import Graphics.Vty.Attributes
 import Graphics.Vty.Image hiding ( attr )
 
+import Control.DeepSeq
 import Data.Word
 
 -- | The type of images to be displayed using 'update'.  
@@ -44,6 +46,9 @@ data Picture = Picture
 instance Show Picture where
     show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??"
 
+instance NFData Picture where
+    rnf (Picture c i b) = c `deepseq` i `deepseq` b `deepseq` ()
+
 -- | Create a picture for display for the given image. The picture will not have a displayed cursor
 -- and the background display attribute will be `current_attr`.
 pic_for_image :: Image -> Picture
@@ -65,6 +70,10 @@ data Cursor =
       NoCursor
     | Cursor Word Word
 
+instance NFData Cursor where
+    rnf NoCursor = ()
+    rnf (Cursor !w !h) = ()
+
 -- | Unspecified regions are filled with the picture's background pattern.  The background pattern
 -- can specify a character and a display attribute. If the display attribute used previously should
 -- be used for a background fill then use `current_attr` for the background attribute. This is the
@@ -79,3 +88,6 @@ data Background = Background
     , background_attr :: Attr
     }
 
+instance NFData Background where
+    rnf (Background !c !a) = ()
+

test/BenchImageFuzz.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE MultiWayIf #-}
+module BenchImageFuzz where
+import Graphics.Vty
+import Graphics.Vty.Debug
+
+import Verify.Graphics.Vty.Image
+import Verify
+
+import Control.Applicative
+import Control.Monad
+
+import System.Random
+
+rand :: Arbitrary a => IO a
+rand = head <$> sample' arbitrary
+
+random_image w h = do
+    SingleAttrSingleSpanStack i _ _ _ <- rand
+    return i
+
+random_picture w h = pic_for_image <$> random_image w h
+
+bench_0 = do
+    vty <- mkVty
+    DisplayRegion w h <- display_bounds $ terminal vty
+    let pictures = replicateM 100 (random_picture w h)
+        bench ps = do
+            forM ps (update vty)
+            shutdown vty
+    return $ Bench pictures bench
+

test/BenchNoDiffOpt.hs

@@ -3,6 +3,7 @@ module BenchNoDiffOpt where
 
 {-# LANGUAGE BangPatterns #-}
 import Graphics.Vty
+import Verify
 
 import Control.Concurrent( threadDelay )
 import Control.Monad( liftM2 )
@@ -19,10 +20,13 @@ bench_0 = do
     setStdGen fixed_gen
     vty <- mkVty
     DisplayRegion w h <- display_bounds $ terminal vty
-    let image_0 = char_fill def_attr 'X' w h
-    let image_1 = char_fill def_attr '0' w h
-    flip_out vty 300 image_0 image_1
-    shutdown vty
+    let images = return $ (image_0, image_1)
+        image_0 = char_fill def_attr 'X' w h
+        image_1 = char_fill def_attr '0' w h
+        bench d = do
+            flip_out vty 300 image_0 image_1
+            shutdown vty
+    return $ Bench images bench
 
 flip_out vty n image_0 image_1 = 
     let !p_left  = pic_for_image image_0

test/BenchRenderChar.hs

@@ -5,18 +5,21 @@
 module BenchRenderChar where
 
 import Graphics.Vty
+import Verify
 
 import Control.Monad ( forM_ )
 
 bench_0 = do
     vty <- mkVty
     DisplayRegion w h <- display_bounds $ terminal vty
-    let test_chars = take 500 $ cycle $ [ c | c <- ['a'..'z']]
-    forM_ test_chars $ \test_char -> do
-        let test_image = test_image_using_char test_char w h
-            out_pic = pic_for_image test_image
-        update vty out_pic
-    shutdown vty
+    let test_chars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
+        bench d = do
+            forM_ d $ \test_char -> do
+                let test_image = test_image_using_char test_char w h
+                    out_pic = pic_for_image test_image
+                update vty out_pic
+            shutdown vty
+    return $ Bench test_chars bench
 
 test_image_using_char c w h 
     = vert_cat $ replicate (fromIntegral h)
@@ -25,9 +28,11 @@ test_image_using_char c w h
 bench_1 = do
     vty <- mkVty
     DisplayRegion w h <- display_bounds $ terminal vty
-    let test_chars = take 500 $ cycle $ [ c | c <- ['a'..'z']]
-    forM_ test_chars $ \test_char -> do
-        let test_image = char_fill def_attr test_char w h
-            out_pic = pic_for_image test_image
-        update vty out_pic
-    shutdown vty
+    let test_chars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]
+        bench d = do
+            forM_ d $ \test_char -> do
+                let test_image = char_fill def_attr test_char w h
+                    out_pic = pic_for_image test_image
+                update vty out_pic
+            shutdown vty
+    return $ Bench test_chars bench

test/BenchVerticalScroll.hs

@@ -1,6 +1,7 @@
 module BenchVerticalScroll where
 
 import Graphics.Vty hiding ( pad )
+import Verify
 
 import Control.Concurrent( threadDelay )
 import Control.Monad( liftM2 )
@@ -12,11 +13,10 @@ import System.Environment( getArgs )
 import System.IO
 import System.Random
 
-
 bench_0 = do 
     let fixed_gen = mkStdGen 0
     setStdGen fixed_gen
-    mkVty >>= liftM2 (>>) run shutdown
+    return $ Bench (return ()) (\() -> mkVty >>= liftM2 (>>) run shutdown)
 
 run vt  = mapM_ (\p -> update vt p) . benchgen =<< display_bounds (terminal vt)
 

test/Makefile

@@ -14,9 +14,7 @@ verify_inline \
 
 
 TESTS :=\
-Bench \
-Bench2 \
-BenchRenderChar \
+benchmark \
 Test \
 Test2 \
 yi_issue_264 \
@@ -28,9 +26,8 @@ $(shell mkdir -p objects )
 # TODO: Tests should also be buildable referencing the currently installed vty
 GHC_ARGS=--make -i../src \
 		 -package parallel \
-		 -package deepseq-1.3.0.0 \
+		 -package deepseq-1.3.0.1 \
 		 -hide-package transformers \
-		 -hide-package monads-tf \
 		 -package QuickCheck \
 		 -ignore-package vty \
 		 ../cbits/gwinsz.c ../cbits/set_term_timing.c  ../cbits/mk_wcwidth.c \

test/Verify.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}
@@ -7,6 +8,7 @@
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 module Verify ( module Verify
+              , module Control.DeepSeq
               , module Test.QuickCheck
               , succeeded
               , failed
@@ -30,6 +32,7 @@ import Test.QuickCheck.Monadic ( monadicIO )
 
 import qualified Codec.Binary.UTF8.String as UTF8
 
+import Control.DeepSeq
 import Control.Monad.State.Strict
 
 import Data.IORef
@@ -83,3 +86,6 @@ instance Random Word where
         in (toEnum i, g')
 #endif
 
+data Bench where
+    Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
+

test/Verify/Graphics/Vty/Attributes.hs

@@ -8,12 +8,43 @@ import Verify
 
 import Data.List ( delete )
 
+all_colors :: [Color]
+all_colors =
+    [ black
+    , red
+    , green
+    , yellow
+    , blue
+    , magenta
+    , cyan
+    , white
+    , bright_black
+    , bright_red
+    , bright_green
+    , bright_yellow
+    , bright_blue
+    , bright_magenta
+    , bright_cyan
+    , bright_white
+    ] ++ map Color240 [0..239]
+
+all_styles :: [Style]
+all_styles =
+    [ standout
+    , underline
+    , reverse_video
+    , blink
+    , dim
+    , bold
+    ]
+
 -- Limit the possible attributes to just a few for now.
 possible_attr_mods :: [ AttrOp ]
 possible_attr_mods = 
-    [ set_bold_op
-    , id_op 
-    ]
+    [ id_op 
+    ] ++ map set_fore_color_op all_colors
+      ++ map set_back_color_op all_colors
+      ++ map set_style_op all_styles
 
 instance Arbitrary Attr where
     arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr
@@ -32,7 +63,9 @@ data AttrOp = AttrOp String (Attr -> Attr)
 instance Eq AttrOp where
     AttrOp n0 _ == AttrOp n1 _ = n0 == n1
 
-set_bold_op = AttrOp "set_bold" (flip with_style bold)
+set_style_op s = AttrOp "set_style" (flip with_style s)
+set_fore_color_op c = AttrOp "set_fore_color" (flip with_fore_color c)
+set_back_color_op c = AttrOp "set_back_color" (flip with_back_color c)
 id_op = AttrOp "id" id
 
 apply_op :: AttrOp -> Attr -> Attr

test/Verify/Graphics/Vty/Image.hs

@@ -18,7 +18,8 @@ data UnitImage = UnitImage Char Image
 instance Arbitrary UnitImage where
     arbitrary = do
         SingleColumnChar c <- arbitrary
-        return $ UnitImage c (char def_attr c)
+        a <- arbitrary
+        return $ UnitImage c (char a c)
 
 instance Show UnitImage where
     show (UnitImage c _) = "UnitImage " ++ show c
@@ -51,11 +52,11 @@ instance Arbitrary SingleRowSingleAttrImage where
         -- IdImage which has a height of 0. If this is to represent a single row then the height
         -- must be 1
         single_column_row_text <- resize 128 (listOf1 arbitrary)
-        attr <- arbitrary
+        a <- arbitrary
         return $ SingleRowSingleAttrImage 
-                    attr 
+                    a
                     ( fromIntegral $ length single_column_row_text )
-                    ( horiz_cat $ [ char attr c | SingleColumnChar c <- single_column_row_text ] )
+                    ( horiz_cat $ [ char attr c | (SingleColumnChar c, attr) <- single_column_row_text ] )
 
 data SingleRowTwoAttrImage 
     = SingleRowTwoAttrImage 

test/benchmark.hs

@@ -4,6 +4,7 @@ module Main where
 
 import Graphics.Vty
 
+import qualified BenchImageFuzz
 import qualified BenchNoDiffOpt
 import qualified BenchRenderChar
 import qualified BenchVerticalScroll
@@ -16,12 +17,15 @@ import Data.List
 import System.Environment
 import System.Posix.Process
 
+import Verify
+
 main = do
     args <- getArgs
     let benches = [ ("no-diff-opt-0", BenchNoDiffOpt.bench_0)
                   , ("render-char-0", BenchRenderChar.bench_0)
                   , ("render-char-1", BenchRenderChar.bench_1)
-                  , ("vertical-scroll-0", BenchVerticalScroll.bench_0)]
+                  , ("vertical-scroll-0", BenchVerticalScroll.bench_0)
+                  , ("image-fuzz-0", BenchImageFuzz.bench_0) ]
         help = forM_ benches $ \(b,_) -> putStrLn $ "--" ++ b
     case args of
         ["--help"] -> help
@@ -31,21 +35,23 @@ main = do
                         then args
                         else map fst benches
             -- drop the dash-dash "--"
-            results <- forM args' $ \(_ : _ : b) -> do
-                case lookup b benches of
-                    Just f  -> bench b f
-                    Nothing -> fail $ "No benchmark named " ++ b
+            results <- forM args' $ \(_ : _ : b_name) -> do
+                case lookup b_name benches of
+                    Just b  -> bench b_name b
+                    Nothing -> fail $ "No benchmark named " ++ b_name
             print results
             return ()
 
-bench b f = do
-    putStrLn $ "starting " ++ b
-    start_times <- getProcessTimes
-    f
+bench b_name b = do
+    putStrLn $ "starting " ++ b_name
+    Bench b_data_gen b_proc <- b
+    b_data <- b_data_gen
+    start_times <- b_data `deepseq` getProcessTimes
+    b_proc b_data
     end_times <- getProcessTimes
     let user_time = userTime end_times - userTime start_times
         system_time = systemTime end_times - systemTime start_times
     putStrLn $ "user time: " ++ show user_time
     putStrLn $ "system time: " ++ show system_time
-    return (b, user_time, system_time)
+    return (b_name, user_time, system_time)
 

vty.cabal

@@ -30,7 +30,7 @@ description:
 -- the test suites require >= 1.17.0
 cabal-version:        >= 1.14.0
 build-type:           Simple
-data-files:          README,
+data-files:          README.md,
                      TODO,
                      AUTHORS,
                      CHANGELOG,
@@ -634,12 +634,14 @@ executable vty-benchmark
 
   build-depends:       base >= 4 && < 5,
                        bytestring,
+                       Cabal == 1.17.*,
                        containers,
                        deepseq >= 1.1 && < 1.4,
                        ghc-prim,
                        mtl >= 1.1.1.0 && < 2.2,
                        parallel >= 2.2 && < 3.3,
                        parsec >= 2 && < 4,
+                       QuickCheck >= 2.4,
                        random == 1.0.*,
                        string-qq,
                        terminfo >= 0.3 && < 0.4,