d853571 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Improve support for code language in JATS

d853571Hamish Mackenzie9 years ago

src/Text/Pandoc/Readers/JATS.hs+19−2

compare with master

unifiedsplit

@@ -15,6 +15,8 @@ import Text.Pandoc.Options

15import Text.Pandoc.Shared (underlineSpan, crFilter, safeRead)

16import Text.TeXMath (readMathML, writeTeX)

17import Text.XML.Light

18+import qualified Data.Set as S (fromList, member)

19+import Data.Set ((\\))

19type JATS m = StateT JATSState m

21type JATS m = StateT JATSState m

@@ -98,8 +100,8 @@ instance HasMeta JATSState where

98 deleteMeta field s = s {jatsMeta = deleteMeta field (jatsMeta s)}

100 deleteMeta field s = s {jatsMeta = deleteMeta field (jatsMeta s)}

101

100isBlockElement :: Content -> Bool

102isBlockElement :: Content -> Bool

101−isBlockElement (Elem e) = qName (elName e) `elem` blocktags

103+isBlockElement (Elem e) = qName (elName e) `S.member` blocktags

102− where blocktags = paragraphLevel ++ lists ++ mathML ++ other

104+ where blocktags = S.fromList (paragraphLevel ++ lists ++ mathML ++ other) \\ S.fromList inlinetags

103 paragraphLevel = ["address", "array", "boxed-text", "chem-struct-wrap",

105 paragraphLevel = ["address", "array", "boxed-text", "chem-struct-wrap",

104 "code", "fig", "fig-group", "graphic", "media", "preformat",

106 "code", "fig", "fig-group", "graphic", "media", "preformat",

105 "supplementary-material", "table-wrap", "table-wrap-group",

107 "supplementary-material", "table-wrap", "table-wrap-group",

@@ -108,6 +110,21 @@ isBlockElement (Elem e) = qName (elName e) `elem` blocktags

108 mathML = ["tex-math", "mml:math"]

110 mathML = ["tex-math", "mml:math"]

109 other = ["p", "related-article", "related-object", "ack", "disp-quote",

111 other = ["p", "related-article", "related-object", "ack", "disp-quote",

110 "speech", "statement", "verse-group", "x"]

112 "speech", "statement", "verse-group", "x"]

113+ inlinetags = ["email", "ext-link", "uri", "inline-supplementary-material",

114+ "related-article", "related-object", "hr", "bold", "fixed-case",

115+ "italic", "monospace", "overline", "overline-start", "overline-end",

116+ "roman", "sans-serif", "sc", "strike", "underline", "underline-start",

117+ "underline-end", "ruby", "alternatives", "inline-graphic", "private-char",

118+ "chem-struct", "inline-formula", "tex-math", "mml:math", "abbrev",

119+ "milestone-end", "milestone-start", "named-content", "styled-content",

120+ "fn", "target", "xref", "sub", "sup", "x", "address", "array",

121+ "boxed-text", "chem-struct-wrap", "code", "fig", "fig-group", "graphic",

122+ "media", "preformat", "supplementary-material", "table-wrap",

123+ "table-wrap-group", "disp-formula", "disp-formula-group",

124+ "citation-alternatives", "element-citation", "mixed-citation",

125+ "nlm-citation", "award-id", "funding-source", "open-access",

126+ "def-list", "list", "ack", "disp-quote", "speech", "statement",

127+ "verse-group"]

111isBlockElement _ = False

128isBlockElement _ = False

112

129

113-- Trim leading and trailing newline characters

130-- Trim leading and trailing newline characters

src/Text/Pandoc/Writers/JATS.hs+29−18

@@ -170,6 +170,28 @@ imageMimeType src kvs =

170 ((drop 1 . dropWhile (/='/')) <$> mbMT)

171 in (maintype, subtype)

172

173+languageFor :: [String] -> String

174+languageFor classes =

175+ case langs of

176+ (l:_) -> escapeStringForXML l

177+ [] -> ""

178+ where isLang l = map toLower l `elem` map (map toLower) languages

179+ langsFrom s = if isLang s

180+ then [s]

181+ else languagesByExtension . map toLower $ s

182+ langs = concatMap langsFrom classes

183+

184+codeAttr :: Attr -> (String, [(String, String)])

185+codeAttr (ident,classes,kvs) = (lang, attr)

186+ where

187+ attr = [("id",ident) | not (null ident)] ++

188+ [("language",lang) | not (null lang)] ++

189+ [(k,v) | (k,v) <- kvs, k `elem` ["code-type",

190+ "code-version", "executable",

191+ "language-version", "orientation",

192+ "platforms", "position", "specific-use"]]

193+ lang = languageFor classes

194+

173-- | Convert a Pandoc block element to JATS.

195-- | Convert a Pandoc block element to JATS.

174blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m Doc

196blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m Doc

175blockToJATS _ Null = return empty

197blockToJATS _ Null = return empty

@@ -233,23 +255,10 @@ blockToJATS opts (LineBlock lns) =

233 blockToJATS opts $ linesToPara lns

255 blockToJATS opts $ linesToPara lns

234blockToJATS opts (BlockQuote blocks) =

256blockToJATS opts (BlockQuote blocks) =

235 inTagsIndented "disp-quote" <$> blocksToJATS opts blocks

257 inTagsIndented "disp-quote" <$> blocksToJATS opts blocks

236−blockToJATS _ (CodeBlock (ident,classes,kvs) str) = return $

258+blockToJATS _ (CodeBlock a str) = return $

237 inTags False tag attr (flush (text (escapeStringForXML str)))

259 inTags False tag attr (flush (text (escapeStringForXML str)))

238− where attr = [("id",ident) | not (null ident)] ++

260+ where (lang, attr) = codeAttr a

239− [("language",lang) | not (null lang)] ++

240− [(k,v) | (k,v) <- kvs, k `elem` ["code-type",

241− "code-version", "executable",

242− "language-version", "orientation",

243− "platforms", "position", "specific-use"]]

244− tag = if null lang then "preformat" else "code"

261+ tag = if null lang then "preformat" else "code"

245− lang = case langs of

246− (l:_) -> escapeStringForXML l

247− [] -> ""

248− isLang l = map toLower l `elem` map (map toLower) languages

249− langsFrom s = if isLang s

250− then [s]

251− else languagesByExtension . map toLower $ s

252− langs = concatMap langsFrom classes

253blockToJATS _ (BulletList []) = return empty

262blockToJATS _ (BulletList []) = return empty

254blockToJATS opts (BulletList lst) =

263blockToJATS opts (BulletList lst) =

255 inTags True "list" [("list-type", "bullet")] <$>

264 inTags True "list" [("list-type", "bullet")] <$>

@@ -346,8 +355,10 @@ inlineToJATS opts (Quoted SingleQuote lst) = do

346inlineToJATS opts (Quoted DoubleQuote lst) = do

355inlineToJATS opts (Quoted DoubleQuote lst) = do

347 contents <- inlinesToJATS opts lst

356 contents <- inlinesToJATS opts lst

348 return $ char '“' <> contents <> char '”'

357 return $ char '“' <> contents <> char '”'

349−inlineToJATS _ (Code _ str) =

358+inlineToJATS _ (Code a str) =

350− return $ inTagsSimple "monospace" $ text (escapeStringForXML str)

359+ return $ inTags False tag attr $ text (escapeStringForXML str)

360+ where (lang, attr) = codeAttr a

361+ tag = if null lang then "monospace" else "code"

351inlineToJATS _ il@(RawInline f x)

362inlineToJATS _ il@(RawInline f x)

352 | f == "jats" = return $ text x

363 | f == "jats" = return $ text x

353 | otherwise = do

364 | otherwise = do

test/Tests/Readers/JATS.hs+5

@@ -14,6 +14,11 @@ jats = purely $ readJATS def

14tests :: [TestTree]

15tests = [ testGroup "inline code"

16 [ test jats "basic" $ "\n <monospace>@&</monospace>\n" =?> para (code "@&")

17+ , test jats "lang" $ "\n <code language=\"c\">@&</code>\n" =?> para (codeWith ("", ["c"], []) "@&")

18+ ]

19+ , testGroup "block code"

20+ [ test jats "basic" $ "<preformat>@&</preformat>" =?> codeBlock "@&"

21+ , test jats "lang" $ "<code language=\"c\">@&</code>" =?> codeBlockWith ("", ["c"], []) "@&"

17 ]

22 ]

18 , testGroup "images"

23 , testGroup "images"

19 [ test jats "basic" $ "<graphic mimetype=\"image\" mime-subtype=\"\" xlink:href=\"/url\" xlink:title=\"title\" />"

24 [ test jats "basic" $ "<graphic mimetype=\"image\" mime-subtype=\"\" xlink:href=\"/url\" xlink:title=\"title\" />"

test/Tests/Writers/JATS.hs+6−1

@@ -31,6 +31,11 @@ infix 4 =:

31tests :: [TestTree]

32tests = [ testGroup "inline code"

33 [ "basic" =: code "@&" =?> "\n <monospace>@&</monospace>\n"

34+ , "lang" =: codeWith ("", ["c"], []) "@&" =?> "\n <code language=\"c\">@&</code>\n"

35+ ]

36+ , testGroup "block code"

37+ [ "basic" =: codeBlock "@&" =?> "<preformat>@&</preformat>"

38+ , "lang" =: codeBlockWith ("", ["c"], []) "@&" =?> "<code language=\"c\">@&</code>"

34 ]

39 ]

35 , testGroup "images"

40 , testGroup "images"

36 [ "basic" =:

41 [ "basic" =:

@@ -38,7 +43,7 @@ tests = [ testGroup "inline code"

38 =?> "<graphic mimetype=\"image\" mime-subtype=\"\" xlink:href=\"/url\" xlink:title=\"title\" />"

43 =?> "<graphic mimetype=\"image\" mime-subtype=\"\" xlink:href=\"/url\" xlink:title=\"title\" />"

39 ]

44 ]

40 , testGroup "inlines"

45 , testGroup "inlines"

41− [ "Emphasis" =: emph ("emphasized")

46+ [ "Emphasis" =: emph "emphasized"

42 =?> "\n <italic>emphasized</italic>\n"

47 =?> "\n <italic>emphasized</italic>\n"

43 ]

48 ]

44 , "bullet list" =: bulletList [ plain $ text "first"

49 , "bullet list" =: bulletList [ plain $ text "first"