@@ -52,7 +52,7 @@ import Text.Pandoc.Readers.TeXMath
5252import Text.Pandoc.Highlighting ( highlight )
5353import Text.Pandoc.Walk
5454import Text.Highlighting.Kate.Types ()
55−import Text.XML.Light
55+import Text.XML.Light as XML
5656import Text.TeXMath
5757import Control.Monad.State
5858import Text.Highlighting.Kate
@@ -143,6 +143,31 @@ renderXml :: Element -> BL.ByteString
143143renderXml elt = BL8.pack "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" <>
144144 UTF8.fromStringLazy (showElement elt)
145145
146+renumIdMap :: Int -> [Element] -> M.Map String String
147+renumIdMap _ [] = M.empty
148+renumIdMap n (e:es)
149+ | Just oldId <- findAttr (QName "Id" Nothing Nothing) e =
150+ M.insert oldId ("rId" ++ (show n)) (renumIdMap (n+1) es)
151+ | otherwise = renumIdMap n es
152+
153+replaceAttr :: (QName -> Bool) -> String -> [XML.Attr] -> [XML.Attr]
154+replaceAttr _ _ [] = []
155+replaceAttr f val (a:as) | f (attrKey a) =
156+ (XML.Attr (attrKey a) val) : (replaceAttr f val as)
157+ | otherwise = a : (replaceAttr f val as)
158+
159+renumId :: (QName -> Bool) -> (M.Map String String) -> Element -> Element
160+renumId f renumMap e
161+ | Just oldId <- findAttrBy f e
162+ , Just newId <- M.lookup oldId renumMap =
163+ let attrs' = replaceAttr f newId (elAttribs e)
164+ in
165+ e { elAttribs = attrs' }
166+ | otherwise = e
167+
168+renumIds :: (QName -> Bool) -> (M.Map String String) -> [Element] -> [Element]
169+renumIds f renumMap = map (renumId f renumMap)
170+
146171-- | Produce an Docx file from a Pandoc document.
147172writeDocx :: WriterOptions -- ^ Writer options
148173 -> Pandoc -- ^ Document to convert
@@ -168,12 +193,8 @@ writeDocx opts doc@(Pandoc meta _) = do
168193 let toImageEntry (_,path,_,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img
169194 let imageEntries = map toImageEntry imgs
170195
171− -- adjust contents to add sectPr from reference.docx
172− parsedDoc <- parseXml refArchive distArchive "word/document.xml"
173− let wname f qn = qPrefix qn == Just "w" && f (qName qn)
174− let mbsectpr = filterElementName (wname (=="sectPr")) parsedDoc
175196
176− let sectpr = fromMaybe (mknode "w:sectPr" [] ()) mbsectpr
197+
177198
178199 let stdAttributes =
179200 [("xmlns:w","http://schemas.openxmlformats.org/wordprocessingml/2006/main")
@@ -186,9 +207,6 @@ writeDocx opts doc@(Pandoc meta _) = do
186207 ,("xmlns:pic","http://schemas.openxmlformats.org/drawingml/2006/picture")
187208 ,("xmlns:wp","http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing")]
188209
189− let contents' = contents ++ [sectpr]
190− let docContents = mknode "w:document" stdAttributes
191− $ mknode "w:body" [] contents'
192210
193211 parsedRels <- parseXml refArchive distArchive "word/_rels/document.xml.rels"
194212 let isHeaderNode e = findAttr (QName "Type" Nothing Nothing) e == Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships/header"
@@ -255,7 +273,7 @@ writeDocx opts doc@(Pandoc meta _) = do
255273 [("Type",url')
256274 ,("Id",id')
257275 ,("Target",target')] ()
258− let baserels = map toBaseRel
276+ let baserels' = map toBaseRel
259277 [("http://schemas.openxmlformats.org/officeDocument/2006/relationships/numbering",
260278 "rId1",
261279 "numbering.xml")
@@ -277,8 +295,12 @@ writeDocx opts doc@(Pandoc meta _) = do
277295 ,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/footnotes",
278296 "rId7",
279297 "footnotes.xml")
280− ] ++
281− headers ++ footers
298+ ]
299+
300+ let idMap = renumIdMap (length baserels' + 1) (headers ++ footers)
301+ let renumHeaders = renumIds (\q -> qName q == "Id") idMap headers
302+ let renumFooters = renumIds (\q -> qName q == "Id") idMap footers
303+ let baserels = baserels' ++ renumHeaders ++ renumFooters
282304 let toImgRel (ident,path,_,_,_) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",ident),("Target",path)] ()
283305 let imgrels = map toImgRel imgs
284306 let toLinkRel (src,ident) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink"),("Id",ident),("Target",src),("TargetMode","External") ] ()
@@ -288,6 +310,28 @@ writeDocx opts doc@(Pandoc meta _) = do
288310 $ renderXml reldoc
289311
290312
313+ -- adjust contents to add sectPr from reference.docx
314+ parsedDoc <- parseXml refArchive distArchive "word/document.xml"
315+ let wname f qn = qPrefix qn == Just "w" && f (qName qn)
316+ let mbsectpr = filterElementName (wname (=="sectPr")) parsedDoc
317+ let sectpr = case mbsectpr of
318+ Just sectpr' -> let cs = renumIds
319+ (\q -> qName q == "id" && qPrefix q == Just "r")
320+ idMap
321+ (elChildren sectpr')
322+ in
323+ add_attrs (elAttribs sectpr') $ mknode "w:sectPr" [] cs
324+ Nothing -> (mknode "w:sectPr" [] ())
325+
326+
327+
328+ -- let sectpr = fromMaybe (mknode "w:sectPr" [] ()) mbsectpr'
329+ let contents' = contents ++ [sectpr]
330+ let docContents = mknode "w:document" stdAttributes
331+ $ mknode "w:body" [] contents'
332+
333+
334+
291335 -- word/document.xml
292336 let contentEntry = toEntry "word/document.xml" epochtime
293337 $ renderXml docContents