    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE OverloadedStrings #-}
    {- |
       Module      : Text.Pandoc.XML.Light.Output
       Copyright   : Copyright (C) 2007 Galois, Inc., 2021-2024 John MacFarlane
       License     : GNU GPL, version 2 or above

       Maintainer  : John MacFarlane <jgm@berkeley.edu>
       Stability   : alpha
       Portability : portable

       This code is based on code from xml-light, released under the BSD3 license.
       We use a text Builder instead of ShowS.
    -}
    module Text.Pandoc.XML.Light.Output
      ( -- * Replacement for xml-light's Text.XML.Output
        ppTopElement
      , ppElement
      , ppContent
      , ppcElement
      , ppcContent
      , showTopElement
      , showElement
      , showContent
      , useShortEmptyTags
      , defaultConfigPP
      , ConfigPP(..)
      ) where

    import Data.Text (Text)
    import qualified Data.Text as T
    import qualified Data.Text.Lazy as TL
    import Data.Text.Lazy.Builder (Builder, singleton, fromText, toLazyText)
    import Text.Pandoc.XML.Light.Types

    --
    -- duplicates functions from Text.XML.Output
    --

    -- | The XML 1.0 header
    xmlHeader :: Text
    xmlHeader :: Text
    xmlHeader = Text
    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"

    --------------------------------------------------------------------------------
    data ConfigPP = ConfigPP
      { ConfigPP -> QName -> Bool
    shortEmptyTag :: QName -> Bool
      , ConfigPP -> Bool
    prettify      :: Bool
      }

    -- | Default pretty orinting configuration.
    --  * Always use abbreviate empty tags.
    defaultConfigPP :: ConfigPP
    defaultConfigPP :: ConfigPP
    defaultConfigPP = ConfigPP { shortEmptyTag :: QName -> Bool
    shortEmptyTag = Bool -> QName -> Bool
    forall a b. a -> b -> a
    const Bool
    True
                               , prettify :: Bool
    prettify      = Bool
    False
                               }

    -- | The predicate specifies for which empty tags we should use XML's
    -- abbreviated notation <TAG />.  This is useful if we are working with
    -- some XML-ish standards (such as certain versions of HTML) where some
    -- empty tags should always be displayed in the <TAG></TAG> form.
    useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
    useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
    useShortEmptyTags QName -> Bool
    p ConfigPP
    c = ConfigPP
    c { shortEmptyTag = p }

    -- | Specify if we should use extra white-space to make document more readable.
    -- WARNING: This adds additional white-space to text elements,
    -- and so it may change the meaning of the document.
    useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
    useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
    useExtraWhiteSpace Bool
    p ConfigPP
    c  = ConfigPP
    c { prettify = p }

    -- | A configuration that tries to make things pretty
    -- (possibly at the cost of changing the semantics a bit
    -- through adding white space.)
    prettyConfigPP     :: ConfigPP
    prettyConfigPP :: ConfigPP
    prettyConfigPP      = Bool -> ConfigPP -> ConfigPP
    useExtraWhiteSpace Bool
    True ConfigPP
    defaultConfigPP

    --------------------------------------------------------------------------------

    -- | Pretty printing renders XML documents faithfully,
    -- with the exception that whitespace may be added\/removed
    -- in non-verbatim character data.
    ppTopElement       :: Element -> Text
    ppTopElement :: Element -> Text
    ppTopElement        = ConfigPP -> Element -> Text
    ppcTopElement ConfigPP
    prettyConfigPP

    -- | Pretty printing elements
    ppElement          :: Element -> Text
    ppElement :: Element -> Text
    ppElement           = ConfigPP -> Element -> Text
    ppcElement ConfigPP
    prettyConfigPP

    -- | Pretty printing content
    ppContent          :: Content -> Text
    ppContent :: Content -> Text
    ppContent           = ConfigPP -> Content -> Text
    ppcContent ConfigPP
    prettyConfigPP

    -- | Pretty printing renders XML documents faithfully,
    -- with the exception that whitespace may be added\/removed
    -- in non-verbatim character data.
    ppcTopElement      :: ConfigPP -> Element -> Text
    ppcTopElement :: ConfigPP -> Element -> Text
    ppcTopElement ConfigPP
    c Element
    e   = [Text] -> Text
    T.unlines [Text
    xmlHeader,ConfigPP -> Element -> Text
    ppcElement ConfigPP
    c Element
    e]

    -- | Pretty printing elements
    ppcElement         :: ConfigPP -> Element -> Text
    ppcElement :: ConfigPP -> Element -> Text
    ppcElement ConfigPP
    c        = LazyText -> Text
    TL.toStrict (LazyText -> Text) -> (Element -> LazyText) -> Element -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Builder -> LazyText
    toLazyText (Builder -> LazyText)
    -> (Element -> Builder) -> Element -> LazyText
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ConfigPP -> Builder -> Element -> Builder
    ppElementS ConfigPP
    c Builder
    forall a. Monoid a => a
    mempty

    -- | Pretty printing content
    ppcContent         :: ConfigPP -> Content -> Text
    ppcContent :: ConfigPP -> Content -> Text
    ppcContent ConfigPP
    c        = LazyText -> Text
    TL.toStrict (LazyText -> Text) -> (Content -> LazyText) -> Content -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Builder -> LazyText
    toLazyText (Builder -> LazyText)
    -> (Content -> Builder) -> Content -> LazyText
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ConfigPP -> Builder -> Content -> Builder
    ppContentS ConfigPP
    c Builder
    forall a. Monoid a => a
    mempty

    ppcCData           :: ConfigPP -> CData -> Text
    ppcCData :: ConfigPP -> CData -> Text
    ppcCData ConfigPP
    c         = LazyText -> Text
    TL.toStrict (LazyText -> Text) -> (CData -> LazyText) -> CData -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Builder -> LazyText
    toLazyText (Builder -> LazyText) -> (CData -> Builder) -> CData -> LazyText
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ConfigPP -> Builder -> CData -> Builder
    ppCDataS ConfigPP
    c Builder
    forall a. Monoid a => a
    mempty

    type Indent = Builder

    -- | Pretty printing content using ShowT
    ppContentS         :: ConfigPP -> Indent -> Content -> Builder
    ppContentS :: ConfigPP -> Builder -> Content -> Builder
    ppContentS ConfigPP
    c Builder
    i Content
    x = case Content
    x of
                         Elem Element
    e -> ConfigPP -> Builder -> Element -> Builder
    ppElementS ConfigPP
    c Builder
    i Element
    e
                         Text CData
    t -> ConfigPP -> Builder -> CData -> Builder
    ppCDataS ConfigPP
    c Builder
    i CData
    t
                         CRef Text
    r -> Text -> Builder
    showCRefS Text
    r

    ppElementS         :: ConfigPP -> Indent -> Element -> Builder
    ppElementS :: ConfigPP -> Builder -> Element -> Builder
    ppElementS ConfigPP
    c Builder
    i Element
    e = Builder
    i Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> QName -> [Attr] -> Builder
    tagStart (Element -> QName
    elName Element
    e) (Element -> [Attr]
    elAttribs Element
    e) Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <>
      (case Element -> [Content]
    elContent Element
    e of
        [] | Text
    "?" Text -> Text -> Bool
    `T.isPrefixOf` QName -> Text
    qName QName
    name -> Text -> Builder
    fromText Text
    " ?>"
           | ConfigPP -> QName -> Bool
    shortEmptyTag ConfigPP
    c QName
    name  -> Text -> Builder
    fromText Text
    " />"
        [Text CData
    t] -> Char -> Builder
    singleton Char
    '>' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> ConfigPP -> Builder -> CData -> Builder
    ppCDataS ConfigPP
    c Builder
    forall a. Monoid a => a
    mempty CData
    t Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> QName -> Builder
    tagEnd QName
    name
        [Content]
    cs -> Char -> Builder
    singleton Char
    '>' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    nl Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <>
              [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat ((Content -> Builder) -> [Content] -> [Builder]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    nl) (Builder -> Builder) -> (Content -> Builder) -> Content -> Builder
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ConfigPP -> Builder -> Content -> Builder
    ppContentS ConfigPP
    c (Builder
    sp Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    i)) [Content]
    cs) Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <>
              Builder
    i Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> QName -> Builder
    tagEnd QName
    name
          where (Builder
    nl,Builder
    sp)  = if ConfigPP -> Bool
    prettify ConfigPP
    c then (Builder
    "\n",Builder
    "  ") else (Builder
    "",Builder
    "")
      )
      where name :: QName
    name = Element -> QName
    elName Element
    e

    ppCDataS           :: ConfigPP -> Indent -> CData -> Builder
    ppCDataS :: ConfigPP -> Builder -> CData -> Builder
    ppCDataS ConfigPP
    c Builder
    i CData
    t     = Builder
    i Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> if CData -> CDataKind
    cdVerbatim CData
    t CDataKind -> CDataKind -> Bool
    forall a. Eq a => a -> a -> Bool
    /= CDataKind
    CDataText Bool -> Bool -> Bool
    || Bool -> Bool
    not (ConfigPP -> Bool
    prettify ConfigPP
    c)
                                 then CData -> Builder
    showCDataS CData
    t
                                 else (Char -> Builder -> Builder) -> Builder -> String -> Builder
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Char -> Builder -> Builder
    cons Builder
    forall a. Monoid a => a
    mempty (Text -> String
    T.unpack (CData -> Text
    showCData CData
    t))
      where cons         :: Char -> Builder -> Builder
            cons :: Char -> Builder -> Builder
    cons Char
    '\n' Builder
    ys  = Char -> Builder
    singleton Char
    '\n' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    i Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    ys
            cons Char
    y Builder
    ys     = Char -> Builder
    singleton Char
    y Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    ys

    --------------------------------------------------------------------------------

    -- | Adds the <?xml?> header.
    showTopElement     :: Element -> Text
    showTopElement :: Element -> Text
    showTopElement Element
    c    = Text
    xmlHeader Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Element -> Text
    showElement Element
    c

    showContent        :: Content -> Text
    showContent :: Content -> Text
    showContent         = ConfigPP -> Content -> Text
    ppcContent ConfigPP
    defaultConfigPP

    showElement        :: Element -> Text
    showElement :: Element -> Text
    showElement         = ConfigPP -> Element -> Text
    ppcElement ConfigPP
    defaultConfigPP

    showCData          :: CData -> Text
    showCData :: CData -> Text
    showCData           = ConfigPP -> CData -> Text
    ppcCData ConfigPP
    defaultConfigPP

    -- Note: crefs should not contain '&', ';', etc.
    showCRefS          :: Text -> Builder
    showCRefS :: Text -> Builder
    showCRefS Text
    r         = Char -> Builder
    singleton Char
    '&' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Builder
    fromText Text
    r Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    ';'

    -- | Convert a text element to characters.
    showCDataS         :: CData -> Builder
    showCDataS :: CData -> Builder
    showCDataS CData
    cd =
     case CData -> CDataKind
    cdVerbatim CData
    cd of
       CDataKind
    CDataText     -> Text -> Builder
    escStr (CData -> Text
    cdData CData
    cd)
       CDataKind
    CDataVerbatim -> Text -> Builder
    fromText Text
    "<![CDATA[" Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Builder
    escCData (CData -> Text
    cdData CData
    cd) Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <>
                        Text -> Builder
    fromText Text
    "]]>"
       CDataKind
    CDataRaw      -> Text -> Builder
    fromText (CData -> Text
    cdData CData
    cd)

    --------------------------------------------------------------------------------
    escCData           :: Text -> Builder
    escCData :: Text -> Builder
    escCData Text
    t
      | Text
    "]]>" Text -> Text -> Bool
    `T.isPrefixOf` Text
    t =
         Text -> Builder
    fromText Text
    "]]]]><![CDATA[>" Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Builder
    fromText (Int -> Text -> Text
    T.drop Int
    3 Text
    t)
    escCData Text
    t
      = case Text -> Maybe (Char, Text)
    T.uncons Text
    t of
          Maybe (Char, Text)
    Nothing     -> Builder
    forall a. Monoid a => a
    mempty
          Just (Char
    c,Text
    t') -> Char -> Builder
    singleton Char
    c Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Builder
    escCData Text
    t'

    escChar            :: Char -> Builder
    escChar :: Char -> Builder
    escChar Char
    c = case Char
    c of
      Char
    '<'   -> Text -> Builder
    fromText Text
    "&lt;"
      Char
    '>'   -> Text -> Builder
    fromText Text
    "&gt;"
      Char
    '&'   -> Text -> Builder
    fromText Text
    "&amp;"
      Char
    '"'   -> Text -> Builder
    fromText Text
    "&quot;"
      -- we use &#39 instead of &apos; because IE apparently has difficulties
      -- rendering &apos; in xhtml.
      -- Reported by Rohan Drape <rohan.drape@gmail.com>.
      Char
    '\''  -> Text -> Builder
    fromText Text
    "&#39;"
      Char
    _     -> Char -> Builder
    singleton Char
    c

      {- original xml-light version:
      -- NOTE: We escape '\r' explicitly because otherwise they get lost
      -- when parsed back in because of then end-of-line normalization rules.
      _ | isPrint c || c == '\n' -> singleton c
        | otherwise -> showText "&#" . showsT oc . singleton ';'
          where oc = ord c
      -}

    escStr             :: Text -> Builder
    escStr :: Text -> Builder
    escStr Text
    cs          = if (Char -> Bool) -> Text -> Bool
    T.any Char -> Bool
    needsEscape Text
    cs
                            then [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat ((Char -> Builder) -> String -> [Builder]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Builder
    escChar (Text -> String
    T.unpack Text
    cs))
                            else Text -> Builder
    fromText Text
    cs
     where
      needsEscape :: Char -> Bool
    needsEscape Char
    '<' = Bool
    True
      needsEscape Char
    '>' = Bool
    True
      needsEscape Char
    '&' = Bool
    True
      needsEscape Char
    '"' = Bool
    True
      needsEscape Char
    '\'' = Bool
    True
      needsEscape Char
    _ = Bool
    False

    tagEnd             :: QName -> Builder
    tagEnd :: QName -> Builder
    tagEnd QName
    qn           = Text -> Builder
    fromText Text
    "</" Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> QName -> Builder
    showQName QName
    qn Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    '>'

    tagStart           :: QName -> [Attr] -> Builder
    tagStart :: QName -> [Attr] -> Builder
    tagStart QName
    qn [Attr]
    as      = Char -> Builder
    singleton Char
    '<' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> QName -> Builder
    showQName QName
    qn Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    as_str
     where as_str :: Builder
    as_str       = if [Attr] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Attr]
    as
                             then Builder
    forall a. Monoid a => a
    mempty
                             else [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat ((Attr -> Builder) -> [Attr] -> [Builder]
    forall a b. (a -> b) -> [a] -> [b]
    map Attr -> Builder
    showAttr [Attr]
    as)

    showAttr           :: Attr -> Builder
    showAttr :: Attr -> Builder
    showAttr (Attr QName
    qn Text
    v) = Char -> Builder
    singleton Char
    ' ' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> QName -> Builder
    showQName QName
    qn Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <>
                           Char -> Builder
    singleton Char
    '=' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <>
                           Char -> Builder
    singleton Char
    '"' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Builder
    escStr Text
    v Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    '"'

    showQName          :: QName -> Builder
    showQName :: QName -> Builder
    showQName QName
    q         =
      case QName -> Maybe Text
    qPrefix QName
    q of
        Maybe Text
    Nothing -> Text -> Builder
    fromText (QName -> Text
    qName QName
    q)
        Just Text
    p  -> Text -> Builder
    fromText Text
    p Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    ':' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Builder
    fromText (QName -> Text
    qName QName
    q)