diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -147,7 +147,7 @@ This is comparing blaze with `type-of-html`: -![type-of-html](https://user-images.githubusercontent.com/5609565/30388159-2281182c-98af-11e7-8b29-aac26b7fbb57.png) +![type-of-html](https://user-images.githubusercontent.com/5609565/30524978-229dd21c-9bfe-11e7-8404-1f69b93cec22.png) 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 @@ -215,10 +215,16 @@ This sort of compiletime optimization isn't for free, it'll increase compilation times. +Note that compiling with `-O2` results in a ~25% faster binary than +with `-O` and compiling with `-O0` compiles about 15 times faster, so +be sure that you develop with `-O0` and benchmark or deploy with +`-O2`. Be aware, that cabal compiles only with `-O` if you don't +specify explicitly otherwise. + ## Comparision to lucid and blaze-html Advantages of `type-of-html`: -- more or less 7 times faster +- more or less 10 times faster on a medium sized page - a lot higher type safety: nearly no invalid document is inhabited - fewer dependencies diff --git a/src/Html.hs b/src/Html.hs --- a/src/Html.hs +++ b/src/Html.hs @@ -1,10 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TypeOperators #-} diff --git a/src/Html/Reify.hs b/src/Html/Reify.hs --- a/src/Html/Reify.hs +++ b/src/Html/Reify.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} module Html.Reify where @@ -25,10 +24,13 @@ -- | Render a html document to a Builder. {-# INLINE renderBuilder #-} -renderBuilder :: forall a. Document a => a -> B.Builder -renderBuilder x = renderchunks (Tagged x :: Tagged (Symbols a) a) - <> unConv (convert (Proxy @ (Last (Symbols a)))) +renderBuilder :: Document a => a -> B.Builder +renderBuilder = renderchunks . tag +{-# INLINE tag #-} +tag :: a -> Tagged (ToTypeList a) a +tag = Tagged + -- | Render a html document to a String. {-# INLINE renderString #-} renderString :: Document a => a -> String @@ -44,18 +46,16 @@ renderByteString :: Document a => a -> B.ByteString renderByteString = B.toLazyByteString . renderBuilder -type Document a = - ( Renderchunks (Tagged (Symbols a) a) - , KnownSymbol (Last (Symbols a)) - ) +class Renderchunks (Tagged (ToTypeList a) a) => Document a where +instance Renderchunks (Tagged (ToTypeList a) a) => Document a class Renderchunks a where renderchunks :: a -> B.Builder -instance KnownSymbol a => Renderchunks (Tagged prox (Proxy a)) where +instance KnownSymbol a => Renderchunks (Tagged (prox :: [Symbol]) (Proxy a)) where {-# INLINE renderchunks #-} renderchunks _ = mempty -instance Renderchunks (Tagged prox ()) where +instance Renderchunks (Tagged (prox :: [Symbol]) ()) where {-# INLINE renderchunks #-} renderchunks _ = mempty @@ -75,6 +75,22 @@ = unConv (convert (Proxy @ s)) <> unConv (convert x) +instance {-# INCOHERENT #-} + ( Renderchunks (Tagged xs val) + ) => Renderchunks (Tagged ('FingerTree xs "") val) where + {-# INLINE renderchunks #-} + renderchunks (Tagged t) + = renderchunks (Tagged t :: Tagged xs val) + +instance {-# INCOHERENT #-} + ( Renderchunks (Tagged xs val) + , KnownSymbol x + ) => Renderchunks (Tagged ('FingerTree xs x) val) where + {-# INLINE renderchunks #-} + renderchunks (Tagged t) + = renderchunks (Tagged t :: Tagged xs val) + <> unConv (convert (Proxy @ x)) + instance ( Renderchunks (Tagged prox b) ) => Renderchunks (Tagged prox (a > b)) where @@ -100,13 +116,10 @@ <> renderchunks (Tagged b :: Tagged (Drop (CountContent a) prox) b) instance - ( Renderchunks (Tagged (Symbols (a `f` b)) (a `f` b)) - , KnownSymbol (Last (Symbols (a `f` b))) + ( Renderchunks (Tagged (ToTypeList (a `f` b)) (a `f` b)) , KnownSymbol s ) => Renderchunks (Tagged (s ': ss) [a `f` b]) where {-# INLINE renderchunks #-} renderchunks (Tagged xs) = unConv (convert (Proxy @ s)) - <> foldMap (\x -> renderchunks (Tagged x :: Tagged (Symbols (a `f` b)) (a `f` b)) <> closing) xs - where closing = unConv (convert (Proxy @ (Last (Symbols (a `f` b))))) - + <> foldMap (renderchunks . tag) xs diff --git a/src/Html/Type.hs b/src/Html/Type.hs --- a/src/Html/Type.hs +++ b/src/Html/Type.hs @@ -1,12 +1,11 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} module Html.Type where @@ -228,7 +227,6 @@ | CoordsA | CrossoriginA | DataA - | Data'A | DatetimeA | DefaultA | DeferA @@ -534,123 +532,122 @@ ShowElement Xmp = "xmp" type family ShowAttribute (x :: Attribute) where - ShowAttribute AcceptA = "accept" - ShowAttribute AcceptCharsetA = "accept-charset" - ShowAttribute AccesskeyA = "accesskey" - ShowAttribute ActionA = "action" - ShowAttribute AlignA = "align" - ShowAttribute AltA = "alt" - ShowAttribute AsyncA = "async" - ShowAttribute AutocompleteA = "autocomplete" - ShowAttribute AutofocusA = "autofocus" - ShowAttribute AutoplayA = "autoplay" - ShowAttribute AutosaveA = "autosave" - ShowAttribute BgcolorA = "bgcolor" - ShowAttribute BorderA = "border" - ShowAttribute BufferedA = "buffered" - ShowAttribute ChallengeA = "challenge" - ShowAttribute CharsetA = "charset" - ShowAttribute CheckedA = "checked" - ShowAttribute CiteA = "cite" - ShowAttribute ClassA = "class" - ShowAttribute CodeA = "code" - ShowAttribute CodebaseA = "codebase" - ShowAttribute ColorA = "color" - ShowAttribute ColsA = "cols" - ShowAttribute ColspanA = "colspan" - ShowAttribute ContentA = "content" - ShowAttribute ContenteditableA = "contenteditable" - ShowAttribute ContextmenuA = "contextmenu" - ShowAttribute ControlsA = "controls" - ShowAttribute CoordsA = "coords" - ShowAttribute CrossoriginA = "crossorigin" - ShowAttribute DataA = "data" - ShowAttribute Data'A = "data'" - ShowAttribute DatetimeA = "datetime" - ShowAttribute DefaultA = "default" - ShowAttribute DeferA = "defer" - ShowAttribute DirA = "dir" - ShowAttribute DirnameA = "dirname" - ShowAttribute DisabledA = "disabled" - ShowAttribute DownloadA = "download" - ShowAttribute DraggableA = "draggable" - ShowAttribute DropzoneA = "dropzone" - ShowAttribute EnctypeA = "enctype" - ShowAttribute ForA = "for" - ShowAttribute FormA = "form" - ShowAttribute FormactionA = "formaction" - ShowAttribute HeadersA = "headers" - ShowAttribute HeightA = "height" - ShowAttribute HiddenA = "hidden" - ShowAttribute HighA = "high" - ShowAttribute HrefA = "href" - ShowAttribute HreflangA = "hreflang" - ShowAttribute HttpEquivA = "httpequiv" - ShowAttribute IconA = "icon" - ShowAttribute IdA = "id" - ShowAttribute IntegrityA = "integrity" - ShowAttribute IsmapA = "ismap" - ShowAttribute ItempropA = "itemprop" - ShowAttribute KeytypeA = "keytype" - ShowAttribute KindA = "kind" - ShowAttribute LabelA = "label" - ShowAttribute LangA = "lang" - ShowAttribute LanguageA = "language" - ShowAttribute ListA = "list" - ShowAttribute LoopA = "loop" - ShowAttribute LowA = "low" - ShowAttribute ManifestA = "manifest" - ShowAttribute MaxA = "max" - ShowAttribute MaxlengthA = "maxlength" - ShowAttribute MinlengthA = "minlength" - ShowAttribute MediaA = "media" - ShowAttribute MethodA = "method" - ShowAttribute MinA = "min" - ShowAttribute MultipleA = "multiple" - ShowAttribute MutedA = "muted" - ShowAttribute NameA = "name" - ShowAttribute NovalidateA = "novalidate" - ShowAttribute OpenA = "open" - ShowAttribute OptimumA = "optimum" - ShowAttribute PatternA = "pattern" - ShowAttribute PingA = "ping" - ShowAttribute PlaceholderA = "placeholder" - ShowAttribute PosterA = "poster" - ShowAttribute PreloadA = "preload" - ShowAttribute RadiogroupA = "radiogroup" - ShowAttribute ReadonlyA = "readonly" - ShowAttribute RelA = "rel" - ShowAttribute RequiredA = "required" - ShowAttribute ReversedA = "reversed" - ShowAttribute RowsA = "rows" - ShowAttribute RowspanA = "rowspan" - ShowAttribute SandboxA = "sandbox" - ShowAttribute ScopeA = "scope" - ShowAttribute ScopedA = "scoped" - ShowAttribute SeamlessA = "seamless" - ShowAttribute SelectedA = "selected" - ShowAttribute ShapeA = "shape" - ShowAttribute SizeA = "size" - ShowAttribute SizesA = "sizes" - ShowAttribute SlotA = "slot" - ShowAttribute SpanA = "span" - ShowAttribute SpellcheckA = "spellcheck" - ShowAttribute SrcA = "src" - ShowAttribute SrcdocA = "srcdoc" - ShowAttribute SrclangA = "srclang" - ShowAttribute SrcsetA = "srcset" - ShowAttribute StartA = "start" - ShowAttribute StepA = "step" - ShowAttribute StyleA = "style" - ShowAttribute SummaryA = "summary" - ShowAttribute TabindexA = "tabindex" - ShowAttribute TargetA = "target" - ShowAttribute TitleA = "title" - ShowAttribute TypeA = "type" - ShowAttribute UsemapA = "usemap" - ShowAttribute ValueA = "value" - ShowAttribute WidthA = "width" - ShowAttribute WrapA = "wrap" + ShowAttribute AcceptA = " accept=\"" + ShowAttribute AcceptCharsetA = " accept-charset=\"" + ShowAttribute AccesskeyA = " accesskey=\"" + ShowAttribute ActionA = " action=\"" + ShowAttribute AlignA = " align=\"" + ShowAttribute AltA = " alt=\"" + ShowAttribute AsyncA = " async=\"" + ShowAttribute AutocompleteA = " autocomplete=\"" + ShowAttribute AutofocusA = " autofocus=\"" + ShowAttribute AutoplayA = " autoplay=\"" + ShowAttribute AutosaveA = " autosave=\"" + ShowAttribute BgcolorA = " bgcolor=\"" + ShowAttribute BorderA = " border=\"" + ShowAttribute BufferedA = " buffered=\"" + ShowAttribute ChallengeA = " challenge=\"" + ShowAttribute CharsetA = " charset=\"" + ShowAttribute CheckedA = " checked=\"" + ShowAttribute CiteA = " cite=\"" + ShowAttribute ClassA = " class=\"" + ShowAttribute CodeA = " code=\"" + ShowAttribute CodebaseA = " codebase=\"" + ShowAttribute ColorA = " color=\"" + ShowAttribute ColsA = " cols=\"" + ShowAttribute ColspanA = " colspan=\"" + ShowAttribute ContentA = " content=\"" + ShowAttribute ContenteditableA = " contenteditable=\"" + ShowAttribute ContextmenuA = " contextmenu=\"" + ShowAttribute ControlsA = " controls=\"" + ShowAttribute CoordsA = " coords=\"" + ShowAttribute CrossoriginA = " crossorigin=\"" + ShowAttribute DataA = " data=\"" + ShowAttribute DatetimeA = " datetime=\"" + ShowAttribute DefaultA = " default=\"" + ShowAttribute DeferA = " defer=\"" + ShowAttribute DirA = " dir=\"" + ShowAttribute DirnameA = " dirname=\"" + ShowAttribute DisabledA = " disabled=\"" + ShowAttribute DownloadA = " download=\"" + ShowAttribute DraggableA = " draggable=\"" + ShowAttribute DropzoneA = " dropzone=\"" + ShowAttribute EnctypeA = " enctype=\"" + ShowAttribute ForA = " for=\"" + ShowAttribute FormA = " form=\"" + ShowAttribute FormactionA = " formaction=\"" + ShowAttribute HeadersA = " headers=\"" + ShowAttribute HeightA = " height=\"" + ShowAttribute HiddenA = " hidden=\"" + ShowAttribute HighA = " high=\"" + ShowAttribute HrefA = " href=\"" + ShowAttribute HreflangA = " hreflang=\"" + ShowAttribute HttpEquivA = " httpequiv=\"" + ShowAttribute IconA = " icon=\"" + ShowAttribute IdA = " id=\"" + ShowAttribute IntegrityA = " integrity=\"" + ShowAttribute IsmapA = " ismap=\"" + ShowAttribute ItempropA = " itemprop=\"" + ShowAttribute KeytypeA = " keytype=\"" + ShowAttribute KindA = " kind=\"" + ShowAttribute LabelA = " label=\"" + ShowAttribute LangA = " lang=\"" + ShowAttribute LanguageA = " language=\"" + ShowAttribute ListA = " list=\"" + ShowAttribute LoopA = " loop=\"" + ShowAttribute LowA = " low=\"" + ShowAttribute ManifestA = " manifest=\"" + ShowAttribute MaxA = " max=\"" + ShowAttribute MaxlengthA = " maxlength=\"" + ShowAttribute MinlengthA = " minlength=\"" + ShowAttribute MediaA = " media=\"" + ShowAttribute MethodA = " method=\"" + ShowAttribute MinA = " min=\"" + ShowAttribute MultipleA = " multiple=\"" + ShowAttribute MutedA = " muted=\"" + ShowAttribute NameA = " name=\"" + ShowAttribute NovalidateA = " novalidate=\"" + ShowAttribute OpenA = " open=\"" + ShowAttribute OptimumA = " optimum=\"" + ShowAttribute PatternA = " pattern=\"" + ShowAttribute PingA = " ping=\"" + ShowAttribute PlaceholderA = " placeholder=\"" + ShowAttribute PosterA = " poster=\"" + ShowAttribute PreloadA = " preload=\"" + ShowAttribute RadiogroupA = " radiogroup=\"" + ShowAttribute ReadonlyA = " readonly=\"" + ShowAttribute RelA = " rel=\"" + ShowAttribute RequiredA = " required=\"" + ShowAttribute ReversedA = " reversed=\"" + ShowAttribute RowsA = " rows=\"" + ShowAttribute RowspanA = " rowspan=\"" + ShowAttribute SandboxA = " sandbox=\"" + ShowAttribute ScopeA = " scope=\"" + ShowAttribute ScopedA = " scoped=\"" + ShowAttribute SeamlessA = " seamless=\"" + ShowAttribute SelectedA = " selected=\"" + ShowAttribute ShapeA = " shape=\"" + ShowAttribute SizeA = " size=\"" + ShowAttribute SizesA = " sizes=\"" + ShowAttribute SlotA = " slot=\"" + ShowAttribute SpanA = " span=\"" + ShowAttribute SpellcheckA = " spellcheck=\"" + ShowAttribute SrcA = " src=\"" + ShowAttribute SrcdocA = " srcdoc=\"" + ShowAttribute SrclangA = " srclang=\"" + ShowAttribute SrcsetA = " srcset=\"" + ShowAttribute StartA = " start=\"" + ShowAttribute StepA = " step=\"" + ShowAttribute StyleA = " style=\"" + ShowAttribute SummaryA = " summary=\"" + ShowAttribute TabindexA = " tabindex=\"" + ShowAttribute TargetA = " target=\"" + ShowAttribute TitleA = " title=\"" + ShowAttribute TypeA = " type=\"" + ShowAttribute UsemapA = " usemap=\"" + ShowAttribute ValueA = " value=\"" + ShowAttribute WidthA = " width=\"" + ShowAttribute WrapA = " wrap=\"" type family OpenTag e where OpenTag e = AppendSymbol (AppendSymbol "<" (ShowElement e)) ">" @@ -681,9 +678,6 @@ (><) ('FingerTree ss r) ('FingerTree (s ': ss2) r2) = 'FingerTree (Append ss (AppendSymbol r s ': ss2)) r2 (><) ('FingerTree ss r) ('FingerTree '[] r2) = 'FingerTree ss (AppendSymbol r r2) -type family ToList (t :: FingerTree) where - ToList ('FingerTree ss r) = Append ss '[r] - -- | Flatten a html tree of elements into a type list of tags. type family ToTypeList a :: FingerTree where ToTypeList (a # ()) = ToTypeList a @@ -693,7 +687,7 @@ ToTypeList ((a :@: b) ()) = AppendSymbol "<" (ShowElement a) <| ToTypeList b |> If (HasContent (GetInfo a)) (AppendSymbol ">" (CloseTag a)) ">" ToTypeList (a > b) = OpenTag a <| ToTypeList b |> CloseTag a ToTypeList ((a :@: b) c) = (AppendSymbol "<" (ShowElement a) <| ToTypeList b) >< (">" <| ToTypeList c |> CloseTag a) - ToTypeList (a := b) = 'FingerTree '[AppendSymbol (AppendSymbol " " (ShowAttribute a)) "=\""] "\"" + ToTypeList (a := b) = 'FingerTree '[ShowAttribute a] "\"" ToTypeList (Proxy x) = 'FingerTree '[] x ToTypeList x = 'FingerTree '[""] "" @@ -759,18 +753,6 @@ Take 4 (x1 ': x2 ': x3 ': x4 ': _) = '[x1, x2, x3, x4] 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) - Last (_ ': _ ': x ': xs) = Last (x ': xs) - Last (_ ': x ': xs) = Last (x ': xs) - Last (x ': xs) = x - -- | Type of type level information about tags. data ElementInfo (contentCategories :: [ContentCategory]) @@ -823,9 +805,7 @@ Elem a (_ : xs) = Elem a xs Elem a '[] = False -newtype Tagged (proxies :: [Symbol]) target = Tagged target - -type Symbols a = ToList (ToTypeList a) +newtype Tagged (proxies :: k) target = Tagged target -- | Get type list of valid elements for a given attribute. An empty list signifies global attribute. type family GetAttributeInfo a where 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.1.1 +version: 0.5.1.2 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 @@ -49,7 +49,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench - ghc-options: -Wall + ghc-options: -Wall -O2 default-language: Haskell2010 build-depends: base >= 4.10 && < 4.11 , type-of-html