diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,10 @@
# Revision history for type-of-html
+## 0.5.1.0 -- 2017-09-13
+
+* perf increase
+* better compile times
+
## 0.5.0.0 -- 2017-09-12
* type attributes
diff --git a/Readme.md b/Readme.md
--- a/Readme.md
+++ b/Readme.md
@@ -1,6 +1,6 @@
# Type of html
-`Type of html` is a library for generating html in a highly
+`type-of-html` is a library for generating html in a highly
performant, modular and type safe manner.
Please look at the documentation of the module for an overview of the api:
@@ -110,10 +110,10 @@
)
```
-Please note that the type of 'page' is inferable, so ask ghc-mod or
+Please note that the type of `page` is inferable, so ask ghc-mod or
whatever you use to write it for you. If you choose not to write the
types, you don't need the language extensions. I strongly suggest
-that you don't write signatures for bigger documents.
+that you don't write type signatures for `type-of-html`.
All text will be automatically html escaped:
@@ -137,17 +137,17 @@
## Performance
-`Type of html` is a lot faster than `blaze html` or than `lucid`.
+`type-of-html` is a lot faster than `blaze-html` or than `lucid`.
Look at the following benchmarks:
-Remember this benchmark from blaze?
+Remember this benchmark from `blaze-html`?
-This is comparing blaze with type of html:
+This is comparing blaze with `type-of-html`:
-
+
To look at the exact code of this benchmark look [here](bench/Main.hs)
in the repo. The big table benchmark here is only a 4x4 table. Using
@@ -157,9 +157,9 @@
How is this possible? We supercompile lots of parts of the generation
process. This is possible thanks to the new features of GHC 8.2:
-AppendSymbol. We represent tags as kinds and map these tags to (a ::
-[Symbol]) and then fold all neighbouring Proxies with
-AppendSymbol. Afterwards we retrieve the Proxies with symbolVal which
+AppendSymbol. We represent tags and attributes as kinds and map these
+to (a :: [Symbol]) and then fold all neighbouring Symbols with
+AppendSymbol. Afterwards we reify the Symbols with symbolVal which
will be embedded in the executable as Addr#. All this happens at
compile time. At runtime we do only generate the content and append
Builders.
@@ -176,11 +176,30 @@
```haskell
decodeUtf8 $ toLazyByteString
( Data.ByteString.Builder.unpackCString# "| "#
- <> escape (Data.Text.unpackCString# "test"#)
+ <> builderCString# "test"#
<> Data.ByteString.Builder.unpackCString# " |
"#
)
```
+Note that the compiler automatically sees that your string literal
+doesn't need utf8 and converts directly the `"test"# :: Addr#` to an
+escaped Builder without any intermediate structure, not even an
+allocated bytestring.
+
+```haskell
+renderByteString $ tr_ (td_ "teſt")
+```
+
+Results in
+
+```haskell
+toLazyByteString
+ ( Data.ByteString.Builder.unpackCString# "| "#
+ <> encodeUtf8BuilderEscaped prim (Data.Text.unpackCString# "te\\197\\191t"#)
+ <> Data.ByteString.Builder.unpackCString# " |
"#
+ )
+```
+
If you write
```haskell
@@ -198,20 +217,20 @@
## Comparision to lucid and blaze-html
-Advantages of 'type-of-html':
-- more or less 5 times faster
-- a lot higher type safety: a lot of invalid documents are not inhabited
+Advantages of `type-of-html`:
+- more or less 7 times faster
+- a lot higher type safety: nearly no invalid document is inhabited
- fewer dependencies
Disadvantages of 'type-of-html':
- a bit noisy syntax (don't write types!)
- sometimes unusual type error messages
-- compile times (1 min for a medium sized page, with -O0 only ~4sec)
+- compile times (30sec for a medium sized page, with `-O0` only ~3sec)
- needs at least ghc 8.2
I'd generally recommend that you put your documents into an extra
module to avoid frequent recompilations. Additionally you can use
-type-of-html within an blaze-html document and vice versa. This
+`type-of-html` within an `blaze-html` document and vice versa. This
allows you to gradually migrate, or only write the hotpath in a more
efficient representation.
diff --git a/src/Html/Convert.hs b/src/Html/Convert.hs
--- a/src/Html/Convert.hs
+++ b/src/Html/Convert.hs
@@ -3,6 +3,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
module Html.Convert where
@@ -10,10 +12,14 @@
import Data.Proxy
import Data.String
import GHC.TypeLits
+
import Html.Type
+import GHC.Prim (Addr#, ord#, indexCharOffAddr#)
+import GHC.Types
import Data.Char (ord)
+import qualified GHC.CString as GHC
import qualified Data.Monoid as M
import qualified Data.Semigroup as S
@@ -27,26 +33,41 @@
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
+{-# INLINE escapeUtf8 #-}
+escapeUtf8 :: BP.BoundedPrim Char
+escapeUtf8 =
+ BP.condB (> '>' ) BP.charUtf8 $
+ BP.condB (== '<' ) (fixed4 ('&',('l',('t',';')))) $
+ BP.condB (== '>' ) (fixed4 ('&',('g',('t',';')))) $
+ BP.condB (== '&' ) (fixed5 ('&',('a',('m',('p',';'))))) $
+ BP.condB (== '"' ) (fixed5 ('&',('#',('3',('4',';'))))) $
+ BP.condB (== '\'') (fixed5 ('&',('#',('3',('9',';'))))) $
+ BP.liftFixedToBounded BP.char7
+ where
+ {-# INLINE fixed4 #-}
+ fixed4 x = BP.liftFixedToBounded $ const x BP.>$<
+ BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7
+
+ {-# INLINE fixed5 #-}
+ fixed5 x = BP.liftFixedToBounded $ const x BP.>$<
+ BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7
+
{-# INLINE escape #-}
escape :: BP.BoundedPrim Word8
escape =
BP.condB (> c2w '>' ) (BP.liftFixedToBounded BP.word8) $
- BP.condB (== c2w '<' ) (fixed4 (c2w '&',(c2w 'l',(c2w 't',c2w ';')))) $ -- <
- BP.condB (== c2w '>' ) (fixed4 (c2w '&',(c2w 'g',(c2w 't',c2w ';')))) $ -- >
- BP.condB (== c2w '&' ) (fixed5 (c2w '&',(c2w 'a',(c2w 'm',(c2w 'p',c2w ';'))))) $ -- &
- BP.condB (== c2w '"' ) (fixed5 (c2w '&',(c2w '#',(c2w '3',(c2w '4',c2w ';'))))) $ -- "
- BP.condB (== c2w '\'') (fixed5 (c2w '&',(c2w '#',(c2w '3',(c2w '9',c2w ';'))))) $ -- '
- BP.liftFixedToBounded BP.word8 -- fallback for Chars smaller than '>'
+ BP.condB (== c2w '<' ) (fixed4 (c2w '&',(c2w 'l',(c2w 't',c2w ';')))) $
+ BP.condB (== c2w '>' ) (fixed4 (c2w '&',(c2w 'g',(c2w 't',c2w ';')))) $
+ BP.condB (== c2w '&' ) (fixed5 (c2w '&',(c2w 'a',(c2w 'm',(c2w 'p',c2w ';'))))) $
+ BP.condB (== c2w '"' ) (fixed5 (c2w '&',(c2w '#',(c2w '3',(c2w '4',c2w ';'))))) $
+ BP.condB (== c2w '\'') (fixed5 (c2w '&',(c2w '#',(c2w '3',(c2w '9',c2w ';'))))) $
+ BP.liftFixedToBounded BP.word8
where
-
- {-# INLINE c2w #-}
c2w = fromIntegral . ord
- {-# INLINE fixed4 #-}
fixed4 x = BP.liftFixedToBounded $ const x BP.>$<
BP.word8 BP.>*< BP.word8 BP.>*< BP.word8 BP.>*< BP.word8
- {-# INLINE fixed5 #-}
fixed5 x = BP.liftFixedToBounded $ const x BP.>$<
BP.word8 BP.>*< BP.word8 BP.>*< BP.word8 BP.>*< BP.word8 BP.>*< BP.word8
@@ -101,7 +122,7 @@
convert (AT x) = convert x
instance Convert (Raw String) where
{-# INLINE convert #-}
- convert (Raw x) = Converted (fromString x)
+ convert (Raw x) = stringConvRaw x
instance Convert (Raw T.Text) where
{-# INLINE convert #-}
convert (Raw x) = Converted (T.encodeUtf8Builder x)
@@ -110,7 +131,7 @@
convert (Raw x) = Converted (TL.encodeUtf8Builder x)
instance Convert String where
{-# INLINE convert #-}
- convert = convert . T.pack
+ convert = stringConv
instance Convert T.Text where
{-# INLINE convert #-}
convert = Converted . T.encodeUtf8BuilderEscaped escape
@@ -135,3 +156,37 @@
instance KnownSymbol a => Convert (Proxy a) where
{-# INLINE convert #-}
convert = Converted . U.byteStringCopy . fromString . symbolVal
+
+{-# INLINE builderCString# #-}
+builderCString# :: Addr# -> Converted
+builderCString# addr = Converted $ BP.primUnfoldrBounded escape go 0
+ where
+ go !i | b /= 0 = Just (fromIntegral b, i+1)
+ | otherwise = Nothing
+ where
+ !b = I# (ord# (at# i))
+ at# (I# i#) = indexCharOffAddr# addr i#
+
+{-# INLINE [0] stringConv #-}
+stringConv :: String -> Converted
+stringConv = Converted . BP.primMapListBounded escapeUtf8
+
+{-# INLINE [0] stringConvRaw #-}
+stringConvRaw :: String -> Converted
+stringConvRaw = Converted . B.stringUtf8
+
+{-# RULES "CONVERTED literal" forall a.
+ stringConv (GHC.unpackCString# a)
+ = builderCString# a #-}
+
+{-# RULES "CONVERTED literal raw" forall a.
+ stringConvRaw (GHC.unpackCString# a)
+ = Converted (U.byteStringCopy (fromString (GHC.unpackCString# a))) #-}
+
+{-# RULES "CONVERTED literal utf8" forall a.
+ stringConv (GHC.unpackCStringUtf8# a)
+ = convert (T.pack (GHC.unpackCStringUtf8# a)) #-}
+
+{-# RULES "CONVERTED literal utf8 raw" forall a.
+ stringConvRaw (GHC.unpackCStringUtf8# a)
+ = convert (Raw (T.pack (GHC.unpackCStringUtf8# a))) #-}
diff --git a/src/Html/Type.hs b/src/Html/Type.hs
--- a/src/Html/Type.hs
+++ b/src/Html/Type.hs
@@ -331,7 +331,7 @@
a ?> f (b # c) = a ?> (b # c)
a ?> () = ()
a ?> (b -> c) = TypeError (Text "Html elements can't contain functions")
- a ?> b = CheckString a
+ a ?> b = CheckString a b
type family Null xs where
Null '[] = True
@@ -680,8 +680,13 @@
ToTypeList x = '[Nothing]
-- | Append two type lists.
+--
+-- Note that this definition is that ugly to reduce compiletimes.
+-- Please check whether the context reduction stack or compiletimes of
+-- a big html page get bigger if you try to refactor.
type family Append xs ys :: [k] where
- Append xs '[] = xs
+ Append xs '[]
+ = xs
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
@@ -704,8 +709,8 @@
Append (x1 ': xs) ys
= x1 ': Append xs ys
- Append '[] ys = ys
-
+ Append '[] ys
+ = ys
-- | Check whether an element may have content.
type family HasContent a where
@@ -713,8 +718,12 @@
HasContent _ = True
-- | Fuse neighbouring non empty type level strings.
+--
+-- Note that this definition is that ugly to reduce compiletimes.
+-- Please check whether the context reduction stack or compiletimes of
+-- a big html page get bigger if you try to refactor.
type family Fuse a where
- Fuse '[Just a, Nothing] = '[a, ""]
+ Fuse '[Just a, Nothing] = '[a, ""]
Fuse (Just x1 ': Nothing ': Just x2 ': Nothing ': x ': xs) = x1 ': x2 ': Fuse (x ': xs)
Fuse (Just x1 ': Just x2 ': Nothing ': Just x3 ': Nothing ': x ': xs) = AppendSymbol x1 x2 ': x3 ': Fuse (x ': xs)
Fuse (Just x1 ': Nothing ': Just x2 ': Just x3 ': Nothing ': x ': xs) = x1 ': AppendSymbol x2 x3 ': Fuse (x ': xs)
@@ -733,10 +742,15 @@
Fuse (Just x1 ': Just x2 ': Just x3 ': Just x4 ': Just x5 ': Nothing ': x ': xs) = AppendSymbol x1 (AppendSymbol x2 (AppendSymbol x3 (AppendSymbol x4 x5))) ': Fuse (x ': xs)
Fuse (Just x1 ': Just x2 ': xs) = Fuse (Just (AppendSymbol x1 x2) ': xs)
- Fuse (Just a ': xs) = '[a]
+ Fuse (Just a ': xs) = '[a]
Fuse (Nothing ': xs) = "" ': Fuse xs
- Fuse '[] = '[]
+ Fuse '[] = '[]
+-- | Type level drop.
+--
+-- Note that this definition is that ugly to reduce compiletimes.
+-- Please check whether the context reduction stack or compiletimes of
+-- a big html page get bigger if you try to refactor.
type family Drop n xs :: [Symbol] where
Drop 0 xs = xs
Drop 1 (_ ': xs) = xs
@@ -745,6 +759,11 @@
Drop 4 (_ ': _ ': _ ': _ ': xs) = xs
Drop n (_ ': _ ': _ ': _ ': _ ': xs) = Drop (n-5) xs
+-- | Type level take.
+--
+-- Note that this definition is that ugly to reduce compiletimes.
+-- Please check whether the context reduction stack or compiletimes of
+-- a big html page get bigger if you try to refactor.
type family Take n xs :: [Symbol] where
Take 0 _ = '[]
Take 1 (x1 ': _) = '[x1]
@@ -754,6 +773,10 @@
Take n (x1 ': x2 ': x3 ': x4 ': x5 ': xs) = x1 ': x2 ': x3 ': x4 ': x5 ': Take (n-5) xs
-- | Last for type level lists.
+--
+-- Note that this definition is that ugly to reduce compiletimes.
+-- Please check whether the context reduction stack or compiletimes of
+-- a big html page get bigger if you try to refactor.
type family Last (xs :: [Symbol]) where
Last (_ ': _ ': _ ': _ ': _ ': _ ': _ ': _ ': x ': xs) = Last (x ': xs)
Last (_ ': _ ': _ ': _ ': x ': xs) = Last (x ': xs)
@@ -777,10 +800,10 @@
CheckContentCategory a c = Elem a c
-- | Check whether a given element may contain a string.
-type family CheckString (a :: Element) where
- CheckString a = If (TestPaternity OnlyText (GetInfo a) (ElementInfo '[FlowContent, PhrasingContent] NoContent))
- (() :: Constraint)
- (TypeError (ShowType a :<>: Text " can't contain a string"))
+type family CheckString (a :: Element) b where
+ CheckString a b = If (TestPaternity OnlyText (GetInfo a) (ElementInfo '[FlowContent, PhrasingContent] NoContent))
+ (() :: Constraint)
+ (TypeError (ShowType a :<>: Text " can't contain a " :<>: ShowType b))
-- | Content categories according to the html spec.
data ContentCategory
@@ -818,6 +841,7 @@
type Symbols a = Fuse (ToTypeList a)
+-- | Get type list of valid elements for a given attribute. An empty list signifies global attribute.
type family GetAttributeInfo a where
GetAttributeInfo AcceptA = '[Form, Input]
GetAttributeInfo AcceptCharsetA = '[Form]
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: 0.5.0.0
+version: 0.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
@@ -31,6 +31,7 @@
build-depends: base >= 4.10 && < 4.11
, text
, bytestring
+ , ghc-prim
test-suite test
type: exitcode-stdio-1.0