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

module Text.XmlHtml.XML.Render where

import           Blaze.ByteString.Builder
import           Data.Char
import           Data.Maybe
import           Text.XmlHtml.Common

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

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


------------------------------------------------------------------------------
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 -> Builder
xmlDecl Encoding
e
       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 XML nodes without the overhead of creating a
-- Document structure.
renderXmlFragmentWithOptions :: RenderOptions -> Encoding -> [Node] -> Builder
renderXmlFragmentWithOptions :: RenderOptions -> Encoding -> [Node] -> Builder
renderXmlFragmentWithOptions RenderOptions
_    Encoding
_ []     = forall a. Monoid a => a
mempty
renderXmlFragmentWithOptions 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)

renderXmlFragment :: Encoding -> [Node] -> Builder
renderXmlFragment :: Encoding -> [Node] -> Builder
renderXmlFragment = RenderOptions -> Encoding -> [Node] -> Builder
renderXmlFragmentWithOptions RenderOptions
defaultRenderOptions

------------------------------------------------------------------------------
xmlDecl :: Encoding -> Builder
xmlDecl :: Encoding -> Builder
xmlDecl Encoding
e = Encoding -> Text -> Builder
fromText Encoding
e Text
"<?xml version=\"1.0\" encoding=\""
            forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e (Encoding -> Text
encodingName Encoding
e)
            forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
"\"?>\n"


------------------------------------------------------------------------------
docTypeDecl :: Encoding -> Maybe DocType -> Builder
docTypeDecl :: Encoding -> Maybe DocType -> Builder
docTypeDecl Encoding
_ Maybe DocType
Nothing                      = forall a. Monoid a => a
mempty
docTypeDecl Encoding
e (Just (DocType Text
tag ExternalID
ext InternalSubset
int)) = Encoding -> Text -> Builder
fromText Encoding
e Text
"<!DOCTYPE "
                                   forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
tag
                                   forall a. Monoid a => a -> a -> a
`mappend` Encoding -> ExternalID -> Builder
externalID Encoding
e ExternalID
ext
                                   forall a. Monoid a => a -> a -> a
`mappend` Encoding -> InternalSubset -> Builder
internalSubset Encoding
e InternalSubset
int
                                   forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
">\n"


------------------------------------------------------------------------------
externalID :: Encoding -> ExternalID -> Builder
externalID :: Encoding -> ExternalID -> Builder
externalID Encoding
_ ExternalID
NoExternalID     = forall a. Monoid a => a
mempty
externalID Encoding
e (System Text
sid)     = Encoding -> Text -> Builder
fromText Encoding
e Text
" SYSTEM "
                                forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
sysID Encoding
e Text
sid
externalID Encoding
e (Public Text
pid Text
sid) = Encoding -> Text -> Builder
fromText Encoding
e Text
" PUBLIC "
                                forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
pubID Encoding
e Text
pid
                                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
sysID Encoding
e Text
sid


------------------------------------------------------------------------------
internalSubset :: Encoding -> InternalSubset -> Builder
internalSubset :: Encoding -> InternalSubset -> Builder
internalSubset Encoding
_ InternalSubset
NoInternalSubset = forall a. Monoid a => a
mempty
internalSubset Encoding
e (InternalText Text
t) = Encoding -> Text -> Builder
fromText Encoding
e Text
" " forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t


------------------------------------------------------------------------------
sysID :: Encoding -> Text -> Builder
sysID :: Encoding -> Text -> Builder
sysID Encoding
e Text
sid | Bool -> Bool
not (Text
"\'" Text -> Text -> Bool
`T.isInfixOf` Text
sid) = Encoding -> Text -> Builder
fromText Encoding
e Text
"\'"
                                             forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
sid
                                             forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
"\'"
            | Bool -> Bool
not (Text
"\"" Text -> Text -> Bool
`T.isInfixOf` Text
sid) = Encoding -> Text -> Builder
fromText Encoding
e Text
"\""
                                             forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
sid
                                             forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
"\""
            | Bool
otherwise               = forall a. HasCallStack => [Char] -> a
error [Char]
"SYSTEM id is invalid"


------------------------------------------------------------------------------
pubID :: Encoding -> Text -> Builder
pubID :: Encoding -> Text -> Builder
pubID Encoding
e Text
sid | Bool -> Bool
not (Text
"\"" Text -> Text -> Bool
`T.isInfixOf` Text
sid) = Encoding -> Text -> Builder
fromText Encoding
e Text
"\""
                                             forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
sid
                                             forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
"\""
            | Bool
otherwise               = forall a. HasCallStack => [Char] -> a
error [Char]
"PUBLIC id is invalid"


------------------------------------------------------------------------------
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)                     = RenderOptions
-> Encoding -> Text -> [(Text, Text)] -> [Node] -> Builder
element RenderOptions
opts Encoding
e Text
t [(Text, Text)]
a [Node]
c


------------------------------------------------------------------------------
-- | Process the first node differently to encode leading whitespace.  This
-- lets us be sure that @parseXML@ 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')


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


------------------------------------------------------------------------------
entity :: Encoding -> Char -> Builder
entity :: Encoding -> Char -> Builder
entity Encoding
e Char
'&'  = Encoding -> Text -> Builder
fromText Encoding
e Text
"&amp;"
entity Encoding
e Char
'<'  = Encoding -> Text -> Builder
fromText Encoding
e Text
"&lt;"
entity Encoding
e Char
'>'  = Encoding -> Text -> Builder
fromText Encoding
e Text
"&gt;"
entity Encoding
e Char
'\"' = Encoding -> Text -> Builder
fromText Encoding
e Text
"&quot;"
entity Encoding
e Char
c    = Encoding -> Text -> Builder
fromText Encoding
e Text
"&#"
                forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e ([Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show (Char -> Int
ord Char
c)))
                forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
";"


------------------------------------------------------------------------------
element :: RenderOptions -> Encoding -> Text -> [(Text, Text)] -> [Node] -> Builder
element :: RenderOptions
-> Encoding -> Text -> [(Text, Text)] -> [Node] -> Builder
element RenderOptions
opts Encoding
e Text
t [(Text, Text)]
a [] = 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) -> Builder
attribute RenderOptions
opts Encoding
e) [(Text, Text)]
a)
        forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
"/>"
element RenderOptions
opts Encoding
e Text
t [(Text, Text)]
a [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) -> Builder
attribute RenderOptions
opts Encoding
e) [(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) -> Builder
attribute :: RenderOptions -> Encoding -> (Text, Text) -> Builder
attribute RenderOptions
opts Encoding
e (Text
n,Text
v)
    | 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 -> Text -> Text
T.cons Char
'=' 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 -> Text -> Text
T.cons Char
'=' 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;")