Skip to content
Browse files

Update benchmarks

- Remove warnings
- Update snap benchmarks to work with snap >= 0.3
- Separate benchmarks from criterion code
  • Loading branch information...
1 parent ed1826c commit f3a6cf8b358086bea0fa4401678cd0b36b5d6c07 @jaspervdj committed Dec 25, 2010
View
27 benchmarks/HtmlBenchmarks.hs
@@ -7,27 +7,12 @@ import Data.Monoid (Monoid, mempty, mconcat, mappend)
import Prelude hiding (div, id)
import qualified Prelude as P
-import Criterion.Main
-import Data.ByteString.Char8 (ByteString)
-import GHC.Exts (IsString, fromString)
-import qualified Data.Text.Lazy as LT
-import qualified Data.ByteString.Lazy as LB
-
import Text.Blaze.Html5 hiding (map)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes hiding (title, rows)
-import qualified Text.Blaze.Renderer.Utf8 as Utf8
-import qualified Text.Blaze.Renderer.String as String
-import qualified Text.Blaze.Renderer.Text as Text
-
-main = defaultMain $ concatMap benchHtml benchmarks
- where
- benchHtml (HtmlBenchmark name f x _) =
- [ bench (name ++ " (Utf8)") $ nf (LB.length . Utf8.renderHtml . f) x
- , bench (name ++ " (String)") $ nf (String.renderHtml . f) x
- , bench (name ++ " (Text)") $ nf (LT.length . Text.renderHtml . f) x
- ]
+-- | Description of an HTML benchmark
+--
data HtmlBenchmark = forall a. HtmlBenchmark
String -- ^ Name.
(a -> Html) -- ^ Rendering function.
@@ -68,7 +53,7 @@ basicData = ("Just a test", "joe", items)
{-# NOINLINE basicData #-}
items :: [String]
-items = map (("Number " `mappend`) . show) [1 .. 14]
+items = map (("Number " `mappend`) . show) [1 :: Int .. 14]
{-# NOINLINE items #-}
wideTreeData :: [String]
@@ -100,15 +85,15 @@ bigTable t = table $ mconcat $ map row t
--
basic :: (String, String, [String]) -- ^ (Title, User, Items)
-> Html -- ^ Result.
-basic (title', user, items) = html $ do
+basic (title', user, items') = html $ do
H.head $ title $ string title'
body $ do
div ! id "header" $ (h1 $ string title')
p $ "Hello, " `mappend` string user `mappend` string "!"
p $ "Hello, me!"
p $ "Hello, world!"
h2 $ "loop"
- ol $ mconcat $ map (li . string) items
+ ol $ mconcat $ map (li . string) items'
div ! id "footer" $ mempty
-- | A benchmark producing a very wide but very shallow tree.
@@ -130,5 +115,5 @@ manyAttributes :: [String] -- ^ List of attribute values.
-> Html -- ^ Result.
manyAttributes = foldl setAttribute img
where
- setAttribute html value = html ! id (stringValue value)
+ setAttribute html' value' = html' ! id (stringValue value')
{-# INLINE setAttribute #-}
View
25 benchmarks/RunHtmlBenchmarks.hs
@@ -0,0 +1,25 @@
+-- | This is a module which runs the 'HtmlBenchmarks' module using the different
+-- renderers available.
+--
+module RunHtmlBenchmarks where
+
+import Criterion.Main
+import qualified Data.Text.Lazy as LT
+import qualified Data.ByteString.Lazy as LB
+
+import qualified Text.Blaze.Renderer.Utf8 as Utf8
+import qualified Text.Blaze.Renderer.String as String
+import qualified Text.Blaze.Renderer.Text as Text
+
+import HtmlBenchmarks (HtmlBenchmark (..), benchmarks)
+
+-- | Function to run the benchmarks using criterion
+--
+main :: IO ()
+main = defaultMain $ concatMap benchHtml benchmarks
+ where
+ benchHtml (HtmlBenchmark name f x _) =
+ [ bench (name ++ " (Utf8)") $ nf (LB.length . Utf8.renderHtml . f) x
+ , bench (name ++ " (String)") $ nf (String.renderHtml . f) x
+ , bench (name ++ " (Text)") $ nf (LT.length . Text.renderHtml . f) x
+ ]
View
11 doc/examples/SnapBenchmarkServer.lhs
@@ -6,7 +6,6 @@ Haskell web framework.
> {-# LANGUAGE OverloadedStrings #-}
> module SnapBenchmarkServer where
-> import System (getArgs)
> import Data.Maybe (fromMaybe)
> import Data.Char (toLower)
> import Control.Applicative ((<$>))
@@ -19,9 +18,8 @@ Haskell web framework.
We re-use most of the `BenchmarkServer`, and the `blazeTemplate` function from
the simple `SnapFramework` example as well.
-> import Text.Blaze.Renderer.Utf8 (renderHtml)
> import BenchmarkServer hiding (main)
-> import HtmlBenchmarks hiding (main)
+> import HtmlBenchmarks (HtmlBenchmark (..))
> import SnapFramework (blazeTemplate)
We now present "Handlers" for our templates: these are values of the type
@@ -63,9 +61,4 @@ the top, and then we can access the benchmarks by name.
The main function is simply the same as in the `SnapFramework` example.
> main :: IO ()
-> main = do
-> args <- getArgs
-> let port = case args of
-> [] -> 8000
-> p:_ -> read p
-> httpServe "*" port "myserver" (Just "access.log") (Just "error.log") site
+> main = httpServe defaultConfig site
View
12 doc/examples/SnapFramework.hs
@@ -4,8 +4,6 @@
{-# LANGUAGE OverloadedStrings #-}
module SnapFramework where
-import System (getArgs)
-
import Snap.Http.Server
import Snap.Types
@@ -38,12 +36,4 @@ site = blazeTemplate welcomePage
-- | Snap main function.
--
main :: IO ()
-main = do
- args <- getArgs
- let port = case args of
- [] -> 8000
- p:_ -> read p
- httpServe "*" port "myserver"
- (Just "access.log")
- (Just "error.log")
- site
+main = httpServe defaultConfig site

0 comments on commit f3a6cf8

Please sign in to comment.
Something went wrong with that request. Please try again.