{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{- |
   Module      : Text.Pandoc.Writers.JATS
   Copyright   : 2017-2021 John MacFarlane
   License     : GNU GPL, version 2 or above

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

Conversion of 'Pandoc' documents to JATS XML.
Reference:
https://jats.nlm.nih.gov/publishing/tag-library
-}
module Text.Pandoc.Writers.JATS
  ( writeJATS
  , writeJatsArchiving
  , writeJatsPublishing
  , writeJatsArticleAuthoring
  ) where
import Control.Applicative ((<|>))
import Control.Monad.Reader
import Control.Monad.State
import Data.Generics (everywhere, mkT)
import Data.List (partition)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, listToMaybe)
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)
import Text.Pandoc.Logging
import Text.Pandoc.MIME (getMimeType)
import Text.Pandoc.Walk (walk)
import Text.Pandoc.Options
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
import Text.Pandoc.Writers.Shared
import Text.Pandoc.XML
import Text.TeXMath
import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
import qualified Text.XML.Light as Xml

-- | Convert a @'Pandoc'@ document to JATS (Archiving and Interchange
-- Tag Set.)
writeJatsArchiving :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeJatsArchiving :: WriterOptions -> Pandoc -> m Text
writeJatsArchiving = JATSTagSet -> WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
JATSTagSet -> WriterOptions -> Pandoc -> m Text
writeJats JATSTagSet
TagSetArchiving

-- | Convert a @'Pandoc'@ document to JATS (Journal Publishing Tag Set.)
writeJatsPublishing :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeJatsPublishing :: WriterOptions -> Pandoc -> m Text
writeJatsPublishing = JATSTagSet -> WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
JATSTagSet -> WriterOptions -> Pandoc -> m Text
writeJats JATSTagSet
TagSetPublishing

-- | Convert a @'Pandoc'@ document to JATS (Archiving and Interchange
-- Tag Set.)
writeJatsArticleAuthoring :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeJatsArticleAuthoring :: WriterOptions -> Pandoc -> m Text
writeJatsArticleAuthoring = JATSTagSet -> WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
JATSTagSet -> WriterOptions -> Pandoc -> m Text
writeJats JATSTagSet
TagSetArticleAuthoring

-- | Alias for @'writeJatsArchiving'@. This function exists for backwards
-- compatibility, but will be deprecated in the future. Use
-- @'writeJatsArchiving'@ instead.
writeJATS :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeJATS :: WriterOptions -> Pandoc -> m Text
writeJATS = WriterOptions -> Pandoc -> m Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeJatsArchiving

-- | Convert a @'Pandoc'@ document to JATS.
writeJats :: PandocMonad m => JATSTagSet -> WriterOptions -> Pandoc -> m Text
writeJats :: JATSTagSet -> WriterOptions -> Pandoc -> m Text
writeJats JATSTagSet
tagSet WriterOptions
opts Pandoc
d = do
  [Reference Inlines]
refs <- if Extension -> Extensions -> Bool
extensionEnabled Extension
Ext_element_citations (Extensions -> Bool) -> Extensions -> Bool
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Extensions
writerExtensions WriterOptions
opts
          then Maybe Locale -> Pandoc -> m [Reference Inlines]
forall (m :: * -> *).
PandocMonad m =>
Maybe Locale -> Pandoc -> m [Reference Inlines]
getReferences Maybe Locale
forall a. Maybe a
Nothing Pandoc
d
          else [Reference Inlines] -> m [Reference Inlines]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  let environment :: JATSEnv m
environment = JATSEnv :: forall (m :: * -> *).
JATSTagSet
-> ((Block -> Bool)
    -> WriterOptions -> [Block] -> JATS m (Doc Text))
-> (WriterOptions -> [Inline] -> JATS m (Doc Text))
-> [Reference Inlines]
-> JATSEnv m
JATSEnv
          { jatsTagSet :: JATSTagSet
jatsTagSet = JATSTagSet
tagSet
          , jatsInlinesWriter :: WriterOptions -> [Inline] -> JATS m (Doc Text)
jatsInlinesWriter = WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS
          , jatsBlockWriter :: (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
jatsBlockWriter = (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
(Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
wrappedBlocksToJATS
          , jatsReferences :: [Reference Inlines]
jatsReferences = [Reference Inlines]
refs
          }
  let initialState :: JATSState
initialState = JATSState :: [(Int, Doc Text)] -> JATSState
JATSState { jatsNotes :: [(Int, Doc Text)]
jatsNotes = [] }
  ReaderT (JATSEnv m) m Text -> JATSEnv m -> m Text
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT JATSState (ReaderT (JATSEnv m) m) Text
-> JATSState -> ReaderT (JATSEnv m) m Text
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterOptions
-> Pandoc -> StateT JATSState (ReaderT (JATSEnv m) m) Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> JATS m Text
docToJATS WriterOptions
opts Pandoc
d) JATSState
initialState)
             JATSEnv m
environment

-- | Convert Pandoc document to string in JATS format.
docToJATS :: PandocMonad m => WriterOptions -> Pandoc -> JATS m Text
docToJATS :: WriterOptions -> Pandoc -> JATS m Text
docToJATS WriterOptions
opts (Pandoc Meta
meta [Block]
blocks) = do
  let isBackBlock :: Block -> Bool
isBackBlock (Div (Text
"refs",[Text]
_,[(Text, Text)]
_) [Block]
_) = Bool
True
      isBackBlock Block
_                    = Bool
False
  let ([Block]
backblocks, [Block]
bodyblocks) = (Block -> Bool) -> [Block] -> ([Block], [Block])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Block -> Bool
isBackBlock [Block]
blocks
  -- The numbering here follows LaTeX's internal numbering
  let startLvl :: Int
startLvl = case WriterOptions -> TopLevelDivision
writerTopLevelDivision WriterOptions
opts of
                   TopLevelDivision
TopLevelPart    -> -Int
1
                   TopLevelDivision
TopLevelChapter -> Int
0
                   TopLevelDivision
TopLevelSection -> Int
1
                   TopLevelDivision
TopLevelDefault -> Int
1
  let fromBlocks :: [Block] -> JATS m (Doc Text)
fromBlocks = WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJATS WriterOptions
opts ([Block] -> JATS m (Doc Text))
-> ([Block] -> [Block]) -> [Block] -> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe Int -> [Block] -> [Block]
makeSections Bool
False (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
startLvl)
  let colwidth :: Maybe Int
colwidth = if WriterOptions -> WrapOption
writerWrapText WriterOptions
opts WrapOption -> WrapOption -> Bool
forall a. Eq a => a -> a -> Bool
== WrapOption
WrapAuto
                    then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Int
writerColumns WriterOptions
opts
                    else Maybe Int
forall a. Maybe a
Nothing
  Context Text
metadata <- WriterOptions
-> ([Block] -> JATS m (Doc Text))
-> ([Inline] -> JATS m (Doc Text))
-> Meta
-> StateT JATSState (ReaderT (JATSEnv m) m) (Context Text)
forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
WriterOptions
-> ([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a))
-> Meta
-> m (Context a)
metaToContext WriterOptions
opts
                 [Block] -> JATS m (Doc Text)
fromBlocks
                 ((Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc Text -> Doc Text
forall a. Doc a -> Doc a
chomp (JATS m (Doc Text) -> JATS m (Doc Text))
-> ([Inline] -> JATS m (Doc Text)) -> [Inline] -> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts)
                 Meta
meta
  Doc Text
main <- [Block] -> JATS m (Doc Text)
fromBlocks [Block]
bodyblocks
  [Doc Text]
notes <- (JATSState -> [Doc Text])
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ([Doc Text] -> [Doc Text]
forall a. [a] -> [a]
reverse ([Doc Text] -> [Doc Text])
-> (JATSState -> [Doc Text]) -> JATSState -> [Doc Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Doc Text) -> Doc Text) -> [(Int, Doc Text)] -> [Doc Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Doc Text) -> Doc Text
forall a b. (a, b) -> b
snd ([(Int, Doc Text)] -> [Doc Text])
-> (JATSState -> [(Int, Doc Text)]) -> JATSState -> [Doc Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JATSState -> [(Int, Doc Text)]
jatsNotes)
  Doc Text
backs <- [Block] -> JATS m (Doc Text)
fromBlocks [Block]
backblocks
  JATSTagSet
tagSet <- (JATSEnv m -> JATSTagSet)
-> StateT JATSState (ReaderT (JATSEnv m) m) JATSTagSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> JATSTagSet
forall (m :: * -> *). JATSEnv m -> JATSTagSet
jatsTagSet
  -- In the "Article Authoring" tag set, occurrence of fn-group elements
  -- is restricted to table footers. Footnotes have to be placed inline.
  let fns :: Doc Text
fns = if [Doc Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc Text]
notes Bool -> Bool -> Bool
|| JATSTagSet
tagSet JATSTagSet -> JATSTagSet -> Bool
forall a. Eq a => a -> a -> Bool
== JATSTagSet
TagSetArticleAuthoring
            then Doc Text
forall a. Monoid a => a
mempty
            else Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"fn-group" (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat [Doc Text]
notes
  let back :: Doc Text
back = Doc Text
backs Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
fns
  let date :: Val Text
date =
        case Text -> Context Text -> Maybe (Val Text)
forall a b. FromContext a b => Text -> Context a -> Maybe b
getField Text
"date" Context Text
metadata of
          Maybe (Val Text)
Nothing -> Val Text
forall a. Val a
NullVal
          Just (SimpleVal (Doc Text
x :: Doc Text)) ->
             case Text -> Maybe Day
parseDate (Maybe Int -> Doc Text -> Text
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing Doc Text
x) of
               Maybe Day
Nothing  -> Val Text
forall a. Val a
NullVal
               Just Day
day ->
                 let (Integer
y,Int
m,Int
d) = Day -> (Integer, Int, Int)
toGregorian Day
day
                 in  Context Text -> Val Text
forall a. Context a -> Val a
MapVal (Context Text -> Val Text)
-> (Map Text (Val Text) -> Context Text)
-> Map Text (Val Text)
-> Val Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Val Text) -> Context Text
forall a. Map Text (Val a) -> Context a
Context (Map Text (Val Text) -> Val Text)
-> Map Text (Val Text) -> Val Text
forall a b. (a -> b) -> a -> b
$ [(Text, Val Text)] -> Map Text (Val Text)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                      [(Text
"year" :: Text, Doc Text -> Val Text
forall a. Doc a -> Val a
SimpleVal (Doc Text -> Val Text) -> Doc Text -> Val Text
forall a b. (a -> b) -> a -> b
$ String -> Doc Text
forall a. HasChars a => String -> Doc a
text (String -> Doc Text) -> String -> Doc Text
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
y)
                      ,(Text
"month", Doc Text -> Val Text
forall a. Doc a -> Val a
SimpleVal (Doc Text -> Val Text) -> Doc Text -> Val Text
forall a b. (a -> b) -> a -> b
$ String -> Doc Text
forall a. HasChars a => String -> Doc a
text (String -> Doc Text) -> String -> Doc Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
m)
                      ,(Text
"day", Doc Text -> Val Text
forall a. Doc a -> Val a
SimpleVal (Doc Text -> Val Text) -> Doc Text -> Val Text
forall a b. (a -> b) -> a -> b
$ String -> Doc Text
forall a. HasChars a => String -> Doc a
text (String -> Doc Text) -> String -> Doc Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
d)
                      ,(Text
"iso-8601", Doc Text -> Val Text
forall a. Doc a -> Val a
SimpleVal (Doc Text -> Val Text) -> Doc Text -> Val Text
forall a b. (a -> b) -> a -> b
$ String -> Doc Text
forall a. HasChars a => String -> Doc a
text (String -> Doc Text) -> String -> Doc Text
forall a b. (a -> b) -> a -> b
$
                            TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F" Day
day)
                      ]
          Just Val Text
x -> Val Text
x
  let context :: Context Text
context = Text -> Doc Text -> Context Text -> Context Text
forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"body" Doc Text
main
              (Context Text -> Context Text) -> Context Text -> Context Text
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text -> Context Text -> Context Text
forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"back" Doc Text
back
              (Context Text -> Context Text) -> Context Text -> Context Text
forall a b. (a -> b) -> a -> b
$ Text -> Val Text -> Context Text -> Context Text
forall a b. ToContext a b => Text -> b -> Context a -> Context a
resetField Text
"date" Val Text
date
              (Context Text -> Context Text) -> Context Text -> Context Text
forall a b. (a -> b) -> a -> b
$ Text -> Bool -> Context Text -> Context Text
forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
"mathml" (case WriterOptions -> HTMLMathMethod
writerHTMLMathMethod WriterOptions
opts of
                                        HTMLMathMethod
MathML -> Bool
True
                                        HTMLMathMethod
_      -> Bool
False) Context Text
metadata
  Text -> JATS m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> JATS m Text) -> Text -> JATS m Text
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Doc Text -> Text
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
colwidth (Doc Text -> Text) -> Doc Text -> Text
forall a b. (a -> b) -> a -> b
$
    (if WriterOptions -> Bool
writerPreferAscii WriterOptions
opts then (Text -> Text) -> Doc Text -> Doc Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
toEntities else Doc Text -> Doc Text
forall a. a -> a
id) (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$
    case WriterOptions -> Maybe (Template Text)
writerTemplate WriterOptions
opts of
       Maybe (Template Text)
Nothing  -> Doc Text
main
       Just Template Text
tpl -> Template Text -> Context Text -> Doc Text
forall a b.
(TemplateTarget a, ToContext a b) =>
Template a -> b -> Doc a
renderTemplate Template Text
tpl Context Text
context

-- | Convert a list of Pandoc blocks to JATS.
blocksToJATS :: PandocMonad m => WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJATS :: WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJATS = (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
(Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
wrappedBlocksToJATS (Bool -> Block -> Bool
forall a b. a -> b -> a
const Bool
False)

-- | Like @'blocksToJATS'@, but wraps top-level blocks into a @<p>@
-- element if the @needsWrap@ predicate evaluates to @True@.
wrappedBlocksToJATS :: PandocMonad m
                    => (Block -> Bool)
                    -> WriterOptions
                    -> [Block]
                    -> JATS m (Doc Text)
wrappedBlocksToJATS :: (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
wrappedBlocksToJATS Block -> Bool
needsWrap WriterOptions
opts =
  ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat (StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
 -> JATS m (Doc Text))
-> ([Block] -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text])
-> [Block]
-> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> JATS m (Doc Text))
-> [Block] -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Block -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
Block -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
wrappedBlockToJATS
  where
    wrappedBlockToJATS :: Block -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
wrappedBlockToJATS Block
b = do
      Doc Text
inner <- WriterOptions
-> Block -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts Block
b
      Doc Text -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text))
-> Doc Text -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall a b. (a -> b) -> a -> b
$
        if Block -> Bool
needsWrap Block
b
           then Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"p" [(Text
"specific-use",Text
"wrapper")] Doc Text
inner
           else Doc Text
inner

-- | Auxiliary function to convert Plain block to Para.
plainToPara :: Block -> Block
plainToPara :: Block -> Block
plainToPara (Plain [Inline]
x) = [Inline] -> Block
Para [Inline]
x
plainToPara Block
x         = Block
x

-- | Convert a list of pairs of terms and definitions into a list of
-- JATS varlistentrys.
deflistItemsToJATS :: PandocMonad m
                   => WriterOptions
                   -> [([Inline],[[Block]])] -> JATS m (Doc Text)
deflistItemsToJATS :: WriterOptions -> [([Inline], [[Block]])] -> JATS m (Doc Text)
deflistItemsToJATS WriterOptions
opts [([Inline], [[Block]])]
items =
  [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([Inline], [[Block]]) -> JATS m (Doc Text))
-> [([Inline], [[Block]])]
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Inline] -> [[Block]] -> JATS m (Doc Text))
-> ([Inline], [[Block]]) -> JATS m (Doc Text)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (WriterOptions -> [Inline] -> [[Block]] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> [[Block]] -> JATS m (Doc Text)
deflistItemToJATS WriterOptions
opts)) [([Inline], [[Block]])]
items

-- | Convert a term and a list of blocks into a JATS varlistentry.
deflistItemToJATS :: PandocMonad m
                  => WriterOptions
                  -> [Inline] -> [[Block]] -> JATS m (Doc Text)
deflistItemToJATS :: WriterOptions -> [Inline] -> [[Block]] -> JATS m (Doc Text)
deflistItemToJATS WriterOptions
opts [Inline]
term [[Block]]
defs = do
  Doc Text
term' <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
term
  Doc Text
def' <- (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
(Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
wrappedBlocksToJATS (Bool -> Bool
not (Bool -> Bool) -> (Block -> Bool) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Bool
isPara)
              WriterOptions
opts ([Block] -> JATS m (Doc Text)) -> [Block] -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ ([Block] -> [Block]) -> [[Block]] -> [Block]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Block -> Block) -> [Block] -> [Block]
forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
demoteHeaderAndRefs ([Block] -> [Block]) -> ([Block] -> [Block]) -> [Block] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                (Block -> Block) -> [Block] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Block
plainToPara) [[Block]]
defs
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"def-item" (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$
      Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"term" Doc Text
term' Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$
      Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"def" Doc Text
def'

-- | Convert a list of lists of blocks to a list of JATS list items.
listItemsToJATS :: PandocMonad m
                => WriterOptions
                -> Maybe [Text] -> [[Block]] -> JATS m (Doc Text)
listItemsToJATS :: WriterOptions -> Maybe [Text] -> [[Block]] -> JATS m (Doc Text)
listItemsToJATS WriterOptions
opts Maybe [Text]
markers [[Block]]
items =
  case Maybe [Text]
markers of
       Maybe [Text]
Nothing -> [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Block] -> JATS m (Doc Text))
-> [[Block]] -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Maybe Text -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Maybe Text -> [Block] -> JATS m (Doc Text)
listItemToJATS WriterOptions
opts Maybe Text
forall a. Maybe a
Nothing) [[Block]]
items
       Just [Text]
ms -> [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Text -> [Block] -> JATS m (Doc Text))
-> [Maybe Text]
-> [[Block]]
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (WriterOptions -> Maybe Text -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Maybe Text -> [Block] -> JATS m (Doc Text)
listItemToJATS WriterOptions
opts) ((Text -> Maybe Text) -> [Text] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Maybe Text
forall a. a -> Maybe a
Just [Text]
ms) [[Block]]
items

-- | Convert a list of blocks into a JATS list item.
listItemToJATS :: PandocMonad m
               => WriterOptions
               -> Maybe Text -> [Block] -> JATS m (Doc Text)
listItemToJATS :: WriterOptions -> Maybe Text -> [Block] -> JATS m (Doc Text)
listItemToJATS WriterOptions
opts Maybe Text
mbmarker [Block]
item = do
  Doc Text
contents <- (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
(Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
wrappedBlocksToJATS (Bool -> Bool
not (Bool -> Bool) -> (Block -> Bool) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Bool
isParaOrList) WriterOptions
opts
                 ((Block -> Block) -> [Block] -> [Block]
forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
demoteHeaderAndRefs [Block]
item)
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"list-item" (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$
           Doc Text -> (Text -> Doc Text) -> Maybe Text -> Doc Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc Text
forall a. Doc a
empty (Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"label" (Doc Text -> Doc Text) -> (Text -> Doc Text) -> Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc Text
forall a. HasChars a => String -> Doc a
text (String -> Doc Text) -> (Text -> String) -> Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Maybe Text
mbmarker
           Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
contents

imageMimeType :: Text -> [(Text, Text)] -> (Text, Text)
imageMimeType :: Text -> [(Text, Text)] -> (Text, Text)
imageMimeType Text
src [(Text, Text)]
kvs =
  let mbMT :: Maybe Text
mbMT = String -> Maybe Text
getMimeType (Text -> String
T.unpack Text
src)
      maintype :: Text
maintype = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"image" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
                  Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"mimetype" [(Text, Text)]
kvs Maybe Text -> Maybe Text -> Maybe Text
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                  ((Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbMT)
      subtype :: Text
subtype = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
                  Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"mime-subtype" [(Text, Text)]
kvs Maybe Text -> Maybe Text -> Maybe Text
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                  (Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbMT)
  in (Text
maintype, Text
subtype)

languageFor :: WriterOptions -> [Text] -> Text
languageFor :: WriterOptions -> [Text] -> Text
languageFor WriterOptions
opts [Text]
classes =
  case [Text]
langs of
     (Text
l:[Text]
_) -> Text -> Text
escapeStringForXML Text
l
     []    -> Text
""
    where
          syntaxMap :: SyntaxMap
syntaxMap = WriterOptions -> SyntaxMap
writerSyntaxMap WriterOptions
opts
          isLang :: Text -> Bool
isLang Text
l    = Text -> Text
T.toLower Text
l Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toLower (SyntaxMap -> [Text]
languages SyntaxMap
syntaxMap)
          langsFrom :: Text -> [Text]
langsFrom Text
s = if Text -> Bool
isLang Text
s
                           then [Text
s]
                           else (SyntaxMap -> Text -> [Text]
languagesByExtension SyntaxMap
syntaxMap) (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text
s
          langs :: [Text]
langs       = (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
langsFrom [Text]
classes

codeAttr :: WriterOptions -> Attr -> (Text, [(Text, Text)])
codeAttr :: WriterOptions
-> (Text, [Text], [(Text, Text)]) -> (Text, [(Text, Text)])
codeAttr WriterOptions
opts (Text
ident,[Text]
classes,[(Text, Text)]
kvs) = (Text
lang, [(Text, Text)]
attr)
    where
       attr :: [(Text, Text)]
attr = [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
              [(Text
"language",Text
lang) | Bool -> Bool
not (Text -> Bool
T.null Text
lang)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
              [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"code-type",
                Text
"code-version", Text
"executable",
                Text
"language-version", Text
"orientation",
                    Text
"platforms", Text
"position", Text
"specific-use"]]
       lang :: Text
lang  = WriterOptions -> [Text] -> Text
languageFor WriterOptions
opts [Text]
classes

-- | Convert a Pandoc block element to JATS.
blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS :: WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
_ Block
Null = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
blockToJATS WriterOptions
opts (Div (Text
id',Text
"section":[Text]
_,[(Text, Text)]
kvs) (Header Int
_lvl (Text, [Text], [(Text, Text)])
_ [Inline]
ils : [Block]
xs)) = do
  let idAttr :: [(Text, Text)]
idAttr = [ (Text
"id", WriterOptions -> Text
writerIdentifierPrefix WriterOptions
opts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escapeNCName Text
id')
               | Bool -> Bool
not (Text -> Bool
T.null Text
id')]
  let otherAttrs :: [Text]
otherAttrs = [Text
"sec-type", Text
"specific-use"]
  let attribs :: [(Text, Text)]
attribs = [(Text, Text)]
idAttr [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
otherAttrs]
  Doc Text
title' <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
ils
  Doc Text
contents <- WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJATS WriterOptions
opts [Block]
xs
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"sec" [(Text, Text)]
attribs (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$
      Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"title" Doc Text
title' Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
contents
-- Bibliography reference:
blockToJATS WriterOptions
opts (Div (Text
ident,[Text]
_,[(Text, Text)]
_) [Para [Inline]
lst]) | Text
"ref-" Text -> Text -> Bool
`T.isPrefixOf` Text
ident =
  Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"ref" [(Text
"id", Text -> Text
escapeNCName Text
ident)] (Doc Text -> Doc Text)
-> (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"mixed-citation" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
blockToJATS WriterOptions
opts (Div (Text
"refs",[Text]
_,[(Text, Text)]
_) [Block]
xs) = do
  [Reference Inlines]
refs <- (JATSEnv m -> [Reference Inlines])
-> StateT JATSState (ReaderT (JATSEnv m) m) [Reference Inlines]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> [Reference Inlines]
forall (m :: * -> *). JATSEnv m -> [Reference Inlines]
jatsReferences
  Doc Text
contents <- if [Reference Inlines] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Reference Inlines]
refs
              then WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJATS WriterOptions
opts [Block]
xs
              else WriterOptions -> [Reference Inlines] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Reference Inlines] -> JATS m (Doc Text)
referencesToJATS WriterOptions
opts [Reference Inlines]
refs
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"ref-list" Doc Text
contents
blockToJATS WriterOptions
opts (Div (Text
ident,[Text
cls],[(Text, Text)]
kvs) [Block]
bs) | Text
cls Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"fig", Text
"caption", Text
"table-wrap"] = do
  Doc Text
contents <- WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJATS WriterOptions
opts [Block]
bs
  let attr :: [(Text, Text)]
attr = [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
"xml:lang",Text
l) | (Text
"lang",Text
l) <- [(Text, Text)]
kvs] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"specific-use",
                 Text
"content-type", Text
"orientation", Text
"position"]]
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
cls [(Text, Text)]
attr Doc Text
contents
blockToJATS WriterOptions
opts (Div (Text
ident,[Text]
_,[(Text, Text)]
kvs) [Block]
bs) = do
  Doc Text
contents <- WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJATS WriterOptions
opts [Block]
bs
  let attr :: [(Text, Text)]
attr = [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
"xml:lang",Text
l) | (Text
"lang",Text
l) <- [(Text, Text)]
kvs] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"specific-use",
                 Text
"content-type", Text
"orientation", Text
"position"]]
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"boxed-text" [(Text, Text)]
attr Doc Text
contents
blockToJATS WriterOptions
opts (Header Int
_ (Text, [Text], [(Text, Text)])
_ [Inline]
title) = do
  Doc Text
title' <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
title
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"title" Doc Text
title'
-- No Plain, everything needs to be in a block-level tag
blockToJATS WriterOptions
opts (Plain [Inline]
lst) = WriterOptions -> Block -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts ([Inline] -> Block
Para [Inline]
lst)
blockToJATS WriterOptions
opts (SimpleFigure (Text
ident, [Text]
_, [(Text, Text)]
kvs) [Inline]
txt (Text
src, Text
tit)) = do
  Doc Text
alt <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
txt
  let (Text
maintype, Text
subtype) = Text -> [(Text, Text)] -> (Text, Text)
imageMimeType Text
src [(Text, Text)]
kvs
  let capt :: Doc Text
capt = if [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
txt
                then Doc Text
forall a. Doc a
empty
                else Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"caption" (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"p" Doc Text
alt
  let attr :: [(Text, Text)]
attr = [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"fig-type", Text
"orientation",
                                              Text
"position", Text
"specific-use"]]
  let graphicattr :: [(Text, Text)]
graphicattr = [(Text
"mimetype",Text
maintype),
                     (Text
"mime-subtype",Text
subtype),
                     (Text
"xlink:href",Text
src),  -- do we need to URL escape this?
                     (Text
"xlink:title",Text
tit)]
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"fig" [(Text, Text)]
attr (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$
              Doc Text
capt Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"graphic" [(Text, Text)]
graphicattr
blockToJATS WriterOptions
_ (Para [Image (Text
ident,[Text]
_,[(Text, Text)]
kvs) [Inline]
_ (Text
src, Text
tit)]) = do
  let (Text
maintype, Text
subtype) = Text -> [(Text, Text)] -> (Text, Text)
imageMimeType Text
src [(Text, Text)]
kvs
  let attr :: [(Text, Text)]
attr = [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
"mimetype", Text
maintype),
              (Text
"mime-subtype", Text
subtype),
              (Text
"xlink:href", Text
src)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
"xlink:title", Text
tit) | Bool -> Bool
not (Text -> Bool
T.null Text
tit)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"baseline-shift",
                        Text
"content-type", Text
"specific-use", Text
"xlink:actuate",
                        Text
"xlink:href", Text
"xlink:role", Text
"xlink:show",
                        Text
"xlink:type"]]
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"graphic" [(Text, Text)]
attr
blockToJATS WriterOptions
opts (Para [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"p" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
blockToJATS WriterOptions
opts (LineBlock [[Inline]]
lns) =
  WriterOptions -> Block -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts (Block -> JATS m (Doc Text)) -> Block -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ [[Inline]] -> Block
linesToPara [[Inline]]
lns
blockToJATS WriterOptions
opts (BlockQuote [Block]
blocks) = do
  JATSTagSet
tagSet <- (JATSEnv m -> JATSTagSet)
-> StateT JATSState (ReaderT (JATSEnv m) m) JATSTagSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> JATSTagSet
forall (m :: * -> *). JATSEnv m -> JATSTagSet
jatsTagSet
  let needsWrap :: Block -> Bool
needsWrap = if JATSTagSet
tagSet JATSTagSet -> JATSTagSet -> Bool
forall a. Eq a => a -> a -> Bool
== JATSTagSet
TagSetArticleAuthoring
                  then Bool -> Bool
not (Bool -> Bool) -> (Block -> Bool) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Bool
isPara
                  else \case
                    Header{}       -> Bool
True
                    Block
HorizontalRule -> Bool
True
                    Block
_              -> Bool
False
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"disp-quote" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
(Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
wrappedBlocksToJATS Block -> Bool
needsWrap WriterOptions
opts [Block]
blocks
blockToJATS WriterOptions
opts (CodeBlock (Text, [Text], [(Text, Text)])
a Text
str) = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$
  Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
tag [(Text, Text)]
attr (Doc Text -> Doc Text
forall a. Doc a -> Doc a
flush (String -> Doc Text
forall a. HasChars a => String -> Doc a
text (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeStringForXML Text
str)))
    where (Text
lang, [(Text, Text)]
attr) = WriterOptions
-> (Text, [Text], [(Text, Text)]) -> (Text, [(Text, Text)])
codeAttr WriterOptions
opts (Text, [Text], [(Text, Text)])
a
          tag :: Text
tag          = if Text -> Bool
T.null Text
lang then Text
"preformat" else Text
"code"
blockToJATS WriterOptions
_ (BulletList []) = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
blockToJATS WriterOptions
opts (BulletList [[Block]]
lst) =
  Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"list" [(Text
"list-type", Text
"bullet")] (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  WriterOptions -> Maybe [Text] -> [[Block]] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Maybe [Text] -> [[Block]] -> JATS m (Doc Text)
listItemsToJATS WriterOptions
opts Maybe [Text]
forall a. Maybe a
Nothing [[Block]]
lst
blockToJATS WriterOptions
_ (OrderedList ListAttributes
_ []) = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
blockToJATS WriterOptions
opts (OrderedList (Int
start, ListNumberStyle
numstyle, ListNumberDelim
delimstyle) [[Block]]
items) = do
  JATSTagSet
tagSet <- (JATSEnv m -> JATSTagSet)
-> StateT JATSState (ReaderT (JATSEnv m) m) JATSTagSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> JATSTagSet
forall (m :: * -> *). JATSEnv m -> JATSTagSet
jatsTagSet
  let listType :: Text
listType =
        -- The Article Authoring tag set doesn't allow a more specific
        -- @list-type@ attribute than "order".
        if JATSTagSet
tagSet JATSTagSet -> JATSTagSet -> Bool
forall a. Eq a => a -> a -> Bool
== JATSTagSet
TagSetArticleAuthoring
        then Text
"order"
        else case ListNumberStyle
numstyle of
               ListNumberStyle
DefaultStyle -> Text
"order"
               ListNumberStyle
Decimal      -> Text
"order"
               ListNumberStyle
Example      -> Text
"order"
               ListNumberStyle
UpperAlpha   -> Text
"alpha-upper"
               ListNumberStyle
LowerAlpha   -> Text
"alpha-lower"
               ListNumberStyle
UpperRoman   -> Text
"roman-upper"
               ListNumberStyle
LowerRoman   -> Text
"roman-lower"
  let simpleList :: Bool
simpleList = Int
start Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& (ListNumberDelim
delimstyle ListNumberDelim -> ListNumberDelim -> Bool
forall a. Eq a => a -> a -> Bool
== ListNumberDelim
DefaultDelim Bool -> Bool -> Bool
||
                                  ListNumberDelim
delimstyle ListNumberDelim -> ListNumberDelim -> Bool
forall a. Eq a => a -> a -> Bool
== ListNumberDelim
Period)
  let markers :: Maybe [Text]
markers = if Bool
simpleList
                   then Maybe [Text]
forall a. Maybe a
Nothing
                   else [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$
                          ListAttributes -> [Text]
orderedListMarkers (Int
start, ListNumberStyle
numstyle, ListNumberDelim
delimstyle)
  Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"list" [(Text
"list-type", Text
listType)] (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    WriterOptions -> Maybe [Text] -> [[Block]] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Maybe [Text] -> [[Block]] -> JATS m (Doc Text)
listItemsToJATS WriterOptions
opts Maybe [Text]
markers [[Block]]
items
blockToJATS WriterOptions
opts (DefinitionList [([Inline], [[Block]])]
lst) =
  Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"def-list" [] (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [([Inline], [[Block]])] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [([Inline], [[Block]])] -> JATS m (Doc Text)
deflistItemsToJATS WriterOptions
opts [([Inline], [[Block]])]
lst
blockToJATS WriterOptions
_ b :: Block
b@(RawBlock Format
f Text
str)
  | Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
"jats"    = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ String -> Doc Text
forall a. HasChars a => String -> Doc a
text (String -> Doc Text) -> String -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
str -- raw XML block
  | Bool
otherwise      = do
      LogMessage -> StateT JATSState (ReaderT (JATSEnv m) m) ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT JATSState (ReaderT (JATSEnv m) m) ())
-> LogMessage -> StateT JATSState (ReaderT (JATSEnv m) m) ()
forall a b. (a -> b) -> a -> b
$ Block -> LogMessage
BlockNotRendered Block
b
      Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
blockToJATS WriterOptions
_ Block
HorizontalRule = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty -- not semantic
blockToJATS WriterOptions
opts (Table (Text, [Text], [(Text, Text)])
attr Caption
caption [ColSpec]
colspecs TableHead
thead [TableBody]
tbody TableFoot
tfoot) =
  WriterOptions -> Table -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Table -> JATS m (Doc Text)
tableToJATS WriterOptions
opts ((Text, [Text], [(Text, Text)])
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> Table
Ann.toTable (Text, [Text], [(Text, Text)])
attr Caption
caption [ColSpec]
colspecs TableHead
thead [TableBody]
tbody TableFoot
tfoot)

-- | Convert a list of inline elements to JATS.
inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS :: WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst = [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
hcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inline -> JATS m (Doc Text))
-> [Inline] -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Inline -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> JATS m (Doc Text)
inlineToJATS WriterOptions
opts) ([Inline] -> [Inline]
fixCitations [Inline]
lst)
  where
   fixCitations :: [Inline] -> [Inline]
fixCitations [] = []
   fixCitations (Inline
x:[Inline]
xs) | Inline -> Bool
needsFixing Inline
x =
     Inline
x Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: Text -> Inline
Str ([Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Inline]
ys) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline] -> [Inline]
fixCitations [Inline]
zs
     where
       needsFixing :: Inline -> Bool
needsFixing (RawInline (Format Text
"jats") Text
z) =
           Text
"<pub-id pub-id-type=" Text -> Text -> Bool
`T.isPrefixOf` Text
z
       needsFixing Inline
_           = Bool
False
       isRawInline :: Inline -> Bool
isRawInline RawInline{} = Bool
True
       isRawInline Inline
_           = Bool
False
       ([Inline]
ys,[Inline]
zs)                 = (Inline -> Bool) -> [Inline] -> ([Inline], [Inline])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Inline -> Bool
isRawInline [Inline]
xs
   fixCitations (Inline
x:[Inline]
xs) = Inline
x Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline] -> [Inline]
fixCitations [Inline]
xs

-- | Convert an inline element to JATS.
inlineToJATS :: PandocMonad m => WriterOptions -> Inline -> JATS m (Doc Text)
inlineToJATS :: WriterOptions -> Inline -> JATS m (Doc Text)
inlineToJATS WriterOptions
_ (Str Text
str) = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ String -> Doc Text
forall a. HasChars a => String -> Doc a
text (String -> Doc Text) -> String -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeStringForXML Text
str
inlineToJATS WriterOptions
opts (Emph [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"italic" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS WriterOptions
opts (Underline [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"underline" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS WriterOptions
opts (Strong [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"bold" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS WriterOptions
opts (Strikeout [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"strike" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS WriterOptions
opts (Superscript [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"sup" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS WriterOptions
opts (Subscript [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"sub" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS WriterOptions
opts (SmallCaps [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"sc" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS WriterOptions
opts (Quoted QuoteType
SingleQuote [Inline]
lst) = do
  Doc Text
contents <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
'‘' Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
contents Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
'’'
inlineToJATS WriterOptions
opts (Quoted QuoteType
DoubleQuote [Inline]
lst) = do
  Doc Text
contents <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
'“' Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
contents Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
'”'
inlineToJATS WriterOptions
opts (Code (Text, [Text], [(Text, Text)])
a Text
str) =
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
tag [(Text, Text)]
attr (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Text
escapeStringForXML Text
str)
    where (Text
lang, [(Text, Text)]
attr) = WriterOptions
-> (Text, [Text], [(Text, Text)]) -> (Text, [(Text, Text)])
codeAttr WriterOptions
opts (Text, [Text], [(Text, Text)])
a
          tag :: Text
tag          = if Text -> Bool
T.null Text
lang then Text
"monospace" else Text
"code"
inlineToJATS WriterOptions
_ il :: Inline
il@(RawInline Format
f Text
x)
  | Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
"jats" = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
x
  | Bool
otherwise   = do
      LogMessage -> StateT JATSState (ReaderT (JATSEnv m) m) ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT JATSState (ReaderT (JATSEnv m) m) ())
-> LogMessage -> StateT JATSState (ReaderT (JATSEnv m) m) ()
forall a b. (a -> b) -> a -> b
$ Inline -> LogMessage
InlineNotRendered Inline
il
      Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
inlineToJATS WriterOptions
_ Inline
LineBreak = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
cr -- not allowed as child of p
-- see https://jats.nlm.nih.gov/publishing/tag-library/1.2/element/break.html
inlineToJATS WriterOptions
_ Inline
Space = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
space
inlineToJATS WriterOptions
opts Inline
SoftBreak
  | WriterOptions -> WrapOption
writerWrapText WriterOptions
opts WrapOption -> WrapOption -> Bool
forall a. Eq a => a -> a -> Bool
== WrapOption
WrapPreserve = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
cr
  | Bool
otherwise = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
space
inlineToJATS WriterOptions
opts (Note [Block]
contents) = do
  JATSTagSet
tagSet <- (JATSEnv m -> JATSTagSet)
-> StateT JATSState (ReaderT (JATSEnv m) m) JATSTagSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> JATSTagSet
forall (m :: * -> *). JATSEnv m -> JATSTagSet
jatsTagSet
  -- Footnotes must occur inline when using the Article Authoring tag set.
  if JATSTagSet
tagSet JATSTagSet -> JATSTagSet -> Bool
forall a. Eq a => a -> a -> Bool
== JATSTagSet
TagSetArticleAuthoring
    then Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"fn" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
(Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
wrappedBlocksToJATS (Bool -> Bool
not (Bool -> Bool) -> (Block -> Bool) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Bool
isPara) WriterOptions
opts [Block]
contents
    else do
      [(Int, Doc Text)]
notes <- (JATSState -> [(Int, Doc Text)])
-> StateT JATSState (ReaderT (JATSEnv m) m) [(Int, Doc Text)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets JATSState -> [(Int, Doc Text)]
jatsNotes
      let notenum :: Int
notenum = case [(Int, Doc Text)]
notes of
                      (Int
n, Doc Text
_):[(Int, Doc Text)]
_ -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                      []       -> Int
1
      Doc Text
thenote <- Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"fn" [(Text
"id", Text
"fn" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
notenum)]
                     (Doc Text -> Doc Text)
-> (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"label" (Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall a. Show a => a -> Text
tshow Int
notenum) Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<>)
                    (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
(Block -> Bool) -> WriterOptions -> [Block] -> JATS m (Doc Text)
wrappedBlocksToJATS (Bool -> Bool
not (Bool -> Bool) -> (Block -> Bool) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Bool
isPara) WriterOptions
opts
                         ((Block -> Block) -> [Block] -> [Block]
forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
demoteHeaderAndRefs [Block]
contents)
      (JATSState -> JATSState)
-> StateT JATSState (ReaderT (JATSEnv m) m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((JATSState -> JATSState)
 -> StateT JATSState (ReaderT (JATSEnv m) m) ())
-> (JATSState -> JATSState)
-> StateT JATSState (ReaderT (JATSEnv m) m) ()
forall a b. (a -> b) -> a -> b
$ \JATSState
st -> JATSState
st{ jatsNotes :: [(Int, Doc Text)]
jatsNotes = (Int
notenum, Doc Text
thenote) (Int, Doc Text) -> [(Int, Doc Text)] -> [(Int, Doc Text)]
forall a. a -> [a] -> [a]
: [(Int, Doc Text)]
notes }
      Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
"xref" [(Text
"ref-type", Text
"fn"),
                                    (Text
"rid", Text
"fn" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
notenum)]
             (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ String -> Doc Text
forall a. HasChars a => String -> Doc a
text (Int -> String
forall a. Show a => a -> String
show Int
notenum)
inlineToJATS WriterOptions
opts (Cite [Citation]
_ [Inline]
lst) =
  WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS WriterOptions
opts (Span (Text
ident,[Text]
classes,[(Text, Text)]
kvs) [Inline]
ils) = do
  Doc Text
contents <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
ils
  let commonAttr :: [(Text, Text)]
commonAttr = [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
                   [(Text
"xml:lang",Text
l) | (Text
"lang",Text
l) <- [(Text, Text)]
kvs] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
                   [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs,  Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"alt", Text
"specific-use"]]
  -- A named-content element is a good fit for spans, but requires a
  -- content-type attribute to be present. We use either the explicit
  -- attribute or the first class as content type. If neither is
  -- available, then we fall back to using a @styled-content@ element.
  let (Text
tag, [(Text, Text)]
specificAttr) =
        case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"content-type" [(Text, Text)]
kvs Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text]
classes of
          Just Text
ct -> ( Text
"named-content"
                     , (Text
"content-type", Text
ct) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:
                       [(Text
k, Text
v) | (Text
k, Text
v) <- [(Text, Text)]
kvs
                       , Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"rid", Text
"vocab", Text
"vocab-identifier",
                                   Text
"vocab-term", Text
"vocab-term-identifier"]])
          -- Fall back to styled-content
          Maybe Text
Nothing -> (Text
"styled-content"
                     , [(Text
k, Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs
                       , Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"style", Text
"style-type", Text
"style-detail",
                                   Text
"toggle"]])
  let attr :: [(Text, Text)]
attr = [(Text, Text)]
commonAttr [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text, Text)]
specificAttr
  -- unwrap if wrapping element would have no attributes
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$
    if [(Text, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Text)]
attr
    then Doc Text
contents
    else Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
tag [(Text, Text)]
attr Doc Text
contents
inlineToJATS WriterOptions
_ (Math MathType
t Text
str) = do
  let addPref :: Attr -> Attr
addPref (Xml.Attr QName
q String
v)
         | QName -> String
Xml.qName QName
q String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"xmlns" = QName -> String -> Attr
Xml.Attr QName
q{ qName :: String
Xml.qName = String
"xmlns:mml" } String
v
         | Bool
otherwise = QName -> String -> Attr
Xml.Attr QName
q String
v
  let fixNS' :: Element -> Element
fixNS' Element
e = Element
e{ elName :: QName
Xml.elName =
                         (Element -> QName
Xml.elName Element
e){ qPrefix :: Maybe String
Xml.qPrefix = String -> Maybe String
forall a. a -> Maybe a
Just String
"mml" } }
  let fixNS :: Element -> Element
fixNS = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Element -> Element) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Element -> Element
fixNS') (Element -> Element) -> (Element -> Element) -> Element -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              (\Element
e -> Element
e{ elAttribs :: [Attr]
Xml.elAttribs = (Attr -> Attr) -> [Attr] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> Attr
addPref (Element -> [Attr]
Xml.elAttribs Element
e) })
  let conf :: ConfigPP
conf = (QName -> Bool) -> ConfigPP -> ConfigPP
Xml.useShortEmptyTags (Bool -> QName -> Bool
forall a b. a -> b -> a
const Bool
False) ConfigPP
Xml.defaultConfigPP
  Either Inline Element
res <- (DisplayType -> [Exp] -> Element)
-> MathType
-> Text
-> StateT JATSState (ReaderT (JATSEnv m) m) (Either Inline Element)
forall (m :: * -> *) a.
PandocMonad m =>
(DisplayType -> [Exp] -> a)
-> MathType -> Text -> m (Either Inline a)
convertMath DisplayType -> [Exp] -> Element
writeMathML MathType
t Text
str
  let tagtype :: Text
tagtype = case MathType
t of
                     MathType
DisplayMath -> Text
"disp-formula"
                     MathType
InlineMath  -> Text
"inline-formula"

  let rawtex :: Doc Text
rawtex = String -> Doc Text
forall a. HasChars a => String -> Doc a
text String
"<![CDATA[" Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
str Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> String -> Doc Text
forall a. HasChars a => String -> Doc a
text String
"]]>"
  let texMath :: Doc Text
texMath = Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"tex-math" Doc Text
rawtex

  JATSTagSet
tagSet <- (JATSEnv m -> JATSTagSet)
-> StateT JATSState (ReaderT (JATSEnv m) m) JATSTagSet
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> JATSTagSet
forall (m :: * -> *). JATSEnv m -> JATSTagSet
jatsTagSet
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text))
-> (Doc Text -> Doc Text) -> Doc Text -> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
tagtype (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$
    case Either Inline Element
res of
      Right Element
r  -> let mathMl :: Doc Text
mathMl = String -> Doc Text
forall a. HasChars a => String -> Doc a
text (ConfigPP -> Element -> String
Xml.ppcElement ConfigPP
conf (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ Element -> Element
fixNS Element
r)
                  -- tex-math is unsupported in Article Authoring tag set
                  in if JATSTagSet
tagSet JATSTagSet -> JATSTagSet -> Bool
forall a. Eq a => a -> a -> Bool
== JATSTagSet
TagSetArticleAuthoring
                     then Doc Text
mathMl
                     else Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"alternatives" (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$
                          Doc Text
forall a. Doc a
cr Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
texMath Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
mathMl
      Left Inline
_   -> if JATSTagSet
tagSet JATSTagSet -> JATSTagSet -> Bool
forall a. Eq a => a -> a -> Bool
/= JATSTagSet
TagSetArticleAuthoring
                  then Doc Text
texMath
                  else Doc Text
rawtex
inlineToJATS WriterOptions
_ (Link (Text, [Text], [(Text, Text)])
_attr [Str Text
t] (Text -> Text -> Maybe Text
T.stripPrefix Text
"mailto:" -> Just Text
email, Text
_))
  | Text -> Text
escapeURI Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
email =
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple Text
"email" (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Text
escapeStringForXML Text
email)
inlineToJATS WriterOptions
opts (Link (Text
ident,[Text]
_,[(Text, Text)]
kvs) [Inline]
txt (Text -> Maybe (Char, Text)
T.uncons -> Just (Char
'#', Text
src), Text
_)) = do
  let attr :: [(Text, Text)]
attr = [[(Text, Text)]] -> [(Text, Text)]
forall a. Monoid a => [a] -> a
mconcat
             [ [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)]
             , [(Text
"alt", [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Inline]
txt) | Bool -> Bool
not ([Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
txt)]
             , [(Text
"rid", Text -> Text
escapeNCName Text
src)]
             , [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"ref-type", Text
"specific-use"]]
             , [(Text
"ref-type", Text
"bibr") | Text
"ref-" Text -> Text -> Bool
`T.isPrefixOf` Text
src]
             ]
  if [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
txt
     then Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"xref" [(Text, Text)]
attr
     else do
        Doc Text
contents <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
txt
        Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
"xref" [(Text, Text)]
attr Doc Text
contents
inlineToJATS WriterOptions
opts (Link (Text
ident,[Text]
_,[(Text, Text)]
kvs) [Inline]
txt (Text
src, Text
tit)) = do
  let attr :: [(Text, Text)]
attr = [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
"ext-link-type", Text
"uri"),
              (Text
"xlink:href", Text
src)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
"xlink:title", Text
tit) | Bool -> Bool
not (Text -> Bool
T.null Text
tit)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"assigning-authority",
                                              Text
"specific-use", Text
"xlink:actuate",
                                              Text
"xlink:role", Text
"xlink:show",
                                              Text
"xlink:type"]]
  Doc Text
contents <- WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
txt
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False Text
"ext-link" [(Text, Text)]
attr Doc Text
contents
inlineToJATS WriterOptions
_ (Image (Text
ident,[Text]
_,[(Text, Text)]
kvs) [Inline]
_ (Text
src, Text
tit)) = do
  let mbMT :: Maybe Text
mbMT = String -> Maybe Text
getMimeType (Text -> String
T.unpack Text
src)
  let maintype :: Text
maintype = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"image" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
                  Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"mimetype" [(Text, Text)]
kvs Maybe Text -> Maybe Text -> Maybe Text
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                  ((Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbMT)
  let subtype :: Text
subtype = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
                  Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"mime-subtype" [(Text, Text)]
kvs Maybe Text -> Maybe Text -> Maybe Text
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
                  (Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'/') (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbMT)
  let attr :: [(Text, Text)]
attr = [(Text
"id", Text -> Text
escapeNCName Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
"mimetype", Text
maintype),
              (Text
"mime-subtype", Text
subtype),
              (Text
"xlink:href", Text
src)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
"xlink:title", Text
tit) | Bool -> Bool
not (Text -> Bool
T.null Text
tit)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"baseline-shift",
                        Text
"content-type", Text
"specific-use", Text
"xlink:actuate",
                        Text
"xlink:href", Text
"xlink:role", Text
"xlink:show",
                        Text
"xlink:type"]]
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"inline-graphic" [(Text, Text)]
attr

isParaOrList :: Block -> Bool
isParaOrList :: Block -> Bool
isParaOrList Para{}           = Bool
True
isParaOrList Plain{}          = Bool
True
isParaOrList BulletList{}     = Bool
True
isParaOrList OrderedList{}    = Bool
True
isParaOrList DefinitionList{} = Bool
True
isParaOrList Block
_                = Bool
False

isPara :: Block -> Bool
isPara :: Block -> Bool
isPara Para{}  = Bool
True
isPara Plain{} = Bool
True
isPara Block
_       = Bool
False

demoteHeaderAndRefs :: Block -> Block
demoteHeaderAndRefs :: Block -> Block
demoteHeaderAndRefs (Header Int
_ (Text, [Text], [(Text, Text)])
_ [Inline]
ils) = [Inline] -> Block
Para [Inline]
ils
demoteHeaderAndRefs (Div (Text
"refs",[Text]
cls,[(Text, Text)]
kvs) [Block]
bs) =
                       (Text, [Text], [(Text, Text)]) -> [Block] -> Block
Div (Text
"",[Text]
cls,[(Text, Text)]
kvs) [Block]
bs
demoteHeaderAndRefs Block
x = Block
x

parseDate :: Text -> Maybe Day
parseDate :: Text -> Maybe Day
parseDate Text
s = [Maybe Day] -> Maybe Day
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((String -> Maybe Day) -> [String] -> [Maybe Day]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Maybe Day
`parsetimeWith` Text -> String
T.unpack Text
s) [String]
formats)
  where parsetimeWith :: String -> String -> Maybe Day
parsetimeWith = Bool -> TimeLocale -> String -> String -> Maybe Day
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale
        formats :: [String]
formats = [String
"%x",String
"%m/%d/%Y", String
"%D",String
"%F", String
"%d %b %Y",
                    String
"%e %B %Y", String
"%b. %e, %Y", String
"%B %e, %Y",
                    String
"%Y%m%d", String
"%Y%m", String
"%Y"]