Merge branch 'master' of https://github.com/jgm/pandoc

3 files changed, 205 insertions, 10 deletions

diff --git a/src/Text/Pandoc/Writers/JATS/References.hs b/src/Text/Pandoc/Writers/JATS/References.hs
new file mode 100644
index 000000000..5b19fd034
--- /dev/null
+++ b/src/Text/Pandoc/Writers/JATS/References.hs
@@ -0,0 +1,164 @@
+{-# 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 (escapeNCName, escapeStringForXML, 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 ident = escapeNCName $ "ref-" <> unItemId (referenceId ref)
+  let wrap = inTags True "ref" [("id", ident)]
+           . 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 $
+                    escapeStringForXML 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 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 ' ') $
+                    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/Table.hs b/src/Text/Pandoc/Writers/JATS/Table.hs
index a4d42832d..70569bdcd 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>
@@ -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
 
@@ -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
@@ -216,7 +222,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
@@ -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 8162f3bc0..8d8673cf6 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>
@@ -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
@@ -36,10 +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)
+    -- ^ Converts an inline list to JATS.
+
+  , jatsReferences    :: [Reference Inlines] -- ^ List of references
   }
 
 -- | JATS writer type