type-of-html 1.5.0.0 → 1.5.1.0
raw patch · 21 files changed
+102/−226 lines, 21 filesdep −temporarydep ~basePVP ok
version bump matches the API change (PVP)
Dependencies removed: temporary
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- bench/Alloc.hs +61/−57
- bench/Compilation.hs +0/−40
- bench/Compilation/X0.hs +0/−9
- bench/Compilation/X1.hs +0/−9
- bench/Compilation/X128.hs +0/−9
- bench/Compilation/X16.hs +0/−9
- bench/Compilation/X2.hs +0/−9
- bench/Compilation/X32.hs +0/−9
- bench/Compilation/X4.hs +0/−9
- bench/Compilation/X64.hs +0/−9
- bench/Compilation/X8.hs +0/−9
- bench/Perf.hs +6/−1
- bench/Reduction.hs +1/−5
- src/Html.hs +1/−5
- src/Html/Convert.hs +1/−6
- src/Html/Reify.hs +5/−1
- src/Html/Type/Internal.hs +1/−0
- test/Type.hs +4/−4
- test/Value.hs +5/−5
- type-of-html.cabal +13/−21
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for type-of-html +## 1.5.1.0 -- 2020-01-18++* improve compile times and run times for big pages+ ## 1.5.0.0 -- 2018-11-29 * add compactHTML
bench/Alloc.hs view
@@ -1,5 +1,11 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-} -- | Note that the allocation numbers are only reproducible on linux using the nix shell. @@ -12,13 +18,12 @@ import qualified Big as B import Weigh-import Control.DeepSeq import Data.Proxy import Data.Int -import System.IO.Temp import GHC import GHC.Paths (libdir)+import GHC.TypeNats import DynFlags import Control.Monad @@ -30,72 +35,71 @@ where n' = weightAllocatedBytes w answer = " allocated bytes than expected: " ++ show (abs $ n' - n) -allocsError :: Int -> Int -> Int -> Weight -> Maybe String+allocsError :: (Show a, Integral a) => a -> a -> a -> Weight -> Maybe String allocsError i m n w | n' > (m'+1) = Just $ "More" ++ answer | n' < (m'-1) = Just $ "Less" ++ answer | otherwise = Nothing- where n' = round (fromIntegral (weightAllocatedBytes w) / (10^i) :: Rational) :: Int+ where n' = round (fromIntegral (weightAllocatedBytes w) / (10^i) :: Rational) m' = n + m answer = " allocated bytes than expected: " ++ pretty (abs $ m' - n') pretty x = show x ++ " e" ++ show i -f :: NFData b => String -> (a -> b) -> a -> Int64 -> Weigh ()-f s g x n = validateFunc s g x (allocs n)+f :: Document b => String -> (a -> b) -> a -> Int64 -> Weigh ()+f s g x n = validateFunc s (renderByteString . g) x (allocs n) main :: IO ()-main = withSystemTempDirectory "compile" $ \tmp -> mainWith $ do+main = mainWith $ do - -- ghc version 822 844 862- f "()" renderByteString () $ ghc [ 80, 48, -32 ]- f "Int" renderByteString (123456789 :: Int) $ ghc [ 216 ]- f "Word" renderByteString (123456789 :: Word) $ ghc [ 216 ]- f "Char" renderByteString 'a' $ ghc [ 216 ]- f "Integer" renderByteString (123456789 :: Integer) $ ghc [ 248 ]- f "Proxy" renderByteString (Proxy :: Proxy "a") $ ghc [ 264, 0, 16 ]- f "oneElement Proxy" (renderByteString . S.oneElement) (Proxy :: Proxy "b") $ ghc [ 264, 0, 16 ]- f "oneElement ()" (renderByteString . S.oneElement) () $ ghc [ 264, 0, 16 ]- f "oneAttribute ()" (renderByteString . A.class_) () $ ghc [ 264, 0, 16 ]- f "oneAttribute Proxy" (renderByteString . A.class_) (Proxy :: Proxy "c") $ ghc [ 264, 0, 16 ]- f "listElement" (renderByteString . S.listElement) () $ ghc [ 608 ]- f "Double" renderByteString (123456789 :: Double) $ ghc [ 360 ]- f "oneElement" (renderByteString . S.oneElement) "" $ ghc [ 368 ]- f "nestedElement" (renderByteString . S.nestedElement) "" $ ghc [ 368 ]- f "listOfAttributes" (\x -> renderByteString [A.class_ x, A.class_ x]) () $ ghc [ 712 ]- f "Float" renderByteString (123456789 :: Float) $ ghc [ 400 ]- f "oneAttribute" (renderByteString . A.class_) "" $ ghc [ 520 ]- f "parallelElement" (renderByteString . S.parallelElement) "" $ ghc [ 520 ]- f "parallelAttribute" (\x -> renderByteString $ A.class_ x # A.id_ x) "" $ ghc [ 736 ]- f "elementWithAttribute" (\x -> renderByteString $ div_A (A.class_ x) x) "" $ ghc [ 696 ]- f "listOfListOf" (\x -> renderByteString $ div_ [i_ [span_ x]]) () $ ghc [ 1200, 0, 64 ]- f "helloWorld" (renderByteString . M.helloWorld) () $ ghc [ 1248, 0, 16 ]- f "page" (renderByteString . M.page) () $ ghc [ 1400, 0, 16 ]- f "table" (renderByteString . M.table) (2,2) $ ghc [ 2640, -32, 136 ]- f "AttrShort" (renderByteString . M.attrShort) () $ ghc [ 2616, 0, 88 ]- f "pageA" (renderByteString . M.pageA) () $ ghc [ 2848, 0, 16 ]- f "AttrLong" (renderByteString . M.attrLong) () $ ghc [ 2616, 0, 16 ]- f "Big table" (renderByteString . M.table) (15,15) $ ghc [54040,-1824, 1904 ]- f "Big page" (renderByteString . B.page) () $ ghc [27832, -56, 72 ]- let g x y z = validateAction x (compile tmp) y . allocsError 7 z $ ghc [ 118, 0, 4 ]- g "Compile Library" "Html" $ ghc [ 0 ]- g "Compile Small.hs" "Small" $ ghc [ 1 ]- g "Compile Medium.hs" "Medium" $ ghc [ 39, 2, 2 ]- g "Compile Big.hs" "Big" $ ghc [ 73, 2, 1 ]- g "Compile Perf.hs" "bench/Perf.hs" $ ghc [ 117, 213, 4 ]- g "Compile X0.hs" "bench/Compilation/X0.hs" $ ghc [ 3, 1 ]- g "Compile X1.hs" "bench/Compilation/X1.hs" $ ghc [ 4, 2, -2 ]- g "Compile X2.hs" "bench/Compilation/X2.hs" $ ghc [ 5 ]- g "Compile X4.hs" "bench/Compilation/X4.hs" $ ghc [ 7 ]- g "Compile X8.hs" "bench/Compilation/X8.hs" $ ghc [ 12 ]- g "Compile X16.hs" "bench/Compilation/X16.hs" $ ghc [ 25 ]- g "Compile X32.hs" "bench/Compilation/X32.hs" $ ghc [ 64, 2 ]- g "Compile X64.hs" "bench/Compilation/X64.hs" $ ghc [ 203, 4, -4 ]- g "Compile X128.hs" "bench/Compilation/X128.hs" $ ghc [ 714, 4, -5 ]+ let ghc = allocFold :: GhcVersions [802, 804, 806, 808] -ghc :: Num a => [a] -> a-ghc xs = sum [y | (y, v) <- zip xs supportedGhcs, v <= __GLASGOW_HASKELL__]+ f "()" id () $ ghc 128 0 0 0+ f "Int" id (123456789 :: Int) $ ghc 192 0 0 0+ f "Word" id (123456789 :: Word) $ ghc 192 0 0 0+ f "Char" id 'a' $ ghc 192 0 0 0+ f "Integer" id (123456789 :: Integer) $ ghc 248 0 0 0+ f "Proxy" id (Proxy :: Proxy "a") $ ghc 208 0 0 0+ f "oneElement Proxy" S.oneElement (Proxy :: Proxy "b") $ ghc 208 0 0 0+ f "oneElement ()" S.oneElement () $ ghc 208 0 0 0+ f "oneAttribute ()" A.class_ () $ ghc 208 0 0 0+ f "oneAttribute Proxy" A.class_ (Proxy :: Proxy "c") $ ghc 208 0 0 0+ f "listElement" S.listElement () $ ghc 608 0 0 0+ f "Double" id (123456789 :: Double) $ ghc 360 0 0 0+ f "oneElement" S.oneElement "" $ ghc 368 0 0 0+ f "nestedElement" S.nestedElement "" $ ghc 368 0 0 0+ f "listOfAttributes" (\x -> [A.class_ x, A.class_ x]) () $ ghc 712 0 0 0+ f "Float" id (123456789 :: Float) $ ghc 400 0 0 0+ f "oneAttribute" A.class_ "" $ ghc 520 0 0 0+ f "parallelElement" S.parallelElement "" $ ghc 520 0 0 (-16)+ f "parallelAttribute" (\x -> A.class_ x # A.id_ x) "" $ ghc 736 0 0 0+ f "elementWithAttribute" (\x -> div_A (A.class_ x) x) "" $ ghc 696 0 0 0+ f "listOfListOf" (\x -> div_ [i_ [span_ x]]) () $ ghc 1200 0 64 0+ f "helloWorld" M.helloWorld () $ ghc 920 168 0 0+ f "page" M.page () $ ghc 1400 0 720 0+ f "table" M.table (2,2) $ ghc 2640 0 8 (-96)+ f "AttrShort" M.attrShort () $ ghc 2688 0 2104 0+ f "pageA" M.pageA () $ ghc 4552 (-96) (-96) (-288)+ f "AttrLong" M.attrLong () $ ghc 2688 0 2104 0+ f "Big table" M.table (15,15) $ ghc 54040 0 8 (-3736)+ f "Big page" B.page () $ ghc 27888 (-120) 0 (-1344) - where supportedGhcs = [802, 804, 806] :: [Int]+type family GhcVersions xs where+ GhcVersions '[] = Int64+ GhcVersions (x ': xs) = GHC x -> GhcVersions xs++newtype GHC (k :: Nat) = GHC Int64 deriving Num++class AllocFold a where+ allocFold :: a++instance AllocFold (GHC k -> Int64) where+ allocFold (GHC i) = i++instance AllocFold (GHC m -> a) => AllocFold (GHC l -> GHC m -> a) where+ allocFold (GHC i1) i2 = allocFold (GHC i1 + i2)++instance {-# OVERLAPPING #-} AllocFold (GHC __GLASGOW_HASKELL__ -> a) => AllocFold (GHC __GLASGOW_HASKELL__ -> GHC m -> a) where+ allocFold i1 _ = allocFold i1 compile :: String -> String -> IO () compile out m =
− bench/Compilation.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}--module Compilation (helloWorld, R(..), Proxy(..)) where--import Html--import GHC.TypeLits-import Data.Proxy--type family Repeat (n :: Nat) x where- Repeat 0 x = x- Repeat n x = x # Repeat (n-1) x--class R n x where- r :: Proxy n -> x -> Repeat n x--instance {-# INCOHERENT #-} R 0 x where- r _ x = x--instance (Repeat n x ~ (x # Repeat (n-1) x), R (n-1) x) => R n x where- r _ x = x # r (Proxy :: Proxy (n-1)) x--helloWorld :: 'Title ?> a => a -> 'Html > (('Head > ('Title > a)) # ('Body > ('P > ())))-helloWorld x =- html_- ( head_- ( title_ x- )- # body_- ( p_ ()- )- )--
− bench/Compilation/X0.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X0 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 0) $ helloWorld ()-
− bench/Compilation/X1.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X1 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 1) $ helloWorld ()-
− bench/Compilation/X128.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X128 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 128) $ helloWorld ()-
− bench/Compilation/X16.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X16 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 16) $ helloWorld ()-
− bench/Compilation/X2.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X2 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 2) $ helloWorld ()-
− bench/Compilation/X32.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X32 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 32) $ helloWorld ()-
− bench/Compilation/X4.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X4 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 4) $ helloWorld ()-
− bench/Compilation/X64.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X64 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 64) $ helloWorld ()-
− bench/Compilation/X8.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE DataKinds #-}--module Compilation.X8 (run) where--import Compilation--run :: IO ()-run = print . r (Proxy :: Proxy 8) $ helloWorld ()-
bench/Perf.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-}+ module Main where import Html@@ -18,9 +20,12 @@ import System.IO.Unsafe import Data.Proxy import Text.Blaze.Html.Renderer.Utf8-import Data.Semigroup ((<>)) import qualified Data.Text.Lazy as LT import qualified Data.Text as T++#if __GLASGOW_HASKELL__ <= 802+import Data.Semigroup ((<>), Semigroup)+#endif main :: IO () main = defaultMain
bench/Reduction.hs view
@@ -3,12 +3,8 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} #if __GLASGOW_HASKELL__ <= 802 {-# OPTIONS_GHC -fsimpl-tick-factor=66 -freduction-depth=55 #-}-#elif __GLASGOW_HASKELL__ <= 804-{-# OPTIONS_GHC -fsimpl-tick-factor=66 -freduction-depth=29 #-}-#elif __GLASGOW_HASKELL__ <= 806-{-# OPTIONS_GHC -fsimpl-tick-factor=66 -freduction-depth=29 #-} #else-{-# OPTIONS_GHC -fsimpl-tick-factor=66 -freduction-depth=1 #-}+{-# OPTIONS_GHC -fsimpl-tick-factor=66 -freduction-depth=29 #-} #endif module Main where
src/Html.hs view
@@ -46,22 +46,18 @@ import qualified Data.Text.Lazy.Encoding as T -- | Render a html document to a Builder.-{-# INLINE renderBuilder #-} renderBuilder :: Document a => a -> Builder-renderBuilder = unConv . inline (render @ 'False . (T :: a -> T (ToList a) a)) . inline+renderBuilder = unConv . (render @ 'False . (T :: a -> T (ToList a) a)) -- | Render a html document to a String.-{-# INLINE renderString #-} renderString :: Document a => a -> String renderString = T.unpack . renderText -- | Render a html document to a lazy Text.-{-# INLINE renderText #-} renderText :: Document a => a -> T.Text renderText = T.decodeUtf8 . renderByteString -- | Render a html document to a lazy ByteString.-{-# INLINE renderByteString #-} renderByteString :: Document a => a -> BL.ByteString renderByteString = BE.toLazyByteStringWith ( BE.untrimmedStrategy
src/Html/Convert.hs view
@@ -18,9 +18,7 @@ import Numeric.Natural import GHC.Exts import GHC.TypeLits-import GHC.Prim (Addr#, ord#, indexCharOffAddr#) import GHC.CString (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#)-import GHC.Base (build) import qualified Data.Semigroup as S import qualified Data.Monoid as M@@ -32,10 +30,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -newtype Converted = Converted {unConv :: B.Builder} deriving (M.Monoid)-instance S.Semigroup Converted where- {-# INLINE (<>) #-}- Converted x <> Converted y = Converted (inline x S.<> inline y)+newtype Converted = Converted {unConv :: B.Builder} deriving (M.Monoid, S.Semigroup) instance IsString Converted where fromString = convert
src/Html/Reify.hs view
@@ -13,6 +13,8 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-}+ module Html.Reify where import Html.Type.Internal@@ -21,7 +23,10 @@ import Data.Proxy import GHC.TypeLits import Data.ByteString.Builder++#if __GLASGOW_HASKELL__ <= 802 import Data.Semigroup ((<>), Semigroup)+#endif import qualified Data.Sequence as S @@ -47,7 +52,6 @@ retrieve m f (MkCompactHTML c1 c2) (Put x) = retrieve (unConv (convert x) : m) f (MkCompactHTML @ xs c1 c2) instance Retrievable '[] where- {-# INLINE retrieve #-} retrieve m f (MkCompactHTML bs is) = f $ byteString bs <> foldMap (\(i,b) -> m !! i <> byteString b) is type Document' a = R 'False (T (ToList a) a)
src/Html/Type/Internal.hs view
@@ -441,6 +441,7 @@ ToList ((a :@: b) ()) = AppendSymbol "<" (ShowElement a) <| ToList b |> If (HasContent (GetEInfo a)) (AppendSymbol ">" (CloseTag a)) ">" ToList ((a :@: ()) b) = OpenTag a <| ToList b |> CloseTag a ToList ((a :@: b) c) = (AppendSymbol "<" (ShowElement a) <| ToList b) >< (">" <| ToList c |> CloseTag a)+ ToList (a := ()) = 'List '[] (AppendSymbol " " (ShowAttribute a)) ToList (a := b) = AppendSymbol " " (AppendSymbol (ShowAttribute a) "=\"") <| ToList b |> "\"" ToList () = 'List '[] "" ToList (Proxy x) = 'List '[] x
test/Type.hs view
@@ -30,13 +30,13 @@ , ToList (('Div :@: ('ClassA := Int)) Int) == 'List '["<div class=\"","\">"] "</div>" , ToList (('Div :@: ('ClassA := ())) Int)- == 'List '["<div class=\"\">"] "</div>"+ == 'List '["<div class>"] "</div>" , ToList (('Div :@: ('ClassA := ())) ())- == 'List '[] "<div class=\"\"></div>"+ == 'List '[] "<div class></div>" , ToList (('Div :@: ('ClassA := () # 'IdA := ())) ())- == 'List '[] "<div class=\"\" id=\"\"></div>"+ == 'List '[] "<div class id></div>" , ToList (('Div :@: ('ClassA := () # 'IdA := Proxy "ab")) ())- == 'List '[] "<div class=\"\" id=\"ab\"></div>"+ == 'List '[] "<div class id=\"ab\"></div>" ) type family a == b where
test/Value.hs view
@@ -213,23 +213,23 @@ renderString (div_A (A.id_ ()) "a") `shouldBe`- "<div id=\"\">a</div>"+ "<div id>a</div>" renderString (div_A A.hidden_ "a") `shouldBe`- "<div hidden=\"\">a</div>"+ "<div hidden>a</div>" renderString (div_A A.hidden_ ()) `shouldBe`- "<div hidden=\"\"></div>"+ "<div hidden></div>" renderString (div_A A.hidden_ () # "a") `shouldBe`- "<div hidden=\"\"></div>a"+ "<div hidden></div>a" renderString (div_A A.hidden_ () # img_) `shouldBe`- "<div hidden=\"\"></div><img>"+ "<div hidden></div><img>" it "handles Ints" $ do
type-of-html.cabal view
@@ -1,5 +1,5 @@ name: type-of-html-version: 1.5.0.0+version: 1.5.1.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@@ -7,9 +7,12 @@ author: Florian Knupfer maintainer: fknupfer@gmail.com homepage: https://github.com/knupfer/type-of-html-tested-with: GHC == 8.2.2+tested-with: GHC == 8.6.5+ , GHC == 8.6.4 , GHC == 8.4.4- , GHC == 8.6.2+ , GHC == 8.4.3+ , GHC == 8.2.2+ , GHC == 8.2.1 copyright: 2017 - 2018, Florian Knupfer category: Language, Text, Web, HTML build-type: Simple@@ -30,8 +33,8 @@ , Html.Reify hs-source-dirs: src default-language: Haskell2010- ghc-options: -Wall- build-depends: base >= 4.9 && <= 5+ ghc-options: -Wall -O2+ build-depends: base >= 4.10 && <= 5 , text , bytestring , ghc-prim@@ -44,7 +47,7 @@ hs-source-dirs: test ghc-options: -Wall -O0 default-language: Haskell2010- build-depends: base >= 4.9 && <= 5+ build-depends: base >= 4.10 && <= 5 , type-of-html , QuickCheck , hspec@@ -57,7 +60,7 @@ other-modules: Html.Type.Internal ghc-options: -Wall default-language: Haskell2010- build-depends: base >= 4.9 && <= 5+ build-depends: base >= 4.10 && <= 5 , bytestring benchmark reduction@@ -66,7 +69,7 @@ hs-source-dirs: bench ghc-options: -Wall -O2 default-language: Haskell2010- build-depends: base >= 4.9 && <= 5+ build-depends: base >= 4.10 && <= 5 , type-of-html benchmark alloc@@ -75,26 +78,15 @@ other-modules: Small , Medium , Big- , Compilation- , Compilation.X0- , Compilation.X1- , Compilation.X2- , Compilation.X4- , Compilation.X8- , Compilation.X16- , Compilation.X32- , Compilation.X64- , Compilation.X128 hs-source-dirs: bench ghc-options: -Wall -O2 default-language: Haskell2010- build-depends: base >= 4.9 && <= 5+ build-depends: base >= 4.10 && <= 5 , type-of-html , deepseq , weigh , ghc , ghc-paths- , temporary benchmark perf type: exitcode-stdio-1.0@@ -106,7 +98,7 @@ hs-source-dirs: bench ghc-options: -Wall -O2 default-language: Haskell2010- build-depends: base >= 4.9 && <= 5+ build-depends: base >= 4.10 && <= 5 , type-of-html , text , bytestring