{-# LANGUAGE PatternGuards, OverloadedStrings #-}
{-|
This module converts a list of 'Tag' back into a string.
-}
module Text.HTML.TagSoup.Render
(
renderTags, renderTagsOptions, escapeHTML,
RenderOptions(..), renderOptions
) where
import Text.HTML.TagSoup.Entity
import Text.HTML.TagSoup.Type
import Text.StringLike
-- | These options control how 'renderTags' works.
--
-- The strange quirk of only minimizing @\
@ tags is due to Internet Explorer treating
-- @\
\<\/br\>@ as @\
\
@.
data RenderOptions str = RenderOptions
{optEscape :: str -> str -- ^ Escape a piece of text (default = escape the four characters @&\"\<\>@)
,optMinimize :: str -> Bool -- ^ Minimise \\<\/b\> -> \ (default = minimise only @\
@ tags)
,optRawTag :: str -> Bool -- ^ Should a tag be output with no escaping (default = true only for @script@)
}
-- | Replace the four characters @&\"\<\>@ with their HTML entities ('escapeXML' lifted to 'StringLike').
escapeHTML :: StringLike str => str -> str
escapeHTML = fromString . escapeXML . toString
-- | The default render options value, described in 'RenderOptions'.
renderOptions :: StringLike str => RenderOptions str
renderOptions = RenderOptions escapeHTML (\x -> toString x == "br") (\x -> toString x == "script")
-- | Show a list of tags, as they might have been parsed, using the default settings given in
-- 'RenderOptions'.
--
-- > renderTags [TagOpen "hello" [],TagText "my&",TagClose "world"] == "my&"
renderTags :: StringLike str => [Tag str] -> str
renderTags = renderTagsOptions renderOptions
-- | Show a list of tags using settings supplied by the 'RenderOptions' parameter,
-- eg. to avoid escaping any characters one could do:
--
-- > renderTagsOptions renderOptions{optEscape = id} [TagText "my&"] == "my&"
renderTagsOptions :: StringLike str => RenderOptions str -> [Tag str] -> str
renderTagsOptions opts = strConcat . tags
where
ss x = [x]
tags (TagOpen name atts:TagClose name2:xs)
| name == name2 && optMinimize opts name = open name atts " /" ++ tags xs
tags (TagOpen name atts:xs)
| Just ('?',_) <- uncons name = open name atts " ?" ++ tags xs
| optRawTag opts name =
let (a,b) = break (== TagClose name) (TagOpen name atts:xs)
in concatMap (\x -> case x of TagText s -> [s]; _ -> tag x) a ++ tags b
tags (x:xs) = tag x ++ tags xs
tags [] = []
tag (TagOpen name atts) = open name atts ""
tag (TagClose name) = ["", name, ">"]
tag (TagText text) = [txt text]
tag (TagComment text) = ss ""
tag _ = ss ""
txt = optEscape opts
open name atts shut = ["<",name] ++ concatMap att atts ++ [shut,">"]
att ("","") = [" \"\""]
att (x ,"") = [" ", x]
att ("", y) = [" \"",txt y,"\""]
att (x , y) = [" ",x,"=\"",txt y,"\""]
com xs | Just ('-',xs) <- uncons xs, Just ('-',xs) <- uncons xs, Just ('>',xs) <- uncons xs = "-- >" : com xs
com xs = case uncons xs of
Nothing -> []
Just (x,xs) -> fromChar x : com xs