    {-# 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
           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 Text
    "\xFEFF" -- byte order mark
                        | Bool
    otherwise = Builder
    forall a. Monoid a => a
    mempty
              nodes :: Builder
    nodes | [Node] -> Bool
    forall a. [a] -> 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. HasCallStack => [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. HasCallStack => [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
    _ []     = Builder
    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 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 Encoding
    e = Encoding -> Text -> Builder
    fromText Encoding
    e Text
    "<?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 Text
    "\"?>\n"

    ------------------------------------------------------------------------------
    docTypeDecl :: Encoding -> Maybe DocType -> Builder
    docTypeDecl :: Encoding -> Maybe DocType -> Builder
    docTypeDecl Encoding
    _ Maybe DocType
    Nothing                      = Builder
    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 "
                                       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 Text
    ">\n"

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

    ------------------------------------------------------------------------------
    node :: RenderOptions -> Encoding -> Node -> Builder
    node :: RenderOptions -> Encoding -> Node -> Builder
    node RenderOptions
    _    Encoding
    e (TextNode Text
    t)                        = String -> Encoding -> Text -> Builder
    escaped String
    "<>&" Encoding
    e Text
    t
    node RenderOptions
    _    Encoding
    e (Comment Text
    t) | Text
    "--" Text -> Text -> Bool
    `T.isInfixOf` Text
    t  = String -> Builder
    forall a. HasCallStack => String -> a
    error String
    "Invalid comment"
                            | Text
    "-" Text -> Text -> Bool
    `T.isSuffixOf` Text
    t  = String -> Builder
    forall a. HasCallStack => String -> a
    error String
    "Invalid comment"
                            | Bool
    otherwise             = Encoding -> Text -> Builder
    fromText Encoding
    e Text
    "<!--"
                                                      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
    "-->"
    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
    "")   = Builder
    forall a. Monoid a => a
    mempty
    firstNode RenderOptions
    opts Encoding
    e (TextNode Text
    t)    = let (Char
    c,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 String -> Encoding -> Text -> Builder
    escaped String
    "<>& \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 :: String -> Encoding -> Text -> Builder
    escaped String
    _   Encoding
    _ Text
    "" = Builder
    forall a. Monoid a => a
    mempty
    escaped String
    bad Encoding
    e Text
    t  = let (Text
    p,Text
    s) = (Char -> Bool) -> Text -> (Text, Text)
    T.break (Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    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
                             Maybe (Char, Text)
    Nothing     -> Builder
    forall a. Monoid a => a
    mempty
                             Just (Char
    c,Text
    ss) -> Encoding -> Char -> Builder
    entity Encoding
    e Char
    c Builder -> Builder -> Builder
    forall a. Monoid a => a -> a -> a
    `mappend` String -> Encoding -> Text -> Builder
    escaped String
    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
    "&#"
                    Builder -> Builder -> Builder
    forall a. Monoid a => a -> a -> a
    `mappend` Encoding -> Text -> Builder
    fromText Encoding
    e (String -> Text
    T.pack (Int -> String
    forall a. Show a => a -> String
    show (Char -> Int
    ord Char
    c)))
                    Builder -> Builder -> Builder
    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
    "<"
            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 Text
    "/>"
    element RenderOptions
    opts Encoding
    e Text
    t [(Text, Text)]
    a [Node]
    c = Encoding -> Text -> Builder
    fromText Encoding
    e Text
    "<"
            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 Text
    ">"
            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 Text
    "</"
            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
    ">"

    ------------------------------------------------------------------------------
    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 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 Text
    " "
          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 Char
    '=' Text
    alternative)
          Builder -> Builder -> Builder
    forall a. Monoid a => a -> a -> a
    `mappend` String -> Encoding -> Text -> Builder
    escaped String
    "<&" 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 Text
    " "
          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 Char
    '=' Text
    surround)
          Builder -> Builder -> Builder
    forall a. Monoid a => a -> a -> a
    `mappend` (Text -> Text) -> Builder -> Builder
    bmap (HasCallStack => Text -> Text -> Text -> Text
    Text -> Text -> Text -> Text
    T.replace Text
    surround Text
    ent) (String -> Encoding -> Text -> Builder
    escaped String
    "<&" Encoding
    e Text
    v)
          Builder -> Builder -> Builder
    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;")