aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Text/Pandoc/Writers/JATS.hs85
-rw-r--r--src/Text/Pandoc/Writers/JATS/Table.hs81
-rw-r--r--src/Text/Pandoc/Writers/JATS/Types.hs46
3 files changed, 144 insertions, 68 deletions
diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs
index f2820a501..0ddb70c83 100644
--- a/src/Text/Pandoc/Writers/JATS.hs
+++ b/src/Text/Pandoc/Writers/JATS.hs
@@ -40,26 +40,14 @@ import Text.DocLayout
import Text.Pandoc.Shared
import Text.Pandoc.Templates (renderTemplate)
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.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 (Eq)
-
--- | Internal state used by the writer.
-newtype JATSState = JATSState
- { 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
@@ -83,9 +71,14 @@ writeJATS = writeJatsArchiving
-- | Convert a @'Pandoc'@ document to JATS.
writeJats :: PandocMonad m => JATSTagSet -> WriterOptions -> Pandoc -> m Text
writeJats tagSet opts d =
- runReaderT (evalStateT (docToJATS opts d)
- (JATSState{ jatsNotes = [] }))
- tagSet
+ runReaderT (evalStateT (docToJATS opts d) initialState)
+ environment
+ where initialState = JATSState { jatsNotes = [] }
+ environment = JATSEnv
+ { jatsTagSet = tagSet
+ , jatsInlinesWriter = inlinesToJATS
+ , jatsBlockWriter = blockToJATS
+ }
-- | Convert Pandoc document to string in JATS format.
docToJATS :: PandocMonad m => WriterOptions -> Pandoc -> JATS m Text
@@ -110,7 +103,7 @@ docToJATS opts (Pandoc meta blocks) = do
main <- fromBlocks bodyblocks
notes <- gets (reverse . map snd . jatsNotes)
backs <- fromBlocks backblocks
- tagSet <- ask
+ tagSet <- asks jatsTagSet
-- In the "Article Authoring" tag set, occurrence of fn-group elements
-- is restricted to table footers. Footnotes have to be placed inline.
let fns = if null notes || tagSet == TagSetArticleAuthoring
@@ -311,7 +304,7 @@ blockToJATS opts (Para lst) =
blockToJATS opts (LineBlock lns) =
blockToJATS opts $ linesToPara lns
blockToJATS opts (BlockQuote blocks) = do
- tagSet <- ask
+ tagSet <- asks jatsTagSet
let blocksToJats' = if tagSet == TagSetArticleAuthoring
then wrappedBlocksToJATS (not . isPara)
else blocksToJATS
@@ -326,7 +319,7 @@ blockToJATS opts (BulletList lst) =
listItemsToJATS opts Nothing lst
blockToJATS _ (OrderedList _ []) = return empty
blockToJATS opts (OrderedList (start, numstyle, delimstyle) items) = do
- tagSet <- ask
+ tagSet <- asks jatsTagSet
let listType =
-- The Article Authoring tag set doesn't allow a more specific
-- @list-type@ attribute than "order".
@@ -356,52 +349,8 @@ blockToJATS _ b@(RawBlock f str)
report $ BlockNotRendered b
return empty
blockToJATS _ HorizontalRule = return empty -- not semantic
-blockToJATS opts (Table _ blkCapt specs th tb tf) =
- case toLegacyTable blkCapt specs th tb tf of
- ([], aligns, widths, headers, rows) -> captionlessTable aligns widths headers 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 headers
- 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
+blockToJATS opts (Table attr blkCapt specs th tb tf) =
+ tableToJATS opts attr blkCapt specs th tb tf
-- | Convert a list of inline elements to JATS.
inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> JATS m (Doc Text)
@@ -458,7 +407,7 @@ inlineToJATS opts SoftBreak
| writerWrapText opts == WrapPreserve = return cr
| otherwise = return space
inlineToJATS opts (Note contents) = do
- tagSet <- ask
+ tagSet <- asks jatsTagSet
-- Footnotes must occur inline when using the Article Authoring tag set.
if tagSet == TagSetArticleAuthoring
then inTagsIndented "fn" <$> wrappedBlocksToJATS (not . isPara) opts contents
@@ -504,7 +453,7 @@ inlineToJATS _ (Math t str) = do
let rawtex = text "<![CDATA[" <> literal str <> text "]]>"
let texMath = inTagsSimple "tex-math" rawtex
- tagSet <- ask
+ tagSet <- asks jatsTagSet
return . inTagsSimple tagtype $
case res of
Right r -> let mathMl = text (Xml.ppcElement conf $ fixNS r)
diff --git a/src/Text/Pandoc/Writers/JATS/Table.hs b/src/Text/Pandoc/Writers/JATS/Table.hs
new file mode 100644
index 000000000..cccd866aa
--- /dev/null
+++ b/src/Text/Pandoc/Writers/JATS/Table.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+ Module : Text.Pandoc.Writers.JATS.Table
+ Copyright : © 2020 Albert Krewinkel
+ License : GNU GPL, version 2 or above
+
+ Maintainer : Albert Krewinkel <tarleb@zeitkraut.de>
+ Stability : alpha
+ Portability : portable
+
+Conversion of 'Pandoc' tables to JATS XML.
+-}
+module Text.Pandoc.Writers.JATS.Table
+ ( tableToJATS
+ ) where
+import Control.Monad.Reader (asks)
+import Data.Text (Text)
+import Text.Pandoc.Class.PandocMonad (PandocMonad)
+import Text.Pandoc.Definition
+import Text.Pandoc.Options (WriterOptions)
+import Text.DocLayout (Doc, empty, vcat, ($$))
+import Text.Pandoc.Shared (tshow)
+import Text.Pandoc.Writers.JATS.Types
+import Text.Pandoc.Writers.Shared (toLegacyTable)
+import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag)
+
+
+tableToJATS :: PandocMonad m
+ => WriterOptions
+ -> Attr -> Caption -> [ColSpec] -> TableHead
+ -> [TableBody] -> TableFoot
+ -> JATS m (Doc Text)
+tableToJATS opts _attr blkCapt specs th tb tf = do
+ blockToJATS <- asks jatsBlockWriter
+ case toLegacyTable blkCapt specs th tb tf of
+ ([], aligns, widths, headers, rows) -> captionlessTable aligns widths headers 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 headers
+ 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] = do
+ inlinesToJATS <- asks jatsInlinesWriter
+ inTags False (if isHeader then "th" else "td") [] <$>
+ inlinesToJATS opts item
+tableItemToJATS opts isHeader item = do
+ blockToJATS <- asks jatsBlockWriter
+ inTags False (if isHeader then "th" else "td") [] . vcat <$>
+ mapM (blockToJATS opts) item
diff --git a/src/Text/Pandoc/Writers/JATS/Types.hs b/src/Text/Pandoc/Writers/JATS/Types.hs
new file mode 100644
index 000000000..8162f3bc0
--- /dev/null
+++ b/src/Text/Pandoc/Writers/JATS/Types.hs
@@ -0,0 +1,46 @@
+{- |
+ Module : Text.Pandoc.Writers.JATS.Types
+ Copyright : Copyright (C) 2017-2020 John MacFarlane
+ License : GNU GPL, version 2 or above
+
+ Maintainer : John MacFarlane <jgm@berkeley.edu>
+ Stability : alpha
+ Portability : portable
+
+Types for pandoc's JATS writer.
+-}
+module Text.Pandoc.Writers.JATS.Types
+ ( JATS
+ , JATSEnv (..)
+ , JATSState (..)
+ , JATSTagSet (..)
+ )
+where
+
+import Control.Monad.Reader (ReaderT)
+import Control.Monad.State (StateT)
+import Data.Text (Text)
+import Text.DocLayout (Doc)
+import Text.Pandoc.Definition (Block, Inline)
+import Text.Pandoc.Options (WriterOptions)
+
+-- | JATS tag set variant
+data JATSTagSet
+ = TagSetArchiving -- ^ Archiving and Interchange Tag Set
+ | TagSetPublishing -- ^ Journal Publishing Tag Set
+ | TagSetArticleAuthoring -- ^ Article Authoring Tag Set
+ deriving (Eq)
+
+-- | Internal state used by the writer.
+newtype JATSState = JATSState
+ { jatsNotes :: [(Int, Doc Text)]
+ }
+
+data JATSEnv m = JATSEnv
+ { jatsTagSet :: JATSTagSet
+ , jatsInlinesWriter :: WriterOptions -> [Inline] -> JATS m (Doc Text)
+ , jatsBlockWriter :: WriterOptions -> Block -> JATS m (Doc Text)
+ }
+
+-- | JATS writer type
+type JATS m = StateT JATSState (ReaderT (JATSEnv m) m)