git.iko.soy/typeable/pandoc
on master help sign in
Docx reader: fix for Issue #1692 (i18n styles)

This patch builds paragraph styles tree, then checks if paragraph has style.styleId or style/name.val matching predetermined patterns. Works with "Heading#" (name.val="heading #") for headings and "Quote"|"BlockQuote"|"BlockQuotation" (name.val="Quote"|"Block Text") for block quotes.

commit96c4b9e2e68295930b87e35cbff554623faea5a3 authorNikolay Yakimov <root@livid.pp.ru> dateSat 25 Oct 2014, 20:30 (12 years ago) parente16683b
2 files changed+130−56
compare with master
unifiedsplit
src/Text/Pandoc/Readers/Docx.hs+6−27 src/Text/Pandoc/Readers/Docx/Parse.hs+124−29
src/Text/Pandoc/Readers/Docx.hs+6−27
@@ -84,8 +84,7 @@ import Text.Pandoc.Readers.Docx.Lists
8484import Text.Pandoc.Readers.Docx.Reducible
8585import Text.Pandoc.Shared
8686import Text.Pandoc.MediaBag (insertMedia, MediaBag)
87−import Data.Maybe (isJust)
88−import Data.List (delete, stripPrefix, (\\), intersect, isPrefixOf)
87+import Data.List (delete, (\\), intersect)
8988import Data.Monoid
9089import Text.TeXMath (writeTeX)
9190import Data.Default (Default)
@@ -197,19 +196,9 @@ fixAuthors mv = mv
197196codeStyles :: [String]
198197codeStyles = ["VerbatimChar"]
199198
200−blockQuoteDivs :: [String]
201−blockQuoteDivs = ["Quote", "BlockQuote", "BlockQuotation"]
202−
203199codeDivs :: [String]
204200codeDivs = ["SourceCode"]
205201
206−
207−-- For the moment, we have English, Danish, German, and French. This
208−-- is fairly ad-hoc, and there might be a more systematic way to do
209−-- it, but it's better than nothing.
210−headerPrefixes :: [String]
211−headerPrefixes = ["Heading", "Overskrift", "berschrift", "Titre"]
212−
213202runElemToInlines :: RunElem -> Inlines
214203runElemToInlines (TextRun s) = text s
215204runElemToInlines (LnBrk) = linebreak
@@ -434,9 +423,9 @@ parStyleToTransform pPr
434423 let pPr' = pPr { pStyle = cs, indentation = Nothing}
435424 in
436425 (divWith ("", [c], [])) . (parStyleToTransform pPr')
437− | (c:cs) <- pStyle pPr
438− , c `elem` blockQuoteDivs =
439− let pPr' = pPr { pStyle = cs \\ blockQuoteDivs }
426+ | (_:cs) <- pStyle pPr
427+ , Just True <- pBlockQuote pPr =
428+ let pPr' = pPr { pStyle = cs }
440429 in
441430 blockQuote . (parStyleToTransform pPr')
442431 | (_:cs) <- pStyle pPr =
@@ -467,12 +456,11 @@ bodyPartToBlocks (Paragraph pPr parparts)
467456 $ parStyleToTransform pPr
468457 $ codeBlock
469458 $ concatMap parPartToString parparts
470− | (c : cs) <- filter (isJust . isHeaderClass) $ pStyle pPr
471− , Just (prefix, n) <- isHeaderClass c = do
459+ | Just (style, n) <- pHeading pPr = do
472460 ils <- local (\s-> s{docxInHeaderBlock=True}) $
473461 (concatReduce <$> mapM parPartToInlines parparts)
474462 makeHeaderAnchor $
475− headerWith ("", delete (prefix ++ show n) cs, []) n ils
463+ headerWith ("", delete style (pStyle pPr), []) n ils
476464 | otherwise = do
477465 ils <- concatReduce <$> mapM parPartToInlines parparts >>=
478466 (return . fromList . trimLineBreaks . normalizeSpaces . toList)
@@ -559,12 +547,3 @@ docxToOutput :: ReaderOptions -> Docx -> (Meta, [Block], MediaBag)
559547docxToOutput opts (Docx (Document _ body)) =
560548 let dEnv = def { docxOptions = opts} in
561549 evalDocxContext (bodyToOutput body) dEnv def
562−
563−isHeaderClass :: String -> Maybe (String, Int)
564−isHeaderClass s | (pref:_) <- filter (\h -> isPrefixOf h s) headerPrefixes
565− , Just s' <- stripPrefix pref s =
566− case reads s' :: [(Int, String)] of
567− [] -> Nothing
568− ((n, "") : []) -> Just (pref, n)
569− _ -> Nothing
570−isHeaderClass _ = Nothing
src/Text/Pandoc/Readers/Docx/Parse.hs+124−29
@@ -1,4 +1,4 @@
1−{-# LANGUAGE PatternGuards, ViewPatterns #-}
1+{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleInstances #-}
22
33{-
44Copyright (C) 2014 Jesse Rosenthal <jrosenthal@jhu.edu>
@@ -65,7 +65,7 @@ import Text.Pandoc.Compat.Except
6565import Text.TeXMath.Readers.OMML (readOMML)
6666import Text.Pandoc.Readers.Docx.Fonts (getUnicode, Font(..))
6767import Text.TeXMath (Exp)
68−import Data.Char (readLitChar, ord, chr)
68+import Data.Char (readLitChar, ord, chr, isDigit)
6969
7070data ReaderEnv = ReaderEnv { envNotes :: Notes
7171 , envNumbering :: Numbering
@@ -73,6 +73,7 @@ data ReaderEnv = ReaderEnv { envNotes :: Notes
7373 , envMedia :: Media
7474 , envFont :: Maybe Font
7575 , envCharStyles :: CharStyleMap
76+ , envParStyles :: ParStyleMap
7677 }
7778 deriving Show
7879
@@ -122,8 +123,12 @@ type Media = [(FilePath, B.ByteString)]
122123
123124type CharStyle = (String, RunStyle)
124125
126+type ParStyle = (String, ParStyleData)
127+
125128type CharStyleMap = M.Map String RunStyle
126129
130+type ParStyleMap = M.Map String ParStyleData
131+
127132data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
128133 deriving Show
129134
@@ -152,6 +157,8 @@ data ParIndentation = ParIndentation { leftParIndent :: Maybe Integer
152157data ParagraphStyle = ParagraphStyle { pStyle :: [String]
153158 , indentation :: Maybe ParIndentation
154159 , dropCap :: Bool
160+ , pHeading :: Maybe (String, Int)
161+ , pBlockQuote :: Maybe Bool
155162 }
156163 deriving Show
157164
@@ -159,6 +166,8 @@ defaultParagraphStyle :: ParagraphStyle
159166defaultParagraphStyle = ParagraphStyle { pStyle = []
160167 , indentation = Nothing
161168 , dropCap = False
169+ , pHeading = Nothing
170+ , pBlockQuote = Nothing
162171 }
163172
164173
@@ -213,6 +222,11 @@ data RunStyle = RunStyle { isBold :: Maybe Bool
213222 , rStyle :: Maybe CharStyle}
214223 deriving Show
215224
225+data ParStyleData = ParStyleData { headingLev :: Maybe (String, Int)
226+ , isBlockQuote :: Maybe Bool
227+ , psStyle :: Maybe ParStyle}
228+ deriving Show
229+
216230defaultRunStyle :: RunStyle
217231defaultRunStyle = RunStyle { isBold = Nothing
218232 , isItalic = Nothing
@@ -242,8 +256,8 @@ archiveToDocx archive = do
242256 numbering = archiveToNumbering archive
243257 rels = archiveToRelationships archive
244258 media = archiveToMedia archive
245− styles = archiveToStyles archive
246− rEnv = ReaderEnv notes numbering rels media Nothing styles
259+ (styles, parstyles) = archiveToStyles archive
260+ rEnv = ReaderEnv notes numbering rels media Nothing styles parstyles
247261 doc <- runD (archiveToDocument archive) rEnv
248262 return $ Docx doc
249263
@@ -263,47 +277,69 @@ elemToBody ns element | isElem ns "w" "body" element =
263277 (\bps -> return $ Body bps)
264278elemToBody _ _ = throwError WrongElem
265279
266−archiveToStyles :: Archive -> CharStyleMap
280+archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)
267281archiveToStyles zf =
268282 let stylesElem = findEntryByPath "word/styles.xml" zf >>=
269283 (parseXMLDoc . UTF8.toStringLazy . fromEntry)
270284 in
271285 case stylesElem of
272− Nothing -> M.empty
286+ Nothing -> (M.empty, M.empty)
273287 Just styElem ->
274288 let namespaces = mapMaybe attrToNSPair (elAttribs styElem)
275289 in
276− M.fromList $ buildBasedOnList namespaces styElem Nothing
290+ ( M.fromList $ buildBasedOnList namespaces styElem
291+ (Nothing :: Maybe CharStyle),
292+ M.fromList $ buildBasedOnList namespaces styElem
293+ (Nothing :: Maybe ParStyle) )
277294
278−isBasedOnStyle :: NameSpaces -> Element -> Maybe CharStyle -> Bool
295+isBasedOnStyle :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> Bool
279296isBasedOnStyle ns element parentStyle
280297 | isElem ns "w" "style" element
281− , Just "character" <- findAttr (elemName ns "w" "type") element
298+ , Just styleType <- findAttr (elemName ns "w" "type") element
299+ , styleType == cStyleType parentStyle
282300 , Just basedOnVal <- findChild (elemName ns "w" "basedOn") element >>=
283301 findAttr (elemName ns "w" "val")
284− , Just (parentId, _) <- parentStyle = (basedOnVal == parentId)
302+ , Just ps <- parentStyle = (basedOnVal == getStyleId ps)
285303 | isElem ns "w" "style" element
286− , Just "character" <- findAttr (elemName ns "w" "type") element
304+ , Just styleType <- findAttr (elemName ns "w" "type") element
305+ , styleType == cStyleType parentStyle
287306 , Nothing <- findChild (elemName ns "w" "basedOn") element
288307 , Nothing <- parentStyle = True
289308 | otherwise = False
290309
291−elemToCharStyle :: NameSpaces -> Element -> Maybe CharStyle -> Maybe CharStyle
292−elemToCharStyle ns element parentStyle
293− | isElem ns "w" "style" element
294− , Just "character" <- findAttr (elemName ns "w" "type") element
295− , Just styleId <- findAttr (elemName ns "w" "styleId") element =
296− Just (styleId, elemToRunStyle ns element parentStyle)
297− | otherwise = Nothing
298−
299−getStyleChildren :: NameSpaces -> Element -> Maybe CharStyle -> [CharStyle]
310+class ElemToStyle a where
311+ cStyleType :: Maybe a -> String
312+ elemToStyle :: NameSpaces -> Element -> Maybe a -> Maybe a
313+ getStyleId :: a -> String
314+
315+instance ElemToStyle CharStyle where
316+ cStyleType _ = "character"
317+ elemToStyle ns element parentStyle
318+ | isElem ns "w" "style" element
319+ , Just "character" <- findAttr (elemName ns "w" "type") element
320+ , Just styleId <- findAttr (elemName ns "w" "styleId") element =
321+ Just (styleId, elemToRunStyle ns element parentStyle)
322+ | otherwise = Nothing
323+ getStyleId s = fst s
324+
325+instance ElemToStyle ParStyle where
326+ cStyleType _ = "paragraph"
327+ elemToStyle ns element parentStyle
328+ | isElem ns "w" "style" element
329+ , Just "paragraph" <- findAttr (elemName ns "w" "type") element
330+ , Just styleId <- findAttr (elemName ns "w" "styleId") element =
331+ Just (styleId, elemToParStyleData ns element parentStyle)
332+ | otherwise = Nothing
333+ getStyleId s = fst s
334+
335+getStyleChildren :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a]
300336getStyleChildren ns element parentStyle
301337 | isElem ns "w" "styles" element =
302− mapMaybe (\e -> elemToCharStyle ns e parentStyle) $
338+ mapMaybe (\e -> elemToStyle ns e parentStyle) $
303339 filterChildren (\e' -> isBasedOnStyle ns e' parentStyle) element
304340 | otherwise = []
305341
306−buildBasedOnList :: NameSpaces -> Element -> Maybe CharStyle -> [CharStyle]
342+buildBasedOnList :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a]
307343buildBasedOnList ns element rootStyle =
308344 case (getStyleChildren ns element rootStyle) of
309345 [] -> []
@@ -543,7 +579,8 @@ elemToBodyPart ns element
543579elemToBodyPart ns element
544580 | isElem ns "w" "p" element
545581 , Just (numId, lvl) <- elemToNumInfo ns element = do
546− let parstyle = elemToParagraphStyle ns element
582+ sty <- asks envParStyles
583+ let parstyle = elemToParagraphStyle ns element sty
547584 parparts <- mapD (elemToParPart ns) (elChildren element)
548585 num <- asks envNumbering
549586 case lookupLevel numId lvl num of
@@ -551,7 +588,8 @@ elemToBodyPart ns element
551588 Nothing -> throwError WrongElem
552589elemToBodyPart ns element
553590 | isElem ns "w" "p" element = do
554− let parstyle = elemToParagraphStyle ns element
591+ sty <- asks envParStyles
592+ let parstyle = elemToParagraphStyle ns element sty
555593 parparts <- mapD (elemToParPart ns) (elChildren element)
556594 return $ Paragraph parstyle parparts
557595elemToBodyPart ns element
@@ -684,14 +722,30 @@ elemToRun ns element
684722 return $ Run runStyle runElems
685723elemToRun _ _ = throwError WrongElem
686724
687−elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
688−elemToParagraphStyle ns element
725+getParentStyleValue :: (ParStyleData -> Maybe a) -> ParStyleData -> Maybe a
726+getParentStyleValue field style
727+ | Just value <- field style = Just value
728+ | Just parentStyle <- psStyle style
729+ = getParentStyleValue field (snd parentStyle)
730+getParentStyleValue _ _ = Nothing
731+
732+getParStyleField :: (ParStyleData -> Maybe a) -> ParStyleMap -> [String] ->
733+ Maybe a
734+getParStyleField field stylemap styles
735+ | x <- mapMaybe (\x -> M.lookup x stylemap) styles
736+ , (y:_) <- mapMaybe (getParentStyleValue field) x
737+ = Just y
738+getParStyleField _ _ _ = Nothing
739+
740+elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> ParagraphStyle
741+elemToParagraphStyle ns element sty
689742 | Just pPr <- findChild (elemName ns "w" "pPr") element =
690− ParagraphStyle
691− {pStyle =
743+ let style =
692744 mapMaybe
693745 (findAttr (elemName ns "w" "val"))
694746 (findChildren (elemName ns "w" "pStyle") pPr)
747+ in ParagraphStyle
748+ {pStyle = style
695749 , indentation =
696750 findChild (elemName ns "w" "ind") pPr >>=
697751 elemToParIndentation ns
@@ -703,8 +757,10 @@ elemToParagraphStyle ns element
703757 Just "none" -> False
704758 Just _ -> True
705759 Nothing -> False
760+ , pHeading = getParStyleField headingLev sty style
761+ , pBlockQuote = getParStyleField isBlockQuote sty style
706762 }
707−elemToParagraphStyle _ _ = defaultParagraphStyle
763+elemToParagraphStyle _ _ _ = defaultParagraphStyle
708764
709765checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool
710766checkOnOff ns rPr tag
@@ -758,6 +814,45 @@ elemToRunStyle ns element parentStyle
758814 }
759815elemToRunStyle _ _ _ = defaultRunStyle
760816
817+isNumericNotNull :: String -> Bool
818+isNumericNotNull str = (str /= []) && (all isDigit str)
819+
820+getHeaderLevel :: NameSpaces -> Element -> Maybe (String,Int)
821+getHeaderLevel ns element
822+ | Just styleId <- findAttr (elemName ns "w" "styleId") element
823+ , Just index <- stripPrefix "Heading" styleId
824+ , isNumericNotNull index = Just (styleId, read index)
825+ | Just styleId <- findAttr (elemName ns "w" "styleId") element
826+ , Just index <- findChild (elemName ns "w" "name") element >>=
827+ findAttr (elemName ns "w" "val") >>=
828+ stripPrefix "heading "
829+ , isNumericNotNull index = Just (styleId, read index)
830+getHeaderLevel _ _ = Nothing
831+
832+blockQuoteStyleIds :: [String]
833+blockQuoteStyleIds = ["Quote", "BlockQuote", "BlockQuotation"]
834+
835+blockQuoteStyleNames :: [String]
836+blockQuoteStyleNames = ["Quote", "Block Text"]
837+
838+getBlockQuote :: NameSpaces -> Element -> Maybe Bool
839+getBlockQuote ns element
840+ | Just styleId <- findAttr (elemName ns "w" "styleId") element
841+ , styleId `elem` blockQuoteStyleIds = Just True
842+ | Just styleName <- findChild (elemName ns "w" "name") element >>=
843+ findAttr (elemName ns "w" "val")
844+ , styleName `elem` blockQuoteStyleNames = Just True
845+getBlockQuote _ _ = Nothing
846+
847+elemToParStyleData :: NameSpaces -> Element -> Maybe ParStyle -> ParStyleData
848+elemToParStyleData ns element parentStyle =
849+ ParStyleData
850+ {
851+ headingLev = getHeaderLevel ns element
852+ , isBlockQuote = getBlockQuote ns element
853+ , psStyle = parentStyle
854+ }
855+
761856elemToRunElem :: NameSpaces -> Element -> D RunElem
762857elemToRunElem ns element
763858 | isElem ns "w" "t" element