@@ -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
@@ -64,7 +64,7 @@ import Text.Pandoc.MIME (MimeType, getMimeType, getMimeTypeDef,
6464 extensionFromMimeType)
6565import Control.Applicative ((<$>), (<|>), (<*>))
6666import Data.Maybe (fromMaybe, mapMaybe)
67−import Data.Char (isDigit)
67+import Data.Char (toLower)
6868
6969data ListMarker = NoMarker
7070 | BulletMarker
@@ -90,6 +90,9 @@ listMarkerToId (NumberMarker sty delim n) =
9090 OneParen -> '2'
9191 TwoParens -> '3'
9292
93+newtype ParaStyleMap = ParaStyleMap (M.Map String String) deriving Show
94+newtype CharStyleMap = CharStyleMap (M.Map String String) deriving Show
95+
9396data WriterState = WriterState{
9497 stTextProperties :: [Element]
9598 , stParaProperties :: [Element]
@@ -106,7 +109,8 @@ data WriterState = WriterState{
106109 , stChangesAuthor :: String
107110 , stChangesDate :: String
108111 , stPrintWidth :: Integer
109− , stHeadingStyles :: [(Int,String)]
112+ , stParaStyles :: ParaStyleMap
113+ , stCharStyles :: CharStyleMap
110114 , stFirstPara :: Bool
111115 }
112116
@@ -127,7 +131,8 @@ defaultWriterState = WriterState{
127131 , stChangesAuthor = "unknown"
128132 , stChangesDate = "1969-12-31T19:00:00Z"
129133 , stPrintWidth = 1
130− , stHeadingStyles = []
134+ , stParaStyles = ParaStyleMap M.empty
135+ , stCharStyles = CharStyleMap M.empty
131136 , stFirstPara = False
132137 }
133138
@@ -218,29 +223,25 @@ writeDocx opts doc@(Pandoc meta _) = do
218223 let styleNamespaces = map ((,) <$> qName . attrKey <*> attrVal) .
219224 filter ((==Just "xmlns") . qPrefix . attrKey) .
220225 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)
226+ mywURI = lookup "w" styleNamespaces
227+ myName name = QName name mywURI (Just "w")
228+ getAttrStyleId = findAttr (myName "styleId")
229+ getAttrType = findAttr (myName "type")
230+ isParaStyle = (Just "paragraph" ==) . getAttrType
231+ isCharStyle = (Just "character" ==) . getAttrType
232+ getNameVal = findChild (myName "name") >=> findAttr (myName "val") >=> return . map toLower
233+ genStyleItem f e | f e = liftM2 (,) <$> getNameVal <*> getAttrStyleId $ e
234+ | otherwise = Nothing
235+ genStyleMap f = M.fromList $ mapMaybe (genStyleItem f) $ findChildren (myName "style") styledoc
236+ paraStyles = ParaStyleMap $ genStyleMap isParaStyle
237+ charStyles = CharStyleMap $ genStyleMap isCharStyle
238238
239239 ((contents, footnotes), st) <- runStateT (writeOpenXML opts{writerWrapText = False} doc')
240240 defaultWriterState{ stChangesAuthor = fromMaybe "unknown" username
241241 , stChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime
242242 , stPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth)
243− , stHeadingStyles = headingStyles}
243+ , stParaStyles = paraStyles
244+ , stCharStyles = charStyles}
244245 let epochtime = floor $ utcTimeToPOSIXSeconds utctime
245246 let imgs = M.elems $ stImages st
246247
@@ -602,14 +603,14 @@ writeOpenXML opts (Pandoc meta blocks) = do
602603 Just (MetaBlocks [Para xs]) -> xs
603604 Just (MetaInlines xs) -> xs
604605 _ -> []
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 $
606+ title <- withParaPropM (pStyleM "Title") $ blocksToOpenXML opts [Para tit | not (null tit)]
607+ subtitle <- withParaPropM (pStyleM "Subtitle") $ blocksToOpenXML opts [Para subtitle' | not (null subtitle')]
608+ authors <- withParaPropM (pStyleM "Author") $ blocksToOpenXML opts $
608609 map Para auths
609− date <- withParaProp (pStyle "Date") $ blocksToOpenXML opts [Para dat | not (null dat)]
610+ date <- withParaPropM (pStyleM "Date") $ blocksToOpenXML opts [Para dat | not (null dat)]
610611 abstract <- if null abstract'
611612 then return []
612− else withParaProp (pStyle "Abstract") $ blocksToOpenXML opts abstract'
613+ else withParaPropM (pStyleM "Abstract") $ blocksToOpenXML opts abstract'
613614 let convertSpace (Str x : Space : Str y : xs) = Str (x ++ " " ++ y) : xs
614615 convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs
615616 convertSpace xs = xs
@@ -623,11 +624,24 @@ writeOpenXML opts (Pandoc meta blocks) = do
623624blocksToOpenXML :: WriterOptions -> [Block] -> WS [Element]
624625blocksToOpenXML opts bls = concat `fmap` mapM (blockToOpenXML opts) bls
625626
626−pStyle :: String -> Element
627−pStyle sty = mknode "w:pStyle" [("w:val",sty)] ()
627+getStyleId :: String -> M.Map String String -> String
628+getStyleId s = M.findWithDefault (filter (/=' ') s) (map toLower s)
629+
630+pStyle :: String -> ParaStyleMap -> Element
631+pStyle sty (ParaStyleMap m) = mknode "w:pStyle" [("w:val",sty')] ()
632+ where
633+ sty' = getStyleId sty m
634+
635+pStyleM :: String -> WS XML.Element
636+pStyleM = flip fmap (gets stParaStyles) . pStyle
637+
638+rStyle :: String -> CharStyleMap -> Element
639+rStyle sty (CharStyleMap m) = mknode "w:rStyle" [("w:val",sty')] ()
640+ where
641+ sty' = getStyleId sty m
628642
629−rStyle :: String -> Element
630−rStyle sty = mknode "w:rStyle" [("w:val",sty)] ()
643+rStyleM :: String -> WS XML.Element
644+rStyleM = flip fmap (gets stCharStyles) . rStyle
631645
632646getUniqueId :: MonadIO m => m String
633647-- the + 20 is to ensure that there are no clashes with the rIds
@@ -641,13 +655,12 @@ blockToOpenXML opts (Div (_,["references"],_) bs) = do
641655 let (hs, bs') = span isHeaderBlock bs
642656 header <- blocksToOpenXML opts hs
643657 -- We put the Bibliography style on paragraphs after the header
644− rest <- withParaProp (pStyle "Bibliography") $ blocksToOpenXML opts bs'
658+ rest <- withParaPropM (pStyleM "Bibliography") $ blocksToOpenXML opts bs'
645659 return (header ++ rest)
646660blockToOpenXML opts (Div _ bs) = blocksToOpenXML opts bs
647661blockToOpenXML opts (Header lev (ident,_,_) lst) = do
648662 setFirstPara
649− headingStyles <- gets stHeadingStyles
650− paraProps <- maybe id (withParaProp . pStyle) (lookup lev headingStyles) $
663+ paraProps <- withParaPropM (pStyleM ("Heading "++show lev)) $
651664 getParaProps False
652665 contents <- inlinesToOpenXML opts lst
653666 usedIdents <- gets stSectionIds
@@ -660,26 +673,27 @@ blockToOpenXML opts (Header lev (ident,_,_) lst) = do
660673 ,("w:name",bookmarkName)] ()
661674 let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] ()
662675 return [mknode "w:p" [] (paraProps ++ [bookmarkStart, bookmarkEnd] ++ contents)]
663−blockToOpenXML opts (Plain lst) = withParaProp (pStyle "Compact")
676+blockToOpenXML opts (Plain lst) = withParaPropM (pStyleM "Compact")
664677 $ blockToOpenXML opts (Para lst)
665678-- title beginning with fig: indicates that the image is a figure
666679blockToOpenXML opts (Para [Image alt (src,'f':'i':'g':':':tit)]) = do
667680 setFirstPara
668681 paraProps <- getParaProps False
669682 contents <- inlinesToOpenXML opts [Image alt (src,tit)]
670− captionNode <- withParaProp (pStyle "ImageCaption")
683+ captionNode <- withParaPropM (pStyleM "Image Caption")
671684 $ blockToOpenXML opts (Para alt)
672685 return $ mknode "w:p" [] (paraProps ++ contents) : captionNode
673686-- fixDisplayMath sometimes produces a Para [] as artifact
674687blockToOpenXML _ (Para []) = return []
675688blockToOpenXML opts (Para lst) = do
676− isFirstPara <- gets stFirstPara
689+ isFirstPara <- gets stFirstPara
677690 paraProps <- getParaProps $ case lst of
678691 [Math DisplayMath _] -> True
679692 _ -> False
693+ pSM <- gets stParaStyles
680694 let paraProps' = case paraProps of
681− [] | isFirstPara -> [mknode "w:pPr" [] [(pStyle "FirstParagraph")]]
682− [] -> [mknode "w:pPr" [] [(pStyle "BodyText")]]
695+ [] | isFirstPara -> [mknode "w:pPr" [] [(pStyle "First Paragraph" pSM)]]
696+ [] -> [mknode "w:pPr" [] [(pStyle "Body Text" pSM)]]
683697 ps -> ps
684698 modify $ \s -> s { stFirstPara = False }
685699 contents <- inlinesToOpenXML opts lst
@@ -688,11 +702,11 @@ blockToOpenXML _ (RawBlock format str)
688702 | format == Format "openxml" = return [ x | Elem x <- parseXML str ]
689703 | otherwise = return []
690704blockToOpenXML opts (BlockQuote blocks) = do
691− p <- withParaProp (pStyle "BlockQuote") $ blocksToOpenXML opts blocks
705+ p <- withParaPropM (pStyleM "Block Quote") $ blocksToOpenXML opts blocks
692706 setFirstPara
693707 return p
694708blockToOpenXML opts (CodeBlock attrs str) = do
695− p <- withParaProp (pStyle "SourceCode") $ (blockToOpenXML opts $ Para [Code attrs str])
709+ p <- withParaPropM (pStyleM "Source Code") (blockToOpenXML opts $ Para [Code attrs str])
696710 setFirstPara
697711 return p
698712blockToOpenXML _ HorizontalRule = do
@@ -707,7 +721,7 @@ blockToOpenXML opts (Table caption aligns widths headers rows) = do
707721 let captionStr = stringify caption
708722 caption' <- if null caption
709723 then return []
710− else withParaProp (pStyle "TableCaption")
724+ else withParaPropM (pStyleM "Table Caption")
711725 $ blockToOpenXML opts (Para caption)
712726 let alignmentFor al = mknode "w:jc" [("w:val",alignmentToString al)] ()
713727 let cellToOpenXML (al, cell) = withParaProp (alignmentFor al)
@@ -767,9 +781,9 @@ blockToOpenXML opts (DefinitionList items) = do
767781
768782definitionListItemToOpenXML :: WriterOptions -> ([Inline],[[Block]]) -> WS [Element]
769783definitionListItemToOpenXML opts (term,defs) = do
770− term' <- withParaProp (pStyle "DefinitionTerm")
784+ term' <- withParaPropM (pStyleM "Definition Term")
771785 $ blockToOpenXML opts (Para term)
772− defs' <- withParaProp (pStyle "Definition")
786+ defs' <- withParaPropM (pStyleM "Definition")
773787 $ concat `fmap` mapM (blocksToOpenXML opts) defs
774788 return $ term' ++ defs'
775789
@@ -833,6 +847,9 @@ withTextProp d p = do
833847 popTextProp
834848 return res
835849
850+withTextPropM :: WS Element -> WS a -> WS a
851+withTextPropM = (. flip withTextProp) . (>>=)
852+
836853getParaProps :: Bool -> WS [Element]
837854getParaProps displayMathPara = do
838855 props <- gets stParaProperties
@@ -861,6 +878,9 @@ withParaProp d p = do
861878 popParaProp
862879 return res
863880
881+withParaPropM :: WS Element -> WS a -> WS a
882+withParaPropM = (. flip withParaProp) . (>>=)
883+
864884formattedString :: String -> WS [Element]
865885formattedString str = do
866886 props <- getTextProps
@@ -943,25 +963,27 @@ inlineToOpenXML opts (Math mathType str) = do
943963 Right r -> return [r]
944964 Left _ -> inlinesToOpenXML opts (texMathToInlines mathType str)
945965inlineToOpenXML 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 ]
966+inlineToOpenXML opts (Code attrs str) = do
967+ rSM <- gets stCharStyles
968+ let unhighlighted = intercalate [br] `fmap`
969+ (mapM formattedString $ lines str)
970+ formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok)
971+ toHlTok (toktype,tok) = mknode "w:r" []
972+ [ mknode "w:rPr" []
973+ [ rStyle (show toktype) rSM ]
974+ , mknode "w:t" [("xml:space","preserve")] tok ]
975+ withTextProp (rStyle "Verbatim Char" rSM)
976+ $ if writerHighlight opts
977+ then case highlight formatOpenXML attrs str of
978+ Nothing -> unhighlighted
979+ Just h -> return h
980+ else unhighlighted
960981inlineToOpenXML opts (Note bs) = do
961982 notes <- gets stFootnotes
962983 notenum <- getUniqueId
984+ rSM <- gets stCharStyles
963985 let notemarker = mknode "w:r" []
964− [ mknode "w:rPr" [] (rStyle "FootnoteRef")
986+ [ mknode "w:rPr" [] (rStyle "Footnote Ref" rSM)
965987 , mknode "w:footnoteRef" [] () ]
966988 let notemarkerXml = RawInline (Format "openxml") $ ppElement notemarker
967989 let insertNoteRef (Plain ils : xs) = Plain (notemarkerXml : ils) : xs
@@ -971,22 +993,22 @@ inlineToOpenXML opts (Note bs) = do
971993 oldParaProperties <- gets stParaProperties
972994 oldTextProperties <- gets stTextProperties
973995 modify $ \st -> st{ stListLevel = -1, stParaProperties = [], stTextProperties = [] }
974− contents <- withParaProp (pStyle "FootnoteText") $ blocksToOpenXML opts
996+ contents <- withParaPropM (pStyleM "Footnote Text") $ blocksToOpenXML opts
975997 $ insertNoteRef bs
976998 modify $ \st -> st{ stListLevel = oldListLevel, stParaProperties = oldParaProperties,
977999 stTextProperties = oldTextProperties }
9781000 let newnote = mknode "w:footnote" [("w:id", notenum)] $ contents
9791001 modify $ \s -> s{ stFootnotes = newnote : notes }
9801002 return [ mknode "w:r" []
981− [ mknode "w:rPr" [] (rStyle "FootnoteRef")
1003+ [ mknode "w:rPr" [] (rStyle "Footnote Ref" rSM)
9821004 , mknode "w:footnoteReference" [("w:id", notenum)] () ] ]
9831005-- internal link:
9841006inlineToOpenXML opts (Link txt ('#':xs,_)) = do
985− contents <- withTextProp (rStyle "Link") $ inlinesToOpenXML opts txt
1007+ contents <- withTextPropM (rStyleM "Link") $ inlinesToOpenXML opts txt
9861008 return [ mknode "w:hyperlink" [("w:anchor",xs)] contents ]
9871009-- external link:
9881010inlineToOpenXML opts (Link txt (src,_)) = do
989− contents <- withTextProp (rStyle "Link") $ inlinesToOpenXML opts txt
1011+ contents <- withTextPropM (rStyleM "Link") $ inlinesToOpenXML opts txt
9901012 extlinks <- gets stExternalLinks
9911013 id' <- case M.lookup src extlinks of
9921014 Just i -> return i
@@ -1088,7 +1110,7 @@ defaultFootnotes = [ mknode "w:footnote"
10881110 [ mknode "w:p" [] $
10891111 [ mknode "w:r" [] $
10901112 [ mknode "w:continuationSeparator" [] ()]]]]
1091−
1113+
10921114parseXml :: Archive -> Archive -> String -> IO Element
10931115parseXml refArchive distArchive relpath =
10941116 case ((findEntryByPath relpath refArchive `mplus`