ODT/opendocument writers: properly handle highlighting styles.

These styles were going into an office:styles element in content.xml,
but this is invalid.  Instead they must go in styles.xml. See #9287.

The variable `highlighting-styles` no longer has any effect on
the default opendocument template, and highlighting styles are
not included in opendocument output.

2 files changed, 80 insertions, 41 deletions

diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs
index c5ca33029..6953a9528 100644
--- a/src/Text/Pandoc/Writers/ODT.hs
+++ b/src/Text/Pandoc/Writers/ODT.hs
@@ -48,6 +48,8 @@ import Text.Pandoc.XML.Light
 import Text.TeXMath
 import qualified Text.XML.Light as XL
 import Network.URI (parseRelativeReference, URI(uriPath))
+import Control.Monad (MonadPlus(mplus))
+import Skylighting
 
 newtype ODTState = ODTState { stEntries :: [Entry]
                          }
@@ -187,29 +189,56 @@ pandocToODT opts doc@(Pandoc meta _) = do
   -- make sure mimetype is first
   let mimetypeEntry = toEntry "mimetype" epochtime
                       $ fromStringLazy "application/vnd.oasis.opendocument.text"
-  archive'' <- updateStyleWithLang lang
+  archive'' <- updateStyle opts lang
                   $ addEntryToArchive mimetypeEntry
                   $ addEntryToArchive metaEntry archive'
   return $ fromArchive archive''
 
-updateStyleWithLang :: PandocMonad m => Maybe Lang -> Archive -> O m Archive
-updateStyleWithLang Nothing arch = return arch
-updateStyleWithLang (Just lang) arch = do
+updateStyle :: forall m . PandocMonad m
+            => WriterOptions -> Maybe Lang -> Archive -> O m Archive
+updateStyle opts mbLang arch = do
   epochtime <- floor `fmap` lift P.getPOSIXTime
-  entries <- mapM (\e -> if eRelativePath e == "styles.xml"
-                            then case parseXMLElement
-                                    (toTextLazy (fromEntry e)) of
-                                    Left msg -> throwError $
-                                        PandocXMLError "styles.xml" msg
-                                    Right d -> return $
-                                      toEntry "styles.xml" epochtime
-                                      ( fromTextLazy
-                                      . TL.fromStrict
-                                      . ppTopElement
-                                      . addLang lang $ d )
-                            else return e) (zEntries arch)
+  let goEntry :: Entry -> O m Entry
+      goEntry e
+        | eRelativePath e == "styles.xml"
+          = case parseXMLElement (toTextLazy (fromEntry e)) of
+              Left msg -> throwError $ PandocXMLError "styles.xml" msg
+              Right d -> return $
+                toEntry "styles.xml" epochtime
+                ( fromTextLazy
+                . TL.fromStrict
+                . showTopElement
+                . maybe id addLang mbLang
+                . transformElement (\qn -> qName qn == "styles" &&
+                                      qPrefix qn == Just "office" )
+                     (maybe id addHlStyles (writerHighlightStyle opts))
+                $ d )
+        | otherwise = pure e
+  entries <- mapM goEntry (zEntries arch)
   return arch{ zEntries = entries }
 
+addHlStyles :: Style -> Element -> Element
+addHlStyles sty el =
+  el{ elContent = filter (not . isHlStyle) (elContent el) ++
+                styleToOpenDocument sty }
+ where
+   isHlStyle (Elem e) = "Tok" `T.isSuffixOf` (qName (elName e))
+   isHlStyle _ = False
+
+-- top-down search
+transformElement :: (QName -> Bool)
+                 -> (Element -> Element)
+                 -> Element
+                 -> Element
+transformElement g f el
+  | g (elName el)
+    = f el
+  | otherwise
+    = el{ elContent = map go (elContent el) }
+ where
+   go (Elem e) = Elem (transformElement g f e)
+   go x = x
+
 -- TODO FIXME avoid this generic traversal!
 addLang :: Lang -> Element -> Element
 addLang lang = everywhere' (mkT updateLangAttr)
@@ -304,3 +333,36 @@ documentSettings isTextMode = fromStringLazy $ render Nothing
            inTags False "config:config-item" [("config:name", "IsTextMode")
                                              ,("config:type", "boolean")] $
                                               text $ if isTextMode then "true" else "false")
+
+styleToOpenDocument :: Style -> [Content]
+styleToOpenDocument style = map (Elem . toStyle) alltoktypes
+  where alltoktypes = enumFromTo KeywordTok NormalTok
+        styleName x =
+          case T.break (== ':') x of
+            (b, a) | T.null a  -> QName x Nothing (Just "style")
+                   | otherwise -> QName (T.drop 1 a) Nothing (Just b)
+        styleAttr (x, y) = Attr (styleName x) y
+        styleAttrs = map styleAttr
+        styleElement x attrs cs =
+          Element (styleName x) (styleAttrs attrs) cs Nothing
+        toStyle toktype =
+          styleElement "style"
+            [("name", tshow toktype), ("family", "text")]
+            [Elem (styleElement "text-properties"
+                      (tokColor toktype ++ tokBgColor toktype ++
+                        [("fo:font-style", "italic") |
+                           tokFeature tokenItalic toktype ] ++
+                        [("fo:font-weight", "bold") |
+                           tokFeature tokenBold toktype ] ++
+                        [("style:text-underline-style", "solid") |
+                           tokFeature tokenUnderline toktype ])
+                        [])]
+        tokStyles = tokenStyles style
+        tokFeature f toktype = maybe False f $ Map.lookup toktype tokStyles
+        tokColor toktype =
+          maybe [] (\c -> [("fo:color", T.pack (fromColor c))])
+                        ((tokenColor =<< Map.lookup toktype tokStyles)
+                           `mplus` defaultColor style)
+        tokBgColor toktype =
+          maybe [] (\c -> [("fo:background-color", T.pack (fromColor c))])
+                    (tokenBackground =<< Map.lookup toktype tokStyles)
diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs
index 5f17ce7a2..945da4717 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, MonadPlus(mplus))
+import Control.Monad (unless, liftM)
 import Control.Monad.State.Strict ( StateT(..), modify, gets, lift )
 import Data.Char (chr)
 import Data.Foldable (find)
@@ -44,8 +44,7 @@ import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
 import Text.Pandoc.XML
 import Text.Printf (printf)
 import Text.Pandoc.Highlighting (highlight)
-import Skylighting
-import qualified Data.Map as M
+import Skylighting (FormatOptions(..), SourceLine, Token)
 
 -- | Auxiliary function to convert Plain block to Para.
 plainToPara :: Block -> Block
@@ -268,11 +267,9 @@ writeOpenDocument opts (Pandoc meta blocks) = do
                           [("style:name", "L" <> tshow n)] (vcat l)
   let listStyles  = map listStyle (stListStyles s)
   let automaticStyles = vcat $ reverse $ styles ++ listStyles
-  let highlightingStyles = maybe mempty styleToOpenDocument (writerHighlightStyle opts)
   let context = defField "body" body
               . defField "toc" (writerTableOfContents opts)
               . defField "toc-depth" (tshow $ writerTOCDepth opts)
-              . defField "highlighting-styles" highlightingStyles
               . defField "automatic-styles" automaticStyles
               $ metadata
   return $ render colwidth $
@@ -923,23 +920,3 @@ withLangFromAttr (_,_,kvs) action =
                 report $ InvalidLang l
                 action
 
-styleToOpenDocument :: Style -> Doc Text
-styleToOpenDocument style = vcat (map toStyle alltoktypes)
-  where alltoktypes = enumFromTo KeywordTok NormalTok
-        toStyle toktype = inTags True "style:style" [("style:name", tshow toktype),
-                                                     ("style:family", "text")] $
-                             selfClosingTag "style:text-properties"
-                               (tokColor toktype ++ tokBgColor toktype ++
-                                 [("fo:font-style", "italic") |
-                                    tokFeature tokenItalic toktype ] ++
-                                 [("fo:font-weight", "bold") |
-                                    tokFeature tokenBold toktype ] ++
-                                 [("style:text-underline-style", "solid") |
-                                    tokFeature tokenUnderline toktype ])
-        tokStyles = tokenStyles style
-        tokFeature f toktype = maybe False f $ M.lookup toktype tokStyles
-        tokColor toktype = maybe [] (\c -> [("fo:color", T.pack (fromColor c))])
-                         $ (tokenColor =<< M.lookup toktype tokStyles)
-                           `mplus` defaultColor style
-        tokBgColor toktype = maybe [] (\c -> [("fo:background-color", T.pack (fromColor c))])
-                         $ (tokenBackground =<< M.lookup toktype tokStyles)