diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for type-of-html +## 1.4.0.1 -- 2018-05-26 + +* reduction of reduction depth + ## 1.4.0.0 -- 2018-05-01 * add fixity for > diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -305,6 +305,15 @@ resulting html as bytestring in the binary and is therefore the fastest possible output. +Please consider as well using the packages +[https://hackage.haskell.org/package/type-of-html-static](type-of-html-static) +which provides helper TH functions to optimize even more at compile +time. It was put in a seperate package to avoid a dependency on TH +(which would've been handy for the functions in `Html.Element`). You +can achieve more or less 5x faster rendering when applying these +optimizations. The actual performance gain depends a lot on the +structure of your document. + ## Comparision to lucid and blaze-html Advantages of `type-of-html`: diff --git a/bench/Alloc.hs b/bench/Alloc.hs --- a/bench/Alloc.hs +++ b/bench/Alloc.hs @@ -71,30 +71,30 @@ f "helloWorld" 1264 (renderByteString . M.helloWorld) () f "page" 1256 (renderByteString . M.page) () f "table" 1664 (renderByteString . M.table) (2,2) - f "AttrShort" 3352 (renderByteString . M.attrShort) () + f "AttrShort" 3232 (renderByteString . M.attrShort) () f "pageA" 2320 (renderByteString . M.pageA) () - f "AttrLong" 2608 (renderByteString . M.attrLong) () + f "AttrLong" 3232 (renderByteString . M.attrLong) () f "Big table" 19968 (renderByteString . M.table) (15,15) - f "Big page" 25064 (renderByteString . B.page) () + f "Big page" 24960 (renderByteString . B.page) () - let libAlloc n = allocsError (101 + n) 7 + let libAlloc n = allocsError (104 + n) 7 validateAction "Compile Library" (compile tmp) "Html" $ libAlloc 0 - validateAction "Compile Small.hs" (compile tmp) "Small" $ libAlloc 4 - validateAction "Compile Medium.hs" (compile tmp) "Medium" $ libAlloc 77 - validateAction "Compile Big.hs" (compile tmp) "Big" $ libAlloc 145 - validateAction "Compile Alloc.hs" (compile tmp) "bench/Alloc.hs" $ libAlloc 151 - validateAction "Compile Perf.hs" (compile tmp) "bench/Perf.hs" $ libAlloc 299 + validateAction "Compile Small.hs" (compile tmp) "Small" $ libAlloc 2 + validateAction "Compile Medium.hs" (compile tmp) "Medium" $ libAlloc 39 + validateAction "Compile Big.hs" (compile tmp) "Big" $ libAlloc 73 + validateAction "Compile Alloc.hs" (compile tmp) "bench/Alloc.hs" $ libAlloc 76 + validateAction "Compile Perf.hs" (compile tmp) "bench/Perf.hs" $ libAlloc 181 - validateAction "Compile X0.hs" (compile tmp) "bench/Compilation/X0.hs" $ libAlloc 5 + validateAction "Compile X0.hs" (compile tmp) "bench/Compilation/X0.hs" $ libAlloc 4 validateAction "Compile X1.hs" (compile tmp) "bench/Compilation/X1.hs" $ libAlloc 5 - validateAction "Compile X2.hs" (compile tmp) "bench/Compilation/X2.hs" $ libAlloc 6 - validateAction "Compile X4.hs" (compile tmp) "bench/Compilation/X4.hs" $ libAlloc 8 - validateAction "Compile X8.hs" (compile tmp) "bench/Compilation/X8.hs" $ libAlloc 13 - validateAction "Compile X16.hs" (compile tmp) "bench/Compilation/X16.hs" $ libAlloc 26 + validateAction "Compile X2.hs" (compile tmp) "bench/Compilation/X2.hs" $ libAlloc 5 + validateAction "Compile X4.hs" (compile tmp) "bench/Compilation/X4.hs" $ libAlloc 7 + validateAction "Compile X8.hs" (compile tmp) "bench/Compilation/X8.hs" $ libAlloc 12 + validateAction "Compile X16.hs" (compile tmp) "bench/Compilation/X16.hs" $ libAlloc 25 validateAction "Compile X32.hs" (compile tmp) "bench/Compilation/X32.hs" $ libAlloc 66 validateAction "Compile X64.hs" (compile tmp) "bench/Compilation/X64.hs" $ libAlloc 205 - validateAction "Compile X128.hs" (compile tmp) "bench/Compilation/X128.hs" $ libAlloc 716 + validateAction "Compile X128.hs" (compile tmp) "bench/Compilation/X128.hs" $ libAlloc 717 compile :: String -> String -> IO () compile out m = diff --git a/bench/Big.hs b/bench/Big.hs --- a/bench/Big.hs +++ b/bench/Big.hs @@ -96,91 +96,3 @@ ) ) ) - -page' = \x -> - html_ - ( body_ - ( h1_A (A.id_ "a") - ( img_ - # strong_A (A.class_ "b") (0 :: Int) - ) - # div_ - ( div_A (A.id_ "c") (1 :: Int) - ) - # attrShort "" - # attrLong "" - # table (3,3) - # div_ - ( form_A (A.class_ "d") - ( fieldset_ - ( div_A (A.id_ "e") - ( div_ - ( label_A (A.class_ "f") "g" - # select_ - ( option_A (A.id_ "h") "i" - # option_ "j" - ) - # div_A (A.class_ "k") "l" - ) - # i_ x - ) - # button_A (A.id_ "m") (i_ "n") - ) - ) - ) - # div_ - ( form_A (A.class_ "o") - ( fieldset_ - ( div_A (A.id_ "p") - ( div_ - ( label_A (A.class_ "q") "r" - # select_ - ( option_A (A.id_ "s") "4" - # option_ "u" - ) - # div_A (A.class_ "v") "w" - ) - # i_ x - ) - # button_A (A.id_ "x") (i_ "y") - ) - ) - ) - # div_ - ( form_A (A.class_ "z") - ( fieldset_ - ( div_A (A.id_ "A") - ( div_ - ( label_A (A.class_ "B") "C" - # select_ - ( option_A (A.id_ "D") "E" - # option_ "F" - ) - # div_A (A.class_ "G") "H" - ) - # i_ x - ) - # button_A (A.id_ "I") (i_ "J") - ) - ) - ) - # div_ - ( form_A (A.class_ "K") - ( fieldset_ - ( div_A (A.id_ "L") - ( div_ - ( label_A (A.class_ "M") "N" - # select_ - ( option_A (A.id_ "O") "P" - # option_ "Q" - ) - # div_A (A.class_ "R") "S" - ) - # i_ x - ) - # button_A (A.id_ "T") (i_ "U") - ) - ) - ) - ) - ) diff --git a/bench/Blaze.hs b/bench/Blaze.hs --- a/bench/Blaze.hs +++ b/bench/Blaze.hs @@ -1,21 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + module Blaze where -import Data.String import Control.Monad import Text.Blaze.Html5 ((!)) -import System.IO.Unsafe -import System.Random - -import qualified Data.Text as T - import qualified Text.Blaze.Html5 as B import qualified Text.Blaze.Html5.Attributes as BA -{-# NOINLINE randomText #-} -randomText :: T.Text -randomText = unsafePerformIO $ T.pack . take 250 . randoms <$> newStdGen - blazeMinimal :: B.Html -> B.Html blazeMinimal = B.div @@ -25,7 +17,7 @@ B.head $ do B.title x B.body $ do - B.p $ fromString "Hello World!" + B.p "Hello World!" blazePage :: B.Html -> B.Html blazePage x = @@ -33,84 +25,82 @@ B.body $ do B.h1 $ do B.img - B.strong $ fromString "0" + B.strong (B.toHtml (0 :: Int)) B.div $ do - B.div $ fromString "1" + B.div (B.toHtml (1 :: Int)) B.div $ do B.form $ do B.fieldset $ do B.div $ do B.div $ do - B.label $ fromString "a" + B.label "a" B.select $ do - B.option $ fromString "b" - B.option $ fromString "c" - B.div $ fromString "d" + B.option "b" + B.option "c" + B.div "d" B.i x - B.button . B.i $ fromString "e" + B.button $ B.i "e" -blazeAttrShort :: B.Html -> B.Html +blazeAttrShort :: B.AttributeValue -> B.Html blazeAttrShort x - = B.i ! BA.accesskey (fromString "a") - $ B.i ! BA.class_ (fromString "b") - $ B.i ! BA.contenteditable (fromString "c") - $ B.i ! BA.contextmenu (fromString "d") - $ B.i ! BA.dir (fromString "e") - $ B.i ! BA.draggable (fromString "f") - $ B.i ! BA.hidden (fromString "g") - $ B.i ! BA.id (fromString "h") - $ B.i ! BA.itemprop (fromString "i") - $ B.i ! BA.lang (fromString "j") - $ B.i ! BA.spellcheck (fromString "k") - $ B.i ! BA.style (fromString "l") - $ B.i ! BA.tabindex (fromString "m") - $ B.i ! BA.title (fromString "n") - $ x + = B.i ! BA.accesskey "a" + $ B.i ! BA.class_ "b" + $ B.i ! BA.contenteditable "c" + $ B.i ! BA.contextmenu "d" + $ B.i ! BA.dir "e" + $ B.i ! BA.draggable "f" + $ B.i ! BA.hidden mempty + $ B.i ! BA.id "h" + $ B.i ! BA.itemprop "i" + $ B.i ! BA.lang "j" + $ B.i ! BA.spellcheck "k" + $ B.i ! BA.style "l" + $ B.i ! BA.title x + $ "m" -blazeAttrLong :: B.Html -> B.Html +blazeAttrLong :: B.AttributeValue -> B.Html blazeAttrLong x - = B.i ! BA.accesskey (fromString "a") - ! BA.class_ (fromString "b") - ! BA.contenteditable (fromString "c") - ! BA.contextmenu (fromString "d") - ! BA.dir (fromString "e") - ! BA.draggable (fromString "f") - ! BA.hidden (fromString "g") - ! BA.id (fromString "h") - ! BA.itemprop (fromString "i") - ! BA.lang (fromString "j") - ! BA.spellcheck (fromString "k") - ! BA.style (fromString "l") - ! BA.tabindex (fromString "m") - ! BA.title (fromString "n") - $ x + = B.i ! BA.accesskey "a" + ! BA.class_ "b" + ! BA.contenteditable "c" + ! BA.contextmenu "d" + ! BA.dir "e" + ! BA.draggable "f" + ! BA.hidden mempty + ! BA.id "h" + ! BA.itemprop "i" + ! BA.lang "j" + ! BA.spellcheck "k" + ! BA.style "l" + ! BA.title x + $ "m" blazePageA :: B.Html -> B.Html blazePageA x = B.html $ do B.body $ do - B.h1 ! BA.id (fromString "a") $ do + B.h1 ! BA.id "a" $ do B.img - B.strong ! BA.class_ (fromString "b") $ fromString "0" + B.strong ! BA.class_ "b" $ (B.toHtml (0 :: Int)) B.div $ do - B.div ! BA.id (fromString "c") $ fromString "1" + B.div ! BA.id "c" $ (B.toHtml (1 :: Int)) B.div $ do - B.form ! BA.class_ (fromString "d") $ do + B.form ! BA.class_ "d" $ do B.fieldset $ do - B.div ! BA.id (fromString "e") $ do + B.div ! BA.id "e" $ do B.div $ do - B.label ! BA.class_ (fromString "f") $ fromString "a" + B.label ! BA.class_ "f" $ "a" B.select $ do - B.option ! BA.id (fromString "g") $ fromString "b" - B.option (fromString "c") - B.div ! BA.class_ (fromString "h") $ fromString "d" + B.option ! BA.id "g" $ "b" + B.option "c" + B.div ! BA.class_ "h" $ "d" B.i x - B.button ! BA.id (fromString "i") $ B.i $ fromString "e" + B.button ! BA.id "i" $ B.i "e" blazeTable :: (Int, Int) -> B.Html blazeTable (n, m) = B.table . replicateM_ n . B.tr - $ mapM_ (B.td . fromString . show) [1..m] + $ mapM_ (B.td . B.toHtml) [1..m] diff --git a/bench/Compilation/X0.hs b/bench/Compilation/X0.hs --- a/bench/Compilation/X0.hs +++ b/bench/Compilation/X0.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X0 (run) where diff --git a/bench/Compilation/X1.hs b/bench/Compilation/X1.hs --- a/bench/Compilation/X1.hs +++ b/bench/Compilation/X1.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X1 (run) where diff --git a/bench/Compilation/X128.hs b/bench/Compilation/X128.hs --- a/bench/Compilation/X128.hs +++ b/bench/Compilation/X128.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X128 (run) where diff --git a/bench/Compilation/X16.hs b/bench/Compilation/X16.hs --- a/bench/Compilation/X16.hs +++ b/bench/Compilation/X16.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X16 (run) where diff --git a/bench/Compilation/X2.hs b/bench/Compilation/X2.hs --- a/bench/Compilation/X2.hs +++ b/bench/Compilation/X2.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X2 (run) where diff --git a/bench/Compilation/X32.hs b/bench/Compilation/X32.hs --- a/bench/Compilation/X32.hs +++ b/bench/Compilation/X32.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X32 (run) where diff --git a/bench/Compilation/X4.hs b/bench/Compilation/X4.hs --- a/bench/Compilation/X4.hs +++ b/bench/Compilation/X4.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X4 (run) where diff --git a/bench/Compilation/X64.hs b/bench/Compilation/X64.hs --- a/bench/Compilation/X64.hs +++ b/bench/Compilation/X64.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X64 (run) where diff --git a/bench/Compilation/X8.hs b/bench/Compilation/X8.hs --- a/bench/Compilation/X8.hs +++ b/bench/Compilation/X8.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -freduction-depth=0 #-} {-# LANGUAGE DataKinds #-} module Compilation.X8 (run) where diff --git a/bench/Medium.hs b/bench/Medium.hs --- a/bench/Medium.hs +++ b/bench/Medium.hs @@ -17,20 +17,8 @@ ) ) -helloWorld' = \x -> - html_ - ( head_ - ( title_ x - ) - # body_ - ( p_ "Hello World!" - ) - ) - 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_ ( body_ @@ -62,85 +50,20 @@ ) ) -page' = \x -> - html_ - ( body_ - ( h1_ - ( img_ - # strong_ (0 :: Int) - ) - # div_ - ( div_ (1 :: Int) - ) - # div_ - ( form_ - ( fieldset_ - ( div_ - ( div_ - ( label_ "a" - # select_ - ( option_ "b" - # option_ "c" - ) - # div_ "d" - ) - # i_ x - ) - # button_ (i_ "e") - ) - ) - ) - ) - ) - - -attrShort x - = i_A (A.accesskey_ "a") - . i_A (A.class_ "b") - . i_A (A.contenteditable_ "c") - . i_A (A.contextmenu_ "d") - . i_A (A.dir_ "e") - . i_A (A.draggable_ "f") - . i_A A.hidden_ - . i_A (A.id_ "h") - . i_A (A.itemprop_ "i") - . i_A (A.lang_ "j") - . i_A (A.spellcheck_ "k") - . i_A (A.style_ "l") - . i_A (A.title_ "m") - $ x - -attrShort' - = i_A (A.accesskey_ "a") - . i_A (A.class_ "b") - . i_A (A.contenteditable_ "c") - . i_A (A.contextmenu_ "d") - . i_A (A.dir_ "e") - . i_A (A.draggable_ "f") - . i_A A.hidden_ - . i_A (A.id_ "h") - . i_A (A.itemprop_ "i") - . i_A (A.lang_ "j") - . i_A (A.spellcheck_ "k") - . i_A (A.style_ "l") - . i_A (A.title_ "m") - -attrShort'' - = \x -> - i_A (A.accesskey_ "a") - . i_A (A.class_ "b") - . i_A (A.contenteditable_ "c") - . i_A (A.contextmenu_ "d") - . i_A (A.dir_ "e") - . i_A (A.draggable_ "f") - . i_A A.hidden_ - . i_A (A.id_ "h") - . i_A (A.itemprop_ "i") - . i_A (A.lang_ "j") - . i_A (A.spellcheck_ "k") - . i_A (A.style_ "l") - . i_A (A.title_ "m") - $ x +attrShort x = + i_A (A.accesskey_ "a") + ( i_A (A.class_ "b") + ( i_A (A.contenteditable_ "c") + ( i_A (A.contextmenu_ "d") + ( i_A (A.dir_ "e") + ( i_A (A.draggable_ "f") + ( i_A A.hidden_ + ( i_A (A.id_ "h") + ( i_A (A.itemprop_ "i") + ( i_A (A.lang_ "j") + ( i_A (A.spellcheck_ "k") + ( i_A (A.style_ "l") + ( i_A (A.title_ x) "m")))))))))))) attrLong x = i_A ( A.accesskey_ "a" @@ -155,40 +78,8 @@ # A.lang_ "j" # A.spellcheck_ "k" # A.style_ "l" - # A.title_ "n" - ) x - -attrLong' = - i_A ( A.accesskey_ "a" - # A.class_ "b" - # A.contenteditable_ "c" - # A.contextmenu_ "d" - # A.dir_ "e" - # A.draggable_ "f" - # A.hidden_ - # A.id_ "h" - # A.itemprop_ "i" - # A.lang_ "j" - # A.spellcheck_ "k" - # A.style_ "l" - # A.title_ "m" - ) - -attrLong'' = \x -> - i_A ( A.accesskey_ "a" - # A.class_ "b" - # A.contenteditable_ "c" - # A.contextmenu_ "d" - # A.dir_ "e" - # A.draggable_ "f" - # A.hidden_ - # A.id_ "h" - # A.itemprop_ "i" - # A.lang_ "j" - # A.spellcheck_ "k" - # A.style_ "l" - # A.title_ "m" - ) x + # A.title_ x + ) "m" pageA x = html_ @@ -215,37 +106,6 @@ # i_ x ) # button_A (A.id_ "n") (i_ "o") - ) - ) - ) - ) - ) - -pageA' = \x -> - html_ - ( body_ - ( h1_A (A.id_ "a") - ( img_ - # strong_A (A.class_ "b") (0 :: Int) - ) - # div_ - ( div_A (A.id_ "c") (1 :: Int) - ) - # div_ - ( form_A (A.class_ "d") - ( fieldset_ - ( div_A (A.id_ "e") - ( div_ - ( label_A (A.class_ "f") "g" - # select_ - ( option_A (A.id_ "h") "i" - # option_ "j" - ) - # div_A (A.class_ "k") "l" - ) - # i_ x - ) - # button_A (A.id_ "m") (i_ "n") ) ) ) diff --git a/bench/Perf.hs b/bench/Perf.hs --- a/bench/Perf.hs +++ b/bench/Perf.hs @@ -13,6 +13,7 @@ import Criterion.Main import Data.String import System.Random +import System.IO.Unsafe import Data.Proxy import Text.Blaze.Html.Renderer.Utf8 import qualified Text.Blaze.Html5 as BL @@ -30,17 +31,9 @@ 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) @@ -64,47 +57,54 @@ 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 "randomString" $ nf renderByteString randomString + , bench "randomStringRaw" $ nf renderByteString randomStringRaw + , bench "randomStrictText" $ nf renderByteString randomStrictText + , bench "randomStrictTextRaw" $ nf renderByteString randomStrictTextRaw + , bench "randomLazyText" $ nf renderByteString randomLazyText + , bench "randomLazyTextRaw" $ nf renderByteString 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 +{-# NOINLINE randomString #-} +randomString :: String +randomString = unsafePerformIO $ take 250 . randoms <$> newStdGen +{-# NOINLINE randomStringRaw #-} +randomStringRaw :: Raw String +randomStringRaw = unsafePerformIO $ Raw . take 250 . randoms <$> newStdGen + +{-# NOINLINE randomStrictText #-} +randomStrictText :: T.Text +randomStrictText = unsafePerformIO $ T.pack . take 250 . randoms <$> newStdGen + +{-# NOINLINE randomStrictTextRaw #-} +randomStrictTextRaw :: Raw T.Text +randomStrictTextRaw = unsafePerformIO $ Raw . T.pack . take 250 . randoms <$> newStdGen + +{-# NOINLINE randomLazyText #-} +randomLazyText :: LT.Text +randomLazyText = unsafePerformIO $ LT.pack . take 250 . randoms <$> newStdGen + +{-# NOINLINE randomLazyTextRaw #-} +randomLazyTextRaw :: Raw LT.Text +randomLazyTextRaw = unsafePerformIO $ Raw . LT.pack . take 250 . 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" + [ bench "blaze-html" $ nf (renderHtml . BL.blazeMinimal) (fromString "") + , bench "type-of-html" $ nf (renderByteString . S.oneElement) "" ] , bgroup "hello world" [ bench "blaze-html" $ nf (renderHtml . BL.blazeHelloWorld) (fromString "TEST") @@ -130,8 +130,8 @@ [ 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 + , bgroup "encode random string" + [ bench "blaze-html" $ nf (renderHtml . BL.div . BL.toHtml) randomString + , bench "type-of-html" $ nf (renderByteString . div_) randomString ] ] diff --git a/bench/Reduction.hs b/bench/Reduction.hs new file mode 100644 --- /dev/null +++ b/bench/Reduction.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures -freduction-depth=29 -fsimpl-tick-factor=42 #-} +module Main where + +import Html +import qualified Html.Attribute as A + +main = print p9 + +p1 = div_A (A.id_ 'a') 'b' + +p2 = div_ (p1 # p1) + +p3 = div_ (p2 # p2) + +p4 = div_ (p3 # p3) + +p5 = div_ (p4 # p4) + +p6 = div_ (p5 # p5) + +p7 = div_ (p6 # p6) + +p8 = div_ (p7 # p7) + +p9 = div_ (p8 # p8) diff --git a/bench/Small.hs b/bench/Small.hs --- a/bench/Small.hs +++ b/bench/Small.hs @@ -5,33 +5,23 @@ import Html -import Control.Arrow - -oneElement, oneElement', oneElement'' +oneElement :: ('Div ?> a) => a -> 'Div > a -oneElement x = div_ x -oneElement' = div_ -oneElement'' = \x -> div_ x +oneElement = div_ -nestedElement, nestedElement', nestedElement'' +nestedElement :: ('Span ?> a) => a -> 'Div > ('Span > a) nestedElement x = div_ (span_ x) -nestedElement' = div_ . span_ -nestedElement'' = \x -> div_ (span_ x) -parallelElement, parallelElement', parallelElement'' +parallelElement :: ('Span ?> a, 'Div ?> a) => a -> ('Div > a) # ('Span > a) parallelElement x = div_ x # span_ x -parallelElement' = uncurry (#) . (div_ &&& span_) -parallelElement'' = \x -> div_ x # span_ x -listElement, listElement', listElement'' +listElement :: ('Div ?> a) => a -> ['Div > a] listElement x = [div_ x] -listElement' = pure . div_ -listElement'' = \x -> [div_ x] diff --git a/src/Html/Type/Internal.hs b/src/Html/Type/Internal.hs --- a/src/Html/Type/Internal.hs +++ b/src/Html/Type/Internal.hs @@ -9,6 +9,8 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} -- Compatibility with ghc8.2 + module Html.Type.Internal where import GHC.TypeLits @@ -444,6 +446,12 @@ -- a big html page get bigger if you try to refactor. type family Append xs ys :: [k] where + Append (x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': x9 ': x10 ': x11 ': x12 ': x13 ': x14 ': x15 ': x16 ': xs) ys + = x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': x9 ': x10 ': x11 ': x12 ': x13 ': x14 ': x15 ': x16 ': Append xs ys + + Append (x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': xs) ys + = x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': Append xs ys + Append (x1 ': x2 ': x3 ': x4 ': xs) ys = x1 ': x2 ': x3 ': x4 ': Append xs ys @@ -465,9 +473,14 @@ Drop 0 xs = xs Drop 1 (_ ': xs) = xs Drop 2 (_ ': _ ': xs) = xs - Drop 3 (_ ': _ ': _ ': xs) = xs Drop 4 (_ ': _ ': _ ': _ ': xs) = xs +#if __GLASGOW_HASKELL__ >= 804 + Drop 8 (_ ': _ ': _ ': _ ': _ ': _ ': _ ': _ ': xs) = xs + Drop n xs = Drop (n - 2^Log2 n) (Drop (2^(Log2 n-1)) (Drop (2^(Log2 n-1)) xs)) +#else + Drop 3 (_ ': _ ': _ ': xs) = xs Drop n (_ ': _ ': _ ': _ ': _ ': xs) = Drop (n-5) xs +#endif -- | Type level take. -- @@ -480,7 +493,12 @@ Take 2 (x1 ': x2 ': _) = '[x1, x2] Take 3 (x1 ': x2 ': x3 ': _) = '[x1, x2, x3] Take 4 (x1 ': x2 ': x3 ': x4 ': _) = '[x1, x2, x3, x4] - Take n (x1 ': x2 ': x3 ': x4 ': x5 ': xs) = x1 ': x2 ': x3 ': x4 ': x5 ': Take (n-5) xs + Take 5 (x1 ': x2 ': x3 ': x4 ': x5 ': _) = '[x1, x2, x3, x4, x5] + Take 6 (x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': _) = '[x1, x2, x3, x4, x5, x6] + Take 7 (x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': _) = '[x1, x2, x3, x4, x5, x6, x7] + Take 8 (x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': _) = '[x1, x2, x3, x4, x5, x6, x7, x8] + Take 9 (x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': x9 ': _) = '[x1, x2, x3, x4, x5, x6, x7, x8, x9] + Take n (x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': x9 ': x10 ': xs) = x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': x9 ': x10 ': Take (n-10) xs -- | Type of type level information about tags. data EInfo 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.4.0.0 +version: 1.4.0.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 @@ -56,6 +56,15 @@ ghc-options: -Wall default-language: Haskell2010 build-depends: base >= 4.9 && < 5 + +benchmark reduction + type: exitcode-stdio-1.0 + main-is: Reduction.hs + hs-source-dirs: bench + ghc-options: -Wall -O2 + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5 + , type-of-html benchmark alloc type: exitcode-stdio-1.0