type-of-html 1.4.1.0 → 1.5.0.0

raw patch · 11 files changed

+389/−165 lines, 11 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Readme.md +25/−12
• bench/Alloc.hs +34/−37
• bench/Perf.hs +54/−28
• bench/Reduction.hs +13/−1
• src/Html.hs +71/−8
• src/Html/Convert.hs +6/−2
• src/Html/Reify.hs +120/−76
• src/Html/Type.hs +9/−0
• src/Html/Type/Internal.hs +50/−0
• type-of-html.cabal +3/−1

@@ -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

@@ -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.

@@ -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 =

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -11,6 +11,15 @@   , Raw(..)   , Attribute(..)   , Element(..)+  , CompactHTML+  , Put(..)+  , V(..)+  , Retrievable+  , Retrieve+  , Variables+  , Document+  , Compactable   ) where  import Html.Type.Internal+import Html.Reify

@@ -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

@@ -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