@@ -29,7 +29,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2929Conversion of 'Pandoc' documents to docx.
3030-}
3131module Text.Pandoc.Writers.Docx ( writeDocx ) where
32−import Data.List ( intercalate, isPrefixOf, isSuffixOf )
32+import Data.List ( intercalate, isPrefixOf, isSuffixOf, stripPrefix )
3333import qualified Data.ByteString as B
3434import qualified Data.ByteString.Lazy as BL
3535import qualified Data.ByteString.Lazy.Char8 as BL8
@@ -64,6 +64,7 @@ import Text.Pandoc.MIME (MimeType, getMimeType, getMimeTypeDef,
6464 extensionFromMimeType)
6565import Control.Applicative ((<$>), (<|>), (<*>))
6666import Data.Maybe (fromMaybe, mapMaybe)
67+import Data.Char (isDigit)
6768
6869data ListMarker = NoMarker
6970 | BulletMarker
@@ -105,6 +106,7 @@ data WriterState = WriterState{
105106 , stChangesAuthor :: String
106107 , stChangesDate :: String
107108 , stPrintWidth :: Integer
109+ , stHeadingStyles :: [(Int,String)]
108110 }
109111
110112defaultWriterState :: WriterState
@@ -124,6 +126,7 @@ defaultWriterState = WriterState{
124126 , stChangesAuthor = "unknown"
125127 , stChangesDate = "1969-12-31T19:00:00Z"
126128 , stPrintWidth = 1
129+ , stHeadingStyles = []
127130 }
128131
129132type WS a = StateT WriterState IO a
@@ -205,11 +208,37 @@ writeDocx opts doc@(Pandoc meta _) = do
205208 <*> (read <$> mbAttrMarLeft ::Maybe Integer)
206209 )
207210
211+ -- styles
212+ let stylepath = "word/styles.xml"
213+ styledoc <- parseXml refArchive distArchive stylepath
214+
215+ -- parse styledoc for heading styles
216+ let styleNamespaces = map ((,) <$> qName . attrKey <*> attrVal) .
217+ filter ((==Just "xmlns") . qPrefix . attrKey) .
218+ elAttribs $ styledoc
219+ let headingStyles =
220+ let
221+ mywURI = lookup "w" styleNamespaces
222+ myName name = QName name mywURI (Just "w")
223+ getAttrStyleId = findAttr (myName "styleId")
224+ getNameVal = findChild (myName "name") >=> findAttr (myName "val")
225+ getNum s | not $ null s, all isDigit s = Just (read s :: Int)
226+ | otherwise = Nothing
227+ getEngHeader = getAttrStyleId >=> stripPrefix "Heading" >=> getNum
228+ getIntHeader = getNameVal >=> stripPrefix "heading " >=> getNum
229+ toTuple getF = liftM2 (,) <$> getF <*> getAttrStyleId
230+ toMap getF = mapMaybe (toTuple getF) $
231+ findChildren (myName "style") styledoc
232+ select a b | not $ null a = a
233+ | otherwise = b
234+ in
235+ select (toMap getEngHeader) (toMap getIntHeader)
236+
208237 ((contents, footnotes), st) <- runStateT (writeOpenXML opts{writerWrapText = False} doc')
209238 defaultWriterState{ stChangesAuthor = fromMaybe "unknown" username
210239 , stChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime
211− , stPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth) }
212−
240+ , stPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth)
241+ , stHeadingStyles = headingStyles}
213242 let epochtime = floor $ utcTimeToPOSIXSeconds utctime
214243 let imgs = M.elems $ stImages st
215244
@@ -363,8 +392,6 @@ writeDocx opts doc@(Pandoc meta _) = do
363392
364393 -- styles
365394 let newstyles = styleToOpenXml $ writerHighlightStyle opts
366− let stylepath = "word/styles.xml"
367− styledoc <- parseXml refArchive distArchive stylepath
368395 let styledoc' = styledoc{ elContent = elContent styledoc ++
369396 [Elem x | x <- newstyles, writerHighlight opts] }
370397 let styleEntry = toEntry stylepath epochtime $ renderXml styledoc'
@@ -616,8 +643,9 @@ blockToOpenXML opts (Div (_,["references"],_) bs) = do
616643 return (header ++ rest)
617644blockToOpenXML opts (Div _ bs) = blocksToOpenXML opts bs
618645blockToOpenXML opts (Header lev (ident,_,_) lst) = do
619− paraProps <- withParaProp (pStyle $ "Heading" ++ show lev) $
620− getParaProps False
646+ headingStyles <- gets stHeadingStyles
647+ paraProps <- maybe id (withParaProp . pStyle) (lookup lev headingStyles) $
648+ getParaProps False
621649 contents <- inlinesToOpenXML opts lst
622650 usedIdents <- gets stSectionIds
623651 let bookmarkName = if null ident