OpenDocument writer: add syntax highlighting tags for CodeBlock.

We still aren't injecting the style, but this will improve things.
See #6710.

1 files changed, 24 insertions, 12 deletions

diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs
index e54322e8b..d818616ae 100644
--- a/src/Text/Pandoc/Writers/OpenDocument.hs
+++ b/src/Text/Pandoc/Writers/OpenDocument.hs
@@ -15,7 +15,7 @@ Conversion of 'Pandoc' documents to OpenDocument XML.
 -}
 module Text.Pandoc.Writers.OpenDocument ( writeOpenDocument ) where
 import Control.Arrow ((***), (>>>))
-import Control.Monad (unless, liftM)
+import Control.Monad (unless, liftM, (>=>))
 import Control.Monad.State.Strict ( StateT(..), modify, gets, lift )
 import Data.Char (chr)
 import Data.Foldable (find)
@@ -285,10 +285,10 @@ withParagraphStyle  o s (b:bs)
     where go i = (<>) i <$>  withParagraphStyle o s bs
 withParagraphStyle _ _ [] = return empty
 
-inPreformattedTags :: PandocMonad m => Text -> OD m (Doc Text)
+inPreformattedTags :: PandocMonad m => [Doc Text] -> OD m (Doc Text)
 inPreformattedTags s = do
   n <- paraStyle [("style:parent-style-name","Preformatted_20_Text")]
-  return . inParagraphTagsWithStyle ("P" <> tshow n) . handleSpaces $ s
+  return $ inParagraphTagsWithStyle ("P" <> tshow n) $ hcat s
 
 orderedListToOpenDocument :: PandocMonad m
                           => WriterOptions -> Int -> [[Block]] -> OD m (Doc Text)
@@ -385,7 +385,15 @@ blockToOpenDocument o = \case
     DefinitionList b -> setFirstPara >> defList b
     BulletList     b -> setFirstPara >> bulletListToOpenDocument o b
     OrderedList  a b -> setFirstPara >> orderedList a b
-    CodeBlock    _ s -> setFirstPara >> preformatted s
+    CodeBlock attrs s -> do
+      setFirstPara
+      if isNothing (writerHighlightStyle o)
+         then unhighlighted s
+         else case highlight (writerSyntaxMap o) formatOpenDocument attrs s of
+                Right h  -> flush . vcat <$> mapM inPreformattedTags h
+                Left msg -> do
+                  unless (T.null msg) $ report $ CouldNotHighlight msg
+                  unhighlighted s
     Table a bc s th tb tf -> setFirstPara >> table (Ann.toTable a bc s th tb tf)
     HorizontalRule   -> setFirstPara >> return (selfClosingTag "text:p"
                          [ ("text:style-name", "Horizontal_20_Line") ])
@@ -398,7 +406,8 @@ blockToOpenDocument o = \case
                            r <- vcat  <$> mapM (deflistItemToOpenDocument o) b
                            setInDefinitionList False
                            return r
-      preformatted  s = flush . vcat <$> mapM (inPreformattedTags . escapeStringForXML) (T.lines s)
+      unhighlighted s = flush . vcat <$>
+            (mapM (inPreformattedTags . (:[])) (map preformatted (T.lines s)))
       mkDiv    attr s = do
         let (ident,_,kvs) = attr
             i = withLangFromAttr attr $
@@ -611,7 +620,7 @@ inlineToOpenDocument o ils
       then unhighlighted s
       else case highlight (writerSyntaxMap o)
                   formatOpenDocument attrs s of
-                Right h  -> return $ mconcat $ mconcat h
+                Right h  -> inlinedCode $ mconcat $ mconcat h
                 Left msg -> do
                   unless (T.null msg) $ report $ CouldNotHighlight msg
                   unhighlighted s
@@ -629,13 +638,7 @@ inlineToOpenDocument o ils
     Image attr _ (s,t) -> mkImg attr s t
     Note        l  -> mkNote l
     where
-      formatOpenDocument :: FormatOptions -> [SourceLine] -> [[Doc Text]]
-      formatOpenDocument _fmtOpts = map (map toHlTok)
-      toHlTok :: Token -> Doc Text
-      toHlTok (toktype,tok) =
-        inTags False "text:span" [("text:style-name", T.pack $ show toktype)] $ preformatted tok
       unhighlighted s = inlinedCode $ preformatted s
-      preformatted s = handleSpaces $ escapeStringForXML s
       inlinedCode s = return $ inTags False "text:span" [("text:style-name", "Source_Text")] s
       mkImg (_, _, kvs) s _ = do
                id' <- gets stImageId
@@ -673,6 +676,15 @@ inlineToOpenDocument o ils
         addNote nn
         return nn
 
+formatOpenDocument :: FormatOptions -> [SourceLine] -> [[Doc Text]]
+formatOpenDocument _fmtOpts = map (map toHlTok)
+toHlTok :: Token -> Doc Text
+toHlTok (toktype,tok) =
+  inTags False "text:span" [("text:style-name", T.pack $ show toktype)] $ preformatted tok
+
+preformatted :: Text -> Doc Text
+preformatted s = handleSpaces $ escapeStringForXML s
+
 mkLink :: WriterOptions -> [(Text,ReferenceType)] -> Text -> Text -> Doc Text -> Doc Text
 mkLink o identTypes s t d =
   let maybeIdentAndType = case T.uncons s of