9b6ee81 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

[Docx Writer] Re-use Readers.Docx.Parse for StyleMap (#5766)

9b6ee81Nikolay Yakimov7 years ago

pandoc.cabal+2−1

compare with master

unifiedsplit

@@ -566,8 +566,8 @@ library

566 Text.Pandoc.Readers.Docx.Lists,

567 Text.Pandoc.Readers.Docx.Combine,

568 Text.Pandoc.Readers.Docx.Parse,

569+ Text.Pandoc.Readers.Docx.Parse.Styles,

569 Text.Pandoc.Readers.Docx.Util,

570 Text.Pandoc.Readers.Docx.Util,

570− Text.Pandoc.Readers.Docx.StyleMap,

571 Text.Pandoc.Readers.Docx.Fields,

572 Text.Pandoc.Readers.LaTeX.Parsing,

573 Text.Pandoc.Readers.LaTeX.Lang,

@@ -592,6 +592,7 @@ library

592 Text.Pandoc.Readers.Org.Parsing,

593 Text.Pandoc.Readers.Org.Shared,

594 Text.Pandoc.Readers.Roff,

595+ Text.Pandoc.Writers.Docx.StyleMap,

595 Text.Pandoc.Writers.Roff,

596 Text.Pandoc.Writers.Roff,

596 Text.Pandoc.Writers.Powerpoint.Presentation,

597 Text.Pandoc.Writers.Powerpoint.Presentation,

597 Text.Pandoc.Writers.Powerpoint.Output,

598 Text.Pandoc.Writers.Powerpoint.Output,

src/Text/Pandoc/Readers/Docx/Parse.hs+3−257

@@ -1,14 +1,9 @@

1{-# LANGUAGE NoImplicitPrelude #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE ViewPatterns #-}

2{-# LANGUAGE ViewPatterns #-}

6−{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{- |

3{- |

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

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

6+ 2019 Nikolay Yakimov <root@livid.pp.ru>

12 License : GNU GPL, version 2 or above

7 License : GNU GPL, version 2 or above

14 Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>

9 Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>

@@ -57,6 +52,7 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..)

57 , leftBiasedMergeRunStyle

52 , leftBiasedMergeRunStyle

58 ) where

53 ) where

59import Prelude

54import Prelude

55+import Text.Pandoc.Readers.Docx.Parse.Styles

60import Codec.Archive.Zip

56import Codec.Archive.Zip

61import Control.Applicative ((<|>))

57import Control.Applicative ((<|>))

62import Control.Monad.Except

58import Control.Monad.Except

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

64import Control.Monad.State.Strict

60import Control.Monad.State.Strict

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

61import Data.Bits ((.|.))

66import qualified Data.ByteString.Lazy as B

62import qualified Data.ByteString.Lazy as B

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

63+import Data.Char (chr, ord, readLitChar)

68import Data.List

64import Data.List

69−import Data.Function (on)

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

71import qualified Data.Map as M

65import qualified Data.Map as M

72import Data.Maybe

66import Data.Maybe

73−import Data.Coerce

74import System.FilePath

67import System.FilePath

75import Text.Pandoc.Readers.Docx.Util

68import Text.Pandoc.Readers.Docx.Util

76import Text.Pandoc.Readers.Docx.Fields

69import Text.Pandoc.Readers.Docx.Fields

@@ -262,37 +255,6 @@ newtype Row = Row [Cell]

262newtype Cell = Cell [BodyPart]

255newtype Cell = Cell [BodyPart]

263 deriving Show

256 deriving Show

264

257

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−

296leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle

258leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle

297leftBiasedMergeRunStyle a b = RunStyle

259leftBiasedMergeRunStyle a b = RunStyle

298 { isBold = isBold a <|> isBold b

260 { isBold = isBold a <|> isBold b

@@ -333,44 +295,6 @@ data Run = Run RunStyle [RunElem]

333data RunElem = TextRun String | LnBrk | Tab | SoftHyphen | NoBreakHyphen

295data RunElem = TextRun String | LnBrk | Tab | SoftHyphen | NoBreakHyphen

334 deriving Show

296 deriving Show

335

297

336−data VertAlign = BaseLn | SupScrpt | SubScrpt

337− deriving Show

338−

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

352− }

353− deriving Show

354−

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

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

357− , psParentStyle :: Maybe ParStyle

358− , pStyleName :: ParaStyleName

359− , pStyleId :: ParaStyleId

360− }

361− deriving Show

362−

363−defaultRunStyle :: RunStyle

364−defaultRunStyle = RunStyle { isBold = Nothing

365− , isItalic = Nothing

366− , isSmallCaps = Nothing

367− , isStrike = Nothing

368− , isRTL = Nothing

369− , rVertAlign = Nothing

370− , rUnderline = Nothing

371− , rParentStyle = Nothing

372− }

373−

374type Target = String

298type Target = String

375type Anchor = String

299type Anchor = String

376type URL = String

300type URL = String

@@ -449,46 +373,6 @@ elemToBody _ _ = throwError WrongElem

449

373

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

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

451archiveToStyles = archiveToStyles' getStyleId getStyleId

375archiveToStyles = 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 =

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

456− (parseXMLDoc . UTF8.toStringLazy . fromEntry)

457− in

458− case stylesElem of

459− Nothing -> (M.empty, M.empty)

460− Just styElem ->

461− let namespaces = elemToNameSpaces styElem

462− in

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

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

465−

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

467−isBasedOnStyle ns element parentStyle

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

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

470− , styleType == cStyleType parentStyle

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

472− findAttrByName ns "w" "val"

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

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

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

476− , styleType == cStyleType parentStyle

477− , Nothing <- findChildByName ns "w" "basedOn" element

478− , Nothing <- parentStyle = True

479− | otherwise = False

480−

481−class HasStyleId a => ElemToStyle a where

482− cStyleType :: Maybe a -> String

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

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

376

493class HasParentStyle a where

377class HasParentStyle a where

494 getParentStyle :: a -> Maybe a

378 getParentStyle :: a -> Maybe a

@@ -511,52 +395,6 @@ constructBogusParStyleData stName = ParStyle

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

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

512 }

396 }

513

397

514−instance ElemToStyle CharStyle where

515− cStyleType _ = "character"

516− elemToStyle ns element parentStyle

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

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

519− elemToCharStyle ns element parentStyle

520− | otherwise = Nothing

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

529−

530−instance ElemToStyle ParStyle where

531− cStyleType _ = "paragraph"

532− elemToStyle ns element parentStyle

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

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

535− = elemToParStyleData ns element parentStyle

536− | otherwise = Nothing

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

545−

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

547−getStyleChildren ns element parentStyle

548− | isElem ns "w" "styles" element =

549− mapMaybe (\e -> elemToStyle ns e parentStyle) $

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

551− | otherwise = []

552−

553−buildBasedOnList :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a]

554−buildBasedOnList ns element rootStyle =

555− case getStyleChildren ns element rootStyle of

556− [] -> []

557− stys -> stys ++

558− concatMap (buildBasedOnList ns element . Just) stys

559−

560archiveToNotes :: Archive -> Notes

398archiveToNotes :: Archive -> Notes

561archiveToNotes zf =

399archiveToNotes zf =

562 let fnElem = findEntryByPath "word/footnotes.xml" zf

400 let fnElem = findEntryByPath "word/footnotes.xml" zf

@@ -789,9 +627,6 @@ testBitMask bitMaskS n =

789 [] -> False

627 [] -> False

790 ((n', _) : _) -> (n' .|. n) /= 0

628 ((n', _) : _) -> (n' .|. n) /= 0

791

629

792−stringToInteger :: String -> Maybe Integer

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

794−

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

630pHeading :: ParagraphStyle -> Maybe (ParaStyleName, Int)

796pHeading = getParStyleField headingLev . pStyle

631pHeading = getParStyleField headingLev . pStyle

797

632

@@ -1166,21 +1001,6 @@ elemToParagraphStyle ns element sty

1166 }

1001 }

1167elemToParagraphStyle _ _ _ = defaultParagraphStyle

1002elemToParagraphStyle _ _ _ = defaultParagraphStyle

1168

1003

1169−checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool

1170−checkOnOff ns rPr tag

1171− | Just t <- findChild tag rPr

1172− , Just val <- findAttrByName ns "w" "val" t =

1173− Just $ case val of

1174− "true" -> True

1175− "false" -> False

1176− "on" -> True

1177− "off" -> False

1178− "1" -> True

1179− "0" -> False

1180− _ -> False

1181− | Just _ <- findChild tag rPr = Just True

1182−checkOnOff _ _ _ = Nothing

1183−

1184elemToRunStyleD :: NameSpaces -> Element -> D RunStyle

1004elemToRunStyleD :: NameSpaces -> Element -> D RunStyle

1185elemToRunStyleD ns element

1005elemToRunStyleD ns element

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

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

@@ -1192,80 +1012,6 @@ elemToRunStyleD ns element

1192 return $ elemToRunStyle ns element parentSty

1012 return $ elemToRunStyle ns element parentSty

1193elemToRunStyleD _ _ = return defaultRunStyle

1013elemToRunStyleD _ _ = return defaultRunStyle

1194

1014

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−

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

1203−elemToRunStyle ns element parentStyle

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

1205− RunStyle

1206− {

1207− isBold = checkOnOff ns rPr (elemName ns "w" "b") `mplus`

1208− checkOnOff ns rPr (elemName ns "w" "bCs")

1209− , isItalic = checkOnOff ns rPr (elemName ns "w" "i") `mplus`

1210− checkOnOff ns rPr (elemName ns "w" "iCs")

1211− , isSmallCaps = checkOnOff ns rPr (elemName ns "w" "smallCaps")

1212− , isStrike = checkOnOff ns rPr (elemName ns "w" "strike")

1213− , isRTL = checkOnOff ns rPr (elemName ns "w" "rtl")

1214− , rVertAlign =

1215− findChildByName ns "w" "vertAlign" rPr >>=

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

1217− \v -> Just $ case v of

1218− "superscript" -> SupScrpt

1219− "subscript" -> SubScrpt

1220− _ -> BaseLn

1221− , rUnderline =

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

1223− findAttrByName ns "w" "val"

1224− , rParentStyle = parentStyle

1225− }

1226−elemToRunStyle _ _ _ = defaultRunStyle

1227−

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

1229−getHeaderLevel ns element

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)

1235−getHeaderLevel _ _ = Nothing

1236−

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)

1241−

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

1243−getNumInfo ns element = do

1244− let numPr = findChildByName ns "w" "pPr" element >>=

1245− findChildByName ns "w" "numPr"

1246− lvl = fromMaybe "0" (numPr >>=

1247− findChildByName ns "w" "ilvl" >>=

1248− findAttrByName ns "w" "val")

1249− numId <- numPr >>=

1250− findChildByName ns "w" "numId" >>=

1251− findAttrByName ns "w" "val"

1252− return (numId, lvl)

1253−

1254−

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

1260− {

1261− headingLev = getHeaderLevel ns element

1262− , numInfo = getNumInfo ns element

1263− , psParentStyle = parentStyle

1264− , pStyleName = styleName

1265− , pStyleId = ParaStyleId styleId

1266− }

1267−elemToParStyleData _ _ _ = Nothing

1268−

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

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

1270elemToRunElem ns element

1016elemToRunElem ns element

1271 | isElem ns "w" "t" element

1017 | isElem ns "w" "t" element

src/Text/Pandoc/Readers/Docx/Parse/Styles.hsnew file+304

@@ -0,0 +1,304 @@

1+{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{- |

7+ Module : Text.Pandoc.Readers.Docx.Parse.Styles

9+ 2019 Nikolay Yakimov <root@livid.pp.ru>

10+ License : GNU GPL, version 2 or above

11+

12+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>

13+ Stability : alpha

14+ Portability : portable

15+

16+Type machinery and code for extraction and manipulation of docx styles

17+-}

18+

19+module Text.Pandoc.Readers.Docx.Parse.Styles (

20+ CharStyleId(..)

21+ , CharStyle

22+ , ParaStyleId(..)

23+ , ParStyle(..)

24+ , RunStyle(..)

25+ , HasStyleName

26+ , StyleName

27+ , ParaStyleName

28+ , CharStyleName

29+ , FromStyleName

30+ , VertAlign(..)

31+ , StyleId

32+ , HasStyleId

33+ , archiveToStyles'

34+ , getStyleId

35+ , getStyleName

36+ , cStyleData

37+ , fromStyleName

38+ , fromStyleId

39+ , stringToInteger

40+ , getNumInfo

41+ , elemToRunStyle

42+ , defaultRunStyle

43+ ) where

44+import Prelude

45+import Codec.Archive.Zip

46+import Control.Applicative ((<|>))

47+import Control.Monad.Except

48+import Data.Char (toLower)

49+import Data.List

50+import Data.Function (on)

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

52+import qualified Data.Map as M

53+import Data.Maybe

54+import Data.Coerce

55+import Text.Pandoc.Readers.Docx.Util

56+import qualified Text.Pandoc.UTF8 as UTF8

57+import Text.XML.Light

58+

59+newtype CharStyleId = CharStyleId String

60+ deriving (Show, Eq, Ord, IsString, FromStyleId)

61+newtype ParaStyleId = ParaStyleId String

62+ deriving (Show, Eq, Ord, IsString, FromStyleId)

63+

64+newtype CharStyleName = CharStyleName CIString

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

66+newtype ParaStyleName = ParaStyleName CIString

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

68+

69+-- Case-insensitive comparisons

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

71+

72+class FromStyleName a where

73+ fromStyleName :: a -> String

74+

75+instance FromStyleName String where

76+ fromStyleName = id

77+

78+class FromStyleId a where

79+ fromStyleId :: a -> String

80+

81+instance FromStyleId String where

82+ fromStyleId = id

83+

84+instance Eq CIString where

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

86+

87+instance Ord CIString where

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

89+

90+data VertAlign = BaseLn | SupScrpt | SubScrpt

91+ deriving Show

92+

93+data CharStyle = CharStyle { cStyleId :: CharStyleId

94+ , cStyleName :: CharStyleName

95+ , cStyleData :: RunStyle

96+ } deriving (Show)

97+

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

99+ , isItalic :: Maybe Bool

100+ , isSmallCaps :: Maybe Bool

101+ , isStrike :: Maybe Bool

102+ , isRTL :: Maybe Bool

103+ , rVertAlign :: Maybe VertAlign

104+ , rUnderline :: Maybe String

105+ , rParentStyle :: Maybe CharStyle

106+ }

107+ deriving Show

108+

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

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

111+ , psParentStyle :: Maybe ParStyle

112+ , pStyleName :: ParaStyleName

113+ , pStyleId :: ParaStyleId

114+ }

115+ deriving Show

116+

117+defaultRunStyle :: RunStyle

118+defaultRunStyle = RunStyle { isBold = Nothing

119+ , isItalic = Nothing

120+ , isSmallCaps = Nothing

121+ , isStrike = Nothing

122+ , isRTL = Nothing

123+ , rVertAlign = Nothing

124+ , rUnderline = Nothing

125+ , rParentStyle = Nothing

126+ }

127+

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

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

130+archiveToStyles' conv1 conv2 zf =

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

132+ (parseXMLDoc . UTF8.toStringLazy . fromEntry)

133+ in

134+ case stylesElem of

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

136+ Just styElem ->

137+ let namespaces = elemToNameSpaces styElem

138+ in

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

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

141+

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

143+isBasedOnStyle ns element parentStyle

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

145+ , Just styleType <- findAttrByName ns "w" "type" element

146+ , styleType == cStyleType parentStyle

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

148+ findAttrByName ns "w" "val"

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

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

151+ , Just styleType <- findAttrByName ns "w" "type" element

152+ , styleType == cStyleType parentStyle

153+ , Nothing <- findChildByName ns "w" "basedOn" element

154+ , Nothing <- parentStyle = True

155+ | otherwise = False

156+

157+class HasStyleId a => ElemToStyle a where

158+ cStyleType :: Maybe a -> String

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

160+

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

162+ type StyleId a

163+ getStyleId :: a -> StyleId a

164+

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

166+ type StyleName a

167+ getStyleName :: a -> StyleName a

168+

169+instance ElemToStyle CharStyle where

170+ cStyleType _ = "character"

171+ elemToStyle ns element parentStyle

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

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

174+ elemToCharStyle ns element parentStyle

175+ | otherwise = Nothing

176+

177+instance HasStyleId CharStyle where

178+ type StyleId CharStyle = CharStyleId

179+ getStyleId = cStyleId

180+

181+instance HasStyleName CharStyle where

182+ type StyleName CharStyle = CharStyleName

183+ getStyleName = cStyleName

184+

185+instance ElemToStyle ParStyle where

186+ cStyleType _ = "paragraph"

187+ elemToStyle ns element parentStyle

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

189+ , Just "paragraph" <- findAttrByName ns "w" "type" element

190+ = elemToParStyleData ns element parentStyle

191+ | otherwise = Nothing

192+

193+instance HasStyleId ParStyle where

194+ type StyleId ParStyle = ParaStyleId

195+ getStyleId = pStyleId

196+

197+instance HasStyleName ParStyle where

198+ type StyleName ParStyle = ParaStyleName

199+ getStyleName = pStyleName

200+

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

202+getStyleChildren ns element parentStyle

203+ | isElem ns "w" "styles" element =

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

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

206+ | otherwise = []

207+

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

209+buildBasedOnList ns element rootStyle =

210+ case getStyleChildren ns element rootStyle of

211+ [] -> []

212+ stys -> stys ++

213+ concatMap (buildBasedOnList ns element . Just) stys

214+

215+stringToInteger :: String -> Maybe Integer

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

217+

218+checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool

219+checkOnOff ns rPr tag

220+ | Just t <- findChild tag rPr

221+ , Just val <- findAttrByName ns "w" "val" t =

222+ Just $ case val of

223+ "true" -> True

224+ "false" -> False

225+ "on" -> True

226+ "off" -> False

227+ "1" -> True

228+ "0" -> False

229+ _ -> False

230+ | Just _ <- findChild tag rPr = Just True

231+checkOnOff _ _ _ = Nothing

232+

233+elemToCharStyle :: NameSpaces

234+ -> Element -> Maybe CharStyle -> Maybe CharStyle

235+elemToCharStyle ns element parentStyle

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

237+ <*> getElementStyleName ns element

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

239+

240+elemToRunStyle :: NameSpaces -> Element -> Maybe CharStyle -> RunStyle

241+elemToRunStyle ns element parentStyle

242+ | Just rPr <- findChildByName ns "w" "rPr" element =

243+ RunStyle

244+ {

245+ isBold = checkOnOff ns rPr (elemName ns "w" "b") `mplus`

246+ checkOnOff ns rPr (elemName ns "w" "bCs")

247+ , isItalic = checkOnOff ns rPr (elemName ns "w" "i") `mplus`

248+ checkOnOff ns rPr (elemName ns "w" "iCs")

249+ , isSmallCaps = checkOnOff ns rPr (elemName ns "w" "smallCaps")

250+ , isStrike = checkOnOff ns rPr (elemName ns "w" "strike")

251+ , isRTL = checkOnOff ns rPr (elemName ns "w" "rtl")

252+ , rVertAlign =

253+ findChildByName ns "w" "vertAlign" rPr >>=

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

255+ \v -> Just $ case v of

256+ "superscript" -> SupScrpt

257+ "subscript" -> SubScrpt

258+ _ -> BaseLn

259+ , rUnderline =

260+ findChildByName ns "w" "u" rPr >>=

261+ findAttrByName ns "w" "val"

262+ , rParentStyle = parentStyle

263+ }

264+elemToRunStyle _ _ _ = defaultRunStyle

265+

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

267+getHeaderLevel ns element

268+ | Just styleName <- getElementStyleName ns element

269+ , Just n <- stringToInteger =<<

270+ (stripPrefix "heading " . map toLower $

271+ fromStyleName styleName)

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

273+getHeaderLevel _ _ = Nothing

274+

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

276+getElementStyleName ns el = coerce <$>

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

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

279+

280+getNumInfo :: NameSpaces -> Element -> Maybe (String, String)

281+getNumInfo ns element = do

282+ let numPr = findChildByName ns "w" "pPr" element >>=

283+ findChildByName ns "w" "numPr"

284+ lvl = fromMaybe "0" (numPr >>=

285+ findChildByName ns "w" "ilvl" >>=

286+ findAttrByName ns "w" "val")

287+ numId <- numPr >>=

288+ findChildByName ns "w" "numId" >>=

289+ findAttrByName ns "w" "val"

290+ return (numId, lvl)

291+

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

293+elemToParStyleData ns element parentStyle

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

295+ , Just styleName <- getElementStyleName ns element

296+ = Just $ ParStyle

297+ {

298+ headingLev = getHeaderLevel ns element

299+ , numInfo = getNumInfo ns element

300+ , psParentStyle = parentStyle

301+ , pStyleName = styleName

302+ , pStyleId = ParaStyleId styleId

303+ }

304+elemToParStyleData _ _ _ = Nothing

src/Text/Pandoc/Readers/Docx/StyleMap.hsdeleted−123

@@ -1,123 +0,0 @@

1−{-# LANGUAGE NoImplicitPrelude #-}

2−{- |

3− Module : Text.Pandoc.Readers.Docx.StyleMaps

5− 2014-2019 John MacFarlane <jgm@berkeley.edu>,

6− 2015 Nikolay Yakimov <root@livid.pp.ru>

7− License : GNU GPL, version 2 or above

8−

9− Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>

10− Stability : alpha

11− Portability : portable

12−

13−Mappings of element styles (word to pandoc-internal).

14−-}

15−module Text.Pandoc.Readers.Docx.StyleMap ( StyleMaps(..)

16− , alterMap

17− , getMap

18− , defaultStyleMaps

19− , getStyleMaps

20− , getStyleId

21− , hasStyleName

22− ) where

23−

24−import Prelude

25−import Control.Monad.State.Strict

26−import Data.Char (toLower)

27−import qualified Data.Map as M

28−import Text.Pandoc.Readers.Docx.Util

29−import Text.XML.Light

30−

31−newtype ParaStyleMap = ParaStyleMap ( M.Map String String )

32−newtype CharStyleMap = CharStyleMap ( M.Map String String )

33−

34−class StyleMap a where

35− alterMap :: (M.Map String String -> M.Map String String) -> a -> a

36− getMap :: a -> M.Map String String

37−

38−instance StyleMap ParaStyleMap where

39− alterMap f (ParaStyleMap m) = ParaStyleMap $ f m

40− getMap (ParaStyleMap m) = m

41−

42−instance StyleMap CharStyleMap where

43− alterMap f (CharStyleMap m) = CharStyleMap $ f m

44− getMap (CharStyleMap m) = m

45−

46−insert :: (StyleMap a) => Maybe String -> Maybe String -> a -> a

47−insert (Just k) (Just v) m = alterMap (M.insert k v) m

48−insert _ _ m = m

49−

50−getStyleId :: (StyleMap a) => String -> a -> String

51−getStyleId s = M.findWithDefault (filter (/=' ') s) (map toLower s) . getMap

52−

53−hasStyleName :: (StyleMap a) => String -> a -> Bool

54−hasStyleName styleName = M.member (map toLower styleName) . getMap

55−

56−data StyleMaps = StyleMaps { sNameSpaces :: NameSpaces

57− , sParaStyleMap :: ParaStyleMap

58− , sCharStyleMap :: CharStyleMap

59− }

60−

61−data StyleType = ParaStyle | CharStyle

62−

63−defaultStyleMaps :: StyleMaps

64−defaultStyleMaps = StyleMaps { sNameSpaces = []

65− , sParaStyleMap = ParaStyleMap M.empty

66− , sCharStyleMap = CharStyleMap M.empty

67− }

68−

69−type StateM a = State StyleMaps a

70−

71−getStyleMaps :: Element -> StyleMaps

72−getStyleMaps docElem = execState genStyleMap state'

73− where

74− state' = defaultStyleMaps {sNameSpaces = elemToNameSpaces docElem}

75− genStyleItem e = do

76− styleType <- getStyleType e

77− styleId <- getAttrStyleId e

78− nameValLowercase <- fmap (map toLower) `fmap` getNameVal e

79− case styleType of

80− Just ParaStyle -> modParaStyleMap $ insert nameValLowercase styleId

81− Just CharStyle -> modCharStyleMap $ insert nameValLowercase styleId

82− _ -> return ()

83− genStyleMap = do

84− style <- elemName' "style"

85− let styles = findChildren style docElem

86− forM_ styles genStyleItem

87−

88−modParaStyleMap :: (ParaStyleMap -> ParaStyleMap) -> StateM ()

89−modParaStyleMap f = modify $ \s ->

90− s {sParaStyleMap = f $ sParaStyleMap s}

91−

92−modCharStyleMap :: (CharStyleMap -> CharStyleMap) -> StateM ()

93−modCharStyleMap f = modify $ \s ->

94− s {sCharStyleMap = f $ sCharStyleMap s}

95−

96−getStyleType :: Element -> StateM (Maybe StyleType)

97−getStyleType e = do

98− styleTypeStr <- getAttrType e

99− case styleTypeStr of

100− Just "paragraph" -> return $ Just ParaStyle

101− Just "character" -> return $ Just CharStyle

102− _ -> return Nothing

103−

104−getAttrType :: Element -> StateM (Maybe String)

105−getAttrType el = do

106− name <- elemName' "type"

107− return $ findAttr name el

108−

109−getAttrStyleId :: Element -> StateM (Maybe String)

110−getAttrStyleId el = do

111− name <- elemName' "styleId"

112− return $ findAttr name el

113−

114−getNameVal :: Element -> StateM (Maybe String)

115−getNameVal el = do

116− name <- elemName' "name"

117− val <- elemName' "val"

118− return $ findChild name el >>= findAttr val

119−

120−elemName' :: String -> StateM QName

121−elemName' name = do

122− namespaces <- gets sNameSpaces

123− return $ elemName namespaces "w" name

src/Text/Pandoc/Writers/Docx.hs+30−31

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

3{-# LANGUAGE RankNTypes #-}

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ViewPatterns #-}

6+{-# LANGUAGE OverloadedStrings #-}

6{- |

7{- |

7 Module : Text.Pandoc.Writers.Docx

8 Module : Text.Pandoc.Writers.Docx

@@ -23,8 +24,9 @@ import Control.Monad.Reader

23import Control.Monad.State.Strict

24import Control.Monad.State.Strict

24import qualified Data.ByteString as B

25import qualified Data.ByteString as B

25import qualified Data.ByteString.Lazy as BL

26import qualified Data.ByteString.Lazy as BL

26−import Data.Char (isSpace, ord, toLower, isLetter)

27+import Data.Char (isSpace, ord, isLetter)

27import Data.List (intercalate, isPrefixOf, isSuffixOf)

28import Data.List (intercalate, isPrefixOf, isSuffixOf)

29+import Data.String (fromString)

28import qualified Data.Map as M

30import qualified Data.Map as M

29import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList)

31import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList)

30import qualified Data.Set as Set

32import qualified Data.Set as Set

@@ -46,7 +48,7 @@ import Text.Pandoc.Logging

46import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType,

48import Text.Pandoc.MIME (MimeType, extensionFromMimeType, getMimeType,

47 getMimeTypeDef)

49 getMimeTypeDef)

48import Text.Pandoc.Options

50import Text.Pandoc.Options

49−import Text.Pandoc.Readers.Docx.StyleMap

51+import Text.Pandoc.Writers.Docx.StyleMap

50import Text.Pandoc.Shared

52import Text.Pandoc.Shared

51import Text.Pandoc.Walk

53import Text.Pandoc.Walk

52import Text.Pandoc.Writers.Math

54import Text.Pandoc.Writers.Math

@@ -132,8 +134,8 @@ data WriterState = WriterState{

132 , stFirstPara :: Bool

134 , stFirstPara :: Bool

133 , stInTable :: Bool

135 , stInTable :: Bool

134 , stTocTitle :: [Inline]

136 , stTocTitle :: [Inline]

135− , stDynamicParaProps :: Set.Set String

137+ , stDynamicParaProps :: Set.Set ParaStyleName

136− , stDynamicTextProps :: Set.Set String

138+ , stDynamicTextProps :: Set.Set CharStyleName

137 , stCurId :: Int

139 , stCurId :: Int

138 }

140 }

139

141

@@ -147,7 +149,7 @@ defaultWriterState = WriterState{

147 , stLists = [NoMarker]

149 , stLists = [NoMarker]

148 , stInsId = 1

150 , stInsId = 1

149 , stDelId = 1

151 , stDelId = 1

150− , stStyleMaps = defaultStyleMaps

152+ , stStyleMaps = StyleMaps M.empty M.empty

151 , stFirstPara = False

153 , stFirstPara = False

152 , stInTable = False

154 , stInTable = False

153 , stTocTitle = [Str "Table of Contents"]

155 , stTocTitle = [Str "Table of Contents"]

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

265 styledoc <- addLang <$> parseXml refArchive distArchive stylepath

267 styledoc <- addLang <$> parseXml refArchive distArchive stylepath

266

268

267 -- parse styledoc for heading styles

269 -- parse styledoc for heading styles

268− let styleMaps = getStyleMaps styledoc

270+ let styleMaps = getStyleMaps refArchive

269

271

270 let tocTitle = case lookupMetaInlines "toc-title" meta of

272 let tocTitle = case lookupMetaInlines "toc-title" meta of

271 [] -> stTocTitle defaultWriterState

273 [] -> stTocTitle defaultWriterState

@@ -462,11 +464,11 @@ writeDocx opts doc@(Pandoc meta _) = do

462 -- are not already in the style map. Note that keys in the stylemap

464 -- are not already in the style map. Note that keys in the stylemap

463 -- are normalized as lowercase.

465 -- are normalized as lowercase.

464 let newDynamicParaProps = filter

466 let newDynamicParaProps = filter

465− (\sty -> isNothing $ M.lookup (toLower <$> sty) $ getMap $ sParaStyleMap styleMaps)

467+ (\sty -> not $ hasStyleName sty $ smParaStyle styleMaps)

466 (Set.toList $ stDynamicParaProps st)

468 (Set.toList $ stDynamicParaProps st)

467

469

468 newDynamicTextProps = filter

470 newDynamicTextProps = filter

469− (\sty -> isNothing $ M.lookup (toLower <$> sty) $ getMap $ sCharStyleMap styleMaps)

471+ (\sty -> not $ hasStyleName sty $ smCharStyle styleMaps)

470 (Set.toList $ stDynamicTextProps st)

472 (Set.toList $ stDynamicTextProps st)

471

473

472 let newstyles = map newParaPropToOpenXml newDynamicParaProps ++

474 let newstyles = map newParaPropToOpenXml newDynamicParaProps ++

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

609 return $ fromArchive archive

611 return $ fromArchive archive

610

612

611

613

612−newParaPropToOpenXml :: String -> Element

614+newParaPropToOpenXml :: ParaStyleName -> Element

613−newParaPropToOpenXml s =

615+newParaPropToOpenXml (fromStyleName -> s) =

614 let styleId = filter (not . isSpace) s

616 let styleId = filter (not . isSpace) s

615 in mknode "w:style" [ ("w:type", "paragraph")

617 in mknode "w:style" [ ("w:type", "paragraph")

616 , ("w:customStyle", "1")

618 , ("w:customStyle", "1")

@@ -620,8 +622,8 @@ newParaPropToOpenXml s =

620 , mknode "w:qFormat" [] ()

622 , mknode "w:qFormat" [] ()

621 ]

623 ]

622

624

623−newTextPropToOpenXml :: String -> Element

625+newTextPropToOpenXml :: CharStyleName -> Element

624−newTextPropToOpenXml s =

626+newTextPropToOpenXml (fromStyleName -> s) =

625 let styleId = filter (not . isSpace) s

627 let styleId = filter (not . isSpace) s

626 in mknode "w:style" [ ("w:type", "character")

628 in mknode "w:style" [ ("w:type", "character")

627 , ("w:customStyle", "1")

629 , ("w:customStyle", "1")

@@ -634,7 +636,7 @@ styleToOpenXml :: StyleMaps -> Style -> [Element]

634styleToOpenXml sm style =

636styleToOpenXml sm style =

635 maybeToList parStyle ++ mapMaybe toStyle alltoktypes

637 maybeToList parStyle ++ mapMaybe toStyle alltoktypes

636 where alltoktypes = enumFromTo KeywordTok NormalTok

638 where alltoktypes = enumFromTo KeywordTok NormalTok

637− toStyle toktype | hasStyleName (show toktype) (sCharStyleMap sm) = Nothing

639+ toStyle toktype | hasStyleName (fromString $ show toktype) (smCharStyle sm) = Nothing

638 | otherwise = Just $

640 | otherwise = Just $

639 mknode "w:style" [("w:type","character"),

641 mknode "w:style" [("w:type","character"),

640 ("w:customStyle","1"),("w:styleId",show toktype)]

642 ("w:customStyle","1"),("w:styleId",show toktype)]

@@ -657,7 +659,7 @@ styleToOpenXml sm style =

657 tokBg toktype = maybe "auto" (drop 1 . fromColor)

659 tokBg toktype = maybe "auto" (drop 1 . fromColor)

658 $ (tokenBackground =<< M.lookup toktype tokStyles)

660 $ (tokenBackground =<< M.lookup toktype tokStyles)

659 `mplus` backgroundColor style

661 `mplus` backgroundColor style

660− parStyle | hasStyleName "Source Code" (sParaStyleMap sm) = Nothing

662+ parStyle | hasStyleName "Source Code" (smParaStyle sm) = Nothing

661 | otherwise = Just $

663 | otherwise = Just $

662 mknode "w:style" [("w:type","paragraph"),

664 mknode "w:style" [("w:type","paragraph"),

663 ("w:customStyle","1"),("w:styleId","SourceCode")]

665 ("w:customStyle","1"),("w:styleId","SourceCode")]

@@ -848,17 +850,17 @@ writeOpenXML opts (Pandoc meta blocks) = do

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

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

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

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

850

852

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

853+pStyleM :: (PandocMonad m) => ParaStyleName -> WS m XML.Element

852pStyleM styleName = do

854pStyleM styleName = do

853− styleMaps <- gets stStyleMaps

855+ pStyleMap <- gets (smParaStyle . stStyleMaps)

854− let sty' = getStyleId styleName $ sParaStyleMap styleMaps

856+ let sty' = getStyleIdFromName styleName pStyleMap

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

857+ return $ mknode "w:pStyle" [("w:val", fromStyleId sty')] ()

856

858

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

859+rStyleM :: (PandocMonad m) => CharStyleName -> WS m XML.Element

858rStyleM styleName = do

860rStyleM styleName = do

859− styleMaps <- gets stStyleMaps

861+ cStyleMap <- gets (smCharStyle . stStyleMaps)

860− let sty' = getStyleId styleName $ sCharStyleMap styleMaps

862+ let sty' = getStyleIdFromName styleName cStyleMap

861− return $ mknode "w:rStyle" [("w:val",sty')] ()

863+ return $ mknode "w:rStyle" [("w:val", fromStyleId sty')] ()

862

864

863getUniqueId :: (PandocMonad m) => WS m String

865getUniqueId :: (PandocMonad m) => WS m String

864-- the + 20 is to ensure that there are no clashes with the rIds

866-- the + 20 is to ensure that there are no clashes with the rIds

@@ -880,7 +882,7 @@ blockToOpenXML' :: (PandocMonad m) => WriterOptions -> Block -> WS m [Element]

880blockToOpenXML' _ Null = return []

882blockToOpenXML' _ Null = return []

881blockToOpenXML' opts (Div (ident,_classes,kvs) bs) = do

883blockToOpenXML' opts (Div (ident,_classes,kvs) bs) = do

882 stylemod <- case lookup dynamicStyleKey kvs of

884 stylemod <- case lookup dynamicStyleKey kvs of

883− Just sty -> do

885+ Just (fromString -> sty) -> do

884 modify $ \s ->

886 modify $ \s ->

885 s{stDynamicParaProps = Set.insert sty

887 s{stDynamicParaProps = Set.insert sty

886 (stDynamicParaProps s)}

888 (stDynamicParaProps s)}

@@ -901,7 +903,7 @@ blockToOpenXML' opts (Div (ident,_classes,kvs) bs) = do

901 wrapBookmark ident $ header ++ contents

903 wrapBookmark ident $ header ++ contents

902blockToOpenXML' opts (Header lev (ident,_,_) lst) = do

904blockToOpenXML' opts (Header lev (ident,_,_) lst) = do

903 setFirstPara

905 setFirstPara

904− paraProps <- withParaPropM (pStyleM ("Heading "++show lev)) $

906+ paraProps <- withParaPropM (pStyleM (fromString $ "Heading "++show lev)) $

905 getParaProps False

907 getParaProps False

906 contents <- inlinesToOpenXML opts lst

908 contents <- inlinesToOpenXML opts lst

907 if null ident

909 if null ident

@@ -916,8 +918,7 @@ blockToOpenXML' opts (Plain lst) = do

916 isInTable <- gets stInTable

918 isInTable <- gets stInTable

917 let block = blockToOpenXML opts (Para lst)

919 let block = blockToOpenXML opts (Para lst)

918 prop <- pStyleM "Compact"

920 prop <- pStyleM "Compact"

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

921+ if isInTable then withParaProp prop block else block

920− return $ para

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

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

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

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

923 setFirstPara

924 setFirstPara

@@ -1087,9 +1088,7 @@ getTextProps :: (PandocMonad m) => WS m [Element]

1087getTextProps = do

1088getTextProps = do

1088 props <- asks envTextProperties

1089 props <- asks envTextProperties

1089 let squashed = squashProps props

1090 let squashed = squashProps props

1090− return $ if null squashed

1091− then []

1092− else [mknode "w:rPr" [] squashed]

1091+ return [mknode "w:rPr" [] squashed | (not . null) squashed]

1093

1092

1094withTextProp :: PandocMonad m => Element -> WS m a -> WS m a

1093withTextProp :: PandocMonad m => Element -> WS m a -> WS m a

1095withTextProp d p =

1094withTextProp d p =

@@ -1174,7 +1173,7 @@ inlineToOpenXML' _ (Span (ident,["comment-end"],kvs) _) =

1174 ]

1173 ]

1175inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do

1174inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do

1176 stylemod <- case lookup dynamicStyleKey kvs of

1175 stylemod <- case lookup dynamicStyleKey kvs of

1177− Just sty -> do

1176+ Just (fromString -> sty) -> do

1178 modify $ \s ->

1177 modify $ \s ->

1179 s{stDynamicTextProps = Set.insert sty

1178 s{stDynamicTextProps = Set.insert sty

1180 (stDynamicTextProps s)}

1179 (stDynamicTextProps s)}

@@ -1259,7 +1258,7 @@ inlineToOpenXML' opts (Math mathType str) = do

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

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

1260inlineToOpenXML' opts (Code attrs str) = do

1259inlineToOpenXML' opts (Code attrs str) = do

1261 let alltoktypes = [KeywordTok ..]

1260 let alltoktypes = [KeywordTok ..]

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

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

1263 let unhighlighted = intercalate [br] `fmap`

1262 let unhighlighted = intercalate [br] `fmap`

1264 mapM formattedString (lines str)

1263 mapM formattedString (lines str)

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

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

src/Text/Pandoc/Writers/Docx/StyleMap.hsnew file+48

@@ -0,0 +1,48 @@

1+{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{- |

4+ Module : Text.Pandoc.Writers.Docx.StyleMap

6+ 2014-2019 John MacFarlane <jgm@berkeley.edu>,

7+ 2015-2019 Nikolay Yakimov <root@livid.pp.ru>

8+ License : GNU GPL, version 2 or above

10+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>

11+ Stability : alpha

12+ Portability : portable

13+

14+Mappings of element styles (word to pandoc-internal).

15+-}

16+

17+module Text.Pandoc.Writers.Docx.StyleMap ( StyleMaps(..)

18+ , ParaStyleName

19+ , CharStyleName

20+ , getStyleMaps

21+ , getStyleIdFromName

22+ , hasStyleName

23+ , fromStyleId

24+ , fromStyleName

25+ ) where

26+

27+import Text.Pandoc.Readers.Docx.Parse.Styles

28+import Codec.Archive.Zip

29+import qualified Data.Map as M

30+import Data.String

31+import Data.Char (isSpace)

32+import Prelude

33+

34+data StyleMaps = StyleMaps { smCharStyle :: CharStyleNameMap, smParaStyle :: ParaStyleNameMap }

35+type ParaStyleNameMap = M.Map ParaStyleName ParStyle

36+type CharStyleNameMap = M.Map CharStyleName CharStyle

37+

38+getStyleIdFromName :: (Ord sn, FromStyleName sn, IsString (StyleId sty), HasStyleId sty)

39+ => sn -> M.Map sn sty -> StyleId sty

40+getStyleIdFromName s = maybe (fallback s) getStyleId . M.lookup s

41+ where fallback = fromString . filter (not . isSpace) . fromStyleName

42+

43+hasStyleName :: (Ord sn, HasStyleId sty)

44+ => sn -> M.Map sn sty -> Bool

45+hasStyleName styleName = M.member styleName

46+

47+getStyleMaps :: Archive -> StyleMaps

48+getStyleMaps = uncurry StyleMaps . archiveToStyles' getStyleName getStyleName