src/Benchmarks/BlazeTBenchmarks.hs

   1 -- | This is a collection of HTML benchmarks for BlazeMarkup.
   2 --
   3 {-# LANGUAGE OverloadedStrings, ExistentialQuantification, RankNTypes #-}
   4 {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
   5 module Benchmarks.BlazeTBenchmarks where
   6
   7 import           Data.Monoid (Monoid, mempty, mconcat, mappend)
   8 import           Prelude hiding (div, id,map)
   9 import qualified Prelude as P
  10
  11 import           Text.BlazeT
  12 import           Text.BlazeT.Html5
  13 import qualified Text.BlazeT.Html5 as H
  14 import qualified Text.BlazeT.Html5.Attributes as A
  15
  16 -- | Description of an HTML benchmark
  17 --
  18 data HtmlBenchmark = forall a. HtmlBenchmark
  19     String       -- ^ Name.
  20     (a -> Html)  -- ^ Rendering function.
  21     a            -- ^ Data.
  22     Html         -- ^ Longer description.
  23
  24 -- | List containing all benchmarks.
  25 --
  26 benchmarks :: [HtmlBenchmark]
  27 benchmarks =
  28     [ HtmlBenchmark "bigTable" bigTable bigTableData $
  29         let h = toHtml $ length bigTableData
  30             w = toHtml $ length $ P.head bigTableData
  31         in (string "Rendering of a big (") >> h >> (string "x") >> w >> ") HTML table"
  32     , HtmlBenchmark "basic" basic basicData
  33         "A simple, small basic template with a few holes to fill in"
  34     , HtmlBenchmark "wideTree" wideTree wideTreeData $
  35         (string "A very wide tree (") >> toHtml (length wideTreeData) >> " elements)"
  36     , HtmlBenchmark "wideTreeEscaping" wideTree wideTreeEscapingData $ do
  37         (string "A very wide tree (") >> toHtml (length wideTreeData) >> (string " elements)")
  38         " with lots of escaping"
  39     , HtmlBenchmark "deepTree" deepTree deepTreeData $ do
  40         (string "A really deep tree (") >> toHtml deepTreeData >> " nested templates)"
  41     , HtmlBenchmark "manyAttributes" manyAttributes manyAttributesData $ do
  42         (string "A single element with ") >> toHtml (length manyAttributesData)
  43         " attributes."
  44     , HtmlBenchmark "customAttribute" customAttributes customAttributesData $
  45         "Creating custom attributes"
  46     ]
  47
  48 rows :: Int
  49 rows = 1000
  50
  51 bigTableData :: [[Int]]
  52 bigTableData = replicate rows [1..10]
  53 {-# NOINLINE bigTableData #-}
  54
  55 basicData :: (String, String, [String])
  56 basicData = ("Just a test", "joe", items)
  57 {-# NOINLINE basicData #-}
  58
  59 items :: [String]
  60 items = fmap (("Number " `mappend`) . show) [1 :: Int .. 14]
  61 {-# NOINLINE items #-}
  62
  63 wideTreeData :: [String]
  64 wideTreeData = take 5000 $
  65     cycle ["λf.(λx.fxx)(λx.fxx)", "These old days", "Foobar", "lol", "x ∈ A"]
  66 {-# NOINLINE wideTreeData #-}
  67
  68 wideTreeEscapingData :: [String]
  69 wideTreeEscapingData = take 1000 $
  70     cycle ["<><>", "\"lol\"", "<&>", "'>>'"]
  71 {-# NOINLINE wideTreeEscapingData #-}
  72
  73 deepTreeData :: Int
  74 deepTreeData = 1000
  75 {-# NOINLINE deepTreeData #-}
  76
  77 manyAttributesData :: [String]
  78 manyAttributesData = wideTreeData
  79
  80 customAttributesData :: [(String, String)]
  81 customAttributesData = zip wideTreeData wideTreeData
  82
  83 -- | Render the argument matrix as an HTML table.
  84 --
  85 bigTable :: [[Int]]  -- ^ Matrix.
  86          -> Html     -- ^ Result.
  87 bigTable t = table $ mconcat $ fmap row t
  88   where
  89     row r = tr $ mconcat $ fmap (td . toHtml) r
  90
  91 -- | Render a simple HTML page with some data.
  92 --
  93 basic :: (String, String, [String])  -- ^ (Title, User, Items)
  94       -> Html                        -- ^ Result.
  95 basic (title', user, items') = html $ do
  96     H.head $ title $ toHtml title'
  97     body $ do
  98         div ! A.id "header" $ (h1 $ toHtml title')
  99         p $ "Hello, " `mappend` toHtml user `mappend` "!"
 100         p $ "Hello, me!"
 101         p $ "Hello, world!"
 102         h2 $ "loop"
 103         ol $ mconcat $ fmap (li . toHtml) items'
 104         div ! A.id "footer" $ mempty
 105
 106 -- | A benchmark producing a very wide but very shallow tree.
 107 --
 108 wideTree :: [String]  -- ^ Text to create a tree from.
 109          -> Html      -- ^ Result.
 110 wideTree = div . mapM_ ((p ! A.id "foo") . toHtml)
 111
 112 -- | Create a very deep tree.
 113 --
 114 deepTree :: Int   -- ^ Depth of the tree.
 115          -> Html  -- ^ Result.
 116 deepTree 0 = "foo"
 117 deepTree n = p $ table $ tr $ td $ div $ deepTree (n - 1)
 118
 119 -- | Create an element with many attributes.
 120 --
 121 manyAttributes :: [String]  -- ^ List of attribute values.
 122                -> Html      -- ^ Result.
 123 manyAttributes = foldl setAttribute img
 124   where
 125     setAttribute html' value' = html' ! A.id (toValue value')
 126     {-# INLINE setAttribute #-}
 127
 128 customAttributes :: [(String, String)]  -- ^ List of attribute name, value pairs
 129                  -> Html                -- ^ Result
 130 customAttributes = foldl setAttribute img
 131   where
 132     setAttribute html' (name, value') =
 133         html' ! customAttribute (stringTag name) (toValue value')