@@ -50,7 +50,6 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
5050 , Cell(..)
5151 , archiveToDocx
5252 ) where
53−
5453import Codec.Archive.Zip
5554import Text.XML.Light
5655import Data.Maybe
@@ -73,6 +72,7 @@ data ReaderEnv = ReaderEnv { envNotes :: Notes
7372 , envRelationships :: [Relationship]
7473 , envMedia :: Media
7574 , envFont :: Maybe Font
75+ , envCharStyles :: CharStyleMap
7676 }
7777 deriving Show
7878
@@ -120,6 +120,10 @@ data Body = Body [BodyPart]
120120
121121type Media = [(FilePath, B.ByteString)]
122122
123+type CharStyle = (String, RunStyle)
124+
125+type CharStyleMap = M.Map String RunStyle
126+
123127data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
124128 deriving Show
125129
@@ -206,7 +210,7 @@ data RunStyle = RunStyle { isBold :: Maybe Bool
206210 , isStrike :: Maybe Bool
207211 , rVertAlign :: Maybe VertAlign
208212 , rUnderline :: Maybe String
209− , rStyle :: Maybe String }
213+ , rStyle :: Maybe CharStyle}
210214 deriving Show
211215
212216defaultRunStyle :: RunStyle
@@ -216,8 +220,7 @@ defaultRunStyle = RunStyle { isBold = Nothing
216220 , isStrike = Nothing
217221 , rVertAlign = Nothing
218222 , rUnderline = Nothing
219− , rStyle = Nothing
220− }
223+ , rStyle = Nothing}
221224
222225
223226type Target = String
@@ -239,7 +242,8 @@ archiveToDocx archive = do
239242 numbering = archiveToNumbering archive
240243 rels = archiveToRelationships archive
241244 media = archiveToMedia archive
242− rEnv = ReaderEnv notes numbering rels media Nothing
245+ styles = archiveToStyles archive
246+ rEnv = ReaderEnv notes numbering rels media Nothing styles
243247 doc <- runD (archiveToDocument archive) rEnv
244248 return $ Docx doc
245249
@@ -259,6 +263,53 @@ elemToBody ns element | isElem ns "w" "body" element =
259263 (\bps -> return $ Body bps)
260264elemToBody _ _ = throwError WrongElem
261265
266+archiveToStyles :: Archive -> CharStyleMap
267+archiveToStyles zf =
268+ let stylesElem = findEntryByPath "word/styles.xml" zf >>=
269+ (parseXMLDoc . UTF8.toStringLazy . fromEntry)
270+ in
271+ case stylesElem of
272+ Nothing -> M.empty
273+ Just styElem ->
274+ let namespaces = mapMaybe attrToNSPair (elAttribs styElem)
275+ in
276+ M.fromList $ buildBasedOnList namespaces styElem Nothing
277+
278+isBasedOnStyle :: NameSpaces -> Element -> Maybe CharStyle -> Bool
279+isBasedOnStyle ns element parentStyle
280+ | isElem ns "w" "style" element
281+ , Just "character" <- findAttr (elemName ns "w" "type") element
282+ , Just basedOnVal <- findChild (elemName ns "w" "basedOn") element >>=
283+ findAttr (elemName ns "w" "val")
284+ , Just (parentId, _) <- parentStyle = (basedOnVal == parentId)
285+ | isElem ns "w" "style" element
286+ , Just "character" <- findAttr (elemName ns "w" "type") element
287+ , Nothing <- findChild (elemName ns "w" "basedOn") element
288+ , Nothing <- parentStyle = True
289+ | otherwise = False
290+
291+elemToCharStyle :: NameSpaces -> Element -> Maybe CharStyle -> Maybe CharStyle
292+elemToCharStyle ns element parentStyle
293+ | isElem ns "w" "style" element
294+ , Just "character" <- findAttr (elemName ns "w" "type") element
295+ , Just styleId <- findAttr (elemName ns "w" "styleId") element =
296+ Just (styleId, elemToRunStyle ns element parentStyle)
297+ | otherwise = Nothing
298+
299+getStyleChildren :: NameSpaces -> Element -> Maybe CharStyle -> [CharStyle]
300+getStyleChildren ns element parentStyle
301+ | isElem ns "w" "styles" element =
302+ mapMaybe (\e -> elemToCharStyle ns e parentStyle) $
303+ filterChildren (\e' -> isBasedOnStyle ns e' parentStyle) element
304+ | otherwise = []
305+
306+buildBasedOnList :: NameSpaces -> Element -> Maybe CharStyle -> [CharStyle]
307+buildBasedOnList ns element rootStyle =
308+ case (getStyleChildren ns element rootStyle) of
309+ [] -> []
310+ stys -> stys ++
311+ (concatMap (\s -> buildBasedOnList ns element (Just s)) stys)
312+
262313archiveToNotes :: Archive -> Notes
263314archiveToNotes zf =
264315 let fnElem = findEntryByPath "word/footnotes.xml" zf
@@ -629,7 +680,8 @@ elemToRun ns element
629680elemToRun ns element
630681 | isElem ns "w" "r" element = do
631682 runElems <- elemToRunElems ns element
632− return $ Run (elemToRunStyle ns element) runElems
683+ runStyle <- elemToRunStyleD ns element
684+ return $ Run runStyle runElems
633685elemToRun _ _ = throwError WrongElem
634686
635687elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
@@ -669,9 +721,22 @@ checkOnOff ns rPr tag
669721 | Just _ <- findChild tag rPr = Just True
670722checkOnOff _ _ _ = Nothing
671723
672−
673−elemToRunStyle :: NameSpaces -> Element -> RunStyle
674−elemToRunStyle ns element
724+elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
725+elemToRunStyleD ns element
726+ | Just rPr <- findChild (elemName ns "w" "rPr") element = do
727+ charStyles <- asks envCharStyles
728+ let parentSty = case
729+ findChild (elemName ns "w" "rStyle") rPr >>=
730+ findAttr (elemName ns "w" "val")
731+ of
732+ Just styName | Just style <- M.lookup styName charStyles ->
733+ Just (styName, style)
734+ _ -> Nothing
735+ return $ elemToRunStyle ns element parentSty
736+elemToRunStyleD _ _ = return defaultRunStyle
737+
738+elemToRunStyle :: NameSpaces -> Element -> Maybe CharStyle -> RunStyle
739+elemToRunStyle ns element parentStyle
675740 | Just rPr <- findChild (elemName ns "w" "rPr") element =
676741 RunStyle
677742 {
@@ -689,11 +754,9 @@ elemToRunStyle ns element
689754 , rUnderline =
690755 findChild (elemName ns "w" "u") rPr >>=
691756 findAttr (elemName ns "w" "val")
692− , rStyle =
693− findChild (elemName ns "w" "rStyle") rPr >>=
694− findAttr (elemName ns "w" "val")
757+ , rStyle = parentStyle
695758 }
696−elemToRunStyle _ _ = defaultRunStyle
759+elemToRunStyle _ _ _ = defaultRunStyle
697760
698761elemToRunElem :: NameSpaces -> Element -> D RunElem
699762elemToRunElem ns element