diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Mike Ledger + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# A nice HTML templating library + + diff --git a/benchmarks/BigTable/Blaze.hs b/benchmarks/BigTable/Blaze.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BigTable/Blaze.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +module BigTable.Blaze where +import Criterion.Main (Benchmark, bench, nf) +import Data.Text.Lazy (Text) +import Text.Blaze.Html.Renderer.Text as H +import Text.Blaze.Html5 as H +import Weigh (Weigh, func) + +-- | Render the argument matrix as an HTML table. +-- +bigTable :: [[Int]] -- ^ Matrix. + -> Text -- ^ Result. +bigTable t = renderHtml $ do + h1 "i am a real big old table\n" + p "i am good at lots of static data\n" + p "i am glab at lots of static data\n" + p "i am glob at lots of static data\n" + p "i am glib at lots of static data\n" + p "i am glub at lots of static data\n" + p "i am glom at lots of static data\n" + p "i am glof at lots of static data\n" + p "i am gref at lots of static data\n" + p "i am greg at lots of static data\n" + table $ do + thead (tr (mapM_ (th . toHtml) [1..10 :: Int])) + tbody (mapM_ row t) + p "i am good at lots of static data\n" + p "i am glab at lots of static data\n" + p "i am glob at lots of static data\n" + p "i am glib at lots of static data\n" + p "i am glub at lots of static data\n" + p "i am glom at lots of static data\n" + p "i am glof at lots of static data\n" + p "i am gref at lots of static data\n" + p "i am greg at lots of static data\n" + where + row r = tr (mapM_ (\t -> do + p "hi!\n" + td (toHtml t) + p "hello!\n") r) + +benchmark :: [[Int]] -> Benchmark +benchmark rows = bench "blaze" (bigTable `nf` rows) + +weight :: [[Int]] -> Weigh () +weight i = func (show (length i) ++ "/blaze") bigTable i diff --git a/benchmarks/BigTable/Lucid.hs b/benchmarks/BigTable/Lucid.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BigTable/Lucid.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +module BigTable.Lucid where +import Criterion.Main (Benchmark, bench, nf) +import Data.Text.Lazy (Text) +import Lucid.Base +import Lucid.Html5 +import Weigh (Weigh, func) + +-- | Render the argument matrix as an HTML table. +-- +bigTable :: [[Int]] -- ^ Matrix. + -> Text -- ^ Result. +bigTable t = renderText $ do + h1_ "i am a real big old table\n" + + p_ "i am good at lots of static data\n" + p_ "i am glab at lots of static data\n" + p_ "i am glob at lots of static data\n" + p_ "i am glib at lots of static data\n" + p_ "i am glub at lots of static data\n" + p_ "i am glom at lots of static data\n" + p_ "i am glof at lots of static data\n" + p_ "i am gref at lots of static data\n" + p_ "i am greg at lots of static data\n" + + table_ $ do + thead_ (tr_ (mapM_ (th_ . toHtml . show) [1..10 :: Int])) + tbody_ (mapM_ row t) + + p_ "i am good at lots of static data\n" + p_ "i am glab at lots of static data\n" + p_ "i am glob at lots of static data\n" + p_ "i am glib at lots of static data\n" + p_ "i am glub at lots of static data\n" + p_ "i am glom at lots of static data\n" + p_ "i am glof at lots of static data\n" + p_ "i am gref at lots of static data\n" + p_ "i am greg at lots of static data\n" + + where + row :: [Int] -> Html () + row r = tr_ (mapM_ (\t -> do + p_ "hi!\n" + td_ (toHtml (show t)) + p_ "hello!\n") r) + +benchmark :: [[Int]] -> Benchmark +benchmark rows = bench "lucid" (bigTable `nf` rows) + +weight :: [[Int]] -> Weigh () +weight i = func (show (length i) ++ "/lucid") bigTable i diff --git a/benchmarks/BigTable/Nice.hs b/benchmarks/BigTable/Nice.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BigTable/Nice.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +module BigTable.Nice where +import Criterion.Main (Benchmark, bench, nf) +import Data.Functor.Identity +import Text.Html.Nice +import Weigh (Weigh, func) + +rows :: FastMarkup ([[Int]] -> FastMarkup (FastMarkup Builder)) +rows = compile $ do + h1_ "i am a real big old table\n" + p_ "i am good at lots of static data\n" + p_ "i am glab at lots of static data\n" + p_ "i am glob at lots of static data\n" + p_ "i am glib at lots of static data\n" + p_ "i am glub at lots of static data\n" + p_ "i am glom at lots of static data\n" + p_ "i am glof at lots of static data\n" + p_ "i am gref at lots of static data\n" + p_ "i am greg at lots of static data\n" + table_ $ do + thead_ . tr_ . mapM_ (th_ . builder . decimal) $ [1..10 :: Int] + tbody_ . stream . tr_ . stream $ do + p_ "hi!\n" + td_ (dynamic decimal) + p_ "hello!\n" + p_ "i am good at lots of static data\n" + p_ "i am glab at lots of static data\n" + p_ "i am glob at lots of static data\n" + p_ "i am glib at lots of static data\n" + p_ "i am glub at lots of static data\n" + p_ "i am glom at lots of static data\n" + p_ "i am glof at lots of static data\n" + p_ "i am gref at lots of static data\n" + p_ "i am greg at lots of static data\n" + +bigTable :: [[Int]] -> Text +bigTable table = + toLazyText (runIdentity (r (rows :$ table))) + +benchmark :: [[Int]] -> Benchmark +benchmark t = bench "nice" (bigTable `nf` t) + +weight :: [[Int]] -> Weigh () +weight i = func (show (length i) ++ "/nice") bigTable i + diff --git a/benchmarks/Mem.hs b/benchmarks/Mem.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Mem.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BangPatterns #-} +import qualified BigTable.Blaze as Blaze +import qualified BigTable.Lucid as Lucid +import qualified BigTable.Nice as Nice +import Control.Monad (forM_) +import qualified Data.Text.Lazy.IO as T +import qualified Weigh as Mem + +{-# NOINLINE rows #-} +rows :: Int -> [[Int]] +rows i = replicate i [1..10] + +main :: IO () +main = do + + -- Sanity checks + let + check l f g = + if f' == g' + then putStrLn ("OK: " ++ l) + else do + putStrLn ("FAILED: " ++ l) + putStrLn "\n### f:" + T.putStrLn f' + putStrLn "\n### g:" + T.putStrLn g' + where + f' = f (rows 10) + g' = g (rows 10) + + check "nice = blaze" Nice.bigTable Blaze.bigTable + check "nice = lucid" Nice.bigTable Lucid.bigTable + check "lucid = blaze" Lucid.bigTable Blaze.bigTable + + Mem.mainWith $ forM_ [10, 100, 1000] $ \i -> do + let table = rows i + Blaze.weight table + Nice.weight table + Lucid.weight table + diff --git a/benchmarks/Perf.hs b/benchmarks/Perf.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Perf.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +import qualified BigTable.Blaze as Blaze +import qualified BigTable.Lucid as Lucid +import qualified BigTable.Nice as Nice +import qualified Criterion.Main as Perf +import qualified Data.Text.Lazy.IO as T + +{-# NOINLINE rows #-} +rows :: Int -> [[Int]] +rows i = replicate i [1..10] + +main :: IO () +main = do + + -- Sanity checks + let + check l f g = + if f' == g' + then putStrLn ("OK: " ++ l) + else do + putStrLn ("FAILED: " ++ l) + putStrLn "\n### f:" + T.putStrLn f' + putStrLn "\n### g:" + T.putStrLn g' + where + f' = f (rows 10) + g' = g (rows 10) + + check "nice = blaze" Nice.bigTable Blaze.bigTable + check "nice = lucid" Nice.bigTable Lucid.bigTable + check "lucid = blaze" Lucid.bigTable Blaze.bigTable + + Perf.defaultMain + [ Perf.bgroup (show i) + [ Blaze.benchmark (rows i) + , Nice.benchmark (rows i) + , Lucid.benchmark (rows i) + ] + | i <- [10, 100, 1000] + ] + diff --git a/nice-html.cabal b/nice-html.cabal new file mode 100644 --- /dev/null +++ b/nice-html.cabal @@ -0,0 +1,94 @@ +name: nice-html +version: 0.1.0.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. +homepage: https://github.com/mikeplus64/nice-html#readme +bug-reports: https://github.com/mikeplus64/nice-html/issues +author: Mike Ledger +maintainer: mike@quasimal.com +copyright: 2017 Mike Ledger +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/mikeplus64/nice-html + +library + hs-source-dirs: + src + ghc-options: -Wall -O2 + build-depends: + base >=4.9 && <5 + , bytestring >= 0.10 + , deepseq + , text >=1.2 + , vector >=0.5 + , template-haskell >= 2.11 + , blaze-markup >= 0.5 + , recursion-schemes >= 5.0.1 + , transformers + , free >= 4.5 + , bifunctors >= 5.1 + , data-default-class + exposed-modules: + Text.Html.Nice + Text.Html.Nice.Internal + Text.Html.Nice.FreeMonad + Text.Html.Nice.Writer + Text.Html.Nice.Writer.Html5 + other-modules: + Paths_nice_html + default-language: Haskell2010 + +benchmark mem + type: exitcode-stdio-1.0 + main-is: Mem.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.Blaze + BigTable.Lucid + BigTable.Nice + default-language: Haskell2010 + +benchmark perf + type: exitcode-stdio-1.0 + main-is: Perf.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.Blaze + BigTable.Lucid + BigTable.Nice + default-language: Haskell2010 diff --git a/src/Text/Html/Nice.hs b/src/Text/Html/Nice.hs new file mode 100644 --- /dev/null +++ b/src/Text/Html/Nice.hs @@ -0,0 +1,31 @@ +module Text.Html.Nice + ( + -- * Nice HTML writer monad + module Text.Html.Nice.Writer + -- * HTML5 support + , module Text.Html.Nice.Writer.Html5 + -- * Rendering + , FastMarkup + , Render (..) + , (:$) (..) + , renderM + , renderMs + , render + -- * Re-exports of 'TLB.Builder' functions + , module Data.Text.Lazy.Builder + , module Data.Text.Lazy.Builder.Int + , module Data.Text.Lazy.Builder.RealFloat + -- * Re-exports of lazy 'Text' functions + , Text + , fromStrict + , toStrict + ) where +import Data.Text.Lazy (Text, fromStrict, toStrict) +import Data.Text.Lazy.Builder +import Data.Text.Lazy.Builder.Int +import Data.Text.Lazy.Builder.RealFloat +import Text.Html.Nice.Internal ((:$) (..), FastMarkup, + Render (..), render, renderM, + renderMs) +import Text.Html.Nice.Writer +import Text.Html.Nice.Writer.Html5 diff --git a/src/Text/Html/Nice/FreeMonad.hs b/src/Text/Html/Nice/FreeMonad.hs new file mode 100644 --- /dev/null +++ b/src/Text/Html/Nice/FreeMonad.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +-- | A 'Free' monad-based HTML markup monad. Unlike the writer-like monad in +-- "Text.Html.Nice.Writer", sequencing bits of markup together results in them +-- being nested, rather than concatenated. +-- +-- There is no kitchen-sink of HTML5 elements provided. Use OverloadedLabels +-- instead: @ #div :: Markup n () @ and @ #div :: MakeNode n () @. +-- +-- Since the monad and applicative of 'Markup' here nests rather than +-- concatenates, the function 'nodes' is provided to put a list of nodes +-- in sequence. You can use OverloadedLists for convenient syntax here. +-- +-- Example Markup: +-- +-- @ +-- #html >> +-- [ #head >> #title >> "Title goes here" +-- , #body >> +-- [ #h1 >> "heading goes here" +-- , #p >> "i am a paragraph below the heading" +-- , do i <- branch [0..100] +-- builder (decimal i) +-- ] +-- ] +-- @ +-- +module Text.Html.Nice.FreeMonad + ( -- * Markup + Markup + , FastMarkup + , runMarkup + -- * Compiling + , compile + -- * Rendering + -- ** Rendering through some monad + , renderM + , renderMs + -- ** Pure rendering + , render + , Identity (..) + -- * Util + , TLB.toLazyText + -- * Special HTML elements + , doctype + -- ** Basic node types + , node + , Attr (..) + , attr + , empty + -- ** Text types + , text + , lazyText + , builder + , unescape + , string + -- * Dynamic nodes + , dynamic + , hole + , embed + -- ** Sequential nodes + , nodes + , branch + -- ** Streamed dynamic nodes + , stream + -- ** Combinators + , sub + -- * Useful exports + -- ** Useful 'TLB.Builder' functions + , TLB.decimal + , TLB.realFloat + , TLB.fromText + , TLB.fromString + , TLB.fromLazyText + -- ** Text builder + , TLB.Builder + -- ** Void type + , Void + ) where +import Control.Monad +import Control.Monad.Free.Church +import Data.Bifunctor +import Data.Default.Class +import Data.Foldable as F +import qualified Data.Functor.Foldable as F +import Data.Functor.Identity +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.Builder.Int as TLB +import qualified Data.Text.Lazy.Builder.RealFloat as TLB +import qualified Data.Vector as V +import Data.Void +import GHC.Exts (IsList (..)) +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.TypeLits (KnownSymbol, symbolVal') +import Text.Html.Nice.Internal + +-- | 'Markup' is a free monad based on the base functor to 'Markup\'F' +-- +-- Beware: this is a wacky monad. '>>' does *not* sequence nodes together; +-- instead, it nests them. To lay out nodes sequentially, use 'nodes'. +-- +-- = Syntactic sugar +-- 'Markup' supports @OverloadedLabels@, @OverloadedStrings@ and +-- @OverloadedLists@. +-- +-- == @OverloadedStrings@ +-- @("foo" :: Markup n a) = 'text' "foo"@ +-- +-- == @OverloadedLists@ +-- @([a,b,c] :: Markup n a) = 'nodes' [a,b,c]@ +-- +-- == @OverloadedLabels@ +-- The 'IsLabel' instances give a convenient way to write nodes. +-- +-- === Nodes without attributes +-- @ (#foo :: 'Markup' n a) = 'node' "foo" [] @ +-- +-- === Nodes with attributes +-- @ 'attr' #foo [a,b,c] = 'node' "foo" [a,b,c] @ +-- +newtype Markup n a = Markup { unMarkup :: F (Markup'F n) a } + deriving (Functor, Applicative, Monad, MonadFree (Markup'F n)) + +instance Default (Markup n a) where + def = empty + +instance Monoid (Markup n a) where + mempty = empty + mappend a b = nodes [a, b] + +instance IsString (Markup n a) where + fromString = text . fromString + +instance IsList (Markup n a) where + type Item (Markup n a) = Markup n a + fromList = nodes + toList _ = error "haha, fooled you, Markup has no toList" + +instance (a ~ (), KnownSymbol s) => IsLabel s (Markup n a) where + fromLabel p = node (fromString (symbolVal' p)) [] + +newtype MakeNode n a = N ([Attr n] -> Markup n a) + +instance (a ~ (), KnownSymbol s) => IsLabel s (MakeNode n a) where + fromLabel p = N (node (fromString (symbolVal' p))) + +instance Bifunctor Markup where + first f = Markup . hoistF (first f) . unMarkup + second = fmap + +-- | For use with @OverloadedLabels@. +-- +-- @ 'attr' #x [a,b,c] = 'node' "x" [a,b,c] @ +-- +attr :: MakeNode n a -> [Attr n] -> Markup n a +attr (N f) a = f a + +runMarkup :: Markup n a -> Markup' n +runMarkup h = runF (unMarkup h) (const Empty) F.embed + +-- | Compile a 'Html' for use with 'render' and its friends. +-- +-- See also: 'compile_'. +compile :: Markup n a -> FastMarkup n +compile = compile_ . runMarkup + +-- | Make a node with some attributes. +node :: Text -> [Attr n] -> Markup n () +node t v = liftF (NodeF t (V.fromList v) ()) + +-- | Insert text and escape it +text :: Text -> Markup n a +text t = liftF (TextF DoEscape (StrictT t)) + +-- | Insert text and escape it +lazyText :: TL.Text -> Markup n a +lazyText t = liftF (TextF DoEscape (LazyT t)) + +-- | Insert text and escape it +builder :: TLB.Builder -> Markup n a +builder t = liftF (TextF DoEscape (BuilderT t)) + +-- | Insert text and escape it +string :: String -> Markup n a +string t = liftF (TextF DoEscape (BuilderT (TLB.fromString t))) + +-- | Insert text and don't escape it +unescape :: Text -> Markup n a +unescape t = liftF (TextF Don'tEscape (StrictT t)) + +-- | Insert a dynamic value. +dynamic :: n -> Markup n a +dynamic n = liftF (HoleF DoEscape n) + +hole :: Markup (a -> a) t +hole = dynamic id + +-- | For each element of a list of branches, generate sequential markup +branch :: [a] -> Markup n a +branch = liftF . ListF + +-- | For each element of a list, generate sequential markup +nodes :: [Markup n a] -> Markup n a +nodes = join . liftF . ListF + +-- | Empty node. Terminates 'Markup' to this point +empty :: Markup n a +empty = liftF EmptyF + +-- | Insert a sub-template. +sub :: Markup n a -> Markup (FastMarkup n) a +sub x = liftF (HoleF Don'tEscape (compile x)) + +-- | Insert a sub-template. +{-# INLINE embed #-} +embed :: (t -> FastMarkup n) -> Markup (t -> FastMarkup n) a +embed f = dynamic f + +{-# INLINE stream #-} +stream :: Foldable f + => Markup (a -> n) r' + -> Markup (f a -> FastMarkup n) r +stream m = embed $ \fa -> case F.toList fa of + [] -> FEmpty + list -> FStream (ListS list (\a -> fmap ($ a) fm)) + where + !fm = compile m + +doctype :: Markup n a +doctype = liftF DoctypeF + diff --git a/src/Text/Html/Nice/Internal.hs b/src/Text/Html/Nice/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Html/Nice/Internal.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Text.Html.Nice.Internal where +import Control.DeepSeq (NFData (..)) +import Control.Monad +import Control.Monad.Trans.State.Strict (evalState, get, modify') +import Data.Bifunctor.TH +import Data.Functor.Foldable.TH +import Data.Functor.Identity +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Void +import GHC.Generics (Generic) +import qualified Text.Blaze as Blaze +import qualified Text.Blaze.Internal as Blaze (textBuilder) +import qualified Text.Blaze.Renderer.Text as Blaze + +type AttrName = Text + +data Attr a = (:=) + { attrKey :: !AttrName + , attrVal :: !Text + } | (:-) + { attrKey :: !AttrName + , attrValHole :: a + } deriving (Show, Eq, Functor, Foldable, Traversable) + +data IsEscaped = DoEscape | Don'tEscape + deriving (Show, Eq) + +data SomeText + = LazyT TL.Text + | BuilderT TLB.Builder + | StrictT !T.Text + deriving (Show, Eq) + +-- | A very simple HTML DSL +data Markup' a + = Doctype + | Node !Text !(Vector (Attr a)) (Markup' a) + | VoidNode !Text !(Vector (Attr a)) + | List [Markup' a] + | Stream (Stream a) + | Text !IsEscaped !SomeText + | Hole !IsEscaped a + | Empty + deriving (Show, Eq, Functor, Foldable, Traversable) + +data Stream a + = forall s. ListS [s] (s -> FastMarkup a) + | forall s t. S !s !(s -> Next s t) !(t -> FastMarkup a) + +instance Show a => Show (Stream a) where + show (ListS s f) = "(Stream (" ++ show (map f s) ++ "))" + show (S s next f) = show (ListS (asList s) f) + where + asList s1 = case next s1 of + Next s2 a -> a : asList s2 + Done a -> [a] + +-- | Don't use this! It's a lie! +instance Eq (Stream a) where + _ == _ = True + +instance Functor Stream where + fmap f (S s next fm) = S s next (\s' -> fmap f (fm s')) + fmap f (ListS l g) = ListS l (\s -> fmap f (g s)) + +instance Foldable Stream where + foldMap f (S s0 next fm) = go s0 + where + go s = case next s of + Next s1 a -> foldMap f (fm a) <> go s1 + Done a -> foldMap f (fm a) + foldMap f (ListS s fm) = foldMap (foldMap f . fm) s + +instance NFData (Stream a) where + rnf (S !_ !_ !_) = () + rnf (ListS !_ !_) = () + +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 (fm x)) (go xs) + go [] = nil +unstream f (S s0 next fm) cons nil = go s0 + where + go s = case next s of + Next s1 a -> cons (f (fm a)) (go s1) + Done a -> cons (f (fm a)) nil + +instance Traversable Stream where + -- phew ... + traverse f str = + (\s0' -> ListS s0' id) <$> + sequenceA (unstream (traverse f) str (:) []) + +data Next s a + = Next !s !a + | Done !a + deriving (Show, Eq, Functor, Foldable, Traversable) + +-------------------------------------------------------------------------------- +-- Compiling + +data a :$ b = (:$) (FastMarkup (a -> b)) a + deriving (Functor) + +infixl 0 :$ + +instance Show a => Show (a :$ b) where + show (a :$ b) = '(':showsPrec 11 b (' ':':':'$':' ':showsPrec 11 (b <$ a) ")") + +data FastMarkup a + = Bunch {-# UNPACK #-} !(Vector (FastMarkup a)) + | FStream (Stream a) + | FLText TL.Text + | FSText {-# UNPACK #-} !Text + | FBuilder !TLB.Builder + | FHole !IsEscaped !a + | FEmpty + deriving (Show, Eq, Functor, Foldable, Traversable, Generic) + +instance Monoid (FastMarkup a) where + mempty = FBuilder mempty + mappend a b = Bunch [a, b] + +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 + FHole !_ a -> rnf a + _ -> () + +makeBaseFunctor ''Markup' +deriveBifunctor ''Markup'F + +{-# INLINE plateFM #-} +-- | Unlike 'plate', this uses 'Monad'. That's because 'traverse' over 'Vector' +-- is really quite slow. +plateFM :: Monad m + => (FastMarkup a -> m (FastMarkup a)) + -> FastMarkup a + -> m (FastMarkup a) +plateFM f x = case x of + Bunch v -> Bunch <$> V.mapM f v + _ -> pure x + +compileAttrs :: forall a. Vector (Attr a) -> (TLB.Builder, Vector (Attr a)) +compileAttrs v = (static, dynAttrs) + where + isHoly :: Foldable f => f a -> Bool + isHoly = foldr (\_ _ -> True) False + + staticAttrs :: Vector (Attr a) + dynAttrs :: Vector (Attr a) + (dynAttrs, staticAttrs) = case V.unstablePartition isHoly v of + (dyn, stat) -> (dyn, stat) + + static :: TLB.Builder + static = + V.foldr + (\((:=) key val) xs -> + " " <> TLB.fromText key <> "=\"" <> escapeText val <> "\"" <> xs) + mempty + staticAttrs + +escapeText :: Text -> TLB.Builder +escapeText = Blaze.renderMarkupBuilder . Blaze.text + +{-# INLINE escape #-} +escape :: SomeText -> TLB.Builder +escape st = case st of + StrictT t -> Blaze.renderMarkupBuilder (Blaze.text t) + LazyT t -> Blaze.renderMarkupBuilder (Blaze.lazyText t) + BuilderT t -> Blaze.renderMarkupBuilder (Blaze.textBuilder t) + +toText :: TLB.Builder -> Text +toText = TL.toStrict . TLB.toLazyText + +fastAttr :: Attr a -> FastMarkup a +fastAttr ((:-) k v) = + Bunch [FSText (" " <> k <> "=\""), FHole DoEscape v, FSText "\""] +fastAttr _ = + error "very bad" + +fast :: Markup' a -> FastMarkup a +fast m = case m of + Doctype -> FSText "\n" + Node t attrs m' -> case compileAttrs attrs of + (staticAttrs, dynAttrs) -> case V.length dynAttrs of + 0 -> Bunch + [ FSText (T.concat ["<", t, toText staticAttrs, ">"]) + , fast m' + , FSText (T.concat [""]) + ] + _ -> Bunch + [ FBuilder ("<" <> TLB.fromText t <> staticAttrs) + , Bunch (V.map fastAttr dynAttrs) + , FSText ">" + , fast m' + , FSText (" t <> ">") + ] + VoidNode t attrs -> case compileAttrs attrs of + (staticAttrs, dynAttrs) -> case V.length dynAttrs of + 0 -> FSText (T.concat ["<", t, toText staticAttrs, " />"]) + _ -> Bunch + [ FBuilder ("<" <> TLB.fromText t <> staticAttrs) + , Bunch (V.map fastAttr dynAttrs) + , FSText " />" + ] + Text DoEscape t -> FBuilder (escape t) + Text Don'tEscape t -> case t of + StrictT a -> FSText a + LazyT a -> FLText a + BuilderT a -> FBuilder a + List v -> Bunch (V.map fast (V.fromList v)) + Hole e v -> FHole e v + Stream a -> FStream a + Empty -> FEmpty + +-- | Look for an immediate string-like term and render that +immediateRender :: FastMarkup a -> Maybe TLB.Builder +immediateRender fm = case fm of + FBuilder t -> Just t + FSText t -> Just (TLB.fromText t) + FLText t -> Just (TLB.fromLazyText t) + FEmpty -> Just mempty + _ -> Nothing + +-- | Flatten a vector of 'FastMarkup. String-like terms that are next to +-- eachother should be combined +munch :: Vector (FastMarkup a) -> Vector (FastMarkup a) +munch v = V.fromList (go mempty 0) + where + len = V.length v + go acc i + | i < len = + let e = V.unsafeIndex v i + in case immediateRender e of + Just b -> go (acc <> b) (i + 1) + 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 + _ -> go + + where + go = again $ case fm of + Bunch v -> case V.length v of + 0 -> FEmpty + 1 -> V.head v + _ -> Bunch + (munch + (V.concatMap + (\x -> case x of + Bunch v' -> v' + FEmpty -> V.empty + _ -> V.singleton (flatten x)) + v)) + _ -> runIdentity (plateFM (Identity . flatten) fm) + + again a + | eqHack a == eqHack fm = fm + | otherwise = flatten a + +-- | Run all Text builders +strictify :: FastMarkup a -> FastMarkup a +strictify fm = case fm of + FBuilder t -> FLText (TLB.toLazyText t) + FLText t -> FLText t + _ -> runIdentity (plateFM (Identity . strictify) fm) + +-- | Compile 'Markup''' +compile_ :: Markup' a -> FastMarkup a +compile_ = strictify . flatten . fast + +-------------------------------------------------------------------------------- +-- Rendering + +{-# + SPECIALISE renderM :: (a -> Identity TLB.Builder) + -> FastMarkup a + -> Identity TLB.Builder + #-} + +{-# INLINABLE renderM #-} +-- | Render 'FastMarkup' +renderM :: Monad m => (a -> m TLB.Builder) -> FastMarkup a -> m TLB.Builder +renderM f = go + where + + runStream (S s0 next fm) = rgo s0 + where + rgo s' = case next s' of + Next xs x -> mappend <$> go (fm x) <*> rgo xs + Done x -> go (fm x) + + runStream (ListS l fm) = rgo l + where + rgo (x:xs) = mappend <$> go (fm x) <*> rgo xs + rgo _ = pure mempty + + go fm = case fm of + Bunch v -> V.foldM (\a b -> return (a <> b)) mempty =<< V.mapM go v + FBuilder t -> return t + FSText t -> return (TLB.fromText t) + FLText t -> return (TLB.fromLazyText t) + FHole _ a -> f a + FStream str -> runStream str + _ -> return mempty + +{-# INLINE renderMs #-} +-- | Render 'FastMarkup' by recursively rendering any sub-markup. +renderMs :: Monad m => (a -> m (FastMarkup Void)) -> FastMarkup a -> m TLB.Builder +renderMs f = renderM (f >=> renderMs (f . absurd)) + +{-# INLINE render #-} +-- | Render 'FastMarkup' that has no holes. +render :: FastMarkup Void -> TLB.Builder +render = runIdentity . renderM absurd + +class Render a m where + r :: a -> m TLB.Builder + +-- | Defer application of an argument to rendering +instance (Monad m, Render b m) => Render (a :$ b) m where + {-# INLINE r #-} + r (b :$ a) = renderM (\f -> r (f a)) b + +instance Monad m => Render Void m where + {-# INLINE r #-} + r = return . absurd + +instance Monad m => Render TLB.Builder m where + {-# INLINE r #-} + r = return + +instance {-# OVERLAPPABLE #-} (Render a m, Monad m) => Render (FastMarkup a) m where + {-# INLINE r #-} + r = renderM r + diff --git a/src/Text/Html/Nice/Writer.hs b/src/Text/Html/Nice/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Text/Html/Nice/Writer.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +module Text.Html.Nice.Writer + ( -- * The markup monad + Markup + -- * Basic node types + , text + , lazyText + , builder + , string + -- ** Variants that don't escape their input + , textRaw + , lazyTextRaw + , builderRaw + , stringRaw + -- * Combinators + , (!) + , dynamic + , dynamicRaw + , sub + -- ** Streaming + , stream + -- ** Noting specific elements + , Note (..) + , note + -- * Compilation + , compile + , runMarkup + -- * Internals + , makeElement + , makeVoidElement + ) where +import Data.Foldable (toList) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Vector as V +import Text.Html.Nice.Internal + +type Children p = [Markup' p] -> [Markup' p] + +data MarkupStep p a = MarkupStep + { msGlobalId :: {-# UNPACK #-} !Int + , msChildren :: Children p + , msResult :: a + } deriving (Functor, Foldable, Traversable) + +-- | A Writer-like monad +newtype Markup p a = Markup (Int -> [Attr p] -> MarkupStep p a) + +instance Functor (Markup p) where + fmap f (Markup m) = Markup (\i attr -> fmap f (m i attr)) + +instance Applicative (Markup p) where + pure a = Markup (\i _ -> MarkupStep i id a) + Markup f <*> Markup x = Markup $ \i attr -> + case f i attr of + MarkupStep j fnodes f' -> + case x j [] of + MarkupStep k xnodes x' -> + MarkupStep k (fnodes . xnodes) (f' x') + +instance Monad (Markup p) where + Markup mx >>= f = Markup $ \i attr -> case mx i attr of + MarkupStep j dx a -> case f a of + Markup f' -> case f' j attr of + MarkupStep k dy b -> MarkupStep k (dx . dy) b + +-- | Compile a 'Markup'. Don't run this multiple times! +compile :: Markup t a -> FastMarkup t +compile m = case runM 0 m of (m', _, _) -> compile_ m' + +-- | Compile a 'Markup'. Don't run this multiple times! +-- +-- Same as 'compile' but lets you use the result. +runMarkup :: Markup t a -> (a, FastMarkup t) +runMarkup m = case runM 0 m of (m', _, a) -> (a, compile_ m') + +-------------------------------------------------------------------------------- +-- Internals + +runM :: Int -> Markup t a -> (Markup' t, Int, a) +runM i (Markup m) = (List (x []), j, a) where MarkupStep j x a = m i [] + +{-# INLINE makeElement #-} +makeElement :: Text -> Markup p a -> Markup p a +makeElement name m = + Markup $ \i attr -> case runM i m of + (cs, j, a) -> MarkupStep + { msGlobalId = j + , msChildren = (:) (Node name (V.fromList attr) cs) + , msResult = a + } + +{-# INLINE makeVoidElement #-} +makeVoidElement :: Text -> Markup p () +makeVoidElement name = Markup $ \i attr -> MarkupStep + { msGlobalId = i + , msChildren = (:) (VoidNode name (V.fromList attr)) + , msResult = () + } + +{-# INLINE lift #-} +lift :: Markup' t -> Markup t () +lift m' = Markup $ \i _ -> MarkupStep + { msGlobalId = i + , msChildren = (m':) + , msResult = () + } + +-------------------------------------------------------------------------------- +-- Node types + +{-# INLINE dynamic #-} +dynamic :: p -> Markup p () +dynamic = lift . Hole DoEscape + +{-# INLINE dynamicRaw #-} +dynamicRaw :: p -> Markup p () +dynamicRaw = lift . Hole Don'tEscape + +instance a ~ () => IsString (Markup t a) where + fromString = text . fromString + +-------------------------------------------------------------------------------- +-- Combinators + +{-# INLINE (!) #-} +-- | Add some attributes +(!) :: (Markup t a -> Markup t b) -> [Attr t] -> Markup t a -> Markup t b +(!) f a x = Markup $ \i attrs -> + case f x of + Markup m -> m i (a ++ attrs) + +infixl 8 ! + +{-# INLINE stream #-} +stream :: Foldable f + => Markup (a -> n) r + -> Markup (f a -> FastMarkup n) r +stream m = + result <$ dynamic (\fa -> FStream (ListS + (toList fa) + (\a -> fmap ($ a) fm))) + where + (result, !fm) = runMarkup m + +-- | Sub-template +sub :: Markup n a -> Markup (FastMarkup n) a +sub m = case runMarkup m of + (a, fm) -> a <$ lift (Hole Don'tEscape fm) + +-------------------------------------------------------------------------------- +-- 'Note' system + +data Note a = Note + { noteId :: {-# UNPACK #-} !Int + , noted :: FastMarkup a + } deriving (Eq, Show, Functor) + +-- | Give a node a unique id +-- +-- Might be handy to build server-side react-esque systems +note :: (Markup t a -> Markup t b) -> Markup t a -> Markup t (Note t, b) +note f x = withNote + where + withNote = do + (i, a) <- markup + case runM i markup of + (m', _, _) -> return (Note + { noteId = i + , noted = compile_ m' + }, a) + + markup = Markup $ \i attrs -> case f x of + Markup m -> + case m (i + 1) ("id" := niceId i:attrs) of + ms -> ms { msResult = (i, msResult ms) } + +-- | HTML 'id' attribute given to 'note'd elements. +niceId :: Int -> Text +niceId i = T.pack ("nice-" ++ show i) + +-------------------------------------------------------------------------------- +-- Useful string functions + +-- | Insert text and escape it +text :: Text -> Markup t () +text = lift . Text DoEscape . StrictT + +-- | Insert text and escape it +lazyText :: TL.Text -> Markup n () +lazyText = lift . Text DoEscape . LazyT + +-- | Insert text and escape it +builder :: TLB.Builder -> Markup n () +builder = lift . Text DoEscape . BuilderT + +-- | Insert text and escape it +string :: String -> Markup n () +string = lift . Text DoEscape . BuilderT . TLB.fromString + +-- | Insert text and don't escape it +textRaw :: Text -> Markup t () +textRaw = lift . Text Don'tEscape . StrictT + +-- | Insert text and don't escape it +lazyTextRaw :: TL.Text -> Markup n () +lazyTextRaw = lift . Text Don'tEscape . LazyT + +-- | Insert text and don't escape it +builderRaw :: TLB.Builder -> Markup n () +builderRaw = lift . Text Don'tEscape . BuilderT + +-- | Insert text and don't escape it +stringRaw :: String -> Markup n () +stringRaw = lift . Text Don'tEscape . BuilderT . TLB.fromString + diff --git a/src/Text/Html/Nice/Writer/Html5.hs b/src/Text/Html/Nice/Writer/Html5.hs new file mode 100644 --- /dev/null +++ b/src/Text/Html/Nice/Writer/Html5.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Text.Html.Nice.Writer.Html5 where +import qualified Language.Haskell.TH as TH +import Text.Html.Nice.Internal (AttrName) +import Text.Html.Nice.Writer (Markup, makeElement, makeVoidElement) + +$(let + parents :: [String] + parents = + [ "a", "abbr", "address", "article", "aside", "audio", "b" + , "bdo", "blockquote", "body", "button", "canvas", "caption", "cite" + , "code", "colgroup", "command", "datalist", "dd", "del", "details" + , "dfn", "div", "dl", "dt", "em", "fieldset", "figcaption", "figure" + , "footer", "form", "h1", "h2", "h3", "h4", "h5", "h6", "head", "header" + , "hgroup", "html", "i", "iframe", "ins", "kbd", "label" + , "legend", "li", "main", "map", "mark", "menu", "meter", "nav" + , "noscript", "object", "ol", "optgroup", "option", "output", "p" + , "pre", "progress", "q", "rp", "rt", "ruby", "samp", "script" + , "section", "select", "small", "span", "strong", "style", "sub" + , "summary", "sup", "table", "tbody", "td", "textarea", "tfoot", "th" + , "thead", "time", "title", "tr", "ul", "var", "video" + ] + + leafs :: [String] + leafs = + [ "area", "base", "br", "col", "embed", "hr", "img", "input", "keygen" + , "link", "menuitem", "meta", "param", "source", "track", "wbr" + ] + + attributes :: [String] + attributes = + [ "accept", "accept-charset", "accesskey", "action", "alt", "async" + , "autocomplete", "autofocus", "autoplay", "challenge", "charset" + , "checked", "cite", "class", "cols", "colspan", "content" + , "contenteditable", "contextmenu", "controls", "coords", "data" + , "datetime", "defer", "dir", "disabled", "draggable", "enctype", "for" + , "form", "formaction", "formenctype", "formmethod", "formnovalidate" + , "formtarget", "headers", "height", "hidden", "high", "href" + , "hreflang", "http-equiv", "icon", "id", "ismap", "item", "itemprop" + , "itemscope", "itemtype" + , "keytype", "label", "lang", "list", "loop", "low", "manifest", "max" + , "maxlength", "media", "method", "min", "multiple", "name" + , "novalidate", "onbeforeonload", "onbeforeprint", "onblur", "oncanplay" + , "oncanplaythrough", "onchange", "oncontextmenu", "onclick" + , "ondblclick", "ondrag", "ondragend", "ondragenter", "ondragleave" + , "ondragover", "ondragstart", "ondrop", "ondurationchange", "onemptied" + , "onended", "onerror", "onfocus", "onformchange", "onforminput" + , "onhaschange", "oninput", "oninvalid", "onkeydown", "onkeyup" + , "onload", "onloadeddata", "onloadedmetadata", "onloadstart" + , "onmessage", "onmousedown", "onmousemove", "onmouseout", "onmouseover" + , "onmouseup", "onmousewheel", "ononline", "onpagehide", "onpageshow" + , "onpause", "onplay", "onplaying", "onprogress", "onpropstate" + , "onratechange", "onreadystatechange", "onredo", "onresize", "onscroll" + , "onseeked", "onseeking", "onselect", "onstalled", "onstorage" + , "onsubmit", "onsuspend", "ontimeupdate", "onundo", "onunload" + , "onvolumechange", "onwaiting", "open", "optimum", "pattern", "ping" + , "placeholder", "preload", "pubdate", "radiogroup", "readonly", "rel" + , "required", "reversed", "rows", "rowspan", "sandbox", "scope" + , "scoped", "seamless", "selected", "shape", "size", "sizes", "span" + , "spellcheck", "src", "srcdoc", "start", "step", "style", "subject" + , "summary", "tabindex", "target", "title", "type", "usemap", "value" + , "width", "wrap", "xmlns" + ] + + fun :: TH.Name -> String -> TH.ExpQ + fun f x = TH.appE (TH.varE f) (TH.stringE x) + + hs :: Char -> Char + hs '-' = '_' + hs a = a + + parentQ :: String -> TH.DecsQ + parentQ name = do + decName <- TH.newName (map hs name ++ "_") + sig <- TH.sigD decName [t| forall t a. Markup t a -> Markup t a |] + val <- TH.funD decName [TH.clause [] (TH.normalB (fun 'makeElement name)) []] + return [sig, val] + + voidQ :: String -> TH.DecsQ + voidQ name = do + decName <- TH.newName (map hs name ++ "_") + sig <- TH.sigD decName [t| forall t. Markup t () |] + val <- TH.funD decName [TH.clause [] (TH.normalB (fun 'makeVoidElement name)) []] + return [sig, val] + + attrQ :: String -> TH.DecsQ + attrQ name = do + decName <- TH.newName (map hs name ++ if elem name (parents ++ leafs) + then "__" + else "_") + sig <- TH.sigD decName [t| AttrName |] + val <- TH.funD decName [TH.clause [] (TH.normalB (TH.stringE name)) []] + return [sig, val] + + in concat <$> sequence + [ fmap concat (mapM parentQ parents) + , fmap concat (mapM voidQ leafs) + , fmap concat (mapM attrQ attributes) + ]) +