Merge pull request #1968 from lierdakil/issue1607

Fixes for multiple docx writer style bugs.

3 files changed, 137 insertions, 20 deletions

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..5a4e9cfc2
--- /dev/null
+++ b/src/Text/Pandoc/Readers/Docx/StyleMap.hs
@@ -0,0 +1,105 @@
+module Text.Pandoc.Readers.Docx.StyleMap (  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}
+    genStyleItem e = do
+      styleType <- getStyleType e
+      styleId <- getAttrStyleId e
+      nameValLowercase <- map toLower `fmap` getNameVal e
+      case styleType of
+        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
+  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