XML.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
--   Module      : Text.Pandoc.Writers.XML
--   Copyright   : Copyright (C) 2025- Massimiliano Farinella and John MacFarlane
--   License     : GNU GPL, version 2 or above
--
--   Maintainer  : Massimiliano Farinella <massifrg@gmail.com>
--   Stability   : WIP
--   Portability : portable
--
-- Conversion of 'Pandoc' documents to (pandoc specific) xml markup.
module Text.Pandoc.Writers.XML (writeXML) where

import Data.Map (Map, toList)
import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Data.Version (versionBranch)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Options (WriterOptions (..))
import Text.Pandoc.XML.Light
import qualified Text.Pandoc.XML.Light as XML
import Text.Pandoc.XMLFormat
import Text.XML.Light (xml_header)

type PandocAttr = Text.Pandoc.Definition.Attr

writeXML :: (PandocMonad m) => WriterOptions -> Pandoc -> m T.Text
writeXML _ doc = do
  return $ pandocToXmlText doc

text_node :: T.Text -> Content
text_node text = Text (CData CDataText text Nothing)

emptyElement :: T.Text -> Element
emptyElement tag =
  Element
    { elName = unqual tag,
      elAttribs = [],
      elContent = [],
      elLine = Nothing
    }

elementWithContents :: T.Text -> [Content] -> Element
elementWithContents tag contents =
  Element
    { elName = unqual tag,
      elAttribs = [],
      elContent = contents,
      elLine = Nothing
    }

elementWithAttributes :: T.Text -> [XML.Attr] -> Element
elementWithAttributes tag attributes =
  Element
    { elName = unqual tag,
      elAttribs = attributes,
      elContent = [],
      elLine = Nothing
    }

elementWithAttrAndContents :: T.Text -> PandocAttr -> [Content] -> Element
elementWithAttrAndContents tag attr contents = addAttrAttributes attr $ elementWithContents tag contents

asBlockOfInlines :: Element -> [Content]
asBlockOfInlines el = [Elem el, text_node "\n"]

asBlockOfBlocks :: Element -> [Content]
asBlockOfBlocks el = [Elem newline_before_first, newline]
  where
    newline = text_node "\n"
    newline_before_first = if null (elContent el) then el else prependContents [newline] el

itemName :: (Show a) => a -> T.Text
itemName a = T.pack $ takeWhile (/= ' ') (show a)

intAsText :: Int -> T.Text
intAsText i = T.pack $ show i

itemAsEmptyElement :: (Show a) => a -> Element
itemAsEmptyElement item = emptyElement $ itemName item

pandocToXmlText :: Pandoc -> T.Text
pandocToXmlText (Pandoc (Meta meta) blocks) = with_header . with_blocks . with_meta . with_version $ el
  where
    el = prependContents [text_node "\n"] $ emptyElement "Pandoc"
    with_version = addAttribute atNameApiVersion (T.intercalate "," $ map (T.pack . show) $ versionBranch pandocTypesVersion)
    with_meta = appendContents (metaMapToXML meta "meta")
    with_blocks = appendContents (asBlockOfBlocks $ elementWithContents "blocks" $ blocksToXML blocks)
    with_header :: Element -> T.Text
    with_header e = T.concat [T.pack xml_header, "\n", showElement e]

metaMapToXML :: Map T.Text MetaValue -> T.Text -> [Content]
metaMapToXML mmap tag = asBlockOfBlocks $ elementWithContents tag entries
  where
    entries = concatMap to_entry $ toList mmap
    to_entry :: (T.Text, MetaValue) -> [Content]
    to_entry (text, metavalue) = asBlockOfBlocks with_key
      where
        entry = elementWithContents tgNameMetaMapEntry $ metaValueToXML metavalue
        with_key = addAttribute atNameMetaMapEntryKey text entry

metaValueToXML :: MetaValue -> [Content]
metaValueToXML value =
  let name = itemName value
      el = itemAsEmptyElement value
   in case (value) of
        MetaBool b -> asBlockOfInlines $ addAttribute atNameMetaBoolValue bool_value el
          where
            bool_value = if b then "true" else "false"
        MetaString s -> asBlockOfInlines $ appendContents [text_node s] el
        MetaInlines inlines -> asBlockOfInlines $ appendContents (inlinesToXML inlines) el
        MetaBlocks blocks -> asBlockOfBlocks $ appendContents (blocksToXML blocks) el
        MetaList items -> asBlockOfBlocks $ appendContents (concatMap metaValueToXML items) el
        MetaMap mm -> metaMapToXML mm name

blocksToXML :: [Block] -> [Content]
blocksToXML blocks = concatMap blockToXML blocks

inlinesToXML :: [Inline] -> [Content]
inlinesToXML inlines = concatMap inlineContentToContents (ilsToIlsContent inlines [])

data InlineContent
  = NormalInline Inline
  | ElSpace Int
  | ElStr T.Text

ilsToIlsContent :: [Inline] -> [InlineContent] -> [InlineContent]
ilsToIlsContent (Space : xs) [] = ilsToIlsContent xs [ElSpace 1]
ilsToIlsContent (Space : xs) (NormalInline Space : cs) = ilsToIlsContent xs (ElSpace 2 : cs)
ilsToIlsContent (Space : xs) (ElSpace n : cs) = ilsToIlsContent xs (ElSpace (n + 1) : cs)
-- empty Str are always encoded as <Str />
ilsToIlsContent (Str "" : xs) ilct = ilsToIlsContent xs (ElStr "" : ilct)
-- Str s1, Str s2 -> s1<Str content="s2">
ilsToIlsContent (Str s2 : xs) (NormalInline str1@(Str _) : ilct) = ilsToIlsContent xs (ElStr s2 : NormalInline str1 : ilct)
--
ilsToIlsContent (Str s : xs) ilct =
  if T.any (== ' ') s
    then ilsToIlsContent xs (ElStr s : ilct)
    else ilsToIlsContent xs (NormalInline (Str s) : ilct)
ilsToIlsContent (x : xs) ilct = ilsToIlsContent xs (NormalInline x : ilct)
ilsToIlsContent [] ilct = reverse $ lastSpaceAsElem ilct
  where
    lastSpaceAsElem :: [InlineContent] -> [InlineContent]
    lastSpaceAsElem (NormalInline Space : xs) = ElSpace 1 : xs
    lastSpaceAsElem ilcts = ilcts

inlineContentToContents :: InlineContent -> [Content]
inlineContentToContents (NormalInline il) = inlineToXML il
inlineContentToContents (ElSpace 1) = [Elem $ emptyElement "Space"]
inlineContentToContents (ElSpace n) = [Elem $ addAttribute atNameSpaceCount (intAsText n) (emptyElement "Space")]
inlineContentToContents (ElStr "") = [Elem $ emptyElement "Str"]
inlineContentToContents (ElStr s) = [Elem $ addAttribute atNameStrContent s (emptyElement "Str")]

asContents :: Element -> [Content]
asContents el = [Elem el]

wrapBlocks :: T.Text -> [Block] -> [Content]
wrapBlocks tag blocks = asBlockOfBlocks $ elementWithContents tag $ blocksToXML blocks

wrapArrayOfBlocks :: T.Text -> [[Block]] -> [Content]
wrapArrayOfBlocks tag array = concatMap (wrapBlocks tag) array

-- wrapInlines :: T.Text -> [Inline] -> [Content]
-- wrapInlines tag inlines = asBlockOfInlines $ element_with_contents tag $ inlinesToXML inlines

blockToXML :: Block -> [Content]
blockToXML block =
  let el = itemAsEmptyElement block
   in case (block) of
        Para inlines -> asBlockOfInlines $ appendContents (inlinesToXML inlines) el
        Header level (idn, cls, attrs) inlines -> asBlockOfInlines $ appendContents (inlinesToXML inlines) with_attr
          where
            with_attr = addAttrAttributes (idn, cls, attrs ++ [(atNameLevel, intAsText level)]) el
        Plain inlines -> asBlockOfInlines $ appendContents (inlinesToXML inlines) el
        Div attr blocks -> asBlockOfBlocks $ appendContents (blocksToXML blocks) with_attr
          where
            with_attr = addAttrAttributes attr el
        BulletList items -> asBlockOfBlocks $ appendContents (wrapArrayOfBlocks tgNameListItem items) el
        OrderedList (start, style, delim) items -> asBlockOfBlocks $ with_contents . with_attrs $ el
          where
            with_attrs =
              addAttributes
                ( validAttributes
                    [ (atNameStart, intAsText start),
                      (atNameNumberStyle, itemName style),
                      (atNameNumberDelim, itemName delim)
                    ]
                )
            with_contents = appendContents (wrapArrayOfBlocks tgNameListItem items)
        BlockQuote blocks -> asBlockOfBlocks $ appendContents (blocksToXML blocks) el
        HorizontalRule -> asBlockOfInlines el
        CodeBlock attr text -> asBlockOfInlines $ with_contents . with_attr $ el
          where
            with_contents = appendContents [text_node text]
            with_attr = addAttrAttributes attr
        LineBlock lins -> asBlockOfBlocks $ appendContents (concatMap wrapInlines lins) el
          where
            wrapInlines inlines = asContents $ appendContents (inlinesToXML inlines) $ emptyElement tgNameLineItem
        Table attr caption colspecs thead tbodies tfoot -> asBlockOfBlocks $ with_foot . with_bodies . with_head . with_colspecs . with_caption . with_attr $ el
          where
            with_attr = addAttrAttributes attr
            with_caption = appendContents (captionToXML caption)
            with_colspecs = appendContents (colSpecsToXML colspecs)
            with_head = appendContents (tableHeadToXML thead)
            with_bodies = appendContents (concatMap tableBodyToXML tbodies)
            with_foot = appendContents (tableFootToXML tfoot)
        Figure attr caption blocks -> asBlockOfBlocks $ with_contents . with_caption . with_attr $ el
          where
            with_attr = addAttrAttributes attr
            with_caption = appendContents (captionToXML caption)
            with_contents = appendContents (blocksToXML blocks)
        RawBlock (Format format) text -> asContents $ appendContents [text_node text] raw
          where
            raw = addAttribute atNameFormat format el
        DefinitionList items -> asBlockOfBlocks $ appendContents (map definitionListItemToXML items) el

inlineToXML :: Inline -> [Content]
inlineToXML inline =
  let el = itemAsEmptyElement inline
      wrapInlines inlines = asContents $ appendContents (inlinesToXML inlines) el
   in case (inline) of
        Space -> [text_node " "]
        Str s -> [text_node s]
        Emph inlines -> wrapInlines inlines
        Strong inlines -> wrapInlines inlines
        Quoted quote_type inlines -> asContents $ appendContents (inlinesToXML inlines) quoted
          where
            quoted = addAttribute atNameQuoteType (itemName quote_type) el
        Underline inlines -> wrapInlines inlines
        Strikeout inlines -> wrapInlines inlines
        SmallCaps inlines -> wrapInlines inlines
        Superscript inlines -> wrapInlines inlines
        Subscript inlines -> wrapInlines inlines
        SoftBreak -> asContents el
        LineBreak -> asContents el
        Span attr inlines -> asContents $ appendContents (inlinesToXML inlines) with_attr
          where
            with_attr = addAttrAttributes attr el
        Link (idn, cls, attrs) inlines (url, title) -> asContents $ appendContents (inlinesToXML inlines) with_attr
          where
            with_attr = addAttrAttributes (idn, cls, attrs ++ [(atNameLinkUrl, url), (atNameTitle, title)]) el
        Image (idn, cls, attrs) inlines (url, title) -> asContents $ appendContents (inlinesToXML inlines) with_attr
          where
            with_attr = addAttrAttributes (idn, cls, attrs ++ [(atNameImageUrl, url), (atNameTitle, title)]) el
        RawInline (Format format) text -> asContents $ appendContents [text_node text] raw
          where
            raw = addAttribute atNameFormat format el
        Math math_type text -> asContents $ appendContents [text_node text] math
          where
            math = addAttribute atNameMathType (itemName math_type) el
        Code attr text -> asContents $ appendContents [text_node text] with_attr
          where
            with_attr = addAttrAttributes attr el
        Note blocks -> asContents $ appendContents (blocksToXML blocks) el
        Cite citations inlines -> asContents $ appendContents (inlinesToXML inlines) with_citations
          where
            with_citations = addCitations citations el

-- TODO: don't let an attribute overwrite id or class
maybeAttribute :: (T.Text, T.Text) -> Maybe XML.Attr
maybeAttribute (_, "") = Nothing
maybeAttribute ("", _) = Nothing
maybeAttribute (name, value) = Just $ XML.Attr (unqual name) value

validAttributes :: [(T.Text, T.Text)] -> [XML.Attr]
validAttributes pairs = mapMaybe maybeAttribute pairs

appendContents :: [Content] -> Element -> Element
appendContents newContents el = el {elContent = (elContent el) ++ newContents}

prependContents :: [Content] -> Element -> Element
prependContents newContents el = el {elContent = newContents ++ (elContent el)}

addAttributes :: [XML.Attr] -> Element -> Element
addAttributes newAttrs el = el {elAttribs = newAttrs ++ elAttribs el}

addAttribute :: T.Text -> T.Text -> Element -> Element
addAttribute attr_name attr_value el = el {elAttribs = new_attr : elAttribs el}
  where
    new_attr = XML.Attr (unqual attr_name) attr_value

addAttrAttributes :: PandocAttr -> Element -> Element
addAttrAttributes (identifier, classes, attributes) el = addAttributes attrs' el
  where
    attrs' = mapMaybe maybeAttribute (("id", identifier) : ("class", T.intercalate " " classes) : attributes)

addCitations :: [Citation] -> Element -> Element
addCitations citations el = appendContents [Elem $ elementWithContents tgNameCitations $ (text_node "\n") : concatMap citation_to_elem citations] el
  where
    citation_to_elem :: Citation -> [Content]
    citation_to_elem citation = asBlockOfInlines with_suffix
      where
        cit_elem = elementWithAttributes (itemName citation) attrs
        prefix = citationPrefix citation
        suffix = citationSuffix citation
        with_prefix =
          if null prefix
            then cit_elem
            else appendContents [Elem $ elementWithContents tgNameCitationPrefix $ inlinesToXML prefix] cit_elem
        with_suffix =
          if null suffix
            then with_prefix
            else appendContents [Elem $ elementWithContents tgNameCitationSuffix $ inlinesToXML suffix] with_prefix
        attrs =
          map
            (\(n, v) -> XML.Attr (unqual n) v)
            [ ("id", citationId citation),
              (atNameCitationMode, T.pack $ show $ citationMode citation),
              (atNameCitationNoteNum, intAsText $ citationNoteNum citation),
              (atNameCitationHash, intAsText $ citationHash citation)
            ]

definitionListItemToXML :: ([Inline], [[Block]]) -> Content
definitionListItemToXML (inlines, defs) = Elem $ elementWithContents tgNameDefListItem $ term ++ wrapArrayOfBlocks tgNameDefListDef defs
  where
    term = asBlockOfInlines $ appendContents (inlinesToXML inlines) $ emptyElement tgNameDefListTerm

captionToXML :: Caption -> [Content]
captionToXML (Caption short blocks) = asBlockOfBlocks with_short_caption
  where
    el = elementWithContents "Caption" $ blocksToXML blocks
    with_short_caption = case (short) of
      Just inlines -> prependContents (asBlockOfInlines $ elementWithContents tgNameShortCaption $ inlinesToXML inlines) el
      _ -> el

colSpecToXML :: (Alignment, ColWidth) -> [Content]
colSpecToXML (align, cw) = asBlockOfInlines colspec
  where
    colspec = elementWithAttributes "ColSpec" $ validAttributes [(atNameAlignment, itemName align), (atNameColWidth, colwidth)]
    colwidth = case (cw) of
      ColWidth d -> T.pack $ show d
      ColWidthDefault -> "0"

colSpecsToXML :: [(Alignment, ColWidth)] -> [Content]
colSpecsToXML colspecs = asBlockOfBlocks $ elementWithContents tgNameColspecs $ concatMap colSpecToXML colspecs

tableHeadToXML :: TableHead -> [Content]
tableHeadToXML (TableHead attr rows) = asBlockOfBlocks $ elementWithAttrAndContents "TableHead" attr $ concatMap rowToXML rows

tableBodyToXML :: TableBody -> [Content]
tableBodyToXML (TableBody (idn, cls, attrs) (RowHeadColumns headcols) hrows brows) = asBlockOfBlocks $ elementWithAttrAndContents "TableBody" attr children
  where
    attr = (idn, cls, (atNameRowHeadColumns, intAsText headcols) : attrs)
    header_rows = asBlockOfBlocks $ elementWithContents tgNameBodyHeader $ concatMap rowToXML hrows
    body_rows = asBlockOfBlocks $ elementWithContents tgNameBodyBody $ concatMap rowToXML brows
    children = header_rows ++ body_rows

tableFootToXML :: TableFoot -> [Content]
tableFootToXML (TableFoot attr rows) = asBlockOfBlocks $ elementWithAttrAndContents "TableFoot" attr $ concatMap rowToXML rows

rowToXML :: Row -> [Content]
rowToXML (Row attr cells) = asBlockOfBlocks $ elementWithAttrAndContents "Row" attr $ concatMap cellToXML cells

cellToXML :: Cell -> [Content]
cellToXML (Cell (idn, cls, attrs) alignment (RowSpan rowspan) (ColSpan colspan) blocks) = asBlockOfBlocks $ elementWithAttrAndContents "Cell" attr $ blocksToXML blocks
  where
    with_alignment a = (atNameAlignment, itemName alignment) : a
    with_rowspan a = if rowspan > 1 then (atNameRowspan, intAsText rowspan) : a else a
    with_colspan a = if colspan > 1 then (atNameColspan, intAsText colspan) : a else a
    attrs' = (with_colspan . with_rowspan . with_alignment) attrs
    attr = (idn, cls, attrs')