{-# 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
    {RenderOptions str -> str -> str
optEscape :: str -> str        -- ^ Escape a piece of text (default = escape the four characters @&\"\<\>@)
    ,RenderOptions str -> str -> Bool
optMinimize :: str -> Bool     -- ^ Minimise \<b\>\<\/b\> -> \<b/\> (default = minimise only @\<br\>@ tags)
    ,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 :: 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 :: 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 (\x :: str
x -> str -> String
forall a. StringLike a => a -> String
toString str
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "br") (\x :: str
x -> str -> String
forall a. StringLike a => a -> String
toString str
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "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 :: [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 :: RenderOptions str -> [Tag str] -> str
renderTagsOptions opts :: 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 x :: a
x = [a
x]

        tags :: [Tag str] -> [str]
tags (TagOpen name :: str
name atts :: [Attribute str]
atts:TagClose name2 :: str
name2:xs :: [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]
forall a. [a] -> [a] -> [a]
++ [Tag str] -> [str]
tags [Tag str]
xs
        tags (TagOpen name :: str
name atts :: [Attribute str]
atts:xs :: [Tag str]
xs)
            | Just ('?',_) <- 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]
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 (a :: [Tag str]
a,b :: [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 (\x :: Tag str
x -> case Tag str
x of TagText s :: str
s -> [str
s]; _ -> 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 (x :: Tag str
x:xs :: [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 name :: str
name atts :: [Attribute str]
atts) = str -> [Attribute str] -> str -> [str]
forall (t :: * -> *).
Foldable t =>
str -> t (Attribute str) -> str -> [str]
open str
name [Attribute str]
atts ""
        tag (TagClose name :: str
name) = ["</", str
name, ">"]
        tag (TagText text :: str
text) = [str -> str
txt str
text]
        tag (TagComment text :: str
text) = str -> [str]
forall a. a -> [a]
ss "<!--" [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 "-->"
        tag _ = str -> [str]
forall a. a -> [a]
ss ""

        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 name :: str
name atts :: t (Attribute str)
atts shut :: str
shut = ["<",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,">"]
        att :: Attribute str -> [str]
att ("","") = [" \"\""]
        att (x :: str
x ,"") = [" ", str
x]
        att ("", y :: str
y) = [" \"",str -> str
txt str
y,"\""]
        att (x :: str
x , y :: str
y) = [" ",str
x,"=\"",str -> str
txt str
y,"\""]

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