{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{- |
   Module      : Text.Pandoc.Writers.JATS
   Copyright   : Copyright (C) 2017-2020 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.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)
import Data.Time (toGregorian, Day, parseTimeM, defaultTimeLocale, formatTime)
import qualified Data.Text as T
import Data.Text (Text)
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.Math
import Text.Pandoc.Writers.Shared
import Text.Pandoc.XML
import Text.TeXMath
import qualified Text.XML.Light as Xml

-- | JATS tag set variant
data JATSTagSet
  = TagSetArchiving         -- ^ Archiving and Interchange Tag Set
  | TagSetPublishing        -- ^ Journal Publishing Tag Set
  | TagSetArticleAuthoring  -- ^ Article Authoring Tag Set
  deriving (JATSTagSet -> JATSTagSet -> Bool
(JATSTagSet -> JATSTagSet -> Bool)
-> (JATSTagSet -> JATSTagSet -> Bool) -> Eq JATSTagSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JATSTagSet -> JATSTagSet -> Bool
$c/= :: JATSTagSet -> JATSTagSet -> Bool
== :: JATSTagSet -> JATSTagSet -> Bool
$c== :: JATSTagSet -> JATSTagSet -> Bool
Eq)

-- | Internal state used by the writer.
newtype JATSState = JATSState
  { JATSState -> [(Int, Doc Text)]
jatsNotes :: [(Int, Doc Text)] }

-- | JATS writer type
type JATS a = StateT JATSState (ReaderT JATSTagSet a)

-- | 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 tagSet :: JATSTagSet
tagSet opts :: WriterOptions
opts d :: Pandoc
d =
  ReaderT JATSTagSet m Text -> JATSTagSet -> m Text
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT JATSState (ReaderT JATSTagSet m) Text
-> JATSState -> ReaderT JATSTagSet m Text
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (WriterOptions
-> Pandoc -> StateT JATSState (ReaderT JATSTagSet m) Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> JATS m Text
docToJATS WriterOptions
opts Pandoc
d)
               (JATSState :: [(Int, Doc Text)] -> JATSState
JATSState{ jatsNotes :: [(Int, Doc Text)]
jatsNotes = [] }))
             JATSTagSet
tagSet

-- | Convert Pandoc document to string in JATS format.
docToJATS :: PandocMonad m => WriterOptions -> Pandoc -> JATS m Text
docToJATS :: WriterOptions -> Pandoc -> JATS m Text
docToJATS opts :: WriterOptions
opts (Pandoc meta :: Meta
meta blocks :: [Block]
blocks) = do
  let isBackBlock :: Block -> Bool
isBackBlock (Div ("refs",_,_) _) = Bool
True
      isBackBlock _                    = Bool
False
  let (backblocks :: [Block]
backblocks, bodyblocks :: [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
                   TopLevelPart    -> -1
                   TopLevelChapter -> 0
                   TopLevelSection -> 1
                   TopLevelDefault -> 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 JATSTagSet 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 <- [Doc Text] -> [Doc Text]
forall a. [a] -> [a]
reverse ([Doc Text] -> [Doc Text])
-> ([(Int, Doc Text)] -> [Doc Text])
-> [(Int, Doc Text)]
-> [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])
-> StateT JATSState (ReaderT JATSTagSet m) [(Int, Doc Text)]
-> StateT JATSState (ReaderT JATSTagSet m) [Doc Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JATSState -> [(Int, Doc Text)])
-> StateT JATSState (ReaderT JATSTagSet m) [(Int, Doc Text)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets JATSState -> [(Int, Doc Text)]
jatsNotes
  Doc Text
backs <- [Block] -> JATS m (Doc Text)
fromBlocks [Block]
backblocks
  JATSTagSet
tagSet <- StateT JATSState (ReaderT JATSTagSet m) JATSTagSet
forall r (m :: * -> *). MonadReader r m => m r
ask
  -- 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 "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 "date" Context Text
metadata of
          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
               Nothing  -> Val Text
forall a. Val a
NullVal
               Just day :: Day
day ->
                 let (y :: Integer
y,m :: Int
m,d :: 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
                      [("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)
                      ,("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)
                      ,("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)
                      ,("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 "%F" Day
day)
                      ]
          Just x :: 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 "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 "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 "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 "mathml" (case WriterOptions -> HTMLMathMethod
writerHTMLMathMethod WriterOptions
opts of
                                        MathML -> Bool
True
                                        _      -> 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
       Nothing  -> Doc Text
main
       Just tpl :: 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 needsWrap :: Block -> Bool
needsWrap opts :: WriterOptions
opts =
  ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet m) [Doc Text]
 -> JATS m (Doc Text))
-> ([Block] -> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet 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 JATSTagSet m) (Doc Text)
wrappedBlockToJATS
  where
    wrappedBlockToJATS :: Block -> StateT JATSState (ReaderT JATSTagSet m) (Doc Text)
wrappedBlockToJATS b :: Block
b = do
      Doc Text
inner <- WriterOptions
-> Block -> StateT JATSState (ReaderT JATSTagSet m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts Block
b
      Doc Text -> StateT JATSState (ReaderT JATSTagSet m) (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT JATSState (ReaderT JATSTagSet m) (Doc Text))
-> Doc Text -> StateT JATSState (ReaderT JATSTagSet 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 "p" [("specific-use","wrapper")] Doc Text
inner
           else Doc Text
inner

-- | Auxiliary function to convert Plain block to Para.
plainToPara :: Block -> Block
plainToPara :: Block -> Block
plainToPara (Plain x :: [Inline]
x) = [Inline] -> Block
Para [Inline]
x
plainToPara x :: 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 opts :: WriterOptions
opts items :: [([Inline], [[Block]])]
items =
  [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet 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 opts :: WriterOptions
opts term :: [Inline]
term defs :: [[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 "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 "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 "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 opts :: WriterOptions
opts markers :: Maybe [Text]
markers items :: [[Block]]
items =
  case Maybe [Text]
markers of
       Nothing -> [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet 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 ms :: [Text]
ms -> [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet 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 opts :: WriterOptions
opts mbmarker :: Maybe Text
mbmarker item :: [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 "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 (\lbl :: Text
lbl -> Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "label" (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
lbl)) 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 src :: Text
src kvs :: [(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 "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 "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
/='/') (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 "" (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 "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 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
/='/')) (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 :: [Text] -> Text
languageFor :: [Text] -> Text
languageFor classes :: [Text]
classes =
  case [Text]
langs of
     (l :: Text
l:_) -> Text -> Text
escapeStringForXML Text
l
     []    -> ""
    where isLang :: Text -> Bool
isLang l :: 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 [Text]
languages
          langsFrom :: Text -> [Text]
langsFrom s :: Text
s = if Text -> Bool
isLang Text
s
                           then [Text
s]
                           else Text -> [Text]
languagesByExtension (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 :: Attr -> (Text, [(Text, Text)])
codeAttr :: Attr -> (Text, [(Text, Text)])
codeAttr (ident :: Text
ident,classes :: [Text]
classes,kvs :: [(Text, Text)]
kvs) = (Text
lang, [(Text, Text)]
attr)
    where
       attr :: [(Text, Text)]
attr = [("id",Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
              [("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) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["code-type",
                "code-version", "executable",
                "language-version", "orientation",
                    "platforms", "position", "specific-use"]]
       lang :: Text
lang  = [Text] -> Text
languageFor [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 _ Null = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
blockToJATS opts :: WriterOptions
opts (Div (id' :: Text
id',"section":_,kvs :: [(Text, Text)]
kvs) (Header _lvl :: Int
_lvl _ ils :: [Inline]
ils : xs :: [Block]
xs)) = do
  let idAttr :: [(Text, Text)]
idAttr = [("id", WriterOptions -> Text
writerIdentifierPrefix WriterOptions
opts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
id') | Bool -> Bool
not (Text -> Bool
T.null Text
id')]
  let otherAttrs :: [Text]
otherAttrs = ["sec-type", "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) | (k :: Text
k,v :: 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 "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 "title" Doc Text
title' Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
contents
-- Bibliography reference:
blockToJATS opts :: WriterOptions
opts (Div (Text -> Text -> Maybe Text
T.stripPrefix "ref-" -> Just _,_,_) [Para lst :: [Inline]
lst]) =
  WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
blockToJATS opts :: WriterOptions
opts (Div ("refs",_,_) xs :: [Block]
xs) = do
  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
$ Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented "ref-list" Doc Text
contents
blockToJATS opts :: WriterOptions
opts (Div (ident :: Text
ident,[cls :: Text
cls],kvs :: [(Text, Text)]
kvs) bs :: [Block]
bs) | Text
cls Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["fig", "caption", "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 = [("id", Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("xml:lang",Text
l) | ("lang",l :: Text
l) <- [(Text, Text)]
kvs] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["specific-use",
                 "content-type", "orientation", "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 opts :: WriterOptions
opts (Div (ident :: Text
ident,_,kvs :: [(Text, Text)]
kvs) bs :: [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 = [("id", Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("xml:lang",Text
l) | ("lang",l :: Text
l) <- [(Text, Text)]
kvs] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["specific-use",
                 "content-type", "orientation", "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 "boxed-text" [(Text, Text)]
attr Doc Text
contents
blockToJATS opts :: WriterOptions
opts (Header _ _ title :: [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 "title" Doc Text
title'
-- No Plain, everything needs to be in a block-level tag
blockToJATS opts :: WriterOptions
opts (Plain lst :: [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)
-- title beginning with fig: indicates that the image is a figure
blockToJATS opts :: WriterOptions
opts (Para [Image (ident :: Text
ident,_,kvs :: [(Text, Text)]
kvs) txt :: [Inline]
txt
  (src :: Text
src,Text -> Text -> Maybe Text
T.stripPrefix "fig:" -> Just tit :: 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 (maintype :: Text
maintype, subtype :: 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 "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 "p" Doc Text
alt
  let attr :: [(Text, Text)]
attr = [("id", 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) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["fig-type", "orientation",
                                              "position", "specific-use"]]
  let graphicattr :: [(Text, Text)]
graphicattr = [("mimetype",Text
maintype),
                     ("mime-subtype",Text
subtype),
                     ("xlink:href",Text
src),  -- do we need to URL escape this?
                     ("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 "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 "graphic" [(Text, Text)]
graphicattr
blockToJATS _ (Para [Image (ident :: Text
ident,_,kvs :: [(Text, Text)]
kvs) _ (src :: Text
src, tit :: Text
tit)]) = do
  let (maintype :: Text
maintype, subtype :: Text
subtype) = Text -> [(Text, Text)] -> (Text, Text)
imageMimeType Text
src [(Text, Text)]
kvs
  let attr :: [(Text, Text)]
attr = [("id", Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("mimetype", Text
maintype),
              ("mime-subtype", Text
subtype),
              ("xlink:href", Text
src)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("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) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["baseline-shift",
                        "content-type", "specific-use", "xlink:actuate",
                        "xlink:href", "xlink:role", "xlink:show",
                        "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 "graphic" [(Text, Text)]
attr
blockToJATS opts :: WriterOptions
opts (Para lst :: [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "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 opts :: WriterOptions
opts (LineBlock lns :: [[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 opts :: WriterOptions
opts (BlockQuote blocks :: [Block]
blocks) = do
  JATSTagSet
tagSet <- StateT JATSState (ReaderT JATSTagSet m) JATSTagSet
forall r (m :: * -> *). MonadReader r m => m r
ask
  let blocksToJats' :: WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJats' = if JATSTagSet
tagSet JATSTagSet -> JATSTagSet -> Bool
forall a. Eq a => a -> a -> Bool
== JATSTagSet
TagSetArticleAuthoring
                      then (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)
                      else WriterOptions -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJATS
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented "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
<$> WriterOptions -> [Block] -> JATS m (Doc Text)
blocksToJats' WriterOptions
opts [Block]
blocks
blockToJATS _ (CodeBlock a :: Attr
a 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
$
  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 (lang :: Text
lang, attr :: [(Text, Text)]
attr) = Attr -> (Text, [(Text, Text)])
codeAttr Attr
a
          tag :: Text
tag          = if Text -> Bool
T.null Text
lang then "preformat" else "code"
blockToJATS _ (BulletList []) = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
blockToJATS opts :: WriterOptions
opts (BulletList lst :: [[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 "list" [("list-type", "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 _ (OrderedList _ []) = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
blockToJATS opts :: WriterOptions
opts (OrderedList (start :: Int
start, numstyle :: ListNumberStyle
numstyle, delimstyle :: ListNumberDelim
delimstyle) items :: [[Block]]
items) = do
  JATSTagSet
tagSet <- StateT JATSState (ReaderT JATSTagSet m) JATSTagSet
forall r (m :: * -> *). MonadReader r m => m r
ask
  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 "order"
        else case ListNumberStyle
numstyle of
               DefaultStyle -> "order"
               Decimal      -> "order"
               Example      -> "order"
               UpperAlpha   -> "alpha-upper"
               LowerAlpha   -> "alpha-lower"
               UpperRoman   -> "roman-upper"
               LowerRoman   -> "roman-lower"
  let simpleList :: Bool
simpleList = Int
start Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
$
                          (Int, ListNumberStyle, ListNumberDelim) -> [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 "list" [("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 opts :: WriterOptions
opts (DefinitionList lst :: [([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 "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 _ b :: Block
b@(RawBlock f :: Format
f str :: Text
str)
  | Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== "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 JATSTagSet m) ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT JATSState (ReaderT JATSTagSet m) ())
-> LogMessage -> StateT JATSState (ReaderT JATSTagSet 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 _ 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 opts :: WriterOptions
opts (Table [] aligns :: [Alignment]
aligns widths :: [Double]
widths headers :: [[Block]]
headers rows :: [[[Block]]]
rows) = do
  let percent :: a -> Text
percent w :: a
w    = Integer -> Text
forall a. Show a => a -> Text
tshow (a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate (100a -> a -> a
forall a. Num a => a -> a -> a
*a
w) :: Integer) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "*"
  let coltags :: Doc Text
coltags = [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall a b. (a -> b) -> a -> b
$ (Double -> Alignment -> Doc Text)
-> [Double] -> [Alignment] -> [Doc Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\w :: Double
w al :: Alignment
al -> Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag "col"
                       ([("width", Double -> Text
forall a. RealFrac a => a -> Text
percent Double
w) | Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> 0] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
                        [("align", Alignment -> Text
alignmentToText Alignment
al)])) [Double]
widths [Alignment]
aligns
  Doc Text
thead <- if ([Block] -> Bool) -> [[Block]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Block] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Block]]
headers
              then Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
              else Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented "thead" (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 -> Bool -> [[Block]] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Bool -> [[Block]] -> JATS m (Doc Text)
tableRowToJATS WriterOptions
opts Bool
True [[Block]]
headers
  Doc Text
tbody <- (Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented "tbody" (Doc Text -> Doc Text)
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat) ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Bool -> [[Block]] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Bool -> [[Block]] -> JATS m (Doc Text)
tableRowToJATS WriterOptions
opts Bool
False) [[[Block]]]
rows
  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 "table" [] (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Doc Text
coltags Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
thead Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
tbody
blockToJATS opts :: WriterOptions
opts (Table caption :: [Inline]
caption aligns :: [Alignment]
aligns widths :: [Double]
widths headers :: [[Block]]
headers rows :: [[[Block]]]
rows) = do
  Doc Text
captionDoc <- Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented "caption" (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 -> Block -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts ([Inline] -> Block
Para [Inline]
caption)
  Doc Text
tbl <- WriterOptions -> Block -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts ([Inline]
-> [Alignment] -> [Double] -> [[Block]] -> [[[Block]]] -> Block
Table [] [Alignment]
aligns [Double]
widths [[Block]]
headers [[[Block]]]
rows)
  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 "table-wrap" [] (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Doc Text
captionDoc Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
tbl

alignmentToText :: Alignment -> Text
alignmentToText :: Alignment -> Text
alignmentToText alignment :: Alignment
alignment = case Alignment
alignment of
                                 AlignLeft    -> "left"
                                 AlignRight   -> "right"
                                 AlignCenter  -> "center"
                                 AlignDefault -> "left"

tableRowToJATS :: PandocMonad m
                  => WriterOptions
                  -> Bool
                  -> [[Block]]
                  -> JATS m (Doc Text)
tableRowToJATS :: WriterOptions -> Bool -> [[Block]] -> JATS m (Doc Text)
tableRowToJATS opts :: WriterOptions
opts isHeader :: Bool
isHeader cols :: [[Block]]
cols =
  (Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented "tr" (Doc Text -> Doc Text)
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat) ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Bool -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Bool -> [Block] -> JATS m (Doc Text)
tableItemToJATS WriterOptions
opts Bool
isHeader) [[Block]]
cols

tableItemToJATS :: PandocMonad m
                   => WriterOptions
                   -> Bool
                   -> [Block]
                   -> JATS m (Doc Text)
tableItemToJATS :: WriterOptions -> Bool -> [Block] -> JATS m (Doc Text)
tableItemToJATS opts :: WriterOptions
opts isHeader :: Bool
isHeader [Plain item :: [Inline]
item] =
  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 (if Bool
isHeader then "th" else "td") [] (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]
item
tableItemToJATS opts :: WriterOptions
opts isHeader :: Bool
isHeader item :: [Block]
item =
  (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 (if Bool
isHeader then "th" else "td") [] (Doc Text -> Doc Text)
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat) ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Block -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts) [Block]
item

-- | 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 opts :: WriterOptions
opts lst :: [Inline]
lst = [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
hcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT JATSTagSet 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 JATSTagSet 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 (x :: Inline
x:xs :: [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 "jats") z :: Text
z) =
           "<pub-id pub-id-type=" Text -> Text -> Bool
`T.isPrefixOf` Text
z
       needsFixing _           = Bool
False
       isRawInline :: Inline -> Bool
isRawInline RawInline{} = Bool
True
       isRawInline _           = Bool
False
       (ys :: [Inline]
ys,zs :: [Inline]
zs)                 = (Inline -> Bool) -> [Inline] -> ([Inline], [Inline])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Inline -> Bool
isRawInline [Inline]
xs
   fixCitations (x :: Inline
x:xs :: [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 _ (Str 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 opts :: WriterOptions
opts (Emph lst :: [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "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 opts :: WriterOptions
opts (Strong lst :: [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "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 opts :: WriterOptions
opts (Strikeout lst :: [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "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 opts :: WriterOptions
opts (Superscript lst :: [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "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 opts :: WriterOptions
opts (Subscript lst :: [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "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 opts :: WriterOptions
opts (SmallCaps lst :: [Inline]
lst) =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "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 opts :: WriterOptions
opts (Quoted SingleQuote lst :: [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 '‘' 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 '’'
inlineToJATS opts :: WriterOptions
opts (Quoted DoubleQuote lst :: [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 '“' 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 '”'
inlineToJATS _ (Code a :: Attr
a 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
$ 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 (lang :: Text
lang, attr :: [(Text, Text)]
attr) = Attr -> (Text, [(Text, Text)])
codeAttr Attr
a
          tag :: Text
tag          = if Text -> Bool
T.null Text
lang then "monospace" else "code"
inlineToJATS _ il :: Inline
il@(RawInline f :: Format
f x :: Text
x)
  | Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== "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 JATSTagSet m) ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT JATSState (ReaderT JATSTagSet m) ())
-> LogMessage -> StateT JATSState (ReaderT JATSTagSet 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 _ 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 _ Space = Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
space
inlineToJATS opts :: WriterOptions
opts 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 opts :: WriterOptions
opts (Note contents :: [Block]
contents) = do
  JATSTagSet
tagSet <- StateT JATSState (ReaderT JATSTagSet m) JATSTagSet
forall r (m :: * -> *). MonadReader r m => m r
ask
  -- 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 "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 JATSTagSet 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
                      (n :: Int
n, _):_ -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
                      []       -> 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 "fn" [("id","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) -> 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 JATSTagSet m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((JATSState -> JATSState)
 -> StateT JATSState (ReaderT JATSTagSet m) ())
-> (JATSState -> JATSState)
-> StateT JATSState (ReaderT JATSTagSet m) ()
forall a b. (a -> b) -> a -> b
$ \st :: 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 "xref" [("ref-type", "fn"),
                                    ("rid", "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 opts :: WriterOptions
opts (Cite _ lst :: [Inline]
lst) =
  -- TODO revisit this after examining the jats.csl pipeline
  WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
lst
inlineToJATS opts :: WriterOptions
opts (Span ("",_,[]) ils :: [Inline]
ils) = WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
ils
inlineToJATS opts :: WriterOptions
opts (Span (ident :: Text
ident,_,kvs :: [(Text, Text)]
kvs) ils :: [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 attr :: [(Text, Text)]
attr = [("id",Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("xml:lang",Text
l) | ("lang",l :: Text
l) <- [(Text, Text)]
kvs] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs
                    ,  Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["content-type", "rationale",
                                 "rid", "specific-use"]]
  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 "milestone-start" [(Text, Text)]
attr 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
<>
           Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag "milestone-end" []
inlineToJATS _ (Math t :: MathType
t str :: Text
str) = do
  let addPref :: Attr -> Attr
addPref (Xml.Attr q :: QName
q v :: String
v)
         | QName -> String
Xml.qName QName
q String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "xmlns" = QName -> String -> Attr
Xml.Attr QName
q{ qName :: String
Xml.qName = "xmlns:mml" } String
v
         | Bool
otherwise = QName -> String -> Attr
Xml.Attr QName
q String
v
  let fixNS' :: Element -> Element
fixNS' e :: 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 "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
.
              (\e :: 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 JATSTagSet 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
                     DisplayMath -> "disp-formula"
                     InlineMath  -> "inline-formula"

  let rawtex :: Doc Text
rawtex = String -> Doc Text
forall a. HasChars a => String -> Doc a
text "<![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 "]]>"
  let texMath :: Doc Text
texMath = Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsSimple "tex-math" Doc Text
rawtex

  JATSTagSet
tagSet <- StateT JATSState (ReaderT JATSTagSet m) JATSTagSet
forall r (m :: * -> *). MonadReader r m => m r
ask
  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 r :: 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 "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 _   -> if JATSTagSet
tagSet JATSTagSet -> JATSTagSet -> Bool
forall a. Eq a => a -> a -> Bool
/= JATSTagSet
TagSetArticleAuthoring
                  then Doc Text
texMath
                  else Doc Text
rawtex
inlineToJATS _ (Link _attr :: Attr
_attr [Str t :: Text
t] (Text -> Text -> Maybe Text
T.stripPrefix "mailto:" -> Just email :: Text
email, _))
  | 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 "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 opts :: WriterOptions
opts (Link (ident :: Text
ident,_,kvs :: [(Text, Text)]
kvs) txt :: [Inline]
txt (Text -> Maybe (Char, Text)
T.uncons -> Just ('#', src :: Text
src), _)) = do
  let attr :: [(Text, Text)]
attr = [("id", Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("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, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("rid", Text
src)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [(Text
k,Text
v) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["ref-type", "specific-use"]]
  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 "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 "xref" [(Text, Text)]
attr Doc Text
contents
inlineToJATS opts :: WriterOptions
opts (Link (ident :: Text
ident,_,kvs :: [(Text, Text)]
kvs) txt :: [Inline]
txt (src :: Text
src, tit :: Text
tit)) = do
  let attr :: [(Text, Text)]
attr = [("id", Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("ext-link-type", "uri"),
              ("xlink:href", Text
src)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("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) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["assigning-authority",
                                              "specific-use", "xlink:actuate",
                                              "xlink:role", "xlink:show",
                                              "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 "ext-link" [(Text, Text)]
attr Doc Text
contents
inlineToJATS _ (Image (ident :: Text
ident,_,kvs :: [(Text, Text)]
kvs) _ (src :: Text
src, tit :: 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 "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 "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
/='/') (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 "" (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 "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 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
/='/')) (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 = [("id", Text
ident) | Bool -> Bool
not (Text -> Bool
T.null Text
ident)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("mimetype", Text
maintype),
              ("mime-subtype", Text
subtype),
              ("xlink:href", Text
src)] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
             [("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) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["baseline-shift",
                        "content-type", "specific-use", "xlink:actuate",
                        "xlink:href", "xlink:role", "xlink:show",
                        "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 "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 _                = Bool
False

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

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

parseDate :: Text -> Maybe Day
parseDate :: Text -> Maybe Day
parseDate s :: 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 (\fs :: String
fs -> String -> String -> Maybe Day
parsetimeWith String
fs (String -> Maybe Day) -> String -> Maybe Day
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s) [String]
formats) :: Maybe Day
  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 = ["%x","%m/%d/%Y", "%D","%F", "%d %b %Y",
                    "%e %B %Y", "%b. %e, %Y", "%B %e, %Y",
                    "%Y%m%d", "%Y%m", "%Y"]