diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,164 @@ # A nice HTML templating library +This is a library for HTML templating in the same vein as `blaze-html`, `lucid`, +or `type-of-html`, which all provide HTML EDSLs for Haskell. +## Overview +WIP. Check out `Text.Html.Nice.Writer` for the simplest, most recommendedest, +monadic interface. + +## Example + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module TodoList where +import Data.Text (Text) +import Text.Html.Nice ((:$) (..), Attr (..), Builder, + FastMarkup, Render (..)) +import Text.Html.Nice.Writer +import Text.Html.Nice.Writer.Html5 + +data Todo = Todo + { todoDate :: Text + , todoText :: Text + } + +todos :: [Todo] +todos = + [ Todo "october 25 2017" "write todo list asdf" -- escaped + , Todo "october 26 2017" "write another todo list" + ] + +template :: FastMarkup ([Todo] -> FastMarkup Text) +template = compile $ do + doctype_ + html_ $ do + head_ $ title_ "Todo list" + body_ $ do + h1_ "Todo list" + stream $ div_ ! "class" := "todo-item" $ do + text "\n\n" -- this gets escaped + b_ (dynamic todoText) + " (" + dynamic todoDate + ")" + +test :: Monad m => m Builder +test = r (template :$ todos) +``` + +## Comparison + +1. Unlike `blaze-html` and `lucid`: `nice-html` has a distinct template + compilation phase, with a different type for compiled markup. + +2. Unlike `type-of-html`: this compilation is done explicitly at runtime. This + increases runtime, but enables more complex transformations. Namely + `nice-html` can compile escaped text. `nice-html` also makes no attempt to + ensure correct HTML. + +3. Unlike each of them, `nice-html` parameterises its templating type with the + type for the data you use in the template. This enables `nice-html` to compile + the static parts of the dynamic parts of a template instead of just the + top-level stuff. + +4. Like `lucid`, `nice-html` has a valid `Monad` interface (actually, two). + +5. Unlike `lucid`, `nice-html` does not have a monad transformer. The only state + that `nice-html` can currently keep track of is an increasing `Int` counter, + intended to be used to keep track of the `id` of elements for use with + JavaScript. But even this doesn't really work, because it doesn't support + repeated elements (e.g. produced by `stream`). + + This makes it harder to write templates for `nice-html`, because you + generally can't/shouldn't use the familiar `mapM_` etc. for dynamic data as + you might if you were using `lucid` or `blaze`. + + +## Benchmark results (as of 0.3.0) + +### Memory (includes memory overhead compilation... I think) + +``` +nice-html-0.3.0: benchmarks +Running 2 benchmarks... +Benchmark mem: RUNNING... +OK: nice = blaze +OK: nice = lucid +OK: lucid = blaze + +Case Allocated GCs +10/blaze 562,152 1 +10/nice 297,544 0 +10/lucid 230,304 0 +100/blaze 4,520,016 8 +100/nice 2,952,184 5 +100/lucid 1,855,256 3 +1000/blaze 44,096,616 85 +1000/nice 29,500,096 57 +1000/lucid 18,071,008 32 +Benchmark mem: FINISH +``` + +### Runtime + +``` +Benchmark perf: RUNNING... +benchmarking 10/blaze +time 80.13 μs (79.59 μs .. 80.73 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 80.41 μs (80.08 μs .. 80.83 μs) +std dev 1.166 μs (951.2 ns .. 1.531 μs) + +benchmarking 10/nice +time 34.09 μs (33.88 μs .. 34.28 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 34.08 μs (33.93 μs .. 34.25 μs) +std dev 542.8 ns (477.2 ns .. 619.9 ns) +variance introduced by outliers: 12% (moderately inflated) + +benchmarking 10/lucid +time 57.40 μs (57.03 μs .. 57.75 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 57.44 μs (57.15 μs .. 57.67 μs) +std dev 856.7 ns (763.9 ns .. 960.4 ns) + +benchmarking 100/blaze +time 660.8 μs (657.2 μs .. 664.9 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 661.6 μs (659.1 μs .. 664.3 μs) +std dev 8.748 μs (7.441 μs .. 10.24 μs) + +benchmarking 100/nice +time 336.9 μs (334.7 μs .. 338.9 μs) + 1.000 R² (0.999 R² .. 1.000 R²) +mean 334.3 μs (333.2 μs .. 336.1 μs) +std dev 4.685 μs (3.229 μs .. 7.873 μs) + +benchmarking 100/lucid +time 514.4 μs (509.5 μs .. 519.7 μs) + 0.999 R² (0.999 R² .. 1.000 R²) +mean 507.1 μs (504.6 μs .. 510.4 μs) +std dev 9.897 μs (7.573 μs .. 14.83 μs) +variance introduced by outliers: 11% (moderately inflated) + +benchmarking 1000/blaze +time 6.355 ms (6.324 ms .. 6.380 ms) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 6.424 ms (6.400 ms .. 6.453 ms) +std dev 79.56 μs (62.81 μs .. 106.2 μs) + +benchmarking 1000/nice +time 3.356 ms (3.348 ms .. 3.366 ms) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 3.376 ms (3.369 ms .. 3.385 ms) +std dev 24.95 μs (20.64 μs .. 29.55 μs) + +benchmarking 1000/lucid +time 4.885 ms (4.850 ms .. 4.921 ms) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 4.868 ms (4.857 ms .. 4.881 ms) +std dev 36.95 μs (31.34 μs .. 43.37 μs) + +Benchmark perf: FINISH +``` diff --git a/benchmarks/MemProf.hs b/benchmarks/MemProf.hs new file mode 100644 --- /dev/null +++ b/benchmarks/MemProf.hs @@ -0,0 +1,11 @@ +-- with stack, compile this with --profile --benchmark-arguments '+RTS -p' +import qualified BigTable.Nice as Nice +import qualified Weigh as Mem + +{-# NOINLINE rows #-} +rows :: Int -> [[Int]] +rows i = replicate i [1..10] + +main :: IO () +main = Mem.mainWith (Nice.weight (rows 100)) + diff --git a/nice-html.cabal b/nice-html.cabal --- a/nice-html.cabal +++ b/nice-html.cabal @@ -1,5 +1,5 @@ name: nice-html -version: 0.2.0 +version: 0.3.0 category: Web description: A fast and nice HTML templating library with distinct compilation/rendering phases. synopsis: A fast and nice HTML templating library with distinct compilation/rendering phases. @@ -67,6 +67,27 @@ other-modules: BigTable.Blaze BigTable.Lucid + BigTable.Nice + default-language: Haskell2010 + +benchmark mem-prof + type: exitcode-stdio-1.0 + main-is: MemProf.hs + hs-source-dirs: + benchmarks + ghc-options: -Wall -O2 + build-depends: + base == 4.9.* + , criterion + , blaze-markup + , blaze-html + , lucid + , text + , bytestring + , nice-html + , weigh + , pretty-show + other-modules: BigTable.Nice default-language: Haskell2010 diff --git a/src/Text/Html/Nice.hs b/src/Text/Html/Nice.hs --- a/src/Text/Html/Nice.hs +++ b/src/Text/Html/Nice.hs @@ -14,6 +14,7 @@ , render -- * Utility , recompile + , unlayer -- * Re-exports of 'TLB.Builder' functions , module Data.Text.Lazy.Builder , module Data.Text.Lazy.Builder.Int @@ -30,6 +31,6 @@ import Text.Html.Nice.Internal ((:$) (..), Attr (..), FastMarkup, Render (..), recompile, render, renderM, - renderMs) + renderMs, unlayer) import Text.Html.Nice.Writer import Text.Html.Nice.Writer.Html5 diff --git a/src/Text/Html/Nice/Internal.hs b/src/Text/Html/Nice/Internal.hs --- a/src/Text/Html/Nice/Internal.hs +++ b/src/Text/Html/Nice/Internal.hs @@ -22,7 +22,6 @@ import Control.DeepSeq (NFData (..)) import Control.Monad import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.State.Strict (evalState, get, modify') import Data.Bifunctor.TH import Data.Functor.Foldable.TH import Data.Functor.Identity @@ -70,15 +69,12 @@ | Text !IsEscaped !SomeText | Hole !IsEscaped a | Empty - deriving (Show, Eq, Functor, Foldable, Traversable) + deriving (Show, Eq, Functor, Foldable) {- , Traversable) -} -data Stream a - = forall s. ListS [s] (FastMarkup (s -> a)) - | S [FastMarkup a] +data Stream a = forall s. ListS [s] !(FastMarkup (s -> a)) instance Show a => Show (Stream a) where show (ListS s f) = "(Stream (" ++ show (map (\a -> fmap ($ a) f) s) ++ "))" - show (S fm) = "(S " ++ show fm ++ ")" -- | Don't use this! It's a lie! instance Eq (Stream a) where @@ -86,29 +82,17 @@ instance Functor Stream where fmap f (ListS l g) = ListS l (fmap (fmap f) g) - fmap f (S x) = S (fmap (fmap f) x) instance Foldable Stream where foldMap f s = unstream (foldMap f) s mappend mempty instance NFData a => NFData (Stream a) where rnf (ListS !_ !s) = rnf s - rnf (S fm) = rnf fm {-# INLINE unstream #-} unstream :: (FastMarkup a -> b) -> Stream a -> (b -> c -> c) -> c -> c -unstream f (ListS l fm) cons nil = go l - where - go (x:xs) = cons (f (fmap ($ x) fm)) (go xs) - go [] = nil -unstream f (S l) cons nil = go l - where - go (x:xs) = cons (f x) (go xs) - go [] = nil - -instance Traversable Stream where - -- phew ... - traverse f str = S <$> sequenceA (unstream (traverse f) str (:) []) +unstream f (ListS l fm) cons nil = + foldr (\x -> cons (f (fmap ($ x) fm))) nil l -------------------------------------------------------------------------------- -- Compiling @@ -123,13 +107,16 @@ data FastMarkup a = Bunch {-# UNPACK #-} !(Vector (FastMarkup a)) - | FStream (Stream a) + -- could unpack this manually but would then have to also write + -- Show/Eq/Functor/Foldable manually + | FStream !(Stream a) + | FHole !IsEscaped !a | FLText TL.Text | FSText {-# UNPACK #-} !Text | FBuilder !TLB.Builder - | FHole !IsEscaped !a | FEmpty - deriving (Show, Eq, Functor, Foldable, Traversable, Generic) + | FDeep (FastMarkup (FastMarkup a)) + deriving (Show, Eq, Functor, Foldable, Generic) instance Monoid (FastMarkup a) where mempty = FBuilder mempty @@ -137,12 +124,12 @@ instance NFData a => NFData (FastMarkup a) where rnf f = case f of - Bunch v -> rnf v - FStream s -> rnf s - FLText t -> rnf t - FSText t -> rnf t + Bunch v -> rnf v + FStream s -> rnf s + FLText t -> rnf t + FSText t -> rnf t FHole !_ a -> rnf a - _ -> () + _ -> () makeBaseFunctor ''Markup' deriveBifunctor ''Markup'F @@ -254,22 +241,10 @@ Nothing -> FBuilder acc : e : go mempty (i + 1) | otherwise = [FBuilder acc] -data EqHack a = EqHack {-# UNPACK #-} !Int a - -instance Eq (EqHack a) where - EqHack i _ == EqHack j _ = i == j - --- | Tag everything in a 'Traversable' with a number -eqHack :: Traversable f => f a -> f (EqHack a) -eqHack = (`evalState` 0) . traverse (\x -> do - i <- get - modify' (+ 1) - return (EqHack i x)) - -- | Recursively flatten 'FastMarkup' until doing so does nothing flatten :: FastMarkup a -> FastMarkup a flatten fm = case fm of - FStream t -> FStream t + FStream t -> FStream t -- ignore streams _ -> go where @@ -288,7 +263,8 @@ _ -> runIdentity (plateFM (Identity . flatten) fm) again a - | eqHack a == eqHack fm = fm + -- Eq but ignore holes + | (() <$ a) == (() <$ fm) = fm | otherwise = flatten a -- | Run all Text builders @@ -305,6 +281,9 @@ recompile :: FastMarkup a -> FastMarkup a recompile = strictify . flatten +unlayer :: FastMarkup (FastMarkup a) -> FastMarkup a +unlayer = FDeep + -------------------------------------------------------------------------------- -- Rendering @@ -314,19 +293,21 @@ -> Identity TLB.Builder #-} -{-# INLINABLE renderM #-} +{-# INLINE renderM #-} -- | Render 'FastMarkup' renderM :: Monad m => (a -> m TLB.Builder) -> FastMarkup a -> m TLB.Builder renderM f = go where - go fm = case fm of - Bunch v -> V.foldM (\a b -> return (a <> b)) mempty =<< V.mapM go v + Bunch v -> V.foldM (\acc x -> mappend acc <$> go x) mempty v FBuilder t -> return t FSText t -> return (TLB.fromText t) FLText t -> return (TLB.fromLazyText t) - FHole _ a -> f a + FHole esc a -> case esc of + DoEscape -> Blaze.renderMarkupBuilder . Blaze.textBuilder <$> f a + Don'tEscape -> f a FStream str -> unstream go str (liftM2 mappend) (return mempty) + FDeep a -> renderM go a _ -> return mempty {-# INLINE renderMs #-} @@ -345,7 +326,7 @@ -- needs undecidableinstances ... instance (Render b m, m' ~ ReaderT a m) => Render (a -> b) m' where {-# INLINE r #-} - r f = ReaderT (\a -> r (f a)) + r f = ReaderT (r . f) -- | Defer application of an argument to rendering instance (Monad m, Render b m) => Render (a :$ b) m where @@ -360,9 +341,23 @@ {-# INLINE r #-} r = return +instance Monad m => Render T.Text m where + {-# INLINE r #-} + r = return . TLB.fromText + +instance Monad m => Render TL.Text m where + {-# INLINE r #-} + r = return . TLB.fromLazyText + instance {-# OVERLAPPABLE #-} (Render a m, Monad m) => Render (FastMarkup a) m where {-# INLINE r #-} r = renderM r + +newtype RenderToFastMarkup a = RenderToFastMarkup { unToFastMarkup :: a } + +instance (ToFastMarkup a, Monad m) => Render (RenderToFastMarkup a) m where + {-# INLINE r #-} + r = r . (toFastMarkup :: a -> FastMarkup Void) . unToFastMarkup -------------------------------------------------------------------------------- diff --git a/src/Text/Html/Nice/Writer.hs b/src/Text/Html/Nice/Writer.hs --- a/src/Text/Html/Nice/Writer.hs +++ b/src/Text/Html/Nice/Writer.hs @@ -10,7 +10,6 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} @@ -35,6 +34,7 @@ , dynamicRaw , using , sub + , mapP -- ** Streaming , stream -- ** Noting specific elements @@ -144,6 +144,15 @@ dynamicRaw :: p -> Markup p () dynamicRaw = lift . Hole Don'tEscape +-- | Map over the holes in a 'Markup'. This necessarily discards any attributes +-- currently being added that are not static. +mapP :: (a -> b) -> Markup a r -> Markup b r +mapP f (Markup m) = Markup $ \i attr -> case m i (foldr addA [] attr) of + ms -> ms { msChildren = \cs -> map (fmap f) (msChildren ms []) ++ cs } + where + addA ((:=) a b) xs = (a := b) : xs + addA _ xs = xs + instance a ~ () => IsString (Markup t a) where fromString = text . fromString @@ -174,7 +183,7 @@ => Markup (a -> n) r -> Markup (f a -> FastMarkup n) r stream m = - result <$ dynamic (\fa -> FStream (ListS (toList fa) fm)) + result <$ dynamicRaw (\fa -> FStream (ListS (toList fa) fm)) where (result, !fm) = runMarkup m