@@ -1,14 +1,9 @@
11{-# LANGUAGE NoImplicitPrelude #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE PatternGuards #-}
52{-# LANGUAGE ViewPatterns #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
93{- |
104 Module : Text.Pandoc.Readers.Docx.Parse
115 Copyright : Copyright (C) 2014-2019 Jesse Rosenthal
6+ 2019 Nikolay Yakimov <root@livid.pp.ru>
127 License : GNU GPL, version 2 or above
138
149 Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
@@ -57,6 +52,7 @@ module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
5752 , leftBiasedMergeRunStyle
5853 ) where
5954import Prelude
55+import Text.Pandoc.Readers.Docx.Parse.Styles
6056import Codec.Archive.Zip
6157import Control.Applicative ((<|>))
6258import Control.Monad.Except
@@ -64,13 +60,10 @@ import Control.Monad.Reader
6460import Control.Monad.State.Strict
6561import Data.Bits ((.|.))
6662import qualified Data.ByteString.Lazy as B
67−import Data.Char (chr, ord, readLitChar, toLower)
63+import Data.Char (chr, ord, readLitChar)
6864import Data.List
69−import Data.Function (on)
70−import Data.String (IsString(..))
7165import qualified Data.Map as M
7266import Data.Maybe
73−import Data.Coerce
7467import System.FilePath
7568import Text.Pandoc.Readers.Docx.Util
7669import Text.Pandoc.Readers.Docx.Fields
@@ -262,37 +255,6 @@ newtype Row = Row [Cell]
262255newtype Cell = Cell [BodyPart]
263256 deriving Show
264257
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−
296258leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle
297259leftBiasedMergeRunStyle a b = RunStyle
298260 { isBold = isBold a <|> isBold b
@@ -333,44 +295,6 @@ data Run = Run RunStyle [RunElem]
333295data RunElem = TextRun String | LnBrk | Tab | SoftHyphen | NoBreakHyphen
334296 deriving Show
335297
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−
374298type Target = String
375299type Anchor = String
376300type URL = String
@@ -449,46 +373,6 @@ elemToBody _ _ = throwError WrongElem
449373
450374archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)
451375archiveToStyles = 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
492376
493377class HasParentStyle a where
494378 getParentStyle :: a -> Maybe a
@@ -511,52 +395,6 @@ constructBogusParStyleData stName = ParStyle
511395 , pStyleId = ParaStyleId . filter (/=' ') . fromStyleName $ stName
512396 }
513397
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−
560398archiveToNotes :: Archive -> Notes
561399archiveToNotes zf =
562400 let fnElem = findEntryByPath "word/footnotes.xml" zf
@@ -789,9 +627,6 @@ testBitMask bitMaskS n =
789627 [] -> False
790628 ((n', _) : _) -> (n' .|. n) /= 0
791629
792−stringToInteger :: String -> Maybe Integer
793−stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])
794−
795630pHeading :: ParagraphStyle -> Maybe (ParaStyleName, Int)
796631pHeading = getParStyleField headingLev . pStyle
797632
@@ -1166,21 +1001,6 @@ elemToParagraphStyle ns element sty
11661001 }
11671002elemToParagraphStyle _ _ _ = defaultParagraphStyle
11681003
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−
11841004elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
11851005elemToRunStyleD ns element
11861006 | Just rPr <- findChildByName ns "w" "rPr" element = do
@@ -1192,80 +1012,6 @@ elemToRunStyleD ns element
11921012 return $ elemToRunStyle ns element parentSty
11931013elemToRunStyleD _ _ = return defaultRunStyle
11941014
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−
12691015elemToRunElem :: NameSpaces -> Element -> D RunElem
12701016elemToRunElem ns element
12711017 | isElem ns "w" "t" element