Docx writer: pass through comments.

We assume that comments are defined as parsed by the
docx reader:

    I want <span class="comment-start" id="0" author="Jesse Rosenthal"
    date="2016-05-09T16:13:00Z">I left a comment.</span>some text to
    have a comment <span class="comment-end" id="0"></span>on it.

We assume also that the id attributes are unique and properly
matched between comment-start and comment-end.

Closes #2994.

1 files changed, 47 insertions, 8 deletions

diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs
index 8b19f3740..51e4ffb98 100644
--- a/src/Text/Pandoc/Writers/Docx.hs
+++ b/src/Text/Pandoc/Writers/Docx.hs
@@ -123,6 +123,7 @@ defaultWriterEnv = WriterEnv{ envTextProperties = []
 
 data WriterState = WriterState{
          stFootnotes      :: [Element]
+       , stComments       :: [([(String,String)], [Inline])]
        , stSectionIds     :: Set.Set String
        , stExternalLinks  :: M.Map String String
        , stImages         :: M.Map FilePath (String, String, Maybe MimeType, Element, B.ByteString)
@@ -139,6 +140,7 @@ data WriterState = WriterState{
 defaultWriterState :: WriterState
 defaultWriterState = WriterState{
         stFootnotes      = defaultFootnotes
+      , stComments       = []
       , stSectionIds     = Set.empty
       , stExternalLinks  = M.empty
       , stImages         = M.empty
@@ -305,11 +307,11 @@ writeDocx opts doc@(Pandoc meta _) = do
         }
 
 
-  ((contents, footnotes), st) <- runStateT
-                                 (runReaderT
-                                  (writeOpenXML opts{writerWrapText = WrapNone} doc')
-                                  env)
-                                 initialSt
+  ((contents, footnotes, comments), st) <- runStateT
+                         (runReaderT
+                          (writeOpenXML opts{writerWrapText = WrapNone} doc')
+                          env)
+                         initialSt
   let epochtime = floor $ utcTimeToPOSIXSeconds utctime
   let imgs = M.elems $ stImages st
 
@@ -370,6 +372,8 @@ writeDocx opts doc@(Pandoc meta _) = do
                     "application/vnd.openxmlformats-officedocument.wordprocessingml.styles+xml")
                   ,("/word/document.xml",
                     "application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml")
+                  ,("/word/comments.xml",
+                    "application/vnd.openxmlformats-officedocument.wordprocessingml.comments+xml")
                   ,("/word/footnotes.xml",
                     "application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml")
                   ] ++
@@ -416,6 +420,9 @@ writeDocx opts doc@(Pandoc meta _) = do
                     ,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/footnotes",
                       "rId7",
                       "footnotes.xml")
+                    ,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments",
+                      "rId8",
+                      "comments.xml")
                     ]
 
   let idMap = renumIdMap (length baserels' + 1) (headers ++ footers)
@@ -461,6 +468,10 @@ writeDocx opts doc@(Pandoc meta _) = do
         $ renderXml $ mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
         linkrels
 
+  -- comments
+  let commentsEntry = toEntry "word/comments.xml" epochtime
+        $ renderXml $ mknode "w:comments" stdAttributes comments
+
   -- styles
 
   -- We only want to inject paragraph and text properties that
@@ -564,6 +575,7 @@ writeDocx opts doc@(Pandoc meta _) = do
   let archive = foldr addEntryToArchive emptyArchive $
                   contentTypesEntry : relsEntry : contentEntry : relEntry :
                   footnoteRelEntry : numEntry : styleEntry : footnotesEntry :
+                  commentsEntry :
                   docPropsEntry : docPropsAppEntry : themeEntry :
                   fontTableEntry : settingsEntry : webSettingsEntry :
                   imageEntries ++ headerFooterEntries ++
@@ -762,7 +774,7 @@ makeTOC _ = return []
 
 -- | Convert Pandoc document to two lists of
 -- OpenXML elements (the main document and footnotes).
-writeOpenXML :: (PandocMonad m) => WriterOptions -> Pandoc -> WS m ([Element], [Element])
+writeOpenXML :: (PandocMonad m) => WriterOptions -> Pandoc -> WS m ([Element], [Element],[Element])
 writeOpenXML opts (Pandoc meta blocks) = do
   let tit = docTitle meta ++ case lookupMeta "subtitle" meta of
                                   Just (MetaBlocks [Plain xs]) -> LineBreak : xs
@@ -791,10 +803,27 @@ writeOpenXML opts (Pandoc meta blocks) = do
       convertSpace xs                           = xs
   let blocks' = bottomUp convertSpace blocks
   doc' <- (setFirstPara >> blocksToOpenXML opts blocks')
-  notes' <- reverse `fmap` gets stFootnotes
+  notes' <- reverse <$> gets stFootnotes
+  comments <- reverse <$> gets stComments
+  let toComment (kvs, ils) = do
+        annotation <- inlinesToOpenXML opts ils
+        return $
+          mknode "w:comment" [('w':':':k,v) | (k,v) <- kvs]
+            [ mknode "w:p" [] $
+              [ mknode "w:pPr" []
+                [ mknode "w:pStyle" [("w:val", "CommentText")] () ]
+              , mknode "w:r" []
+                [ mknode "w:rPr" []
+                  [ mknode "w:rStyle" [("w:val", "CommentReference")] ()
+                  , mknode "w:annotationRef" [] ()
+                  ]
+                ]
+              ] ++ annotation
+            ]
+  comments' <- mapM toComment comments
   toc <- makeTOC opts
   let meta' = title ++ subtitle ++ authors ++ date ++ abstract ++ toc
-  return (meta' ++ doc', notes')
+  return (meta' ++ doc', notes', comments')
 
 -- | Convert a list of Pandoc blocks to OpenXML.
 blocksToOpenXML :: (PandocMonad m) => WriterOptions -> [Block] -> WS m [Element]
@@ -1101,6 +1130,16 @@ inlineToOpenXML' _ (Str str) =
   formattedString str
 inlineToOpenXML' opts Space = inlineToOpenXML opts (Str " ")
 inlineToOpenXML' opts SoftBreak = inlineToOpenXML opts (Str " ")
+inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do
+  modify $ \st -> st{ stComments = (("id",ident):kvs, ils) : stComments st }
+  return [ mknode "w:commentRangeStart" [("w:id", ident)] () ]
+inlineToOpenXML' _ (Span (ident,["comment-end"],_) _) = do
+  return [ mknode "w:commentRangeEnd" [("w:id", ident)] ()
+         , mknode "w:r" []
+           [ mknode "w:rPr" []
+             [ mknode "w:rStyle" [("w:val", "CommentReference")] () ]
+           , mknode "w:commentReference" [("w:id", ident)] () ]
+         ]
 inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do
   stylemod <- case lookup dynamicStyleKey kvs of
                    Just sty -> do