@@ -32,8 +32,10 @@ module Text.Pandoc.Writers.Docx ( writeDocx ) where
3232import Data.List ( intercalate, groupBy )
3333import qualified Data.ByteString as B
3434import qualified Data.ByteString.Lazy as BL
35+import qualified Data.ByteString.Lazy.Char8 as BL8
3536import qualified Data.Map as M
3637import qualified Text.Pandoc.UTF8 as UTF8
38+import Data.Monoid ((<>))
3739import Codec.Archive.Zip
3840import Data.Time.Clock.POSIX
3941import Text.Pandoc.Definition
@@ -89,9 +91,6 @@ defaultWriterState = WriterState{
8991
9092type WS a = StateT WriterState IO a
9193
92−showTopElement' :: Element -> String
93−showTopElement' x = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++ showElement x
94−
9594mknode :: Node t => String -> [(String,String)] -> t -> Element
9695mknode s attrs =
9796 add_attrs (map (\(k,v) -> Attr (unqual k) v) attrs) . node (unqual s)
@@ -99,6 +98,10 @@ mknode s attrs =
9998toLazy :: B.ByteString -> BL.ByteString
10099toLazy = BL.fromChunks . (:[])
101100
101+renderXml :: Element -> BL.ByteString
102+renderXml elt = BL8.pack "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" <>
103+ UTF8.fromStringLazy (showElement elt)
104+
102105-- | Produce an Docx file from a Pandoc document.
103106writeDocx :: WriterOptions -- ^ Writer options
104107 -> Pandoc -- ^ Document to convert
@@ -155,7 +158,7 @@ writeDocx opts doc@(Pandoc meta _) = do
155158 [("Extension","rels"),("ContentType","application/vnd.openxmlformats-package.relationships+xml")] ()]
156159 let contentTypesDoc = mknode "Types" [("xmlns","http://schemas.openxmlformats.org/package/2006/content-types")] $ defaultnodes ++ overrides
157160 let contentTypesEntry = toEntry "[Content_Types].xml" epochtime
158− $ UTF8.fromStringLazy $ showTopElement' contentTypesDoc
161+ $ renderXml contentTypesDoc
159162
160163 -- word/_rels/document.xml.rels
161164 let toBaseRel (url', id', target') = mknode "Relationship"
@@ -190,22 +193,21 @@ writeDocx opts doc@(Pandoc meta _) = do
190193 let linkrels = map toLinkRel $ M.toList $ stExternalLinks st
191194 let reldoc = mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")] $ baserels ++ imgrels ++ linkrels
192195 let relEntry = toEntry "word/_rels/document.xml.rels" epochtime
193− $ UTF8.fromStringLazy $ showTopElement' reldoc
196+ $ renderXml reldoc
194197
195198 -- create entries for images in word/media/...
196199 let toImageEntry (_,path,_,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img
197200 let imageEntries = map toImageEntry imgs
198201
199202 -- word/document.xml
200− let contentEntry = toEntry "word/document.xml" epochtime $ UTF8.fromStringLazy $ showTopElement' contents
203+ let contentEntry = toEntry "word/document.xml" epochtime $ renderXml contents
201204
202205 -- footnotes
203− let footnotesEntry = toEntry "word/footnotes.xml" epochtime $ UTF8.fromStringLazy $
204− showTopElement' footnotes
206+ let footnotesEntry = toEntry "word/footnotes.xml" epochtime $ renderXml footnotes
205207
206208 -- footnote rels
207− let footnoteRelEntry = toEntry "word/_rels/footnotes.xml.rels" epochtime $ UTF8.fromStringLazy $
208− showTopElement' $ mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
209+ let footnoteRelEntry = toEntry "word/_rels/footnotes.xml.rels" epochtime
210+ $ renderXml $ mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
209211 $ linkrels
210212
211213 -- styles
@@ -213,11 +215,11 @@ writeDocx opts doc@(Pandoc meta _) = do
213215 let stylepath = "word/styles.xml"
214216 styledoc <- parseXml refArchive stylepath
215217 let styledoc' = styledoc{ elContent = elContent styledoc ++ map Elem newstyles }
216− let styleEntry = toEntry stylepath epochtime $ UTF8.fromStringLazy $ showTopElement' styledoc'
218+ let styleEntry = toEntry stylepath epochtime $ renderXml styledoc'
217219
218220 -- construct word/numbering.xml
219221 let numpath = "word/numbering.xml"
220− numEntry <- (toEntry numpath epochtime . UTF8.fromStringLazy . showTopElement')
222+ numEntry <- (toEntry numpath epochtime . renderXml)
221223 `fmap` mkNumbering (stNumStyles st) (stLists st)
222224 let docPropsPath = "docProps/core.xml"
223225 let docProps = mknode "cp:coreProperties"
@@ -231,21 +233,36 @@ writeDocx opts doc@(Pandoc meta _) = do
231233 (maybe "" id $ normalizeDate $ stringify $ docDate meta)
232234 : mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] () -- put current time here
233235 : map (mknode "dc:creator" [] . stringify) (docAuthors meta)
234− let docPropsEntry = toEntry docPropsPath epochtime $ UTF8.fromStringLazy $ showTopElement' docProps
235− let relsPath = "_rels/.rels"
236− rels <- case findEntryByPath relsPath refArchive of
237− Just e -> return $ UTF8.toStringLazy $ fromEntry e
238− Nothing -> err 57 "could not find .rels/_rels in reference docx"
236+ let docPropsEntry = toEntry docPropsPath epochtime $ renderXml docProps
239237
240− -- fix .rels/_rels, which can get screwed up when reference.docx is edited by Word
241− let rels' = substitute "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties"
242− "http://schemas.openxmlformats.org/officedocument/2006/relationships/metadata/core-properties"
243− rels
244− let relsEntry = toEntry relsPath epochtime $ UTF8.fromStringLazy rels'
238+ let relsPath = "_rels/.rels"
239+ let rels = mknode "Relationships" [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
240+ $ map (\attrs -> mknode "Relationship" attrs ())
241+ [ [("Id","rId1")
242+ ,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument")
243+ ,("Target","word/document.xml")]
244+ , [("Id","rId4")
245+ ,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties")
246+ ,("Target","docProps/app.xml")]
247+ , [("Id","rId3")
248+ ,("Type","http://schemas.openxmlformats.org/officedocument/2006/relationships/metadata/core-properties")
249+ ,("Target","docProps/core.xml")]
250+ ]
251+ let relsEntry = toEntry relsPath epochtime $ renderXml rels
252+
253+ let entryFromArchive path = (toEntry path epochtime . renderXml) `fmap`
254+ parseXml refArchive path
255+ docPropsAppEntry <- entryFromArchive "docProps/app.xml"
256+ themeEntry <- entryFromArchive "word/theme/theme1.xml"
257+ fontTableEntry <- entryFromArchive "word/fontTable.xml"
258+ webSettingsEntry <- entryFromArchive "word/webSettings.xml"
245259
246260 -- Create archive
247− let archive = foldr addEntryToArchive refArchive $
248− contentTypesEntry : relsEntry : contentEntry : relEntry : footnoteRelEntry : numEntry : styleEntry : footnotesEntry : docPropsEntry : imageEntries
261+ let archive = foldr addEntryToArchive emptyArchive $
262+ contentTypesEntry : relsEntry : contentEntry : relEntry :
263+ footnoteRelEntry : numEntry : styleEntry : footnotesEntry :
264+ docPropsEntry : docPropsAppEntry : themeEntry :
265+ fontTableEntry : webSettingsEntry : imageEntries
249266 return $ fromArchive archive
250267
251268styleToOpenXml :: Style -> [Element]