780079a · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Merge branch 'lierdakil-docx-reader-styles'

780079aJohn MacFarlane7 years ago

.gitignore+1

compare with master

unifiedsplit

@@ -23,3 +23,4 @@ windows/*.wixobj

23data/reference.docx

24data/reference.odt

25.stack-work

26+cabal.project.local

MANUAL.txt+3−3

@@ -5321,17 +5321,17 @@ And with the extension:

5321

5322 $ pandoc test/docx/custom-style-reference.docx -f docx+styles -t markdown

5323

5324− ::: {custom-style="FirstParagraph"}

5324+ ::: {custom-style="First Paragraph"}

5325 This is some text.

5326 :::

5327

5328− ::: {custom-style="BodyText"}

5328+ ::: {custom-style="Body Text"}

5329 This is text with an [emphasized]{custom-style="Emphatic"} text style.

5330 And this is text with a [strengthened]{custom-style="Strengthened"}

5331 text style.

5332 :::

5333

5334− ::: {custom-style="MyBlockStyle"}

5334+ ::: {custom-style="My Block Style"}

5335 > Here is a styled paragraph that inherits from Block Text.

5336 :::

5337

src/Text/Pandoc/Readers/Docx.hs+99−113

@@ -2,6 +2,8 @@

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PatternGuards #-}

5+{-# LANGUAGE MultiWayIf #-}

6+{-# LANGUAGE FlexibleContexts #-}

5{- |

7{- |

6 Module : Text.Pandoc.Readers.Docx

8 Module : Text.Pandoc.Readers.Docx

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

64import qualified Data.ByteString.Lazy as B

66import qualified Data.ByteString.Lazy as B

65import Data.Default (Default)

67import Data.Default (Default)

66import Data.List (delete, intersect)

68import Data.List (delete, intersect)

69+import Data.Char (isSpace)

67import qualified Data.Map as M

70import qualified Data.Map as M

68import Data.Maybe (isJust, fromMaybe)

71import Data.Maybe (isJust, fromMaybe)

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

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

@@ -129,16 +132,16 @@ instance Default DEnv where

129type DocxContext m = ReaderT DEnv (StateT DState m)

132type DocxContext m = ReaderT DEnv (StateT DState m)

130

133

131evalDocxContext :: PandocMonad m => DocxContext m a -> DEnv -> DState -> m a

134evalDocxContext :: PandocMonad m => DocxContext m a -> DEnv -> DState -> m a

132−evalDocxContext ctx env st = flip evalStateT st $flip runReaderT env ctx

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

133

136

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

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

135−spansToKeep :: [String]

138+spansToKeep :: [CharStyleName]

136spansToKeep = []

139spansToKeep = []

137

140

138−divsToKeep :: [String]

141+divsToKeep :: [ParaStyleName]

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

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

140

143

141−metaStyles :: M.Map String String

144+metaStyles :: M.Map ParaStyleName String

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

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

143 , ("Subtitle", "subtitle")

146 , ("Subtitle", "subtitle")

144 , ("Author", "author")

147 , ("Author", "author")

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

150

153

151isMetaPar :: BodyPart -> Bool

154isMetaPar :: BodyPart -> Bool

152isMetaPar (Paragraph pPr _) =

155isMetaPar (Paragraph pPr _) =

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

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

154isMetaPar _ = False

157isMetaPar _ = False

155

158

156isEmptyPar :: BodyPart -> Bool

159isEmptyPar :: BodyPart -> Bool

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

167bodyPartsToMeta' [] = return M.empty

170bodyPartsToMeta' [] = return M.empty

168bodyPartsToMeta' (bp : bps)

171bodyPartsToMeta' (bp : bps)

169 | (Paragraph pPr parParts) <- bp

172 | (Paragraph pPr parParts) <- bp

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

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

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

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

172 inlines <- smushInlines <$> mapM parPartToInlines parParts

175 inlines <- smushInlines <$> mapM parPartToInlines parParts

173 remaining <- bodyPartsToMeta' bps

176 remaining <- bodyPartsToMeta' bps

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

197 g _ = MetaInlines []

200 g _ = MetaInlines []

198fixAuthors mv = mv

201fixAuthors mv = mv

199

202

200−codeStyles :: [String]

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

201−codeStyles = ["VerbatimChar"]

204+isInheritedFromStyles names sty

205+ | getStyleName sty `elem` names = True

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

207+ | otherwise = False

202

208

203−codeDivs :: [String]

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

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

205

226

206runElemToInlines :: RunElem -> Inlines

227runElemToInlines :: RunElem -> Inlines

207runElemToInlines (TextRun s) = text s

228runElemToInlines (TextRun s) = text s

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

227parPartToString (ExternalHyperLink _ runs) = concatMap runToString runs

248parPartToString (ExternalHyperLink _ runs) = concatMap runToString runs

228parPartToString _ = ""

249parPartToString _ = ""

229

250

230−blacklistedCharStyles :: [String]

251+blacklistedCharStyles :: [CharStyleName]

231blacklistedCharStyles = ["Hyperlink"]

252blacklistedCharStyles = ["Hyperlink"]

232

253

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

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

234resolveDependentRunStyle rPr

255resolveDependentRunStyle rPr

256+ | Just s <- rParentStyle rPr

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

257+ , getStyleName s `elem` blacklistedCharStyles =

236 return rPr

258 return rPr

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

259+ | Just s <- rParentStyle rPr = do

238 opts <- asks docxOptions

260 opts <- asks docxOptions

239 if isEnabled Ext_styles opts

261 if isEnabled Ext_styles opts

240 then return rPr

262 then return rPr

241− else do rPr' <- resolveDependentRunStyle cs

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

242− return $

243− RunStyle { isBold = case isBold rPr of

244− Just bool -> Just bool

245− Nothing -> isBold rPr'

246− , isItalic = case isItalic rPr of

247− Just bool -> Just bool

248− Nothing -> isItalic rPr'

249− , isSmallCaps = case isSmallCaps rPr of

250− Just bool -> Just bool

251− Nothing -> isSmallCaps rPr'

252− , isStrike = case isStrike rPr of

253− Just bool -> Just bool

254− Nothing -> isStrike rPr'

255− , isRTL = case isRTL rPr of

256− Just bool -> Just bool

257− Nothing -> isRTL rPr'

258− , rVertAlign = case rVertAlign rPr of

259− Just valign -> Just valign

260− Nothing -> rVertAlign rPr'

261− , rUnderline = case rUnderline rPr of

262− Just ulstyle -> Just ulstyle

263− Nothing -> rUnderline rPr'

264− , rStyle = rStyle rPr

265− }

266 | otherwise = return rPr

264 | otherwise = return rPr

267

265

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

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

269runStyleToTransform rPr

267runStyleToTransform rPr

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

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

271− , s `elem` spansToKeep = do

269+ , sn `elem` spansToKeep = do

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

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

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

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

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

272+ | Just s <- rParentStyle rPr = do

275− opts <- asks docxOptions

276− let extraInfo = if isEnabled Ext_styles opts

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

273+ ei <- extraInfo spanWith s

278− else id

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

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

280− return $ extraInfo . transform

275+ return $ ei . transform

281 | Just True <- isItalic rPr = do

276 | Just True <- isItalic rPr = do

282 transform <- runStyleToTransform rPr{isItalic = Nothing}

277 transform <- runStyleToTransform rPr{isItalic = Nothing}

283 return $ emph . transform

278 return $ emph . transform

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

309

304

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

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

311runToInlines (Run rs runElems)

306runToInlines (Run rs runElems)

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

307+ | maybe False isCodeCharStyle $ rParentStyle rs = do

313− , s `elem` codeStyles = do

314 rPr <- resolveDependentRunStyle rs

308 rPr <- resolveDependentRunStyle rs

315 let codeString = code $ concatMap runElemToString runElems

309 let codeString = code $ concatMap runElemToString runElems

316 return $ case rVertAlign rPr of

310 return $ case rVertAlign rPr of

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

525 isSp LineBreak = True

519 isSp LineBreak = True

526 isSp _ = False

520 isSp _ = False

527

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+

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

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

529parStyleToTransform pPr

531parStyleToTransform pPr

530 | (c:cs) <- pStyle pPr

532 | (c:cs) <- pStyle pPr

531− , c `elem` divsToKeep = do

533+ , getStyleName c `elem` divsToKeep = do

532 let pPr' = pPr { pStyle = cs }

534 let pPr' = pPr { pStyle = cs }

533 transform <- parStyleToTransform pPr'

535 transform <- parStyleToTransform pPr'

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

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

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

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

536− c `elem` listParagraphDivs = do

538+ getStyleName c `elem` listParagraphStyles = do

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

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

538 transform <- parStyleToTransform pPr'

540 transform <- parStyleToTransform pPr'

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

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

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

541− , Just True <- pBlockQuote pPr = do

542− opts <- asks docxOptions

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

544− transform <- parStyleToTransform pPr'

545− let extraInfo = if isEnabled Ext_styles opts

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

547− else id

548− return $ extraInfo . blockQuote . transform

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

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

550− opts <- asks docxOptions

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

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

552 transform <- parStyleToTransform pPr'

544 transform <- parStyleToTransform pPr'

553− let extraInfo = if isEnabled Ext_styles opts

545+ ei <- extraInfo divWith c

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

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

555− else id

556− return $ extraInfo . transform

557 | null (pStyle pPr)

547 | null (pStyle pPr)

558− , Just left <- indentation pPr >>= leftParIndent

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

559− , Just hang <- indentation pPr >>= hangingParIndent = do

560 let pPr' = pPr { indentation = Nothing }

549 let pPr' = pPr { indentation = Nothing }

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

561 transform <- parStyleToTransform pPr'

551 transform <- parStyleToTransform pPr'

562− return $ case (left - hang) > 0 of

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

563− True -> blockQuote . transform

553+ then blockQuote . transform

564− False -> transform

565− | null (pStyle pPr),

566− Just left <- indentation pPr >>= leftParIndent = do

567− let pPr' = pPr { indentation = Nothing }

568− transform <- parStyleToTransform pPr'

569− return $ case left > 0 of

570− True -> blockQuote . transform

571− False -> transform

554+ else transform

572parStyleToTransform _ = return id

555parStyleToTransform _ = return id

573

556

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

558+normalizeToClassName = map go . fromStyleName

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

560+ | otherwise = c

561+

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

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

575bodyPartToBlocks (Paragraph pPr parparts)

563bodyPartToBlocks (Paragraph pPr parparts)

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

564+ | isCodeDiv pPr = do

577 transform <- parStyleToTransform pPr

565 transform <- parStyleToTransform pPr

578 return $

566 return $

579 transform $

567 transform $

@@ -583,62 +571,60 @@ bodyPartToBlocks (Paragraph pPr parparts)

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

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

584 (smushInlines <$> mapM parPartToInlines parparts)

572 (smushInlines <$> mapM parPartToInlines parparts)

585 makeHeaderAnchor $

573 makeHeaderAnchor $

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

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

587 | otherwise = do

575 | otherwise = do

588− ils <- (trimSps . smushInlines) <$> mapM parPartToInlines parparts

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

589 prevParaIls <- gets docxPrevPara

577 prevParaIls <- gets docxPrevPara

590 dropIls <- gets docxDropCap

578 dropIls <- gets docxDropCap

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

592− if dropCap pPr

583+ if dropCap pPr'

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

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

594 return mempty

585 return mempty

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

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

596 let ils'' = prevParaIls <>

587 let ils'' = prevParaIls <>

597 (if isNull prevParaIls then mempty else space) <>

588 (if isNull prevParaIls then mempty else space) <>

598 ils'

589 ils'

590+ handleInsertion = do

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

592+ transform <- parStyleToTransform pPr'

593+ return $ transform $ paraOrPlain ils''

599 opts <- asks docxOptions

594 opts <- asks docxOptions

600− case () of

601−

602− _ | isNull ils'' && not (isEnabled Ext_empty_paragraphs opts) ->

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

603 return mempty

596 return mempty

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

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

605− , AcceptChanges <- readerTrackChanges opts -> do

598+ , AcceptChanges <- readerTrackChanges opts ->

606− modify $ \s -> s {docxPrevPara = mempty}

599+ handleInsertion

607− transform <- parStyleToTransform pPr

608− return $ transform $ para ils''

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

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

610 , RejectChanges <- readerTrackChanges opts -> do

601 , RejectChanges <- readerTrackChanges opts -> do

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

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

612 return mempty

603 return mempty

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

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

614 , AllChanges <- readerTrackChanges opts

605 , AllChanges <- readerTrackChanges opts

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

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

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

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

617 insertMark = spanWith attr mempty

608 insertMark = spanWith attr mempty

618− transform <- parStyleToTransform pPr

609+ transform <- parStyleToTransform pPr'

619 return $ transform $

610 return $ transform $

620− para $ ils'' <> insertMark

611+ paraOrPlain $ ils'' <> insertMark

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

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

622 , AcceptChanges <- readerTrackChanges opts -> do

613 , AcceptChanges <- readerTrackChanges opts -> do

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

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

624 return mempty

615 return mempty

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

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

626− , RejectChanges <- readerTrackChanges opts -> do

617+ , RejectChanges <- readerTrackChanges opts ->

627− modify $ \s -> s {docxPrevPara = mempty}

618+ handleInsertion

628− transform <- parStyleToTransform pPr

629− return $ transform $ para ils''

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

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

631 , AllChanges <- readerTrackChanges opts

620 , AllChanges <- readerTrackChanges opts

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

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

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

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

634 insertMark = spanWith attr mempty

623 insertMark = spanWith attr mempty

635− transform <- parStyleToTransform pPr

624+ transform <- parStyleToTransform pPr'

636 return $ transform $

625 return $ transform $

637− para $ ils'' <> insertMark

626+ paraOrPlain $ ils'' <> insertMark

638− _ | otherwise -> do

627+ | otherwise -> handleInsertion

639− modify $ \s -> s {docxPrevPara = mempty}

640− transform <- parStyleToTransform pPr

641− return $ transform $ para ils''

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

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

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

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

644 -- since Docx expects us to pick up where we left off.

630 -- since Docx expects us to pick up where we left off.

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

658 blks <- bodyPartToBlocks (Paragraph pPr parparts)

644 blks <- bodyPartToBlocks (Paragraph pPr parparts)

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

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

660bodyPartToBlocks (ListItem pPr _ _ _ parparts) =

646bodyPartToBlocks (ListItem pPr _ _ _ parparts) =

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

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

662 in

648 in

663 bodyPartToBlocks $ Paragraph pPr' parparts

649 bodyPartToBlocks $ Paragraph pPr' parparts

664bodyPartToBlocks (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+202−113

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

@@ -121,9 +139,9 @@ unwrap :: NameSpaces -> Content -> [Content]

121unwrap ns (Elem element)

139unwrap ns (Elem element)

122 | isElem ns "w" "sdt" element

140 | isElem ns "w" "sdt" element

123 , Just sdtContent <- findChildByName ns "w" "sdtContent" element

141 , Just sdtContent <- findChildByName ns "w" "sdtContent" element

124− = concatMap ((unwrap ns) . Elem) (elChildren sdtContent)

142+ = concatMap (unwrap ns . Elem) (elChildren sdtContent)

125 | isElem ns "w" "smartTag" element

143 | isElem ns "w" "smartTag" element

126− = concatMap ((unwrap ns) . Elem) (elChildren element)

144+ = concatMap (unwrap ns . Elem) (elChildren element)

127unwrap _ content = [content]

145unwrap _ content = [content]

128

146

129unwrapChild :: NameSpaces -> Content -> Content

147unwrapChild :: NameSpaces -> Content -> Content

@@ -149,24 +167,20 @@ walkDocument ns element =

149 _ -> Nothing

167 _ -> Nothing

150

168

151

169

152−data Docx = Docx Document

170+newtype Docx = Docx Document

153 deriving Show

171 deriving Show

154

172

155data Document = Document NameSpaces Body

173data Document = Document NameSpaces Body

156 deriving Show

174 deriving Show

157

175

158−data Body = Body [BodyPart]

176+newtype Body = Body [BodyPart]

159 deriving Show

177 deriving Show

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

@@ -242,18 +250,61 @@ data BodyPart = Paragraph ParagraphStyle [ParPart]

242

250

243type TblGrid = [Integer]

251type TblGrid = [Integer]

244

252

245−data TblLook = TblLook {firstRowFormatting::Bool}

253+newtype TblLook = TblLook {firstRowFormatting::Bool}

246 deriving Show

254 deriving Show

247

255

248defaultTblLook :: TblLook

256defaultTblLook :: TblLook

249defaultTblLook = TblLook{firstRowFormatting = False}

257defaultTblLook = TblLook{firstRowFormatting = False}

250

258

251−data Row = Row [Cell]

259+newtype Row = Row [Cell]

252 deriving Show

260 deriving Show

253

261

254−data Cell = Cell [BodyPart]

262+newtype 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

@@ -495,7 +594,7 @@ filePathToRelType "word/_rels/endnotes.xml.rels" _ = Just InEndnote

495-- -- to see if it's a documentPath, we have to check against the dynamic

594-- -- to see if it's a documentPath, we have to check against the dynamic

496-- -- docPath specified in "_rels/.rels"

595-- -- docPath specified in "_rels/.rels"

497filePathToRelType path docXmlPath =

596filePathToRelType path docXmlPath =

498− if path == "word/_rels/" ++ (takeFileName docXmlPath) ++ ".rels"

597+ if path == "word/_rels/" ++ takeFileName docXmlPath ++ ".rels"

499 then Just InDocument

598 then Just InDocument

500 else Nothing

599 else Nothing

501

600

@@ -537,7 +636,7 @@ lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do

537 case lvlOverride of

636 case lvlOverride of

538 Just (LevelOverride _ _ (Just lvl')) -> Just lvl'

637 Just (LevelOverride _ _ (Just lvl')) -> Just lvl'

539 Just (LevelOverride _ (Just strt) _) ->

638 Just (LevelOverride _ (Just strt) _) ->

540− lookup ilvl $ map (\(Level i fmt s _) -> (i, (Level i fmt s (Just strt)))) lvls

639+ lookup ilvl $ map (\(Level i fmt s _) -> (i, Level i fmt s (Just strt))) lvls

541 _ ->

640 _ ->

542 lookup ilvl $ map (\l@(Level i _ _ _) -> (i, l)) lvls

641 lookup ilvl $ map (\l@(Level i _ _ _) -> (i, l)) lvls

543

642

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

@@ -703,23 +808,19 @@ elemToBodyPart ns element

703elemToBodyPart ns element

808elemToBodyPart ns element

704 | isElem ns "w" "p" element

809 | isElem ns "w" "p" element

705 , Just (numId, lvl) <- getNumInfo ns element = do

810 , Just (numId, lvl) <- getNumInfo ns element = do

706− sty <- asks envParStyles

707− let parstyle = elemToParagraphStyle ns element sty

811+ parstyle <- elemToParagraphStyle ns element <$> asks envParStyles

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

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

709− num <- asks envNumbering

710− let levelInfo = lookupLevel numId lvl num

813+ levelInfo <- lookupLevel numId lvl <$> asks envNumbering

711 return $ ListItem parstyle numId lvl levelInfo parparts

814 return $ ListItem parstyle numId lvl levelInfo parparts

712elemToBodyPart ns element

815elemToBodyPart ns element

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

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

714− sty <- asks envParStyles

715− let parstyle = elemToParagraphStyle ns element sty

817+ parstyle <- elemToParagraphStyle ns element <$> asks envParStyles

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

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

717 -- Word uses list enumeration for numbered headings, so we only

819 -- Word uses list enumeration for numbered headings, so we only

718 -- want to infer a list from the styles if it is NOT a heading.

820 -- want to infer a list from the styles if it is NOT a heading.

719 case pHeading parstyle of

821 case pHeading parstyle of

720 Nothing | Just (numId, lvl) <- pNumInfo parstyle -> do

822 Nothing | Just (numId, lvl) <- pNumInfo parstyle -> do

721− num <- asks envNumbering

722− let levelInfo = lookupLevel numId lvl num

823+ levelInfo <- lookupLevel numId lvl <$> asks envNumbering

723 return $ ListItem parstyle numId lvl levelInfo parparts

824 return $ ListItem parstyle numId lvl levelInfo parparts

724 _ -> return $ Paragraph parstyle parparts

825 _ -> return $ Paragraph parstyle parparts

725elemToBodyPart ns element

826elemToBodyPart ns element

@@ -727,7 +828,7 @@ elemToBodyPart ns element

727 let caption' = findChildByName ns "w" "tblPr" element

828 let caption' = findChildByName ns "w" "tblPr" element

728 >>= findChildByName ns "w" "tblCaption"

829 >>= findChildByName ns "w" "tblCaption"

729 >>= findAttrByName ns "w" "val"

830 >>= findAttrByName ns "w" "val"

730− caption = (fromMaybe "" caption')

831+ caption = fromMaybe "" caption'

731 grid' = case findChildByName ns "w" "tblGrid" element of

832 grid' = case findChildByName ns "w" "tblGrid" element of

732 Just g -> elemToTblGrid ns g

833 Just g -> elemToTblGrid ns g

733 Nothing -> return []

834 Nothing -> return []

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

1007 return $ Run runStyle runElems

1108 return $ Run runStyle runElems

1008elemToRun _ _ = throwError WrongElem

1109elemToRun _ _ = throwError WrongElem

1009

1110

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

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

1011getParentStyleValue field style

1112getParentStyleValue field style

1012 | Just value <- field style = Just value

1113 | Just value <- field style = Just value

1013− | Just parentStyle <- psStyle style

1114+ | Just parentStyle <- psParentStyle style

1014− = getParentStyleValue field (snd parentStyle)

1115+ = getParentStyleValue field parentStyle

1015getParentStyleValue _ _ = Nothing

1116getParentStyleValue _ _ = Nothing

1016

1117

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

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

1018− Maybe a

1019−getParStyleField field stylemap styles

1119+getParStyleField field styles

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

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

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

1022 = Just y

1121 = Just y

1023−getParStyleField _ _ _ = Nothing

1122+getParStyleField _ _ = Nothing

1024

1123

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

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

1026getTrackedChange ns element

1125getTrackedChange ns element

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

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

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

1043 let style =

1142 let style =

1044 mapMaybe

1143 mapMaybe

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

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

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

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

1047 in ParagraphStyle

1146 in ParagraphStyle

1048− {pStyle = style

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

1049 , indentation =

1148 , indentation =

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

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

1051 elemToParIndentation ns

1150 elemToParIndentation ns

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

1057 Just "none" -> False

1156 Just "none" -> False

1058 Just _ -> True

1157 Just _ -> True

1059 Nothing -> False

1158 Nothing -> False

1060− , pHeading = getParStyleField headingLev sty style

1061− , pNumInfo = getParStyleField numInfo sty style

1062− , pBlockQuote = getParStyleField isBlockQuote sty style

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

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

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

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

1065 isElem ns "w" "moveTo" e ||

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

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

1089elemToRunStyleD ns element

1185elemToRunStyleD ns element

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

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

1091 charStyles <- asks envCharStyles

1187 charStyles <- asks envCharStyles

1092− let parentSty = case

1188+ let parentSty =

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

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

1094− findAttrByName ns "w" "val"

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

1095− of

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

1191+ flip M.lookup charStyles . CharStyleId

1097− Just (styName, style)

1098− _ -> Nothing

1099 return $ elemToRunStyle ns element parentSty

1192 return $ elemToRunStyle ns element parentSty

1100elemToRunStyleD _ _ = return defaultRunStyle

1193elemToRunStyleD _ _ = return defaultRunStyle

1101

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+

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

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

1103elemToRunStyle ns element parentStyle

1203elemToRunStyle ns element parentStyle

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

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

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

1121 , rUnderline =

1221 , rUnderline =

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

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

1123 findAttrByName ns "w" "val"

1223 findAttrByName ns "w" "val"

1124− , rStyle = parentStyle

1224+ , rParentStyle = parentStyle

1125 }

1225 }

1126elemToRunStyle _ _ _ = defaultRunStyle

1226elemToRunStyle _ _ _ = defaultRunStyle

1127

1227

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

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

1129getHeaderLevel ns element

1229getHeaderLevel ns element

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

1230+ | Just styleName <- getElementStyleName ns element

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

1132− , Just n <- stringToInteger index

1231+ , Just n <- stringToInteger =<<

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

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

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

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

1137− stripPrefix "heading "

1232+ (stripPrefix "heading " . map toLower $

1138− , Just n <- stringToInteger index

1233+ fromStyleName styleName)

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

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

1140getHeaderLevel _ _ = Nothing

1235getHeaderLevel _ _ = Nothing

1141

1236

1142−blockQuoteStyleIds :: [String]

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

1144−

1145−blockQuoteStyleNames :: [String]

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

1147−

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

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

1149−getBlockQuote ns element

1238+getElementStyleName ns el = coerce <$>

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

1151− , styleId `elem` blockQuoteStyleIds = Just True

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

1153− findAttrByName ns "w" "val"

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

1154− , styleName `elem` blockQuoteStyleNames = Just True

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

1155−getBlockQuote _ _ = Nothing

1156

1241

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

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

1158getNumInfo ns element = do

1243getNumInfo ns element = do

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

1167 return (numId, lvl)

1252 return (numId, lvl)

1168

1253

1169

1254

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

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

1171−elemToParStyleData ns element parentStyle =

1256+elemToParStyleData ns element parentStyle

1172− ParStyleData

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

1258+ , Just styleName <- getElementStyleName ns element

1259+ = Just $ ParStyle

1173 {

1260 {

1174 headingLev = getHeaderLevel ns element

1261 headingLev = getHeaderLevel ns element

1175− , isBlockQuote = getBlockQuote ns element

1176 , numInfo = getNumInfo ns element

1262 , numInfo = getNumInfo ns element

1177− , psStyle = parentStyle

1263+ , psParentStyle = parentStyle

1264+ , pStyleName = styleName

1265+ , pStyleId = ParaStyleId styleId

1178− }

1266+ }

1267+elemToParStyleData _ _ _ = Nothing

1179

1268

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

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

1181elemToRunElem ns element

1270elemToRunElem ns element

src/Text/Pandoc/Writers/Docx.hs+61−66

@@ -208,7 +208,7 @@ writeDocx opts doc@(Pandoc meta _) = do

208 let doc' = walk fixDisplayMath doc

209 username <- P.lookupEnv "USERNAME"

210 utctime <- P.getCurrentTime

211− distArchive <- (toArchive . BL.fromStrict) <$> do

211+ distArchive <- toArchive . BL.fromStrict <$> do

212 oldUserDataDir <- P.getUserDataDir

213 P.setUserDataDir Nothing

214 res <- P.readDefaultDataFile "reference.docx"

@@ -216,7 +216,7 @@ writeDocx opts doc@(Pandoc meta _) = do

216 return res

217 refArchive <- case writerReferenceDoc opts of

218 Just f -> toArchive <$> P.readFileLazy f

219− Nothing -> (toArchive . BL.fromStrict) <$>

219+ Nothing -> toArchive . BL.fromStrict <$>

220 P.readDataFile "reference.docx"

221

222 parsedDoc <- parseXml refArchive distArchive "word/document.xml"

@@ -237,7 +237,7 @@ writeDocx opts doc@(Pandoc meta _) = do

237 >>= subtrct mbAttrMarRight

238 >>= subtrct mbAttrMarLeft

239 where

240− subtrct mbStr = \x -> mbStr >>= safeRead >>= (\y -> Just $ x - y)

240+ subtrct mbStr x = mbStr >>= safeRead >>= (\y -> Just $ x - y)

241

242 -- styles

243 mblang <- toLang $ getLang opts meta

@@ -285,7 +285,7 @@ writeDocx opts doc@(Pandoc meta _) = do

285 envRTL = isRTLmeta

286 , envChangesAuthor = fromMaybe "unknown" username

287 , envChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime

288− , envPrintWidth = maybe 420 (\x -> quot x 20) pgContentWidth

288+ , envPrintWidth = maybe 420 (`quot` 20) pgContentWidth

289 }

290

291

@@ -366,7 +366,7 @@ writeDocx opts doc@(Pandoc meta _) = do

366 map (\x -> (maybe "" ("/word/" ++) $ extractTarget x,

367 "application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml")) footers) ++

368 map mkImageOverride imgs ++

369− map mkMediaOverride [ eRelativePath e | e <- zEntries refArchive

369+ [ mkMediaOverride (eRelativePath e) | e <- zEntries refArchive

370 , "word/media/" `isPrefixOf` eRelativePath e ]

371

372 let defaultnodes = [mknode "Default"

@@ -589,8 +589,8 @@ writeDocx opts doc@(Pandoc meta _) = do

589 mapMaybe (fmap ("word/" ++) . extractTarget)

590 (headers ++ footers)

591 let miscRelEntries = [ e | e <- zEntries refArchive

592− , "word/_rels/" `isPrefixOf` (eRelativePath e)

592+ , "word/_rels/" `isPrefixOf` eRelativePath e

593− , ".xml.rels" `isSuffixOf` (eRelativePath e)

593+ , ".xml.rels" `isSuffixOf` eRelativePath e

594 , eRelativePath e /= "word/_rels/document.xml.rels"

595 , eRelativePath e /= "word/_rels/footnotes.xml.rels" ]

596 let otherMediaEntries = [ e | e <- zEntries refArchive

@@ -778,24 +778,24 @@ makeTOC opts = do

778 tocTitle <- gets stTocTitle

779 title <- withParaPropM (pStyleM "TOC Heading") (blocksToOpenXML opts [Para tocTitle])

780 return

781− [mknode "w:sdt" [] ([

781+ [mknode "w:sdt" [] [

782 mknode "w:sdtPr" [] (

783− mknode "w:docPartObj" [] (

783+ mknode "w:docPartObj" []

784 [mknode "w:docPartGallery" [("w:val","Table of Contents")] (),

785 mknode "w:docPartUnique" [] ()]

786− ) -- w:docPartObj

786+ -- w:docPartObj

787 ), -- w:sdtPr

788 mknode "w:sdtContent" [] (title++[

789 mknode "w:p" [] (

790− mknode "w:r" [] ([

790+ mknode "w:r" [] [

791 mknode "w:fldChar" [("w:fldCharType","begin"),("w:dirty","true")] (),

792 mknode "w:instrText" [("xml:space","preserve")] tocCmd,

793 mknode "w:fldChar" [("w:fldCharType","separate")] (),

794 mknode "w:fldChar" [("w:fldCharType","end")] ()

795− ]) -- w:r

795+ ] -- w:r

796 ) -- w:p

797 ])

798− ])] -- w:sdt

798+ ]] -- w:sdt

799

800-- | Convert Pandoc document to two lists of

801-- OpenXML elements (the main document and footnotes).

@@ -809,12 +809,12 @@ writeOpenXML opts (Pandoc meta blocks) = do

809 let includeTOC = writerTableOfContents opts || lookupMetaBool "toc" meta

810 title <- withParaPropM (pStyleM "Title") $ blocksToOpenXML opts [Para tit | not (null tit)]

811 subtitle <- withParaPropM (pStyleM "Subtitle") $ blocksToOpenXML opts [Para subtitle' | not (null subtitle')]

812− authors <- withParaProp (pCustomStyle "Author") $ blocksToOpenXML opts $

812+ authors <- withParaPropM (pStyleM "Author") $ blocksToOpenXML opts $

813 map Para auths

814 date <- withParaPropM (pStyleM "Date") $ blocksToOpenXML opts [Para dat | not (null dat)]

815 abstract <- if null abstract'

816 then return []

817− else withParaProp (pCustomStyle "Abstract") $ blocksToOpenXML opts abstract'

817+ else withParaPropM (pStyleM "Abstract") $ blocksToOpenXML opts abstract'

818 let convertSpace (Str x : Space : Str y : xs) = Str (x ++ " " ++ y) : xs

819 convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs

820 convertSpace xs = xs

@@ -848,18 +848,12 @@ writeOpenXML opts (Pandoc meta blocks) = do

848blocksToOpenXML :: (PandocMonad m) => WriterOptions -> [Block] -> WS m [Element]

849blocksToOpenXML opts bls = concat `fmap` mapM (blockToOpenXML opts) bls

850

851−pCustomStyle :: String -> Element

852−pCustomStyle sty = mknode "w:pStyle" [("w:val",sty)] ()

853−

854pStyleM :: (PandocMonad m) => String -> WS m XML.Element

851pStyleM :: (PandocMonad m) => String -> WS m XML.Element

855pStyleM styleName = do

852pStyleM styleName = do

856 styleMaps <- gets stStyleMaps

853 styleMaps <- gets stStyleMaps

857 let sty' = getStyleId styleName $ sParaStyleMap styleMaps

854 let sty' = getStyleId styleName $ sParaStyleMap styleMaps

858 return $ mknode "w:pStyle" [("w:val",sty')] ()

855 return $ mknode "w:pStyle" [("w:val",sty')] ()

859

856

860−rCustomStyle :: String -> Element

861−rCustomStyle sty = mknode "w:rStyle" [("w:val",sty)] ()

862−

863rStyleM :: (PandocMonad m) => String -> WS m XML.Element

857rStyleM :: (PandocMonad m) => String -> WS m XML.Element

864rStyleM styleName = do

858rStyleM styleName = do

865 styleMaps <- gets stStyleMaps

859 styleMaps <- gets stStyleMaps

@@ -921,19 +915,19 @@ blockToOpenXML' opts (Header lev (ident,_,_) lst) = do

921blockToOpenXML' opts (Plain lst) = do

915blockToOpenXML' opts (Plain lst) = do

922 isInTable <- gets stInTable

916 isInTable <- gets stInTable

923 let block = blockToOpenXML opts (Para lst)

917 let block = blockToOpenXML opts (Para lst)

918+ prop <- pStyleM "Compact"

924− para <- if isInTable then withParaProp (pCustomStyle "Compact") block else block

919+ para <- if isInTable then withParaProp prop block else block

925 return $ para

920 return $ para

926−

927-- title beginning with fig: indicates that the image is a figure

921-- title beginning with fig: indicates that the image is a figure

928blockToOpenXML' opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) = do

922blockToOpenXML' opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) = do

929 setFirstPara

923 setFirstPara

930− let prop = pCustomStyle $

924+ prop <- pStyleM $

931 if null alt

925 if null alt

932 then "Figure"

926 then "Figure"

933− else "CaptionedFigure"

927+ else "Captioned Figure"

934 paraProps <- local (\env -> env { envParaProperties = EnvProps (Just prop) [] <> envParaProperties env }) (getParaProps False)

928 paraProps <- local (\env -> env { envParaProperties = EnvProps (Just prop) [] <> envParaProperties env }) (getParaProps False)

935 contents <- inlinesToOpenXML opts [Image attr alt (src,tit)]

929 contents <- inlinesToOpenXML opts [Image attr alt (src,tit)]

936− captionNode <- withParaProp (pCustomStyle "ImageCaption")

930+ captionNode <- withParaPropM (pStyleM "Image Caption")

937 $ blockToOpenXML opts (Para alt)

931 $ blockToOpenXML opts (Para alt)

938 return $ mknode "w:p" [] (paraProps ++ contents) : captionNode

932 return $ mknode "w:p" [] (paraProps ++ contents) : captionNode

939blockToOpenXML' opts (Para lst)

933blockToOpenXML' opts (Para lst)

@@ -944,10 +938,10 @@ blockToOpenXML' opts (Para lst)

944 [x] -> isDisplayMath x

938 [x] -> isDisplayMath x

945 _ -> False

939 _ -> False

946 paraProps <- getParaProps displayMathPara

940 paraProps <- getParaProps displayMathPara

941+ bodyTextStyle <- if isFirstPara

942+ then pStyleM "First Paragraph"

947− bodyTextStyle <- pStyleM "Body Text"

943+ else pStyleM "Body Text"

948 let paraProps' = case paraProps of

944 let paraProps' = case paraProps of

949− [] | isFirstPara -> [mknode "w:pPr" []

950− [pCustomStyle "FirstParagraph"]]

951 [] -> [mknode "w:pPr" [] [bodyTextStyle]]

945 [] -> [mknode "w:pPr" [] [bodyTextStyle]]

952 ps -> ps

946 ps -> ps

953 modify $ \s -> s { stFirstPara = False }

947 modify $ \s -> s { stFirstPara = False }

@@ -965,7 +959,7 @@ blockToOpenXML' opts (BlockQuote blocks) = do

965 setFirstPara

959 setFirstPara

966 return p

960 return p

967blockToOpenXML' opts (CodeBlock attrs@(ident, _, _) str) = do

961blockToOpenXML' opts (CodeBlock attrs@(ident, _, _) str) = do

968− p <- withParaProp (pCustomStyle "SourceCode") (blockToOpenXML opts $ Para [Code attrs str])

962+ p <- withParaPropM (pStyleM "Source Code") (blockToOpenXML opts $ Para [Code attrs str])

969 setFirstPara

963 setFirstPara

970 wrapBookmark ident p

964 wrapBookmark ident p

971blockToOpenXML' _ HorizontalRule = do

965blockToOpenXML' _ HorizontalRule = do

@@ -981,7 +975,7 @@ blockToOpenXML' opts (Table caption aligns widths headers rows) = do

981 let captionStr = stringify caption

975 let captionStr = stringify caption

982 caption' <- if null caption

976 caption' <- if null caption

983 then return []

977 then return []

984− else withParaProp (pCustomStyle "TableCaption")

978+ else withParaPropM (pStyleM "Table Caption")

985 $ blockToOpenXML opts (Para caption)

979 $ blockToOpenXML opts (Para caption)

986 let alignmentFor al = mknode "w:jc" [("w:val",alignmentToString al)] ()

980 let alignmentFor al = mknode "w:jc" [("w:val",alignmentToString al)] ()

987 -- Table cells require a <w:p> element, even an empty one!

981 -- Table cells require a <w:p> element, even an empty one!

@@ -997,7 +991,8 @@ blockToOpenXML' opts (Table caption aligns widths headers rows) = do

997 [ mknode "w:tcBorders" []

991 [ mknode "w:tcBorders" []

998 $ mknode "w:bottom" [("w:val","single")] ()

992 $ mknode "w:bottom" [("w:val","single")] ()

999 , mknode "w:vAlign" [("w:val","bottom")] () ]

993 , mknode "w:vAlign" [("w:val","bottom")] () ]

994+ compactStyle <- pStyleM "Compact"

1000− let emptyCell = [mknode "w:p" [] [mknode "w:pPr" [] [pCustomStyle "Compact"]]]

995+ let emptyCell = [mknode "w:p" [] [mknode "w:pPr" [] [compactStyle]]]

1001 let mkcell border contents = mknode "w:tc" []

996 let mkcell border contents = mknode "w:tc" []

1002 $ [ borderProps | border ] ++

997 $ [ borderProps | border ] ++

1003 if null contents

998 if null contents

@@ -1030,20 +1025,17 @@ blockToOpenXML' opts (Table caption aligns widths headers rows) = do

1030 : [ mkrow True headers' | hasHeader ] ++

1025 : [ mkrow True headers' | hasHeader ] ++

1031 map (mkrow False) rows'

1026 map (mkrow False) rows'

1032 )]

1027 )]

1033−blockToOpenXML' opts (BulletList lst) = do

1028+blockToOpenXML' opts el

1034− let marker = BulletMarker

1029+ | BulletList lst <- el = addOpenXMLList BulletMarker lst

1035− addList marker

1036− numid <- getNumId

1037− l <- asList $ concat `fmap` mapM (listItemToOpenXML opts numid) lst

1038− setFirstPara

1039− return l

1040−blockToOpenXML' opts (OrderedList (start, numstyle, numdelim) lst) = do

1030+ | OrderedList (start, numstyle, numdelim) lst <- el

1041− let marker = NumberMarker numstyle numdelim start

1031+ = addOpenXMLList (NumberMarker numstyle numdelim start) lst

1032+ where

1033+ addOpenXMLList marker lst = do

1042− addList marker

1034+ addList marker

1043− numid <- getNumId

1035+ numid <- getNumId

1044− l <- asList $ concat `fmap` mapM (listItemToOpenXML opts numid) lst

1036+ l <- asList $ concat `fmap` mapM (listItemToOpenXML opts numid) lst

1045− setFirstPara

1037+ setFirstPara

1046− return l

1038+ return l

1047blockToOpenXML' opts (DefinitionList items) = do

1039blockToOpenXML' opts (DefinitionList items) = do

1048 l <- concat `fmap` mapM (definitionListItemToOpenXML opts) items

1040 l <- concat `fmap` mapM (definitionListItemToOpenXML opts) items

1049 setFirstPara

1041 setFirstPara

@@ -1051,9 +1043,9 @@ blockToOpenXML' opts (DefinitionList items) = do

1051

1043

1052definitionListItemToOpenXML :: (PandocMonad m) => WriterOptions -> ([Inline],[[Block]]) -> WS m [Element]

1044definitionListItemToOpenXML :: (PandocMonad m) => WriterOptions -> ([Inline],[[Block]]) -> WS m [Element]

1053definitionListItemToOpenXML opts (term,defs) = do

1045definitionListItemToOpenXML opts (term,defs) = do

1054− term' <- withParaProp (pCustomStyle "DefinitionTerm")

1046+ term' <- withParaPropM (pStyleM "Definition Term")

1055 $ blockToOpenXML opts (Para term)

1047 $ blockToOpenXML opts (Para term)

1056− defs' <- withParaProp (pCustomStyle "Definition")

1048+ defs' <- withParaPropM (pStyleM "Definition")

1057 $ concat `fmap` mapM (blocksToOpenXML opts) defs

1049 $ concat `fmap` mapM (blocksToOpenXML opts) defs

1058 return $ term' ++ defs'

1050 return $ term' ++ defs'

1059

1051

@@ -1159,7 +1151,7 @@ inlineToOpenXML' _ (Str str) =

1159 formattedString str

1151 formattedString str

1160inlineToOpenXML' opts Space = inlineToOpenXML opts (Str " ")

1152inlineToOpenXML' opts Space = inlineToOpenXML opts (Str " ")

1161inlineToOpenXML' opts SoftBreak = inlineToOpenXML opts (Str " ")

1153inlineToOpenXML' opts SoftBreak = inlineToOpenXML opts (Str " ")

1162−inlineToOpenXML' opts (Span (_,["underline"],_) ils) = do

1154+inlineToOpenXML' opts (Span (_,["underline"],_) ils) =

1163 withTextProp (mknode "w:u" [("w:val","single")] ()) $

1155 withTextProp (mknode "w:u" [("w:val","single")] ()) $

1164 inlinesToOpenXML opts ils

1156 inlinesToOpenXML opts ils

1165inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do

1157inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do

@@ -1192,18 +1184,21 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do

1192 Just "rtl" -> local (\env -> env { envRTL = True })

1184 Just "rtl" -> local (\env -> env { envRTL = True })

1193 Just "ltr" -> local (\env -> env { envRTL = False })

1185 Just "ltr" -> local (\env -> env { envRTL = False })

1194 _ -> id

1186 _ -> id

1195− let off x = withTextProp (mknode x [("w:val","0")] ())

1187+ off x = withTextProp (mknode x [("w:val","0")] ())

1196− let pmod = (if "csl-no-emph" `elem` classes then off "w:i" else id) .

1188+ pmod = (if "csl-no-emph" `elem` classes then off "w:i" else id) .

1197 (if "csl-no-strong" `elem` classes then off "w:b" else id) .

1189 (if "csl-no-strong" `elem` classes then off "w:b" else id) .

1198 (if "csl-no-smallcaps" `elem` classes

1190 (if "csl-no-smallcaps" `elem` classes

1199 then off "w:smallCaps"

1191 then off "w:smallCaps"

1200 else id)

1192 else id)

1193+ getChangeAuthorDate = do

1194+ defaultAuthor <- asks envChangesAuthor

1195+ defaultDate <- asks envChangesDate

1196+ let author = fromMaybe defaultAuthor (lookup "author" kvs)

1197+ date = fromMaybe defaultDate (lookup "date" kvs)

1198+ return (author, date)

1201 insmod <- if "insertion" `elem` classes

1199 insmod <- if "insertion" `elem` classes

1202 then do

1200 then do

1203− defaultAuthor <- asks envChangesAuthor

1201+ (author, date) <- getChangeAuthorDate

1204− defaultDate <- asks envChangesDate

1205− let author = fromMaybe defaultAuthor (lookup "author" kvs)

1206− date = fromMaybe defaultDate (lookup "date" kvs)

1207 insId <- gets stInsId

1202 insId <- gets stInsId

1208 modify $ \s -> s{stInsId = insId + 1}

1203 modify $ \s -> s{stInsId = insId + 1}

1209 return $ \f -> do

1204 return $ \f -> do

@@ -1215,10 +1210,7 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do

1215 else return id

1210 else return id

1216 delmod <- if "deletion" `elem` classes

1211 delmod <- if "deletion" `elem` classes

1217 then do

1212 then do

1218− defaultAuthor <- asks envChangesAuthor

1213+ (author, date) <- getChangeAuthorDate

1219− defaultDate <- asks envChangesDate

1220− let author = fromMaybe defaultAuthor (lookup "author" kvs)

1221− date = fromMaybe defaultDate (lookup "date" kvs)

1222 delId <- gets stDelId

1214 delId <- gets stDelId

1223 modify $ \s -> s{stDelId = delId + 1}

1215 modify $ \s -> s{stDelId = delId + 1}

1224 return $ \f -> local (\env->env{envInDel=True}) $ do

1216 return $ \f -> local (\env->env{envInDel=True}) $ do

@@ -1266,14 +1258,17 @@ inlineToOpenXML' opts (Math mathType str) = do

1266 Left il -> inlineToOpenXML' opts il

1258 Left il -> inlineToOpenXML' opts il

1267inlineToOpenXML' opts (Cite _ lst) = inlinesToOpenXML opts lst

1259inlineToOpenXML' opts (Cite _ lst) = inlinesToOpenXML opts lst

1268inlineToOpenXML' opts (Code attrs str) = do

1260inlineToOpenXML' opts (Code attrs str) = do

1261+ let alltoktypes = [KeywordTok ..]

1262+ tokTypesMap <- mapM (\tt -> (,) tt <$> rStyleM (show tt)) alltoktypes

1269 let unhighlighted = intercalate [br] `fmap`

1263 let unhighlighted = intercalate [br] `fmap`

1270 mapM formattedString (lines str)

1264 mapM formattedString (lines str)

1271 formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok)

1265 formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok)

1272− toHlTok (toktype,tok) = mknode "w:r" []

1266+ toHlTok (toktype,tok) =

1267+ mknode "w:r" []

1273− [ mknode "w:rPr" []

1268+ [ mknode "w:rPr" [] $

1274− [ rCustomStyle (show toktype) ]

1269+ maybeToList (lookup toktype tokTypesMap)

1275− , mknode "w:t" [("xml:space","preserve")] (T.unpack tok) ]

1270+ , mknode "w:t" [("xml:space","preserve")] (T.unpack tok) ]

1276− withTextProp (rCustomStyle "VerbatimChar")

1271+ withTextPropM (rStyleM "Verbatim Char")

1277 $ if isNothing (writerHighlightStyle opts)

1272 $ if isNothing (writerHighlightStyle opts)

1278 then unhighlighted

1273 then unhighlighted

1279 else case highlight (writerSyntaxMap opts)

1274 else case highlight (writerSyntaxMap opts)

@@ -1431,12 +1426,12 @@ defaultFootnotes :: [Element]

1431defaultFootnotes = [ mknode "w:footnote"

1426defaultFootnotes = [ mknode "w:footnote"

1432 [("w:type", "separator"), ("w:id", "-1")]

1427 [("w:type", "separator"), ("w:id", "-1")]

1433 [ mknode "w:p" []

1428 [ mknode "w:p" []

1434− [mknode "w:r" [] $

1429+ [mknode "w:r" []

1435 [ mknode "w:separator" [] ()]]]

1430 [ mknode "w:separator" [] ()]]]

1436 , mknode "w:footnote"

1431 , mknode "w:footnote"

1437 [("w:type", "continuationSeparator"), ("w:id", "0")]

1432 [("w:type", "continuationSeparator"), ("w:id", "0")]

1438 [ mknode "w:p" []

1433 [ mknode "w:p" []

1439− [ mknode "w:r" [] $

1434+ [ mknode "w:r" []

1440 [ mknode "w:continuationSeparator" [] ()]]]]

1435 [ mknode "w:continuationSeparator" [] ()]]]]

1441

1436

1442

1437

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/0_level_headers.native+2−2

@@ -15,10 +15,10 @@

15,Para [Str "FIGURES",Space,Str "iv"]

16,Para [Str "TABLES",Space,Str "v"]

17,Para [Str "SECTION",Space,Str "1",Space,Str "Introduction",Space,Str "2"]

18−,Header 1 ("figures",["Heading0"],[]) [Str "FIGURES"]

18+,Header 1 ("figures",["Heading-0"],[]) [Str "FIGURES"]

19,Para [Strong [Str "Figure",Space,Str "Page"]]

20,Para [Strong [Str "No",Space,Str "table",Space,Str "of",Space,Str "figures",Space,Str "entries",Space,Str "found."]]

21−,Header 1 ("tables",["Heading0"],[]) [Str "TABLES"]

21+,Header 1 ("tables",["Heading-0"],[]) [Str "TABLES"]

22,Para [Strong [Str "Table",Space,Str "Page"]]

23,Para [Strong [Str "No",Space,Str "table",Space,Str "of",Space,Str "figures",Space,Str "entries",Space,Str "found."]]

24,Header 1 ("introduction",[],[]) [Str "Introduction"]

test/docx/adjacent_codeblocks.docx

Binary file not shown.

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/custom-style-with-styles.native+3−3

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

1−[Div ("",[],[("custom-style","FirstParagraph")])

1+[Div ("",[],[("custom-style","First Paragraph")])

2 [Para [Str "This",Space,Str "is",Space,Str "some",Space,Str "text."]]

3−,Div ("",[],[("custom-style","BodyText")])

3+,Div ("",[],[("custom-style","Body Text")])

4 [Para [Str "This",Space,Str "is",Space,Str "text",Space,Str "with",Space,Str "an",Space,Span ("",[],[("custom-style","Emphatic")]) [Str "emphasized"],Space,Str "text",Space,Str "style.",Space,Str "And",Space,Str "this",Space,Str "is",Space,Str "text",Space,Str "with",Space,Str "a",Space,Span ("",[],[("custom-style","Strengthened")]) [Str "strengthened"],Space,Str "text",Space,Str "style."]]

5−,Div ("",[],[("custom-style","MyBlockStyle")])

5+,Div ("",[],[("custom-style","My Block Style")])

6 [BlockQuote

7 [Para [Str "Here",Space,Str "is",Space,Str "a",Space,Str "styled",Space,Str "paragraph",Space,Str "that",Space,Str "inherits",Space,Str "from",Space,Str "Block",Space,Str "Text."]]]]

test/docx/lists-compact.docxnew file

Binary file not shown.

test/docx/lists-compact.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.docx

Binary file not shown.

test/docx/lists.native+1−1

@@ -15,4 +15,4 @@

15 ,Para [Str "Sub",Space,Str "paragraph"]]]]]]

16 ,[Para [Str "Same",Space,Str "list"]]]

17,BulletList

18− [[Para [Str "Different",Space,Str "list",Space,Str "adjacent",Space,Str "to",Space,Str "the",Space,Str "one",Space,Str "above."]]]]

18+ [[Plain [Str "Different",Space,Str "list",Space,Str "adjacent",Space,Str "to",Space,Str "the",Space,Str "one",Space,Str "above."]]]]

test/docx/nested_anchors_in_header.native+1−1

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

1−[Header 1 ("\1086\1075\1083\1072\1074\1083\1077\1085\1080\1077",["TOCHeading"],[]) [Str "\1054\1075\1083\1072\1074\1083\1077\1085\1080\1077"]

1+[Header 1 ("\1086\1075\1083\1072\1074\1083\1077\1085\1080\1077",["TOC-Heading"],[]) [Str "\1054\1075\1083\1072\1074\1083\1077\1085\1080\1077"]

2,Para [Link ("",[],[]) [Str "Short",Space,Str "instructions",Space,Str "1"] ("#short-instructions","")]

3,Para [Link ("",[],[]) [Str "Some",Space,Str "instructions",Space,Str "1"] ("#some-instructions","")]

4,Para [Link ("",[],[]) [Str "Remote",Space,Str "folder",Space,Str "or",Space,Str "longlonglonglonglong",Space,Str "file",Space,Str "with",Space,Str "manymanymanymany",Space,Str "letters",Space,Str "inside",Space,Str "opening",Space,Str "2"] ("#remote-folder-or-longlonglonglonglong-file-with-manymanymanymany-letters-inside-opening","")]