From edcf2b1433f9bca8b4fc86094afdddd94926a414 Mon Sep 17 00:00:00 2001 From: vi Date: Thu, 26 Jun 2014 19:51:23 +0800 Subject: [PATCH] A simple DOM tree renderer, using Blaze. --- src/Text/Taggy.hs | 2 ++ src/Text/Taggy/Renderer.hs | 46 ++++++++++++++++++++++++++++++++ taggy.cabal | 4 +++ tests/Text/Taggy/RendererSpec.hs | 17 ++++++++++++ 4 files changed, 69 insertions(+) create mode 100644 src/Text/Taggy/Renderer.hs create mode 100644 tests/Text/Taggy/RendererSpec.hs diff --git a/src/Text/Taggy.hs b/src/Text/Taggy.hs index da0bbce..303990f 100644 --- a/src/Text/Taggy.hs +++ b/src/Text/Taggy.hs @@ -13,6 +13,7 @@ module Text.Taggy , module Text.Taggy.Parser , module Text.Taggy.DOM , module Text.Taggy.Combinators + , module Text.Taggy.Renderer ) where import Data.Text (Text) @@ -20,6 +21,7 @@ import Text.Taggy.Types import Text.Taggy.Parser import Text.Taggy.DOM import Text.Taggy.Combinators +import Text.Taggy.Renderer linksIn :: [Tag] -> [Text] linksIn = map attrValue diff --git a/src/Text/Taggy/Renderer.hs b/src/Text/Taggy/Renderer.hs new file mode 100644 index 0000000..0dd4220 --- /dev/null +++ b/src/Text/Taggy/Renderer.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE LambdaCase, RecordWildCards, FlexibleInstances, UndecidableInstances, OverloadedStrings #-} + +module Text.Taggy.Renderer ( + Renderable(..) +) where + +import Data.Foldable (Foldable(foldMap)) +import Data.HashMap.Strict (HashMap, foldlWithKey') +import Data.Monoid ((<>)) +import Data.Text (Text, unpack) +import Data.Text.Encoding (encodeUtf8) +import Text.Blaze (Markup) +import Text.Blaze.Renderer.Text (renderMarkup) +import Text.Taggy.DOM (Element(..), Node(..)) +import qualified Data.Text.Lazy as Lazy (Text) +import Text.Blaze.Internal (ChoiceString(..), StaticString(..), MarkupM(..)) + +class AsMarkup a where + toMarkup :: a -> Markup + +instance AsMarkup Node where + toMarkup = \case + NodeContent text -> Content $ Text text + NodeElement elmt -> toMarkup elmt + +instance AsMarkup Element where + toMarkup Element{..} = eltAttrs `toAttribute` Parent tag begin end kids + where tag = toStatic eltName + begin = toStatic $ "<" <> eltName + end = toStatic $ " eltName <> ">" + kids = foldMap toMarkup eltChildren + +class Renderable a where + render :: a -> Lazy.Text + +instance AsMarkup a => Renderable a where + render = renderMarkup . toMarkup + +------------------------------------------------------------------------ + +toAttribute :: HashMap Text Text -> (Markup -> Markup) +toAttribute = flip $ foldlWithKey' toAttribute' + where toAttribute' html attr value = AddCustomAttribute (Text attr) (Text value) html + +toStatic :: Text -> StaticString +toStatic text = StaticString (unpack text ++) (encodeUtf8 text) text diff --git a/taggy.cabal b/taggy.cabal index 2459f4e..48a309d 100644 --- a/taggy.cabal +++ b/taggy.cabal @@ -22,6 +22,8 @@ library Text.Taggy.Types other-modules: build-depends: base >=4.5 && <5, + blaze-html, + blaze-markup, text >=1 && <1.2, attoparsec >=0.11 && <0.13, vector >=0.7, @@ -67,6 +69,8 @@ test-suite spec Spec.hs build-depends: base == 4.* + , blaze-html + , blaze-markup , text , hspec , hspec-attoparsec diff --git a/tests/Text/Taggy/RendererSpec.hs b/tests/Text/Taggy/RendererSpec.hs new file mode 100644 index 0000000..e6b60f4 --- /dev/null +++ b/tests/Text/Taggy/RendererSpec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Taggy.RendererSpec where + +import Test.Hspec +import Text.Taggy + +spec :: Spec +spec = do + describe "render" $ do + let doc = "foobaz" + node = head . domify $ taggyWith False doc + elmt = (\(NodeElement e) -> e) $ node + it "Should render a given node." $ do + render node `shouldBe` doc + it "Should render a given element." $ do + render elmt `shouldBe` doc