add a generic benchmark executable

src/Graphics/Vty/Error.hs

@@ -0,0 +1,11 @@
+module Graphics.Vty.Error
+    where
+
+import Control.Exception
+
+
+-- | The type of exceptions specific to vty.
+--
+-- These have fully qualified names by default since, IMO, exception handling requires this.
+data VtyException
+    =  VtyFailure String -- | Uncategorized failure specific to vty.

test/BenchRenderChar.hs

@@ -2,31 +2,33 @@
  - This is what Yi uses in Yi.UI.Vty.drawText. Ideally a sequence of renderChar images horizontally
  - composed should provide no worse performance than a fill render op.
  -}
+module BenchRenderChar where
 import Graphics.Vty
 
 import Control.Monad ( forM_ )
 
 import System.Time
 
-main = do
+bench_0 = do
     vty <- mkVty
-    (w, h) <- getSize vty
+    DisplayRegion w h <- display_bounds $ terminal vty
     let test_chars = take 500 $ cycle $ [ c | c <- ['a'..'z']]
-    start_time_0 <- getClockTime
     forM_ test_chars $ \test_char -> do
         let test_image = test_image_using_renderChar test_char w h
-            out_pic = pic { pImage = test_image }
+            out_pic = pic_for_image test_image
         update vty out_pic
-    end_time_0 <- getClockTime
-    let start_time_1 = end_time_0
-    forM_ test_chars $ \test_char -> do
-        let test_image = renderFill attr test_char w h
-            out_pic = pic { pImage = test_image }
-        update vty out_pic
-    end_time_1 <- getClockTime
     shutdown vty
-    putStrLn $ timeDiffToString $ diffClockTimes end_time_0 start_time_0
-    putStrLn $ timeDiffToString $ diffClockTimes end_time_1 start_time_1
 
-test_image_using_renderChar c w h = vertcat $ replicate h $ horzcat $ map (renderChar attr) (replicate w c)
+test_image_using_renderChar c w h = vert_cat $ replicate (fromIntegral h)
+                                             $ horiz_cat $ map (char def_attr)
+                                                               (replicate (fromIntegral w) c)
 
+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

test/BenchVerticalScroll.hs

@@ -1,4 +1,4 @@
-module Main where
+module BenchVerticalScroll where
 
 import Graphics.Vty hiding ( pad )
 
@@ -16,15 +16,9 @@ import System.Random
 main = do 
     let fixed_gen = mkStdGen 0
     setStdGen fixed_gen
-    args <- getArgs
-    case args of
-        []         -> mkVty >>= liftM2 (>>) (run $ Just 0) shutdown
-        ["--delay"]         -> mkVty >>= liftM2 (>>) (run $ Just 1000000) shutdown
-        ["--slow"] -> mkVty >>= liftM2 (>>) (run Nothing ) shutdown
-        _          -> fail "usage: ./Bench [--slow|--delay]"
+    mkVty >>= liftM2 (>>) run shutdown
 
-run (Just delay) vt  = mapM_ (\p -> update vt p >> threadDelay delay) . benchgen =<< display_bounds (terminal vt)
-run Nothing vt = mapM_ (update vt) (benchgen $ DisplayRegion 200 100)
+run vt  = mapM_ (\p -> update vt p) . benchgen =<< display_bounds (terminal vt)
 
 -- Currently, we just do scrolling.
 takem :: (a -> Word) -> Word -> [a] -> ([a],[a])
@@ -54,9 +48,13 @@ pad :: Word -> Image -> Image
 pad ml img = img <|> char_fill def_attr ' ' (ml - image_width img) 1
 
 clines :: StdGen -> Word -> [Image]
-clines g maxll = map (pad maxll . horiz_cat . map (uncurry string)) $ fold (toEnum . length . snd) (lengths maxll g1) (nums g2)
+clines g maxll = map (pad maxll . horiz_cat . map (uncurry string)) 
+                 $ fold (toEnum . length . snd) (lengths maxll g1) (nums g2)
   where (g1,g2)  = split g
 
 benchgen :: DisplayRegion -> [Picture]
-benchgen (DisplayRegion w h) = take 500 $ map ((\i -> pic_for_image i) . vert_cat . take (fromEnum h)) $ tails $ clines (mkStdGen 42) w
+benchgen (DisplayRegion w h) 
+    = take 2000 $ map ((\i -> pic_for_image i) . vert_cat . take (fromEnum h))
+        $ tails
+        $ clines (mkStdGen 80) w
 

test/benchmark.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Main where
+
+import Graphics.Vty
+
+import qualified BenchVerticalScroll
+import qualified BenchRenderChar
+
+import Control.Monad
+
+import Data.Maybe
+import Data.List
+
+import System.Environment
+import System.Posix.Process
+
+main = do
+    args <- getArgs
+    let benches = [ ("vertical-scroll-0", BenchVerticalScroll.main)
+                  , ("render-char-0", BenchRenderChar.bench_0)
+                  , ("render-char-1", BenchRenderChar.bench_1)]
+        help = forM_ benches $ \(b,_) -> putStrLn $ "--" ++ b
+    case args of
+        ["--help"] -> help
+        ["-h"    ] -> help
+        _          -> do
+            let args' = if args /= []
+                        then args
+                        else map fst benches
+            results <- forM args' $ \b -> do
+                case lookup b benches of
+                    Just f  -> bench b f
+                    Nothing -> fail $ "No benchmark named " ++ b
+            print results
+            return ()
+
+bench b f = do
+    putStrLn $ "starting " ++ b
+    start_times <- getProcessTimes
+    f
+    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)
+

vty.cabal

@@ -1,5 +1,5 @@
 name:                vty
-version:             4.7.2
+version:             4.8.0
 license:             BSD3
 license-file:        LICENSE
 author:              AUTHORS
@@ -619,9 +619,33 @@ executable vty-interactive-terminal-test
                        utf8-string >= 0.3 && < 0.4,
                        vector >= 0.7
 
--- Bench.hs
--- Bench2.hs
--- BenchRenderChar.hs
+executable vty-benchmark
+  main-is:             benchmarsk.hs
+
+  default-language:    Haskell2010
+
+  hs-source-dirs:      src test
+
+  c-sources:           cbits/gwinsz.c
+                       cbits/set_term_timing.c
+                       cbits/mk_wcwidth.c
+
+  include-dirs:        cbits
+
+  build-depends:       base >= 4 && < 5,
+                       bytestring,
+                       containers,
+                       deepseq >= 1.1 && < 1.4,
+                       ghc-prim,
+                       mtl >= 1.1.1.0 && < 2.2,
+                       parallel >= 2.2 && < 3.3,
+                       parsec >= 2 && < 4,
+                       string-qq,
+                       terminfo >= 0.3 && < 0.4,
+                       unix,
+                       utf8-string >= 0.3 && < 0.4,
+                       vector >= 0.7
+
 -- ControlTable.hs
 -- HereDoc.hs
 -- Test.hs