Added widgets benchmark

yesod-core/bench/widget.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- | BigTable benchmark implemented using Hamlet.
 --
 {-# LANGUAGE QuasiQuotes #-}
@@ -7,19 +8,22 @@ import Criterion.Main
 import Text.Hamlet
 import Numeric (showInt)
 import qualified Data.ByteString.Lazy as L
-import qualified Text.Blaze.Renderer.Utf8 as Utf8
+import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
 import Data.Monoid (mconcat)
 import Text.Blaze.Html5 (table, tr, td)
-import Yesod.Widget
+import Text.Blaze.Html (toHtml)
+import Yesod.Core.Widget
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.RWS
 import Data.Functor.Identity
-import Yesod.Internal
+import Yesod.Core.Types
+import Data.Monoid
+import Data.IORef
 
 main = defaultMain
     [ bench "bigTable html" $ nf bigTableHtml bigTableData
     , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
-    , bench "bigTable widget" $ nf bigTableWidget bigTableData
+    , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
     , bench "bigTable blaze" $ nf bigTableBlaze bigTableData
     ]
   where
@@ -30,50 +34,35 @@ main = defaultMain
     bigTableData = replicate rows [1..10]
     {-# NOINLINE bigTableData #-}
 
-bigTableHtml rows = L.length $ renderHtml [$hamlet|
-<table
+bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
 |]
 
-bigTableHamlet rows = L.length $ renderHamlet id [$hamlet|
-<table
+bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
 |]
 
-bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet|
-<table
+bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
-|]) (\_ _ -> "foo")
+|])
   where
-  run (GWidget w) =
-    let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0
-     in x
-  {-
-  run (GWidget w) = runIdentity $ do
-    w' <- flip evalStateT 0
-        $ runWriterT $ runWriterT $ runWriterT $ runWriterT
-        $ runWriterT $ runWriterT $ runWriterT w
-    let ((((((((),
-         Body body),
-         _),
-         _),
-         _),
-         _),
-         _),
-         _) = w'
+  render _ _ = "foo"
+  run (WidgetT w) = do
+    (_, GWData { gwdBody = Body x }) <- w undefined
+    return x
 
-    return body
-    -}
-
-bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t
+bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t
   where
-    row r = tr $ mconcat $ map (td . string . show) r
+    row r = tr $ mconcat $ map (td . toHtml . show) r

yesod-core/yesod-core.cabal

@@ -125,6 +125,20 @@ test-suite tests
     ghc-options:     -Wall
     extensions: TemplateHaskell
 
+benchmark widgets
+    type: exitcode-stdio-1.0
+    hs-source-dirs: bench
+    build-depends:  base
+                  , criterion
+                  , bytestring
+                  , text
+                  , hamlet
+                  , transformers
+                  , yesod-core
+                  , blaze-html
+    main-is:        widget.hs
+    ghc-options:    -Wall -O2
+
 source-repository head
   type:     git
   location: https://github.com/yesodweb/yesod