@@ -0,0 +1,429 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE PatternGuards #-}
4+Copyright (C) 2006-2015 John MacFarlane <jgm@berkeley.edu>
6+This program is free software; you can redistribute it and/or modify
7+it under the terms of the GNU General Public License as published by
8+the Free Software Foundation; either version 2 of the License, or
9+(at your option) any later version.
11+This program is distributed in the hope that it will be useful,
12+but WITHOUT ANY WARRANTY; without even the implied warranty of
13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14+GNU General Public License for more details.
16+You should have received a copy of the GNU General Public License
17+along with this program; if not, write to the Free Software
18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21+ Module : Text.Pandoc.Writers.JATS
22+ Copyright : Copyright (C) 2017 John MacFarlane
23+ License : GNU GPL, version 2 or above
25+ Maintainer : John MacFarlane <jgm@berkeley.edu>
27+ Portability : portable
29+Conversion of 'Pandoc' documents to JATS XML.
31+https://jats.nlm.nih.gov/publishing/tag-library/1.1d3/element/mml-math.html
33+module Text.Pandoc.Writers.JATS ( writeJATS ) where
34+import Control.Monad.Reader
35+import Data.Char (toLower)
36+import Data.Generics (everywhere, mkT)
37+import Data.List (intercalate, isSuffixOf)
38+import Data.Maybe (fromMaybe)
39+import qualified Text.Pandoc.Builder as B
40+import Text.Pandoc.Class (PandocMonad, report)
41+import Text.Pandoc.Definition
42+import Text.Pandoc.Highlighting (languages, languagesByExtension)
43+import Text.Pandoc.Logging
44+import Text.Pandoc.Options
45+import Text.Pandoc.Pretty
46+import Text.Pandoc.Shared
47+import Text.Pandoc.Templates (renderTemplate')
48+import Text.Pandoc.Writers.Math
49+import Text.Pandoc.Writers.Shared
50+import Text.Pandoc.XML
51+import Text.Pandoc.MIME (getMimeType)
53+import qualified Text.XML.Light as Xml
55+data JATSVersion = JATS1_1
58+type DB = ReaderT JATSVersion
60+-- | Convert list of authors to a docbook <author> section
61+authorToJATS :: PandocMonad m => WriterOptions -> [Inline] -> DB m B.Inlines
62+authorToJATS opts name' = do
63+ name <- render Nothing <$> inlinesToJATS opts name'
64+ let colwidth = if writerWrapText opts == WrapAuto
65+ then Just $ writerColumns opts
67+ return $ B.rawInline "docbook" $ render colwidth $
69+ then -- last name first
70+ let (lastname, rest) = break (==',') name
71+ firstname = triml rest in
72+ inTagsSimple "firstname" (text $ escapeStringForXML firstname) <>
73+ inTagsSimple "surname" (text $ escapeStringForXML lastname)
74+ else -- last name last
75+ let namewords = words name
76+ lengthname = length namewords
77+ (firstname, lastname) = case lengthname of
80+ n -> (intercalate " " (take (n-1) namewords), last namewords)
81+ in inTagsSimple "firstname" (text $ escapeStringForXML firstname) $$
82+ inTagsSimple "surname" (text $ escapeStringForXML lastname)
84+writeJATS :: PandocMonad m => WriterOptions -> Pandoc -> m String
86+ runReaderT (docToJATS opts d) JATS1_1
88+-- | Convert Pandoc document to string in JATS format.
89+docToJATS :: PandocMonad m => WriterOptions -> Pandoc -> DB m String
90+docToJATS opts (Pandoc meta blocks) = do
91+ let elements = hierarchicalize blocks
92+ let colwidth = if writerWrapText opts == WrapAuto
93+ then Just $ writerColumns opts
95+ let render' = render colwidth
96+ let opts' = if (maybe False (("/book>" `isSuffixOf`) . trimr)
97+ (writerTemplate opts) &&
98+ TopLevelDefault == writerTopLevelDivision opts)
99+ then opts{ writerTopLevelDivision = TopLevelChapter }
101+ -- The numbering here follows LaTeX's internal numbering
102+ let startLvl = case writerTopLevelDivision opts' of
104+ TopLevelChapter -> 0
105+ TopLevelSection -> 1
106+ TopLevelDefault -> 1
107+ auths' <- mapM (authorToJATS opts) $ docAuthors meta
108+ let meta' = B.setMeta "author" auths' meta
109+ metadata <- metaToJSON opts
110+ (fmap (render colwidth . vcat) .
111+ (mapM (elementToJATS opts' startLvl) .
113+ (fmap (render colwidth) . inlinesToJATS opts')
115+ main <- (render' . inTagsIndented "body" . vcat) <$>
116+ (mapM (elementToJATS opts' startLvl) elements)
117+ let context = defField "body" main
118+ $ defField "mathml" (case writerHTMLMathMethod opts of
122+ return $ case writerTemplate opts of
124+ Just tpl -> renderTemplate' tpl context
126+-- | Convert an Element to JATS.
127+elementToJATS :: PandocMonad m => WriterOptions -> Int -> Element -> DB m Doc
128+elementToJATS opts _ (Blk block) = blockToJATS opts block
129+elementToJATS opts lvl (Sec _ _num (id',_,kvs) title elements) = do
130+ let idAttr = [("id", writerIdentifierPrefix opts ++ id') | not (null id')]
131+ let otherAttrs = ["sec-type", "specific-use"]
132+ let attribs = idAttr ++ [(k,v) | (k,v) <- kvs, k `elem` otherAttrs]
133+ contents <- mapM (elementToJATS opts (lvl + 1)) elements
134+ title' <- inlinesToJATS opts title
135+ return $ inTags True "sec" attribs $
136+ inTagsSimple "title" title' $$ vcat contents
138+-- | Convert a list of Pandoc blocks to JATS.
139+blocksToJATS :: PandocMonad m => WriterOptions -> [Block] -> DB m Doc
140+blocksToJATS opts = fmap vcat . mapM (blockToJATS opts)
142+-- | Auxiliary function to convert Plain block to Para.
143+plainToPara :: Block -> Block
144+plainToPara (Plain x) = Para x
147+-- | Convert a list of pairs of terms and definitions into a list of
148+-- JATS varlistentrys.
149+deflistItemsToJATS :: PandocMonad m
150+ => WriterOptions -> [([Inline],[[Block]])] -> DB m Doc
151+deflistItemsToJATS opts items =
152+ vcat <$> mapM (\(term, defs) -> deflistItemToJATS opts term defs) items
154+-- | Convert a term and a list of blocks into a JATS varlistentry.
155+deflistItemToJATS :: PandocMonad m
156+ => WriterOptions -> [Inline] -> [[Block]] -> DB m Doc
157+deflistItemToJATS opts term defs = do
158+ term' <- inlinesToJATS opts term
159+ def' <- blocksToJATS opts $ concatMap (map plainToPara) defs
160+ return $ inTagsIndented "def-item" $
161+ inTagsIndented "term" term' $$
162+ inTagsIndented "def" def'
164+-- | Convert a list of lists of blocks to a list of JATS list items.
165+listItemsToJATS :: PandocMonad m
166+ => WriterOptions -> (Maybe [String]) -> [[Block]] -> DB m Doc
167+listItemsToJATS opts markers items =
169+ Nothing -> vcat <$> mapM (listItemToJATS opts Nothing) items
170+ Just ms -> vcat <$> zipWithM (listItemToJATS opts) (map Just ms) items
172+-- | Convert a list of blocks into a JATS list item.
173+listItemToJATS :: PandocMonad m
174+ => WriterOptions -> (Maybe String) -> [Block] -> DB m Doc
175+listItemToJATS opts mbmarker item = do
176+ contents <- blocksToJATS opts item
177+ return $ inTagsIndented "list-item" $
178+ maybe empty (\lbl -> inTagsIndented "label" (text lbl)) mbmarker
181+-- | Convert a Pandoc block element to JATS.
182+blockToJATS :: PandocMonad m => WriterOptions -> Block -> DB m Doc
183+blockToJATS _ Null = return empty
184+-- Add ids to paragraphs in divs with ids - this is needed for
185+-- pandoc-citeproc to get link anchors in bibliographies:
186+blockToJATS opts (Div (ident,_,_) [Para lst]) =
187+ let attribs = [("id", ident) | not (null ident)] in
188+ inTags True "p" attribs <$> inlinesToJATS opts lst
189+blockToJATS opts (Div (ident,_,kvs) bs) = do
190+ contents <- blocksToJATS opts bs
191+ let attr = [("id", ident) | not (null ident)] ++
192+ [("xml:lang",l) | ("lang",l) <- kvs] ++
193+ [(k,v) | (k,v) <- kvs, k `elem` ["specific-use",
194+ "content-type", "orientation", "position"]]
195+ return $ inTags True "boxed-text" attr contents
196+blockToJATS _ (Header _ _ _) =
197+ return empty -- should not occur after hierarchicalize
198+-- No Plain, everything needs to be in a block-level tag
199+blockToJATS opts (Plain lst) = blockToJATS opts (Para lst)
200+-- title beginning with fig: indicates that the image is a figure
201+blockToJATS opts (Para [Image (ident,_,kvs) txt
202+ (src,'f':'i':'g':':':tit)]) = do
203+ alt <- inlinesToJATS opts txt
204+ let capt = if null txt
206+ else inTagsSimple "caption" alt
207+ let attr = [("id", ident) | not (null ident)] ++
208+ [(k,v) | (k,v) <- kvs, k `elem` ["fig-type", "orientation",
209+ "position", "specific-use"]]
210+ let mbMT = getMimeType src
211+ let maintype = fromMaybe "image" $
212+ lookup "mimetype" kvs `mplus`
213+ (takeWhile (/='/') <$> mbMT)
214+ let subtype = fromMaybe "" $
215+ lookup "mime-subtype" kvs `mplus`
216+ ((drop 1 . dropWhile (/='/')) <$> mbMT)
217+ let graphicattr = [("mimetype",maintype),
218+ ("mime-subtype",drop 1 subtype),
219+ ("xlink:href",src), -- do we need to URL escape this?
220+ ("xlink:title",tit)]
221+ return $ inTags True "fig" attr $
222+ capt $$ selfClosingTag "graphic" graphicattr
223+blockToJATS opts (Para lst) =
224+ inTagsIndented "p" <$> inlinesToJATS opts lst
225+blockToJATS opts (LineBlock lns) =
226+ blockToJATS opts $ linesToPara lns
227+blockToJATS opts (BlockQuote blocks) =
228+ inTagsIndented "disp-quote" <$> blocksToJATS opts blocks
229+blockToJATS _ (CodeBlock (ident,classes,kvs) str) = return $
230+ inTags False tag attr (flush (text (escapeStringForXML str)))
231+ where attr = [("id",ident) | not (null ident)] ++
232+ [("language",lang) | not (null lang)] ++
233+ [(k,v) | (k,v) <- kvs, k `elem` ["code-type",
234+ "code-version", "executable",
235+ "language-version", "orientation",
236+ "platforms", "position", "specific-use"]]
237+ tag = if null lang then "preformat" else "code"
238+ lang = case langs of
239+ (l:_) -> escapeStringForXML l
241+ isLang l = map toLower l `elem` map (map toLower) languages
242+ langsFrom s = if isLang s
244+ else languagesByExtension . map toLower $ s
245+ langs = concatMap langsFrom classes
246+blockToJATS _ (BulletList []) = return empty
247+blockToJATS opts (BulletList lst) = do
248+ inTags True "list" [("list-type", "bullet")] <$>
249+ listItemsToJATS opts Nothing lst
250+blockToJATS _ (OrderedList _ []) = return empty
251+blockToJATS opts (OrderedList (start, numstyle, delimstyle) items) = do
252+ let listType = case numstyle of
253+ DefaultStyle -> "order"
256+ UpperAlpha -> "alpha-upper"
257+ LowerAlpha -> "alpha-lower"
258+ UpperRoman -> "roman-upper"
259+ LowerRoman -> "roman-lower"
260+ let simpleList = start == 1 && (delimstyle == DefaultDelim ||
261+ delimstyle == Period)
262+ let markers = if simpleList
265+ orderedListMarkers (start, numstyle, delimstyle)
266+ inTags True "list" [("list-type", listType)] <$>
267+ listItemsToJATS opts markers items
268+blockToJATS opts (DefinitionList lst) = do
269+ inTags True "def-list" [] <$> deflistItemsToJATS opts lst
270+blockToJATS _ b@(RawBlock f str)
271+ | f == "jats" = return $ text str -- raw XML block
273+ report $ BlockNotRendered b
275+blockToJATS _ HorizontalRule = return empty -- not semantic
276+blockToJATS opts (Table [] aligns widths headers rows) = do
277+ let percent w = show (truncate (100*w) :: Integer) ++ "*"
278+ let coltags = vcat $ zipWith (\w al -> selfClosingTag "col"
279+ ([("width", percent w) | w > 0] ++
280+ [("align", alignmentToString al)])) widths aligns
281+ thead <- if all null headers
283+ else inTagsIndented "thead" <$> tableRowToJATS opts True headers
284+ tbody <- (inTagsIndented "tbody" . vcat) <$>
285+ mapM (tableRowToJATS opts False) rows
286+ return $ inTags True "table" [] $ coltags $$ thead $$ tbody
287+blockToJATS opts (Table caption aligns widths headers rows) = do
288+ captionDoc <- inTagsIndented "caption" <$> blockToJATS opts (Para caption)
289+ tbl <- blockToJATS opts (Table [] aligns widths headers rows)
290+ return $ inTags True "table-wrap" [] $ captionDoc $$ tbl
292+alignmentToString :: Alignment -> [Char]
293+alignmentToString alignment = case alignment of
295+ AlignRight -> "right"
296+ AlignCenter -> "center"
297+ AlignDefault -> "left"
299+tableRowToJATS :: PandocMonad m
304+tableRowToJATS opts isHeader cols =
305+ (inTagsIndented "tr" . vcat) <$> mapM (tableItemToJATS opts isHeader) cols
307+tableItemToJATS :: PandocMonad m
312+tableItemToJATS opts isHeader item =
313+ (inTags True (if isHeader then "th" else "td") [] . vcat) <$>
314+ mapM (blockToJATS opts) item
316+-- | Convert a list of inline elements to JATS.
317+inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> DB m Doc
318+inlinesToJATS opts lst = hcat <$> mapM (inlineToJATS opts) lst
320+-- | Convert an inline element to JATS.
321+inlineToJATS :: PandocMonad m => WriterOptions -> Inline -> DB m Doc
322+inlineToJATS _ (Str str) = return $ text $ escapeStringForXML str
323+inlineToJATS opts (Emph lst) =
324+ inTagsSimple "italic" <$> inlinesToJATS opts lst
325+inlineToJATS opts (Strong lst) =
326+ inTags False "bold" [("role", "strong")] <$> inlinesToJATS opts lst
327+inlineToJATS opts (Strikeout lst) =
328+ inTagsSimple "strike" <$> inlinesToJATS opts lst
329+inlineToJATS opts (Superscript lst) =
330+ inTagsSimple "sup" <$> inlinesToJATS opts lst
331+inlineToJATS opts (Subscript lst) =
332+ inTagsSimple "sub" <$> inlinesToJATS opts lst
333+inlineToJATS opts (SmallCaps lst) =
334+ inTags False "sc" [("role", "smallcaps")] <$>
335+ inlinesToJATS opts lst
336+inlineToJATS opts (Quoted SingleQuote lst) = do
337+ contents <- inlinesToJATS opts lst
338+ return $ char '‘' <> contents <> char '’'
339+inlineToJATS opts (Quoted DoubleQuote lst) = do
340+ contents <- inlinesToJATS opts lst
341+ return $ char '“' <> contents <> char '”'
342+inlineToJATS _ (Code _ str) =
343+ return $ inTagsSimple "monospace" $ text (escapeStringForXML str)
344+inlineToJATS _ il@(RawInline f x)
345+ | f == "jats" = return $ text x
347+ report $ InlineNotRendered il
349+inlineToJATS _ LineBreak = return $ selfClosingTag "break" []
350+inlineToJATS _ Space = return space
351+inlineToJATS opts SoftBreak
352+ | writerWrapText opts == WrapPreserve = return cr
353+ | otherwise = return space
354+inlineToJATS opts (Note contents) =
355+ -- TODO technically only <p> tags are allowed inside
356+ inTagsIndented "fn" <$> blocksToJATS opts contents
357+inlineToJATS opts (Cite _ lst) =
358+ -- TODO revisit this after examining the jats.csl pipeline
359+ inlinesToJATS opts lst
360+inlineToJATS opts (Span ("",_,[]) ils) = inlinesToJATS opts ils
361+inlineToJATS opts (Span (ident,_,kvs) ils) = do
362+ contents <- inlinesToJATS opts ils
363+ let attr = [("id",ident) | not (null ident)] ++
364+ [("xml:lang",l) | ("lang",l) <- kvs] ++
365+ [(k,v) | (k,v) <- kvs
366+ , k `elem` ["content-type", "rationale",
367+ "rid", "specific-use"]]
368+ return $ selfClosingTag "milestone-start" attr <> contents <>
369+ selfClosingTag "milestone-end" []
370+inlineToJATS _ (Math t str) = do
371+ let addPref (Xml.Attr q v)
372+ | Xml.qName q == "xmlns" = Xml.Attr q{ Xml.qName = "xmlns:mml" } v
373+ | otherwise = Xml.Attr q v
374+ let fixNS' e = e{ Xml.elName =
375+ (Xml.elName e){ Xml.qPrefix = Just "mml" } }
376+ let fixNS = everywhere (mkT fixNS') .
377+ (\e -> e{ Xml.elAttribs = map addPref (Xml.elAttribs e) })
378+ let conf = Xml.useShortEmptyTags (const False) Xml.defaultConfigPP
379+ res <- convertMath writeMathML t str
380+ let tagtype = case t of
381+ DisplayMath -> "disp-formula"
382+ InlineMath -> "inline-formula"
383+ return $ inTagsSimple tagtype $
385+ Right r -> text $ Xml.ppcElement conf
387+ Left _ -> inTagsSimple "tex-math"
388+ $ text "<![CDATA[" <>
391+inlineToJATS _ (Link _attr [Str t] ('m':'a':'i':'l':'t':'o':':':email, _))
392+ | escapeURI t == email =
393+ return $ inTagsSimple "email" $ text (escapeStringForXML email)
394+inlineToJATS opts (Link (ident,_,kvs) txt ('#':src, _)) = do
395+ let attr = [("id", ident) | not (null ident)] ++
396+ [("alt", stringify txt),
398+ [(k,v) | (k,v) <- kvs, k `elem` ["ref-type", "specific-use"]]
399+ contents <- inlinesToJATS opts txt
400+ return $ inTags False "xref" attr contents
401+inlineToJATS opts (Link (ident,_,kvs) txt (src, tit)) = do
402+ let attr = [("id", ident) | not (null ident)] ++
403+ [("ext-link-type", "uri"),
404+ ("xlink:href", src)] ++
405+ [("xlink:title", tit) | not (null tit)] ++
406+ [(k,v) | (k,v) <- kvs, k `elem` ["assigning-authority",
407+ "specific-use", "xlink:actuate",
408+ "xlink:role", "xlink:show",
410+ contents <- inlinesToJATS opts txt
411+ return $ inTags False "ext-link" attr contents
412+inlineToJATS _ (Image (ident,_,kvs) _ (src, tit)) = do
413+ let mbMT = getMimeType src
414+ let maintype = fromMaybe "image" $
415+ lookup "mimetype" kvs `mplus`
416+ (takeWhile (/='/') <$> mbMT)
417+ let subtype = fromMaybe "" $
418+ lookup "mime-subtype" kvs `mplus`
419+ ((drop 1 . dropWhile (/='/')) <$> mbMT)
420+ let attr = [("id", ident) | not (null ident)] ++
421+ [("mimetype", maintype),
422+ ("mime-subtype", subtype),
423+ ("xlink:href", src)] ++
424+ [("xlink:title", tit) | not (null tit)] ++
425+ [(k,v) | (k,v) <- kvs, k `elem` ["baseline-shift",
426+ "content-type", "specific-use", "xlink:actuate",
427+ "xlink:href", "xlink:role", "xlink:show",
429+ return $ selfClosingTag "inline-graphic" attr