{-# 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 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
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 -> 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
renderHtmlFragmentWithOptions :: RenderOptions -> Encoding -> [Node] -> Builder
renderHtmlFragmentWithOptions :: RenderOptions -> Encoding -> [Node] -> Builder
renderHtmlFragmentWithOptions _ _ [] = Builder
forall a. Monoid a => a
mempty
renderHtmlFragmentWithOptions 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)
renderHtmlFragment :: Encoding -> [Node] -> Builder
renderHtmlFragment :: Encoding -> [Node] -> Builder
renderHtmlFragment = RenderOptions -> Encoding -> [Node] -> Builder
renderHtmlFragmentWithOptions RenderOptions
defaultRenderOptions
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 ('&',ss :: Text
ss) | Either [Char] () -> Bool
forall b b. Either b b -> Bool
isLeft (Parser () -> [Char] -> Text -> Either [Char] ()
forall a. Parser a -> [Char] -> Text -> Either [Char] a
parseText Parser ()
ambigAmp "" Text
s)
-> Encoding -> Text -> Builder
fromText Encoding
e "&" Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` [Char] -> Encoding -> Text -> Builder
escaped [Char]
bad Encoding
e Text
ss
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
where isLeft :: Either b b -> Bool
isLeft = (b -> Bool) -> (b -> Bool) -> Either b b -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True) (Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False)
ambigAmp :: Parser ()
ambigAmp = Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char '&' ParsecT Text () Identity Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
(ParsecT Text () Identity Char
P.finishCharRef ParsecT Text () Identity Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return () Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text
P.finishEntityRef Parser Text -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
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) =
let tbase :: Text
tbase = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd ":" 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
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')
element :: RenderOptions -> Encoding -> Text -> Text -> [(Text, Text)] -> [Node] -> Builder
element :: RenderOptions
-> Encoding -> Text -> Text -> [(Text, Text)] -> [Node] -> Builder
element opts :: RenderOptions
opts e :: Encoding
e t :: Text
t tb :: Text
tb a :: [(Text, Text)]
a c :: [Node]
c
| Text
tb Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet Text
voidTags Bool -> Bool -> Bool
&& [Node] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [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, Text) -> Builder
attribute RenderOptions
opts Encoding
e Text
tb) [(Text, Text)]
a)
Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Encoding -> Text -> Builder
fromText Encoding
e " />"
| Text
tb Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`S.member` HashSet Text
voidTags =
[Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ " must be empty"
| Text -> [(Text, Text)] -> Bool
isRawText Text
tb [(Text, Text)]
a,
(Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Node -> Bool
isTextNode [Node]
c,
let s :: Text
s = [Text] -> Text
T.concat ((Node -> Text) -> [Node] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Text
nodeText [Node]
c),
Bool -> Bool
not ("</" Text -> Text -> Text
`T.append` Text
t Text -> Text -> Bool
`T.isInfixOf` Text
s) =
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, Text) -> Builder
attribute RenderOptions
opts Encoding
e Text
tb) [(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` Encoding -> Text -> Builder
fromText Encoding
e Text
s
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 ">"
| Text -> [(Text, Text)] -> Bool
isRawText Text
tb [(Text, Text)]
a,
[ TextNode _ ] <- [Node]
c =
[Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ " cannot contain text looking like its end tag"
| Text -> [(Text, Text)] -> Bool
isRawText Text
tb [(Text, Text)]
a =
[Char] -> Builder
forall a. HasCallStack => [Char] -> a
error ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ " cannot contain child elements or comments"
| 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` ([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, Text) -> Builder
attribute RenderOptions
opts Encoding
e Text
tb) [(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, Text) -> Builder
attribute :: RenderOptions -> Encoding -> Text -> (Text, Text) -> Builder
attribute opts :: RenderOptions
opts e :: Encoding
e tb :: Text
tb (n :: Text
n,v :: Text
v)
| Text
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
explicit =
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
| 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 -> ("\"", "'" , """)
nbase :: Text
nbase = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> (Text, Text) -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOnEnd ":" Text
n
explicit :: Bool
explicit = Bool
-> (HashMap Text (HashSet Text) -> Bool)
-> Maybe (HashMap Text (HashSet Text))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Bool
True
(Bool -> (HashSet Text -> Bool) -> Maybe (HashSet Text) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member Text
nbase) (Maybe (HashSet Text) -> Bool)
-> (HashMap Text (HashSet Text) -> Maybe (HashSet Text))
-> HashMap Text (HashSet Text)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HashMap Text (HashSet Text) -> Maybe (HashSet Text)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
tb)
(RenderOptions -> Maybe (HashMap Text (HashSet Text))
roExplicitEmptyAttrs RenderOptions
opts)