summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2014-12-07 16:44:24 +0000
committerMatthew Pickering <matthewtpickering@gmail.com>2014-12-07 16:44:24 +0000
commit068bdbbc9153834736a6f80b1457abd7612abbe9 (patch)
tree57949bd5a980d1a82a9e228d201b9077aa920820
parentdc16f21d981044db8478c9dfb0ee2145370b5b5f (diff)
parent3c894987b2d734a77e395e1968dac9ec80d4d51c (diff)
Merge pull request #1716 from lierdakil/issue1607-pullreq
First step to fixing internationalisation problems with docx output
-rw-r--r--src/Text/Pandoc/Writers/Docx.hs42
1 files changed, 35 insertions, 7 deletions
diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs
index 8740e7cef..f8e8cc34d 100644
--- a/src/Text/Pandoc/Writers/Docx.hs
+++ b/src/Text/Pandoc/Writers/Docx.hs
@@ -29,7 +29,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Conversion of 'Pandoc' documents to docx.
-}
module Text.Pandoc.Writers.Docx ( writeDocx ) where
-import Data.List ( intercalate, isPrefixOf, isSuffixOf )
+import Data.List ( intercalate, isPrefixOf, isSuffixOf, stripPrefix )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BL8
@@ -64,6 +64,7 @@ import Text.Pandoc.MIME (MimeType, getMimeType, getMimeTypeDef,
extensionFromMimeType)
import Control.Applicative ((<$>), (<|>), (<*>))
import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Char (isDigit)
data ListMarker = NoMarker
| BulletMarker
@@ -105,6 +106,7 @@ data WriterState = WriterState{
, stChangesAuthor :: String
, stChangesDate :: String
, stPrintWidth :: Integer
+ , stHeadingStyles :: [(Int,String)]
}
defaultWriterState :: WriterState
@@ -124,6 +126,7 @@ defaultWriterState = WriterState{
, stChangesAuthor = "unknown"
, stChangesDate = "1969-12-31T19:00:00Z"
, stPrintWidth = 1
+ , stHeadingStyles = []
}
type WS a = StateT WriterState IO a
@@ -205,11 +208,37 @@ writeDocx opts doc@(Pandoc meta _) = do
<*> (read <$> mbAttrMarLeft ::Maybe Integer)
)
+ -- styles
+ let stylepath = "word/styles.xml"
+ styledoc <- parseXml refArchive distArchive stylepath
+
+ -- parse styledoc for heading styles
+ let styleNamespaces = map ((,) <$> qName . attrKey <*> attrVal) .
+ filter ((==Just "xmlns") . qPrefix . attrKey) .
+ elAttribs $ styledoc
+ let headingStyles =
+ let
+ mywURI = lookup "w" styleNamespaces
+ myName name = QName name mywURI (Just "w")
+ getAttrStyleId = findAttr (myName "styleId")
+ getNameVal = findChild (myName "name") >=> findAttr (myName "val")
+ getNum s | not $ null s, all isDigit s = Just (read s :: Int)
+ | otherwise = Nothing
+ getEngHeader = getAttrStyleId >=> stripPrefix "Heading" >=> getNum
+ getIntHeader = getNameVal >=> stripPrefix "heading " >=> getNum
+ toTuple getF = liftM2 (,) <$> getF <*> getAttrStyleId
+ toMap getF = mapMaybe (toTuple getF) $
+ findChildren (myName "style") styledoc
+ select a b | not $ null a = a
+ | otherwise = b
+ in
+ select (toMap getEngHeader) (toMap getIntHeader)
+
((contents, footnotes), st) <- runStateT (writeOpenXML opts{writerWrapText = False} doc')
defaultWriterState{ stChangesAuthor = fromMaybe "unknown" username
, stChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime
- , stPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth) }
-
+ , stPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth)
+ , stHeadingStyles = headingStyles}
let epochtime = floor $ utcTimeToPOSIXSeconds utctime
let imgs = M.elems $ stImages st
@@ -363,8 +392,6 @@ writeDocx opts doc@(Pandoc meta _) = do
-- styles
let newstyles = styleToOpenXml $ writerHighlightStyle opts
- let stylepath = "word/styles.xml"
- styledoc <- parseXml refArchive distArchive stylepath
let styledoc' = styledoc{ elContent = elContent styledoc ++
[Elem x | x <- newstyles, writerHighlight opts] }
let styleEntry = toEntry stylepath epochtime $ renderXml styledoc'
@@ -616,8 +643,9 @@ blockToOpenXML opts (Div (_,["references"],_) bs) = do
return (header ++ rest)
blockToOpenXML opts (Div _ bs) = blocksToOpenXML opts bs
blockToOpenXML opts (Header lev (ident,_,_) lst) = do
- paraProps <- withParaProp (pStyle $ "Heading" ++ show lev) $
- getParaProps False
+ headingStyles <- gets stHeadingStyles
+ paraProps <- maybe id (withParaProp . pStyle) (lookup lev headingStyles) $
+ getParaProps False
contents <- inlinesToOpenXML opts lst
usedIdents <- gets stSectionIds
let bookmarkName = if null ident