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.5.0.0 -- 2018-11-29 + +* add compactHTML + ## 1.4.1.0 -- 2018-11-12 * add aria rules and attributes diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -305,15 +305,31 @@ 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. +### CompactHTML +You can use an even more performant representation if you can +sacrifice some flexibility. If every variable of your html document +is just some type which will be converted into a Builder, you can +render your entire html document as a list of ByteString which will be +cached by ghc and interspersed with variables. This will be in a lot +of cases orders of magnitude faster. This is especially the case with +larger pages. For very small pages (let's say upto 5 elements) this +technique is slower. + +```haskell +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} + +import Html + +test x y = div_ "Hello, my name is: " # x # "I'm of age: " # y + +myDoc :: CompactHTML ["name", "age"] +myDoc = compactHTML (test (V @"name") (V @"age")) + +main = putStrLn $ renderCompactString myDoc (Put "Bob") (Put (42 :: Int)) +``` + ## Comparision to lucid and blaze-html Advantages of `type-of-html`: @@ -449,7 +465,4 @@ which is used for the Symbol, is shared of equal Symbols. ### Isn't there any performance tweak left? -At the moment, string literals are handled well, but not optimal. The -escaping of string literals is done everytime when rendering the html -document, ideally we convince GHC to float the escaped string literal -to top level. I guess, that would make things a bit faster. +As far as I know: no. If you disagree, please file an issue. diff --git a/bench/Alloc.hs b/bench/Alloc.hs --- a/bench/Alloc.hs +++ b/bench/Alloc.hs @@ -46,59 +46,56 @@ main :: IO () main = withSystemTempDirectory "compile" $ \tmp -> mainWith $ do - -- ghc version 822 843 861 - f "()" renderByteString () $ ghc [ 96 ] + -- 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 [ 232 ] + f "Char" renderByteString 'a' $ ghc [ 216 ] f "Integer" renderByteString (123456789 :: Integer) $ ghc [ 248 ] - f "Proxy" renderByteString (Proxy :: Proxy "a") $ ghc [ 280 ] - f "oneElement Proxy" (renderByteString . S.oneElement) (Proxy :: Proxy "b") $ ghc [ 280 ] - f "oneElement ()" (renderByteString . S.oneElement) () $ ghc [ 280 ] - f "oneAttribute ()" (renderByteString . A.class_) () $ ghc [ 280 ] - f "oneAttribute Proxy" (renderByteString . A.class_) (Proxy :: Proxy "c") $ ghc [ 280 ] - f "listElement" (renderByteString . S.listElement) () $ ghc [ 392 ] + 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 [ 488, 0, -16 ] + 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 [ 408 ] + 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 [ 584 ] - f "elementWithAttribute" (\x -> renderByteString $ div_A (A.class_ x) x) "" $ ghc [ 584 ] - f "listOfListOf" (\x -> renderByteString $ div_ [i_ [span_ x]]) () $ ghc [ 896, 88, -8 ] + 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 [ 1256 ] - f "table" (renderByteString . M.table) (2,2) $ ghc [ 1920, -256, -8 ] - f "AttrShort" (renderByteString . M.attrShort) () $ ghc [ 3184, 48 ] - f "pageA" (renderByteString . M.pageA) () $ ghc [ 2536, -216 ] - f "AttrLong" (renderByteString . M.attrLong) () $ ghc [ 3184, 48, -192 ] - f "Big table" (renderByteString . M.table) (15,15) $ ghc [12904, 7064, -8 ] - f "Big page" (renderByteString . B.page) () $ ghc [25208, -248, -40 ] - let g x y z = validateAction x (compile tmp) y . allocsError 7 z $ ghc [ 104, 0, 2 ] + 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 [ 0 ] - g "Compile Medium.hs" "Medium" $ ghc [ 37, 0, 2 ] - g "Compile Big.hs" "Big" $ ghc [ 70, 0, 3 ] - g "Compile Alloc.hs" "bench/Alloc.hs" $ ghc [ 74, 2 ] - g "Compile Perf.hs" "bench/Perf.hs" $ ghc [ 179, 2 ] - g "Compile X0.hs" "bench/Compilation/X0.hs" $ ghc [ 4, -2 ] - g "Compile X1.hs" "bench/Compilation/X1.hs" $ ghc [ 3 ] + 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 [ 23 ] - g "Compile X32.hs" "bench/Compilation/X32.hs" $ ghc [ 64, 0 ] - g "Compile X64.hs" "bench/Compilation/X64.hs" $ ghc [ 203, 2, -3 ] - g "Compile X128.hs" "bench/Compilation/X128.hs" $ ghc [ 711, 4, -5 ] + 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 ] ghc :: Num a => [a] -> a -ghc [] = 0 -ghc (x:xs) = sum $ x:[y | (y, v) <- zip xs supportedGhcs, v < __GLASGOW_HASKELL__] - - where supportedGhcs = [802, 804] :: [Int] +ghc xs = sum [y | (y, v) <- zip xs supportedGhcs, v <= __GLASGOW_HASKELL__] + where supportedGhcs = [802, 804, 806] :: [Int] compile :: String -> String -> IO () compile out m = diff --git a/bench/Perf.hs b/bench/Perf.hs --- a/bench/Perf.hs +++ b/bench/Perf.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -freduction-depth=0 #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} + module Main where import Html @@ -15,7 +18,7 @@ import System.IO.Unsafe import Data.Proxy import Text.Blaze.Html.Renderer.Utf8 -import qualified Text.Blaze.Html5 as BL +import Data.Semigroup ((<>)) import qualified Data.Text.Lazy as LT import qualified Data.Text as T @@ -24,7 +27,8 @@ [ small , medium , big - , blaze + , comparison + , scaling ] small :: Benchmark @@ -99,38 +103,60 @@ , bench "page" $ nf (renderByteString . B.page) "big" ] -blaze :: Benchmark -blaze = bgroup "Blaze" - [ bgroup "minimal" - [ bench "blaze-html" $ nf (renderHtml . BL.blazeMinimal) (fromString "") - , bench "type-of-html" $ nf (renderByteString . S.oneElement) "" - ] - , bgroup "hello world" +comparison :: Benchmark +comparison = bgroup "Comparison" + [ 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" + , bench "compactHTML" $ nf (renderCompactByteString (compactHTML $ M.helloWorld (V @ "x"))) (Put "TEST") ] - , bgroup "page" - [ bench "blaze-html" $ nf (renderHtml . BL.blazePage) (fromString "TEST") - , bench "type-of-html" $ nf (renderByteString . M.page) "TEST" + , bgroup "table" + [ bench "blaze-html" $ nf (renderHtml . BL.blazeTable) (4,4) + , bench "type-of-html" $ nf (renderByteString . M.table) (4,4) ] - , bgroup "page with attributes" + , bgroup "small page" [ bench "blaze-html" $ nf (renderHtml . BL.blazePageA) (fromString "TEST") , bench "type-of-html" $ nf (renderByteString . M.pageA) "TEST" + , bench "compactHTML" $ nf (renderCompactByteString (compactHTML $ M.pageA (V @ "x"))) (Put "TEST") ] - , bgroup "table" - [ bench "blaze-html" $ nf (renderHtml . BL.blazeTable) (4,4) - , bench "type-of-html" $ nf (renderByteString . M.table) (4,4) + , bgroup "medium page" + [ bench "blaze-html" $ nf (renderHtml . (\x -> BL.blazePageA x <> BL.blazePageA x)) (fromString "TEST") + , bench "type-of-html" $ nf (renderByteString . (\x -> M.pageA x # M.pageA x)) "TEST" + , bench "compactHTML" $ nf (renderCompactByteString (compactHTML $ M.pageA (V @ "x") # M.pageA (V @ "x"))) (Put "TEST") ] - , bgroup "encode random string" - [ bench "blaze-html" $ nf (renderHtml . BL.div . BL.toHtml) randomString - , bench "type-of-html" $ nf (renderByteString . div_) randomString + , bgroup "big page" + [ bench "blaze-html" $ nf (renderHtml . (\x -> BL.blazePageA x <> BL.blazePageA x <> BL.blazePageA x <> BL.blazePageA x)) (fromString "TEST") + , bench "type-of-html" $ nf (renderByteString . (\x -> M.pageA x # M.pageA x # M.pageA x # M.pageA x)) "TEST" + , bench "compactHTML" $ nf (renderCompactByteString (compactHTML $ M.pageA (V @ "x") # M.pageA (V @ "x") # M.pageA (V @ "x") # M.pageA (V @ "x"))) (Put "TEST") ] ] + +scaling :: Benchmark +scaling = bgroup "Scaling" + [ bgroup "2 divs" + [ bench "normal" $ nf (renderByteString . divs2) "input" + , bench "compact" $ nf (renderCompactByteString . compactHTML $ divs2 (V @ "x")) (Put "input") + ] + , bgroup "4 divs" + [ bench "normal" $ nf (renderByteString . divs4) "input" + , bench "compact" $ nf (renderCompactByteString . compactHTML $ divs4 (V @ "x")) (Put "input") + ] + , bgroup "8 divs" + [ bench "normal" $ nf (renderByteString . divs8) "input" + , bench "compact" $ nf (renderCompactByteString . compactHTML $ divs8 (V @ "x")) (Put "input") + ] + , bgroup "16 divs" + [ bench "normal" $ nf (renderByteString . divs16) "input" + , bench "compact" $ nf (renderCompactByteString . compactHTML $ divs16 (V @ "x")) (Put "input") + ] + , bgroup "32 divs" + [ bench "normal" $ nf (renderByteString . divs32) "input" + , bench "compact" $ nf (renderCompactByteString . compactHTML $ divs32 (V @ "x")) (Put "input") + ] + ] + where + divs2 x = div_ "lorem;" # x # div_ "ipsum<>" + divs4 = divs2 . divs2 + divs8 = divs4 . divs4 + divs16 = divs8 . divs8 + divs32 = divs16 . divs16 diff --git a/bench/Reduction.hs b/bench/Reduction.hs --- a/bench/Reduction.hs +++ b/bench/Reduction.hs @@ -1,4 +1,16 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures -freduction-depth=29 -fsimpl-tick-factor=42 #-} +{-# LANGUAGE CPP #-} + +{-# 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 #-} +#endif + module Main where import Html diff --git a/src/Html.hs b/src/Html.hs --- a/src/Html.hs +++ b/src/Html.hs @@ -1,32 +1,55 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} module Html - ( renderString + ( module Html.Type + , module Html.Convert + , module Html.Element + , renderString , renderText , renderByteString , renderBuilder - , Document - , module Html.Type - , module Html.Convert - , module Html.Element + , compactHTML + , renderCompactString + , renderCompactText + , renderCompactByteString + , renderCompactBuilder + , Put(..) + , V(..) ) where import Html.Reify import Html.Convert import Html.Element import Html.Type +import Html.Type.Internal -import qualified Data.ByteString.Lazy as B +import Control.Arrow +import GHC.Exts +import Data.Either +import Data.List +import Data.ByteString.Builder +import Data.Maybe + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Builder.Extra as BE import qualified Data.Text.Lazy as T 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 + -- | Render a html document to a String. {-# INLINE renderString #-} renderString :: Document a => a -> String @@ -39,12 +62,52 @@ -- | Render a html document to a lazy ByteString. {-# INLINE renderByteString #-} -renderByteString :: Document a => a -> B.ByteString +renderByteString :: Document a => a -> BL.ByteString renderByteString = BE.toLazyByteStringWith ( BE.untrimmedStrategy 1024 BE.smallChunkSize - ) B.empty . renderBuilder + ) BL.empty . renderBuilder + +renderCompactHTML :: Retrievable a => (Builder -> f) -> CompactHTML a -> Retrieve f a +renderCompactHTML = retrieve mempty + +-- | Render a compacted html document to a Builder. +renderCompactBuilder :: Retrievable a => CompactHTML a -> Retrieve Builder a +renderCompactBuilder = renderCompactHTML id + +-- | Render a compacted html document to a lazy ByteString. +renderCompactByteString :: Retrievable a => CompactHTML a -> Retrieve BL.ByteString a +renderCompactByteString = renderCompactHTML toLazyBS + +-- | Render a compacted html document to a lazy Text. +renderCompactText :: Retrievable a => CompactHTML a -> Retrieve T.Text a +renderCompactText = renderCompactHTML (T.decodeUtf8 . toLazyBS) + +-- | Render a compacted html document to a String. +renderCompactString :: Retrievable a => CompactHTML a -> Retrieve String a +renderCompactString = renderCompactHTML (T.unpack . T.decodeUtf8 . toLazyBS) + +toLazyBS :: Builder -> BL.ByteString +toLazyBS = BE.toLazyByteStringWith (BE.untrimmedStrategy 1024 BE.smallChunkSize) BL.empty + +-- | Compact a html document. +compactHTML :: Compactable a => a -> CompactHTML (Variables a) +compactHTML html + = uncurry MkCompactHTML + . concatEithers + . toList + . render @ 'True + $ (T :: a -> T (ToList a) a) html + where + concatEithers :: [Either Converted String] -> (B.ByteString, [(Int, B.ByteString)]) + concatEithers = (f *** go) . span isLeft + where go (Right r1:xs) = let (ls,rs) = span isLeft xs + in (indexVar html r1, f ls) : go rs + go _ = [] + f = BL.toStrict . toLazyByteString . unConv . mconcat . lefts + indexVar :: forall a. Compactable a => a -> String -> Int + indexVar _ s = fromJust (elemIndex s (showTypeList @ (Reverse (Variables a)))) -- | Show instances to faciliate ghci development. instance Document ((a :@: b) c) => Show ((a :@: b) c) where show = renderString diff --git a/src/Html/Convert.hs b/src/Html/Convert.hs --- a/src/Html/Convert.hs +++ b/src/Html/Convert.hs @@ -16,8 +16,8 @@ import Data.Char (ord) import Data.Double.Conversion.ByteString import Numeric.Natural +import GHC.Exts import GHC.TypeLits -import GHC.Types import GHC.Prim (Addr#, ord#, indexCharOffAddr#) import GHC.CString (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#) import GHC.Base (build) @@ -32,7 +32,11 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -newtype Converted = Converted {unConv :: B.Builder} deriving (M.Monoid,S.Semigroup) +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) + instance IsString Converted where fromString = convert {-| Convert a type efficienctly to a renderable representation. Add diff --git a/src/Html/Reify.hs b/src/Html/Reify.hs --- a/src/Html/Reify.hs +++ b/src/Html/Reify.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} module Html.Reify where @@ -16,110 +19,151 @@ import Html.Convert import Data.Proxy -import Data.Semigroup ((<>)) -import Data.ByteString.Builder (Builder) -import GHC.Exts +import GHC.TypeLits +import Data.ByteString.Builder +import Data.Semigroup ((<>), Semigroup) -type Document' a = R (T (ToList a) a) +import qualified Data.Sequence as S +type Compactable' a = (ShowTypeList (Reverse (Variables a)), R 'True (T (ToList a) a)) + +-- | Constraint for compactable html documents. It's a type family to avoid an +-- error about FlexibleContexts and a warning about MonoLocalBinds. +type family Compactable a where Compactable a = Compactable' a + +-- | Data for putting variables into a rendered compacted html document. +data Put (n :: Symbol) = forall a. Convert a => Put a + +-- | Type of a rendered compact html which determines the amount of arguments. +type family Retrieve f xs where + Retrieve f (x ': xs) = Put x -> Retrieve f xs + Retrieve f '[] = f + +-- | List of Symbols for which a render function can be created. +class Retrievable a where + retrieve :: [Builder] -> (Builder -> f) -> CompactHTML a -> Retrieve f a + +instance (KnownSymbol x, Retrievable xs) => Retrievable (x ': xs) where + 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) + -- | Constraint for html documents. It's a type family to avoid an -- error about FlexibleContexts and a warning about MonoLocalBinds. type family Document a where Document a = Document' a --- | Render a html document to a Builder. -{-# INLINE renderBuilder #-} -renderBuilder :: Document a => a -> Builder -renderBuilder = unConv . render . (T :: a -> T (ToList a) a) . inline +type family RenderOutput x = r | r -> x where + RenderOutput 'False = Converted + RenderOutput 'True = S.Seq (Either Converted String) -class R a where - render :: a -> Converted +class R u a where + render :: a -> RenderOutput u +instance Convert s + => R 'False (One s) where + render (One x) = convert x + +instance Convert s + => R 'True (One s) where + render (One x) = pure . Left $ convert x + instance {-# INCOHERENT #-} - R (T '[] val) where - {-# INLINE render #-} + KnownSymbol n => + R 'True (T '[ "" ] (V n)) where + render _ = pure (Right (symbolVal (Proxy @ n))) + +-- | Common instances + +instance {-# INCOHERENT #-} + Monoid (RenderOutput u) => R u (T '[] val) where render _ = mempty instance {-# INCOHERENT #-} - ( Convert val - ) => R (T '[ "" ] val) where - {-# INLINE render #-} - render (T x) = convert x + ( R u (One val) + ) => R u (T '[ "" ] val) where + render (T x) = render (One x) instance - ( Convert b - , Convert (Proxy s) - ) => R (T '[s] (a := b)) where - {-# INLINE render #-} - render (T (AT x)) = convert (Proxy @ s) <> convert x + ( R u (T '[ "" ] b) + , R u (One (Proxy s)) + , Semigroup (RenderOutput u) + ) => R u (T '[s] (a := b)) where + render (T (AT x)) = render (One (Proxy @ s)) <> render (T x :: T '[ "" ] b) instance {-# INCOHERENT #-} - ( Convert val - , Convert (Proxy s) - ) => R (T '[s] val) where - {-# INLINE render #-} - render (T x) = convert (Proxy @ s) <> convert x + ( R u (T '[ "" ] val) + , R u (One (Proxy s)) + , Semigroup (RenderOutput u) + ) => R u (T '[s] val) where + render (T x) = render (One (Proxy @ s)) <> render (T x :: T '[ "" ] val) instance {-# OVERLAPPING #-} - ( Convert (Proxy s) - ) => R (T '[s] String) where - {-# INLINE render #-} - render (T x) = convert (Proxy @ s) <> convert x + ( R u (One (Proxy s)) + , R u (One String) + , Semigroup (RenderOutput u) + ) => R u (T '[s] String) where + render (T x) = render (One (Proxy @ s)) <> render (One x) instance {-# OVERLAPPING #-} - ( R (T xs val) - ) => R (T ('List xs "") val) where - {-# INLINE render #-} + ( R u (T xs val) + ) => R u (T ('List xs "") val) where render (T t) = render (T t :: T xs val) instance - ( R (T xs val) - , Convert (Proxy x) - ) => R (T ('List xs x) val) where - {-# INLINE render #-} - render (T t) = render (T t :: T xs val) <> convert (Proxy @ x) + ( R u (T xs val) + , R u (One (Proxy x)) + , Semigroup (RenderOutput u) + ) => R u (T ('List xs x) val) where + render (T t) = render (T t :: T xs val) <> render (One (Proxy @ x)) instance - ( R (T (Take (Length b) ps) b) - , R (T (Drop (Length b) ps) c) - ) => R (T ps ((a :@: b) c)) where - {-# INLINE render #-} + ( R u (T (Take (Length b) ps) b) + , R u (T (Drop (Length b) ps) c) + , Semigroup (RenderOutput u) + ) => R u (T ps ((a :@: b) c)) where render (T ~(WithAttributes b c)) = render (T b :: T (Take (Length b) ps) b) <> render (T c :: T (Drop (Length b) ps) c) instance - ( R (T (Take (Length a) ps) a) - , R (T (Drop (Length a) ps) b) - ) => R (T ps (a # b)) where - {-# INLINE render #-} + ( R u (T (Take (Length a) ps) a) + , R u (T (Drop (Length a) ps) b) + , Semigroup (RenderOutput u) + ) => R u (T ps (a # b)) where render (T ~(a :#: b)) = render (T a :: T (Take (Length a) ps) a) <> render (T b :: T (Drop (Length a) ps) b) instance - ( R (T (ToList a) a) - , Convert (Proxy s) - ) => R (T (s ': ss) [a]) where - {-# INLINE render #-} + ( R u (T (ToList a) a) + , R u (One (Proxy s)) + , Semigroup (RenderOutput u) + , Monoid (RenderOutput u) + ) => R u (T (s ': ss) [a]) where render (T xs) - = convert (Proxy @ s) - <> foldMap (Converted . renderBuilder) xs + = render (One (Proxy @ s)) + <> foldMap (render . (T :: a -> T (ToList a) a)) xs instance - ( R (T (ToList a) a) - , Convert (Proxy s) - ) => R (T (s ': ss) (Maybe a)) where - {-# INLINE render #-} + ( R u (T (ToList a) a) + , R u (One (Proxy s)) + , Semigroup (RenderOutput u) + , Monoid (RenderOutput u) + ) => R u (T (s ': ss) (Maybe a)) where render (T mx) - = convert (Proxy @ s) - <> foldMap (Converted . renderBuilder) mx + = render (One (Proxy @ s)) + <> foldMap (render . (T :: a -> T (ToList a) a)) mx instance - ( R (T (ToList a) a) - , R (T (ToList b) b) - , Convert (Proxy s) - ) => R (T (s ': ss) (Either a b)) where - {-# INLINE render #-} + ( R u (T (ToList a) a) + , R u (T (ToList b) b) + , R u (One (Proxy s)) + , Semigroup (RenderOutput u) + ) => R u (T (s ': ss) (Either a b)) where render (T eab) - = convert (Proxy @ s) - <> either (Converted . renderBuilder) (Converted . renderBuilder) eab + = render (One (Proxy @ s)) + <> either (render . (T :: a -> T (ToList a) a)) (render . (T :: b -> T (ToList b) b)) eab diff --git a/src/Html/Type.hs b/src/Html/Type.hs --- a/src/Html/Type.hs +++ b/src/Html/Type.hs @@ -11,6 +11,15 @@ , Raw(..) , Attribute(..) , Element(..) + , CompactHTML + , Put(..) + , V(..) + , Retrievable + , Retrieve + , Variables + , Document + , Compactable ) where import Html.Type.Internal +import Html.Reify 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 @@ -2,6 +2,9 @@ {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} @@ -17,6 +20,7 @@ import GHC.Exts (Constraint) import Data.Proxy import Data.Type.Bool +import Data.ByteString (ByteString) {-# DEPRECATED @@ -47,6 +51,52 @@ Nextid "This is an obsolete html element and should not be used." #-} + +-- | Data for declaring variables in a html document which will be compacted. +data V (n :: Symbol) = V + +newtype One a = One a + +-- | Unique set of variables in a html document in the order of occurence. +type Variables a = Dedupe (GetV a) + +-- | A compacted html documented with it's variables annoted as a list of Symbols. +data CompactHTML (a :: [Symbol]) = MkCompactHTML ByteString [(Int, ByteString)] deriving Show + +type family GetV a :: [Symbol] where + GetV (a # b) = Append (GetV a) (GetV b) + GetV ((a :@: b) c) = Append (GetV b) (GetV c) + GetV (a := b) = GetV b + GetV (Maybe a) = GetV a + GetV [a] = GetV a + GetV (Either a b) = Append (GetV a) (GetV b) + GetV (V v) = '[v] + GetV x = '[] + +type family Reverse xs where + Reverse xs = Reverse' xs '[] + +type family Reverse' xs ys where + Reverse' (x':xs) ys = Reverse' xs (x':ys) + Reverse' '[] ys = ys + +type family Dedupe xs :: [Symbol] where + Dedupe (x ': xs) = x ': Dedupe (Delete x xs) + Dedupe '[] = '[] + +type family Delete x xs :: [Symbol] where + Delete x (x ': xs) = Delete x xs + Delete x (y ': xs) = y ': Delete x xs + Delete _ _ = '[] + +class ShowTypeList a where + showTypeList :: [String] + +instance (ShowTypeList xs, KnownSymbol x) => ShowTypeList (x ': xs) where + showTypeList = symbolVal (Proxy @ x) : showTypeList @ xs + +instance ShowTypeList '[] where + showTypeList = [] -- | The data type of all html elements and the kind of elements. data Element 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.1.0 +version: 1.5.0.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 @@ -36,6 +36,7 @@ , bytestring , ghc-prim , double-conversion + , containers test-suite value type: exitcode-stdio-1.0 @@ -57,6 +58,7 @@ ghc-options: -Wall default-language: Haskell2010 build-depends: base >= 4.9 && <= 5 + , bytestring benchmark reduction type: exitcode-stdio-1.0