packages feed

nice-html (empty) → 0.1.0.0

raw patch · 13 files changed

+1335/−0 lines, 13 filesdep +basedep +bifunctorsdep +blaze-html

Dependencies added: base, bifunctors, blaze-html, blaze-markup, bytestring, criterion, data-default-class, deepseq, free, lucid, nice-html, pretty-show, recursion-schemes, template-haskell, text, transformers, vector, weigh

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,3 @@+# A nice HTML templating library++
+ benchmarks/BigTable/Blaze.hs view
@@ -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
+ benchmarks/BigTable/Lucid.hs view
@@ -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
+ benchmarks/BigTable/Nice.hs view
@@ -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+
+ benchmarks/Mem.hs view
@@ -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+
+ benchmarks/Perf.hs view
@@ -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]+    ]+
+ nice-html.cabal view
@@ -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
+ src/Text/Html/Nice.hs view
@@ -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
+ src/Text/Html/Nice/FreeMonad.hs view
@@ -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+
+ src/Text/Html/Nice/Internal.hs view
@@ -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 "<!DOCTYPE html>\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 ["</", t, ">"])+        ]+      _ -> 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+
+ src/Text/Html/Nice/Writer.hs view
@@ -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+
+ src/Text/Html/Nice/Writer/Html5.hs view
@@ -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)+     ])+