{-# 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"
| 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
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
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 "&"
entity e :: Encoding
e '<' = Encoding -> Text -> Builder
fromText Encoding
e "<"
entity e :: Encoding
e '>' = Encoding -> Text -> Builder
fromText Encoding
e ">"
entity e :: Encoding
e '\"' = Encoding -> Text -> Builder
fromText Encoding
e """
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 -> ("'" , "\"", "'")
SurroundDoubleQuote -> ("\"", "'" , """)