"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "src/Text/Pandoc/Writers/JATS.hs" between
pandoc-2.11.1.1.tar.gz and pandoc-2.11.2.tar.gz

About: Pandoc converts files from one markup format into another.

JATS.hs  (pandoc-2.11.1.1)	:	JATS.hs  (pandoc-2.11.2)
skipping to change at line 43		skipping to change at line 43
import Text.Pandoc.Definition		import Text.Pandoc.Definition
import Text.Pandoc.Highlighting (languages, languagesByExtension)		import Text.Pandoc.Highlighting (languages, languagesByExtension)
import Text.Pandoc.Logging		import Text.Pandoc.Logging
import Text.Pandoc.MIME (getMimeType)		import Text.Pandoc.MIME (getMimeType)
import Text.Pandoc.Walk (walk)		import Text.Pandoc.Walk (walk)
import Text.Pandoc.Options		import Text.Pandoc.Options
import Text.DocLayout		import Text.DocLayout
import Text.Pandoc.Shared		import Text.Pandoc.Shared
import Text.Pandoc.Templates (renderTemplate)		import Text.Pandoc.Templates (renderTemplate)
import Text.DocTemplates (Context(..), Val(..))		import Text.DocTemplates (Context(..), Val(..))
		import Text.Pandoc.Writers.JATS.Table (tableToJATS)
		import Text.Pandoc.Writers.JATS.Types
import Text.Pandoc.Writers.Math		import Text.Pandoc.Writers.Math
import Text.Pandoc.Writers.Shared		import Text.Pandoc.Writers.Shared
import Text.Pandoc.XML		import Text.Pandoc.XML
import Text.TeXMath		import Text.TeXMath
import qualified Text.XML.Light as Xml		import qualified Text.XML.Light as Xml
data JATSTagSet
= TagSetArchiving -- ^ Archiving and Interchange Tag Set
| TagSetPublishing -- ^ Journal Publishing Tag Set
| TagSetArticleAuthoring -- ^ Article Authoring Tag Set
deriving (Eq)
newtype JATSState = JATSState
{ jatsNotes :: [(Int, Doc Text)] }
type JATS a = StateT JATSState (ReaderT JATSTagSet a)
-- | Convert a @'Pandoc'@ document to JATS (Archiving and Interchange		-- | Convert a @'Pandoc'@ document to JATS (Archiving and Interchange
-- Tag Set.)		-- Tag Set.)
writeJatsArchiving :: PandocMonad m => WriterOptions -> Pandoc -> m Text		writeJatsArchiving :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeJatsArchiving = writeJats TagSetArchiving		writeJatsArchiving = writeJats TagSetArchiving
-- | Convert a @'Pandoc'@ document to JATS (Journal Publishing Tag Set.)		-- | Convert a @'Pandoc'@ document to JATS (Journal Publishing Tag Set.)
writeJatsPublishing :: PandocMonad m => WriterOptions -> Pandoc -> m Text		writeJatsPublishing :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeJatsPublishing = writeJats TagSetPublishing		writeJatsPublishing = writeJats TagSetPublishing
-- | Convert a @'Pandoc'@ document to JATS (Archiving and Interchange		-- | Convert a @'Pandoc'@ document to JATS (Archiving and Interchange
skipping to change at line 86		skipping to change at line 74
-- | Alias for @'writeJatsArchiving'@. This function exists for backwards		-- | Alias for @'writeJatsArchiving'@. This function exists for backwards
-- compatibility, but will be deprecated in the future. Use		-- compatibility, but will be deprecated in the future. Use
-- @'writeJatsArchiving'@ instead.		-- @'writeJatsArchiving'@ instead.
writeJATS :: PandocMonad m => WriterOptions -> Pandoc -> m Text		writeJATS :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeJATS = writeJatsArchiving		writeJATS = writeJatsArchiving
-- | Convert a @'Pandoc'@ document to JATS.		-- | Convert a @'Pandoc'@ document to JATS.
writeJats :: PandocMonad m => JATSTagSet -> WriterOptions -> Pandoc -> m Text		writeJats :: PandocMonad m => JATSTagSet -> WriterOptions -> Pandoc -> m Text
writeJats tagSet opts d =		writeJats tagSet opts d =
runReaderT (evalStateT (docToJATS opts d)		runReaderT (evalStateT (docToJATS opts d) initialState)
(JATSState{ jatsNotes = [] }))		environment
tagSet		where initialState = JATSState { jatsNotes = [] }
		environment = JATSEnv
		{ jatsTagSet = tagSet
		, jatsInlinesWriter = inlinesToJATS
		, jatsBlockWriter = blockToJATS
		}
-- | Convert Pandoc document to string in JATS format.		-- | Convert Pandoc document to string in JATS format.
docToJATS :: PandocMonad m => WriterOptions -> Pandoc -> JATS m Text		docToJATS :: PandocMonad m => WriterOptions -> Pandoc -> JATS m Text
docToJATS opts (Pandoc meta blocks) = do		docToJATS opts (Pandoc meta blocks) = do
let isBackBlock (Div ("refs",_,_) _) = True		let isBackBlock (Div ("refs",_,_) _) = True
isBackBlock _ = False		isBackBlock _ = False
let (backblocks, bodyblocks) = partition isBackBlock blocks		let (backblocks, bodyblocks) = partition isBackBlock blocks
-- The numbering here follows LaTeX's internal numbering		-- The numbering here follows LaTeX's internal numbering
let startLvl = case writerTopLevelDivision opts of		let startLvl = case writerTopLevelDivision opts of
TopLevelPart -> -1		TopLevelPart -> -1
skipping to change at line 113		skipping to change at line 106
let colwidth = if writerWrapText opts == WrapAuto		let colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts		then Just $ writerColumns opts
else Nothing		else Nothing
metadata <- metaToContext opts		metadata <- metaToContext opts
fromBlocks		fromBlocks
(fmap chomp . inlinesToJATS opts)		(fmap chomp . inlinesToJATS opts)
meta		meta
main <- fromBlocks bodyblocks		main <- fromBlocks bodyblocks
notes <- gets (reverse . map snd . jatsNotes)		notes <- gets (reverse . map snd . jatsNotes)
backs <- fromBlocks backblocks		backs <- fromBlocks backblocks
tagSet <- ask		tagSet <- asks jatsTagSet
-- In the "Article Authoring" tag set, occurrence of fn-group elements		-- In the "Article Authoring" tag set, occurrence of fn-group elements
-- is restricted to table footers. Footnotes have to be placed inline.		-- is restricted to table footers. Footnotes have to be placed inline.
let fns = if null notes || tagSet == TagSetArticleAuthoring		let fns = if null notes || tagSet == TagSetArticleAuthoring
then mempty		then mempty
else inTagsIndented "fn-group" $ vcat notes		else inTagsIndented "fn-group" $ vcat notes
let back = backs $$ fns		let back = backs $$ fns
let date =		let date =
case getField "date" metadata of		case getField "date" metadata of
Nothing -> NullVal		Nothing -> NullVal
Just (SimpleVal (x :: Doc Text)) ->		Just (SimpleVal (x :: Doc Text)) ->
skipping to change at line 314		skipping to change at line 307
[(k,v) | (k,v) <- kvs, k `elem` ["baseline-shift",		[(k,v) | (k,v) <- kvs, k `elem` ["baseline-shift",
"content-type", "specific-use", "xlink:actuate",		"content-type", "specific-use", "xlink:actuate",
"xlink:href", "xlink:role", "xlink:show",		"xlink:href", "xlink:role", "xlink:show",
"xlink:type"]]		"xlink:type"]]
return $ selfClosingTag "graphic" attr		return $ selfClosingTag "graphic" attr
blockToJATS opts (Para lst) =		blockToJATS opts (Para lst) =
inTagsSimple "p" <$> inlinesToJATS opts lst		inTagsSimple "p" <$> inlinesToJATS opts lst
blockToJATS opts (LineBlock lns) =		blockToJATS opts (LineBlock lns) =
blockToJATS opts $ linesToPara lns		blockToJATS opts $ linesToPara lns
blockToJATS opts (BlockQuote blocks) = do		blockToJATS opts (BlockQuote blocks) = do
tagSet <- ask		tagSet <- asks jatsTagSet
let blocksToJats' = if tagSet == TagSetArticleAuthoring		let blocksToJats' = if tagSet == TagSetArticleAuthoring
then wrappedBlocksToJATS (not . isPara)		then wrappedBlocksToJATS (not . isPara)
else blocksToJATS		else blocksToJATS
inTagsIndented "disp-quote" <$> blocksToJats' opts blocks		inTagsIndented "disp-quote" <$> blocksToJats' opts blocks
blockToJATS _ (CodeBlock a str) = return $		blockToJATS _ (CodeBlock a str) = return $
inTags False tag attr (flush (text (T.unpack $ escapeStringForXML str)))		inTags False tag attr (flush (text (T.unpack $ escapeStringForXML str)))
where (lang, attr) = codeAttr a		where (lang, attr) = codeAttr a
tag = if T.null lang then "preformat" else "code"		tag = if T.null lang then "preformat" else "code"
blockToJATS _ (BulletList []) = return empty		blockToJATS _ (BulletList []) = return empty
blockToJATS opts (BulletList lst) =		blockToJATS opts (BulletList lst) =
inTags True "list" [("list-type", "bullet")] <$>		inTags True "list" [("list-type", "bullet")] <$>
listItemsToJATS opts Nothing lst		listItemsToJATS opts Nothing lst
blockToJATS _ (OrderedList _ []) = return empty		blockToJATS _ (OrderedList _ []) = return empty
blockToJATS opts (OrderedList (start, numstyle, delimstyle) items) = do		blockToJATS opts (OrderedList (start, numstyle, delimstyle) items) = do
tagSet <- ask		tagSet <- asks jatsTagSet
let listType =		let listType =
-- The Article Authoring tag set doesn't allow a more specific		-- The Article Authoring tag set doesn't allow a more specific
-- @list-type@ attribute than "order".		-- @list-type@ attribute than "order".
if tagSet == TagSetArticleAuthoring		if tagSet == TagSetArticleAuthoring
then "order"		then "order"
else case numstyle of		else case numstyle of
DefaultStyle -> "order"		DefaultStyle -> "order"
Decimal -> "order"		Decimal -> "order"
Example -> "order"		Example -> "order"
UpperAlpha -> "alpha-upper"		UpperAlpha -> "alpha-upper"
skipping to change at line 359		skipping to change at line 352
inTags True "list" [("list-type", listType)] <$>		inTags True "list" [("list-type", listType)] <$>
listItemsToJATS opts markers items		listItemsToJATS opts markers items
blockToJATS opts (DefinitionList lst) =		blockToJATS opts (DefinitionList lst) =
inTags True "def-list" [] <$> deflistItemsToJATS opts lst		inTags True "def-list" [] <$> deflistItemsToJATS opts lst
blockToJATS _ b@(RawBlock f str)		blockToJATS _ b@(RawBlock f str)
| f == "jats" = return $ text $ T.unpack str -- raw XML block		| f == "jats" = return $ text $ T.unpack str -- raw XML block
| otherwise = do		| otherwise = do
report $ BlockNotRendered b		report $ BlockNotRendered b
return empty		return empty
blockToJATS _ HorizontalRule = return empty -- not semantic		blockToJATS _ HorizontalRule = return empty -- not semantic
blockToJATS opts (Table _ blkCapt specs th tb tf) =		blockToJATS opts (Table attr blkCapt specs th tb tf) =
case toLegacyTable blkCapt specs th tb tf of		tableToJATS opts attr blkCapt specs th tb tf
([], aligns, widths, headers, rows) -> captionlessTable aligns widths header
s rows
(caption, aligns, widths, headers, rows) -> do
captionDoc <- inTagsIndented "caption" <$> blockToJATS opts (Para caption)
tbl <- captionlessTable aligns widths headers rows
return $ inTags True "table-wrap" [] $ captionDoc $$ tbl
where
captionlessTable aligns widths headers rows = do
let percent w = tshow (truncate (100*w) :: Integer) <> "*"
let coltags = vcat $ zipWith (\w al -> selfClosingTag "col"
([("width", percent w) | w > 0] ++
[("align", alignmentToText al)])) widths aligns
thead <- if all null headers
then return empty
else inTagsIndented "thead" <$> tableRowToJATS opts True heade
rs
tbody <- inTagsIndented "tbody" . vcat <$>
mapM (tableRowToJATS opts False) rows
return $ inTags True "table" [] $ coltags $$ thead $$ tbody
alignmentToText :: Alignment -> Text
alignmentToText alignment = case alignment of
AlignLeft -> "left"
AlignRight -> "right"
AlignCenter -> "center"
AlignDefault -> "left"
tableRowToJATS :: PandocMonad m
=> WriterOptions
-> Bool
-> [[Block]]
-> JATS m (Doc Text)
tableRowToJATS opts isHeader cols =
inTagsIndented "tr" . vcat <$> mapM (tableItemToJATS opts isHeader) cols
tableItemToJATS :: PandocMonad m
=> WriterOptions
-> Bool
-> [Block]
-> JATS m (Doc Text)
tableItemToJATS opts isHeader [Plain item] =
inTags False (if isHeader then "th" else "td") [] <$>
inlinesToJATS opts item
tableItemToJATS opts isHeader item =
inTags False (if isHeader then "th" else "td") [] . vcat <$>
mapM (blockToJATS opts) item
-- | Convert a list of inline elements to JATS.		-- | Convert a list of inline elements to JATS.
inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> JATS m (Doc Text)		inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS opts lst = hcat <$> mapM (inlineToJATS opts) (fixCitations lst)		inlinesToJATS opts lst = hcat <$> mapM (inlineToJATS opts) (fixCitations lst)
where		where
fixCitations [] = []		fixCitations [] = []
fixCitations (x:xs) | needsFixing x =		fixCitations (x:xs) | needsFixing x =
x : Str (stringify ys) : fixCitations zs		x : Str (stringify ys) : fixCitations zs
where		where
needsFixing (RawInline (Format "jats") z) =		needsFixing (RawInline (Format "jats") z) =
skipping to change at line 461		skipping to change at line 410
| otherwise = do		| otherwise = do
report $ InlineNotRendered il		report $ InlineNotRendered il
return empty		return empty
inlineToJATS _ LineBreak = return cr -- not allowed as child of p		inlineToJATS _ LineBreak = return cr -- not allowed as child of p
-- see https://jats.nlm.nih.gov/publishing/tag-library/1.2/element/break.html		-- see https://jats.nlm.nih.gov/publishing/tag-library/1.2/element/break.html
inlineToJATS _ Space = return space		inlineToJATS _ Space = return space
inlineToJATS opts SoftBreak		inlineToJATS opts SoftBreak
| writerWrapText opts == WrapPreserve = return cr		| writerWrapText opts == WrapPreserve = return cr
| otherwise = return space		| otherwise = return space
inlineToJATS opts (Note contents) = do		inlineToJATS opts (Note contents) = do
tagSet <- ask		tagSet <- asks jatsTagSet
-- Footnotes must occur inline when using the Article Authoring tag set.		-- Footnotes must occur inline when using the Article Authoring tag set.
if tagSet == TagSetArticleAuthoring		if tagSet == TagSetArticleAuthoring
then inTagsIndented "fn" <$> wrappedBlocksToJATS (not . isPara) opts content s		then inTagsIndented "fn" <$> wrappedBlocksToJATS (not . isPara) opts content s
else do		else do
notes <- gets jatsNotes		notes <- gets jatsNotes
let notenum = case notes of		let notenum = case notes of
(n, _):_ -> n + 1		(n, _):_ -> n + 1
[] -> 1		[] -> 1
thenote <- inTags True "fn" [("id","fn" <> tshow notenum)]		thenote <- inTags True "fn" [("id","fn" <> tshow notenum)]
<$> wrappedBlocksToJATS (not . isPara) opts		<$> wrappedBlocksToJATS (not . isPara) opts
skipping to change at line 507		skipping to change at line 456
(\e -> e{ Xml.elAttribs = map addPref (Xml.elAttribs e) })		(\e -> e{ Xml.elAttribs = map addPref (Xml.elAttribs e) })
let conf = Xml.useShortEmptyTags (const False) Xml.defaultConfigPP		let conf = Xml.useShortEmptyTags (const False) Xml.defaultConfigPP
res <- convertMath writeMathML t str		res <- convertMath writeMathML t str
let tagtype = case t of		let tagtype = case t of
DisplayMath -> "disp-formula"		DisplayMath -> "disp-formula"
InlineMath -> "inline-formula"		InlineMath -> "inline-formula"
let rawtex = text "<![CDATA[" <> literal str <> text "]]>"		let rawtex = text "<![CDATA[" <> literal str <> text "]]>"
let texMath = inTagsSimple "tex-math" rawtex		let texMath = inTagsSimple "tex-math" rawtex
tagSet <- ask		tagSet <- asks jatsTagSet
return . inTagsSimple tagtype $		return . inTagsSimple tagtype $
case res of		case res of
Right r -> let mathMl = text (Xml.ppcElement conf $ fixNS r)		Right r -> let mathMl = text (Xml.ppcElement conf $ fixNS r)
-- tex-math is unsupported in Article Authoring tag set		-- tex-math is unsupported in Article Authoring tag set
in if tagSet == TagSetArticleAuthoring		in if tagSet == TagSetArticleAuthoring
then mathMl		then mathMl
else inTagsSimple "alternatives" $		else inTagsSimple "alternatives" $
cr <> texMath $$ mathMl		cr <> texMath $$ mathMl
Left _ -> if tagSet /= TagSetArticleAuthoring		Left _ -> if tagSet /= TagSetArticleAuthoring
then texMath		then texMath
End of changes. 9 change blocks.
67 lines changed or deleted		17 lines changed or added

---