nice-html 0.2.0 → 0.3.0
raw patch · 6 files changed
+249/−51 lines, 6 filesdep ~basedep ~blaze-markupdep ~bytestring
Dependency ranges changed: base, blaze-markup, bytestring, text
Files
- README.md +161/−0
- benchmarks/MemProf.hs +11/−0
- nice-html.cabal +22/−1
- src/Text/Html/Nice.hs +2/−1
- src/Text/Html/Nice/Internal.hs +42/−47
- src/Text/Html/Nice/Writer.hs +11/−2
README.md view
@@ -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 <html>asdf</html>" -- 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<script></script>\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+```
+ benchmarks/MemProf.hs view
@@ -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))+
nice-html.cabal view
@@ -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
src/Text/Html/Nice.hs view
@@ -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
src/Text/Html/Nice/Internal.hs view
@@ -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 --------------------------------------------------------------------------------
src/Text/Html/Nice/Writer.hs view
@@ -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