96c4b9e · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Docx reader: fix for Issue #1692 (i18n styles)

96c4b9eNikolay Yakimov12 years ago

src/Text/Pandoc/Readers/Docx.hs+6−27

compare with master

unifiedsplit

@@ -84,8 +84,7 @@ import Text.Pandoc.Readers.Docx.Lists

84import Text.Pandoc.Readers.Docx.Reducible

85import Text.Pandoc.Shared

86import Text.Pandoc.MediaBag (insertMedia, MediaBag)

87−import Data.Maybe (isJust)

88−import Data.List (delete, stripPrefix, (\\), intersect, isPrefixOf)

87+import Data.List (delete, (\\), intersect)

89import Data.Monoid

88import Data.Monoid

90import Text.TeXMath (writeTeX)

89import Text.TeXMath (writeTeX)

91import Data.Default (Default)

90import Data.Default (Default)

@@ -197,19 +196,9 @@ fixAuthors mv = mv

197codeStyles :: [String]

196codeStyles :: [String]

198codeStyles = ["VerbatimChar"]

197codeStyles = ["VerbatimChar"]

199

198

200−blockQuoteDivs :: [String]

201−blockQuoteDivs = ["Quote", "BlockQuote", "BlockQuotation"]

202−

203codeDivs :: [String]

199codeDivs :: [String]

204codeDivs = ["SourceCode"]

200codeDivs = ["SourceCode"]

205

201

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−

213runElemToInlines :: RunElem -> Inlines

202runElemToInlines :: RunElem -> Inlines

214runElemToInlines (TextRun s) = text s

203runElemToInlines (TextRun s) = text s

215runElemToInlines (LnBrk) = linebreak

204runElemToInlines (LnBrk) = linebreak

@@ -434,9 +423,9 @@ parStyleToTransform pPr

434 let pPr' = pPr { pStyle = cs, indentation = Nothing}

423 let pPr' = pPr { pStyle = cs, indentation = Nothing}

435 in

424 in

436 (divWith ("", [c], [])) . (parStyleToTransform pPr')

425 (divWith ("", [c], [])) . (parStyleToTransform pPr')

437− | (c:cs) <- pStyle pPr

426+ | (_:cs) <- pStyle pPr

438− , c `elem` blockQuoteDivs =

427+ , Just True <- pBlockQuote pPr =

439− let pPr' = pPr { pStyle = cs \\ blockQuoteDivs }

428+ let pPr' = pPr { pStyle = cs }

440 in

429 in

441 blockQuote . (parStyleToTransform pPr')

430 blockQuote . (parStyleToTransform pPr')

442 | (_:cs) <- pStyle pPr =

431 | (_:cs) <- pStyle pPr =

@@ -467,12 +456,11 @@ bodyPartToBlocks (Paragraph pPr parparts)

467 $ parStyleToTransform pPr

456 $ parStyleToTransform pPr

468 $ codeBlock

457 $ codeBlock

469 $ concatMap parPartToString parparts

458 $ concatMap parPartToString parparts

470− | (c : cs) <- filter (isJust . isHeaderClass) $ pStyle pPr

459+ | Just (style, n) <- pHeading pPr = do

471− , Just (prefix, n) <- isHeaderClass c = do

472 ils <- local (\s-> s{docxInHeaderBlock=True}) $

460 ils <- local (\s-> s{docxInHeaderBlock=True}) $

473 (concatReduce <$> mapM parPartToInlines parparts)

461 (concatReduce <$> mapM parPartToInlines parparts)

474 makeHeaderAnchor $

462 makeHeaderAnchor $

475− headerWith ("", delete (prefix ++ show n) cs, []) n ils

463+ headerWith ("", delete style (pStyle pPr), []) n ils

476 | otherwise = do

464 | otherwise = do

477 ils <- concatReduce <$> mapM parPartToInlines parparts >>=

465 ils <- concatReduce <$> mapM parPartToInlines parparts >>=

478 (return . fromList . trimLineBreaks . normalizeSpaces . toList)

466 (return . fromList . trimLineBreaks . normalizeSpaces . toList)

@@ -559,12 +547,3 @@ docxToOutput :: ReaderOptions -> Docx -> (Meta, [Block], MediaBag)

559docxToOutput opts (Docx (Document _ body)) =

547docxToOutput opts (Docx (Document _ body)) =

560 let dEnv = def { docxOptions = opts} in

548 let dEnv = def { docxOptions = opts} in

561 evalDocxContext (bodyToOutput body) dEnv def

549 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 #-}

3{-

@@ -65,7 +65,7 @@ import Text.Pandoc.Compat.Except

65import Text.TeXMath.Readers.OMML (readOMML)

66import Text.Pandoc.Readers.Docx.Fonts (getUnicode, Font(..))

67import Text.TeXMath (Exp)

68−import Data.Char (readLitChar, ord, chr)

68+import Data.Char (readLitChar, ord, chr, isDigit)

70data ReaderEnv = ReaderEnv { envNotes :: Notes

71 , envNumbering :: Numbering

@@ -73,6 +73,7 @@ data ReaderEnv = ReaderEnv { envNotes :: Notes

73 , envMedia :: Media

74 , envFont :: Maybe Font

75 , envCharStyles :: CharStyleMap

76+ , envParStyles :: ParStyleMap

76 }

77 }

77 deriving Show

78 deriving Show

@@ -122,8 +123,12 @@ type Media = [(FilePath, B.ByteString)]

122

123

123type CharStyle = (String, RunStyle)

124type CharStyle = (String, RunStyle)

124

125

126+type ParStyle = (String, ParStyleData)

127+

125type CharStyleMap = M.Map String RunStyle

128type CharStyleMap = M.Map String RunStyle

126

129

130+type ParStyleMap = M.Map String ParStyleData

131+

127data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]

132data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]

128 deriving Show

133 deriving Show

129

134

@@ -152,6 +157,8 @@ data ParIndentation = ParIndentation { leftParIndent :: Maybe Integer

152data ParagraphStyle = ParagraphStyle { pStyle :: [String]

157data ParagraphStyle = ParagraphStyle { pStyle :: [String]

153 , indentation :: Maybe ParIndentation

158 , indentation :: Maybe ParIndentation

154 , dropCap :: Bool

159 , dropCap :: Bool

160+ , pHeading :: Maybe (String, Int)

161+ , pBlockQuote :: Maybe Bool

155 }

162 }

156 deriving Show

163 deriving Show

157

164

@@ -159,6 +166,8 @@ defaultParagraphStyle :: ParagraphStyle

159defaultParagraphStyle = ParagraphStyle { pStyle = []

166defaultParagraphStyle = ParagraphStyle { pStyle = []

160 , indentation = Nothing

167 , indentation = Nothing

161 , dropCap = False

168 , dropCap = False

169+ , pHeading = Nothing

170+ , pBlockQuote = Nothing

162 }

171 }

163

172

164

173

@@ -213,6 +222,11 @@ data RunStyle = RunStyle { isBold :: Maybe Bool

213 , rStyle :: Maybe CharStyle}

222 , rStyle :: Maybe CharStyle}

214 deriving Show

223 deriving Show

215

224

225+data ParStyleData = ParStyleData { headingLev :: Maybe (String, Int)

226+ , isBlockQuote :: Maybe Bool

227+ , psStyle :: Maybe ParStyle}

228+ deriving Show

229+

216defaultRunStyle :: RunStyle

230defaultRunStyle :: RunStyle

217defaultRunStyle = RunStyle { isBold = Nothing

231defaultRunStyle = RunStyle { isBold = Nothing

218 , isItalic = Nothing

232 , isItalic = Nothing

@@ -242,8 +256,8 @@ archiveToDocx archive = do

242 numbering = archiveToNumbering archive

256 numbering = archiveToNumbering archive

243 rels = archiveToRelationships archive

257 rels = archiveToRelationships archive

244 media = archiveToMedia archive

258 media = archiveToMedia archive

245− styles = archiveToStyles archive

259+ (styles, parstyles) = archiveToStyles archive

246− rEnv = ReaderEnv notes numbering rels media Nothing styles

260+ rEnv = ReaderEnv notes numbering rels media Nothing styles parstyles

247 doc <- runD (archiveToDocument archive) rEnv

261 doc <- runD (archiveToDocument archive) rEnv

248 return $ Docx doc

262 return $ Docx doc

249

263

@@ -263,47 +277,69 @@ elemToBody ns element | isElem ns "w" "body" element =

263 (\bps -> return $ Body bps)

277 (\bps -> return $ Body bps)

264elemToBody _ _ = throwError WrongElem

278elemToBody _ _ = throwError WrongElem

265

279

266−archiveToStyles :: Archive -> CharStyleMap

280+archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)

267archiveToStyles zf =

281archiveToStyles zf =

268 let stylesElem = findEntryByPath "word/styles.xml" zf >>=

282 let stylesElem = findEntryByPath "word/styles.xml" zf >>=

269 (parseXMLDoc . UTF8.toStringLazy . fromEntry)

283 (parseXMLDoc . UTF8.toStringLazy . fromEntry)

270 in

284 in

271 case stylesElem of

285 case stylesElem of

272− Nothing -> M.empty

286+ Nothing -> (M.empty, M.empty)

273 Just styElem ->

287 Just styElem ->

274 let namespaces = mapMaybe attrToNSPair (elAttribs styElem)

288 let namespaces = mapMaybe attrToNSPair (elAttribs styElem)

275 in

289 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) )

277

294

278−isBasedOnStyle :: NameSpaces -> Element -> Maybe CharStyle -> Bool

295+isBasedOnStyle :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> Bool

279isBasedOnStyle ns element parentStyle

296isBasedOnStyle ns element parentStyle

280 | isElem ns "w" "style" element

297 | 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

282 , Just basedOnVal <- findChild (elemName ns "w" "basedOn") element >>=

300 , Just basedOnVal <- findChild (elemName ns "w" "basedOn") element >>=

283 findAttr (elemName ns "w" "val")

301 findAttr (elemName ns "w" "val")

284− , Just (parentId, _) <- parentStyle = (basedOnVal == parentId)

302+ , Just ps <- parentStyle = (basedOnVal == getStyleId ps)

285 | isElem ns "w" "style" element

303 | 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

287 , Nothing <- findChild (elemName ns "w" "basedOn") element

306 , Nothing <- findChild (elemName ns "w" "basedOn") element

288 , Nothing <- parentStyle = True

307 , Nothing <- parentStyle = True

289 | otherwise = False

308 | otherwise = False

290

309

310+class ElemToStyle a where

311+ cStyleType :: Maybe a -> String

291−elemToCharStyle :: NameSpaces -> Element -> Maybe CharStyle -> Maybe CharStyle

312+ elemToStyle :: NameSpaces -> Element -> Maybe a -> Maybe a

313+ getStyleId :: a -> String

314+

315+instance ElemToStyle CharStyle where

316+ cStyleType _ = "character"

292−elemToCharStyle ns element parentStyle

317+ elemToStyle ns element parentStyle

293− | isElem ns "w" "style" element

318+ | isElem ns "w" "style" element

294− , Just "character" <- findAttr (elemName ns "w" "type") element

319+ , Just "character" <- findAttr (elemName ns "w" "type") element

295− , Just styleId <- findAttr (elemName ns "w" "styleId") element =

320+ , Just styleId <- findAttr (elemName ns "w" "styleId") element =

296− Just (styleId, elemToRunStyle ns element parentStyle)

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)

297− | otherwise = Nothing

332+ | otherwise = Nothing

298−

333+ getStyleId s = fst s

334+

299−getStyleChildren :: NameSpaces -> Element -> Maybe CharStyle -> [CharStyle]

335+getStyleChildren :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a]

300getStyleChildren ns element parentStyle

336getStyleChildren ns element parentStyle

301 | isElem ns "w" "styles" element =

337 | isElem ns "w" "styles" element =

302− mapMaybe (\e -> elemToCharStyle ns e parentStyle) $

338+ mapMaybe (\e -> elemToStyle ns e parentStyle) $

303 filterChildren (\e' -> isBasedOnStyle ns e' parentStyle) element

339 filterChildren (\e' -> isBasedOnStyle ns e' parentStyle) element

304 | otherwise = []

340 | otherwise = []

305

341

306−buildBasedOnList :: NameSpaces -> Element -> Maybe CharStyle -> [CharStyle]

342+buildBasedOnList :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a]

307buildBasedOnList ns element rootStyle =

343buildBasedOnList ns element rootStyle =

308 case (getStyleChildren ns element rootStyle) of

344 case (getStyleChildren ns element rootStyle) of

309 [] -> []

345 [] -> []

@@ -543,7 +579,8 @@ elemToBodyPart ns element

543elemToBodyPart ns element

579elemToBodyPart ns element

544 | isElem ns "w" "p" element

580 | isElem ns "w" "p" element

545 , Just (numId, lvl) <- elemToNumInfo ns element = do

581 , Just (numId, lvl) <- elemToNumInfo ns element = do

582+ sty <- asks envParStyles

546− let parstyle = elemToParagraphStyle ns element

583+ let parstyle = elemToParagraphStyle ns element sty

547 parparts <- mapD (elemToParPart ns) (elChildren element)

584 parparts <- mapD (elemToParPart ns) (elChildren element)

548 num <- asks envNumbering

585 num <- asks envNumbering

549 case lookupLevel numId lvl num of

586 case lookupLevel numId lvl num of

@@ -551,7 +588,8 @@ elemToBodyPart ns element

551 Nothing -> throwError WrongElem

588 Nothing -> throwError WrongElem

552elemToBodyPart ns element

589elemToBodyPart ns element

553 | isElem ns "w" "p" element = do

590 | isElem ns "w" "p" element = do

591+ sty <- asks envParStyles

554− let parstyle = elemToParagraphStyle ns element

592+ let parstyle = elemToParagraphStyle ns element sty

555 parparts <- mapD (elemToParPart ns) (elChildren element)

593 parparts <- mapD (elemToParPart ns) (elChildren element)

556 return $ Paragraph parstyle parparts

594 return $ Paragraph parstyle parparts

557elemToBodyPart ns element

595elemToBodyPart ns element

@@ -684,14 +722,30 @@ elemToRun ns element

684 return $ Run runStyle runElems

722 return $ Run runStyle runElems

685elemToRun _ _ = throwError WrongElem

723elemToRun _ _ = throwError WrongElem

686

724

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+

687−elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle

740+elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> ParagraphStyle

688−elemToParagraphStyle ns element

741+elemToParagraphStyle ns element sty

689 | Just pPr <- findChild (elemName ns "w" "pPr") element =

742 | Just pPr <- findChild (elemName ns "w" "pPr") element =

690− ParagraphStyle

743+ let style =

691− {pStyle =

692 mapMaybe

744 mapMaybe

693 (findAttr (elemName ns "w" "val"))

745 (findAttr (elemName ns "w" "val"))

694 (findChildren (elemName ns "w" "pStyle") pPr)

746 (findChildren (elemName ns "w" "pStyle") pPr)

747+ in ParagraphStyle

748+ {pStyle = style

695 , indentation =

749 , indentation =

696 findChild (elemName ns "w" "ind") pPr >>=

750 findChild (elemName ns "w" "ind") pPr >>=

697 elemToParIndentation ns

751 elemToParIndentation ns

@@ -703,8 +757,10 @@ elemToParagraphStyle ns element

703 Just "none" -> False

757 Just "none" -> False

704 Just _ -> True

758 Just _ -> True

705 Nothing -> False

759 Nothing -> False

760+ , pHeading = getParStyleField headingLev sty style

761+ , pBlockQuote = getParStyleField isBlockQuote sty style

706 }

762 }

707−elemToParagraphStyle _ _ = defaultParagraphStyle

763+elemToParagraphStyle _ _ _ = defaultParagraphStyle

708

764

709checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool

765checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool

710checkOnOff ns rPr tag

766checkOnOff ns rPr tag

@@ -758,6 +814,45 @@ elemToRunStyle ns element parentStyle

758 }

814 }

759elemToRunStyle _ _ _ = defaultRunStyle

815elemToRunStyle _ _ _ = defaultRunStyle

760

816

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+

761elemToRunElem :: NameSpaces -> Element -> D RunElem

856elemToRunElem :: NameSpaces -> Element -> D RunElem

762elemToRunElem ns element

857elemToRunElem ns element

763 | isElem ns "w" "t" element

858 | isElem ns "w" "t" element