c113ca6 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

[Docx Reader] Use style names, not ids, for assigning semantic meaning

c113ca6Nikolay Yakimov7 years ago

src/Text/Pandoc/Readers/Docx.hs+84−78

compare with master

unifiedsplit

@@ -3,6 +3,7 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE MultiWayIf #-}

6+{-# LANGUAGE FlexibleContexts #-}

6{- |

7{- |

7 Module : Text.Pandoc.Readers.Docx

8 Module : Text.Pandoc.Readers.Docx

@@ -65,6 +66,7 @@ import Control.Monad.State.Strict

65import qualified Data.ByteString.Lazy as B

66import qualified Data.ByteString.Lazy as B

66import Data.Default (Default)

67import Data.Default (Default)

67import Data.List (delete, intersect)

68import Data.List (delete, intersect)

69+import Data.Char (isSpace)

68import qualified Data.Map as M

70import qualified Data.Map as M

69import Data.Maybe (isJust, fromMaybe)

71import Data.Maybe (isJust, fromMaybe)

70import Data.Sequence (ViewL (..), viewl)

72import Data.Sequence (ViewL (..), viewl)

@@ -133,13 +135,13 @@ evalDocxContext :: PandocMonad m => DocxContext m a -> DEnv -> DState -> m a

133evalDocxContext ctx env st = flip evalStateT st $ runReaderT ctx env

135evalDocxContext ctx env st = flip evalStateT st $ runReaderT ctx env

134

136

135-- This is empty, but we put it in for future-proofing.

137-- This is empty, but we put it in for future-proofing.

136−spansToKeep :: [String]

138+spansToKeep :: [CharStyleName]

137spansToKeep = []

139spansToKeep = []

138

140

139−divsToKeep :: [String]

141+divsToKeep :: [ParaStyleName]

140−divsToKeep = ["list-item", "Definition", "DefinitionTerm"]

142+divsToKeep = ["Definition", "Definition Term"]

141

143

142−metaStyles :: M.Map String String

144+metaStyles :: M.Map ParaStyleName String

143metaStyles = M.fromList [ ("Title", "title")

145metaStyles = M.fromList [ ("Title", "title")

144 , ("Subtitle", "subtitle")

146 , ("Subtitle", "subtitle")

145 , ("Author", "author")

147 , ("Author", "author")

@@ -151,7 +153,7 @@ sepBodyParts = span (\bp -> isMetaPar bp || isEmptyPar bp)

151

153

152isMetaPar :: BodyPart -> Bool

154isMetaPar :: BodyPart -> Bool

153isMetaPar (Paragraph pPr _) =

155isMetaPar (Paragraph pPr _) =

154− not $ null $ intersect (pStyle pPr) (M.keys metaStyles)

156+ not $ null $ intersect (getStyleNames $ pStyle pPr) (M.keys metaStyles)

155isMetaPar _ = False

157isMetaPar _ = False

156

158

157isEmptyPar :: BodyPart -> Bool

159isEmptyPar :: BodyPart -> Bool

@@ -168,7 +170,7 @@ bodyPartsToMeta' :: PandocMonad m => [BodyPart] -> DocxContext m (M.Map String M

168bodyPartsToMeta' [] = return M.empty

170bodyPartsToMeta' [] = return M.empty

169bodyPartsToMeta' (bp : bps)

171bodyPartsToMeta' (bp : bps)

170 | (Paragraph pPr parParts) <- bp

172 | (Paragraph pPr parParts) <- bp

171− , (c : _)<- (pStyle pPr) `intersect` (M.keys metaStyles)

173+ , (c : _)<- getStyleNames (pStyle pPr) `intersect` M.keys metaStyles

172 , (Just metaField) <- M.lookup c metaStyles = do

174 , (Just metaField) <- M.lookup c metaStyles = do

173 inlines <- smushInlines <$> mapM parPartToInlines parParts

175 inlines <- smushInlines <$> mapM parPartToInlines parParts

174 remaining <- bodyPartsToMeta' bps

176 remaining <- bodyPartsToMeta' bps

@@ -198,11 +200,29 @@ fixAuthors (MetaBlocks blks) =

198 g _ = MetaInlines []

200 g _ = MetaInlines []

199fixAuthors mv = mv

201fixAuthors mv = mv

200

202

201−codeStyles :: [String]

203+isInheritedFromStyles :: (Eq (StyleName s), HasStyleName s, HasParentStyle s) => [StyleName s] -> s -> Bool

202−codeStyles = ["VerbatimChar"]

204+isInheritedFromStyles names sty

205+ | getStyleName sty `elem` names = True

206+ | Just psty <- getParentStyle sty = isInheritedFromStyles names psty

207+ | otherwise = False

203

208

204−codeDivs :: [String]

209+hasStylesInheritedFrom :: [ParaStyleName] -> ParagraphStyle -> Bool

205−codeDivs = ["SourceCode"]

210+hasStylesInheritedFrom ns s = any (isInheritedFromStyles ns) $ pStyle s

211+

212+removeStyleNamed :: ParaStyleName -> ParagraphStyle -> ParagraphStyle

213+removeStyleNamed sn ps = ps{pStyle = filter (\psd -> getStyleName psd /= sn) $ pStyle ps}

214+

215+isCodeCharStyle :: CharStyle -> Bool

216+isCodeCharStyle = isInheritedFromStyles ["Verbatim Char"]

217+

218+isCodeDiv :: ParagraphStyle -> Bool

219+isCodeDiv = hasStylesInheritedFrom ["Source Code"]

220+

221+isBlockQuote :: ParStyle -> Bool

222+isBlockQuote =

223+ isInheritedFromStyles [

224+ "Quote", "Block Text", "Block Quote", "Block Quotation"

225+ ]

206

226

207runElemToInlines :: RunElem -> Inlines

227runElemToInlines :: RunElem -> Inlines

208runElemToInlines (TextRun s) = text s

228runElemToInlines (TextRun s) = text s

@@ -228,57 +248,31 @@ parPartToString (InternalHyperLink _ runs) = concatMap runToString runs

228parPartToString (ExternalHyperLink _ runs) = concatMap runToString runs

248parPartToString (ExternalHyperLink _ runs) = concatMap runToString runs

229parPartToString _ = ""

249parPartToString _ = ""

230

250

231−blacklistedCharStyles :: [String]

251+blacklistedCharStyles :: [CharStyleName]

232blacklistedCharStyles = ["Hyperlink"]

252blacklistedCharStyles = ["Hyperlink"]

233

253

234resolveDependentRunStyle :: PandocMonad m => RunStyle -> DocxContext m RunStyle

254resolveDependentRunStyle :: PandocMonad m => RunStyle -> DocxContext m RunStyle

235resolveDependentRunStyle rPr

255resolveDependentRunStyle rPr

256+ | Just s <- rParentStyle rPr

236− | Just (s, _) <- rStyle rPr, s `elem` blacklistedCharStyles =

257+ , getStyleName s `elem` blacklistedCharStyles =

237 return rPr

258 return rPr

238− | Just (_, cs) <- rStyle rPr = do

259+ | Just s <- rParentStyle rPr = do

239 opts <- asks docxOptions

260 opts <- asks docxOptions

240 if isEnabled Ext_styles opts

261 if isEnabled Ext_styles opts

241 then return rPr

262 then return rPr

242− else do rPr' <- resolveDependentRunStyle cs

263+ else leftBiasedMergeRunStyle rPr <$> resolveDependentRunStyle (cStyleData s)

243− return $

244− RunStyle { isBold = case isBold rPr of

245− Just bool -> Just bool

246− Nothing -> isBold rPr'

247− , isItalic = case isItalic rPr of

248− Just bool -> Just bool

249− Nothing -> isItalic rPr'

250− , isSmallCaps = case isSmallCaps rPr of

251− Just bool -> Just bool

252− Nothing -> isSmallCaps rPr'

253− , isStrike = case isStrike rPr of

254− Just bool -> Just bool

255− Nothing -> isStrike rPr'

256− , isRTL = case isRTL rPr of

257− Just bool -> Just bool

258− Nothing -> isRTL rPr'

259− , rVertAlign = case rVertAlign rPr of

260− Just valign -> Just valign

261− Nothing -> rVertAlign rPr'

262− , rUnderline = case rUnderline rPr of

263− Just ulstyle -> Just ulstyle

264− Nothing -> rUnderline rPr'

265− , rStyle = rStyle rPr

266− }

267 | otherwise = return rPr

264 | otherwise = return rPr

268

265

269runStyleToTransform :: PandocMonad m => RunStyle -> DocxContext m (Inlines -> Inlines)

266runStyleToTransform :: PandocMonad m => RunStyle -> DocxContext m (Inlines -> Inlines)

270runStyleToTransform rPr

267runStyleToTransform rPr

271− | Just (s, _) <- rStyle rPr

268+ | Just sn <- getStyleName <$> rParentStyle rPr

272− , s `elem` spansToKeep = do

269+ , sn `elem` spansToKeep = do

273− transform <- runStyleToTransform rPr{rStyle = Nothing}

270+ transform <- runStyleToTransform rPr{rParentStyle = Nothing}

274− return $ spanWith ("", [s], []) . transform

271+ return $ spanWith ("", [normalizeToClassName sn], []) . transform

275− | Just (s, _) <- rStyle rPr = do

272+ | Just s <- rParentStyle rPr = do

276− opts <- asks docxOptions

277− let extraInfo = if isEnabled Ext_styles opts

278− then spanWith ("", [], [("custom-style", s)])

273+ ei <- extraInfo spanWith s

279− else id

280− transform <- runStyleToTransform rPr{rStyle = Nothing}

274+ transform <- runStyleToTransform rPr{rParentStyle = Nothing}

281− return $ extraInfo . transform

275+ return $ ei . transform

282 | Just True <- isItalic rPr = do

276 | Just True <- isItalic rPr = do

283 transform <- runStyleToTransform rPr{isItalic = Nothing}

277 transform <- runStyleToTransform rPr{isItalic = Nothing}

284 return $ emph . transform

278 return $ emph . transform

@@ -310,8 +304,7 @@ runStyleToTransform rPr

310

304

311runToInlines :: PandocMonad m => Run -> DocxContext m Inlines

305runToInlines :: PandocMonad m => Run -> DocxContext m Inlines

312runToInlines (Run rs runElems)

306runToInlines (Run rs runElems)

313− | Just (s, _) <- rStyle rs

307+ | maybe False isCodeCharStyle $ rParentStyle rs = do

314− , s `elem` codeStyles = do

315 rPr <- resolveDependentRunStyle rs

308 rPr <- resolveDependentRunStyle rs

316 let codeString = code $ concatMap runElemToString runElems

309 let codeString = code $ concatMap runElemToString runElems

317 return $ case rVertAlign rPr of

310 return $ case rVertAlign rPr of

@@ -526,39 +519,49 @@ trimSps (Many ils) = Many $ Seq.dropWhileL isSp $Seq.dropWhileR isSp ils

526 isSp LineBreak = True

519 isSp LineBreak = True

527 isSp _ = False

520 isSp _ = False

528

521

522+extraInfo :: (Eq (StyleName a), PandocMonad m, HasStyleName a)

523+ => (Attr -> i -> i) -> a -> DocxContext m (i -> i)

524+extraInfo f s = do

525+ opts <- asks docxOptions

526+ return $ if | isEnabled Ext_styles opts

527+ -> f ("", [], [("custom-style", fromStyleName $ getStyleName s)])

528+ | otherwise -> id

529+

529parStyleToTransform :: PandocMonad m => ParagraphStyle -> DocxContext m (Blocks -> Blocks)

530parStyleToTransform :: PandocMonad m => ParagraphStyle -> DocxContext m (Blocks -> Blocks)

530parStyleToTransform pPr

531parStyleToTransform pPr

531 | (c:cs) <- pStyle pPr

532 | (c:cs) <- pStyle pPr

532− , c `elem` divsToKeep = do

533+ , getStyleName c `elem` divsToKeep = do

533 let pPr' = pPr { pStyle = cs }

534 let pPr' = pPr { pStyle = cs }

534 transform <- parStyleToTransform pPr'

535 transform <- parStyleToTransform pPr'

535− return $ divWith ("", [c], []) . transform

536+ return $ divWith ("", [normalizeToClassName $ getStyleName c], []) . transform

536 | (c:cs) <- pStyle pPr,

537 | (c:cs) <- pStyle pPr,

537− c `elem` listParagraphDivs = do

538+ getStyleName c `elem` listParagraphStyles = do

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

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

539 transform <- parStyleToTransform pPr'

540 transform <- parStyleToTransform pPr'

540− return $ divWith ("", [c], []) . transform

541+ return $ divWith ("", [normalizeToClassName $ getStyleName c], []) . transform

541 | (c:cs) <- pStyle pPr = do

542 | (c:cs) <- pStyle pPr = do

542− opts <- asks docxOptions

543− let pPr' = pPr { pStyle = cs}

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

544 transform <- parStyleToTransform pPr'

545− let extraInfo = if isEnabled Ext_styles opts

545+ ei <- extraInfo divWith c

546− then divWith ("", [], [("custom-style", c)])

547− else id

548− return $ extraInfo . (if fromMaybe False (pBlockQuote pPr) then blockQuote else id) . transform

546+ return $ ei . (if isBlockQuote c then blockQuote else id) . transform

549 | null (pStyle pPr)

547 | null (pStyle pPr)

550 , Just left <- indentation pPr >>= leftParIndent = do

548 , Just left <- indentation pPr >>= leftParIndent = do

551 let pPr' = pPr { indentation = Nothing }

549 let pPr' = pPr { indentation = Nothing }

552 hang = fromMaybe 0 $ indentation pPr >>= hangingParIndent

550 hang = fromMaybe 0 $ indentation pPr >>= hangingParIndent

553 transform <- parStyleToTransform pPr'

551 transform <- parStyleToTransform pPr'

554− return $ if (left - hang) > 0

552+ return $ if (left - hang) > 0

555 then blockQuote . transform

553 then blockQuote . transform

556 else transform

554 else transform

557parStyleToTransform _ = return id

555parStyleToTransform _ = return id

558

556

557+normalizeToClassName :: (FromStyleName a) => a -> String

558+normalizeToClassName = map go . fromStyleName

559+ where go c | isSpace c = '-'

560+ | otherwise = c

561+

559bodyPartToBlocks :: PandocMonad m => BodyPart -> DocxContext m Blocks

562bodyPartToBlocks :: PandocMonad m => BodyPart -> DocxContext m Blocks

560bodyPartToBlocks (Paragraph pPr parparts)

563bodyPartToBlocks (Paragraph pPr parparts)

561− | not $ null $ codeDivs `intersect` (pStyle pPr) = do

564+ | isCodeDiv pPr = do

562 transform <- parStyleToTransform pPr

565 transform <- parStyleToTransform pPr

563 return $

566 return $

564 transform $

567 transform $

@@ -568,13 +571,16 @@ bodyPartToBlocks (Paragraph pPr parparts)

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

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

569 (smushInlines <$> mapM parPartToInlines parparts)

572 (smushInlines <$> mapM parPartToInlines parparts)

570 makeHeaderAnchor $

573 makeHeaderAnchor $

571− headerWith ("", delete style (pStyle pPr), []) n ils

574+ headerWith ("", map normalizeToClassName . delete style $ getStyleNames (pStyle pPr), []) n ils

572 | otherwise = do

575 | otherwise = do

573 ils <- trimSps . smushInlines <$> mapM parPartToInlines parparts

576 ils <- trimSps . smushInlines <$> mapM parPartToInlines parparts

574 prevParaIls <- gets docxPrevPara

577 prevParaIls <- gets docxPrevPara

575 dropIls <- gets docxDropCap

578 dropIls <- gets docxDropCap

576 let ils' = dropIls <> ils

579 let ils' = dropIls <> ils

580+ let (paraOrPlain, pPr')

581+ | hasStylesInheritedFrom ["Compact"] pPr = (plain, removeStyleNamed "Compact" pPr)

582+ | otherwise = (para, pPr)

577− if dropCap pPr

583+ if dropCap pPr'

578 then do modify $ \s -> s { docxDropCap = ils' }

584 then do modify $ \s -> s { docxDropCap = ils' }

579 return mempty

585 return mempty

580 else do modify $ \s -> s { docxDropCap = mempty }

586 else do modify $ \s -> s { docxDropCap = mempty }

@@ -583,41 +589,41 @@ bodyPartToBlocks (Paragraph pPr parparts)

583 ils'

589 ils'

584 handleInsertion = do

590 handleInsertion = do

585 modify $ \s -> s {docxPrevPara = mempty}

591 modify $ \s -> s {docxPrevPara = mempty}

586− transform <- parStyleToTransform pPr

592+ transform <- parStyleToTransform pPr'

587− return $ transform $ para ils''

593+ return $ transform $ paraOrPlain ils''

588 opts <- asks docxOptions

594 opts <- asks docxOptions

589 if | isNull ils'' && not (isEnabled Ext_empty_paragraphs opts) ->

595 if | isNull ils'' && not (isEnabled Ext_empty_paragraphs opts) ->

590 return mempty

596 return mempty

591− | Just (TrackedChange Insertion _) <- pChange pPr

597+ | Just (TrackedChange Insertion _) <- pChange pPr'

592 , AcceptChanges <- readerTrackChanges opts ->

598 , AcceptChanges <- readerTrackChanges opts ->

593 handleInsertion

599 handleInsertion

594− | Just (TrackedChange Insertion _) <- pChange pPr

600+ | Just (TrackedChange Insertion _) <- pChange pPr'

595 , RejectChanges <- readerTrackChanges opts -> do

601 , RejectChanges <- readerTrackChanges opts -> do

596 modify $ \s -> s {docxPrevPara = ils''}

602 modify $ \s -> s {docxPrevPara = ils''}

597 return mempty

603 return mempty

598− | Just (TrackedChange Insertion cInfo) <- pChange pPr

604+ | Just (TrackedChange Insertion cInfo) <- pChange pPr'

599 , AllChanges <- readerTrackChanges opts

605 , AllChanges <- readerTrackChanges opts

600 , ChangeInfo _ cAuthor cDate <- cInfo -> do

606 , ChangeInfo _ cAuthor cDate <- cInfo -> do

601 let attr = ("", ["paragraph-insertion"], [("author", cAuthor), ("date", cDate)])

607 let attr = ("", ["paragraph-insertion"], [("author", cAuthor), ("date", cDate)])

602 insertMark = spanWith attr mempty

608 insertMark = spanWith attr mempty

603− transform <- parStyleToTransform pPr

609+ transform <- parStyleToTransform pPr'

604 return $ transform $

610 return $ transform $

605− para $ ils'' <> insertMark

611+ paraOrPlain $ ils'' <> insertMark

606− | Just (TrackedChange Deletion _) <- pChange pPr

612+ | Just (TrackedChange Deletion _) <- pChange pPr'

607 , AcceptChanges <- readerTrackChanges opts -> do

613 , AcceptChanges <- readerTrackChanges opts -> do

608 modify $ \s -> s {docxPrevPara = ils''}

614 modify $ \s -> s {docxPrevPara = ils''}

609 return mempty

615 return mempty

610− | Just (TrackedChange Deletion _) <- pChange pPr

616+ | Just (TrackedChange Deletion _) <- pChange pPr'

611 , RejectChanges <- readerTrackChanges opts ->

617 , RejectChanges <- readerTrackChanges opts ->

612 handleInsertion

618 handleInsertion

613− | Just (TrackedChange Deletion cInfo) <- pChange pPr

619+ | Just (TrackedChange Deletion cInfo) <- pChange pPr'

614 , AllChanges <- readerTrackChanges opts

620 , AllChanges <- readerTrackChanges opts

615 , ChangeInfo _ cAuthor cDate <- cInfo -> do

621 , ChangeInfo _ cAuthor cDate <- cInfo -> do

616 let attr = ("", ["paragraph-deletion"], [("author", cAuthor), ("date", cDate)])

622 let attr = ("", ["paragraph-deletion"], [("author", cAuthor), ("date", cDate)])

617 insertMark = spanWith attr mempty

623 insertMark = spanWith attr mempty

618− transform <- parStyleToTransform pPr

624+ transform <- parStyleToTransform pPr'

619 return $ transform $

625 return $ transform $

620− para $ ils'' <> insertMark

626+ paraOrPlain $ ils'' <> insertMark

621 | otherwise -> handleInsertion

627 | otherwise -> handleInsertion

622bodyPartToBlocks (ListItem pPr numId lvl (Just levelInfo) parparts) = do

628bodyPartToBlocks (ListItem pPr numId lvl (Just levelInfo) parparts) = do

623 -- We check whether this current numId has previously been used,

629 -- We check whether this current numId has previously been used,

@@ -638,7 +644,7 @@ bodyPartToBlocks (ListItem pPr numId lvl (Just levelInfo) parparts) = do

638 blks <- bodyPartToBlocks (Paragraph pPr parparts)

644 blks <- bodyPartToBlocks (Paragraph pPr parparts)

639 return $ divWith ("", ["list-item"], kvs) blks

645 return $ divWith ("", ["list-item"], kvs) blks

640bodyPartToBlocks (ListItem pPr _ _ _ parparts) =

646bodyPartToBlocks (ListItem pPr _ _ _ parparts) =

641− let pPr' = pPr {pStyle = "ListParagraph": pStyle pPr}

647+ let pPr' = pPr {pStyle = constructBogusParStyleData "list-paragraph": pStyle pPr}

642 in

648 in

643 bodyPartToBlocks $ Paragraph pPr' parparts

649 bodyPartToBlocks $ Paragraph pPr' parparts

644bodyPartToBlocks (Tbl _ _ _ []) =

650bodyPartToBlocks (Tbl _ _ _ []) =

src/Text/Pandoc/Readers/Docx/Lists.hs+15−10

@@ -1,4 +1,5 @@

1{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE OverloadedStrings #-}

2{- |

3{- |

3 Module : Text.Pandoc.Readers.Docx.Lists

4 Module : Text.Pandoc.Readers.Docx.Lists

@@ -14,13 +15,16 @@ Functions for converting flat docx paragraphs into nested lists.

14module Text.Pandoc.Readers.Docx.Lists ( blocksToBullets

15module Text.Pandoc.Readers.Docx.Lists ( blocksToBullets

15 , blocksToDefinitions

16 , blocksToDefinitions

16 , listParagraphDivs

17 , listParagraphDivs

18+ , listParagraphStyles

17 ) where

19 ) where

19import Prelude

21import Prelude

20import Data.List

22import Data.List

21import Data.Maybe

23import Data.Maybe

24+import Data.String (fromString)

22import Text.Pandoc.Generic (bottomUp)

25import Text.Pandoc.Generic (bottomUp)

23import Text.Pandoc.JSON

26import Text.Pandoc.JSON

27+import Text.Pandoc.Readers.Docx.Parse (ParaStyleName)

24import Text.Pandoc.Shared (trim, safeRead)

28import Text.Pandoc.Shared (trim, safeRead)

26isListItem :: Block -> Bool

30isListItem :: Block -> Bool

@@ -79,7 +83,10 @@ getListType b@(Div (_, _, kvs) _) | isListItem b =

79getListType _ = Nothing

83getListType _ = Nothing

81listParagraphDivs :: [String]

85listParagraphDivs :: [String]

82−listParagraphDivs = ["ListParagraph"]

86+listParagraphDivs = ["list-paragraph"]

87+

88+listParagraphStyles :: [ParaStyleName]

89+listParagraphStyles = map fromString listParagraphDivs

84-- This is a first stab at going through and attaching meaning to list

91-- This is a first stab at going through and attaching meaning to list

85-- paragraphs, without an item marker, following a list item. We

92-- paragraphs, without an item marker, following a list item. We

@@ -160,7 +167,7 @@ blocksToDefinitions' defAcc acc [] =

160 reverse $ DefinitionList (reverse defAcc) : acc

167 reverse $ DefinitionList (reverse defAcc) : acc

161blocksToDefinitions' defAcc acc

168blocksToDefinitions' defAcc acc

162 (Div (_, classes1, _) blks1 : Div (ident2, classes2, kvs2) blks2 : blks)

169 (Div (_, classes1, _) blks1 : Div (ident2, classes2, kvs2) blks2 : blks)

163− | "DefinitionTerm" `elem` classes1 && "Definition" `elem` classes2 =

170+ | "Definition-Term" `elem` classes1 && "Definition" `elem` classes2 =

164 let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)

171 let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)

165 pair = if remainingAttr2 == ("", [], []) then (concatMap plainParaInlines blks1, [blks2]) else (concatMap plainParaInlines blks1, [[Div remainingAttr2 blks2]])

172 pair = if remainingAttr2 == ("", [], []) then (concatMap plainParaInlines blks1, [blks2]) else (concatMap plainParaInlines blks1, [[Div remainingAttr2 blks2]])

166 in

173 in

@@ -169,12 +176,12 @@ blocksToDefinitions' ((defTerm, defItems):defs) acc

169 (Div (ident2, classes2, kvs2) blks2 : blks)

176 (Div (ident2, classes2, kvs2) blks2 : blks)

170 | "Definition" `elem` classes2 =

177 | "Definition" `elem` classes2 =

171 let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)

178 let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)

172− defItems2 = case remainingAttr2 == ("", [], []) of

179+ defItems2 = if remainingAttr2 == ("", [], [])

173− True -> blks2

180+ then blks2

174− False -> [Div remainingAttr2 blks2]

181+ else [Div remainingAttr2 blks2]

175− defAcc' = case null defItems of

182+ defAcc' = if null defItems

176− True -> (defTerm, [defItems2]) : defs

183+ then (defTerm, [defItems2]) : defs

177− False -> (defTerm, init defItems ++ [last defItems ++ defItems2]) : defs

184+ else (defTerm, init defItems ++ [last defItems ++ defItems2]) : defs

178 in

185 in

179 blocksToDefinitions' defAcc' acc blks

186 blocksToDefinitions' defAcc' acc blks

180blocksToDefinitions' [] acc (b:blks) =

187blocksToDefinitions' [] acc (b:blks) =

@@ -198,7 +205,5 @@ removeListDivs' blk = [blk]

198removeListDivs :: [Block] -> [Block]

205removeListDivs :: [Block] -> [Block]

199removeListDivs = concatMap removeListDivs'

206removeListDivs = concatMap removeListDivs'

200

207

201−

202−

203blocksToDefinitions :: [Block] -> [Block]

208blocksToDefinitions :: [Block] -> [Block]

204blocksToDefinitions = blocksToDefinitions' [] []

209blocksToDefinitions = blocksToDefinitions' [] []

src/Text/Pandoc/Readers/Docx/Parse.hs+188−95

@@ -1,7 +1,11 @@

1{-# LANGUAGE NoImplicitPrelude #-}

2{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE PatternGuards #-}

4{-# LANGUAGE PatternGuards #-}

4{-# LANGUAGE ViewPatterns #-}

5{-# LANGUAGE ViewPatterns #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{- |

9{- |

6 Module : Text.Pandoc.Readers.Docx.Parse

10 Module : Text.Pandoc.Readers.Docx.Parse

@@ -31,6 +35,8 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..)

31 , VertAlign(..)

35 , VertAlign(..)

32 , ParIndentation(..)

36 , ParIndentation(..)

33 , ParagraphStyle(..)

37 , ParagraphStyle(..)

38+ , ParStyle

39+ , CharStyle(cStyleData)

34 , Row(..)

40 , Row(..)

35 , Cell(..)

41 , Cell(..)

36 , TrackedChange(..)

42 , TrackedChange(..)

@@ -38,8 +44,17 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..)

38 , ChangeInfo(..)

44 , ChangeInfo(..)

39 , FieldInfo(..)

45 , FieldInfo(..)

40 , Level(..)

46 , Level(..)

47+ , ParaStyleName

48+ , CharStyleName

49+ , FromStyleName(..)

50+ , HasStyleName(..)

51+ , HasParentStyle(..)

41 , archiveToDocx

52 , archiveToDocx

42 , archiveToDocxWithWarnings

53 , archiveToDocxWithWarnings

54+ , getStyleNames

55+ , pHeading

56+ , constructBogusParStyleData

57+ , leftBiasedMergeRunStyle

43 ) where

58 ) where

44import Prelude

59import Prelude

45import Codec.Archive.Zip

60import Codec.Archive.Zip

@@ -49,10 +64,13 @@ import Control.Monad.Reader

49import Control.Monad.State.Strict

64import Control.Monad.State.Strict

50import Data.Bits ((.|.))

65import Data.Bits ((.|.))

51import qualified Data.ByteString.Lazy as B

66import qualified Data.ByteString.Lazy as B

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

67+import Data.Char (chr, ord, readLitChar, toLower)

53import Data.List

68import Data.List

69+import Data.Function (on)

70+import Data.String (IsString(..))

54import qualified Data.Map as M

71import qualified Data.Map as M

55import Data.Maybe

72import Data.Maybe

73+import Data.Coerce

56import System.FilePath

74import System.FilePath

57import Text.Pandoc.Readers.Docx.Util

75import Text.Pandoc.Readers.Docx.Util

58import Text.Pandoc.Readers.Docx.Fields

76import Text.Pandoc.Readers.Docx.Fields

@@ -160,13 +178,9 @@ newtype Body = Body [BodyPart]

160

178

161type Media = [(FilePath, B.ByteString)]

179type Media = [(FilePath, B.ByteString)]

162

180

163−type CharStyle = (String, RunStyle)

181+type CharStyleMap = M.Map CharStyleId CharStyle

164

182

165−type ParStyle = (String, ParStyleData)

166−

167−type CharStyleMap = M.Map String RunStyle

168−

169−type ParStyleMap = M.Map String ParStyleData

183+type ParStyleMap = M.Map ParaStyleId ParStyle

170

184

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

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

172 deriving Show

186 deriving Show

@@ -213,12 +227,9 @@ data ChangeInfo = ChangeInfo ChangeId Author ChangeDate

213data TrackedChange = TrackedChange ChangeType ChangeInfo

227data TrackedChange = TrackedChange ChangeType ChangeInfo

214 deriving Show

228 deriving Show

215

229

216−data ParagraphStyle = ParagraphStyle { pStyle :: [String]

230+data ParagraphStyle = ParagraphStyle { pStyle :: [ParStyle]

217 , indentation :: Maybe ParIndentation

231 , indentation :: Maybe ParIndentation

218 , dropCap :: Bool

232 , dropCap :: Bool

219− , pHeading :: Maybe (String, Int)

220− , pNumInfo :: Maybe (String, String)

221− , pBlockQuote :: Maybe Bool

222 , pChange :: Maybe TrackedChange

233 , pChange :: Maybe TrackedChange

223 }

234 }

224 deriving Show

235 deriving Show

@@ -227,9 +238,6 @@ defaultParagraphStyle :: ParagraphStyle

227defaultParagraphStyle = ParagraphStyle { pStyle = []

238defaultParagraphStyle = ParagraphStyle { pStyle = []

228 , indentation = Nothing

239 , indentation = Nothing

229 , dropCap = False

240 , dropCap = False

230− , pHeading = Nothing

231− , pNumInfo = Nothing

232− , pBlockQuote = Nothing

233 , pChange = Nothing

241 , pChange = Nothing

234 }

242 }

235

243

@@ -254,6 +262,49 @@ newtype Row = Row [Cell]

254newtype Cell = Cell [BodyPart]

262newtype Cell = Cell [BodyPart]

255 deriving Show

263 deriving Show

256

264

265+newtype CharStyleId = CharStyleId { fromCharStyleId :: String }

266+ deriving (Show, Eq, Ord, FromStyleId)

267+newtype ParaStyleId = ParaStyleId { fromParaStyleId :: String }

268+ deriving (Show, Eq, Ord, FromStyleId)

269+

270+newtype CharStyleName = CharStyleName { fromCharStyleName :: CIString }

271+ deriving (Show, Eq, Ord, IsString, FromStyleName)

272+newtype ParaStyleName = ParaStyleName { fromParaStyleName :: CIString }

273+ deriving (Show, Eq, Ord, IsString, FromStyleName)

274+

275+-- Case-insensitive comparisons

276+newtype CIString = CIString String deriving (Show, IsString, FromStyleName)

277+

278+class FromStyleName a where

279+ fromStyleName :: a -> String

280+

281+instance FromStyleName String where

282+ fromStyleName = id

283+

284+class FromStyleId a where

285+ fromStyleId :: a -> String

286+

287+instance FromStyleId String where

288+ fromStyleId = id

289+

290+instance Eq CIString where

291+ (==) = (==) `on` map toLower . coerce

292+

293+instance Ord CIString where

294+ compare = compare `on` map toLower . coerce

295+

296+leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle

297+leftBiasedMergeRunStyle a b = RunStyle

298+ { isBold = isBold a <|> isBold b

299+ , isItalic = isItalic a <|> isItalic b

300+ , isSmallCaps = isSmallCaps a <|> isSmallCaps b

301+ , isStrike = isStrike a <|> isStrike b

302+ , isRTL = isRTL a <|> isRTL b

303+ , rVertAlign = rVertAlign a <|> rVertAlign b

304+ , rUnderline = rUnderline a <|> rUnderline b

305+ , rParentStyle = rParentStyle a

306+ }

307+

257-- (width, height) in EMUs

308-- (width, height) in EMUs

258type Extent = Maybe (Double, Double)

309type Extent = Maybe (Double, Double)

259

310

@@ -285,21 +336,28 @@ data RunElem = TextRun String | LnBrk | Tab | SoftHyphen | NoBreakHyphen

285data VertAlign = BaseLn | SupScrpt | SubScrpt

336data VertAlign = BaseLn | SupScrpt | SubScrpt

286 deriving Show

337 deriving Show

287

338

339+data CharStyle = CharStyle { cStyleId :: CharStyleId

340+ , cStyleName :: CharStyleName

341+ , cStyleData :: RunStyle

342+ } deriving (Show)

343+

288−data RunStyle = RunStyle { isBold :: Maybe Bool

344+data RunStyle = RunStyle { isBold :: Maybe Bool

289− , isItalic :: Maybe Bool

345+ , isItalic :: Maybe Bool

290− , isSmallCaps :: Maybe Bool

346+ , isSmallCaps :: Maybe Bool

291− , isStrike :: Maybe Bool

347+ , isStrike :: Maybe Bool

292− , isRTL :: Maybe Bool

348+ , isRTL :: Maybe Bool

293− , rVertAlign :: Maybe VertAlign

349+ , rVertAlign :: Maybe VertAlign

294− , rUnderline :: Maybe String

350+ , rUnderline :: Maybe String

295− , rStyle :: Maybe CharStyle

351+ , rParentStyle :: Maybe CharStyle

296 }

352 }

297 deriving Show

353 deriving Show

298

354

299−data ParStyleData = ParStyleData { headingLev :: Maybe (String, Int)

355+data ParStyle = ParStyle { headingLev :: Maybe (ParaStyleName, Int)

300− , isBlockQuote :: Maybe Bool

301− , numInfo :: Maybe (String, String)

356+ , numInfo :: Maybe (String, String)

302− , psStyle :: Maybe ParStyle}

357+ , psParentStyle :: Maybe ParStyle

358+ , pStyleName :: ParaStyleName

359+ , pStyleId :: ParaStyleId

360+ }

303 deriving Show

361 deriving Show

304

362

305defaultRunStyle :: RunStyle

363defaultRunStyle :: RunStyle

@@ -310,7 +368,7 @@ defaultRunStyle = RunStyle { isBold = Nothing

310 , isRTL = Nothing

368 , isRTL = Nothing

311 , rVertAlign = Nothing

369 , rVertAlign = Nothing

312 , rUnderline = Nothing

370 , rUnderline = Nothing

313− , rStyle = Nothing

371+ , rParentStyle = Nothing

314 }

372 }

315

373

316type Target = String

374type Target = String

@@ -390,7 +448,10 @@ elemToBody ns element | isElem ns "w" "body" element =

390elemToBody _ _ = throwError WrongElem

448elemToBody _ _ = throwError WrongElem

391

449

392archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)

450archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)

393−archiveToStyles zf =

451+archiveToStyles = archiveToStyles' getStyleId getStyleId

452+archiveToStyles' :: (Ord k1, Ord k2, ElemToStyle a1, ElemToStyle a2) =>

453+ (a1 -> k1) -> (a2 -> k2) -> Archive -> (M.Map k1 a1, M.Map k2 a2)

454+archiveToStyles' conv1 conv2 zf =

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

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

395 (parseXMLDoc . UTF8.toStringLazy . fromEntry)

456 (parseXMLDoc . UTF8.toStringLazy . fromEntry)

396 in

457 in

@@ -399,19 +460,17 @@ archiveToStyles zf =

399 Just styElem ->

460 Just styElem ->

400 let namespaces = elemToNameSpaces styElem

461 let namespaces = elemToNameSpaces styElem

401 in

462 in

402− ( M.fromList $ buildBasedOnList namespaces styElem

463+ ( M.fromList $ map (\r -> (conv1 r, r)) $ buildBasedOnList namespaces styElem Nothing,

403− (Nothing :: Maybe CharStyle),

464+ M.fromList $ map (\p -> (conv2 p, p)) $ buildBasedOnList namespaces styElem Nothing)

404− M.fromList $ buildBasedOnList namespaces styElem

405− (Nothing :: Maybe ParStyle) )

406

465

407−isBasedOnStyle :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> Bool

466+isBasedOnStyle :: (ElemToStyle a, FromStyleId (StyleId a)) => NameSpaces -> Element -> Maybe a -> Bool

408isBasedOnStyle ns element parentStyle

467isBasedOnStyle ns element parentStyle

409 | isElem ns "w" "style" element

468 | isElem ns "w" "style" element

410 , Just styleType <- findAttrByName ns "w" "type" element

469 , Just styleType <- findAttrByName ns "w" "type" element

411 , styleType == cStyleType parentStyle

470 , styleType == cStyleType parentStyle

412 , Just basedOnVal <- findChildByName ns "w" "basedOn" element >>=

471 , Just basedOnVal <- findChildByName ns "w" "basedOn" element >>=

413 findAttrByName ns "w" "val"

472 findAttrByName ns "w" "val"

414− , Just ps <- parentStyle = basedOnVal == getStyleId ps

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

415 | isElem ns "w" "style" element

474 | isElem ns "w" "style" element

416 , Just styleType <- findAttrByName ns "w" "type" element

475 , Just styleType <- findAttrByName ns "w" "type" element

417 , styleType == cStyleType parentStyle

476 , styleType == cStyleType parentStyle

@@ -419,30 +478,70 @@ isBasedOnStyle ns element parentStyle

419 , Nothing <- parentStyle = True

478 , Nothing <- parentStyle = True

420 | otherwise = False

479 | otherwise = False

421

480

422−class ElemToStyle a where

481+class HasStyleId a => ElemToStyle a where

423 cStyleType :: Maybe a -> String

482 cStyleType :: Maybe a -> String

424 elemToStyle :: NameSpaces -> Element -> Maybe a -> Maybe a

483 elemToStyle :: NameSpaces -> Element -> Maybe a -> Maybe a

484+

485+class FromStyleId (StyleId a) => HasStyleId a where

486+ type StyleId a

425− getStyleId :: a -> String

487+ getStyleId :: a -> StyleId a

488+

489+class FromStyleName (StyleName a) => HasStyleName a where

490+ type StyleName a

491+ getStyleName :: a -> StyleName a

492+

493+class HasParentStyle a where

494+ getParentStyle :: a -> Maybe a

495+

496+instance HasParentStyle CharStyle where

497+ getParentStyle = rParentStyle . cStyleData

498+

499+instance HasParentStyle ParStyle where

500+ getParentStyle = psParentStyle

501+

502+getStyleNames :: (Functor t, HasStyleName a) => t a -> t (StyleName a)

503+getStyleNames = fmap getStyleName

504+

505+constructBogusParStyleData :: ParaStyleName -> ParStyle

506+constructBogusParStyleData stName = ParStyle

507+ { headingLev = Nothing

508+ , numInfo = Nothing

509+ , psParentStyle = Nothing

510+ , pStyleName = stName

511+ , pStyleId = ParaStyleId . filter (/=' ') . fromStyleName $ stName

512+ }

426

513

427instance ElemToStyle CharStyle where

514instance ElemToStyle CharStyle where

428 cStyleType _ = "character"

515 cStyleType _ = "character"

429 elemToStyle ns element parentStyle

516 elemToStyle ns element parentStyle

430 | isElem ns "w" "style" element

517 | isElem ns "w" "style" element

431− , Just "character" <- findAttrByName ns "w" "type" element

518+ , Just "character" <- findAttrByName ns "w" "type" element =

432− , Just styleId <- findAttrByName ns "w" "styleId" element =

433− Just (styleId, elemToRunStyle ns element parentStyle)

519+ elemToCharStyle ns element parentStyle

434 | otherwise = Nothing

520 | otherwise = Nothing

521+

522+instance HasStyleId CharStyle where

523+ type StyleId CharStyle = CharStyleId

435− getStyleId s = fst s

524+ getStyleId = cStyleId

525+

526+instance HasStyleName CharStyle where

527+ type StyleName CharStyle = CharStyleName

528+ getStyleName = cStyleName

436

529

437instance ElemToStyle ParStyle where

530instance ElemToStyle ParStyle where

438 cStyleType _ = "paragraph"

531 cStyleType _ = "paragraph"

439 elemToStyle ns element parentStyle

532 elemToStyle ns element parentStyle

440 | isElem ns "w" "style" element

533 | isElem ns "w" "style" element

441 , Just "paragraph" <- findAttrByName ns "w" "type" element

534 , Just "paragraph" <- findAttrByName ns "w" "type" element

442− , Just styleId <- findAttrByName ns "w" "styleId" element =

443− Just (styleId, elemToParStyleData ns element parentStyle)

535+ = elemToParStyleData ns element parentStyle

444 | otherwise = Nothing

536 | otherwise = Nothing

537+

538+instance HasStyleId ParStyle where

539+ type StyleId ParStyle = ParaStyleId

445− getStyleId s = fst s

540+ getStyleId = pStyleId

541+

542+instance HasStyleName ParStyle where

543+ type StyleName ParStyle = ParaStyleName

544+ getStyleName = pStyleName

446

545

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

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

448getStyleChildren ns element parentStyle

547getStyleChildren ns element parentStyle

@@ -693,6 +792,12 @@ testBitMask bitMaskS n =

693stringToInteger :: String -> Maybe Integer

792stringToInteger :: String -> Maybe Integer

694stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])

793stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])

695

794

795+pHeading :: ParagraphStyle -> Maybe (ParaStyleName, Int)

796+pHeading = getParStyleField headingLev . pStyle

797+

798+pNumInfo :: ParagraphStyle -> Maybe (String, String)

799+pNumInfo = getParStyleField numInfo . pStyle

800+

696elemToBodyPart :: NameSpaces -> Element -> D BodyPart

801elemToBodyPart :: NameSpaces -> Element -> D BodyPart

697elemToBodyPart ns element

802elemToBodyPart ns element

698 | isElem ns "w" "p" element

803 | isElem ns "w" "p" element

@@ -1003,20 +1108,18 @@ elemToRun ns element

1003 return $ Run runStyle runElems

1108 return $ Run runStyle runElems

1004elemToRun _ _ = throwError WrongElem

1109elemToRun _ _ = throwError WrongElem

1005

1110

1006−getParentStyleValue :: (ParStyleData -> Maybe a) -> ParStyleData -> Maybe a

1111+getParentStyleValue :: (ParStyle -> Maybe a) -> ParStyle -> Maybe a

1007getParentStyleValue field style

1112getParentStyleValue field style

1008 | Just value <- field style = Just value

1113 | Just value <- field style = Just value

1009− | Just parentStyle <- psStyle style

1114+ | Just parentStyle <- psParentStyle style

1010− = getParentStyleValue field (snd parentStyle)

1115+ = getParentStyleValue field parentStyle

1011getParentStyleValue _ _ = Nothing

1116getParentStyleValue _ _ = Nothing

1012

1117

1013−getParStyleField :: (ParStyleData -> Maybe a) -> ParStyleMap -> [String] ->

1118+getParStyleField :: (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a

1014− Maybe a

1015−getParStyleField field stylemap styles

1119+getParStyleField field styles

1016− | x <- mapMaybe (\x -> M.lookup x stylemap) styles

1017− , (y:_) <- mapMaybe (getParentStyleValue field) x

1120+ | (y:_) <- mapMaybe (getParentStyleValue field) styles

1018 = Just y

1121 = Just y

1019−getParStyleField _ _ _ = Nothing

1122+getParStyleField _ _ = Nothing

1020

1123

1021getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange

1124getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange

1022getTrackedChange ns element

1125getTrackedChange ns element

@@ -1038,10 +1141,10 @@ elemToParagraphStyle ns element sty

1038 | Just pPr <- findChildByName ns "w" "pPr" element =

1141 | Just pPr <- findChildByName ns "w" "pPr" element =

1039 let style =

1142 let style =

1040 mapMaybe

1143 mapMaybe

1041− (findAttrByName ns "w" "val")

1144+ (fmap ParaStyleId . findAttrByName ns "w" "val")

1042 (findChildrenByName ns "w" "pStyle" pPr)

1145 (findChildrenByName ns "w" "pStyle" pPr)

1043 in ParagraphStyle

1146 in ParagraphStyle

1044− {pStyle = style

1147+ {pStyle = mapMaybe (`M.lookup` sty) style

1045 , indentation =

1148 , indentation =

1046 findChildByName ns "w" "ind" pPr >>=

1149 findChildByName ns "w" "ind" pPr >>=

1047 elemToParIndentation ns

1150 elemToParIndentation ns

@@ -1053,9 +1156,6 @@ elemToParagraphStyle ns element sty

1053 Just "none" -> False

1156 Just "none" -> False

1054 Just _ -> True

1157 Just _ -> True

1055 Nothing -> False

1158 Nothing -> False

1056− , pHeading = getParStyleField headingLev sty style

1057− , pNumInfo = getParStyleField numInfo sty style

1058− , pBlockQuote = getParStyleField isBlockQuote sty style

1059 , pChange = findChildByName ns "w" "rPr" pPr >>=

1159 , pChange = findChildByName ns "w" "rPr" pPr >>=

1060 filterChild (\e -> isElem ns "w" "ins" e ||

1160 filterChild (\e -> isElem ns "w" "ins" e ||

1061 isElem ns "w" "moveTo" e ||

1161 isElem ns "w" "moveTo" e ||

@@ -1085,16 +1185,20 @@ elemToRunStyleD :: NameSpaces -> Element -> D RunStyle

1085elemToRunStyleD ns element

1185elemToRunStyleD ns element

1086 | Just rPr <- findChildByName ns "w" "rPr" element = do

1186 | Just rPr <- findChildByName ns "w" "rPr" element = do

1087 charStyles <- asks envCharStyles

1187 charStyles <- asks envCharStyles

1088− let parentSty = case

1188+ let parentSty =

1089 findChildByName ns "w" "rStyle" rPr >>=

1189 findChildByName ns "w" "rStyle" rPr >>=

1090− findAttrByName ns "w" "val"

1190+ findAttrByName ns "w" "val" >>=

1091− of

1092− Just styName | Just style <- M.lookup styName charStyles ->

1191+ flip M.lookup charStyles . CharStyleId

1093− Just (styName, style)

1094− _ -> Nothing

1095 return $ elemToRunStyle ns element parentSty

1192 return $ elemToRunStyle ns element parentSty

1096elemToRunStyleD _ _ = return defaultRunStyle

1193elemToRunStyleD _ _ = return defaultRunStyle

1097

1194

1195+elemToCharStyle :: NameSpaces

1196+ -> Element -> Maybe CharStyle -> Maybe CharStyle

1197+elemToCharStyle ns element parentStyle

1198+ = CharStyle <$> (CharStyleId <$> findAttrByName ns "w" "styleId" element)

1199+ <*> getElementStyleName ns element

1200+ <*> (Just $ elemToRunStyle ns element parentStyle)

1201+

1098elemToRunStyle :: NameSpaces -> Element -> Maybe CharStyle -> RunStyle

1202elemToRunStyle :: NameSpaces -> Element -> Maybe CharStyle -> RunStyle

1099elemToRunStyle ns element parentStyle

1203elemToRunStyle ns element parentStyle

1100 | Just rPr <- findChildByName ns "w" "rPr" element =

1204 | Just rPr <- findChildByName ns "w" "rPr" element =

@@ -1117,38 +1221,23 @@ elemToRunStyle ns element parentStyle

1117 , rUnderline =

1221 , rUnderline =

1118 findChildByName ns "w" "u" rPr >>=

1222 findChildByName ns "w" "u" rPr >>=

1119 findAttrByName ns "w" "val"

1223 findAttrByName ns "w" "val"

1120− , rStyle = parentStyle

1224+ , rParentStyle = parentStyle

1121 }

1225 }

1122elemToRunStyle _ _ _ = defaultRunStyle

1226elemToRunStyle _ _ _ = defaultRunStyle

1123

1227

1124−getHeaderLevel :: NameSpaces -> Element -> Maybe (String,Int)

1228+getHeaderLevel :: NameSpaces -> Element -> Maybe (ParaStyleName, Int)

1125getHeaderLevel ns element

1229getHeaderLevel ns element

1126− | Just styleId <- findAttrByName ns "w" "styleId" element

1230+ | Just styleName <- getElementStyleName ns element

1127− , Just index <- stripPrefix "Heading" styleId

1128− , Just n <- stringToInteger index

1231+ , Just n <- stringToInteger =<<

1129− , n > 0 = Just (styleId, fromInteger n)

1130− | Just styleId <- findAttrByName ns "w" "styleId" element

1131− , Just index <- findChildByName ns "w" "name" element >>=

1132− findAttrByName ns "w" "val" >>=

1133− stripPrefix "heading "

1232+ (stripPrefix "heading " . map toLower $

1134− , Just n <- stringToInteger index

1233+ fromStyleName styleName)

1135− , n > 0 = Just (styleId, fromInteger n)

1234+ , n > 0 = Just (styleName, fromInteger n)

1136getHeaderLevel _ _ = Nothing

1235getHeaderLevel _ _ = Nothing

1137

1236

1138−blockQuoteStyleIds :: [String]

1139−blockQuoteStyleIds = ["Quote", "BlockQuote", "BlockQuotation"]

1140−

1141−blockQuoteStyleNames :: [String]

1142−blockQuoteStyleNames = ["Quote", "Block Text"]

1143−

1144−getBlockQuote :: NameSpaces -> Element -> Maybe Bool

1237+getElementStyleName :: Coercible String a => NameSpaces -> Element -> Maybe a

1145−getBlockQuote ns element

1238+getElementStyleName ns el = coerce <$>

1146− | Just styleId <- findAttrByName ns "w" "styleId" element

1147− , styleId `elem` blockQuoteStyleIds = Just True

1148− | Just styleName <- findChildByName ns "w" "name" element >>=

1149− findAttrByName ns "w" "val"

1239+ ((findChildByName ns "w" "name" el >>= findAttrByName ns "w" "val")

1150− , styleName `elem` blockQuoteStyleNames = Just True

1240+ <|> findAttrByName ns "w" "styleId" el)

1151−getBlockQuote _ _ = Nothing

1152

1241

1153getNumInfo :: NameSpaces -> Element -> Maybe (String, String)

1242getNumInfo :: NameSpaces -> Element -> Maybe (String, String)

1154getNumInfo ns element = do

1243getNumInfo ns element = do

@@ -1163,15 +1252,19 @@ getNumInfo ns element = do

1163 return (numId, lvl)

1252 return (numId, lvl)

1164

1253

1165

1254

1166−elemToParStyleData :: NameSpaces -> Element -> Maybe ParStyle -> ParStyleData

1255+elemToParStyleData :: NameSpaces -> Element -> Maybe ParStyle -> Maybe ParStyle

1167−elemToParStyleData ns element parentStyle =

1256+elemToParStyleData ns element parentStyle

1168− ParStyleData

1257+ | Just styleId <- findAttrByName ns "w" "styleId" element

1258+ , Just styleName <- getElementStyleName ns element

1259+ = Just $ ParStyle

1169 {

1260 {

1170 headingLev = getHeaderLevel ns element

1261 headingLev = getHeaderLevel ns element

1171− , isBlockQuote = getBlockQuote ns element

1172 , numInfo = getNumInfo ns element

1262 , numInfo = getNumInfo ns element

1173− , psStyle = parentStyle

1263+ , psParentStyle = parentStyle

1264+ , pStyleName = styleName

1265+ , pStyleId = ParaStyleId styleId

1174− }

1266+ }

1267+elemToParStyleData _ _ _ = Nothing

1175

1268

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

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

1177elemToRunElem ns element

1270elemToRunElem ns element

test/Tests/Readers/Docx.hs+9

@@ -255,6 +255,10 @@ tests = [ testGroup "document"

255 "lists"

256 "docx/lists.docx"

257 "docx/lists.native"

258+ , testCompare

259+ "compact lists"

260+ "docx/lists-compact.docx"

261+ "docx/lists-compact.native"

258 , testCompare

262 , testCompare

259 "lists with level overrides"

263 "lists with level overrides"

260 "docx/lists_level_override.docx"

264 "docx/lists_level_override.docx"

@@ -425,6 +429,11 @@ tests = [ testGroup "document"

425 "custom styles (`+styles`) enabled"

429 "custom styles (`+styles`) enabled"

426 "docx/custom-style-reference.docx"

430 "docx/custom-style-reference.docx"

427 "docx/custom-style-with-styles.native"

431 "docx/custom-style-with-styles.native"

432+ , testCompareWithOpts

433+ def{readerExtensions=extensionsFromList [Ext_styles]}

434+ "custom styles (`+styles`): Compact style is removed from output"

435+ "docx/compact-style-removal.docx"

436+ "docx/compact-style-removal.native"

428 ]

437 ]

429 , testGroup "metadata"

438 , testGroup "metadata"

430 [ testCompareWithOpts def{readerStandalone=True}

439 [ testCompareWithOpts def{readerStandalone=True}

test/docx/compact-style-removal.docxnew file

Binary file not shown.

test/docx/compact-style-removal.nativenew file+5

@@ -0,0 +1,5 @@

1+[OrderedList (1,Decimal,Period)

2+ [[Plain [Str "One"]]

3+ ,[Plain [Str "Two"]]

4+ ,[Plain [Str "Three"]]

5+ ,[Plain [Str "Four"]]]]

test/docx/lists-compact.docxnew file