From e2cfcb3b9f71c727d29b44e276a3e9fe9d877cca Mon Sep 17 00:00:00 2001
From: Jonathan Daugherty <cygnus@foobox.com>
Date: Sun, 28 Jun 2015 21:00:46 -0700
Subject: [PATCH] Add beginnings of a benchmark suite

---
 brick.cabal               | 27 +++++++++++++++
 programs/Bench.hs         | 70 +++++++++++++++++++++++++++++++++++++++
 src/Brick/Widgets/Core.hs |  6 ++++
 3 files changed, 103 insertions(+)
 create mode 100644 programs/Bench.hs

diff --git a/brick.cabal b/brick.cabal
index 3ac0909..55bc153 100644
--- a/brick.cabal
+++ b/brick.cabal
@@ -58,6 +58,33 @@ executable brick
                        lens,
                        text
 
+Flag bench
+  Description: whether to build benchmarks
+  Default: False
+
+executable brick-bench
+  hs-source-dirs:      programs,src
+
+  if !flag(bench)
+    buildable:         False
+
+  ghc-options:         -threaded -Wall -fno-warn-unused-do-bind -O3
+  default-language:    Haskell2010
+  main-is:             Bench.hs
+  CPP-Options:         -DBENCH
+  build-depends:       base,
+                       transformers,
+                       vty >= 5.2.9,
+                       data-default,
+                       lens,
+                       text,
+                       criterion,
+                       deepseq,
+                       contravariant,
+                       template-haskell,
+                       containers,
+                       vector
+
 executable brick-markup-demo
   hs-source-dirs:      programs
   ghc-options:         -threaded -Wall -fno-warn-unused-do-bind
diff --git a/programs/Bench.hs b/programs/Bench.hs
new file mode 100644
index 0000000..7678e22
--- /dev/null
+++ b/programs/Bench.hs
@@ -0,0 +1,70 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Main where
+
+import Criterion.Main
+import Control.DeepSeq (NFData(..))
+import Data.Monoid
+import Data.Default
+import Graphics.Vty
+import qualified Data.Text as T
+
+import Brick.AttrMap
+import Brick.Widgets.Core
+import Brick.Widgets.Border
+
+instance NFData Widget where
+    rnf w = (hSize w) `seq` (vSize w) `seq` (render w) `seq` ()
+
+aMap :: AttrMap
+aMap = attrMap def []
+
+sz :: DisplayRegion
+sz = (100, 100)
+
+renderBench :: Widget -> Picture
+renderBench w = pic
+    where
+        (_, pic, _) = renderFinal aMap [w] sz (const Nothing) (RS mempty mempty)
+
+mkBench :: String -> Widget -> Benchmark
+mkBench s w = bench s (nf renderBench w)
+
+allGroups :: [Benchmark]
+allGroups =
+    [ bgroup "widgets"
+        [ mkBench "str"                 (str "testing")
+        , mkBench "txt"                 (txt $ T.pack "testing")
+        , mkBench "hBorder"             hBorder
+        , mkBench "hBorderWithLabel"    (hBorderWithLabel (str "label"))
+        , mkBench "vBorder"             vBorder
+        , mkBench "border"              (border $ str "testing")
+        , mkBench "fill"                (fill ' ')
+        , mkBench "hFill"               (hFill ' ')
+        , mkBench "vFill"               (vFill ' ')
+        , mkBench "hBox"                (hBox [str "testing", str "testing"])
+        , mkBench "vBox"                (vBox [str "testing", str "testing"])
+        , mkBench "empty"               emptyWidget
+        , mkBench "hLimit"              (hLimit 1 $ str "t")
+        , mkBench "vLimit"              (vLimit 1 $ str "testing")
+
+        -- withDefaultAttr
+        -- withDefaultAttrName
+        -- withAttrName
+        -- withAttrMappings
+        -- forceAttr
+        -- raw
+        -- withBorderStyle
+        -- translateBy
+        -- cropLeftBy
+        -- cropRightBy
+        -- cropTopBy
+        -- cropBottomBy
+        -- showCursor
+        -- viewport
+        -- visible
+        -- visibleRegion
+        ]
+    ]
+
+main :: IO ()
+main = defaultMain allGroups
diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs
index 901250b..0e49d1e 100644
--- a/src/Brick/Widgets/Core.hs
+++ b/src/Brick/Widgets/Core.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Brick.Widgets.Core
   ( Widget(..)
   , Size(..)
@@ -47,6 +48,11 @@ module Brick.Widgets.Core
   , viewport
   , visible
   , visibleRegion
+
+#ifdef BENCH
+  , renderFinal
+  , RenderState(..)
+#endif
   )
 where