ConTeXt writer: support `tagging` extension [API Change]

Paragraphs are enclosed by `\bpar` and `\epar` commands, and `highlight`
commands are used for emphasis. This results in much better tagging in
PDF output.

5 files changed, 53 insertions, 15 deletions

diff --git a/MANUAL.txt b/MANUAL.txt
index 969daaada..63b99ceb0 100644
--- a/MANUAL.txt
+++ b/MANUAL.txt
@@ -3579,6 +3579,15 @@ In the `context` output format this enables the use of [Natural Tables
 Natural tables allow more fine-grained global customization but come
 at a performance penalty compared to extreme tables.
 
+#### Extension: `tagging` ####
+
+Enabling this extension with `context` output will produce markup
+suitable for the production of tagged PDFs. This includes
+additional markers for paragraphs and alternative markup for
+emphasized text. The `emphasis-command` template variable is set
+if the extension is enabled. Combine this with the `pdfa` variable
+to generate accessible PDFs.
+
 
 # Pandoc's Markdown
 
diff --git a/data/templates/default.context b/data/templates/default.context
index 9081a08b2..b0c90b4a5 100644
--- a/data/templates/default.context
+++ b/data/templates/default.context
@@ -114,6 +114,9 @@ $endif$
 \setupxtable[foot][]
 \setupxtable[lastrow][bottomframe=on]
 
+$if(emphasis-commands)$
+$emphasis-commands$
+$endif$
 $if(highlighting-commands)$
 $highlighting-commands$
 $endif$
diff --git a/src/Text/Pandoc/Extensions.hs b/src/Text/Pandoc/Extensions.hs
index 8cc9a883b..525e96ac6 100644
--- a/src/Text/Pandoc/Extensions.hs
+++ b/src/Text/Pandoc/Extensions.hs
@@ -129,6 +129,7 @@ data Extension =
     | Ext_subscript           -- ^ Subscript using ~this~ syntax
     | Ext_superscript         -- ^ Superscript using ^this^ syntax
     | Ext_styles              -- ^ Read styles that pandoc doesn't know
+    | Ext_tagging             -- ^ Output optimized for PDF tagging
     | Ext_task_lists          -- ^ Parse certain list items as task list items
     | Ext_table_captions      -- ^ Pandoc-style table captions
     | Ext_tex_math_dollars    -- ^ TeX math between $..$ or $$..$$
@@ -602,6 +603,7 @@ getAllExtensions f = universalExtensions <> getAll f
     [ Ext_smart
     , Ext_raw_tex
     , Ext_ntb
+    , Ext_tagging
     ]
   getAll "textile"         = autoIdExtensions <>
     extensionsFromList
diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs
index b375b6c2b..151fbc106 100644
--- a/src/Text/Pandoc/Writers/ConTeXt.hs
+++ b/src/Text/Pandoc/Writers/ConTeXt.hs
@@ -42,6 +42,7 @@ import Text.Pandoc.Writers.Shared
 import Text.Printf (printf)
 
 import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.Map.Strict as Map
 import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
 
 data WriterState =
@@ -52,6 +53,7 @@ data WriterState =
   , stNextRef          :: Int  -- number of next URL reference
   , stOptions          :: WriterOptions -- writer options
   , stOrderedListLevel :: Int  -- level of ordered list
+  , stEmphasisCommands :: Map.Map Text (Doc Text)
   }
 
 -- | Table type
@@ -75,6 +77,7 @@ writeConTeXt options document =
         , stNextRef = 1
         , stOptions = options
         , stOrderedListLevel = 0
+        , stEmphasisCommands = mempty
         }
   in evalStateT (pandocToConTeXt options document) defaultWriterState
 
@@ -123,6 +126,8 @@ pandocToConTeXt options (Pandoc meta blocks) = do
                           | all isDigit (d:ds) -> resetField "papersize"
                                                    (T.pack ('A':d:ds))
                         _                     -> id)
+                $ defField "emphasis-commands"
+                    (mconcat $ Map.elems (stEmphasisCommands st))
                 $ (case writerHighlightStyle options of
                         Just sty | stHighlighting st ->
                           defField "highlighting-commands" (styleToConTeXt sty)
@@ -185,10 +190,20 @@ blockToConTeXt (Div attr@(_,"section":_,_)
   footer' <- sectionFooter attr level
   innerContents <- blockListToConTeXt xs
   return $ header' $$ innerContents $$ footer'
-blockToConTeXt (Plain lst) = inlineListToConTeXt lst
+blockToConTeXt (Plain lst) = do
+  opts <- gets stOptions
+  contents <- inlineListToConTeXt lst
+  return $
+    if isEnabled Ext_tagging opts
+    then "\\bpar{}" <> contents <> "\\epar{}"
+    else contents
 blockToConTeXt (Para lst) = do
+  opts <- gets stOptions
   contents <- inlineListToConTeXt lst
-  return $ contents <> blankline
+  return $
+    if isEnabled Ext_tagging opts
+    then "\\bpar" $$ contents $$ "\\epar" <> blankline
+    else contents <> blankline
 blockToConTeXt (LineBlock lns) = do
   let emptyToBlankline doc = if isEmpty doc
                              then blankline
@@ -551,19 +566,31 @@ inlineListToConTeXt lst = liftM hcat $ mapM inlineToConTeXt $ addStruts lst
         isSpacey (Str (T.uncons -> Just ('\160',_))) = True
         isSpacey _                                   = False
 
+highlightInlines :: PandocMonad m
+                 => Text -> (Doc Text) -> [Inline]
+                 -> WM m (Doc Text)
+highlightInlines name style inlines = do
+  opts <- gets stOptions
+  contents <- inlineListToConTeXt inlines
+  if not (isEnabled Ext_tagging opts)
+    then return $ braces (style <> space <> contents)
+    else do
+      let cmd = "\\definehighlight " <> brackets (literal name) <>
+                brackets ("style=" <> braces style)
+      modify (\st -> st{ stEmphasisCommands =
+                         Map.insert name cmd (stEmphasisCommands st) })
+      return $ "\\" <> literal name <> braces contents
+
 -- | Convert inline element to ConTeXt
 inlineToConTeXt :: PandocMonad m
                 => Inline    -- ^ Inline to convert
                 -> WM m (Doc Text)
-inlineToConTeXt (Emph lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ braces $ "\\em " <> contents
+inlineToConTeXt (Emph lst)      = highlightInlines "emph"      "\\em" lst
+inlineToConTeXt (Strong lst)    = highlightInlines "strong"    "\\bf" lst
+inlineToConTeXt (SmallCaps lst) = highlightInlines "smallcaps" "\\sc" lst
 inlineToConTeXt (Underline lst) = do
   contents <- inlineListToConTeXt lst
   return $ "\\underbar" <> braces contents
-inlineToConTeXt (Strong lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ braces $ "\\bf " <> contents
 inlineToConTeXt (Strikeout lst) = do
   contents <- inlineListToConTeXt lst
   return $ "\\overstrikes" <> braces contents
@@ -573,9 +600,6 @@ inlineToConTeXt (Superscript lst) = do
 inlineToConTeXt (Subscript lst) = do
   contents <- inlineListToConTeXt lst
   return $ "\\low" <> braces contents
-inlineToConTeXt (SmallCaps lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ braces $ "\\sc " <> contents
 inlineToConTeXt (Code (_ident, classes, _kv) str) = do
   let rawCode =
         pure . literal $
diff --git a/test/writer.context b/test/writer.context
index 1ee01e91e..4915a2d5e 100644
--- a/test/writer.context
+++ b/test/writer.context
@@ -86,8 +86,8 @@ markdown test suite.
 \startsectionlevel[title={Level 2 with an \goto{embedded
 link}[url(/url)]},reference={level-2-with-an-embedded-link}]
 
-\startsectionlevel[title={Level 3 with
-{\em emphasis}},reference={level-3-with-emphasis}]
+\startsectionlevel[title={Level 3 with {\em
+emphasis}},reference={level-3-with-emphasis}]
 
 \startsectionlevel[title={Level 4},reference={level-4}]
 
@@ -105,8 +105,8 @@ link}[url(/url)]},reference={level-2-with-an-embedded-link}]
 
 \startsectionlevel[title={Level 1},reference={level-1}]
 
-\startsectionlevel[title={Level 2 with
-{\em emphasis}},reference={level-2-with-emphasis}]
+\startsectionlevel[title={Level 2 with {\em
+emphasis}},reference={level-2-with-emphasis}]
 
 \startsectionlevel[title={Level 3},reference={level-3}]