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&</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