1{-# LANGUAGE PatternGuards, OverloadedStrings #-}
2{-|
3    This module converts a list of 'Tag' back into a string.
4-}
5
6module Text.HTML.TagSoup.Render
7    (
8    renderTags, renderTagsOptions, escapeHTML,
9    RenderOptions(..), renderOptions
10    ) where
11
12import Text.HTML.TagSoup.Entity
13import Text.HTML.TagSoup.Type
14import Text.StringLike
15
16
17-- | These options control how 'renderTags' works.
18--
19--   The strange quirk of only minimizing @\<br\>@ tags is due to Internet Explorer treating
20--   @\<br\>\<\/br\>@ as @\<br\>\<br\>@.
21data RenderOptions str = RenderOptions
22    {optEscape :: str -> str        -- ^ Escape a piece of text (default = escape the four characters @&\"\<\>@)
23    ,optMinimize :: str -> Bool     -- ^ Minimise \<b\>\<\/b\> -> \<b/\> (default = minimise only @\<br\>@ tags)
24    ,optRawTag :: str -> Bool      -- ^ Should a tag be output with no escaping (default = true only for @script@)
25    }
26
27
28-- | Replace the four characters @&\"\<\>@ with their HTML entities ('escapeXML' lifted to 'StringLike').
29escapeHTML :: StringLike str => str -> str
30escapeHTML = fromString . escapeXML . toString
31
32-- | The default render options value, described in 'RenderOptions'.
33renderOptions :: StringLike str => RenderOptions str
34renderOptions = RenderOptions escapeHTML (\x -> toString x == "br") (\x -> toString x == "script")
35
36
37-- | Show a list of tags, as they might have been parsed, using the default settings given in
38--   'RenderOptions'.
39--
40-- > renderTags [TagOpen "hello" [],TagText "my&",TagClose "world"] == "<hello>my&amp;</world>"
41renderTags :: StringLike str => [Tag str] -> str
42renderTags = renderTagsOptions renderOptions
43
44
45-- | Show a list of tags using settings supplied by the 'RenderOptions' parameter,
46--   eg. to avoid escaping any characters one could do:
47--
48-- > renderTagsOptions renderOptions{optEscape = id} [TagText "my&"] == "my&"
49renderTagsOptions :: StringLike str => RenderOptions str -> [Tag str] -> str
50renderTagsOptions opts = strConcat . tags
51    where
52        ss x = [x]
53
54        tags (TagOpen name atts:TagClose name2:xs)
55            | name == name2 && optMinimize opts name = open name atts " /" ++ tags xs
56        tags (TagOpen name atts:xs)
57            | Just ('?',_) <- uncons name = open name atts " ?" ++ tags xs
58            | optRawTag opts name =
59                let (a,b) = break (== TagClose name) (TagOpen name atts:xs)
60                in concatMap (\x -> case x of TagText s -> [s]; _ -> tag x) a ++ tags b
61        tags (x:xs) = tag x ++ tags xs
62        tags [] = []
63
64        tag (TagOpen name atts) = open name atts ""
65        tag (TagClose name) = ["</", name, ">"]
66        tag (TagText text) = [txt text]
67        tag (TagComment text) = ss "<!--" ++ com text ++ ss "-->"
68        tag _ = ss ""
69
70        txt = optEscape opts
71        open name atts shut = ["<",name] ++ concatMap att atts ++ [shut,">"]
72        att ("","") = [" \"\""]
73        att (x ,"") = [" ", x]
74        att ("", y) = [" \"",txt y,"\""]
75        att (x , y) = [" ",x,"=\"",txt y,"\""]
76
77        com xs | Just ('-',xs) <- uncons xs, Just ('-',xs) <- uncons xs, Just ('>',xs) <- uncons xs = "-- >" : com xs
78        com xs = case uncons xs of
79            Nothing -> []
80            Just (x,xs) -> fromChar x : com xs
81