@@ -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, stripPrefix )
32+import Data.List ( intercalate, isPrefixOf, isSuffixOf )
3333import qualified Data.ByteString as B
3434import qualified Data.ByteString.Lazy as BL
3535import qualified Data.ByteString.Lazy.Char8 as BL8
@@ -54,6 +54,8 @@ import Text.Pandoc.Walk
5454import Text.Highlighting.Kate.Types ()
5555import Text.XML.Light as XML
5656import Text.TeXMath
57+import Text.Pandoc.Readers.Docx.StyleMap
58+import Text.Pandoc.Readers.Docx.Util (elemName)
5759import Control.Monad.State
5860import Text.Highlighting.Kate
5961import Data.Unique (hashUnique, newUnique)
@@ -63,8 +65,7 @@ import qualified Control.Exception as E
6365import Text.Pandoc.MIME (MimeType, getMimeType, getMimeTypeDef,
6466 extensionFromMimeType)
6567import Control.Applicative ((<$>), (<|>), (<*>))
66−import Data.Maybe (fromMaybe, mapMaybe)
67−import Data.Char (isDigit)
68+import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
6869
6970data ListMarker = NoMarker
7071 | BulletMarker
@@ -106,7 +107,7 @@ data WriterState = WriterState{
106107 , stChangesAuthor :: String
107108 , stChangesDate :: String
108109 , stPrintWidth :: Integer
109− , stHeadingStyles :: [(Int,String)]
110+ , stStyleMaps :: StyleMaps
110111 , stFirstPara :: Bool
111112 }
112113
@@ -127,7 +128,7 @@ defaultWriterState = WriterState{
127128 , stChangesAuthor = "unknown"
128129 , stChangesDate = "1969-12-31T19:00:00Z"
129130 , stPrintWidth = 1
130− , stHeadingStyles = []
131+ , stStyleMaps = defaultStyleMaps
131132 , stFirstPara = False
132133 }
133134
@@ -215,32 +216,14 @@ writeDocx opts doc@(Pandoc meta _) = do
215216 styledoc <- parseXml refArchive distArchive stylepath
216217
217218 -- parse styledoc for heading styles
218− let styleNamespaces = map ((,) <$> qName . attrKey <*> attrVal) .
219− filter ((==Just "xmlns") . qPrefix . attrKey) .
220− elAttribs $ styledoc
221− let headingStyles =
222− let
223− mywURI = lookup "w" styleNamespaces
224− myName name = QName name mywURI (Just "w")
225− getAttrStyleId = findAttr (myName "styleId")
226− getNameVal = findChild (myName "name") >=> findAttr (myName "val")
227− getNum s | not $ null s, all isDigit s = Just (read s :: Int)
228− | otherwise = Nothing
229− getEngHeader = getAttrStyleId >=> stripPrefix "Heading" >=> getNum
230− getIntHeader = getNameVal >=> stripPrefix "heading " >=> getNum
231− toTuple getF = liftM2 (,) <$> getF <*> getAttrStyleId
232− toMap getF = mapMaybe (toTuple getF) $
233− findChildren (myName "style") styledoc
234− select a b | not $ null a = a
235− | otherwise = b
236− in
237− select (toMap getEngHeader) (toMap getIntHeader)
219+ let styleMaps = getStyleMaps styledoc
238220
239221 ((contents, footnotes), st) <- runStateT (writeOpenXML opts{writerWrapText = False} doc')
240222 defaultWriterState{ stChangesAuthor = fromMaybe "unknown" username
241223 , stChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime
242224 , stPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth)
243− , stHeadingStyles = headingStyles}
225+ , stStyleMaps = styleMaps
226+ }
244227 let epochtime = floor $ utcTimeToPOSIXSeconds utctime
245228 let imgs = M.elems $ stImages st
246229
@@ -393,9 +376,18 @@ writeDocx opts doc@(Pandoc meta _) = do
393376 linkrels
394377
395378 -- styles
396− let newstyles = styleToOpenXml $ writerHighlightStyle opts
397− let styledoc' = styledoc{ elContent = elContent styledoc ++
398− [Elem x | x <- newstyles, writerHighlight opts] }
379+ let newstyles = styleToOpenXml styleMaps $ writerHighlightStyle opts
380+ let styledoc' = styledoc{ elContent = modifyContent (elContent styledoc) }
381+ where
382+ modifyContent
383+ | writerHighlight opts = (++ map Elem newstyles)
384+ | otherwise = filter notTokStyle
385+ notTokStyle (Elem el) = notStyle el || notTokId el
386+ notTokStyle _ = True
387+ notStyle = (/= elemName' "style") . elName
388+ notTokId = maybe True (`notElem` tokStys) . findAttr (elemName' "styleId")
389+ tokStys = "SourceCode" : map show (enumFromTo KeywordTok NormalTok)
390+ elemName' = elemName (sNameSpaces styleMaps) "w"
399391 let styleEntry = toEntry stylepath epochtime $ renderXml styledoc'
400392
401393 -- construct word/numbering.xml
@@ -472,10 +464,13 @@ writeDocx opts doc@(Pandoc meta _) = do
472464 miscRelEntries ++ otherMediaEntries
473465 return $ fromArchive archive
474466
475−styleToOpenXml :: Style -> [Element]
476−styleToOpenXml style = parStyle : map toStyle alltoktypes
467+styleToOpenXml :: StyleMaps -> Style -> [Element]
468+styleToOpenXml sm style =
469+ maybeToList parStyle ++ mapMaybe toStyle alltoktypes
477470 where alltoktypes = enumFromTo KeywordTok NormalTok
478− toStyle toktype = mknode "w:style" [("w:type","character"),
471+ toStyle toktype | hasStyleName (show toktype) (sCharStyleMap sm) = Nothing
472+ | otherwise = Just $
473+ mknode "w:style" [("w:type","character"),
479474 ("w:customStyle","1"),("w:styleId",show toktype)]
480475 [ mknode "w:name" [("w:val",show toktype)] ()
481476 , mknode "w:basedOn" [("w:val","VerbatimChar")] ()
@@ -496,7 +491,9 @@ styleToOpenXml style = parStyle : map toStyle alltoktypes
496491 tokBg toktype = maybe "auto" (drop 1 . fromColor)
497492 $ (tokenBackground =<< lookup toktype tokStyles)
498493 `mplus` backgroundColor style
499− parStyle = mknode "w:style" [("w:type","paragraph"),
494+ parStyle | hasStyleName "Source Code" (sParaStyleMap sm) = Nothing
495+ | otherwise = Just $
496+ mknode "w:style" [("w:type","paragraph"),
500497 ("w:customStyle","1"),("w:styleId","SourceCode")]
501498 [ mknode "w:name" [("w:val","Source Code")] ()
502499 , mknode "w:basedOn" [("w:val","Normal")] ()
@@ -602,14 +599,14 @@ writeOpenXML opts (Pandoc meta blocks) = do
602599 Just (MetaBlocks [Para xs]) -> xs
603600 Just (MetaInlines xs) -> xs
604601 _ -> []
605− title <- withParaProp (pStyle "Title") $ blocksToOpenXML opts [Para tit | not (null tit)]
606− subtitle <- withParaProp (pStyle "Subtitle") $ blocksToOpenXML opts [Para subtitle' | not (null subtitle')]
607− authors <- withParaProp (pStyle "Author") $ blocksToOpenXML opts $
602+ title <- withParaPropM (pStyleM "Title") $ blocksToOpenXML opts [Para tit | not (null tit)]
603+ subtitle <- withParaPropM (pStyleM "Subtitle") $ blocksToOpenXML opts [Para subtitle' | not (null subtitle')]
604+ authors <- withParaProp (pCustomStyle "Author") $ blocksToOpenXML opts $
608605 map Para auths
609− date <- withParaProp (pStyle "Date") $ blocksToOpenXML opts [Para dat | not (null dat)]
606+ date <- withParaPropM (pStyleM "Date") $ blocksToOpenXML opts [Para dat | not (null dat)]
610607 abstract <- if null abstract'
611608 then return []
612− else withParaProp (pStyle "Abstract") $ blocksToOpenXML opts abstract'
609+ else withParaProp (pCustomStyle "Abstract") $ blocksToOpenXML opts abstract'
613610 let convertSpace (Str x : Space : Str y : xs) = Str (x ++ " " ++ y) : xs
614611 convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs
615612 convertSpace xs = xs
@@ -623,11 +620,23 @@ writeOpenXML opts (Pandoc meta blocks) = do
623620blocksToOpenXML :: WriterOptions -> [Block] -> WS [Element]
624621blocksToOpenXML opts bls = concat `fmap` mapM (blockToOpenXML opts) bls
625622
626−pStyle :: String -> Element
627−pStyle sty = mknode "w:pStyle" [("w:val",sty)] ()
623+pCustomStyle :: String -> Element
624+pCustomStyle sty = mknode "w:pStyle" [("w:val",sty)] ()
628625
629−rStyle :: String -> Element
630−rStyle sty = mknode "w:rStyle" [("w:val",sty)] ()
626+pStyleM :: String -> WS XML.Element
627+pStyleM styleName = do
628+ styleMaps <- gets stStyleMaps
629+ let sty' = getStyleId styleName $ sParaStyleMap styleMaps
630+ return $ mknode "w:pStyle" [("w:val",sty')] ()
631+
632+rCustomStyle :: String -> Element
633+rCustomStyle sty = mknode "w:rStyle" [("w:val",sty)] ()
634+
635+rStyleM :: String -> WS XML.Element
636+rStyleM styleName = do
637+ styleMaps <- gets stStyleMaps
638+ let sty' = getStyleId styleName $ sCharStyleMap styleMaps
639+ return $ mknode "w:rStyle" [("w:val",sty')] ()
631640
632641getUniqueId :: MonadIO m => m String
633642-- the + 20 is to ensure that there are no clashes with the rIds
@@ -641,13 +650,12 @@ blockToOpenXML opts (Div (_,["references"],_) bs) = do
641650 let (hs, bs') = span isHeaderBlock bs
642651 header <- blocksToOpenXML opts hs
643652 -- We put the Bibliography style on paragraphs after the header
644− rest <- withParaProp (pStyle "Bibliography") $ blocksToOpenXML opts bs'
653+ rest <- withParaPropM (pStyleM "Bibliography") $ blocksToOpenXML opts bs'
645654 return (header ++ rest)
646655blockToOpenXML opts (Div _ bs) = blocksToOpenXML opts bs
647656blockToOpenXML opts (Header lev (ident,_,_) lst) = do
648657 setFirstPara
649− headingStyles <- gets stHeadingStyles
650− paraProps <- maybe id (withParaProp . pStyle) (lookup lev headingStyles) $
658+ paraProps <- withParaPropM (pStyleM ("Heading "++show lev)) $
651659 getParaProps False
652660 contents <- inlinesToOpenXML opts lst
653661 usedIdents <- gets stSectionIds
@@ -660,26 +668,27 @@ blockToOpenXML opts (Header lev (ident,_,_) lst) = do
660668 ,("w:name",bookmarkName)] ()
661669 let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] ()
662670 return [mknode "w:p" [] (paraProps ++ [bookmarkStart, bookmarkEnd] ++ contents)]
663−blockToOpenXML opts (Plain lst) = withParaProp (pStyle "Compact")
671+blockToOpenXML opts (Plain lst) = withParaProp (pCustomStyle "Compact")
664672 $ blockToOpenXML opts (Para lst)
665673-- title beginning with fig: indicates that the image is a figure
666674blockToOpenXML opts (Para [Image alt (src,'f':'i':'g':':':tit)]) = do
667675 setFirstPara
668676 paraProps <- getParaProps False
669677 contents <- inlinesToOpenXML opts [Image alt (src,tit)]
670− captionNode <- withParaProp (pStyle "ImageCaption")
678+ captionNode <- withParaProp (pCustomStyle "ImageCaption")
671679 $ blockToOpenXML opts (Para alt)
672680 return $ mknode "w:p" [] (paraProps ++ contents) : captionNode
673681-- fixDisplayMath sometimes produces a Para [] as artifact
674682blockToOpenXML _ (Para []) = return []
675683blockToOpenXML opts (Para lst) = do
676− isFirstPara <- gets stFirstPara
684+ isFirstPara <- gets stFirstPara
677685 paraProps <- getParaProps $ case lst of
678686 [Math DisplayMath _] -> True
679687 _ -> False
688+ bodyTextStyle <- pStyleM "Body Text"
680689 let paraProps' = case paraProps of
681− [] | isFirstPara -> [mknode "w:pPr" [] [(pStyle "FirstParagraph")]]
682− [] -> [mknode "w:pPr" [] [(pStyle "BodyText")]]
690+ [] | isFirstPara -> [mknode "w:pPr" [] [pCustomStyle "FirstParagraph"]]
691+ [] -> [mknode "w:pPr" [] [bodyTextStyle]]
683692 ps -> ps
684693 modify $ \s -> s { stFirstPara = False }
685694 contents <- inlinesToOpenXML opts lst
@@ -688,11 +697,11 @@ blockToOpenXML _ (RawBlock format str)
688697 | format == Format "openxml" = return [ x | Elem x <- parseXML str ]
689698 | otherwise = return []
690699blockToOpenXML opts (BlockQuote blocks) = do
691− p <- withParaProp (pStyle "BlockQuote") $ blocksToOpenXML opts blocks
700+ p <- withParaPropM (pStyleM "Block Text") $ blocksToOpenXML opts blocks
692701 setFirstPara
693702 return p
694703blockToOpenXML opts (CodeBlock attrs str) = do
695− p <- withParaProp (pStyle "SourceCode") $ (blockToOpenXML opts $ Para [Code attrs str])
704+ p <- withParaProp (pCustomStyle "SourceCode") (blockToOpenXML opts $ Para [Code attrs str])
696705 setFirstPara
697706 return p
698707blockToOpenXML _ HorizontalRule = do
@@ -707,7 +716,7 @@ blockToOpenXML opts (Table caption aligns widths headers rows) = do
707716 let captionStr = stringify caption
708717 caption' <- if null caption
709718 then return []
710− else withParaProp (pStyle "TableCaption")
719+ else withParaProp (pCustomStyle "TableCaption")
711720 $ blockToOpenXML opts (Para caption)
712721 let alignmentFor al = mknode "w:jc" [("w:val",alignmentToString al)] ()
713722 let cellToOpenXML (al, cell) = withParaProp (alignmentFor al)
@@ -718,32 +727,36 @@ blockToOpenXML opts (Table caption aligns widths headers rows) = do
718727 [ mknode "w:tcBorders" []
719728 $ mknode "w:bottom" [("w:val","single")] ()
720729 , mknode "w:vAlign" [("w:val","bottom")] () ]
721− let emptyCell = [mknode "w:p" [] [mknode "w:pPr" []
722− [mknode "w:pStyle" [("w:val","Compact")] ()]]]
730+ let emptyCell = [mknode "w:p" [] [pCustomStyle "Compact"]]
723731 let mkcell border contents = mknode "w:tc" []
724732 $ [ borderProps | border ] ++
725733 if null contents
726734 then emptyCell
727735 else contents
728− let mkrow border cells = mknode "w:tr" [] $ map (mkcell border) cells
736+ let mkrow border cells = mknode "w:tr" [] $
737+ [mknode "w:trPr" [] [
738+ mknode "w:cnfStyle" [("w:firstRow","1")] ()] | border]
739+ ++ map (mkcell border) cells
729740 let textwidth = 7920 -- 5.5 in in twips, 1/20 pt
730741 let fullrow = 5000 -- 100% specified in pct
731742 let rowwidth = fullrow * sum widths
732743 let mkgridcol w = mknode "w:gridCol"
733744 [("w:w", show (floor (textwidth * w) :: Integer))] ()
745+ let hasHeader = not (all null headers)
734746 return $
735747 caption' ++
736748 [mknode "w:tbl" []
737749 ( mknode "w:tblPr" []
738750 ( mknode "w:tblStyle" [("w:val","TableNormal")] () :
739751 mknode "w:tblW" [("w:type", "pct"), ("w:w", show rowwidth)] () :
752+ mknode "w:tblLook" [("w:firstRow","1") | hasHeader ] () :
740753 [ mknode "w:tblCaption" [("w:val", captionStr)] ()
741754 | not (null caption) ] )
742755 : mknode "w:tblGrid" []
743756 (if all (==0) widths
744757 then []
745758 else map mkgridcol widths)
746− : [ mkrow True headers' | not (all null headers) ] ++
759+ : [ mkrow True headers' | hasHeader ] ++
747760 map (mkrow False) rows'
748761 )]
749762blockToOpenXML opts (BulletList lst) = do
@@ -767,9 +780,9 @@ blockToOpenXML opts (DefinitionList items) = do
767780
768781definitionListItemToOpenXML :: WriterOptions -> ([Inline],[[Block]]) -> WS [Element]
769782definitionListItemToOpenXML opts (term,defs) = do
770− term' <- withParaProp (pStyle "DefinitionTerm")
783+ term' <- withParaProp (pCustomStyle "DefinitionTerm")
771784 $ blockToOpenXML opts (Para term)
772− defs' <- withParaProp (pStyle "Definition")
785+ defs' <- withParaProp (pCustomStyle "Definition")
773786 $ concat `fmap` mapM (blocksToOpenXML opts) defs
774787 return $ term' ++ defs'
775788
@@ -833,6 +846,9 @@ withTextProp d p = do
833846 popTextProp
834847 return res
835848
849+withTextPropM :: WS Element -> WS a -> WS a
850+withTextPropM = (. flip withTextProp) . (>>=)
851+
836852getParaProps :: Bool -> WS [Element]
837853getParaProps displayMathPara = do
838854 props <- gets stParaProperties
@@ -861,6 +877,9 @@ withParaProp d p = do
861877 popParaProp
862878 return res
863879
880+withParaPropM :: WS Element -> WS a -> WS a
881+withParaPropM = (. flip withParaProp) . (>>=)
882+
864883formattedString :: String -> WS [Element]
865884formattedString str = do
866885 props <- getTextProps
@@ -943,25 +962,26 @@ inlineToOpenXML opts (Math mathType str) = do
943962 Right r -> return [r]
944963 Left _ -> inlinesToOpenXML opts (texMathToInlines mathType str)
945964inlineToOpenXML opts (Cite _ lst) = inlinesToOpenXML opts lst
946−inlineToOpenXML opts (Code attrs str) =
947− withTextProp (rStyle "VerbatimChar")
948− $ if writerHighlight opts
949− then case highlight formatOpenXML attrs str of
950− Nothing -> unhighlighted
951− Just h -> return h
952− else unhighlighted
953− where unhighlighted = intercalate [br] `fmap`
954− (mapM formattedString $ lines str)
955− formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok)
956− toHlTok (toktype,tok) = mknode "w:r" []
957− [ mknode "w:rPr" []
958− [ rStyle $ show toktype ]
959− , mknode "w:t" [("xml:space","preserve")] tok ]
965+inlineToOpenXML opts (Code attrs str) = do
966+ let unhighlighted = intercalate [br] `fmap`
967+ (mapM formattedString $ lines str)
968+ formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok)
969+ toHlTok (toktype,tok) = mknode "w:r" []
970+ [ mknode "w:rPr" []
971+ [ rCustomStyle (show toktype) ]
972+ , mknode "w:t" [("xml:space","preserve")] tok ]
973+ withTextProp (rCustomStyle "VerbatimChar")
974+ $ if writerHighlight opts
975+ then case highlight formatOpenXML attrs str of
976+ Nothing -> unhighlighted
977+ Just h -> return h
978+ else unhighlighted
960979inlineToOpenXML opts (Note bs) = do
961980 notes <- gets stFootnotes
962981 notenum <- getUniqueId
982+ footnoteStyle <- rStyleM "Footnote Reference"
963983 let notemarker = mknode "w:r" []
964− [ mknode "w:rPr" [] (rStyle "FootnoteRef")
984+ [ mknode "w:rPr" [] footnoteStyle
965985 , mknode "w:footnoteRef" [] () ]
966986 let notemarkerXml = RawInline (Format "openxml") $ ppElement notemarker
967987 let insertNoteRef (Plain ils : xs) = Plain (notemarkerXml : ils) : xs
@@ -971,22 +991,22 @@ inlineToOpenXML opts (Note bs) = do
971991 oldParaProperties <- gets stParaProperties
972992 oldTextProperties <- gets stTextProperties
973993 modify $ \st -> st{ stListLevel = -1, stParaProperties = [], stTextProperties = [] }
974− contents <- withParaProp (pStyle "FootnoteText") $ blocksToOpenXML opts
994+ contents <- withParaPropM (pStyleM "Footnote Text") $ blocksToOpenXML opts
975995 $ insertNoteRef bs
976996 modify $ \st -> st{ stListLevel = oldListLevel, stParaProperties = oldParaProperties,
977997 stTextProperties = oldTextProperties }
978998 let newnote = mknode "w:footnote" [("w:id", notenum)] $ contents
979999 modify $ \s -> s{ stFootnotes = newnote : notes }
9801000 return [ mknode "w:r" []
981− [ mknode "w:rPr" [] (rStyle "FootnoteRef")
1001+ [ mknode "w:rPr" [] footnoteStyle
9821002 , mknode "w:footnoteReference" [("w:id", notenum)] () ] ]
9831003-- internal link:
9841004inlineToOpenXML opts (Link txt ('#':xs,_)) = do
985− contents <- withTextProp (rStyle "Link") $ inlinesToOpenXML opts txt
1005+ contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt
9861006 return [ mknode "w:hyperlink" [("w:anchor",xs)] contents ]
9871007-- external link:
9881008inlineToOpenXML opts (Link txt (src,_)) = do
989− contents <- withTextProp (rStyle "Link") $ inlinesToOpenXML opts txt
1009+ contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt
9901010 extlinks <- gets stExternalLinks
9911011 id' <- case M.lookup src extlinks of
9921012 Just i -> return i
@@ -1088,7 +1108,7 @@ defaultFootnotes = [ mknode "w:footnote"
10881108 [ mknode "w:p" [] $
10891109 [ mknode "w:r" [] $
10901110 [ mknode "w:continuationSeparator" [] ()]]]]
1091−
1111+
10921112parseXml :: Archive -> Archive -> String -> IO Element
10931113parseXml refArchive distArchive relpath =
10941114 case ((findEntryByPath relpath refArchive `mplus`