c113ca6 · typeable/pandoc

git.iko.soy/typeable/pandoc

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

Motivating issues: #5523, #5052, #5074 Style name comparisons are case-insensitive, since those are case-insensitive in Word. w:styleId will be used as style name if w:name is missing (this should only happen for malformed docx and is kept as a fallback to avoid failing altogether on malformed documents) Block quote detection code moved from Docx.Parser to Readers.Docx Code styles, i.e. "Source Code" and "Verbatim Char" now honor style inheritance Docx Reader now honours "Compact" style (used in Pandoc-generated docx). The side-effect is that "Compact" style no longer shows up in docx+styles output. Styles inherited from "Compact" will still show up. Removed obsolete list-item style from divsToKeep. That didn't really do anything for a while now. Add newtypes to differentiate between style names, ids, and different style types (that is, paragraph and character styles) Since docx style names can have spaces in them, and pandoc-markdown classes can't, anywhere when style name is used as a class name, spaces are replaced with ASCII dashes `-`. Get rid of extraneous intermediate types, carrying styleId information. Instead, styleId is saved with other style data. Use RunStyle for inline style definitions only (lacking styleId and styleName); for Character Styles use CharStyle type (which is basicaly RunStyle with styleId and StyleName bolted onto it).

commitc113ca6717d00870ec10716897d76a6fa62b1d41 authorNikolay Yakimov <root@livid.pp.ru> dateSun 15 Sep 2019, 01:40 (7 years ago) parentfd14ad5

8 files changed+306−183

compare with master

unifiedsplit

src/Text/Pandoc/Readers/Docx.hs+84−78 src/Text/Pandoc/Readers/Docx/Lists.hs+15−10 src/Text/Pandoc/Readers/Docx/Parse.hs+188−95 test/Tests/Readers/Docx.hs+9 test/docx/compact-style-removal.docx test/docx/compact-style-removal.native+5 test/docx/lists-compact.docx test/docx/lists-compact.native+5

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

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

33{-# LANGUAGE OverloadedStrings #-}

44{-# LANGUAGE PatternGuards #-}

55{-# LANGUAGE MultiWayIf #-}

6+{-# LANGUAGE FlexibleContexts #-}

67{- |

78 Module : Text.Pandoc.Readers.Docx

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

6566import qualified Data.ByteString.Lazy as B

6667import Data.Default (Default)

6768import Data.List (delete, intersect)

69+import Data.Char (isSpace)

6870import qualified Data.Map as M

6971import Data.Maybe (isJust, fromMaybe)

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

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

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

134136

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

136−spansToKeep :: [String]

138+spansToKeep :: [CharStyleName]

137139spansToKeep = []

138140

139−divsToKeep :: [String]

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

141+divsToKeep :: [ParaStyleName]

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

141143

142−metaStyles :: M.Map String String

144+metaStyles :: M.Map ParaStyleName String

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

144146 , ("Subtitle", "subtitle")

145147 , ("Author", "author")

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

151153

152154isMetaPar :: BodyPart -> Bool

153155isMetaPar (Paragraph pPr _) =

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

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

155157isMetaPar _ = False

156158

157159isEmptyPar :: BodyPart -> Bool

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

168170bodyPartsToMeta' [] = return M.empty

169171bodyPartsToMeta' (bp : bps)

170172 | (Paragraph pPr parParts) <- bp

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

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

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

173175 inlines <- smushInlines <$> mapM parPartToInlines parParts

174176 remaining <- bodyPartsToMeta' bps

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

198200 g _ = MetaInlines []

199201fixAuthors mv = mv

200202

201−codeStyles :: [String]

202−codeStyles = ["VerbatimChar"]

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

204+isInheritedFromStyles names sty

205+ | getStyleName sty `elem` names = True

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

207+ | otherwise = False

203208

204−codeDivs :: [String]

205−codeDivs = ["SourceCode"]

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

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+ ]

206226

207227runElemToInlines :: RunElem -> Inlines

208228runElemToInlines (TextRun s) = text s

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

228248parPartToString (ExternalHyperLink _ runs) = concatMap runToString runs

229249parPartToString _ = ""

230250

231−blacklistedCharStyles :: [String]

251+blacklistedCharStyles :: [CharStyleName]

232252blacklistedCharStyles = ["Hyperlink"]

233253

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

235255resolveDependentRunStyle rPr

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

256+ | Just s <- rParentStyle rPr

257+ , getStyleName s `elem` blacklistedCharStyles =

237258 return rPr

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

259+ | Just s <- rParentStyle rPr = do

239260 opts <- asks docxOptions

240261 if isEnabled Ext_styles opts

241262 then return rPr

242− else do rPr' <- resolveDependentRunStyle cs

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− }

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

267264 | otherwise = return rPr

268265

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

270267runStyleToTransform rPr

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

272− , s `elem` spansToKeep = do

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

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

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

276− opts <- asks docxOptions

277− let extraInfo = if isEnabled Ext_styles opts

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

279− else id

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

281− return $ extraInfo . transform

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

269+ , sn `elem` spansToKeep = do

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

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

272+ | Just s <- rParentStyle rPr = do

273+ ei <- extraInfo spanWith s

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

275+ return $ ei . transform

282276 | Just True <- isItalic rPr = do

283277 transform <- runStyleToTransform rPr{isItalic = Nothing}

284278 return $ emph . transform

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

310304

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

312306runToInlines (Run rs runElems)

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

314− , s `elem` codeStyles = do

307+ | maybe False isCodeCharStyle $ rParentStyle rs = do

315308 rPr <- resolveDependentRunStyle rs

316309 let codeString = code $ concatMap runElemToString runElems

317310 return $ case rVertAlign rPr of

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

526519 isSp LineBreak = True

527520 isSp _ = False

528521

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+

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

530531parStyleToTransform pPr

531532 | (c:cs) <- pStyle pPr

532− , c `elem` divsToKeep = do

533+ , getStyleName c `elem` divsToKeep = do

533534 let pPr' = pPr { pStyle = cs }

534535 transform <- parStyleToTransform pPr'

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

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

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

537− c `elem` listParagraphDivs = do

538+ getStyleName c `elem` listParagraphStyles = do

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

539540 transform <- parStyleToTransform pPr'

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

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

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

542− opts <- asks docxOptions

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

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

544544 transform <- parStyleToTransform pPr'

545− let extraInfo = if isEnabled Ext_styles opts

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

547− else id

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

545+ ei <- extraInfo divWith c

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

549547 | null (pStyle pPr)

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

551549 let pPr' = pPr { indentation = Nothing }

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

553551 transform <- parStyleToTransform pPr'

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

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

555553 then blockQuote . transform

556554 else transform

557555parStyleToTransform _ = return id

558556

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

558+normalizeToClassName = map go . fromStyleName

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

560+ | otherwise = c

561+

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

560563bodyPartToBlocks (Paragraph pPr parparts)

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

564+ | isCodeDiv pPr = do

562565 transform <- parStyleToTransform pPr

563566 return $

564567 transform $

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

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

569572 (smushInlines <$> mapM parPartToInlines parparts)

570573 makeHeaderAnchor $

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

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

572575 | otherwise = do

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

574577 prevParaIls <- gets docxPrevPara

575578 dropIls <- gets docxDropCap

576579 let ils' = dropIls <> ils

577− if dropCap pPr

580+ let (paraOrPlain, pPr')

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

582+ | otherwise = (para, pPr)

583+ if dropCap pPr'

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

579585 return mempty

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

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

583589 ils'

584590 handleInsertion = do

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

586− transform <- parStyleToTransform pPr

587− return $ transform $ para ils''

592+ transform <- parStyleToTransform pPr'

593+ return $ transform $ paraOrPlain ils''

588594 opts <- asks docxOptions

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

590596 return mempty

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

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

592598 , AcceptChanges <- readerTrackChanges opts ->

593599 handleInsertion

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

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

595601 , RejectChanges <- readerTrackChanges opts -> do

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

597603 return mempty

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

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

599605 , AllChanges <- readerTrackChanges opts

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

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

602608 insertMark = spanWith attr mempty

603− transform <- parStyleToTransform pPr

609+ transform <- parStyleToTransform pPr'

604610 return $ transform $

605− para $ ils'' <> insertMark

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

611+ paraOrPlain $ ils'' <> insertMark

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

607613 , AcceptChanges <- readerTrackChanges opts -> do

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

609615 return mempty

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

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

611617 , RejectChanges <- readerTrackChanges opts ->

612618 handleInsertion

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

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

614620 , AllChanges <- readerTrackChanges opts

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

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

617623 insertMark = spanWith attr mempty

618− transform <- parStyleToTransform pPr

624+ transform <- parStyleToTransform pPr'

619625 return $ transform $

620− para $ ils'' <> insertMark

626+ paraOrPlain $ ils'' <> insertMark

621627 | otherwise -> handleInsertion

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

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

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

638644 blks <- bodyPartToBlocks (Paragraph pPr parparts)

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

640646bodyPartToBlocks (ListItem pPr _ _ _ parparts) =

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

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

642648 in

643649 bodyPartToBlocks $ Paragraph pPr' parparts

644650bodyPartToBlocks (Tbl _ _ _ []) =

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

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

11{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE OverloadedStrings #-}

23{- |

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

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

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

1516 , blocksToDefinitions

1617 , listParagraphDivs

18+ , listParagraphStyles

1719 ) where

1820

1921import Prelude

2022import Data.List

2123import Data.Maybe

24+import Data.String (fromString)

2225import Text.Pandoc.Generic (bottomUp)

2326import Text.Pandoc.JSON

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

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

2529

2630isListItem :: Block -> Bool

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

7983getListType _ = Nothing

8084

8185listParagraphDivs :: [String]

82−listParagraphDivs = ["ListParagraph"]

86+listParagraphDivs = ["list-paragraph"]

87+

88+listParagraphStyles :: [ParaStyleName]

89+listParagraphStyles = map fromString listParagraphDivs

8390

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

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

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

160167 reverse $ DefinitionList (reverse defAcc) : acc

161168blocksToDefinitions' defAcc acc

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

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

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

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

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

166173 in

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

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

170177 | "Definition" `elem` classes2 =

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

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

173− True -> blks2

174− False -> [Div remainingAttr2 blks2]

175− defAcc' = case null defItems of

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

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

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

180+ then blks2

181+ else [Div remainingAttr2 blks2]

182+ defAcc' = if null defItems

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

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

178185 in

179186 blocksToDefinitions' defAcc' acc blks

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

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

198205removeListDivs :: [Block] -> [Block]

199206removeListDivs = concatMap removeListDivs'

200207

201−

202−

203208blocksToDefinitions :: [Block] -> [Block]

204209blocksToDefinitions = blocksToDefinitions' [] []

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

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

11{-# LANGUAGE NoImplicitPrelude #-}

22{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE PatternGuards #-}

45{-# LANGUAGE ViewPatterns #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

59{- |

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

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

3135 , VertAlign(..)

3236 , ParIndentation(..)

3337 , ParagraphStyle(..)

38+ , ParStyle

39+ , CharStyle(cStyleData)

3440 , Row(..)

3541 , Cell(..)

3642 , TrackedChange(..)

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

3844 , ChangeInfo(..)

3945 , FieldInfo(..)

4046 , Level(..)

47+ , ParaStyleName

48+ , CharStyleName

49+ , FromStyleName(..)

50+ , HasStyleName(..)

51+ , HasParentStyle(..)

4152 , archiveToDocx

4253 , archiveToDocxWithWarnings

54+ , getStyleNames

55+ , pHeading

56+ , constructBogusParStyleData

57+ , leftBiasedMergeRunStyle

4358 ) where

4459import Prelude

4560import Codec.Archive.Zip

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

4964import Control.Monad.State.Strict

5065import Data.Bits ((.|.))

5166import qualified Data.ByteString.Lazy as B

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

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

5368import Data.List

69+import Data.Function (on)

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

5471import qualified Data.Map as M

5572import Data.Maybe

73+import Data.Coerce

5674import System.FilePath

5775import Text.Pandoc.Readers.Docx.Util

5876import Text.Pandoc.Readers.Docx.Fields

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

160178

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

162180

163−type CharStyle = (String, RunStyle)

181+type CharStyleMap = M.Map CharStyleId CharStyle

164182

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

170184

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

172186 deriving Show

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

213227data TrackedChange = TrackedChange ChangeType ChangeInfo

214228 deriving Show

215229

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

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

217231 , indentation :: Maybe ParIndentation

218232 , dropCap :: Bool

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

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

221− , pBlockQuote :: Maybe Bool

222233 , pChange :: Maybe TrackedChange

223234 }

224235 deriving Show

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

227238defaultParagraphStyle = ParagraphStyle { pStyle = []

228239 , indentation = Nothing

229240 , dropCap = False

230− , pHeading = Nothing

231− , pNumInfo = Nothing

232− , pBlockQuote = Nothing

233241 , pChange = Nothing

234242 }

235243

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

254262newtype Cell = Cell [BodyPart]

255263 deriving Show

256264

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+

257308-- (width, height) in EMUs

258309type Extent = Maybe (Double, Double)

259310

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

285336data VertAlign = BaseLn | SupScrpt | SubScrpt

286337 deriving Show

287338

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

289− , isItalic :: Maybe Bool

290− , isSmallCaps :: Maybe Bool

291− , isStrike :: Maybe Bool

292− , isRTL :: Maybe Bool

293− , rVertAlign :: Maybe VertAlign

294− , rUnderline :: Maybe String

295− , rStyle :: Maybe CharStyle

339+data CharStyle = CharStyle { cStyleId :: CharStyleId

340+ , cStyleName :: CharStyleName

341+ , cStyleData :: RunStyle

342+ } deriving (Show)

343+

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

345+ , isItalic :: Maybe Bool

346+ , isSmallCaps :: Maybe Bool

347+ , isStrike :: Maybe Bool

348+ , isRTL :: Maybe Bool

349+ , rVertAlign :: Maybe VertAlign

350+ , rUnderline :: Maybe String

351+ , rParentStyle :: Maybe CharStyle

296352 }

297353 deriving Show

298354

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

300− , isBlockQuote :: Maybe Bool

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

302− , psStyle :: Maybe ParStyle}

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

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

357+ , psParentStyle :: Maybe ParStyle

358+ , pStyleName :: ParaStyleName

359+ , pStyleId :: ParaStyleId

360+ }

303361 deriving Show

304362

305363defaultRunStyle :: RunStyle

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

310368 , isRTL = Nothing

311369 , rVertAlign = Nothing

312370 , rUnderline = Nothing

313− , rStyle = Nothing

371+ , rParentStyle = Nothing

314372 }

315373

316374type Target = String

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

390448elemToBody _ _ = throwError WrongElem

391449

392450archiveToStyles :: 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 =

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

395456 (parseXMLDoc . UTF8.toStringLazy . fromEntry)

396457 in

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

399460 Just styElem ->

400461 let namespaces = elemToNameSpaces styElem

401462 in

402− ( M.fromList $ buildBasedOnList namespaces styElem

403− (Nothing :: Maybe CharStyle),

404− M.fromList $ buildBasedOnList namespaces styElem

405− (Nothing :: Maybe ParStyle) )

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

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

406465

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

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

408467isBasedOnStyle ns element parentStyle

409468 | isElem ns "w" "style" element

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

411470 , styleType == cStyleType parentStyle

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

413472 findAttrByName ns "w" "val"

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

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

415474 | isElem ns "w" "style" element

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

417476 , styleType == cStyleType parentStyle

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

419478 , Nothing <- parentStyle = True

420479 | otherwise = False

421480

422−class ElemToStyle a where

481+class HasStyleId a => ElemToStyle a where

423482 cStyleType :: Maybe a -> String

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

425− getStyleId :: a -> String

484+

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

486+ type StyleId a

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+ }

426513

427514instance ElemToStyle CharStyle where

428515 cStyleType _ = "character"

429516 elemToStyle ns element parentStyle

430517 | isElem ns "w" "style" element

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

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

433− Just (styleId, elemToRunStyle ns element parentStyle)

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

519+ elemToCharStyle ns element parentStyle

434520 | otherwise = Nothing

435− getStyleId s = fst s

521+

522+instance HasStyleId CharStyle where

523+ type StyleId CharStyle = CharStyleId

524+ getStyleId = cStyleId

525+

526+instance HasStyleName CharStyle where

527+ type StyleName CharStyle = CharStyleName

528+ getStyleName = cStyleName

436529

437530instance ElemToStyle ParStyle where

438531 cStyleType _ = "paragraph"

439532 elemToStyle ns element parentStyle

440533 | isElem ns "w" "style" element

441534 , 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

444536 | otherwise = Nothing

445− getStyleId s = fst s

537+

538+instance HasStyleId ParStyle where

539+ type StyleId ParStyle = ParaStyleId

540+ getStyleId = pStyleId

541+

542+instance HasStyleName ParStyle where

543+ type StyleName ParStyle = ParaStyleName

544+ getStyleName = pStyleName

446545

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

448547getStyleChildren ns element parentStyle

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

693792stringToInteger :: String -> Maybe Integer

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

695794

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

796+pHeading = getParStyleField headingLev . pStyle

797+

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

799+pNumInfo = getParStyleField numInfo . pStyle

800+

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

697802elemToBodyPart ns element

698803 | isElem ns "w" "p" element

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

10031108 return $ Run runStyle runElems

10041109elemToRun _ _ = throwError WrongElem

10051110

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

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

10071112getParentStyleValue field style

10081113 | Just value <- field style = Just value

1009− | Just parentStyle <- psStyle style

1010− = getParentStyleValue field (snd parentStyle)

1114+ | Just parentStyle <- psParentStyle style

1115+ = getParentStyleValue field parentStyle

10111116getParentStyleValue _ _ = Nothing

10121117

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

1014− Maybe a

1015−getParStyleField field stylemap styles

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

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

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

1119+getParStyleField field styles

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

10181121 = Just y

1019−getParStyleField _ _ _ = Nothing

1122+getParStyleField _ _ = Nothing

10201123

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

10221125getTrackedChange ns element

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

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

10391142 let style =

10401143 mapMaybe

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

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

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

10431146 in ParagraphStyle

1044− {pStyle = style

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

10451148 , indentation =

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

10471150 elemToParIndentation ns

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

10531156 Just "none" -> False

10541157 Just _ -> True

10551158 Nothing -> False

1056− , pHeading = getParStyleField headingLev sty style

1057− , pNumInfo = getParStyleField numInfo sty style

1058− , pBlockQuote = getParStyleField isBlockQuote sty style

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

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

10611161 isElem ns "w" "moveTo" e ||

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

10851185elemToRunStyleD ns element

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

10871187 charStyles <- asks envCharStyles

1088− let parentSty = case

1188+ let parentSty =

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

1090− findAttrByName ns "w" "val"

1091− of

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

1093− Just (styName, style)

1094− _ -> Nothing

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

1191+ flip M.lookup charStyles . CharStyleId

10951192 return $ elemToRunStyle ns element parentSty

10961193elemToRunStyleD _ _ = return defaultRunStyle

10971194

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+

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

10991203elemToRunStyle ns element parentStyle

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

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

11171221 , rUnderline =

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

11191223 findAttrByName ns "w" "val"

1120− , rStyle = parentStyle

1224+ , rParentStyle = parentStyle

11211225 }

11221226elemToRunStyle _ _ _ = defaultRunStyle

11231227

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

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

11251229getHeaderLevel ns element

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

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

1128− , Just n <- stringToInteger index

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 "

1134− , Just n <- stringToInteger index

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

1230+ | Just styleName <- getElementStyleName ns element

1231+ , Just n <- stringToInteger =<<

1232+ (stripPrefix "heading " . map toLower $

1233+ fromStyleName styleName)

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

11361235getHeaderLevel _ _ = Nothing

11371236

1138−blockQuoteStyleIds :: [String]

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

1140−

1141−blockQuoteStyleNames :: [String]

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

1143−

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

1145−getBlockQuote ns element

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"

1150− , styleName `elem` blockQuoteStyleNames = Just True

1151−getBlockQuote _ _ = Nothing

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

1238+getElementStyleName ns el = coerce <$>

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

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

11521241

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

11541243getNumInfo ns element = do

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

11631252 return (numId, lvl)

11641253

11651254

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

1167−elemToParStyleData ns element parentStyle =

1168− ParStyleData

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

1256+elemToParStyleData ns element parentStyle

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

1258+ , Just styleName <- getElementStyleName ns element

1259+ = Just $ ParStyle

11691260 {

11701261 headingLev = getHeaderLevel ns element

1171− , isBlockQuote = getBlockQuote ns element

11721262 , numInfo = getNumInfo ns element

1173− , psStyle = parentStyle

1174− }

1263+ , psParentStyle = parentStyle

1264+ , pStyleName = styleName

1265+ , pStyleId = ParaStyleId styleId

1266+ }

1267+elemToParStyleData _ _ _ = Nothing

11751268

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

11771270elemToRunElem ns element

test/Tests/Readers/Docx.hs+9

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

255255 "lists"

256256 "docx/lists.docx"

257257 "docx/lists.native"

258+ , testCompare

259+ "compact lists"

260+ "docx/lists-compact.docx"

261+ "docx/lists-compact.native"

258262 , testCompare

259263 "lists with level overrides"

260264 "docx/lists_level_override.docx"

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

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

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

427431 "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"

428437 ]

429438 , testGroup "metadata"

430439 [ 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