{-# 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 TextBuilder (from the text-builder package) instead of ShowS.
-}
module Text.Pandoc.XML.Light.Output
  ( -- * Replacement for xml-light's Text.XML.Output
    ppTopElement
  , ppElement
  , ppContent
  , ppcTopElement
  , ppcElement
  , ppcContent
  , showTopElement
  , showElement
  , showContent
  , useShortEmptyTags
  , useInlineTags
  , defaultConfigPP
  , prettyConfigPP
  , ConfigPP(..)
  ) where

import Data.List (intersperse)
import Data.Text (Text)
import qualified Data.Text as T
import TextBuilder (TextBuilder, char, text, toText)
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 -> QName -> Bool
inlineTag     :: 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
                           , inlineTag :: QName -> Bool
inlineTag     = Bool -> QName -> Bool
forall a b. a -> b -> a
const Bool
False
                           , 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 }

-- | The predicate specifies which tags should be treated as inline:
-- when pretty-printing, the whole content of an inline element is
-- kept on a single line, so that no whitespace is added inside it.
useInlineTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
useInlineTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
useInlineTags QName -> Bool
p ConfigPP
c = ConfigPP
c { inlineTag = 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        = TextBuilder -> Text
toText (TextBuilder -> Text)
-> (Element -> TextBuilder) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> TextBuilder -> Element -> TextBuilder
ppElementS ConfigPP
c TextBuilder
forall a. Monoid a => a
mempty

-- | Pretty printing content
ppcContent         :: ConfigPP -> Content -> Text
ppcContent :: ConfigPP -> Content -> Text
ppcContent ConfigPP
c        = TextBuilder -> Text
toText (TextBuilder -> Text)
-> (Content -> TextBuilder) -> Content -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> TextBuilder -> Content -> TextBuilder
ppContentS ConfigPP
c TextBuilder
forall a. Monoid a => a
mempty

type Indent = TextBuilder

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

ppElementS         :: ConfigPP -> Indent -> Element -> TextBuilder
ppElementS :: ConfigPP -> TextBuilder -> Element -> TextBuilder
ppElementS ConfigPP
c TextBuilder
i Element
e = TextBuilder
i TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> ConfigPP -> TextBuilder -> Element -> TextBuilder
ppElementS' ConfigPP
c TextBuilder
i Element
e

-- | Like ppElementS, but without indentation before the element
-- itself.  The indentation is still passed down, so that block-level
-- elements nested inside an inline element are indented properly.
ppElementS'        :: ConfigPP -> Indent -> Element -> TextBuilder
ppElementS' :: ConfigPP -> TextBuilder -> Element -> TextBuilder
ppElementS' ConfigPP
c TextBuilder
i Element
e = QName -> [Attr] -> TextBuilder
tagStart (Element -> QName
elName Element
e) (Element -> [Attr]
elAttribs Element
e) TextBuilder -> TextBuilder -> TextBuilder
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 -> TextBuilder
text Text
" ?>"
       | ConfigPP -> QName -> Bool
shortEmptyTag ConfigPP
c QName
name  -> Text -> TextBuilder
text Text
" />"
    [Text CData
t] -> Char -> TextBuilder
char Char
'>' TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<>
                ConfigPP -> TextBuilder -> CData -> TextBuilder
ppCDataS' ConfigPP
c (if ConfigPP -> QName -> Bool
inlineTag ConfigPP
c QName
name then TextBuilder
i else TextBuilder
forall a. Monoid a => a
mempty) CData
t TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<>
                QName -> TextBuilder
tagEnd QName
name
    [Content]
cs | ConfigPP -> QName -> Bool
inlineTag ConfigPP
c QName
name ->
          Char -> TextBuilder
char Char
'>' TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> [TextBuilder] -> TextBuilder
forall a. Monoid a => [a] -> a
mconcat ((Content -> TextBuilder) -> [Content] -> [TextBuilder]
forall a b. (a -> b) -> [a] -> [b]
map Content -> TextBuilder
inlineContent [Content]
cs) TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> QName -> TextBuilder
tagEnd QName
name
       | Bool
otherwise ->
          Char -> TextBuilder
char Char
'>' TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
nl TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<>
          [TextBuilder] -> TextBuilder
forall a. Monoid a => [a] -> a
mconcat ((Content -> TextBuilder) -> [Content] -> [TextBuilder]
forall a b. (a -> b) -> [a] -> [b]
map ((TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
nl) (TextBuilder -> TextBuilder)
-> (Content -> TextBuilder) -> Content -> TextBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigPP -> TextBuilder -> Content -> TextBuilder
ppContentS ConfigPP
c (TextBuilder
sp TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
i)) [Content]
cs) TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<>
          TextBuilder
i TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> QName -> TextBuilder
tagEnd QName
name
      where (TextBuilder
nl,TextBuilder
sp)  = if ConfigPP -> Bool
prettify ConfigPP
c
                          then (Text -> TextBuilder
text Text
"\n", Text -> TextBuilder
text Text
"  ")
                          else (TextBuilder
forall a. Monoid a => a
mempty, TextBuilder
forall a. Monoid a => a
mempty)
            -- content of an inline element: no indentation is
            -- emitted, so that no whitespace is added to the content
            inlineContent :: Content -> TextBuilder
inlineContent (Elem Element
el) = ConfigPP -> TextBuilder -> Element -> TextBuilder
ppElementS' ConfigPP
c TextBuilder
i Element
el
            inlineContent (Text CData
t)  = ConfigPP -> TextBuilder -> CData -> TextBuilder
ppCDataS' ConfigPP
c TextBuilder
i CData
t
            inlineContent (CRef Text
r)  = Text -> TextBuilder
showCRefS Text
r
  )
  where name :: QName
name = Element -> QName
elName Element
e

ppCDataS           :: ConfigPP -> Indent -> CData -> TextBuilder
ppCDataS :: ConfigPP -> TextBuilder -> CData -> TextBuilder
ppCDataS ConfigPP
c TextBuilder
i CData
t     = TextBuilder
i TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> ConfigPP -> TextBuilder -> CData -> TextBuilder
ppCDataS' ConfigPP
c TextBuilder
i CData
t

-- | Like ppCDataS, but without indentation before the text itself.
-- The indentation is still used after newlines in the text.
ppCDataS'          :: ConfigPP -> Indent -> CData -> TextBuilder
ppCDataS' :: ConfigPP -> TextBuilder -> CData -> TextBuilder
ppCDataS' ConfigPP
c TextBuilder
i CData
t    = 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 -> TextBuilder
showCDataS CData
t
                        -- add indentation after newlines; escaping
                        -- neither adds nor removes newlines, so we
                        -- can split the unescaped text
                        else [TextBuilder] -> TextBuilder
forall a. Monoid a => [a] -> a
mconcat
                             (TextBuilder -> [TextBuilder] -> [TextBuilder]
forall a. a -> [a] -> [a]
intersperse (Char -> TextBuilder
char Char
'\n' TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> TextBuilder
i)
                               ((Text -> TextBuilder) -> [Text] -> [TextBuilder]
forall a b. (a -> b) -> [a] -> [b]
map Text -> TextBuilder
escStr
                                 ((Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') (CData -> Text
cdData CData
t))))



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

-- | 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

-- Note: crefs should not contain '&', ';', etc.
showCRefS          :: Text -> TextBuilder
showCRefS :: Text -> TextBuilder
showCRefS Text
r         = Char -> TextBuilder
char Char
'&' TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
text Text
r TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
char Char
';'

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

--------------------------------------------------------------------------------
escCData           :: Text -> TextBuilder
escCData :: Text -> TextBuilder
escCData Text
t =
  case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"]]>" Text
t of
    (Text
chunk, Text
rest)
      | Text -> Bool
T.null Text
rest -> Text -> TextBuilder
text Text
chunk
      | Bool
otherwise   -> Text -> TextBuilder
text Text
chunk TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
text Text
"]]]]><![CDATA[>" TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<>
                       Text -> TextBuilder
escCData (Int -> Text -> Text
T.drop Int
3 Text
rest)

escChar            :: Char -> TextBuilder
escChar :: Char -> TextBuilder
escChar Char
c = case Char
c of
  Char
'<'   -> Text -> TextBuilder
text Text
"&lt;"
  Char
'>'   -> Text -> TextBuilder
text Text
"&gt;"
  Char
'&'   -> Text -> TextBuilder
text Text
"&amp;"
  Char
'"'   -> Text -> TextBuilder
text 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 -> TextBuilder
text Text
"&#39;"
  Char
_     -> Char -> TextBuilder
char 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 -> TextBuilder
escStr :: Text -> TextBuilder
escStr Text
cs          = case (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
needsEscape Text
cs of
                       (Text
chunk, Text
rest) ->
                         case Text -> Maybe (Char, Text)
T.uncons Text
rest of
                           Maybe (Char, Text)
Nothing -> Text -> TextBuilder
text Text
chunk
                           Just (Char
c, Text
rest') ->
                             Text -> TextBuilder
text Text
chunk TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
escChar Char
c TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Text -> TextBuilder
escStr Text
rest'
 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 -> TextBuilder
tagEnd :: QName -> TextBuilder
tagEnd QName
qn           = Text -> TextBuilder
text Text
"</" TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> QName -> TextBuilder
showQName QName
qn TextBuilder -> TextBuilder -> TextBuilder
forall a. Semigroup a => a -> a -> a
<> Char -> TextBuilder
char Char
'>'

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

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

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