{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards     #-}

module Text.XmlHtml.HTML.Render where

import           Blaze.ByteString.Builder
import           Control.Applicative
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as S
import           Data.Maybe
import qualified Text.Parsec as P
import           Text.XmlHtml.Common
import           Text.XmlHtml.TextParser
import           Text.XmlHtml.HTML.Meta
import qualified Text.XmlHtml.HTML.Parse as P
import qualified Text.XmlHtml.XML.Parse as XML
import           Text.XmlHtml.XML.Render (docTypeDecl, entity)

import           Data.Text (Text)
import qualified Data.Text as T


#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid
#endif

------------------------------------------------------------------------------
-- | And, the rendering code.
renderWithOptions :: RenderOptions -> Encoding -> Maybe DocType -> [Node] -> Builder
renderWithOptions :: RenderOptions -> Encoding -> Maybe DocType -> [Node] -> Builder
renderWithOptions RenderOptions
opts Encoding
e Maybe DocType
dt [Node]
ns = Builder
byteOrder
       forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Maybe DocType -> Builder
docTypeDecl Encoding
e Maybe DocType
dt
       forall a. Monoid a => a -> a -> a
`mappend` Builder
nodes
    where byteOrder :: Builder
byteOrder | Encoding -> Bool
isUTF16 Encoding
e = Encoding -> Text -> Builder
fromText Encoding
e Text
"\xFEFF" -- byte order mark
                    | Bool
otherwise = forall a. Monoid a => a
mempty
          nodes :: Builder
nodes | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
ns   = forall a. Monoid a => a
mempty
                | Bool
otherwise = RenderOptions -> Encoding -> Node -> Builder
firstNode RenderOptions
opts Encoding
e (forall a. [a] -> a
head [Node]
ns)
                    forall a. Monoid a => a -> a -> a
`mappend` (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e) (forall a. [a] -> [a]
tail [Node]
ns))


------------------------------------------------------------------------------
render :: Encoding -> Maybe DocType -> [Node] -> Builder
render :: Encoding -> Maybe DocType -> [Node] -> Builder
render = RenderOptions -> Encoding -> Maybe DocType -> [Node] -> Builder
renderWithOptions RenderOptions
defaultRenderOptions


------------------------------------------------------------------------------
-- | Function for rendering HTML nodes without the overhead of creating a
-- Document structure.
renderHtmlFragmentWithOptions :: RenderOptions -> Encoding -> [Node] -> Builder
renderHtmlFragmentWithOptions :: RenderOptions -> Encoding -> [Node] -> Builder
renderHtmlFragmentWithOptions RenderOptions
_ Encoding
_ []     = forall a. Monoid a => a
mempty
renderHtmlFragmentWithOptions RenderOptions
opts Encoding
e (Node
n:[Node]
ns) =
    RenderOptions -> Encoding -> Node -> Builder
firstNode RenderOptions
opts Encoding
e Node
n forall a. Monoid a => a -> a -> a
`mappend` (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e) [Node]
ns)


------------------------------------------------------------------------------
-- | Function for rendering HTML nodes without the overhead of creating a
-- Document structure, using default rendering options
renderHtmlFragment :: Encoding -> [Node] -> Builder
renderHtmlFragment :: Encoding -> [Node] -> Builder
renderHtmlFragment = RenderOptions -> Encoding -> [Node] -> Builder
renderHtmlFragmentWithOptions RenderOptions
defaultRenderOptions


------------------------------------------------------------------------------
-- | HTML allows & so long as it is not "ambiguous" (i.e., looks like an
-- entity).  So we have a special case for that.
escaped :: [Char] -> Encoding -> Text -> Builder
escaped :: [Char] -> Encoding -> Text -> Builder
escaped [Char]
_   Encoding
_ Text
"" = forall a. Monoid a => a
mempty
escaped [Char]
bad Encoding
e Text
t  =
    let (Text
p,Text
s) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
bad) Text
t
        r :: Maybe (Char, Text)
r     = Text -> Maybe (Char, Text)
T.uncons Text
s
    in  Encoding -> Text -> Builder
fromText Encoding
e Text
p forall a. Monoid a => a -> a -> a
`mappend` case Maybe (Char, Text)
r of
            Maybe (Char, Text)
Nothing
                -> forall a. Monoid a => a
mempty
            Just (Char
'&',Text
ss) | forall {a} {b}. Either a b -> Bool
isLeft (forall a. Parser a -> [Char] -> Text -> Either [Char] a
parseText ParsecT Text () Identity ()
ambigAmp [Char]
"" Text
s)
                -> Encoding -> Text -> Builder
fromText Encoding
e Text
"&" forall a. Monoid a => a -> a -> a
`mappend` [Char] -> Encoding -> Text -> Builder
escaped [Char]
bad Encoding
e Text
ss
            Just (Char
c,Text
ss)
                -> Encoding -> Char -> Builder
entity Encoding
e Char
c forall a. Monoid a => a -> a -> a
`mappend` [Char] -> Encoding -> Text -> Builder
escaped [Char]
bad Encoding
e Text
ss
  where isLeft :: Either a b -> Bool
isLeft   = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Bool
True) (forall a b. a -> b -> a
const Bool
False)
        ambigAmp :: ParsecT Text () Identity ()
ambigAmp = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'&' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
            (Parser Char
P.finishCharRef forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return () forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
XML.name forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Monad m => a -> m a
return ())


------------------------------------------------------------------------------
node :: RenderOptions -> Encoding -> Node -> Builder
node :: RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
_ Encoding
e (TextNode Text
t)                        = [Char] -> Encoding -> Text -> Builder
escaped [Char]
"<>&" Encoding
e Text
t
node RenderOptions
_ Encoding
e (Comment Text
t) | Text
"--" Text -> Text -> Bool
`T.isInfixOf`  Text
t = forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid comment"
                     | Text
"-"  Text -> Text -> Bool
`T.isSuffixOf` Text
t = forall a. HasCallStack => [Char] -> a
error [Char]
"Invalid comment"
                     | Bool
otherwise             = Encoding -> Text -> Builder
fromText Encoding
e Text
"<!--"
                                               forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
                                               forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
"-->"
node RenderOptions
opts Encoding
e (Element Text
t [(Text, Text)]
a [Node]
c)                     =
    let tbase :: Text
tbase = Text -> Text
T.toLower forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd Text
":" Text
t
    in  RenderOptions
-> Encoding -> Text -> Text -> [(Text, Text)] -> [Node] -> Builder
element RenderOptions
opts Encoding
e Text
t Text
tbase [(Text, Text)]
a [Node]
c


------------------------------------------------------------------------------
-- | Process the first node differently to encode leading whitespace.  This
-- lets us be sure that @parseHTML@ is a left inverse to @render@.
firstNode :: RenderOptions -> Encoding -> Node -> Builder
firstNode :: RenderOptions -> Encoding -> Node -> Builder
firstNode RenderOptions
opts Encoding
e (Comment Text
t)     = RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e (Text -> Node
Comment Text
t)
firstNode RenderOptions
opts Encoding
e (Element Text
t [(Text, Text)]
a [Node]
c) = RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e (Text -> [(Text, Text)] -> [Node] -> Node
Element Text
t [(Text, Text)]
a [Node]
c)
firstNode RenderOptions
_    Encoding
_ (TextNode Text
"")   = forall a. Monoid a => a
mempty
firstNode RenderOptions
opts Encoding
e (TextNode Text
t)    = let (Char
c,Text
t') = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
T.uncons Text
t
                                   in [Char] -> Encoding -> Text -> Builder
escaped [Char]
"<>& \t\r" Encoding
e (Char -> Text
T.singleton Char
c)
                                      forall a. Monoid a => a -> a -> a
`mappend` RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e (Text -> Node
TextNode Text
t')


------------------------------------------------------------------------------
-- XXX: Should do something to avoid concatting large CDATA sections before
-- writing them to the output.
element :: RenderOptions -> Encoding -> Text -> Text -> [(Text, Text)] -> [Node] -> Builder
element :: RenderOptions
-> Encoding -> Text -> Text -> [(Text, Text)] -> [Node] -> Builder
element RenderOptions
opts Encoding
e Text
t Text
tb [(Text, Text)]
a [Node]
c
    | Text
tb forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet Text
voidTags Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
c         =
        Encoding -> Text -> Builder
fromText Encoding
e Text
"<"
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
        forall a. Monoid a => a -> a -> a
`mappend` (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder
attribute RenderOptions
opts Encoding
e Text
tb) [(Text, Text)]
a)
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
" />"
    | Text
tb forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet Text
voidTags                   =
        forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t forall a. [a] -> [a] -> [a]
++ [Char]
" must be empty"
    | Text -> [(Text, Text)] -> Bool
isRawText Text
tb [(Text, Text)]
a,
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Node -> Bool
isTextNode [Node]
c,
      let s :: Text
s = [Text] -> Text
T.concat (forall a b. (a -> b) -> [a] -> [b]
map Node -> Text
nodeText [Node]
c),
      Bool -> Bool
not (Text
"</" Text -> Text -> Text
`T.append` Text
t Text -> Text -> Bool
`T.isInfixOf` Text
s) =
        Encoding -> Text -> Builder
fromText Encoding
e Text
"<"
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
        forall a. Monoid a => a -> a -> a
`mappend` (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder
attribute RenderOptions
opts Encoding
e Text
tb) [(Text, Text)]
a)
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
">"
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
s
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
"</"
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
">"
    | Text -> [(Text, Text)] -> Bool
isRawText Text
tb [(Text, Text)]
a,
      [ TextNode Text
_ ] <- [Node]
c                     =
        forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t forall a. [a] -> [a] -> [a]
++ [Char]
" cannot contain text looking like its end tag"
    | Text -> [(Text, Text)] -> Bool
isRawText Text
tb [(Text, Text)]
a                           =
        forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t forall a. [a] -> [a] -> [a]
++ [Char]
" cannot contain child elements or comments"
    | Bool
otherwise =
        Encoding -> Text -> Builder
fromText Encoding
e Text
"<"
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
        forall a. Monoid a => a -> a -> a
`mappend` (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder
attribute RenderOptions
opts Encoding
e Text
tb) [(Text, Text)]
a)
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
">"
        forall a. Monoid a => a -> a -> a
`mappend` (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e) [Node]
c)
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
"</"
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
">"

------------------------------------------------------------------------------
attribute :: RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder
attribute :: RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder
attribute RenderOptions
opts Encoding
e Text
tb (Text
n,Text
v)
    | Text
v forall a. Eq a => a -> a -> Bool
== Text
"" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
explicit =
        Encoding -> Text -> Builder
fromText Encoding
e Text
" "
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
n
    | RenderOptions -> AttrResolveInternalQuotes
roAttributeResolveInternal RenderOptions
opts forall a. Eq a => a -> a -> Bool
== AttrResolveInternalQuotes
AttrResolveAvoidEscape
      Bool -> Bool -> Bool
&& Text
surround Text -> Text -> Bool
`T.isInfixOf` Text
v
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Text
alternative Text -> Text -> Bool
`T.isInfixOf` Text
v) =
        Encoding -> Text -> Builder
fromText Encoding
e Text
" "
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
n
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e (Char
'=' Char -> Text -> Text
`T.cons` Text
alternative)
        forall a. Monoid a => a -> a -> a
`mappend` [Char] -> Encoding -> Text -> Builder
escaped [Char]
"&" Encoding
e Text
v
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
alternative
    | Bool
otherwise =
        Encoding -> Text -> Builder
fromText Encoding
e Text
" "
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
n
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e (Char
'=' Char -> Text -> Text
`T.cons` Text
surround)
        forall a. Monoid a => a -> a -> a
`mappend` (Text -> Text) -> Builder -> Builder
bmap (Text -> Text -> Text -> Text
T.replace Text
surround Text
ent) ([Char] -> Encoding -> Text -> Builder
escaped [Char]
"&" Encoding
e Text
v)
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
surround
  where
    (Text
surround, Text
alternative, Text
ent) = case RenderOptions -> AttrSurround
roAttributeSurround RenderOptions
opts of
        AttrSurround
SurroundSingleQuote -> (Text
"'" , Text
"\"", Text
"&apos;")
        AttrSurround
SurroundDoubleQuote -> (Text
"\"", Text
"'" , Text
"&quot;")
    nbase :: Text
nbase    = Text -> Text
T.toLower forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd Text
":" Text
n
    explicit :: Bool
explicit = forall b a. b -> (a -> b) -> Maybe a -> b
maybe
               Bool
True
               -- Nothing 'explicitEmptyAttributes' means: attach '=""' to all
               -- empty attributes
               (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member Text
nbase) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
tb)
               -- (Just m) means: attach '=""' only when tag and attr name
               -- are in the explicit-empty-attrs map 'm'
               (RenderOptions -> Maybe (HashMap Text (HashSet Text))
roExplicitEmptyAttrs RenderOptions
opts)