diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for type-of-html +## 1.3.4.0 -- 2018-04-03 + +* reduce allocations +* add compilation benchmarks +* small bug fixes + ## 1.3.3.2 -- 2018-03-25 * reduce allocations for smaller pages diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -171,7 +171,7 @@ This is comparing blaze with `type-of-html`: -![type-of-html](https://user-images.githubusercontent.com/5609565/30524978-229dd21c-9bfe-11e7-8404-1f69b93cec22.png) +![type-of-html](https://user-images.githubusercontent.com/5609565/37879227-765df128-3075-11e8-9270-3839ce1852c8.png) To look at the exact code of this benchmark look into the repo. The big table benchmark here is only a 4x4 table. Using a 1000x10 table diff --git a/bench/Alloc.hs b/bench/Alloc.hs --- a/bench/Alloc.hs +++ b/bench/Alloc.hs @@ -13,6 +13,12 @@ import Data.Proxy import Data.Int +import System.IO.Temp +import GHC +import GHC.Paths (libdir) +import DynFlags +import Control.Monad + allocs :: Int64 -> Weight -> Maybe String allocs n w | n' > n = Just $ "More" ++ answer @@ -21,11 +27,24 @@ where n' = weightAllocatedBytes w answer = " allocated bytes than " ++ commas n ++ ": " ++ commas n' +allocsError :: Int -> Int -> Weight -> Maybe String +allocsError n i w + | n' > (n+1) = Just $ "More" ++ answer + | n' < (n-1) = Just $ "Less" ++ answer + | otherwise = Nothing + where n' = round (fromIntegral (weightAllocatedBytes w) / (10^i) :: Rational) :: Int + answer = " allocated bytes than " + ++ pretty (show n) + ++ ": " + ++ pretty (show n') + pretty (a:as) = a : '.' : as ++ " e" ++ show (length as+i) + pretty _ = "" + 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 +main = withSystemTempDirectory "compile" $ \tmp -> mainWith $ do -- nixpkgs: 1b27260 -- ghc: 8.4.1 @@ -40,7 +59,7 @@ f "oneElement ()" 280 (renderByteString . S.oneElement) () f "oneAttribute ()" 280 (renderByteString . A.class_) () f "oneAttribute Proxy" 280 (renderByteString . A.class_) (Proxy :: Proxy "c") - f "listElement" 376 (renderByteString . S.listElement) () + f "listElement" 352 (renderByteString . S.listElement) () f "Double" 360 renderByteString (123456789 :: Double) f "oneElement" 368 (renderByteString . S.oneElement) "" f "nestedElement" 368 (renderByteString . S.nestedElement) "" @@ -56,6 +75,22 @@ f "table" 1664 (renderByteString . M.table) (2,2) f "AttrShort" 2608 (renderByteString . M.attrShort) () f "pageA" 2960 (renderByteString . M.pageA) () - f "AttrLong" 3160 (renderByteString . M.attrLong) () + f "AttrLong" 3352 (renderByteString . M.attrLong) () f "Big table" 19968 (renderByteString . M.table) (15,15) f "Big page" 25064 (renderByteString . B.page) () + + validateAction "Compile Library" (compile tmp) "Html" (allocsError 1021 6) + validateAction "Compile Small.hs" (compile tmp) "Small" (allocsError 1061 6) + validateAction "Compile Medium.hs" (compile tmp) "Medium" (allocsError 1790 6) + validateAction "Compile Big.hs" (compile tmp) "Big" (allocsError 2470 6) + validateAction "Compile Alloc.hs" (compile tmp) "bench/Alloc.hs" (allocsError 2531 6) + validateAction "Compile Perf.hs" (compile tmp) "bench/Perf.hs" (allocsError 4809 6) + +compile :: String -> String -> IO () +compile out m = + void . defaultErrorHandler defaultFatalMessager defaultFlushOut . runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + void $ setSessionDynFlags (dflags {optLevel = 2, importPaths = ["src", "bench"], hiDir = Just out, objectDir = Just out, outputFile = Just (out ++ "/out")}) + target <- guessTarget m Nothing + setTargets [target] + load LoadAllTargets diff --git a/src/Html/Attribute.hs b/src/Html/Attribute.hs --- a/src/Html/Attribute.hs +++ b/src/Html/Attribute.hs @@ -227,10 +227,10 @@ maxlength_ :: Integral a => a -> 'MaxlengthA := a maxlength_ = AT -minlength_ :: a -> 'MinlengthA := a +minlength_ :: Integral a => a -> 'MinlengthA := a minlength_ = AT -media_ :: Integral a => a -> 'MediaA := a +media_ :: a -> 'MediaA := a media_ = AT method_ :: a -> 'MethodA := a 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 @@ -351,11 +351,9 @@ (><) ('FingerTree ss r) ('FingerTree (s ': ss2) r2) = 'FingerTree (Append ss (Both r s ': ss2)) r2 (><) ('FingerTree ss r) ('FingerTree '[] r2) = 'FingerTree ss (Both r r2) -type family OpenTag e where - OpenTag e = ["<", ShowElement e, ">"] +type OpenTag e = ["<", ShowElement e, ">"] -type family CloseTag e where - CloseTag e = [""] +type CloseTag e = [""] -- | Flatten a document into a type list of tags. type family ToList a :: FingerTree where @@ -452,18 +450,6 @@ -- 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 ': x17 ': x18 ': x19 ': x20 ': x21 ': x22 ': x23 ': x24 ': x25 ': x26 ': x27 ': x28 ': x29 ': x30 ': x31 ': x32 ': x33 ': x34 ': x35 ': x36 ': x37 ': x38 ': x39 ': x40 ': x41 ': x42 ': x43 ': x44 ': x45 ': x46 ': x47 ': x48 ': x49 ': x50 ': x51 ': x52 ': x53 ': x54 ': x55 ': x56 ': x57 ': x58 ': x59 ': x60 ': x61 ': x62 ': x63 ': x64 ': xs) ys - = x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': x9 ': x10 ': x11 ': x12 ': x13 ': x14 ': x15 ': x16 ': x17 ': x18 ': x19 ': x20 ': x21 ': x22 ': x23 ': x24 ': x25 ': x26 ': x27 ': x28 ': x29 ': x30 ': x31 ': x32 ': x33 ': x34 ': x35 ': x36 ': x37 ': x38 ': x39 ': x40 ': x41 ': x42 ': x43 ': x44 ': x45 ': x46 ': x47 ': x48 ': x49 ': x50 ': x51 ': x52 ': x53 ': x54 ': x55 ': x56 ': x57 ': x58 ': x59 ': x60 ': x61 ': x62 ': x63 ': x64 ': Append xs ys - - Append (x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': x9 ': x10 ': x11 ': x12 ': x13 ': x14 ': x15 ': x16 ': x17 ': x18 ': x19 ': x20 ': x21 ': x22 ': x23 ': x24 ': x25 ': x26 ': x27 ': x28 ': x29 ': x30 ': x31 ': x32 ': xs) ys - = x1 ': x2 ': x3 ': x4 ': x5 ': x6 ': x7 ': x8 ': x9 ': x10 ': x11 ': x12 ': x13 ': x14 ': x15 ': x16 ': x17 ': x18 ': x19 ': x20 ': x21 ': x22 ': x23 ': x24 ': x25 ': x26 ': x27 ': x28 ': x29 ': x30 ': x31 ': x32 ': Append xs ys - - 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 @@ -746,7 +732,7 @@ GetEInfo I = EInfo "i" '[ FlowContent, PhrasingContent ] PhrasingContent GetEInfo Iframe = EInfo "iframe" '[ FlowContent, PhrasingContent ] NoContent GetEInfo Img = EInfo "img" '[ FlowContent, PhrasingContent ] NoContent - GetEInfo Input = EInfo "input" '[] NoContent + GetEInfo Input = EInfo "input" '[ FlowContent, PhrasingContent ] NoContent GetEInfo Ins = EInfo "ins" '[ FlowContent, PhrasingContent ] OnlyText GetEInfo Kbd = EInfo "kbd" '[ FlowContent, PhrasingContent ] PhrasingContent GetEInfo Label = EInfo "label" '[ FlowContent, PhrasingContent ] (PhrasingContent :&: NOT (SingleElement Label)) 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.2 +version: 1.3.4.0 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 @@ -73,6 +73,9 @@ , type-of-html , deepseq , weigh + , ghc + , ghc-paths + , temporary benchmark perf type: exitcode-stdio-1.0