068bdbb · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Merge pull request #1716 from lierdakil/issue1607-pullreq

068bdbbMatthew Pickering12 years ago

src/Text/Pandoc/Writers/Docx.hs+35−7

compare with master

unifiedsplit

@@ -29,7 +29,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

29Conversion of 'Pandoc' documents to docx.

30-}

31module Text.Pandoc.Writers.Docx ( writeDocx ) where

32−import Data.List ( intercalate, isPrefixOf, isSuffixOf )

32+import Data.List ( intercalate, isPrefixOf, isSuffixOf, stripPrefix )

33import qualified Data.ByteString as B

34import qualified Data.ByteString.Lazy as BL

35import qualified Data.ByteString.Lazy.Char8 as BL8

@@ -64,6 +64,7 @@ import Text.Pandoc.MIME (MimeType, getMimeType, getMimeTypeDef,

64 extensionFromMimeType)

65import Control.Applicative ((<$>), (<|>), (<*>))

66import Data.Maybe (fromMaybe, mapMaybe)

67+import Data.Char (isDigit)

68data ListMarker = NoMarker

69data ListMarker = NoMarker

69 | BulletMarker

70 | BulletMarker

@@ -105,6 +106,7 @@ data WriterState = WriterState{

105 , stChangesAuthor :: String

106 , stChangesAuthor :: String

106 , stChangesDate :: String

107 , stChangesDate :: String

107 , stPrintWidth :: Integer

108 , stPrintWidth :: Integer

109+ , stHeadingStyles :: [(Int,String)]

108 }

110 }

109

111

110defaultWriterState :: WriterState

112defaultWriterState :: WriterState

@@ -124,6 +126,7 @@ defaultWriterState = WriterState{

124 , stChangesAuthor = "unknown"

126 , stChangesAuthor = "unknown"

125 , stChangesDate = "1969-12-31T19:00:00Z"

127 , stChangesDate = "1969-12-31T19:00:00Z"

126 , stPrintWidth = 1

128 , stPrintWidth = 1

129+ , stHeadingStyles = []

127 }

130 }

128

131

129type WS a = StateT WriterState IO a

132type WS a = StateT WriterState IO a

@@ -205,11 +208,37 @@ writeDocx opts doc@(Pandoc meta _) = do

205 <*> (read <$> mbAttrMarLeft ::Maybe Integer)

208 <*> (read <$> mbAttrMarLeft ::Maybe Integer)

206 )

209 )

207

210

211+ -- styles

212+ let stylepath = "word/styles.xml"

213+ styledoc <- parseXml refArchive distArchive stylepath

214+

215+ -- parse styledoc for heading styles

216+ let styleNamespaces = map ((,) <$> qName . attrKey <*> attrVal) .

217+ filter ((==Just "xmlns") . qPrefix . attrKey) .

218+ elAttribs $ styledoc

219+ let headingStyles =

220+ let

221+ mywURI = lookup "w" styleNamespaces

222+ myName name = QName name mywURI (Just "w")

223+ getAttrStyleId = findAttr (myName "styleId")

224+ getNameVal = findChild (myName "name") >=> findAttr (myName "val")

225+ getNum s | not $ null s, all isDigit s = Just (read s :: Int)

226+ | otherwise = Nothing

227+ getEngHeader = getAttrStyleId >=> stripPrefix "Heading" >=> getNum

228+ getIntHeader = getNameVal >=> stripPrefix "heading " >=> getNum

229+ toTuple getF = liftM2 (,) <$> getF <*> getAttrStyleId

230+ toMap getF = mapMaybe (toTuple getF) $

231+ findChildren (myName "style") styledoc

232+ select a b | not $ null a = a

233+ | otherwise = b

234+ in

235+ select (toMap getEngHeader) (toMap getIntHeader)

236+

208 ((contents, footnotes), st) <- runStateT (writeOpenXML opts{writerWrapText = False} doc')

237 ((contents, footnotes), st) <- runStateT (writeOpenXML opts{writerWrapText = False} doc')

209 defaultWriterState{ stChangesAuthor = fromMaybe "unknown" username

238 defaultWriterState{ stChangesAuthor = fromMaybe "unknown" username

210 , stChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime

239 , stChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime

211− , stPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth) }

240+ , stPrintWidth = (maybe 420 (\x -> quot x 20) pgContentWidth)

212−

241+ , stHeadingStyles = headingStyles}

213 let epochtime = floor $ utcTimeToPOSIXSeconds utctime

242 let epochtime = floor $ utcTimeToPOSIXSeconds utctime

214 let imgs = M.elems $ stImages st

243 let imgs = M.elems $ stImages st

215

244

@@ -363,8 +392,6 @@ writeDocx opts doc@(Pandoc meta _) = do

363

392

364 -- styles

393 -- styles

365 let newstyles = styleToOpenXml $ writerHighlightStyle opts

394 let newstyles = styleToOpenXml $ writerHighlightStyle opts

366− let stylepath = "word/styles.xml"

367− styledoc <- parseXml refArchive distArchive stylepath

368 let styledoc' = styledoc{ elContent = elContent styledoc ++

395 let styledoc' = styledoc{ elContent = elContent styledoc ++

369 [Elem x | x <- newstyles, writerHighlight opts] }

396 [Elem x | x <- newstyles, writerHighlight opts] }

370 let styleEntry = toEntry stylepath epochtime $ renderXml styledoc'

397 let styleEntry = toEntry stylepath epochtime $ renderXml styledoc'

@@ -616,8 +643,9 @@ blockToOpenXML opts (Div (_,["references"],_) bs) = do

616 return (header ++ rest)

643 return (header ++ rest)

617blockToOpenXML opts (Div _ bs) = blocksToOpenXML opts bs

644blockToOpenXML opts (Div _ bs) = blocksToOpenXML opts bs

618blockToOpenXML opts (Header lev (ident,_,_) lst) = do

645blockToOpenXML opts (Header lev (ident,_,_) lst) = do

646+ headingStyles <- gets stHeadingStyles

619− paraProps <- withParaProp (pStyle $ "Heading" ++ show lev) $

647+ paraProps <- maybe id (withParaProp . pStyle) (lookup lev headingStyles) $

620− getParaProps False

648+ getParaProps False

621 contents <- inlinesToOpenXML opts lst

649 contents <- inlinesToOpenXML opts lst

622 usedIdents <- gets stSectionIds

650 usedIdents <- gets stSectionIds

623 let bookmarkName = if null ident

651 let bookmarkName = if null ident