[Docx Writer] Re-use Readers.Docx.Parse for StyleMap (#5766)

* [Docx Parser] Move style-parsing-specific code to a new module

* [Docx Writer] Re-use Readers.Docx.Parse.Styles for StyleMap

* [Docx Writer] Move Readers.Docx.StyleMap to Writers.Docx.StyleMap

It's never used outside of writer code, so it makes more sense to scope it under writers really.

1 files changed, 48 insertions, 0 deletions

diff --git a/src/Text/Pandoc/Writers/Docx/StyleMap.hs b/src/Text/Pandoc/Writers/Docx/StyleMap.hs
new file mode 100644
index 000000000..4f0b0c3f9
--- /dev/null
+++ b/src/Text/Pandoc/Writers/Docx/StyleMap.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{- |
+   Module : Text.Pandoc.Writers.Docx.StyleMap
+   Copyright   : © 2014-2019 Jesse Rosenthal <jrosenthal@jhu.edu>,
+                   2014-2019 John MacFarlane <jgm@berkeley.edu>,
+                   2015-2019 Nikolay Yakimov <root@livid.pp.ru>
+   License     : GNU GPL, version 2 or above
+
+   Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
+   Stability   : alpha
+   Portability : portable
+
+Mappings of element styles (word to pandoc-internal).
+-}
+
+module Text.Pandoc.Writers.Docx.StyleMap ( StyleMaps(..)
+                                         , ParaStyleName
+                                         , CharStyleName
+                                         , getStyleMaps
+                                         , getStyleIdFromName
+                                         , hasStyleName
+                                         , fromStyleId
+                                         , fromStyleName
+                                         ) where
+
+import Text.Pandoc.Readers.Docx.Parse.Styles
+import Codec.Archive.Zip
+import qualified Data.Map as M
+import Data.String
+import Data.Char (isSpace)
+import Prelude
+
+data StyleMaps = StyleMaps { smCharStyle :: CharStyleNameMap, smParaStyle :: ParaStyleNameMap }
+type ParaStyleNameMap = M.Map ParaStyleName ParStyle
+type CharStyleNameMap = M.Map CharStyleName CharStyle
+
+getStyleIdFromName :: (Ord sn, FromStyleName sn, IsString (StyleId sty), HasStyleId sty)
+                   => sn -> M.Map sn sty -> StyleId sty
+getStyleIdFromName s = maybe (fallback s) getStyleId . M.lookup s
+  where fallback = fromString . filter (not . isSpace) . fromStyleName
+
+hasStyleName :: (Ord sn, HasStyleId sty)
+             => sn -> M.Map sn sty -> Bool
+hasStyleName styleName = M.member styleName
+
+getStyleMaps :: Archive -> StyleMaps
+getStyleMaps = uncurry StyleMaps . archiveToStyles' getStyleName getStyleName