From 4f3434586743afb69f00ca91fe6ec9b68b39ae7e Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Fri, 8 Jan 2021 18:38:20 +0100
Subject: Update copyright notices for 2021 (#7012)

---
 src/Text/Pandoc/Writers/JATS/Table.hs | 2 +-
 src/Text/Pandoc/Writers/JATS/Types.hs | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

(limited to 'src/Text/Pandoc/Writers/JATS')

diff --git a/src/Text/Pandoc/Writers/JATS/Table.hs b/src/Text/Pandoc/Writers/JATS/Table.hs
index a4d42832d..465480f59 100644
--- a/src/Text/Pandoc/Writers/JATS/Table.hs
+++ b/src/Text/Pandoc/Writers/JATS/Table.hs
@@ -3,7 +3,7 @@
 {-# LANGUAGE TupleSections #-}
 {- |
    Module      : Text.Pandoc.Writers.JATS.Table
-   Copyright   : © 2020 Albert Krewinkel
+   Copyright   : © 2020-2021 Albert Krewinkel
    License     : GNU GPL, version 2 or above
 
    Maintainer  : Albert Krewinkel <tarleb@zeitkraut.de>
diff --git a/src/Text/Pandoc/Writers/JATS/Types.hs b/src/Text/Pandoc/Writers/JATS/Types.hs
index 8162f3bc0..54ed4a8bd 100644
--- a/src/Text/Pandoc/Writers/JATS/Types.hs
+++ b/src/Text/Pandoc/Writers/JATS/Types.hs
@@ -1,6 +1,6 @@
 {- |
    Module      : Text.Pandoc.Writers.JATS.Types
-   Copyright   : Copyright (C) 2017-2020 John MacFarlane
+   Copyright   : Copyright (C) 2017-2021 John MacFarlane
    License     : GNU GPL, version 2 or above
 
    Maintainer  : John MacFarlane <jgm@berkeley.edu>
-- 
cgit v1.2.3


From b4b3560191b3699dd4db9d069244925a3c6074db Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Wed, 20 Jan 2021 19:09:36 +0100
Subject: JATS writer: allow to use element-citation

---
 MANUAL.txt                                 |   7 ++
 pandoc.cabal                               |   1 +
 src/Text/Pandoc/Extensions.hs              |  14 +++
 src/Text/Pandoc/Writers/JATS.hs            |  21 ++--
 src/Text/Pandoc/Writers/JATS/References.hs | 160 +++++++++++++++++++++++++++++
 src/Text/Pandoc/Writers/JATS/Types.hs      |   4 +-
 test/command/7042.md                       | 146 ++++++++++++++++++++++++++
 7 files changed, 346 insertions(+), 7 deletions(-)
 create mode 100644 src/Text/Pandoc/Writers/JATS/References.hs
 create mode 100644 test/command/7042.md

(limited to 'src/Text/Pandoc/Writers/JATS')

diff --git a/MANUAL.txt b/MANUAL.txt
index b9c4ef637..7bf74a8f9 100644
--- a/MANUAL.txt
+++ b/MANUAL.txt
@@ -3093,6 +3093,13 @@ output format.
 Some aspects of [Pandoc's Markdown citation syntax](#citations)
 are also accepted in `org` input.
 
+#### Extension: `element_citations` ####
+
+In the `jats` output formats, this causes reference items to
+be replaced with `<element-citation>` elements. These
+elements are not influenced by CSL styles, but all information
+on the item is included in tags.
+
 #### Extension: `ntb` ####
 
 In the `context` output format this enables the use of [Natural Tables
diff --git a/pandoc.cabal b/pandoc.cabal
index 0d63cbe35..07feb10dd 100644
--- a/pandoc.cabal
+++ b/pandoc.cabal
@@ -638,6 +638,7 @@ library
                    Text.Pandoc.Readers.Metadata,
                    Text.Pandoc.Readers.Roff,
                    Text.Pandoc.Writers.Docx.StyleMap,
+                   Text.Pandoc.Writers.JATS.References,
                    Text.Pandoc.Writers.JATS.Table,
                    Text.Pandoc.Writers.JATS.Types,
                    Text.Pandoc.Writers.LaTeX.Caption,
diff --git a/src/Text/Pandoc/Extensions.hs b/src/Text/Pandoc/Extensions.hs
index 39c2a0489..7aa32c52c 100644
--- a/src/Text/Pandoc/Extensions.hs
+++ b/src/Text/Pandoc/Extensions.hs
@@ -88,6 +88,7 @@ data Extension =
                                   --   does not affect readers/writers directly; it causes
                                   --   the eastAsianLineBreakFilter to be applied after
                                   --   parsing, in Text.Pandoc.App.convertWithOpts.
+    | Ext_element_citations   -- ^ Use element-citation elements for JATS citations
     | Ext_emoji               -- ^ Support emoji like :smile:
     | Ext_empty_paragraphs -- ^ Allow empty paragraphs
     | Ext_epub_html_exts      -- ^ Recognise the EPUB extended version of HTML
@@ -412,6 +413,11 @@ getDefaultExtensions "textile"         = extensionsFromList
                                            Ext_smart,
                                            Ext_raw_html,
                                            Ext_auto_identifiers]
+getDefaultExtensions "jats"            = extensionsFromList
+                                          [Ext_auto_identifiers]
+getDefaultExtensions "jats_archiving"  = getDefaultExtensions "jats"
+getDefaultExtensions "jats_publishing" = getDefaultExtensions "jats"
+getDefaultExtensions "jats_articleauthoring" = getDefaultExtensions "jats"
 getDefaultExtensions "opml"            = pandocExtensions -- affects notes
 getDefaultExtensions _                 = extensionsFromList
                                           [Ext_auto_identifiers]
@@ -554,6 +560,14 @@ getAllExtensions f = universalExtensions <> getAll f
     , Ext_smart
     , Ext_raw_tex
     ]
+  getAll "jats"            =
+    extensionsFromList
+    [ Ext_auto_identifiers
+    , Ext_element_citations
+    ]
+  getAll "jats_archiving"  = getAll "jats"
+  getAll "jats_publishing" = getAll "jats"
+  getAll "jats_articleauthoring" = getAll "jats"
   getAll "opml"            = allMarkdownExtensions -- affects notes
   getAll "twiki"           = autoIdExtensions <>
     extensionsFromList
diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs
index c75d40745..a9369db7a 100644
--- a/src/Text/Pandoc/Writers/JATS.hs
+++ b/src/Text/Pandoc/Writers/JATS.hs
@@ -29,6 +29,7 @@ import Data.Maybe (fromMaybe)
 import Data.Time (toGregorian, Day, parseTimeM, defaultTimeLocale, formatTime)
 import qualified Data.Text as T
 import Data.Text (Text)
+import Text.Pandoc.Citeproc (getReferences)
 import Text.Pandoc.Class.PandocMonad (PandocMonad, report)
 import Text.Pandoc.Definition
 import Text.Pandoc.Highlighting (languages, languagesByExtension)
@@ -40,6 +41,7 @@ import Text.DocLayout
 import Text.Pandoc.Shared
 import Text.Pandoc.Templates (renderTemplate)
 import Text.DocTemplates (Context(..), Val(..))
+import Text.Pandoc.Writers.JATS.References (referencesToJATS)
 import Text.Pandoc.Writers.JATS.Table (tableToJATS)
 import Text.Pandoc.Writers.JATS.Types
 import Text.Pandoc.Writers.Math
@@ -71,15 +73,19 @@ writeJATS = writeJatsArchiving
 
 -- | Convert a @'Pandoc'@ document to JATS.
 writeJats :: PandocMonad m => JATSTagSet -> WriterOptions -> Pandoc -> m Text
-writeJats tagSet opts d =
-  runReaderT (evalStateT (docToJATS opts d) initialState)
-             environment
-  where initialState = JATSState { jatsNotes = [] }
-        environment = JATSEnv
+writeJats tagSet opts d = do
+  refs <- if extensionEnabled Ext_element_citations $ writerExtensions opts
+          then getReferences Nothing d
+          else pure []
+  let environment = JATSEnv
           { jatsTagSet = tagSet
           , jatsInlinesWriter = inlinesToJATS
           , jatsBlockWriter = blockToJATS
+          , jatsReferences = refs
           }
+  let initialState = JATSState { jatsNotes = [] }
+  runReaderT (evalStateT (docToJATS opts d) initialState)
+             environment
 
 -- | Convert Pandoc document to string in JATS format.
 docToJATS :: PandocMonad m => WriterOptions -> Pandoc -> JATS m Text
@@ -258,7 +264,10 @@ blockToJATS opts (Div (ident,_,_) [Para lst]) | "ref-" `T.isPrefixOf` ident =
   inTagsSimple "mixed-citation" <$>
   inlinesToJATS opts lst
 blockToJATS opts (Div ("refs",_,_) xs) = do
-  contents <- blocksToJATS opts xs
+  refs <- asks jatsReferences
+  contents <- if null refs
+              then blocksToJATS opts xs
+              else referencesToJATS opts refs
   return $ inTagsIndented "ref-list" contents
 blockToJATS opts (Div (ident,[cls],kvs) bs) | cls `elem` ["fig", "caption", "table-wrap"] = do
   contents <- blocksToJATS opts bs
diff --git a/src/Text/Pandoc/Writers/JATS/References.hs b/src/Text/Pandoc/Writers/JATS/References.hs
new file mode 100644
index 000000000..4ee7eb9dd
--- /dev/null
+++ b/src/Text/Pandoc/Writers/JATS/References.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+   Module      : Text.Pandoc.Writers.JATS.References
+   Copyright   : © 2021 Albert Krewinkel
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : Albert Krewinkel <tarleb@zeitkraut.de>
+   Stability   : alpha
+   Portability : portable
+
+Creation of a bibliography list using @<element-citation>@ elements in
+reference items.
+-}
+module Text.Pandoc.Writers.JATS.References
+  ( referencesToJATS
+  , referenceToJATS
+  ) where
+
+import Citeproc.Pandoc ()
+import Citeproc.Types
+  ( Date (..), DateParts (..), ItemId (..), Name (..), Reference (..)
+  , Val (..) , lookupVariable, valToText
+  )
+import Data.Text (Text)
+import Text.DocLayout (Doc, empty, isEmpty, literal, vcat)
+import Text.Pandoc.Class.PandocMonad (PandocMonad)
+import Text.Pandoc.Builder (Inlines)
+import Text.Pandoc.Options (WriterOptions)
+import Text.Pandoc.Shared (tshow)
+import Text.Pandoc.Writers.JATS.Types
+import Text.Pandoc.XML (inTags)
+import qualified Data.Text as T
+
+referencesToJATS :: PandocMonad m
+                 => WriterOptions
+                 -> [Reference Inlines]
+                 -> JATS m (Doc Text)
+referencesToJATS opts =
+  fmap (inTags True "ref-list" [] . vcat) . mapM (referenceToJATS opts)
+
+referenceToJATS :: PandocMonad m
+                => WriterOptions
+                -> Reference Inlines
+                -> JATS m (Doc Text)
+referenceToJATS _opts ref = do
+  let refType = referenceType ref
+  let pubType = [("publication-type", refType) | not (T.null refType)]
+  let wrap = inTags True "ref" [("id", "ref-" <> unItemId (referenceId ref))]
+           . inTags True "element-citation" pubType
+  return . wrap . vcat $
+    [ authors
+    , "title" `varInTag`
+      if refType == "book"
+      then "source"
+      else "article-title"
+    , if refType == "book"
+      then empty
+      else "container-title" `varInTag` "source"
+    , editors
+    , "publisher"       `varInTag` "publisher-name"
+    , "publisher-place" `varInTag` "publisher-loc"
+    , yearTag
+    , accessed
+    , "volume"          `varInTag` "volume"
+    , "issue"           `varInTag` "issue"
+    , "page-first"      `varInTag` "fpage"
+    , "page-last"       `varInTag` "lpage"
+    , "pages"           `varInTag` "page-range"
+    , "ISBN"            `varInTag` "isbn"
+    , "ISSN"            `varInTag` "issn"
+    , varInTagWith "doi"  "pub-id" [("pub-id-type", "doi")]
+    , varInTagWith "pmid" "pub-id" [("pub-id-type", "pmid")]
+    ]
+  where
+    varInTag var tagName = varInTagWith var tagName []
+
+    varInTagWith var tagName tagAttribs =
+      case lookupVariable var ref >>= valToText of
+        Nothing  -> mempty
+        Just val -> inTags' tagName tagAttribs $ literal val
+
+    authors = case lookupVariable "author" ref of
+      Just (NamesVal names) ->
+        inTags True "person-group" [("person-group-type", "author")] . vcat $
+        map toNameElements names
+      _                     -> empty
+
+    editors = case lookupVariable "editor" ref of
+      Just (NamesVal names) ->
+        inTags True "person-group" [("person-group-type", "editor")] . vcat $
+        map toNameElements names
+      _                     -> empty
+
+    yearTag =
+      case lookupVariable "issued" ref of
+        Just (DateVal date) -> toDateElements date
+        _ -> empty
+
+    accessed =
+      case lookupVariable "accessed" ref of
+        Just (DateVal d) -> inTags' "date-in-citation"
+                                    [("content-type", "access-date")]
+                                    (toDateElements d)
+        _ -> empty
+
+toDateElements :: Date -> Doc Text
+toDateElements date =
+  case dateParts date of
+    dp@(DateParts (y:m:d:_)):_ -> yearElement y dp <>
+                                  monthElement m <>
+                                  dayElement d
+    dp@(DateParts (y:m:_)):_   -> yearElement y dp <> monthElement m
+    dp@(DateParts (y:_)):_     -> yearElement y dp
+    _                          -> empty
+
+yearElement :: Int -> DateParts -> Doc Text
+yearElement year dp =
+  inTags' "year" [("iso-8601-date", iso8601 dp)] $ literal (fourDigits year)
+
+monthElement :: Int -> Doc Text
+monthElement month = inTags' "month" [] . literal $ twoDigits month
+
+dayElement :: Int -> Doc Text
+dayElement day = inTags' "day" [] . literal $ twoDigits day
+
+iso8601 :: DateParts -> Text
+iso8601 = T.intercalate "-" . \case
+  DateParts (y:m:d:_) -> [fourDigits y, twoDigits m, twoDigits d]
+  DateParts (y:m:_)   -> [fourDigits y, twoDigits m]
+  DateParts (y:_)     -> [fourDigits y]
+  _                   -> []
+
+twoDigits :: Int -> Text
+twoDigits n = T.takeEnd 2 $ '0' `T.cons` tshow n
+
+fourDigits :: Int -> Text
+fourDigits n = T.takeEnd 4 $ "000" <> tshow n
+
+toNameElements :: Name -> Doc Text
+toNameElements name =
+  if not (isEmpty nameTags)
+  then inTags' "name" [] nameTags
+  else nameLiteral name `inNameTag` "string-name"
+    where
+      inNameTag val tag = maybe empty (inTags' tag [] . literal) val
+      surnamePrefix = maybe mempty (`T.snoc` ' ') $
+                      nameNonDroppingParticle name
+      givenSuffix = maybe mempty (T.cons ' ') $
+                    nameDroppingParticle name
+      nameTags = mconcat
+        [ ((surnamePrefix <>) <$> nameFamily name) `inNameTag` "surname"
+        , ((<> givenSuffix) <$> nameGiven name) `inNameTag` "given-names"
+        , nameSuffix name `inNameTag` "suffix"
+        ]
+
+-- | Put the supplied contents between start and end tags of tagType,
+--   with specified attributes.
+inTags' :: Text -> [(Text, Text)] -> Doc Text -> Doc Text
+inTags' = inTags False
diff --git a/src/Text/Pandoc/Writers/JATS/Types.hs b/src/Text/Pandoc/Writers/JATS/Types.hs
index 54ed4a8bd..6fdddc0b5 100644
--- a/src/Text/Pandoc/Writers/JATS/Types.hs
+++ b/src/Text/Pandoc/Writers/JATS/Types.hs
@@ -17,11 +17,12 @@ module Text.Pandoc.Writers.JATS.Types
   )
 where
 
+import Citeproc.Types (Reference)
 import Control.Monad.Reader (ReaderT)
 import Control.Monad.State (StateT)
 import Data.Text (Text)
 import Text.DocLayout (Doc)
-import Text.Pandoc.Definition (Block, Inline)
+import Text.Pandoc.Builder (Block, Inline, Inlines)
 import Text.Pandoc.Options (WriterOptions)
 
 -- | JATS tag set variant
@@ -40,6 +41,7 @@ data JATSEnv m = JATSEnv
   { jatsTagSet :: JATSTagSet
   , jatsInlinesWriter :: WriterOptions -> [Inline] -> JATS m (Doc Text)
   , jatsBlockWriter   :: WriterOptions -> Block    -> JATS m (Doc Text)
+  , jatsReferences    :: [Reference Inlines]
   }
 
 -- | JATS writer type
diff --git a/test/command/7042.md b/test/command/7042.md
new file mode 100644
index 000000000..de0294da3
--- /dev/null
+++ b/test/command/7042.md
@@ -0,0 +1,146 @@
+```
+% pandoc -f markdown -t jats_publishing+element_citations --citeproc -s
+---
+nocite: "[@*]"
+references:
+- author:
+  - family: Jane
+    given: Doe
+  container-title: Public Library of Tests
+  id: year-month
+  issued: 1999-08
+  title: Year and month
+  type: article-journal
+- accessed: 1999-01-22
+  author:
+  - family: Negidius
+    given: Numerius
+  container-title: Public Library of Tests
+  id: access-date
+  issued: 1911-10-03
+  title: Entry with access date
+  type: article-journal
+- author:
+  - family: Beethoven
+    given: Ludwig
+    dropping-particle: van
+  - family: Bray
+    given: Jan
+    non-dropping-particle: de
+  container-title: Public Library of Tests
+  id: name-particles
+  issued: 1820
+  title: Name particles, dropping and non-dropping
+  type: article-journal
+- author:
+  - 宮水 三葉
+  - 立花 瀧
+  title: Big Book of Tests
+  id: book-with-japanese-authors
+  issued: 2016
+  type: book
+- author:
+  - family: Watson
+    given: J. D.
+  - family: Crick
+    given: F. H. C.
+  container-title: Nature
+  doi: '10.1038/171737a0'
+  id: full-journal-article-entry
+  issue: 4356
+  issued: '1953-04-01'
+  pages: 737-738
+  pmid: 13054692
+  title: 'Molecular Structure of Nucleic Acids: A Structure for Deoxyribose Nucleic Acid'
+  type: article-journal
+  volume: 171
+...
+^D
+<?xml version="1.0" encoding="utf-8" ?>
+<!DOCTYPE article PUBLIC "-//NLM//DTD JATS (Z39.96) Journal Publishing DTD v1.2 20190208//EN"
+                  "JATS-publishing1.dtd">
+<article xmlns:mml="http://www.w3.org/1998/Math/MathML" xmlns:xlink="http://www.w3.org/1999/xlink" dtd-version="1.2" article-type="other">
+<front>
+<journal-meta>
+<journal-id></journal-id>
+<journal-title-group>
+</journal-title-group>
+<issn></issn>
+<publisher>
+<publisher-name></publisher-name>
+</publisher>
+</journal-meta>
+<article-meta>
+</article-meta>
+</front>
+<body>
+
+</body>
+<back>
+<ref-list>
+  <ref-list>
+    <ref id="ref-year-month">
+      <element-citation publication-type="article-journal">
+        <person-group person-group-type="author">
+          <name><surname>Jane</surname><given-names>Doe</given-names></name>
+        </person-group>
+        <article-title>Year and month</article-title>
+        <source>Public Library of Tests</source>
+        <year iso-8601-date="1999-08">1999</year><month>08</month>
+      </element-citation>
+    </ref>
+    <ref id="ref-access-date">
+      <element-citation publication-type="article-journal">
+        <person-group person-group-type="author">
+          <name><surname>Negidius</surname><given-names>Numerius</given-names></name>
+        </person-group>
+        <article-title>Entry with access date</article-title>
+        <source>Public Library of Tests</source>
+        <year iso-8601-date="1911-10-03">1911</year><month>10</month><day>03</day>
+        <date-in-citation content-type="access-date"><year iso-8601-date="1999-01-22">1999</year><month>01</month><day>22</day></date-in-citation>
+      </element-citation>
+    </ref>
+    <ref id="ref-name-particles">
+      <element-citation publication-type="article-journal">
+        <person-group person-group-type="author">
+          <name><surname>Beethoven</surname><given-names>Ludwig van</given-names></name>
+          <name><surname>de Bray</surname><given-names>Jan</given-names></name>
+        </person-group>
+        <article-title>Name particles, dropping and non-dropping</article-title>
+        <source>Public Library of Tests</source>
+        <year iso-8601-date="1820">1820</year>
+      </element-citation>
+    </ref>
+    <ref id="ref-book-with-japanese-authors">
+      <element-citation publication-type="book">
+        <person-group person-group-type="author">
+          <string-name>宮水 三葉</string-name>
+          <string-name>立花 瀧</string-name>
+        </person-group>
+        <source>Big Book of Tests</source>
+        <year iso-8601-date="2016">2016</year>
+      </element-citation>
+    </ref>
+    <ref id="ref-full-journal-article-entry">
+      <element-citation publication-type="article-journal">
+        <person-group person-group-type="author">
+          <name><surname>Watson</surname><given-names>J. D.</given-names></name>
+          <name><surname>Crick</surname><given-names>F. H. C.</given-names></name>
+        </person-group>
+        <article-title>Molecular Structure of Nucleic Acids: A Structure for Deoxyribose Nucleic Acid</article-title>
+        <source>Nature</source>
+        <year iso-8601-date="1953-04-01">1953</year><month>04</month><day>01</day>
+        <volume>171</volume>
+        <issue>4356</issue>
+        <fpage>737</fpage>
+        <page-range>737-738</page-range>
+        <pub-id pub-id-type="doi">10.1038/171737a0</pub-id>
+        <pub-id pub-id-type="pmid">13054692</pub-id>
+      </element-citation>
+    </ref>
+  </ref-list>
+</ref-list>
+</back>
+</article>
+
+```
-- 
cgit v1.2.3


From 300b9b0ea365187240115afbfed0df7fa438a7b3 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Fri, 29 Jan 2021 09:37:45 +0100
Subject: JATS writer: escape special chars in reference elements.

Prevents the generation of invalid markup if a citation element contains
an ampersand or another character with a special meaning in XML.
---
 src/Text/Pandoc/Writers/JATS/References.hs | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

(limited to 'src/Text/Pandoc/Writers/JATS')

diff --git a/src/Text/Pandoc/Writers/JATS/References.hs b/src/Text/Pandoc/Writers/JATS/References.hs
index 4ee7eb9dd..903144128 100644
--- a/src/Text/Pandoc/Writers/JATS/References.hs
+++ b/src/Text/Pandoc/Writers/JATS/References.hs
@@ -29,7 +29,7 @@ import Text.Pandoc.Builder (Inlines)
 import Text.Pandoc.Options (WriterOptions)
 import Text.Pandoc.Shared (tshow)
 import Text.Pandoc.Writers.JATS.Types
-import Text.Pandoc.XML (inTags)
+import Text.Pandoc.XML (escapeStringForXML, inTags)
 import qualified Data.Text as T
 
 referencesToJATS :: PandocMonad m
@@ -78,7 +78,8 @@ referenceToJATS _opts ref = do
     varInTagWith var tagName tagAttribs =
       case lookupVariable var ref >>= valToText of
         Nothing  -> mempty
-        Just val -> inTags' tagName tagAttribs $ literal val
+        Just val -> inTags' tagName tagAttribs . literal $
+                    escapeStringForXML val
 
     authors = case lookupVariable "author" ref of
       Just (NamesVal names) ->
@@ -143,7 +144,9 @@ toNameElements name =
   then inTags' "name" [] nameTags
   else nameLiteral name `inNameTag` "string-name"
     where
-      inNameTag val tag = maybe empty (inTags' tag [] . literal) val
+      inNameTag mVal tag = case mVal of
+        Nothing  -> empty
+        Just val -> inTags' tag [] . literal $ escapeStringForXML val
       surnamePrefix = maybe mempty (`T.snoc` ' ') $
                       nameNonDroppingParticle name
       givenSuffix = maybe mempty (T.cons ' ') $
-- 
cgit v1.2.3


From 038261ea529bc4516d7cee501db70020938dbf2b Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Mon, 5 Apr 2021 21:45:52 +0200
Subject: JATS writer: escape disallows chars in identifiers

XML identifiers must start with an underscore or letter, and can contain
only a limited set of punctuation characters. Any IDs not adhering to
these rules are rewritten by writing the offending characters as Uxxxx,
where `xxxx` is the character's hex code.
---
 src/Text/Pandoc/Writers/JATS.hs            |  27 ++--
 src/Text/Pandoc/Writers/JATS/References.hs |   5 +-
 src/Text/Pandoc/Writers/JATS/Table.hs      |   4 +-
 src/Text/Pandoc/XML.hs                     |  30 ++++-
 test/Tests/Writers/JATS.hs                 | 205 ++++++++++++++++-------------
 5 files changed, 162 insertions(+), 109 deletions(-)

(limited to 'src/Text/Pandoc/Writers/JATS')

diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs
index a9369db7a..26f94cb03 100644
--- a/src/Text/Pandoc/Writers/JATS.hs
+++ b/src/Text/Pandoc/Writers/JATS.hs
@@ -239,7 +239,7 @@ languageFor classes =
 codeAttr :: Attr -> (Text, [(Text, Text)])
 codeAttr (ident,classes,kvs) = (lang, attr)
     where
-       attr = [("id",ident) | not (T.null ident)] ++
+       attr = [("id", escapeNCName ident) | not (T.null ident)] ++
               [("language",lang) | not (T.null lang)] ++
               [(k,v) | (k,v) <- kvs, k `elem` ["code-type",
                 "code-version", "executable",
@@ -251,7 +251,8 @@ codeAttr (ident,classes,kvs) = (lang, attr)
 blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m (Doc Text)
 blockToJATS _ Null = return empty
 blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do
-  let idAttr = [("id", writerIdentifierPrefix opts <> id') | not (T.null id')]
+  let idAttr = [ ("id", writerIdentifierPrefix opts <> escapeNCName id')
+               | not (T.null id')]
   let otherAttrs = ["sec-type", "specific-use"]
   let attribs = idAttr ++ [(k,v) | (k,v) <- kvs, k `elem` otherAttrs]
   title' <- inlinesToJATS opts ils
@@ -260,7 +261,7 @@ blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do
       inTagsSimple "title" title' $$ contents
 -- Bibliography reference:
 blockToJATS opts (Div (ident,_,_) [Para lst]) | "ref-" `T.isPrefixOf` ident =
-  inTags True "ref" [("id", ident)] .
+  inTags True "ref" [("id", escapeNCName ident)] .
   inTagsSimple "mixed-citation" <$>
   inlinesToJATS opts lst
 blockToJATS opts (Div ("refs",_,_) xs) = do
@@ -271,14 +272,14 @@ blockToJATS opts (Div ("refs",_,_) xs) = do
   return $ inTagsIndented "ref-list" contents
 blockToJATS opts (Div (ident,[cls],kvs) bs) | cls `elem` ["fig", "caption", "table-wrap"] = do
   contents <- blocksToJATS opts bs
-  let attr = [("id", ident) | not (T.null ident)] ++
+  let attr = [("id", escapeNCName ident) | not (T.null ident)] ++
              [("xml:lang",l) | ("lang",l) <- kvs] ++
              [(k,v) | (k,v) <- kvs, k `elem` ["specific-use",
                  "content-type", "orientation", "position"]]
   return $ inTags True cls attr contents
 blockToJATS opts (Div (ident,_,kvs) bs) = do
   contents <- blocksToJATS opts bs
-  let attr = [("id", ident) | not (T.null ident)] ++
+  let attr = [("id", escapeNCName ident) | not (T.null ident)] ++
              [("xml:lang",l) | ("lang",l) <- kvs] ++
              [(k,v) | (k,v) <- kvs, k `elem` ["specific-use",
                  "content-type", "orientation", "position"]]
@@ -296,7 +297,7 @@ blockToJATS opts (Para [Image (ident,_,kvs) txt
   let capt = if null txt
                 then empty
                 else inTagsSimple "caption" $ inTagsSimple "p" alt
-  let attr = [("id", ident) | not (T.null ident)] ++
+  let attr = [("id", escapeNCName ident) | not (T.null ident)] ++
              [(k,v) | (k,v) <- kvs, k `elem` ["fig-type", "orientation",
                                               "position", "specific-use"]]
   let graphicattr = [("mimetype",maintype),
@@ -307,7 +308,7 @@ blockToJATS opts (Para [Image (ident,_,kvs) txt
               capt $$ selfClosingTag "graphic" graphicattr
 blockToJATS _ (Para [Image (ident,_,kvs) _ (src, tit)]) = do
   let (maintype, subtype) = imageMimeType src kvs
-  let attr = [("id", ident) | not (T.null ident)] ++
+  let attr = [("id", escapeNCName ident) | not (T.null ident)] ++
              [("mimetype", maintype),
               ("mime-subtype", subtype),
               ("xlink:href", src)] ++
@@ -434,7 +435,7 @@ inlineToJATS opts (Note contents) = do
       let notenum = case notes of
                       (n, _):_ -> n + 1
                       []       -> 1
-      thenote <- inTags True "fn" [("id","fn" <> tshow notenum)]
+      thenote <- inTags True "fn" [("id", "fn" <> tshow notenum)]
                     <$> wrappedBlocksToJATS (not . isPara) opts
                          (walk demoteHeaderAndRefs contents)
       modify $ \st -> st{ jatsNotes = (notenum, thenote) : notes }
@@ -447,7 +448,7 @@ inlineToJATS opts (Cite _ lst) =
 inlineToJATS opts (Span ("",_,[]) ils) = inlinesToJATS opts ils
 inlineToJATS opts (Span (ident,_,kvs) ils) = do
   contents <- inlinesToJATS opts ils
-  let attr = [("id",ident) | not (T.null ident)] ++
+  let attr = [("id", escapeNCName ident) | not (T.null ident)] ++
              [("xml:lang",l) | ("lang",l) <- kvs] ++
              [(k,v) | (k,v) <- kvs
                     ,  k `elem` ["content-type", "rationale",
@@ -488,9 +489,9 @@ inlineToJATS _ (Link _attr [Str t] (T.stripPrefix "mailto:" -> Just email, _))
   return $ inTagsSimple "email" $ literal (escapeStringForXML email)
 inlineToJATS opts (Link (ident,_,kvs) txt (T.uncons -> Just ('#', src), _)) = do
   let attr = mconcat
-             [ [("id", ident) | not (T.null ident)]
+             [ [("id", escapeNCName ident) | not (T.null ident)]
              , [("alt", stringify txt) | not (null txt)]
-             , [("rid", src)]
+             , [("rid", escapeNCName src)]
              , [(k,v) | (k,v) <- kvs, k `elem` ["ref-type", "specific-use"]]
              , [("ref-type", "bibr") | "ref-" `T.isPrefixOf` src]
              ]
@@ -500,7 +501,7 @@ inlineToJATS opts (Link (ident,_,kvs) txt (T.uncons -> Just ('#', src), _)) = do
         contents <- inlinesToJATS opts txt
         return $ inTags False "xref" attr contents
 inlineToJATS opts (Link (ident,_,kvs) txt (src, tit)) = do
-  let attr = [("id", ident) | not (T.null ident)] ++
+  let attr = [("id", escapeNCName ident) | not (T.null ident)] ++
              [("ext-link-type", "uri"),
               ("xlink:href", src)] ++
              [("xlink:title", tit) | not (T.null tit)] ++
@@ -518,7 +519,7 @@ inlineToJATS _ (Image (ident,_,kvs) _ (src, tit)) = do
   let subtype = fromMaybe "" $
                   lookup "mime-subtype" kvs `mplus`
                   (T.drop 1 . T.dropWhile (/='/') <$> mbMT)
-  let attr = [("id", ident) | not (T.null ident)] ++
+  let attr = [("id", escapeNCName ident) | not (T.null ident)] ++
              [("mimetype", maintype),
               ("mime-subtype", subtype),
               ("xlink:href", src)] ++
diff --git a/src/Text/Pandoc/Writers/JATS/References.hs b/src/Text/Pandoc/Writers/JATS/References.hs
index 903144128..5b19fd034 100644
--- a/src/Text/Pandoc/Writers/JATS/References.hs
+++ b/src/Text/Pandoc/Writers/JATS/References.hs
@@ -29,7 +29,7 @@ import Text.Pandoc.Builder (Inlines)
 import Text.Pandoc.Options (WriterOptions)
 import Text.Pandoc.Shared (tshow)
 import Text.Pandoc.Writers.JATS.Types
-import Text.Pandoc.XML (escapeStringForXML, inTags)
+import Text.Pandoc.XML (escapeNCName, escapeStringForXML, inTags)
 import qualified Data.Text as T
 
 referencesToJATS :: PandocMonad m
@@ -46,7 +46,8 @@ referenceToJATS :: PandocMonad m
 referenceToJATS _opts ref = do
   let refType = referenceType ref
   let pubType = [("publication-type", refType) | not (T.null refType)]
-  let wrap = inTags True "ref" [("id", "ref-" <> unItemId (referenceId ref))]
+  let ident = escapeNCName $ "ref-" <> unItemId (referenceId ref)
+  let wrap = inTags True "ref" [("id", ident)]
            . inTags True "element-citation" pubType
   return . wrap . vcat $
     [ authors
diff --git a/src/Text/Pandoc/Writers/JATS/Table.hs b/src/Text/Pandoc/Writers/JATS/Table.hs
index 465480f59..2e34900d2 100644
--- a/src/Text/Pandoc/Writers/JATS/Table.hs
+++ b/src/Text/Pandoc/Writers/JATS/Table.hs
@@ -24,7 +24,7 @@ import Text.Pandoc.Definition
 import Text.Pandoc.Options (WriterOptions)
 import Text.Pandoc.Shared (tshow)
 import Text.Pandoc.Writers.JATS.Types
-import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag)
+import Text.Pandoc.XML (escapeNCName, inTags, inTagsIndented, selfClosingTag)
 import qualified Data.Text as T
 import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
 
@@ -216,7 +216,7 @@ cellToJats opts celltype (Ann.Cell (colspec :| _) _colNum cell) =
 
 toAttribs :: Attr -> [Text] -> [(Text, Text)]
 toAttribs (ident, _classes, kvs) knownAttribs =
-  (if T.null ident then id else (("id", ident) :)) $
+  (if T.null ident then id else (("id", escapeNCName ident) :)) $
   filter ((`elem` knownAttribs) . fst) kvs
 
 tableCellToJats :: PandocMonad m
diff --git a/src/Text/Pandoc/XML.hs b/src/Text/Pandoc/XML.hs
index 6dbbce1d2..79b4768ec 100644
--- a/src/Text/Pandoc/XML.hs
+++ b/src/Text/Pandoc/XML.hs
@@ -13,6 +13,7 @@ Functions for escaping and formatting XML.
 -}
 module Text.Pandoc.XML ( escapeCharForXML,
                          escapeStringForXML,
+                         escapeNCName,
                          inTags,
                          selfClosingTag,
                          inTagsSimple,
@@ -24,7 +25,7 @@ module Text.Pandoc.XML ( escapeCharForXML,
                          html5Attributes,
                          rdfaAttributes ) where
 
-import Data.Char (isAscii, isSpace, ord)
+import Data.Char (isAscii, isSpace, ord, isLetter, isDigit)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Text.HTML.TagSoup.Entity (lookupEntity, htmlEntities)
@@ -119,8 +120,33 @@ html5EntityMap = foldr go mempty htmlEntities
              where ent' = T.takeWhile (/=';') (T.pack ent)
            _   -> entmap
 
+-- | Converts a string into an NCName, i.e., an XML name without colons.
+-- Disallowed characters are escaped using @ux%x@, where @%x@ is the
+-- hexadecimal unicode identifier of the escaped character.
+escapeNCName :: Text -> Text
+escapeNCName t = case T.uncons t of
+  Nothing -> T.empty
+  Just (c, cs) -> escapeStartChar c <> T.concatMap escapeNCNameChar cs
+  where
+    escapeStartChar :: Char -> Text
+    escapeStartChar c = if isLetter c || c == '_'
+                        then T.singleton c
+                        else escapeChar c
 
--- Unescapes XML entities
+    escapeNCNameChar :: Char -> Text
+    escapeNCNameChar c = if isNCNameChar c
+                         then T.singleton c
+                         else escapeChar c
+
+    isNCNameChar :: Char -> Bool
+    isNCNameChar c = isLetter c || c `elem` ("_-.·" :: String) || isDigit c
+      || '\x0300' <= c && c <= '\x036f'
+      || '\x203f' <= c && c <= '\x2040'
+
+    escapeChar :: Char -> Text
+    escapeChar = T.pack . printf "U%04X" . ord
+
+-- | Unescapes XML entities
 fromEntities :: Text -> Text
 fromEntities t
   = let (x, y) = T.break (== '&') t
diff --git a/test/Tests/Writers/JATS.hs b/test/Tests/Writers/JATS.hs
index 2f501c890..23c1686dc 100644
--- a/test/Tests/Writers/JATS.hs
+++ b/test/Tests/Writers/JATS.hs
@@ -1,21 +1,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Tests.Writers.JATS (tests) where
 
-import Data.Text (unpack)
+import Data.Text (Text)
 import Test.Tasty
 import Tests.Helpers
 import Text.Pandoc
 import Text.Pandoc.Arbitrary ()
 import Text.Pandoc.Builder
+import qualified Data.Text as T
 
-jats :: (ToPandoc a) => a -> String
-jats = unpack
-  . purely (writeJATS def{ writerWrapText = WrapNone })
-  . toPandoc
+jats :: (ToPandoc a) => a -> Text
+jats = purely (writeJATS def{ writerWrapText = WrapNone })
+     . toPandoc
 
-jatsArticleAuthoring :: (ToPandoc a) => a -> String
-jatsArticleAuthoring = unpack
-  . purely (writeJatsArticleAuthoring def{ writerWrapText = WrapNone })
+jatsArticleAuthoring :: (ToPandoc a) => a -> Text
+jatsArticleAuthoring =
+    purely (writeJatsArticleAuthoring def{ writerWrapText = WrapNone })
   . toPandoc
 
 {-
@@ -32,89 +32,114 @@ which is in turn shorthand for
 
 infix 4 =:
 (=:) :: (ToString a, ToPandoc a)
-     => String -> (a, String) -> TestTree
+     => String -> (a, Text) -> TestTree
 (=:) = test jats
 
 tests :: [TestTree]
-tests = [ testGroup "inline code"
-          [ "basic" =: code "@&" =?> "<p><monospace>@&amp;</monospace></p>"
-          , "lang" =: codeWith ("", ["c"], []) "@&" =?> "<p><code language=\"c\">@&amp;</code></p>"
-          ]
-        , testGroup "block code"
-          [ "basic" =: codeBlock "@&" =?> "<preformat>@&amp;</preformat>"
-          , "lang" =: codeBlockWith ("", ["c"], []) "@&" =?> "<code language=\"c\">@&amp;</code>"
-          ]
-        , testGroup "images"
-          [ "basic" =:
-            image "/url" "title" mempty
-            =?> "<graphic mimetype=\"image\" mime-subtype=\"\" xlink:href=\"/url\" xlink:title=\"title\" />"
-          ]
-        , testGroup "inlines"
-          [ "Emphasis" =: emph "emphasized"
-            =?> "<p><italic>emphasized</italic></p>"
+tests =
+  [ testGroup "inline code"
+    [ "basic" =: code "@&" =?> "<p><monospace>@&amp;</monospace></p>"
+    , "lang" =: codeWith ("", ["c"], []) "@&" =?> "<p><code language=\"c\">@&amp;</code></p>"
+    ]
+  , testGroup "block code"
+    [ "basic" =: codeBlock "@&" =?> "<preformat>@&amp;</preformat>"
+    , "lang" =: codeBlockWith ("", ["c"], []) "@&" =?> "<code language=\"c\">@&amp;</code>"
+    ]
+  , testGroup "images"
+    [ "basic" =:
+      image "/url" "title" mempty
+      =?> "<graphic mimetype=\"image\" mime-subtype=\"\" xlink:href=\"/url\" xlink:title=\"title\" />"
+    ]
+  , testGroup "inlines"
+    [ "Emphasis" =: emph "emphasized"
+      =?> "<p><italic>emphasized</italic></p>"
+
+    , test jatsArticleAuthoring "footnote in articleauthoring tag set"
+      ("test" <> note (para "footnote") =?>
+        unlines [ "<p>test<fn>"
+                , "  <p>footnote</p>"
+                , "</fn></p>"
+                ])
+    ]
+  , "bullet list" =: bulletList [ plain $ text "first"
+                                , plain $ text "second"
+                                , plain $ text "third"
+                                ]
+    =?> "<list list-type=\"bullet\">\n\
+        \  <list-item>\n\
+        \    <p>first</p>\n\
+        \  </list-item>\n\
+        \  <list-item>\n\
+        \    <p>second</p>\n\
+        \  </list-item>\n\
+        \  <list-item>\n\
+        \    <p>third</p>\n\
+        \  </list-item>\n\
+        \</list>"
+  , testGroup "definition lists"
+    [ "with internal link" =: definitionList [(link "#go" "" (str "testing"),
+                                               [plain (text "hi there")])] =?>
+      "<def-list>\n\
+      \  <def-item>\n\
+      \    <term><xref alt=\"testing\" rid=\"go\">testing</xref></term>\n\
+      \    <def>\n\
+      \      <p>hi there</p>\n\
+      \    </def>\n\
+      \  </def-item>\n\
+      \</def-list>"
+    ]
+  , testGroup "math"
+    [ "escape |" =: para (math "\\sigma|_{\\{x\\}}") =?>
+      "<p><inline-formula><alternatives>\n\
+      \<tex-math><![CDATA[\\sigma|_{\\{x\\}}]]></tex-math>\n\
+      \<mml:math display=\"inline\" xmlns:mml=\"http://www.w3.org/1998/Math/MathML\"><mml:mrow><mml:mi>σ</mml:mi><mml:msub><mml:mo stretchy=\"false\" form=\"prefix\">|</mml:mo><mml:mrow><mml:mo stretchy=\"false\" form=\"prefix\">{</mml:mo><mml:mi>x</mml:mi><mml:mo stretchy=\"false\" form=\"postfix\">}</mml:mo></mml:mrow></mml:msub></mml:mrow></mml:math></alternatives></inline-formula></p>"
+    ]
+  , testGroup "headers"
+    [ "unnumbered header" =:
+      headerWith ("foo",["unnumbered"],[]) 1
+      (text "Header 1" <> note (plain $ text "note")) =?>
+      "<sec id=\"foo\">\n\
+      \  <title>Header 1<xref ref-type=\"fn\" rid=\"fn1\">1</xref></title>\n\
+      \</sec>"
+    , "unnumbered sub header" =:
+      headerWith ("foo",["unnumbered"],[]) 1
+      (text "Header")
+      <> headerWith ("foo",["unnumbered"],[]) 2
+      (text "Sub-Header") =?>
+      "<sec id=\"foo\">\n\
+      \  <title>Header</title>\n\
+      \  <sec id=\"foo\">\n\
+      \    <title>Sub-Header</title>\n\
+      \  </sec>\n\
+      \</sec>"
+    , "containing image" =:
+      header 1 (image "imgs/foo.jpg" "" (text "Alt text")) =?>
+      "<sec>\n\
+      \  <title><inline-graphic mimetype=\"image\" mime-subtype=\"jpeg\" xlink:href=\"imgs/foo.jpg\" /></title>\n\
+      \</sec>"
+    ]
+
+  , testGroup "ids"
+    [ "non-ASCII in header ID" =:
+      headerWith ("smørbrød",[],[]) 1 (text "smørbrød") =?>
+      T.unlines [ "<sec id=\"smørbrød\">"
+                , "  <title>smørbrød</title>"
+                , "</sec>"
+                ]
+
+    , "disallowed symbol in header id" =:
+      headerWith ("i/o",[],[]) 1 (text "I/O") =?>
+      T.unlines [ "<sec id=\"iU002Fo\">"
+                , "  <title>I/O</title>"
+                , "</sec>"
+                ]
+
+    , "disallowed symbols in internal link target" =:
+      link "#foo:bar" "" "baz" =?>
+      "<p><xref alt=\"baz\" rid=\"fooU003Abar\">baz</xref></p>"
 
-          , test jatsArticleAuthoring "footnote in articleauthoring tag set"
-            ("test" <> note (para "footnote") =?>
-             unlines [ "<p>test<fn>"
-                     , "  <p>footnote</p>"
-                     , "</fn></p>"
-                     ])
-          ]
-        , "bullet list" =: bulletList [ plain $ text "first"
-                                      , plain $ text "second"
-                                      , plain $ text "third"
-                                      ]
-            =?> "<list list-type=\"bullet\">\n\
-                \  <list-item>\n\
-                \    <p>first</p>\n\
-                \  </list-item>\n\
-                \  <list-item>\n\
-                \    <p>second</p>\n\
-                \  </list-item>\n\
-                \  <list-item>\n\
-                \    <p>third</p>\n\
-                \  </list-item>\n\
-                \</list>"
-        , testGroup "definition lists"
-          [ "with internal link" =: definitionList [(link "#go" "" (str "testing"),
-             [plain (text "hi there")])] =?>
-            "<def-list>\n\
-            \  <def-item>\n\
-            \    <term><xref alt=\"testing\" rid=\"go\">testing</xref></term>\n\
-            \    <def>\n\
-            \      <p>hi there</p>\n\
-            \    </def>\n\
-            \  </def-item>\n\
-            \</def-list>"
-          ]
-        , testGroup "math"
-          [ "escape |" =: para (math "\\sigma|_{\\{x\\}}") =?>
-            "<p><inline-formula><alternatives>\n\
-            \<tex-math><![CDATA[\\sigma|_{\\{x\\}}]]></tex-math>\n\
-            \<mml:math display=\"inline\" xmlns:mml=\"http://www.w3.org/1998/Math/MathML\"><mml:mrow><mml:mi>σ</mml:mi><mml:msub><mml:mo stretchy=\"false\" form=\"prefix\">|</mml:mo><mml:mrow><mml:mo stretchy=\"false\" form=\"prefix\">{</mml:mo><mml:mi>x</mml:mi><mml:mo stretchy=\"false\" form=\"postfix\">}</mml:mo></mml:mrow></mml:msub></mml:mrow></mml:math></alternatives></inline-formula></p>"
-          ]
-        , testGroup "headers"
-          [ "unnumbered header" =:
-            headerWith ("foo",["unnumbered"],[]) 1
-              (text "Header 1" <> note (plain $ text "note")) =?>
-            "<sec id=\"foo\">\n\
-            \  <title>Header 1<xref ref-type=\"fn\" rid=\"fn1\">1</xref></title>\n\
-            \</sec>"
-          , "unnumbered sub header" =:
-            headerWith ("foo",["unnumbered"],[]) 1
-              (text "Header")
-            <> headerWith ("foo",["unnumbered"],[]) 2
-              (text "Sub-Header") =?>
-            "<sec id=\"foo\">\n\
-            \  <title>Header</title>\n\
-            \  <sec id=\"foo\">\n\
-            \    <title>Sub-Header</title>\n\
-            \  </sec>\n\
-            \</sec>"
-          , "containing image" =:
-            header 1 (image "imgs/foo.jpg" "" (text "Alt text")) =?>
-            "<sec>\n\
-            \  <title><inline-graphic mimetype=\"image\" mime-subtype=\"jpeg\" xlink:href=\"imgs/foo.jpg\" /></title>\n\
-            \</sec>"
-          ]
-        ]
+    , "code id starting with a number" =:
+      codeWith ("7y",[],[]) "print 5" =?>
+      "<p><monospace id=\"U0037y\">print 5</monospace></p>"
+    ]
+  ]
-- 
cgit v1.2.3


From 5f79a66ed64e9b0cc326e467dcb17239f1596fcc Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Fri, 16 Apr 2021 22:13:29 +0200
Subject: JATS writer: reduce unnecessary use of <p> elements for wrapping

The `<p>` element is used for wrapping in cases were the contents would
otherwise not be allowed in a certain context. Unnecessary wrapping is
avoided, especially around quotes (`<disp-quote>` elements).

Closes: #7227
---
 src/Text/Pandoc/Writers/JATS.hs       | 22 +++++----
 src/Text/Pandoc/Writers/JATS/Table.hs | 26 +++++++++--
 src/Text/Pandoc/Writers/JATS/Types.hs | 15 ++++--
 test/command/7041.md                  | 23 +++++++++
 test/writer.jats_archiving            | 68 +++++++++++----------------
 test/writer.jats_articleauthoring     | 88 ++++++++++++++++-------------------
 test/writer.jats_publishing           | 68 +++++++++++----------------
 7 files changed, 166 insertions(+), 144 deletions(-)
 create mode 100644 test/command/7041.md

(limited to 'src/Text/Pandoc/Writers/JATS')

diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs
index 5b3e439d4..b58ff8aef 100644
--- a/src/Text/Pandoc/Writers/JATS.hs
+++ b/src/Text/Pandoc/Writers/JATS.hs
@@ -1,6 +1,7 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns        #-}
 {- |
    Module      : Text.Pandoc.Writers.JATS
    Copyright   : 2017-2021 John MacFarlane
@@ -80,7 +81,7 @@ writeJats tagSet opts d = do
   let environment = JATSEnv
           { jatsTagSet = tagSet
           , jatsInlinesWriter = inlinesToJATS
-          , jatsBlockWriter = blockToJATS
+          , jatsBlockWriter = wrappedBlocksToJATS
           , jatsReferences = refs
           }
   let initialState = JATSState { jatsNotes = [] }
@@ -162,11 +163,9 @@ wrappedBlocksToJATS needsWrap opts =
     wrappedBlockToJATS b = do
       inner <- blockToJATS opts b
       return $
-        if needsWrap b || isBlockQuote b -- see #7041
+        if needsWrap b
            then inTags True "p" [("specific-use","wrapper")] inner
            else inner
-    isBlockQuote (BlockQuote _) = True
-    isBlockQuote _ = False
 
 -- | Auxiliary function to convert Plain block to Para.
 plainToPara :: Block -> Block
@@ -324,10 +323,13 @@ blockToJATS opts (LineBlock lns) =
   blockToJATS opts $ linesToPara lns
 blockToJATS opts (BlockQuote blocks) = do
   tagSet <- asks jatsTagSet
-  let blocksToJats' = if tagSet == TagSetArticleAuthoring
-                      then wrappedBlocksToJATS (not . isPara)
-                      else blocksToJATS
-  inTagsIndented "disp-quote" <$> blocksToJats' opts blocks
+  let needsWrap = if tagSet == TagSetArticleAuthoring
+                  then not . isPara
+                  else \case
+                    Header{}       -> True
+                    HorizontalRule -> True
+                    _              -> False
+  inTagsIndented "disp-quote" <$> wrappedBlocksToJATS needsWrap opts blocks
 blockToJATS _ (CodeBlock a str) = return $
   inTags False tag attr (flush (text (T.unpack $ escapeStringForXML str)))
     where (lang, attr) = codeAttr a
diff --git a/src/Text/Pandoc/Writers/JATS/Table.hs b/src/Text/Pandoc/Writers/JATS/Table.hs
index 2e34900d2..70569bdcd 100644
--- a/src/Text/Pandoc/Writers/JATS/Table.hs
+++ b/src/Text/Pandoc/Writers/JATS/Table.hs
@@ -34,13 +34,19 @@ tableToJATS :: PandocMonad m
             -> JATS m (Doc Text)
 tableToJATS opts (Ann.Table attr caption colspecs thead tbodies tfoot) = do
   let (Caption _maybeShortCaption captionBlocks) = caption
+  -- Only paragraphs are allowed in captions, all other blocks must be
+  -- wrapped in @<p>@ elements.
+  let needsWrapping = \case
+        Plain{} -> False
+        Para{}  -> False
+        _       -> True
   tbl <- captionlessTable opts attr colspecs thead tbodies tfoot
   captionDoc <- if null captionBlocks
                 then return empty
                 else do
                   blockToJATS <- asks jatsBlockWriter
-                  inTagsIndented "caption" . vcat <$>
-                    mapM (blockToJATS opts) captionBlocks
+                  inTagsIndented "caption" <$>
+                    blockToJATS needsWrapping opts captionBlocks
   return $ inTags True "table-wrap" [] $ captionDoc $$ tbl
 
 captionlessTable :: PandocMonad m
@@ -230,7 +236,7 @@ tableCellToJats opts ctype colAlign (Cell attr align rowspan colspan item) = do
   inlinesToJats <- asks jatsInlinesWriter
   let cellContents = \case
         [Plain inlines] -> inlinesToJats opts inlines
-        blocks          -> vcat <$> mapM (blockToJats opts) blocks
+        blocks          -> blockToJats needsWrapInCell opts blocks
   let tag' = case ctype of
         BodyCell   -> "td"
         HeaderCell -> "th"
@@ -246,3 +252,17 @@ tableCellToJats opts ctype colAlign (Cell attr align rowspan colspan item) = do
               . maybeCons (colspanAttrib colspan)
               $ toAttribs attr validAttribs
   inTags False tag' attribs <$> cellContents item
+
+-- | Whether the JATS produced from this block should be wrapped in a
+-- @<p>@ element when put directly below a @<td>@ element.
+needsWrapInCell :: Block -> Bool
+needsWrapInCell = \case
+  Plain{}          -> False  -- should be unwrapped anyway
+  Para{}           -> False
+  BulletList{}     -> False
+  OrderedList{}    -> False
+  DefinitionList{} -> False
+  HorizontalRule   -> False
+  CodeBlock{}      -> False
+  RawBlock{}       -> False  -- responsibility of the user
+  _                -> True
diff --git a/src/Text/Pandoc/Writers/JATS/Types.hs b/src/Text/Pandoc/Writers/JATS/Types.hs
index 6fdddc0b5..8d8673cf6 100644
--- a/src/Text/Pandoc/Writers/JATS/Types.hs
+++ b/src/Text/Pandoc/Writers/JATS/Types.hs
@@ -37,11 +37,20 @@ newtype JATSState = JATSState
   { jatsNotes :: [(Int, Doc Text)]
   }
 
+-- | Environment containing all information relevant for rendering.
 data JATSEnv m = JATSEnv
-  { jatsTagSet :: JATSTagSet
+  { jatsTagSet :: JATSTagSet  -- ^ The tag set that's being ouput
+
+  , jatsBlockWriter   :: (Block -> Bool)
+                      -> WriterOptions -> [Block]  -> JATS m (Doc Text)
+    -- ^ Converts a block list to JATS, wrapping top-level blocks into a
+    -- @<p>@ element if the property evaluates to @True@.
+    -- See #7227.
+
   , jatsInlinesWriter :: WriterOptions -> [Inline] -> JATS m (Doc Text)
-  , jatsBlockWriter   :: WriterOptions -> Block    -> JATS m (Doc Text)
-  , jatsReferences    :: [Reference Inlines]
+    -- ^ Converts an inline list to JATS.
+
+  , jatsReferences    :: [Reference Inlines] -- ^ List of references
   }
 
 -- | JATS writer type
diff --git a/test/command/7041.md b/test/command/7041.md
new file mode 100644
index 000000000..1773963b8
--- /dev/null
+++ b/test/command/7041.md
@@ -0,0 +1,23 @@
+```
+% pandoc -f html -t jats
+<table>
+  <tr><td><blockquote>Fly, you fools!</blockquote></td></tr>
+</table>
+^D
+<table-wrap>
+  <table>
+    <colgroup>
+      <col width="100%" />
+    </colgroup>
+    <tbody>
+      <tr>
+        <td><p specific-use="wrapper">
+          <disp-quote>
+            <p>Fly, you fools!</p>
+          </disp-quote>
+        </p></td>
+      </tr>
+    </tbody>
+  </table>
+</table-wrap>
+```
diff --git a/test/writer.jats_archiving b/test/writer.jats_archiving
index 332b5d3fd..70e15b6b8 100644
--- a/test/writer.jats_archiving
+++ b/test/writer.jats_archiving
@@ -78,39 +78,31 @@ Gruber’s markdown test suite.</p>
 <sec id="block-quotes">
   <title>Block Quotes</title>
   <p>E-mail style:</p>
-  <p specific-use="wrapper">
+  <disp-quote>
+    <p>This is a block quote. It is pretty short.</p>
+  </disp-quote>
+  <disp-quote>
+    <p>Code in a block quote:</p>
+    <preformat>sub status {
+    print &quot;working&quot;;
+}</preformat>
+    <p>A list:</p>
+    <list list-type="order">
+      <list-item>
+        <p>item one</p>
+      </list-item>
+      <list-item>
+        <p>item two</p>
+      </list-item>
+    </list>
+    <p>Nested block quotes:</p>
     <disp-quote>
-      <p>This is a block quote. It is pretty short.</p>
+      <p>nested</p>
     </disp-quote>
-  </p>
-  <p specific-use="wrapper">
     <disp-quote>
-      <p>Code in a block quote:</p>
-      <preformat>sub status {
-    print &quot;working&quot;;
-}</preformat>
-      <p>A list:</p>
-      <list list-type="order">
-        <list-item>
-          <p>item one</p>
-        </list-item>
-        <list-item>
-          <p>item two</p>
-        </list-item>
-      </list>
-      <p>Nested block quotes:</p>
-      <p specific-use="wrapper">
-        <disp-quote>
-          <p>nested</p>
-        </disp-quote>
-      </p>
-      <p specific-use="wrapper">
-        <disp-quote>
-          <p>nested</p>
-        </disp-quote>
-      </p>
+      <p>nested</p>
     </disp-quote>
-  </p>
+  </disp-quote>
   <p>This should not be a block quote: 2 &gt; 1.</p>
   <p>And a following paragraph.</p>
 </sec>
@@ -837,12 +829,10 @@ These should not be escaped:  \$ \\ \&gt; \[ \{</preformat>
       </list-item>
     </list>
     <p>An e-mail address: <email>nobody@nowhere.net</email></p>
-    <p specific-use="wrapper">
-      <disp-quote>
-        <p>Blockquoted:
-        <ext-link ext-link-type="uri" xlink:href="http://example.com/">http://example.com/</ext-link></p>
-      </disp-quote>
-    </p>
+    <disp-quote>
+      <p>Blockquoted:
+      <ext-link ext-link-type="uri" xlink:href="http://example.com/">http://example.com/</ext-link></p>
+    </disp-quote>
     <p>Auto-links should not occur here:
     <monospace>&lt;http://example.com/&gt;</monospace></p>
     <preformat>or here: &lt;http://example.com/&gt;</preformat>
@@ -866,11 +856,9 @@ These should not be escaped:  \$ \\ \&gt; \[ \{</preformat>
   <italic>not</italic> be a footnote reference, because it contains a
   space.[^my note] Here is an inline
   note.<xref ref-type="fn" rid="fn3">3</xref></p>
-  <p specific-use="wrapper">
-    <disp-quote>
-      <p>Notes can go in quotes.<xref ref-type="fn" rid="fn4">4</xref></p>
-    </disp-quote>
-  </p>
+  <disp-quote>
+    <p>Notes can go in quotes.<xref ref-type="fn" rid="fn4">4</xref></p>
+  </disp-quote>
   <list list-type="order">
     <list-item>
       <p>And in list items.<xref ref-type="fn" rid="fn5">5</xref></p>
diff --git a/test/writer.jats_articleauthoring b/test/writer.jats_articleauthoring
index 956a30faa..59485a114 100644
--- a/test/writer.jats_articleauthoring
+++ b/test/writer.jats_articleauthoring
@@ -67,43 +67,39 @@ Gruber’s markdown test suite.</p>
 <sec id="block-quotes">
   <title>Block Quotes</title>
   <p>E-mail style:</p>
-  <p specific-use="wrapper">
-    <disp-quote>
-      <p>This is a block quote. It is pretty short.</p>
-    </disp-quote>
-  </p>
-  <p specific-use="wrapper">
-    <disp-quote>
-      <p>Code in a block quote:</p>
-      <p specific-use="wrapper">
-        <preformat>sub status {
+  <disp-quote>
+    <p>This is a block quote. It is pretty short.</p>
+  </disp-quote>
+  <disp-quote>
+    <p>Code in a block quote:</p>
+    <p specific-use="wrapper">
+      <preformat>sub status {
     print &quot;working&quot;;
 }</preformat>
-      </p>
-      <p>A list:</p>
-      <p specific-use="wrapper">
-        <list list-type="order">
-          <list-item>
-            <p>item one</p>
-          </list-item>
-          <list-item>
-            <p>item two</p>
-          </list-item>
-        </list>
-      </p>
-      <p>Nested block quotes:</p>
-      <p specific-use="wrapper">
-        <disp-quote>
-          <p>nested</p>
-        </disp-quote>
-      </p>
-      <p specific-use="wrapper">
-        <disp-quote>
-          <p>nested</p>
-        </disp-quote>
-      </p>
-    </disp-quote>
-  </p>
+    </p>
+    <p>A list:</p>
+    <p specific-use="wrapper">
+      <list list-type="order">
+        <list-item>
+          <p>item one</p>
+        </list-item>
+        <list-item>
+          <p>item two</p>
+        </list-item>
+      </list>
+    </p>
+    <p>Nested block quotes:</p>
+    <p specific-use="wrapper">
+      <disp-quote>
+        <p>nested</p>
+      </disp-quote>
+    </p>
+    <p specific-use="wrapper">
+      <disp-quote>
+        <p>nested</p>
+      </disp-quote>
+    </p>
+  </disp-quote>
   <p>This should not be a block quote: 2 &gt; 1.</p>
   <p>And a following paragraph.</p>
 </sec>
@@ -817,12 +813,10 @@ These should not be escaped:  \$ \\ \&gt; \[ \{</preformat>
       </list-item>
     </list>
     <p>An e-mail address: <email>nobody@nowhere.net</email></p>
-    <p specific-use="wrapper">
-      <disp-quote>
-        <p>Blockquoted:
-        <ext-link ext-link-type="uri" xlink:href="http://example.com/">http://example.com/</ext-link></p>
-      </disp-quote>
-    </p>
+    <disp-quote>
+      <p>Blockquoted:
+      <ext-link ext-link-type="uri" xlink:href="http://example.com/">http://example.com/</ext-link></p>
+    </disp-quote>
     <p>Auto-links should not occur here:
     <monospace>&lt;http://example.com/&gt;</monospace></p>
     <preformat>or here: &lt;http://example.com/&gt;</preformat>
@@ -860,13 +854,11 @@ These should not be escaped:  \$ \\ \&gt; \[ \{</preformat>
     and <monospace>]</monospace> verbatim characters, as well as [bracketed
     text].</p>
   </fn></p>
-  <p specific-use="wrapper">
-    <disp-quote>
-      <p>Notes can go in quotes.<fn>
-        <p>In quote.</p>
-      </fn></p>
-    </disp-quote>
-  </p>
+  <disp-quote>
+    <p>Notes can go in quotes.<fn>
+      <p>In quote.</p>
+    </fn></p>
+  </disp-quote>
   <list list-type="order">
     <list-item>
       <p>And in list items.<fn>
diff --git a/test/writer.jats_publishing b/test/writer.jats_publishing
index f53fd554d..e6db4172a 100644
--- a/test/writer.jats_publishing
+++ b/test/writer.jats_publishing
@@ -78,39 +78,31 @@ Gruber’s markdown test suite.</p>
 <sec id="block-quotes">
   <title>Block Quotes</title>
   <p>E-mail style:</p>
-  <p specific-use="wrapper">
+  <disp-quote>
+    <p>This is a block quote. It is pretty short.</p>
+  </disp-quote>
+  <disp-quote>
+    <p>Code in a block quote:</p>
+    <preformat>sub status {
+    print &quot;working&quot;;
+}</preformat>
+    <p>A list:</p>
+    <list list-type="order">
+      <list-item>
+        <p>item one</p>
+      </list-item>
+      <list-item>
+        <p>item two</p>
+      </list-item>
+    </list>
+    <p>Nested block quotes:</p>
     <disp-quote>
-      <p>This is a block quote. It is pretty short.</p>
+      <p>nested</p>
     </disp-quote>
-  </p>
-  <p specific-use="wrapper">
     <disp-quote>
-      <p>Code in a block quote:</p>
-      <preformat>sub status {
-    print &quot;working&quot;;
-}</preformat>
-      <p>A list:</p>
-      <list list-type="order">
-        <list-item>
-          <p>item one</p>
-        </list-item>
-        <list-item>
-          <p>item two</p>
-        </list-item>
-      </list>
-      <p>Nested block quotes:</p>
-      <p specific-use="wrapper">
-        <disp-quote>
-          <p>nested</p>
-        </disp-quote>
-      </p>
-      <p specific-use="wrapper">
-        <disp-quote>
-          <p>nested</p>
-        </disp-quote>
-      </p>
+      <p>nested</p>
     </disp-quote>
-  </p>
+  </disp-quote>
   <p>This should not be a block quote: 2 &gt; 1.</p>
   <p>And a following paragraph.</p>
 </sec>
@@ -837,12 +829,10 @@ These should not be escaped:  \$ \\ \&gt; \[ \{</preformat>
       </list-item>
     </list>
     <p>An e-mail address: <email>nobody@nowhere.net</email></p>
-    <p specific-use="wrapper">
-      <disp-quote>
-        <p>Blockquoted:
-        <ext-link ext-link-type="uri" xlink:href="http://example.com/">http://example.com/</ext-link></p>
-      </disp-quote>
-    </p>
+    <disp-quote>
+      <p>Blockquoted:
+      <ext-link ext-link-type="uri" xlink:href="http://example.com/">http://example.com/</ext-link></p>
+    </disp-quote>
     <p>Auto-links should not occur here:
     <monospace>&lt;http://example.com/&gt;</monospace></p>
     <preformat>or here: &lt;http://example.com/&gt;</preformat>
@@ -866,11 +856,9 @@ These should not be escaped:  \$ \\ \&gt; \[ \{</preformat>
   <italic>not</italic> be a footnote reference, because it contains a
   space.[^my note] Here is an inline
   note.<xref ref-type="fn" rid="fn3">3</xref></p>
-  <p specific-use="wrapper">
-    <disp-quote>
-      <p>Notes can go in quotes.<xref ref-type="fn" rid="fn4">4</xref></p>
-    </disp-quote>
-  </p>
+  <disp-quote>
+    <p>Notes can go in quotes.<xref ref-type="fn" rid="fn4">4</xref></p>
+  </disp-quote>
   <list list-type="order">
     <list-item>
       <p>And in list items.<xref ref-type="fn" rid="fn5">5</xref></p>
-- 
cgit v1.2.3