diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Text/Pandoc/Writers/JATS.hs | 85 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/JATS/Table.hs | 81 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/JATS/Types.hs | 46 |
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) |