From 409111f647d3efa403ff1efff12eebc3173017b5 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Sun, 1 Mar 2015 22:57:35 +0300 Subject: Started moving StyleMap out of writer code --- src/Text/Pandoc/Readers/Docx/Parse.hs | 26 ++------ src/Text/Pandoc/Readers/Docx/StyleMap.hs | 105 +++++++++++++++++++++++++++++++ src/Text/Pandoc/Readers/Docx/Util.hs | 26 ++++++++ 3 files changed, 137 insertions(+), 20 deletions(-) create mode 100644 src/Text/Pandoc/Readers/Docx/StyleMap.hs create mode 100644 src/Text/Pandoc/Readers/Docx/Util.hs (limited to 'src/Text/Pandoc/Readers') diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs index b644923c4..cce80fb48 100644 --- a/src/Text/Pandoc/Readers/Docx/Parse.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse.hs @@ -65,6 +65,7 @@ import Text.Pandoc.Compat.Except import Text.TeXMath.Readers.OMML (readOMML) import Text.Pandoc.Readers.Docx.Fonts (getUnicode, Font(..)) import Text.TeXMath (Exp) +import Text.Pandoc.Readers.Docx.Util import Data.Char (readLitChar, ord, chr, isDigit) data ReaderEnv = ReaderEnv { envNotes :: Notes @@ -108,8 +109,6 @@ mapD f xs = in concatMapM handler xs -type NameSpaces = [(String, String)] - data Docx = Docx Document deriving Show @@ -249,10 +248,6 @@ type ChangeId = String type Author = String type ChangeDate = String -attrToNSPair :: Attr -> Maybe (String, String) -attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val) -attrToNSPair _ = Nothing - archiveToDocx :: Archive -> Either DocxError Docx archiveToDocx archive = do let notes = archiveToNotes archive @@ -269,7 +264,7 @@ archiveToDocument :: Archive -> D Document archiveToDocument zf = do entry <- maybeToD $ findEntryByPath "word/document.xml" zf docElem <- maybeToD $ (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry - let namespaces = mapMaybe attrToNSPair (elAttribs docElem) + let namespaces = elemToNameSpaces docElem bodyElem <- maybeToD $ findChild (elemName namespaces "w" "body") docElem body <- elemToBody namespaces bodyElem return $ Document namespaces body @@ -288,7 +283,7 @@ archiveToStyles zf = case stylesElem of Nothing -> (M.empty, M.empty) Just styElem -> - let namespaces = mapMaybe attrToNSPair (elAttribs styElem) + let namespaces = elemToNameSpaces styElem in ( M.fromList $ buildBasedOnList namespaces styElem (Nothing :: Maybe CharStyle), @@ -356,10 +351,10 @@ archiveToNotes zf = enElem = findEntryByPath "word/endnotes.xml" zf >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry) fn_namespaces = case fnElem of - Just e -> mapMaybe attrToNSPair (elAttribs e) + Just e -> elemToNameSpaces e Nothing -> [] en_namespaces = case enElem of - Just e -> mapMaybe attrToNSPair (elAttribs e) + Just e -> elemToNameSpaces e Nothing -> [] ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces fn = fnElem >>= (elemToNotes ns "footnote") @@ -459,7 +454,7 @@ archiveToNumbering' zf = do Nothing -> Just $ Numbering [] [] [] Just entry -> do numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry - let namespaces = mapMaybe attrToNSPair (elAttribs numberingElem) + let namespaces = elemToNameSpaces numberingElem numElems = findChildren (QName "num" (lookup "w" namespaces) (Just "w")) numberingElem @@ -488,15 +483,6 @@ elemToNotes _ _ _ = Nothing --------------------------------------------- --------------------------------------------- -elemName :: NameSpaces -> String -> String -> QName -elemName ns prefix name = (QName name (lookup prefix ns) (Just prefix)) - -isElem :: NameSpaces -> String -> String -> Element -> Bool -isElem ns prefix name element = - qName (elName element) == name && - qURI (elName element) == (lookup prefix ns) - - elemToTblGrid :: NameSpaces -> Element -> D TblGrid elemToTblGrid ns element | isElem ns "w" "tblGrid" element = let cols = findChildren (elemName ns "w" "gridCol") element diff --git a/src/Text/Pandoc/Readers/Docx/StyleMap.hs b/src/Text/Pandoc/Readers/Docx/StyleMap.hs new file mode 100644 index 000000000..2e3d6db95 --- /dev/null +++ b/src/Text/Pandoc/Readers/Docx/StyleMap.hs @@ -0,0 +1,105 @@ +module Text.Pandoc.Readers.Docx.StyleMap ( StyleMap + , ParaStyleMap + , CharStyleMap + , StyleMaps(..) + , defaultStyleMaps + , getStyleMaps + , getStyleId + , hasStyleName + ) where + +import Text.XML.Light +import Text.Pandoc.Readers.Docx.Util +import Control.Monad.State +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M + +newtype ParaStyleMap = ParaStyleMap ( M.Map String String ) +newtype CharStyleMap = CharStyleMap ( M.Map String String ) + +class StyleMap a where + alterMap :: (M.Map String String -> M.Map String String) -> a -> a + getMap :: a -> M.Map String String + +instance StyleMap ParaStyleMap where + alterMap f (ParaStyleMap m) = ParaStyleMap $ f m + getMap (ParaStyleMap m) = m + +instance StyleMap CharStyleMap where + alterMap f (CharStyleMap m) = CharStyleMap $ f m + getMap (CharStyleMap m) = m + +insert :: (StyleMap a) => String -> String -> a -> a +insert k v = alterMap $ M.insert k v + +getStyleId :: (StyleMap a) => String -> a -> String +getStyleId s = M.findWithDefault (filter (/=' ') s) (map toLower s) . getMap + +hasStyleName :: (StyleMap a) => String -> a -> Bool +hasStyleName styleName = M.member (map toLower styleName) . getMap + +data StyleMaps = StyleMaps { sNameSpaces :: NameSpaces + , sParaStyleMap :: ParaStyleMap + , sCharStyleMap :: CharStyleMap + } + +data StyleType = ParaStyle | CharStyle + +defaultStyleMaps :: StyleMaps +defaultStyleMaps = StyleMaps { sNameSpaces = [] + , sParaStyleMap = ParaStyleMap M.empty + , sCharStyleMap = CharStyleMap M.empty + } + +type StateM a = StateT StyleMaps Maybe a + +getStyleMaps :: Element -> StyleMaps +getStyleMaps docElem = fromMaybe state' $ execStateT genStyleMap state' + where + state' = defaultStyleMaps {sNameSpaces = elemToNameSpaces docElem} + insertPara key val = modify $ \s -> + s { sParaStyleMap = insert key val $ sParaStyleMap s } + insertChar key val = modify $ \s -> + s { sCharStyleMap = insert key val $ sCharStyleMap s } + genStyleItem e = do + styleType <- getStyleType e + nameVal <- getNameVal e + styleId <- getAttrStyleId e + let nameValLC = map toLower nameVal + case styleType of + ParaStyle -> insertPara nameValLC styleId + CharStyle -> insertChar nameValLC styleId + genStyleMap = do + style <- elemName' "style" + let styles = findChildren style docElem + forM_ styles genStyleItem + +getStyleType :: Element -> StateM StyleType +getStyleType e = do + styleTypeStr <- getAttrType e + case styleTypeStr of + "paragraph" -> return ParaStyle + "character" -> return CharStyle + _ -> lift Nothing + +getAttrType :: Element -> StateM String +getAttrType el = do + name <- elemName' "type" + lift $ findAttr name el + +getAttrStyleId :: Element -> StateM String +getAttrStyleId el = do + name <- elemName' "styleId" + lift $ findAttr name el + +getNameVal :: Element -> StateM String +getNameVal el = do + name <- elemName' "name" + val <- elemName' "val" + lift $ findChild name el >>= findAttr val + +elemName' :: String -> StateM QName +elemName' name = do + namespaces <- gets sNameSpaces + return $ elemName namespaces "w" name diff --git a/src/Text/Pandoc/Readers/Docx/Util.hs b/src/Text/Pandoc/Readers/Docx/Util.hs new file mode 100644 index 000000000..891f107b0 --- /dev/null +++ b/src/Text/Pandoc/Readers/Docx/Util.hs @@ -0,0 +1,26 @@ +module Text.Pandoc.Readers.Docx.Util ( + NameSpaces + , elemName + , isElem + , elemToNameSpaces + ) where + +import Text.XML.Light +import Data.Maybe (mapMaybe) + +type NameSpaces = [(String, String)] + +elemToNameSpaces :: Element -> NameSpaces +elemToNameSpaces = mapMaybe attrToNSPair . elAttribs + +attrToNSPair :: Attr -> Maybe (String, String) +attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val) +attrToNSPair _ = Nothing + +elemName :: NameSpaces -> String -> String -> QName +elemName ns prefix name = QName name (lookup prefix ns) (Just prefix) + +isElem :: NameSpaces -> String -> String -> Element -> Bool +isElem ns prefix name element = + qName (elName element) == name && + qURI (elName element) == lookup prefix ns -- cgit v1.2.3 From 65c80822e7900e92b4bba67912da77062654cc26 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 3 Mar 2015 13:08:52 +0300 Subject: Code cleanup --- src/Text/Pandoc/Readers/Docx/StyleMap.hs | 24 ++++++++++++------------ src/Text/Pandoc/Writers/Docx.hs | 24 ++++++++++-------------- 2 files changed, 22 insertions(+), 26 deletions(-) (limited to 'src/Text/Pandoc/Readers') diff --git a/src/Text/Pandoc/Readers/Docx/StyleMap.hs b/src/Text/Pandoc/Readers/Docx/StyleMap.hs index 2e3d6db95..5a4e9cfc2 100644 --- a/src/Text/Pandoc/Readers/Docx/StyleMap.hs +++ b/src/Text/Pandoc/Readers/Docx/StyleMap.hs @@ -1,7 +1,4 @@ -module Text.Pandoc.Readers.Docx.StyleMap ( StyleMap - , ParaStyleMap - , CharStyleMap - , StyleMaps(..) +module Text.Pandoc.Readers.Docx.StyleMap ( StyleMaps(..) , defaultStyleMaps , getStyleMaps , getStyleId @@ -58,23 +55,26 @@ getStyleMaps :: Element -> StyleMaps getStyleMaps docElem = fromMaybe state' $ execStateT genStyleMap state' where state' = defaultStyleMaps {sNameSpaces = elemToNameSpaces docElem} - insertPara key val = modify $ \s -> - s { sParaStyleMap = insert key val $ sParaStyleMap s } - insertChar key val = modify $ \s -> - s { sCharStyleMap = insert key val $ sCharStyleMap s } genStyleItem e = do styleType <- getStyleType e - nameVal <- getNameVal e styleId <- getAttrStyleId e - let nameValLC = map toLower nameVal + nameValLowercase <- map toLower `fmap` getNameVal e case styleType of - ParaStyle -> insertPara nameValLC styleId - CharStyle -> insertChar nameValLC styleId + ParaStyle -> modParaStyleMap $ insert nameValLowercase styleId + CharStyle -> modCharStyleMap $ insert nameValLowercase styleId genStyleMap = do style <- elemName' "style" let styles = findChildren style docElem forM_ styles genStyleItem +modParaStyleMap :: (ParaStyleMap -> ParaStyleMap) -> StateM () +modParaStyleMap f = modify $ \s -> + s {sParaStyleMap = f $ sParaStyleMap s} + +modCharStyleMap :: (CharStyleMap -> CharStyleMap) -> StateM () +modCharStyleMap f = modify $ \s -> + s {sCharStyleMap = f $ sCharStyleMap s} + getStyleType :: Element -> StateM StyleType getStyleType e = do styleTypeStr <- getAttrType e diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 53065309b..c4de12d2f 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -620,27 +620,23 @@ writeOpenXML opts (Pandoc meta blocks) = do blocksToOpenXML :: WriterOptions -> [Block] -> WS [Element] blocksToOpenXML opts bls = concat `fmap` mapM (blockToOpenXML opts) bls -pStyle :: String -> StyleMaps -> Element -pStyle sty m = mknode "w:pStyle" [("w:val",sty')] () - where - sty' = getStyleId sty $ sParaStyleMap m - pCustomStyle :: String -> Element pCustomStyle sty = mknode "w:pStyle" [("w:val",sty)] () pStyleM :: String -> WS XML.Element -pStyleM = (`fmap` gets stStyleMaps) . pStyle - -rStyle :: String -> StyleMaps -> Element -rStyle sty m = mknode "w:rStyle" [("w:val",sty')] () - where - sty' = getStyleId sty $ sCharStyleMap m +pStyleM styleName = do + styleMaps <- gets stStyleMaps + let sty' = getStyleId styleName $ sParaStyleMap styleMaps + return $ mknode "w:pStyle" [("w:val",sty')] () rCustomStyle :: String -> Element rCustomStyle sty = mknode "w:rStyle" [("w:val",sty)] () rStyleM :: String -> WS XML.Element -rStyleM = (`fmap` gets stStyleMaps) . rStyle +rStyleM styleName = do + styleMaps <- gets stStyleMaps + let sty' = getStyleId styleName $ sCharStyleMap styleMaps + return $ mknode "w:rStyle" [("w:val",sty')] () getUniqueId :: MonadIO m => m String -- the + 20 is to ensure that there are no clashes with the rIds @@ -689,10 +685,10 @@ blockToOpenXML opts (Para lst) = do paraProps <- getParaProps $ case lst of [Math DisplayMath _] -> True _ -> False - sm <- gets stStyleMaps + bodyTextStyle <- pStyleM "Body Text" let paraProps' = case paraProps of [] | isFirstPara -> [mknode "w:pPr" [] [pCustomStyle "FirstParagraph"]] - [] -> [mknode "w:pPr" [] [pStyle "Body Text" sm]] + [] -> [mknode "w:pPr" [] [bodyTextStyle]] ps -> ps modify $ \s -> s { stFirstPara = False } contents <- inlinesToOpenXML opts lst -- cgit v1.2.3