{-# 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 @\<br\>@ tags is due to Internet Explorer treating
--   @\<br\>\<\/br\>@ as @\<br\>\<br\>@.
data RenderOptions str = RenderOptions
    {forall str. RenderOptions str -> str -> str
optEscape :: str -> str        -- ^ Escape a piece of text (default = escape the four characters @&\"\<\>@)
    ,forall str. RenderOptions str -> str -> Bool
optMinimize :: str -> Bool     -- ^ Minimise \<b\>\<\/b\> -> \<b/\> (default = minimise only @\<br\>@ tags)
    ,forall str. RenderOptions str -> str -> Bool
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 :: forall str. StringLike str => str -> str
escapeHTML = String -> str
forall a. IsString a => String -> a
fromString (String -> str) -> (str -> String) -> str -> str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
escapeXML (String -> String) -> (str -> String) -> str -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. str -> String
forall a. StringLike a => a -> String
toString

-- | The default render options value, described in 'RenderOptions'.
renderOptions :: StringLike str => RenderOptions str
renderOptions :: forall str. StringLike str => RenderOptions str
renderOptions = (str -> str) -> (str -> Bool) -> (str -> Bool) -> RenderOptions str
forall str.
(str -> str) -> (str -> Bool) -> (str -> Bool) -> RenderOptions str
RenderOptions str -> str
forall str. StringLike str => str -> str
escapeHTML (\str
x -> str -> String
forall a. StringLike a => a -> String
toString str
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"br") (\str
x -> str -> String
forall a. StringLike a => a -> String
toString str
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"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"] == "<hello>my&amp;</world>"
renderTags :: StringLike str => [Tag str] -> str
renderTags :: forall str. StringLike str => [Tag str] -> str
renderTags = RenderOptions str -> [Tag str] -> str
forall str. StringLike str => RenderOptions str -> [Tag str] -> str
renderTagsOptions RenderOptions str
forall str. StringLike str => RenderOptions str
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 :: forall str. StringLike str => RenderOptions str -> [Tag str] -> str
renderTagsOptions RenderOptions str
opts = [str] -> str
forall a. StringLike a => [a] -> a
strConcat ([str] -> str) -> ([Tag str] -> [str]) -> [Tag str] -> str
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tag str] -> [str]
tags
    where
        ss :: a -> [a]
ss a
x = [a
x]

        tags :: [Tag str] -> [str]
tags (TagOpen str
name [Attribute str]
atts:TagClose str
name2:[Tag str]
xs)
            | str
name str -> str -> Bool
forall a. Eq a => a -> a -> Bool
== str
name2 Bool -> Bool -> Bool
&& RenderOptions str -> str -> Bool
forall str. RenderOptions str -> str -> Bool
optMinimize RenderOptions str
opts str
name = str -> [Attribute str] -> str -> [str]
forall {t :: * -> *}.
Foldable t =>
str -> t (Attribute str) -> str -> [str]
open str
name [Attribute str]
atts str
" /" [str] -> [str] -> [str]
forall a. [a] -> [a] -> [a]
++ [Tag str] -> [str]
tags [Tag str]
xs
        tags (TagOpen str
name [Attribute str]
atts:[Tag str]
xs)
            | Just (Char
'?',str
_) <- str -> Maybe (Char, str)
forall a. StringLike a => a -> Maybe (Char, a)
uncons str
name = str -> [Attribute str] -> str -> [str]
forall {t :: * -> *}.
Foldable t =>
str -> t (Attribute str) -> str -> [str]
open str
name [Attribute str]
atts str
" ?" [str] -> [str] -> [str]
forall a. [a] -> [a] -> [a]
++ [Tag str] -> [str]
tags [Tag str]
xs
            | RenderOptions str -> str -> Bool
forall str. RenderOptions str -> str -> Bool
optRawTag RenderOptions str
opts str
name =
                let ([Tag str]
a,[Tag str]
b) = (Tag str -> Bool) -> [Tag str] -> ([Tag str], [Tag str])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Tag str -> Tag str -> Bool
forall a. Eq a => a -> a -> Bool
== str -> Tag str
forall str. str -> Tag str
TagClose str
name) (str -> [Attribute str] -> Tag str
forall str. str -> [Attribute str] -> Tag str
TagOpen str
name [Attribute str]
attsTag str -> [Tag str] -> [Tag str]
forall a. a -> [a] -> [a]
:[Tag str]
xs)
                in (Tag str -> [str]) -> [Tag str] -> [str]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Tag str
x -> case Tag str
x of TagText str
s -> [str
s]; Tag str
_ -> Tag str -> [str]
tag Tag str
x) [Tag str]
a [str] -> [str] -> [str]
forall a. [a] -> [a] -> [a]
++ [Tag str] -> [str]
tags [Tag str]
b
        tags (Tag str
x:[Tag str]
xs) = Tag str -> [str]
tag Tag str
x [str] -> [str] -> [str]
forall a. [a] -> [a] -> [a]
++ [Tag str] -> [str]
tags [Tag str]
xs
        tags [] = []

        tag :: Tag str -> [str]
tag (TagOpen str
name [Attribute str]
atts) = str -> [Attribute str] -> str -> [str]
forall {t :: * -> *}.
Foldable t =>
str -> t (Attribute str) -> str -> [str]
open str
name [Attribute str]
atts str
""
        tag (TagClose str
name) = [str
"</", str
name, str
">"]
        tag (TagText str
text) = [str -> str
txt str
text]
        tag (TagComment str
text) = str -> [str]
forall {a}. a -> [a]
ss str
"<!--" [str] -> [str] -> [str]
forall a. [a] -> [a] -> [a]
++ str -> [str]
forall {a} {a}. (StringLike a, StringLike a) => a -> [a]
com str
text [str] -> [str] -> [str]
forall a. [a] -> [a] -> [a]
++ str -> [str]
forall {a}. a -> [a]
ss str
"-->"
        tag Tag str
_ = str -> [str]
forall {a}. a -> [a]
ss str
""

        txt :: str -> str
txt = RenderOptions str -> str -> str
forall str. RenderOptions str -> str -> str
optEscape RenderOptions str
opts
        open :: str -> t (Attribute str) -> str -> [str]
open str
name t (Attribute str)
atts str
shut = [str
"<",str
name] [str] -> [str] -> [str]
forall a. [a] -> [a] -> [a]
++ (Attribute str -> [str]) -> t (Attribute str) -> [str]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Attribute str -> [str]
att t (Attribute str)
atts [str] -> [str] -> [str]
forall a. [a] -> [a] -> [a]
++ [str
shut,str
">"]
        att :: Attribute str -> [str]
att (str
"",str
"") = [str
" \"\""]
        att (str
x ,str
"") = [str
" ", str
x]
        att (str
"", str
y) = [str
" \"",str -> str
txt str
y,str
"\""]
        att (str
x , str
y) = [str
" ",str
x,str
"=\"",str -> str
txt str
y,str
"\""]

        com :: a -> [a]
com a
xs | Just (Char
'-',a
xs) <- a -> Maybe (Char, a)
forall a. StringLike a => a -> Maybe (Char, a)
uncons a
xs, Just (Char
'-',a
xs) <- a -> Maybe (Char, a)
forall a. StringLike a => a -> Maybe (Char, a)
uncons a
xs, Just (Char
'>',a
xs) <- a -> Maybe (Char, a)
forall a. StringLike a => a -> Maybe (Char, a)
uncons a
xs = a
"-- >" a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
com a
xs
        com a
xs = case a -> Maybe (Char, a)
forall a. StringLike a => a -> Maybe (Char, a)
uncons a
xs of
            Maybe (Char, a)
Nothing -> []
            Just (Char
x,a
xs) -> Char -> a
forall a. StringLike a => Char -> a
fromChar Char
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
com a
xs