{-# 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 opts :: RenderOptions
opts e :: Encoding
e dt :: Maybe DocType
dt ns :: [Node]
ns = Builder
byteOrder
       Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Builder
xmlDecl Encoding
e
       Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Maybe DocType -> Builder
docTypeDecl Encoding
e Maybe DocType
dt
       Builder -> Builder -> Builder
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 "\xFEFF" -- byte order mark
                    | Bool
otherwise = Builder
forall a. Monoid a => a
mempty
          nodes :: Builder
nodes | [Node] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Node]
ns   = Builder
forall a. Monoid a => a
mempty
                | Bool
otherwise = RenderOptions -> Encoding -> Node -> Builder
firstNode RenderOptions
opts Encoding
e ([Node] -> Node
forall a. [a] -> a
head [Node]
ns)
                    Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (Node -> Builder) -> [Node] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e) ([Node] -> [Node]
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 _    _ []     = Builder
forall a. Monoid a => a
mempty
renderXmlFragmentWithOptions opts :: RenderOptions
opts e :: Encoding
e (n :: Node
n:ns :: [Node]
ns) =
    RenderOptions -> Encoding -> Node -> Builder
firstNode RenderOptions
opts Encoding
e Node
n Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (Node -> Builder) -> [Node] -> [Builder]
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 e :: Encoding
e = Encoding -> Text -> Builder
fromText Encoding
e "<?xml version=\"1.0\" encoding=\""
            Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e (Encoding -> Text
encodingName Encoding
e)
            Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e "\"?>\n"


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


------------------------------------------------------------------------------
externalID :: Encoding -> ExternalID -> Builder
externalID :: Encoding -> ExternalID -> Builder
externalID _ NoExternalID     = Builder
forall a. Monoid a => a
mempty
externalID e :: Encoding
e (System sid :: Text
sid)     = Encoding -> Text -> Builder
fromText Encoding
e " SYSTEM "
                                Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
sysID Encoding
e Text
sid
externalID e :: Encoding
e (Public pid :: Text
pid sid :: Text
sid) = Encoding -> Text -> Builder
fromText Encoding
e " PUBLIC "
                                Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
pubID Encoding
e Text
pid
                                Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e " "
                                Builder -> Builder -> Builder
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 _ NoInternalSubset = Builder
forall a. Monoid a => a
mempty
internalSubset e :: Encoding
e (InternalText t :: Text
t) = Encoding -> Text -> Builder
fromText Encoding
e " " Builder -> Builder -> Builder
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 e :: Encoding
e sid :: Text
sid | Bool -> Bool
not ("\'" Text -> Text -> Bool
`T.isInfixOf` Text
sid) = Encoding -> Text -> Builder
fromText Encoding
e "\'"
                                             Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
sid
                                             Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e "\'"
            | Bool -> Bool
not ("\"" Text -> Text -> Bool
`T.isInfixOf` Text
sid) = Encoding -> Text -> Builder
fromText Encoding
e "\""
                                             Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
sid
                                             Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e "\""
            | Bool
otherwise               = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error "SYSTEM id is invalid"


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


------------------------------------------------------------------------------
node :: RenderOptions -> Encoding -> Node -> Builder
node :: RenderOptions -> Encoding -> Node -> Builder
node _    e :: Encoding
e (TextNode t :: Text
t)                        = [Char] -> Encoding -> Text -> Builder
escaped "<>&" Encoding
e Text
t
node _    e :: Encoding
e (Comment t :: Text
t) | "--" Text -> Text -> Bool
`T.isInfixOf` Text
t  = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error "Invalid comment"
                        | "-" Text -> Text -> Bool
`T.isSuffixOf` Text
t  = [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error "Invalid comment"
                        | Bool
otherwise             = Encoding -> Text -> Builder
fromText Encoding
e "<!--"
                                                  Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
                                                  Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e "-->"
node opts :: RenderOptions
opts e :: Encoding
e (Element t :: Text
t a :: [(Text, Text)]
a c :: [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 opts :: RenderOptions
opts e :: Encoding
e (Comment t :: Text
t)     = RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e (Text -> Node
Comment Text
t)
firstNode opts :: RenderOptions
opts e :: Encoding
e (Element t :: Text
t a :: [(Text, Text)]
a c :: [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 _    _ (TextNode "")   = Builder
forall a. Monoid a => a
mempty
firstNode opts :: RenderOptions
opts e :: Encoding
e (TextNode t :: Text
t)    = let (c :: Char
c,t' :: Text
t') = Maybe (Char, Text) -> (Char, Text)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Char, Text) -> (Char, Text))
-> Maybe (Char, Text) -> (Char, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
T.uncons Text
t
                                   in [Char] -> Encoding -> Text -> Builder
escaped "<>& \t\r" Encoding
e (Char -> Text
T.singleton Char
c)
                                      Builder -> Builder -> Builder
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 _   _ "" = Builder
forall a. Monoid a => a
mempty
escaped bad :: [Char]
bad e :: Encoding
e t :: Text
t  = let (p :: Text
p,s :: Text
s) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> [Char] -> Bool
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 Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` case Maybe (Char, Text)
r of
                         Nothing     -> Builder
forall a. Monoid a => a
mempty
                         Just (c :: Char
c,ss :: Text
ss) -> Encoding -> Char -> Builder
entity Encoding
e Char
c Builder -> Builder -> Builder
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 e :: Encoding
e '&'  = Encoding -> Text -> Builder
fromText Encoding
e "&amp;"
entity e :: Encoding
e '<'  = Encoding -> Text -> Builder
fromText Encoding
e "&lt;"
entity e :: Encoding
e '>'  = Encoding -> Text -> Builder
fromText Encoding
e "&gt;"
entity e :: Encoding
e '\"' = Encoding -> Text -> Builder
fromText Encoding
e "&quot;"
entity e :: Encoding
e c :: Char
c    = Encoding -> Text -> Builder
fromText Encoding
e "&#"
                Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e ([Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show (Char -> Int
ord Char
c)))
                Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e ";"


------------------------------------------------------------------------------
element :: RenderOptions -> Encoding -> Text -> [(Text, Text)] -> [Node] -> Builder
element :: RenderOptions
-> Encoding -> Text -> [(Text, Text)] -> [Node] -> Builder
element opts :: RenderOptions
opts e :: Encoding
e t :: Text
t a :: [(Text, Text)]
a [] = Encoding -> Text -> Builder
fromText Encoding
e "<"
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Builder) -> [(Text, Text)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> (Text, Text) -> Builder
attribute RenderOptions
opts Encoding
e) [(Text, Text)]
a)
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e "/>"
element opts :: RenderOptions
opts e :: Encoding
e t :: Text
t a :: [(Text, Text)]
a c :: [Node]
c = Encoding -> Text -> Builder
fromText Encoding
e "<"
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Builder) -> [(Text, Text)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> (Text, Text) -> Builder
attribute RenderOptions
opts Encoding
e) [(Text, Text)]
a)
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e ">"
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` ([Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (Node -> Builder) -> [Node] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (RenderOptions -> Encoding -> Node -> Builder
node RenderOptions
opts Encoding
e) [Node]
c)
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e "</"
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
t
        Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e ">"


------------------------------------------------------------------------------
attribute :: RenderOptions -> Encoding -> (Text, Text) -> Builder
attribute :: RenderOptions -> Encoding -> (Text, Text) -> Builder
attribute opts :: RenderOptions
opts e :: Encoding
e (n :: Text
n,v :: Text
v)
    | RenderOptions -> AttrResolveInternalQuotes
roAttributeResolveInternal RenderOptions
opts AttrResolveInternalQuotes -> AttrResolveInternalQuotes -> Bool
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 " "
      Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
n
      Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e (Char -> Text -> Text
T.cons '=' Text
alternative)
      Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` [Char] -> Encoding -> Text -> Builder
escaped "<&" Encoding
e Text
v
      Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
alternative
    | Bool
otherwise =
      Encoding -> Text -> Builder
fromText Encoding
e " "
      Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
n
      Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e (Char -> Text -> Text
T.cons '=' Text
surround)
      Builder -> Builder -> Builder
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 "<&" Encoding
e Text
v)
      Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e Text
surround
  where
    (surround :: Text
surround, alternative :: Text
alternative, ent :: Text
ent) = case RenderOptions -> AttrSurround
roAttributeSurround RenderOptions
opts of
        SurroundSingleQuote -> ("'" , "\"", "&apos;")
        SurroundDoubleQuote -> ("\"", "'" ,  "&quot;")