diff --git a/.gitignore b/.gitignore index 94e70b2..713dd98 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ local cabal.sandbox.config cabal.config +report.html TestSuite.tix .hpc hpc diff --git a/src/Text/Blaze/Renderer/Pretty.hs b/src/Text/Blaze/Renderer/Pretty.hs index b3f79bb..8810b11 100644 --- a/src/Text/Blaze/Renderer/Pretty.hs +++ b/src/Text/Blaze/Renderer/Pretty.hs @@ -13,32 +13,57 @@ import Text.Blaze.Renderer.String (fromChoiceString) renderString :: Markup -- ^ Markup to render -> String -- ^ String to append -> String -- ^ Resulting String -renderString = go 0 id +renderString = go 0 where - go :: Int -> (String -> String) -> MarkupM b -> String -> String - go i attrs (Parent _ open close content) = - ind i . getString open . attrs . (">\n" ++) . go (inc i) id content + go :: Int -> MarkupM b -> String -> String + go i (Parent _ open close content) = + ind i . getString open . (">\n" ++) . go (inc i) content . ind i . getString close . ('\n' :) - go i attrs (CustomParent tag content) = + go i (CustomParent tag content) = + ind i . ('<' :) . fromChoiceString tag . (">\n" ++) . + go (inc i) content . ind i . ("\n" ++) + go i (Leaf _ begin end) = + ind i . getString begin . getString end . ('\n' :) + go i (CustomLeaf tag close) = + ind i . ('<' :) . fromChoiceString tag . + ((if close then " />\n" else ">\n") ++) + go i (AddAttribute _ key value h) = flip (go_attrs i) h $ + getString key . fromChoiceString value . ('"' :) + go i (AddCustomAttribute key value h) = flip (go_attrs i) h $ + (' ' : ) . fromChoiceString key . ("=\"" ++) . fromChoiceString value . + ('"' :) + go i (Content content) = ind i . fromChoiceString content . ('\n' :) + go i (Comment comment) = ind i . + ("\n" ++) + go i (Append h1 h2) = go i h1 . go i h2 + go _ Empty = id + {-# NOINLINE go #-} + + go_attrs :: Int -> (String -> String) -> MarkupM b -> String -> String + go_attrs i attrs (Parent _ open close content) = + ind i . getString open . attrs . (">\n" ++) . go (inc i) content + . ind i . getString close . ('\n' :) + go_attrs i attrs (CustomParent tag content) = ind i . ('<' :) . fromChoiceString tag . attrs . (">\n" ++) . - go (inc i) id content . ind i . ("\n" ++) - go i attrs (Leaf _ begin end) = + go_attrs i attrs (Leaf _ begin end) = ind i . getString begin . attrs . getString end . ('\n' :) - go i attrs (CustomLeaf tag close) = + go_attrs i attrs (CustomLeaf tag close) = ind i . ('<' :) . fromChoiceString tag . attrs . ((if close then " />\n" else ">\n") ++) - go i attrs (AddAttribute _ key value h) = flip (go i) h $ + go_attrs i attrs (AddAttribute _ key value h) = flip (go_attrs i) h $ getString key . fromChoiceString value . ('"' :) . attrs - go i attrs (AddCustomAttribute key value h) = flip (go i) h $ + go_attrs i attrs (AddCustomAttribute key value h) = flip (go_attrs i) h $ (' ' : ) . fromChoiceString key . ("=\"" ++) . fromChoiceString value . ('"' :) . attrs - go i _ (Content content) = ind i . fromChoiceString content . ('\n' :) - go i _ (Comment comment) = ind i . + go_attrs i _ (Content content) = ind i . fromChoiceString content . ('\n' :) + go_attrs i _ (Comment comment) = ind i . ("\n" ++) - go i attrs (Append h1 h2) = go i attrs h1 . go i attrs h2 - go _ _ Empty = id - {-# NOINLINE go #-} + go_attrs i attrs (Append h1 h2) = go_attrs i attrs h1 . go_attrs i attrs h2 + go_attrs _ _ Empty = id + {-# NOINLINE go_attrs #-} -- Increase the indentation inc = (+) 4 diff --git a/src/Text/Blaze/Renderer/String.hs b/src/Text/Blaze/Renderer/String.hs index 83cc672..1f95d3f 100644 --- a/src/Text/Blaze/Renderer/String.hs +++ b/src/Text/Blaze/Renderer/String.hs @@ -59,29 +59,52 @@ fromChoiceString EmptyChoiceString = id renderString :: Markup -- ^ Markup to render -> String -- ^ String to append -> String -- ^ Resulting String -renderString = go id +renderString = go where - go :: (String -> String) -> MarkupM b -> String -> String - go attrs (Parent _ open close content) = - getString open . attrs . ('>' :) . go id content . getString close - go attrs (CustomParent tag content) = - ('<' :) . fromChoiceString tag . attrs . ('>' :) . go id content . + go :: MarkupM b -> String -> String + go (Parent _ open close content) = + getString open . ('>' :) . go content . getString close + go (CustomParent tag content) = + ('<' :) . fromChoiceString tag . ('>' :) . go content . ("' :) - go attrs (Leaf _ begin end) = getString begin . attrs . getString end - go attrs (CustomLeaf tag close) = + go (Leaf _ begin end) = getString begin . getString end + go (CustomLeaf tag close) = + ('<' :) . fromChoiceString tag . + (if close then (" />" ++) else ('>' :)) + go (AddAttribute _ key value h) = flip go_attrs h $ + getString key . fromChoiceString value . ('"' :) + go (AddCustomAttribute key value h) = flip go_attrs h $ + (' ' :) . fromChoiceString key . ("=\"" ++) . fromChoiceString value . + ('"' :) + go (Content content) = fromChoiceString content + go (Comment comment) = + ("" ++) + go (Append h1 h2) = go h1 . go h2 + go Empty = id + {-# NOINLINE go #-} + + go_attrs :: (String -> String) -> MarkupM b -> String -> String + go_attrs attrs (Parent _ open close content) = + getString open . attrs . ('>' :) . go content . getString close + go_attrs attrs (CustomParent tag content) = + ('<' :) . fromChoiceString tag . attrs . ('>' :) . go content . + ("' :) + go_attrs attrs (Leaf _ begin end) = getString begin . attrs . getString end + go_attrs attrs (CustomLeaf tag close) = ('<' :) . fromChoiceString tag . attrs . (if close then (" />" ++) else ('>' :)) - go attrs (AddAttribute _ key value h) = flip go h $ + go_attrs attrs (AddAttribute _ key value h) = flip go_attrs h $ getString key . fromChoiceString value . ('"' :) . attrs - go attrs (AddCustomAttribute key value h) = flip go h $ + go_attrs attrs (AddCustomAttribute key value h) = flip go_attrs h $ (' ' :) . fromChoiceString key . ("=\"" ++) . fromChoiceString value . ('"' :) . attrs - go _ (Content content) = fromChoiceString content - go _ (Comment comment) = + go_attrs _ (Content content) = fromChoiceString content + go_attrs _ (Comment comment) = ("" ++) - go attrs (Append h1 h2) = go attrs h1 . go attrs h2 - go _ Empty = id - {-# NOINLINE go #-} + go_attrs attrs (Append h1 h2) = go_attrs attrs h1 . go_attrs attrs h2 + go_attrs _ Empty = id + {-# NOINLINE go_attrs #-} + {-# INLINE renderString #-} -- | Render markup to a lazy 'String'. diff --git a/src/Text/Blaze/Renderer/Text.hs b/src/Text/Blaze/Renderer/Text.hs index 968795d..eae4302 100644 --- a/src/Text/Blaze/Renderer/Text.hs +++ b/src/Text/Blaze/Renderer/Text.hs @@ -81,53 +81,93 @@ renderHtmlBuilder = renderMarkupBuilder renderMarkupBuilderWith :: (ByteString -> Text) -- ^ Decoder for bytestrings -> Markup -- ^ Markup to render -> Builder -- ^ Resulting builder -renderMarkupBuilderWith d = go mempty +renderMarkupBuilderWith d = go where - go :: Builder -> MarkupM b -> Builder - go attrs (Parent _ open close content) = + go :: MarkupM b -> Builder + go (Parent _ open close content) = + B.fromText (getText open) + `mappend` B.singleton '>' + `mappend` go content + `mappend` B.fromText (getText close) + go (CustomParent tag content) = + B.singleton '<' + `mappend` fromChoiceString d tag + `mappend` B.singleton '>' + `mappend` go content + `mappend` B.fromText "' + go (Leaf _ begin end) = + B.fromText (getText begin) + `mappend` B.fromText (getText end) + go (CustomLeaf tag close) = + B.singleton '<' + `mappend` fromChoiceString d tag + `mappend` (if close then B.fromText " />" else B.singleton '>') + go (AddAttribute _ key value h) = + go_attrs (B.fromText (getText key) + `mappend` fromChoiceString d value + `mappend` B.singleton '"') h + go (AddCustomAttribute key value h) = + go_attrs (B.singleton ' ' + `mappend` fromChoiceString d key + `mappend` B.fromText "=\"" + `mappend` fromChoiceString d value + `mappend` B.singleton '"') h + go (Content content) = fromChoiceString d content + go (Comment comment) = + B.fromText "" + go (Append h1 h2) = go h1 `mappend` go h2 + go Empty = mempty + {-# NOINLINE go #-} + + go_attrs :: Builder -> MarkupM b -> Builder + go_attrs attrs (Parent _ open close content) = B.fromText (getText open) `mappend` attrs `mappend` B.singleton '>' - `mappend` go mempty content + `mappend` go content `mappend` B.fromText (getText close) - go attrs (CustomParent tag content) = + go_attrs attrs (CustomParent tag content) = B.singleton '<' `mappend` fromChoiceString d tag `mappend` attrs `mappend` B.singleton '>' - `mappend` go mempty content + `mappend` go content `mappend` B.fromText "' - go attrs (Leaf _ begin end) = + go_attrs attrs (Leaf _ begin end) = B.fromText (getText begin) `mappend` attrs `mappend` B.fromText (getText end) - go attrs (CustomLeaf tag close) = + go_attrs attrs (CustomLeaf tag close) = B.singleton '<' `mappend` fromChoiceString d tag `mappend` attrs `mappend` (if close then B.fromText " />" else B.singleton '>') - go attrs (AddAttribute _ key value h) = - go (B.fromText (getText key) + go_attrs attrs (AddAttribute _ key value h) = + go_attrs (B.fromText (getText key) `mappend` fromChoiceString d value `mappend` B.singleton '"' `mappend` attrs) h - go attrs (AddCustomAttribute key value h) = - go (B.singleton ' ' + go_attrs attrs (AddCustomAttribute key value h) = + go_attrs (B.singleton ' ' `mappend` fromChoiceString d key `mappend` B.fromText "=\"" `mappend` fromChoiceString d value `mappend` B.singleton '"' `mappend` attrs) h - go _ (Content content) = fromChoiceString d content - go _ (Comment comment) = + go_attrs _ (Content content) = fromChoiceString d content + go_attrs _ (Comment comment) = B.fromText "" - go attrs (Append h1 h2) = go attrs h1 `mappend` go attrs h2 - go _ Empty = mempty - {-# NOINLINE go #-} + go_attrs attrs (Append h1 h2) = go_attrs attrs h1 `mappend` go_attrs attrs h2 + go_attrs _ Empty = mempty + {-# NOINLINE go_attrs #-} {-# INLINE renderMarkupBuilderWith #-} renderHtmlBuilderWith :: (ByteString -> Text) -- ^ Decoder for bytestrings diff --git a/src/Text/Blaze/Renderer/Utf8.hs b/src/Text/Blaze/Renderer/Utf8.hs index 612f69c..4d8c7b0 100644 --- a/src/Text/Blaze/Renderer/Utf8.hs +++ b/src/Text/Blaze/Renderer/Utf8.hs @@ -47,53 +47,93 @@ fromChoiceString EmptyChoiceString = mempty -- renderMarkupBuilder, renderHtmlBuilder :: Markup -- ^ Markup to render -> Builder -- ^ Resulting builder -renderMarkupBuilder = go mempty +renderMarkupBuilder = go where - go :: Builder -> MarkupM b -> Builder - go attrs (Parent _ open close content) = + go :: MarkupM b -> Builder + go (Parent _ open close content) = + B.copyByteString (getUtf8ByteString open) + `mappend` B.fromChar '>' + `mappend` go content + `mappend` B.copyByteString (getUtf8ByteString close) + go (CustomParent tag content) = + B.fromChar '<' + `mappend` fromChoiceString tag + `mappend` B.fromChar '>' + `mappend` go content + `mappend` B.fromByteString "' + go (Leaf _ begin end) = + B.copyByteString (getUtf8ByteString begin) + `mappend` B.copyByteString (getUtf8ByteString end) + go (CustomLeaf tag close) = + B.fromChar '<' + `mappend` fromChoiceString tag + `mappend` (if close then B.fromByteString " />" else B.fromChar '>') + go (AddAttribute _ key value h) = + go_attrs (B.copyByteString (getUtf8ByteString key) + `mappend` fromChoiceString value + `mappend` B.fromChar '"') h + go (AddCustomAttribute key value h) = + go_attrs (B.fromChar ' ' + `mappend` fromChoiceString key + `mappend` B.fromByteString "=\"" + `mappend` fromChoiceString value + `mappend` B.fromChar '"') h + go (Content content) = fromChoiceString content + go (Comment comment) = + B.fromByteString "" + go (Append h1 h2) = go h1 `mappend` go h2 + go Empty = mempty + {-# NOINLINE go #-} + + go_attrs :: Builder -> MarkupM b -> Builder + go_attrs attrs (Parent _ open close content) = B.copyByteString (getUtf8ByteString open) `mappend` attrs `mappend` B.fromChar '>' - `mappend` go mempty content + `mappend` go content `mappend` B.copyByteString (getUtf8ByteString close) - go attrs (CustomParent tag content) = + go_attrs attrs (CustomParent tag content) = B.fromChar '<' `mappend` fromChoiceString tag `mappend` attrs `mappend` B.fromChar '>' - `mappend` go mempty content + `mappend` go content `mappend` B.fromByteString "' - go attrs (Leaf _ begin end) = + go_attrs attrs (Leaf _ begin end) = B.copyByteString (getUtf8ByteString begin) `mappend` attrs `mappend` B.copyByteString (getUtf8ByteString end) - go attrs (CustomLeaf tag close) = + go_attrs attrs (CustomLeaf tag close) = B.fromChar '<' `mappend` fromChoiceString tag `mappend` attrs `mappend` (if close then B.fromByteString " />" else B.fromChar '>') - go attrs (AddAttribute _ key value h) = - go (B.copyByteString (getUtf8ByteString key) + go_attrs attrs (AddAttribute _ key value h) = + go_attrs (B.copyByteString (getUtf8ByteString key) `mappend` fromChoiceString value `mappend` B.fromChar '"' `mappend` attrs) h - go attrs (AddCustomAttribute key value h) = - go (B.fromChar ' ' + go_attrs attrs (AddCustomAttribute key value h) = + go_attrs (B.fromChar ' ' `mappend` fromChoiceString key `mappend` B.fromByteString "=\"" `mappend` fromChoiceString value `mappend` B.fromChar '"' `mappend` attrs) h - go _ (Content content) = fromChoiceString content - go _ (Comment comment) = + go_attrs _ (Content content) = fromChoiceString content + go_attrs _ (Comment comment) = B.fromByteString "" - go attrs (Append h1 h2) = go attrs h1 `mappend` go attrs h2 - go _ Empty = mempty - {-# NOINLINE go #-} + go_attrs attrs (Append h1 h2) = go_attrs attrs h1 `mappend` go_attrs attrs h2 + go_attrs _ Empty = mempty + {-# NOINLINE go_attrs #-} {-# INLINE renderMarkupBuilder #-} renderHtmlBuilder = renderMarkupBuilder