diff --git a/bench/Alloc.hs b/bench/Alloc.hs new file mode 100644 --- /dev/null +++ b/bench/Alloc.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} + +module Main where + +import Html +import qualified Html.Attribute as A +import qualified Small as S +import qualified Medium as M +import qualified Big as B + +import Weigh +import Control.DeepSeq +import Data.Proxy +import Data.Int + +allocs :: Int64 -> Weight -> Maybe String +allocs n w + | n' > n = Just $ "More" ++ answer + | n' < n = Just $ "Less" ++ answer + | otherwise = Nothing + where n' = weightAllocatedBytes w + answer = " allocated bytes than " ++ commas n ++ ": " ++ commas n' + +f :: NFData b => String -> Int64 -> (a -> b) -> a -> Weigh () +f s n g x = validateFunc s g x (allocs n) + +main :: IO () +main = mainWith $ do + + -- nixpkgs: 1b27260 + -- ghc: 8.4.1 + + f "()" 4256 renderByteString () + f "Int" 4328 renderByteString (123456789 :: Int) + f "Word" 4328 renderByteString (123456789 :: Word) + f "Char" 4344 renderByteString 'a' + f "Integer" 4360 renderByteString (123456789 :: Integer) + f "Proxy" 4392 renderByteString (Proxy :: Proxy "a") + f "oneElement Proxy" 4392 (renderByteString . S.oneElement) (Proxy :: Proxy "b") + f "oneElement ()" 4392 (renderByteString . S.oneElement) () + f "oneAttribute ()" 4392 (renderByteString . A.class_) () + f "oneAttribute Proxy" 4392 (renderByteString . A.class_) (Proxy :: Proxy "c") + f "listElement" 4488 (renderByteString . S.listElement) () + f "Double" 4472 renderByteString (123456789 :: Double) + f "oneElement" 4480 (renderByteString . S.oneElement) "" + f "nestedElement" 4480 (renderByteString . S.nestedElement) "" + f "listOfAttributes" 4464 (\x -> renderByteString [A.class_ x, A.class_ x]) () + f "Float" 4512 renderByteString (123456789 :: Float) + f "oneAttribute" 4520 (renderByteString . A.class_) "" + f "parallelElement" 4632 (renderByteString . S.parallelElement) "" + f "parallelAttribute" 4696 (\x -> renderByteString $ A.class_ x # A.id_ x) "" + f "elementWithAttribute" 4696 (\x -> renderByteString $ div_A (A.class_ x) x) "" + f "listOfListOf" 4744 (\x -> renderByteString $ div_ [i_ [span_ x]]) () + f "helloWorld" 5344 (renderByteString . M.helloWorld) () + f "page" 5624 (renderByteString . M.page) () + f "table" 5776 (renderByteString . M.table) (2,2) + f "AttrShort" 6720 (renderByteString . M.attrShort) () + f "pageA" 7072 (renderByteString . M.pageA) () + f "AttrLong" 7272 (renderByteString . M.attrLong) () + f "Big table" 19712 (renderByteString . M.table) (15,15) + f "Big page" 24704 (renderByteString . B.page) () diff --git a/bench/Big.hs b/bench/Big.hs --- a/bench/Big.hs +++ b/bench/Big.hs @@ -1,26 +1,13 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Big where import Html -import Medium (attrShort, attrLong) +import Medium (attrShort, attrLong, table) -import Criterion.Main import qualified Html.Attribute as A - -big :: Benchmark -big = bgroup "Big" - [ bench "table" $ nf (renderByteString . table) (15,15) - , bench "table'" $ nf (renderByteString . table') (15,15) - , bench "page" $ nf (renderByteString . page) "big" - , bench "page'" $ nf (renderByteString . page') "big" - ] - -table (n, m) = table_ . replicate n . tr_ $ map td_ [(1::Int)..m] - -table' = \(n,m) -> table_ . replicate n . tr_ $ map td_ [(1::Int)..m] page x = html_ diff --git a/bench/Blaze.hs b/bench/Blaze.hs --- a/bench/Blaze.hs +++ b/bench/Blaze.hs @@ -1,17 +1,12 @@ module Blaze where -import Html -import Small -import Medium - import Data.String -import Criterion.Main import Control.Monad import Text.Blaze.Html5 ((!)) -import Text.Blaze.Html.Renderer.Utf8 import System.IO.Unsafe -import Test.QuickCheck +import System.Random + import qualified Data.Text as T import qualified Text.Blaze.Html5 as B @@ -19,45 +14,7 @@ {-# NOINLINE randomText #-} randomText :: T.Text -randomText = unsafePerformIO $ do - s <- take 250 <$> generate infiniteList :: IO String - return $ T.pack s - -blaze :: Benchmark -blaze = bgroup "Blaze" - [ bgroup "minimal" - [ bench "blaze-html" $ nf (renderHtml . blazeMinimal) (fromString "TEST") - , bench "type-of-html" $ nf (renderByteString . oneElement) "TEST" - ] - , bgroup "hello world" - [ bench "blaze-html" $ nf (renderHtml . blazeHelloWorld) (fromString "TEST") - , bench "type-of-html" $ nf (renderByteString . helloWorld) "TEST" - ] - , bgroup "attributes long" - [ bench "blaze-html" $ nf (renderHtml . blazeAttrLong) (fromString "TEST") - , bench "type-of-html" $ nf (renderByteString . attrLong) "TEST" - ] - , bgroup "attributes short" - [ bench "blaze-html" $ nf (renderHtml . blazeAttrShort) (fromString "TEST") - , bench "type-of-html" $ nf (renderByteString . attrShort) "TEST" - ] - , bgroup "page" - [ bench "blaze-html" $ nf (renderHtml . blazePage) (fromString "TEST") - , bench "type-of-html" $ nf (renderByteString . page) "TEST" - ] - , bgroup "page with attributes" - [ bench "blaze-html" $ nf (renderHtml . blazePageA) (fromString "TEST") - , bench "type-of-html" $ nf (renderByteString . pageA) "TEST" - ] - , bgroup "table" - [ bench "blaze-html" $ nf (renderHtml . blazeTable) (4,4) - , bench "type-of-html" $ nf (renderByteString . table) (4,4) - ] - , bgroup "encode strict text" - [ bench "blaze-html" $ nf (renderHtml . B.div . B.toHtml) randomText - , bench "type-of-html" $ nf (renderByteString . div_) randomText - ] - ] +randomText = unsafePerformIO $ T.pack . take 250 . randoms <$> newStdGen blazeMinimal :: B.Html -> B.Html blazeMinimal = B.div diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 --- a/bench/Main.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Main where - -import Blaze -import Small -import Medium -import Big - -import Criterion.Main - -main :: IO () -main = defaultMain - [ small - , medium - , big - , blaze - ] diff --git a/bench/Medium.hs b/bench/Medium.hs --- a/bench/Medium.hs +++ b/bench/Medium.hs @@ -1,66 +1,12 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module Medium where import Html - -import Test.QuickCheck -import Criterion.Main - import qualified Html.Attribute as A -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -medium :: Benchmark -medium = bgroup "Medium" - [ bench "helloWorld" $ nf (renderByteString . helloWorld) "medium" - , bench "helloWorld'" $ nf (renderByteString . helloWorld') "medium" - , bench "randomString" $ nfIO randomString - , bench "randomStringRaw" $ nfIO randomStringRaw - , bench "randomStrictText" $ nfIO randomStrictText - , bench "randomStrictTextRaw" $ nfIO randomStrictTextRaw - , bench "randomLazyText" $ nfIO randomLazyText - , bench "randomLazyTextRaw" $ nfIO randomLazyTextRaw - , bench "table" $ nf (renderByteString . table) (2,2) - , bench "table'" $ nf (renderByteString . table') (2,2) - , bench "page" $ nf (renderByteString . page) "medium" - , bench "page'" $ nf (renderByteString . page') "medium" - , bench "pageA" $ nf (renderByteString . pageA) "medium" - , bench "pageA'" $ nf (renderByteString . pageA') "medium" - , bench "attrShort" $ nf (renderByteString . attrShort) "medium" - , bench "attrShort'" $ nf (renderByteString . attrShort') "medium" - , bench "attrShort''" $ nf (renderByteString . attrShort'') "medium" - , bench "attrLong" $ nf (renderByteString . attrLong) "medium" - , bench "attrLong'" $ nf (renderByteString . attrLong') "medium" - , bench "attrLong''" $ nf (renderByteString . attrLong'') "medium" - ] - -randomString = do - a <- generate (resize 5 arbitrary) :: IO String - return . renderByteString $ div_ a - -randomStringRaw = do - a <- generate (resize 5 arbitrary) :: IO String - return . renderByteString $ div_ (Raw a) - -randomStrictText = do - a <- T.pack <$> generate (resize 5 arbitrary) :: IO T.Text - return . renderByteString $ div_ a - -randomStrictTextRaw = do - a <- T.pack <$> generate (resize 5 arbitrary) :: IO T.Text - return . renderByteString $ div_ (Raw a) - -randomLazyText = do - a <- LT.pack <$> generate (resize 5 arbitrary) :: IO LT.Text - return . renderByteString $ div_ a - -randomLazyTextRaw = do - a <- LT.pack <$> generate (resize 5 arbitrary) :: IO LT.Text - return . renderByteString $ div_ (Raw a) - helloWorld x = html_ ( head_ @@ -155,7 +101,7 @@ . i_A (A.contextmenu_ "d") . i_A (A.dir_ "e") . i_A (A.draggable_ "f") - . i_A (A.hidden_ ) + . i_A A.hidden_ . i_A (A.id_ "h") . i_A (A.itemprop_ "i") . i_A (A.lang_ "j") @@ -171,7 +117,7 @@ . i_A (A.contextmenu_ "d") . i_A (A.dir_ "e") . i_A (A.draggable_ "f") - . i_A (A.hidden_ ) + . i_A A.hidden_ . i_A (A.id_ "h") . i_A (A.itemprop_ "i") . i_A (A.lang_ "j") @@ -187,7 +133,7 @@ . i_A (A.contextmenu_ "d") . i_A (A.dir_ "e") . i_A (A.draggable_ "f") - . i_A (A.hidden_ ) + . i_A A.hidden_ . i_A (A.id_ "h") . i_A (A.itemprop_ "i") . i_A (A.lang_ "j") diff --git a/bench/Perf.hs b/bench/Perf.hs new file mode 100644 --- /dev/null +++ b/bench/Perf.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Html +import qualified Html.Attribute as A +import qualified Blaze as BL +import qualified Small as S +import qualified Medium as M +import qualified Big as B + +import Criterion.Main +import Data.String +import System.Random +import Data.Proxy +import Text.Blaze.Html.Renderer.Utf8 +import qualified Text.Blaze.Html5 as BL +import qualified Data.Text.Lazy as LT +import qualified Data.Text as T + +main :: IO () +main = defaultMain + [ small + , medium + , big + , blaze + ] + +small :: Benchmark +small = bgroup "Small" + [ bench "oneElement" $ nf (renderByteString . S.oneElement) "" + , bench "oneElement'" $ nf (renderByteString . S.oneElement') "" + , bench "oneElement''" $ nf (renderByteString . S.oneElement'') "" + , bench "nestedElement" $ nf (renderByteString . S.nestedElement) "" + , bench "nestedElement'" $ nf (renderByteString . S.nestedElement') "" + , bench "nestedElement''" $ nf (renderByteString . S.nestedElement'') "" + , bench "parallelElement" $ nf (renderByteString . S.parallelElement) "" + , bench "parallelElement'" $ nf (renderByteString . S.parallelElement') "" + , bench "parallelElement''" $ nf (renderByteString . S.parallelElement'') "" + , bench "listElement" $ nf (renderByteString . S.listElement) "" + , bench "listElement'" $ nf (renderByteString . S.listElement') "" + , bench "listElement''" $ nf (renderByteString . S.listElement'') "" + , bench "Int" $ nf renderByteString (123456789 :: Int) + , bench "Integer" $ nf renderByteString (123456789 :: Integer) + , bench "Double" $ nf renderByteString (123456789 :: Double) + , bench "Float" $ nf renderByteString (123456789 :: Float) + , bench "Word" $ nf renderByteString (123456789 :: Word) + , bench "Proxy" $ nf renderByteString (Proxy :: Proxy "abc") + , bench "Char" $ nf renderByteString 'a' + , bench "oneElement Proxy" $ nf (renderByteString . S.oneElement) (Proxy :: Proxy "abc") + , bench "()" $ nf renderByteString () + , bench "oneElement ()" $ nf (renderByteString . S.oneElement) () + , bench "oneAttribute" $ nf (renderByteString . A.class_) "" + , bench "oneAttribute ()" $ nf (renderByteString . A.class_) () + , bench "oneAttribute Proxy" $ nf (renderByteString . A.class_) (Proxy :: Proxy "abc") + , bench "parallelAttribute" $ nf (\x -> renderByteString $ A.class_ x # A.id_ x) "" + , bench "elementWithAttribute" $ nf (\x -> renderByteString $ div_A (A.class_ x) x) "" + , bench "elementWithParallelAttribute" $ nf (\x -> renderByteString $ div_A (A.class_ x # A.id_ x) x) "" + , bench "listOfAttributes" $ nf (\x -> renderByteString [A.class_ x, A.class_ x]) "" + , bench "listOfListOf" $ nf (\x -> renderByteString $ div_ [i_ [span_ x]]) "" + ] + +medium :: Benchmark +medium = bgroup "Medium" + [ bench "helloWorld" $ nf (renderByteString . M.helloWorld) "medium" + , bench "helloWorld'" $ nf (renderByteString . M.helloWorld') "medium" + , bench "randomString" $ nfIO randomString + , bench "randomStringRaw" $ nfIO randomStringRaw + , bench "randomStrictText" $ nfIO randomStrictText + , bench "randomStrictTextRaw" $ nfIO randomStrictTextRaw + , bench "randomLazyText" $ nfIO randomLazyText + , bench "randomLazyTextRaw" $ nfIO randomLazyTextRaw + , bench "table" $ nf (renderByteString . M.table) (2,2) + , bench "table'" $ nf (renderByteString . M.table') (2,2) + , bench "page" $ nf (renderByteString . M.page) "medium" + , bench "page'" $ nf (renderByteString . M.page') "medium" + , bench "pageA" $ nf (renderByteString . M.pageA) "medium" + , bench "pageA'" $ nf (renderByteString . M.pageA') "medium" + , bench "attrShort" $ nf (renderByteString . M.attrShort) "medium" + , bench "attrShort'" $ nf (renderByteString . M.attrShort') "medium" + , bench "attrShort''" $ nf (renderByteString . M.attrShort'') "medium" + , bench "attrLong" $ nf (renderByteString . M.attrLong) "medium" + , bench "attrLong'" $ nf (renderByteString . M.attrLong') "medium" + , bench "attrLong''" $ nf (renderByteString . M.attrLong'') "medium" + ] where + + randomString = renderByteString . div_ . take 5 . randoms @Char <$> newStdGen + randomStringRaw = renderByteString . div_ . Raw . take 5 . randoms @Char <$> newStdGen + randomStrictText = renderByteString . div_ . T.pack . take 5 . randoms <$> newStdGen + randomStrictTextRaw = renderByteString . div_ . Raw . T.pack . take 5 . randoms <$> newStdGen + randomLazyText = renderByteString . div_ . LT.pack . take 5 . randoms <$> newStdGen + randomLazyTextRaw = renderByteString . div_ . Raw . LT.pack . take 5 . randoms <$> newStdGen + +big :: Benchmark +big = bgroup "Big" + [ bench "table" $ nf (renderByteString . M.table) (15,15) + , bench "table'" $ nf (renderByteString . M.table') (15,15) + , bench "page" $ nf (renderByteString . B.page) "big" + , bench "page'" $ nf (renderByteString . B.page') "big" + ] + +blaze :: Benchmark +blaze = bgroup "Blaze" + [ bgroup "minimal" + [ bench "blaze-html" $ nf (renderHtml . BL.blazeMinimal) (fromString "TEST") + , bench "type-of-html" $ nf (renderByteString . S.oneElement) "TEST" + ] + , bgroup "hello world" + [ bench "blaze-html" $ nf (renderHtml . BL.blazeHelloWorld) (fromString "TEST") + , bench "type-of-html" $ nf (renderByteString . M.helloWorld) "TEST" + ] + , bgroup "attributes long" + [ bench "blaze-html" $ nf (renderHtml . BL.blazeAttrLong) (fromString "TEST") + , bench "type-of-html" $ nf (renderByteString . M.attrLong) "TEST" + ] + , bgroup "attributes short" + [ bench "blaze-html" $ nf (renderHtml . BL.blazeAttrShort) (fromString "TEST") + , bench "type-of-html" $ nf (renderByteString . M.attrShort) "TEST" + ] + , bgroup "page" + [ bench "blaze-html" $ nf (renderHtml . BL.blazePage) (fromString "TEST") + , bench "type-of-html" $ nf (renderByteString . M.page) "TEST" + ] + , bgroup "page with attributes" + [ bench "blaze-html" $ nf (renderHtml . BL.blazePageA) (fromString "TEST") + , bench "type-of-html" $ nf (renderByteString . M.pageA) "TEST" + ] + , bgroup "table" + [ bench "blaze-html" $ nf (renderHtml . BL.blazeTable) (4,4) + , bench "type-of-html" $ nf (renderByteString . M.table) (4,4) + ] + , bgroup "encode strict text" + [ bench "blaze-html" $ nf (renderHtml . BL.div . BL.toHtml) BL.randomText + , bench "type-of-html" $ nf (renderByteString . div_) BL.randomText + ] + ] diff --git a/bench/Small.hs b/bench/Small.hs --- a/bench/Small.hs +++ b/bench/Small.hs @@ -1,79 +1,11 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} module Small where import Html -import qualified Html.Attribute as A -import Data.Proxy -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Data.IORef -import System.IO.Unsafe - -import Criterion.Main import Control.Arrow - -small :: Benchmark -small = bgroup "Small" - [ bench "oneElement" $ nf (renderByteString . oneElement) "" - , bench "oneElement'" $ nf (renderByteString . oneElement') "" - , bench "oneElement''" $ nf (renderByteString . oneElement'') "" - , bench "nestedElement" $ nf (renderByteString . nestedElement) "" - , bench "nestedElement'" $ nf (renderByteString . nestedElement') "" - , bench "nestedElement''" $ nf (renderByteString . nestedElement'') "" - , bench "parallelElement" $ nf (renderByteString . parallelElement) "" - , bench "parallelElement'" $ nf (renderByteString . parallelElement') "" - , bench "parallelElement''" $ nf (renderByteString . parallelElement'') "" - , bench "listElement" $ nf (renderByteString . listElement) "" - , bench "listElement'" $ nf (renderByteString . listElement') "" - , bench "listElement''" $ nf (renderByteString . listElement'') "" - , bench "Int" $ nf renderByteString (123456789 :: Int) - , bench "Integer" $ nf renderByteString (123456789 :: Integer) - , bench "Double" $ nf renderByteString (123456789 :: Double) - , bench "Float" $ nf renderByteString (123456789 :: Float) - , bench "Word" $ nf renderByteString (123456789 :: Word) - , bench "Proxy" $ nf renderByteString (Proxy :: Proxy "abc") - , bench "Char" $ nf renderByteString 'a' - , bench "oneElement Proxy" $ nf (renderByteString . oneElement) (Proxy :: Proxy "abc") - , bench "()" $ nf renderByteString () - , bench "oneElement ()" $ nf (renderByteString . oneElement) () - , bench "oneAttribute" $ nf (renderByteString . A.class_) "" - , bench "oneAttribute ()" $ nf (renderByteString . A.class_) () - , bench "oneAttribute Proxy" $ nf (renderByteString . A.class_) (Proxy :: Proxy "abc") - , bench "parallelAttribute" $ nf (\x -> renderByteString $ A.class_ x # A.id_ x) "" - , bench "elementWithAttribute" $ nf (\x -> renderByteString $ div_A (A.class_ x) x) "" - , bench "elementWithParallelAttribute" $ nf (\x -> renderByteString $ div_A (A.class_ x # A.id_ x) x) "" - , bench "listOfAttributes" $ nf (\x -> renderByteString [A.class_ x, A.class_ x]) "" - , bench "Runtime String" $ nfIO (renderByteString <$> readIORef runtimeString) - , bench "String" $ nf renderByteString "abcdefghijklmnopqrstuvwxyz<>&;" - , bench "Runtime Raw String" $ nfIO (renderByteString . Raw <$> readIORef runtimeString) - , bench "Raw String" $ nf renderByteString (Raw "abcdefghijklmnopqrstuvwxyz<>&;") - , bench "Runtime strict Text" $ nfIO (renderByteString <$> readIORef runtimeStrictText) - , bench "strict Text" $ nf renderByteString (T.pack "abcdefghijklmnopqrstuvwxyz<>&;") - , bench "Runtime Raw strict Text" $ nfIO (renderByteString . Raw <$> readIORef runtimeStrictText) - , bench "Raw strict Text" $ nf renderByteString (Raw (T.pack "abcdefghijklmnopqrstuvwxyz<>&;")) - , bench "Runtime lazy Text" $ nfIO (renderByteString <$> readIORef runtimeLazyText) - , bench "lazy Text" $ nf renderByteString (LT.pack "abcdefghijklmnopqrstuvwxyz<>&;") - , bench "Runtime Raw lazy Text" $ nfIO (renderByteString . Raw <$> readIORef runtimeLazyText) - , bench "Raw lazy Text" $ nf renderByteString (Raw (LT.pack "abcdefghijklmnopqrstuvwxyz<>&;")) - , bench "listOfListOf" $ nf (\x -> renderByteString $ div_ [i_ [span_ x]]) "" - ] - where - -{-# NOINLINE runtimeString #-} -runtimeString :: IORef String -runtimeString = unsafePerformIO $ newIORef "abcdefghijklmnopqrstuvwxyz<>&;" - -{-# NOINLINE runtimeLazyText #-} -runtimeLazyText :: IORef LT.Text -runtimeLazyText = unsafePerformIO . newIORef $ LT.pack "abcdefghijklmnopqrstuvwxyz<>&;" - -{-# NOINLINE runtimeStrictText #-} -runtimeStrictText :: IORef T.Text -runtimeStrictText = unsafePerformIO . newIORef $ T.pack "abcdefghijklmnopqrstuvwxyz<>&;" oneElement, oneElement', oneElement'' :: ('Div ?> a) diff --git a/type-of-html.cabal b/type-of-html.cabal --- a/type-of-html.cabal +++ b/type-of-html.cabal @@ -1,5 +1,5 @@ name: type-of-html -version: 1.3.3.0 +version: 1.3.3.1 synopsis: High performance type driven html generation. description: This library makes most invalid html documents compile time errors and uses advanced type level features to realise compile time computations. license: BSD3 @@ -9,6 +9,7 @@ homepage: https://github.com/knupfer/type-of-html tested-with: GHC == 8.0.2 , GHC == 8.2.2 + , GHC == 8.4.1 copyright: 2017, Florian Knupfer category: Language, Text, Web, HTML build-type: Simple @@ -48,12 +49,26 @@ , QuickCheck , hspec -benchmark bench +benchmark alloc type: exitcode-stdio-1.0 - main-is: Main.hs + main-is: Alloc.hs other-modules: Small , Medium , Big + hs-source-dirs: bench + ghc-options: -Wall -O2 + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5 + , type-of-html + , deepseq + , weigh + +benchmark perf + type: exitcode-stdio-1.0 + main-is: Perf.hs + other-modules: Small + , Medium + , Big , Blaze hs-source-dirs: bench ghc-options: -Wall -O2 @@ -64,4 +79,4 @@ , bytestring , blaze-html , criterion - , QuickCheck + , random