1 files changed, 108 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Readers/Docx/StyleMap.hs b/src/Text/Pandoc/Readers/Docx/StyleMap.hs
new file mode 100644
index 000000000..00906cf07
--- /dev/null
+++ b/src/Text/Pandoc/Readers/Docx/StyleMap.hs
@@ -0,0 +1,108 @@
+module Text.Pandoc.Readers.Docx.StyleMap (  StyleMaps(..)
+                                          , alterMap
+                                          , getMap
+                                          , defaultStyleMaps
+                                          , getStyleMaps
+                                          , getStyleId
+                                          , hasStyleName
+                                          ) where
+
+import           Text.XML.Light
+import           Text.Pandoc.Readers.Docx.Util
+import           Control.Monad.State
+import           Data.Char  (toLower)
+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) => 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
+
+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 = State StyleMaps a
+
+getStyleMaps :: Element -> StyleMaps
+getStyleMaps docElem = execState genStyleMap state'
+    where
+    state' = defaultStyleMaps {sNameSpaces = elemToNameSpaces docElem}
+    genStyleItem e = do
+      styleType <- getStyleType e
+      styleId <- getAttrStyleId e
+      nameValLowercase <- fmap (map toLower) `fmap` getNameVal e
+      case styleType of
+        Just ParaStyle -> modParaStyleMap $ insert nameValLowercase styleId
+        Just CharStyle -> modCharStyleMap $ insert nameValLowercase styleId
+        _              -> return ()
+    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 (Maybe StyleType)
+getStyleType e = do
+  styleTypeStr <- getAttrType e
+  case styleTypeStr of
+    Just "paragraph" -> return $ Just ParaStyle
+    Just "character" -> return $ Just CharStyle
+    _                -> return   Nothing
+
+getAttrType :: Element -> StateM (Maybe String)
+getAttrType el = do
+  name <- elemName' "type"
+  return $ findAttr name el
+
+getAttrStyleId :: Element -> StateM (Maybe String)
+getAttrStyleId el = do
+  name <- elemName' "styleId"
+  return $ findAttr name el
+
+getNameVal :: Element -> StateM (Maybe String)
+getNameVal el = do
+  name <- elemName' "name"
+  val <- elemName' "val"
+  return $ findChild name el >>= findAttr val
+
+elemName' :: String -> StateM QName
+elemName' name = do
+  namespaces <- gets sNameSpaces
+  return $ elemName namespaces "w" name