From d09b7593f60e056d82108a20ca13c48e6b51fc04 Mon Sep 17 00:00:00 2001
From: Nikolay Yakimov <root@livid.pp.ru>
Date: Tue, 24 Mar 2015 19:24:29 +0300
Subject: Docx Writer: Fix StyleMap

I've messed up badly with it, so it didn't work properly most of the
time. At the plus side, fallback mechanic is working wonderfully.
---
 src/Text/Pandoc/Readers/Docx/StyleMap.hs | 37 ++++++++++++++++----------------
 1 file changed, 19 insertions(+), 18 deletions(-)

(limited to 'src')

diff --git a/src/Text/Pandoc/Readers/Docx/StyleMap.hs b/src/Text/Pandoc/Readers/Docx/StyleMap.hs
index 5a4e9cfc2..2901ea2a3 100644
--- a/src/Text/Pandoc/Readers/Docx/StyleMap.hs
+++ b/src/Text/Pandoc/Readers/Docx/StyleMap.hs
@@ -9,7 +9,6 @@ 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 )
@@ -27,8 +26,9 @@ 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
+insert :: (StyleMap a) => Maybe String -> Maybe String -> a -> a
+insert (Just k) (Just v) m = alterMap (M.insert k v) m
+insert _ _ m = m
 
 getStyleId :: (StyleMap a) => String -> a -> String
 getStyleId s = M.findWithDefault (filter (/=' ') s) (map toLower s) . getMap
@@ -49,19 +49,20 @@ defaultStyleMaps = StyleMaps { sNameSpaces = []
                              , sCharStyleMap = CharStyleMap M.empty
                              }
 
-type StateM a = StateT StyleMaps Maybe a
+type StateM a = State StyleMaps a
 
 getStyleMaps :: Element -> StyleMaps
-getStyleMaps docElem = fromMaybe state' $ execStateT genStyleMap state'
+getStyleMaps docElem = execState genStyleMap state'
     where
     state' = defaultStyleMaps {sNameSpaces = elemToNameSpaces docElem}
     genStyleItem e = do
       styleType <- getStyleType e
       styleId <- getAttrStyleId e
-      nameValLowercase <- map toLower `fmap` getNameVal e
+      nameValLowercase <- fmap (map toLower) `fmap` getNameVal e
       case styleType of
-        ParaStyle -> modParaStyleMap $ insert nameValLowercase styleId
-        CharStyle -> modCharStyleMap $ insert nameValLowercase styleId
+        Just ParaStyle -> modParaStyleMap $ insert nameValLowercase styleId
+        Just CharStyle -> modCharStyleMap $ insert nameValLowercase styleId
+        _              -> return ()
     genStyleMap = do
       style <- elemName' "style"
       let styles = findChildren style docElem
@@ -75,29 +76,29 @@ modCharStyleMap :: (CharStyleMap -> CharStyleMap) -> StateM ()
 modCharStyleMap f = modify $ \s ->
   s {sCharStyleMap = f $ sCharStyleMap s}
 
-getStyleType :: Element -> StateM StyleType
+getStyleType :: Element -> StateM (Maybe StyleType)
 getStyleType e = do
   styleTypeStr <- getAttrType e
   case styleTypeStr of
-    "paragraph" -> return ParaStyle
-    "character" -> return CharStyle
-    _           -> lift   Nothing
+    Just "paragraph" -> return $ Just ParaStyle
+    Just "character" -> return $ Just CharStyle
+    _                -> return   Nothing
 
-getAttrType :: Element -> StateM String
+getAttrType :: Element -> StateM (Maybe String)
 getAttrType el = do
   name <- elemName' "type"
-  lift $ findAttr name el
+  return $ findAttr name el
 
-getAttrStyleId :: Element -> StateM String
+getAttrStyleId :: Element -> StateM (Maybe String)
 getAttrStyleId el = do
   name <- elemName' "styleId"
-  lift $ findAttr name el
+  return $ findAttr name el
 
-getNameVal :: Element -> StateM String
+getNameVal :: Element -> StateM (Maybe String)
 getNameVal el = do
   name <- elemName' "name"
   val <- elemName' "val"
-  lift $ findChild name el >>= findAttr val
+  return $ findChild name el >>= findAttr val
 
 elemName' :: String -> StateM QName
 elemName' name = do
-- 
cgit v1.2.3