pandoc-3.9: src/Text/Pandoc/Readers/JATS.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Readers.JATS
Copyright : Copyright (C) 2017-2020 Hamish Mackenzie
License : GNU GPL, version 2 or above
Maintainer : John MacFarlane <jgm@berkeley.edu>
Stability : alpha
Portability : portable
Conversion of JATS XML to 'Pandoc' document.
-}
module Text.Pandoc.Readers.JATS ( readJATS ) where
import Control.Monad.State.Strict ( StateT(runStateT), gets, modify )
import Control.Monad (forM_, when, unless)
import Control.Monad.Except (throwError)
import Text.Pandoc.Error (PandocError(..))
import Data.Char (isDigit, isSpace)
import Data.Default
import Data.Generics
import qualified Data.List as L
import qualified Data.Map as Map
import Data.Maybe (maybeToList, fromMaybe, catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Text.Pandoc.XML (lookupEntity)
import Text.Pandoc.Builder
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Options
import Text.Pandoc.Shared (safeRead)
import Text.Pandoc.Walk (walk)
import Text.Pandoc.XML.Light
import Text.TeXMath (readMathML, writeTeX)
import qualified Data.Set as S (fromList, member)
import Data.Set ((\\))
import Text.Pandoc.Sources (ToSources(..), sourcesToText)
import Safe (headMay)
import Text.Printf (printf)
type JATS m = StateT JATSState m
data JATSState = JATSState{ jatsSectionLevel :: Int
, jatsQuoteType :: QuoteType
, jatsMeta :: Meta
, jatsBook :: Bool
, jatsFootnotes :: Map.Map Text Blocks
, jatsContent :: [Content]
, jatsInFigure :: Bool
} deriving Show
instance Default JATSState where
def = JATSState{ jatsSectionLevel = 0
, jatsQuoteType = DoubleQuote
, jatsMeta = mempty
, jatsBook = False
, jatsFootnotes = mempty
, jatsContent = []
, jatsInFigure = False }
readJATS :: (PandocMonad m, ToSources a)
=> ReaderOptions
-> a
-> m Pandoc
readJATS _ inp = do
let sources = toSources inp
tree <- either (throwError . PandocXMLError "") return $
parseXMLContents (TL.fromStrict . sourcesToText $ sources)
(bs, st') <- flip runStateT (def{ jatsContent = tree }) $ mapM parseBlock tree
let footnotes = jatsFootnotes st'
let blockList = toList $ mconcat bs
let linkToFootnotes :: Inline -> Inline
linkToFootnotes link'@(Link _attr _txt (href, _title)) =
case T.uncons href of
Just ('#', rid) -> case Map.lookup rid footnotes of
Just footnote -> Note (toList footnote)
Nothing -> link'
_ -> link'
linkToFootnotes inline = inline
return $ Pandoc (jatsMeta st') (walk linkToFootnotes blockList)
-- convenience function to get an attribute value, defaulting to ""
attrValue :: Text -> Element -> Text
attrValue attr =
fromMaybe "" . maybeAttrValue attr
maybeAttrValue :: Text -> Element -> Maybe Text
maybeAttrValue attr elt =
lookupAttrBy (\x -> qName x == attr) (elAttribs elt)
-- convenience function
named :: Text -> Element -> Bool
named s e = qName (elName e) == s
--
addMeta :: PandocMonad m => ToMetaValue a => Text -> a -> JATS m ()
addMeta field val = modify (setMeta field val)
instance HasMeta JATSState where
setMeta field v s = s {jatsMeta = setMeta field v (jatsMeta s)}
deleteMeta field s = s {jatsMeta = deleteMeta field (jatsMeta s)}
isBlockElement :: Content -> Bool
isBlockElement (Elem e) = case qName (elName e) of
"disp-formula" -> if onlyOneChild e
then if hasFormulaChild e
then False
else case filterChild (named "alternatives") e of
Just a -> if hasFormulaChild a then False else True
Nothing -> True
else True
"alternatives" -> if hasFormulaChild e then False else True
_ -> qName (elName e) `S.member` blocktags
where blocktags = S.fromList (paragraphLevel ++ lists ++ formulae ++ other) \\ S.fromList canBeInline
paragraphLevel = ["address", "answer", "answer-set", "array", "boxed-text", "chem-struct-wrap",
"code", "explanation", "fig", "fig-group", "graphic", "media", "preformat", "question", "question-wrap", "question-wrap-group",
"supplementary-material", "table-wrap", "table-wrap-group",
"alternatives", "disp-formula", "disp-formula-group"]
lists = ["def-list", "list"]
formulae = ["tex-math", "mml:math"]
other = ["p", "related-article", "related-object", "ack", "disp-quote",
"speech", "statement", "verse-group", "x"]
canBeInline = ["tex-math", "mml:math", "related-object", "x"]
onlyOneChild x = length (allChildren x) == 1
allChildren x = filterChildren (const True) x
isBlockElement _ = False
-- Trim leading and trailing newline characters
trimNl :: Text -> Text
trimNl = T.dropAround (== '\n')
-- function that is used by both graphic (in parseBlock)
-- and inline-graphic (in parseInline)
getGraphic :: PandocMonad m => Element -> JATS m Inlines
getGraphic e = do
let atVal a = attrValue a e
let altText = case filterElement (named "alt-text") e of
Just alt -> textContent alt
Nothing -> mempty
(ident, title, altText') = (atVal "id", atVal "title", text altText)
attr = (ident, T.words $ atVal "role", [])
imageUrl = atVal "href"
return $ imageWith attr imageUrl title altText'
getBlocks :: PandocMonad m => Element -> JATS m Blocks
getBlocks e = mconcat <$>
mapM parseBlock (elContent e)
parseBlock :: PandocMonad m => Content -> JATS m Blocks
parseBlock (Text (CData CDataRaw _ _)) = return mempty -- DOCTYPE
parseBlock (Text (CData _ s _)) = if T.all isSpace s
then return mempty
else return $ plain $ trimInlines $ text s
parseBlock (CRef x) = return $ plain $ str $ T.toUpper x
parseBlock (Elem e) = do
sectionLevel <- gets jatsSectionLevel
let parseBlockWithHeader = wrapWithHeader (sectionLevel+1) (getBlocks e)
case qName (elName e) of
"book" -> parseBook
"book-part-wrapper" -> parseBook
"p" -> parseMixed para (elContent e)
"code" -> codeBlockWithLang
"preformat" -> codeBlockWithLang
"disp-quote" -> wrapWithHeader (sectionLevel+1) parseBlockquote
"list" -> wrapWithHeader (sectionLevel+1) parseList
"def-list" -> wrapWithHeader (sectionLevel+1) (definitionList <$> deflistitems)
"sec" -> parseBlockWithHeader
"abstract" -> parseBlockWithHeader
"ack" -> parseBlockWithHeader
"answer" -> parseBlockWithHeader
"answer-set" -> parseBlockWithHeader
"app" -> parseBlockWithHeader
"app-group" -> parseBlockWithHeader
"author-comment" -> parseBlockWithHeader
"author-notes" -> parseBlockWithHeader
"back" -> parseBlockWithHeader
"bio" -> parseBlockWithHeader
"explanation" -> parseBlockWithHeader
"glossary" -> parseBlockWithHeader
"kwd-group" -> parseBlockWithHeader
"list-item" -> parseBlockWithHeader
"notes" -> parseBlockWithHeader
"option" -> parseBlockWithHeader
"question" -> parseBlockWithHeader
"question-preamble" -> parseBlockWithHeader
"question-wrap-group" -> parseBlockWithHeader
"statement" -> parseBlockWithHeader
"supplement" -> parseBlockWithHeader
"table-wrap-foot" -> parseBlockWithHeader
"trans-abstract" -> parseBlockWithHeader
"verse-group" -> parseBlockWithHeader
"graphic" -> para <$> getGraphic e
"journal-meta" -> parseMetadata e
"article-meta" -> parseMetadata e
"custom-meta" -> parseMetadata e
"processing-meta" -> return mempty
"book-meta" -> parseMetadata e
"title" -> return mempty -- processed by header
"label" -> return mempty -- processed by header
"table" -> parseTable
"fig" -> parseFigure
"fig-group" -> divWith (attrValue "id" e, ["fig-group"], [])
<$> getBlocks e
"table-wrap" -> divWith (attrValue "id" e, ["table-wrap"], [])
<$> getBlocks e
"caption" -> do
inFigure <- gets jatsInFigure
if inFigure -- handled by parseFigure
then return mempty
else divWith (attrValue "id" e, ["caption"], []) <$> wrapWithHeader 6 (getBlocks e)
"fn-group" -> parseFootnoteGroup
"ref-list" -> parseRefList e
"alternatives" -> if hasFormulaChild e
then blockFormula displayMath e
else getBlocks e
"disp-formula" -> if hasFormulaChild e
then blockFormula displayMath e
else divWith (attrValue "id" e, ["disp-formula"], [])
<$> getBlocks e
"index" -> parseBlockWithHeader
"index-div" -> parseBlockWithHeader
"index-group" -> parseBlockWithHeader
"index-title-group" -> return mempty -- handled by index and index-div
"toc" -> parseBlockWithHeader
"toc-div" -> parseBlockWithHeader
"toc-entry" -> parseBlockWithHeader
"toc-group" -> parseBlockWithHeader
"toc-title-group" -> return mempty -- handled by toc
"legend" -> parseBlockWithHeader
"dedication" -> parseBlockWithHeader
"foreword" -> parseBlockWithHeader
"preface" -> parseBlockWithHeader
"?xml" -> return mempty
_ -> getBlocks e
where parseMixed container conts = do
let (ils,rest) = break isBlockElement conts
ils' <- trimInlines . mconcat <$> mapM parseInline ils
let p = if ils' == mempty then mempty else container ils'
case rest of
[] -> return p
(r:rs) -> do
b <- parseBlock r
x <- parseMixed container rs
return $ p <> b <> x
codeBlockWithLang = do
let classes' = case attrValue "language" e of
"" -> []
x -> [x]
return $ codeBlockWith (attrValue "id" e, classes', [])
$ trimNl $ strContentRecursive e
parseBlockquote = do
attrib <- case filterChild (named "attrib") e of
Nothing -> return mempty
Just z -> para . (str "— " <>) . mconcat
<$>
mapM parseInline (elContent z)
contents <- getBlocks e
return $ blockQuote (contents <> attrib)
parseList = do
case attrValue "list-type" e of
"bullet" -> bulletList <$> listitems
listType -> do
let start =
fromMaybe 1 $
( filterElement (named "list-item") e
>>= filterElement (named "label")
)
>>= safeRead . textContent
orderedListWith (start, parseListStyleType listType, DefaultDelim)
<$> listitems
parseListStyleType "roman-lower" = LowerRoman
parseListStyleType "roman-upper" = UpperRoman
parseListStyleType "alpha-lower" = LowerAlpha
parseListStyleType "alpha-upper" = UpperAlpha
parseListStyleType _ = DefaultStyle
listitems = mapM getBlocks $ filterChildren (named "list-item") e
deflistitems = mapM parseVarListEntry $ filterChildren
(named "def-item") e
parseVarListEntry e' = do
let terms = filterChildren (named "term") e'
let items = filterChildren (named "def") e'
terms' <- mapM getInlines terms
items' <- mapM getBlocks items
return (mconcat $ L.intersperse (str "; ") terms', items')
parseFigure = do
modify $ \st -> st{ jatsInFigure = True }
capt <- case filterChild (named "caption") e of
Just t -> mconcat . L.intersperse linebreak <$>
mapM getInlines (filterChildren (const True) t)
Nothing -> return mempty
contents <- getBlocks e
modify $ \st -> st{ jatsInFigure = False }
return $ figureWith
(attrValue "id" e, [], [])
(simpleCaption $ plain capt)
contents
parseFootnoteGroup = do
forM_ (filterChildren (named "fn") e) $ \fn -> do
let id' = attrValue "id" fn
contents <- getBlocks fn
modify $ \st ->
st { jatsFootnotes = Map.insert id' contents (jatsFootnotes st) }
return mempty
parseTable = do
let isCaption x = named "title" x || named "caption" x
capt <- case filterChild isCaption e of
Just t -> getInlines t
Nothing -> return mempty
let e' = fromMaybe e $ filterChild (named "tgroup") e
let isColspec x = named "colspec" x || named "col" x
let colspecs = case filterChild (named "colgroup") e' of
Just c -> filterChildren isColspec c
_ -> filterChildren isColspec e'
let isRow x = named "row" x || named "tr" x
let parseRows elementWithRows =
map parseElement $ filterChildren isRow elementWithRows
-- list of list of body cell elements
let multipleBodyRowElements =
map parseRows $ filterChildren (named "tbody") e'
-- list of list header cell elements
let headRowElements = maybe [] parseRows (filterChild (named "thead") e')
-- list of foot cell elements
let footRowElements = maybe [] parseRows (filterChild (named "tfoot") e')
let toAlignment c = case findAttr (unqual "align") c of
Just "left" -> AlignLeft
Just "right" -> AlignRight
Just "center" -> AlignCenter
_ -> AlignDefault
let toColSpan element = fromMaybe 1 $
findAttr (unqual "colspan") element >>= safeRead
let toRowSpan element = fromMaybe 1 $
findAttr (unqual "rowspan") element >>= safeRead
let toWidth c = do
w <- findAttr (unqual "colwidth") c
n <- safeRead $ "0" <> T.filter (\x -> isDigit x || x == '.') w
if n > 0 then Just n else Nothing
let firstBody = fromMaybe [] (headMay multipleBodyRowElements)
let numrows = L.foldl' max 0 $ map length firstBody
let aligns = case colspecs of
[] -> replicate numrows AlignDefault
cs -> map toAlignment cs
let widths = case colspecs of
[] -> replicate numrows ColWidthDefault
cs -> let ws = map toWidth cs
in case sequence ws of
Just ws' -> let tot = sum ws'
in ColWidth . (/ tot) <$> ws'
Nothing -> replicate numrows ColWidthDefault
let parseCell = parseMixed plain . elContent
let elementToCell element = cell
(toAlignment element)
(RowSpan $ toRowSpan element)
(ColSpan $ toColSpan element)
<$> (parseCell element)
let rowElementsToCells elements = mapM elementToCell elements
let toRow = fmap (Row nullAttr) . rowElementsToCells
toRows elements = mapM toRow elements
headerRows <- toRows headRowElements
footerRows <- toRows footRowElements
bodyRows <- mapM toRows multipleBodyRowElements
return $ table (simpleCaption $ plain capt)
(zip aligns widths)
(TableHead nullAttr headerRows)
(map (TableBody nullAttr 0 []) bodyRows)
(TableFoot nullAttr footerRows)
isEntry x = named "entry" x || named "td" x || named "th" x
parseElement = filterChildren isEntry
wrapWithHeader n mBlocks = do
isBook <- gets jatsBook
let n' = case (filterChild (named "title") e >>= maybeAttrValue "display-as") of
Just t -> read $ T.unpack t
Nothing -> if isBook || n == 0 then n + 1 else n
headerText <- case filterChild (named "title") e of
Just t -> case maybeAttrValue "suppress" t of
Just s -> if s == "no"
then getInlines t
else return mempty
Nothing -> getInlines t
Nothing -> do
let name = qName (elName e)
if (name == "dedication" || name == "foreword" || name == "preface")
then return $ str $ T.toTitle name
else case filterChild (named "index-title-group") e >>= filterChild (named "title") of
Just i -> getInlines i
Nothing -> case filterChild (named "toc-title-group") e >>= filterChild (named "title") of
Just t -> getInlines t
Nothing -> return mempty
oldN <- gets jatsSectionLevel
modify $ \st -> st{ jatsSectionLevel = n }
blocks <- mBlocks
let ident = attrValue "id" e
modify $ \st -> st{ jatsSectionLevel = oldN }
return $ (if headerText == mempty
then mempty
else headerWith (ident,[],[]) n' headerText) <> blocks
parseBook = do
modify $ \st -> st{ jatsBook = True }
getBlocks e
getInlines :: PandocMonad m => Element -> JATS m Inlines
getInlines e' = trimInlines . mconcat <$>
mapM parseInline (elContent e')
parseMetadata :: PandocMonad m => Element -> JATS m Blocks
parseMetadata e = do
isBook <- gets jatsBook
if isBook then getBookTitle e else getArticleTitle e
if isBook then getBookAuthors e else getArticleAuthors e
getAffiliations e
getAbstract e
getPubDate e
getPermissions e
return mempty
getArticleTitle :: PandocMonad m => Element -> JATS m ()
getArticleTitle e = do
tit <- case filterElement (named "article-title") e of
Just s -> getInlines s
Nothing -> return mempty
subtit <- case filterElement (named "subtitle") e of
Just s -> (text ": " <>) <$>
getInlines s
Nothing -> return mempty
when (tit /= mempty) $ addMeta "title" tit
when (subtit /= mempty) $ addMeta "subtitle" subtit
getBookTitle :: PandocMonad m => Element -> JATS m ()
getBookTitle e = do
tit <- case (filterElement (named "book-title-group") e >>= filterElement (named "book-title")) of
Just s -> getInlines s
Nothing -> return mempty
subtit <- case (filterElement (named "book-title-group") e >>= filterElement (named "subtitle")) of
Just s -> (text ": " <>) <$>
getInlines s
Nothing -> return mempty
when (tit /= mempty) $ addMeta "title" tit
when (subtit /= mempty) $ addMeta "subtitle" subtit
getArticleAuthors :: PandocMonad m => Element -> JATS m ()
getArticleAuthors e = do
authors <- mapM getContrib $ filterElements
(\x -> named "contrib" x &&
attrValue "contrib-type" x == "author") e
authorNotes <- mapM getInlines $ filterElements (named "author-notes") e
let authors' = case (reverse authors, authorNotes) of
([], _) -> []
(_, []) -> authors
(a:as, ns) -> reverse as ++ [a <> mconcat ns]
unless (null authors) $ addMeta "author" authors'
getBookAuthors :: PandocMonad m => Element -> JATS m ()
getBookAuthors e = do
authors <- mapM getContrib $ filterElements (\x -> named "contrib-group" x) e
>>= filterElements (\x -> named "contrib" x &&
attrValue "contrib-type" x == "author")
authorNotes <- mapM getInlines $ filterElements (named "author-notes") e
let authors' = case (reverse authors, authorNotes) of
([], _) -> []
(_, []) -> authors
(a:as, ns) -> reverse as ++ [a <> mconcat ns]
unless (null authors) $ addMeta "author" authors'
getAffiliations :: PandocMonad m => Element -> JATS m ()
getAffiliations x = do
affs <- mapM getInlines $ filterChildren (named "aff") x
unless (null affs) $ addMeta "institute" affs
getAbstract :: PandocMonad m => Element -> JATS m ()
getAbstract e =
case filterElement (named "abstract") e of
Just s -> do
blks <- getBlocks s
addMeta "abstract" blks
Nothing -> pure ()
getPubDate :: PandocMonad m => Element -> JATS m ()
getPubDate e =
case filterElement (named "pub-date") e of
Just d -> getDate d >>= addMeta "date" . text
Nothing -> pure ()
-- extract a structured date and create an ISO-8901 string date from it
getDate :: PandocMonad m => Element -> JATS m Text
getDate e =
case maybeAttrValue "iso-8601-date" e of
Just isod -> pure isod
Nothing -> do
let extractDate :: Element -> Maybe Int
extractDate = safeRead . strContent
let yr = filterElement (named "year") e >>= extractDate
let mon = filterElement (named "month") e >>= extractDate
let day = filterElement (named "day") e >>= extractDate
let stringDate = strContent <$> filterElement (named "string-date") e
pure $
case (yr, mon, day) of
(Just y, Just m, Just d) -> T.pack $ printf "%04d-%02d-%02d" y m d
(Just y, Just m, Nothing) -> T.pack $ printf "%04d-%02d" y m
(Just y, Nothing, Nothing) -> T.pack $ printf "%04d" y
_ -> fromMaybe mempty stringDate
getPermissions :: PandocMonad m => Element -> JATS m ()
getPermissions e = do
copyright <- getCopyright e
license <- case filterElement (named "license") e of
Just s -> getLicense s
Nothing -> return mempty
when (copyright /= mempty) $ addMeta "copyright" copyright
when (license /= mempty) $ addMeta "license" license
getCopyright :: PandocMonad m => Element -> JATS m (Map.Map Text MetaValue)
getCopyright e = do
let holder = metaElement e "copyright-holder" "holder"
let statement = metaElement e "copyright-statement" "statement"
let year = metaElement e "copyright-year" "year"
return $ Map.fromList (catMaybes $ [holder, statement, year])
getLicense :: PandocMonad m => Element -> JATS m (Map.Map Text MetaValue)
getLicense e = do
let licenseType = metaAttribute e "license-type" "type"
let licenseLink = metaElementAliRef e "link"
let licenseText = metaElement e "license-p" "text"
return $ Map.fromList (catMaybes $ [licenseType, licenseLink, licenseText])
metaElement :: Element -> Text -> Text -> Maybe (Text, MetaValue)
metaElement e child key =
case filterElement (named child) e of
Just content -> Just (key, toMetaValue $ strContent content)
Nothing -> Nothing
metaElementAliRef :: Element -> Text -> Maybe (Text, MetaValue)
metaElementAliRef e key =
case filterElement isAliLicenseRef e of
Just content -> Just (key, toMetaValue $ strContent content)
Nothing -> Nothing
metaAttribute :: Element -> Text -> Text -> Maybe (Text, MetaValue)
metaAttribute e attr key =
case maybeAttrValue attr e of
Just content -> Just (key, toMetaValue content)
Nothing -> Nothing
getContrib :: PandocMonad m => Element -> JATS m Inlines
getContrib x = do
given <- maybe (return mempty) getInlines
$ filterElement (named "given-names") x
family <- maybe (return mempty) getInlines
$ filterElement (named "surname") x
if given == mempty && family == mempty
then return mempty
else if given == mempty || family == mempty
then return $ given <> family
else return $ given <> space <> family
parseRefList :: PandocMonad m => Element -> JATS m Blocks
parseRefList e = do
refs <- mapM parseRef $ filterChildren (named "ref") e
let mbtitle = filterChild (named "title") e
title <- case mbtitle of
Nothing -> pure mempty
Just te -> header 1 <$> parseInline (Elem te)
addMeta "references" refs
return $ title <> divWith ("refs",[],[]) mempty
parseRef :: PandocMonad m
=> Element -> JATS m (Map.Map Text MetaValue)
parseRef e = do
let combineWithDash x y = x <> text "-" <> y
let getName nm = do
given <- maybe (return mempty) getInlines
$ filterChild (named "given-names") nm
family <- maybe (return mempty) getInlines
$ filterChild (named "surname") nm
return $ toMetaValue $ Map.fromList [
("given" :: Text, given)
, ("family", family)
]
let refElement :: PandocMonad m
=> Element -> Element -> JATS m (Maybe (Text, MetaValue))
refElement c el =
case qName (elName el) of
"article-title" -> Just . ("title",) . toMetaValue <$> getInlines el
"source" ->
case filterChild (named "article-title") c of
Just _ -> Just . ("container-title",) . toMetaValue <$> getInlines el
Nothing -> Just . ("title",) . toMetaValue <$> getInlines el
"label" -> Just . ("citation-label",) . toMetaValue <$> getInlines el
"year" -> case filterChild (named "month") c of
Just m -> Just . ("issued",) . toMetaValue <$>
(combineWithDash
<$> getInlines el <*> getInlines m)
Nothing -> Just . ("issued",) . toMetaValue <$> getInlines el
"volume" -> Just . ("volume",) . toMetaValue <$> getInlines el
"issue" -> Just . ("issue",) . toMetaValue <$> getInlines el
"isbn" -> Just . ("ISBN",) . toMetaValue <$> getInlines el
"issn" -> Just . ("ISSN",) . toMetaValue <$> getInlines el
"uri" -> Just . ("url",) . toMetaValue <$> getInlines el
"fpage" ->
case filterChild (named "lpage") c of
Just lp -> Just . ("page",) . toMetaValue <$>
(combineWithDash <$> getInlines el <*> getInlines lp)
Nothing -> Just . ("page-first",) . toMetaValue <$> getInlines el
"publisher-name" -> Just . ("publisher",) . toMetaValue <$> getInlines el
"publisher-loc" -> Just . ("publisher-place",) . toMetaValue
<$> getInlines el
"edition" -> pure $ Just ("edition",
toMetaValue . T.filter isDigit $ strContent el)
"person-group" -> do names <- mapM getName
(filterChildren (named "name") el)
pure $ Just (attrValue "person-group-type" el,
toMetaValue names)
"pub-id" -> case attrValue "pub-id-type" el of
"doi" -> pure $ Just ("DOI", toMetaValue $ strContent el)
"pmid" -> pure $ Just ("PMID", toMetaValue $ strContent el)
_ -> pure Nothing
"object-id" -> case attrValue "pub-id-type" el of
"doi" -> pure $ Just ("DOI", toMetaValue $ strContent el)
"pmid" -> pure $ Just ("PMID", toMetaValue $ strContent el)
_ -> pure Nothing
_ -> pure Nothing
refVariables <-
case filterChild (named "element-citation") e of
Just c -> (("type", toMetaValue $ case attrValue "publication-type" c of
"journal" -> "article-journal"
x -> x) :) .
catMaybes <$> mapM (refElement c) (elChildren c)
Nothing -> pure [] -- TODO handle mixed-citation
-- allows round-tripping, since JATS writer puts ref- in front of citation ids:
let stripPref t = fromMaybe t $ T.stripPrefix "ref-" t
return $ Map.fromList (("id", toMetaValue $ stripPref $ attrValue "id" e)
: refVariables)
textContent :: Element -> Text
textContent = strContent
strContentRecursive :: Element -> Text
strContentRecursive = strContent .
(\e' -> e'{ elContent = map elementToStr $ elContent e' })
elementToStr :: Content -> Content
elementToStr (Elem e') = Text $ CData CDataText (strContentRecursive e') Nothing
elementToStr x = x
parseInline :: PandocMonad m => Content -> JATS m Inlines
parseInline (Text (CData _ s _)) = return $ text s
parseInline (CRef ref) = return $ maybe (text $ T.toUpper ref) text
$ lookupEntity ref
parseInline (Elem e) =
case qName (elName e) of
"italic" -> innerInlines emph
"bold" -> innerInlines strong
"strike" -> innerInlines strikeout
"sub" -> innerInlines subscript
"sup" -> innerInlines superscript
"underline" -> innerInlines underline
"break" -> return linebreak
"sc" -> innerInlines smallcaps
"code" -> codeWithLang
"monospace" -> codeWithLang
"inline-graphic" -> getGraphic e
"disp-quote" -> do
qt <- gets jatsQuoteType
let qt' = if qt == SingleQuote then DoubleQuote else SingleQuote
modify $ \st -> st{ jatsQuoteType = qt' }
contents <- innerInlines id
modify $ \st -> st{ jatsQuoteType = qt }
return $ if qt == SingleQuote
then singleQuoted contents
else doubleQuoted contents
"xref" -> do
ils <- innerInlines id
let rid = attrValue "rid" e
let rids = T.words rid
let refType = ("ref-type",) <$> maybeAttrValue "ref-type" e
let attr = (attrValue "id" e, [], maybeToList refType)
return $ if refType == Just ("ref-type","bibr")
then cite
(map (\id' ->
let id'' = fromMaybe id' $
T.stripPrefix "ref-" id'
in Citation { citationId = id''
, citationPrefix = []
, citationSuffix = []
, citationMode = NormalCitation
, citationNoteNum = 0
, citationHash = 0}) rids)
ils
else linkWith attr ("#" <> rid) "" ils
"ext-link" -> do
ils <- innerInlines id
let title = fromMaybe "" $ findAttr (QName "title" (Just "http://www.w3.org/1999/xlink") Nothing) e
let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of
Just h -> h
_ -> "#" <> attrValue "rid" e
let ils' = if ils == mempty then str href else ils
let attr = (attrValue "id" e, [], [])
return $ linkWith attr href title ils'
"alternatives" -> if hasFormulaChild e
then inlineFormula math e
else innerInlines id
"disp-formula" -> inlineFormula displayMath e
"inline-formula" -> inlineFormula math e
"math" | qURI (elName e) == Just "http://www.w3.org/1998/Math/MathML"
-> return . math $ mathML e
"tex-math" -> return . math $ textContent e
"email" -> return $ link ("mailto:" <> textContent e) ""
$ str $ textContent e
"uri" -> return $ link (textContent e) "" $ str $ textContent e
"fn" -> note . mconcat <$>
mapM parseBlock (elContent e)
_ -> innerInlines id
where innerInlines f = f . mconcat <$> mapM parseInline (elContent e)
codeWithLang = do
let classes' = case attrValue "language" e of
"" -> []
l -> [l]
return $ codeWith (attrValue "id" e,classes',[]) $ strContentRecursive e
inlineFormula :: PandocMonad m => (Text->Inlines) -> Element -> JATS m Inlines
inlineFormula constructor e = do
let whereToLook = fromMaybe e $ filterElement (named "alternatives") e
texMaths = map textContent $
filterChildren (named "tex-math") whereToLook
mathMLs = map mathML $
filterChildren isMathML whereToLook
return . mconcat . take 1 . map constructor $ texMaths ++ mathMLs
blockFormula :: PandocMonad m => (Text->Inlines) -> Element -> JATS m Blocks
blockFormula constructor e = do
let whereToLook = fromMaybe e $ filterElement (named "alternatives") e
texMaths = map textContent $
filterChildren (named "tex-math") whereToLook
mathMLs = map mathML $
filterChildren isMathML whereToLook
case texMaths ++ mathMLs of
[] -> return mempty
(m:_) -> return $ para (constructor m)
mathML :: Element -> Text
mathML x =
case readMathML . showElement $ everywhere (mkT removePrefix) x of
Left _ -> mempty
Right m -> writeTeX m
where removePrefix elname = elname { qPrefix = Nothing }
isMathML :: Element -> Bool
isMathML x = qName (elName x) == "math" &&
qURI (elName x) ==
Just "http://www.w3.org/1998/Math/MathML"
formulaChildren :: Element -> [Element]
formulaChildren x = filterChildren isMathML x ++ filterChildren (named "tex-math") x
hasFormulaChild :: Element -> Bool
hasFormulaChild x = length (formulaChildren x) > 0
isAliLicenseRef :: Element -> Bool
isAliLicenseRef x = qName (elName x) == "license_ref" &&
qURI (elName x) ==
Just "http://www.niso.org/schemas/ali/1.0/"