5cdd117 · typeable/pandoc

29Conversion of 'Pandoc' documents to docx.

30-}

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

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

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

33import qualified Data.ByteString as B

34import qualified Data.ByteString.Lazy as BL

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

64 extensionFromMimeType)

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

66import Data.Maybe (fromMaybe, mapMaybe)

67−import Data.Char (isDigit)

67+import Data.Char (toLower)

68

69data ListMarker = NoMarker

70 | BulletMarker

90 OneParen -> '2'

91 TwoParens -> '3'

92

93+newtype ParaStyleMap = ParaStyleMap (M.Map String String) deriving Show

94+newtype CharStyleMap = CharStyleMap (M.Map String String) deriving Show

95+

93data WriterState = WriterState{

96data WriterState = WriterState{

94 stTextProperties :: [Element]

97 stTextProperties :: [Element]

95 , stParaProperties :: [Element]

98 , stParaProperties :: [Element]

106 , stChangesAuthor :: String

109 , stChangesAuthor :: String

107 , stChangesDate :: String

110 , stChangesDate :: String

108 , stPrintWidth :: Integer

111 , stPrintWidth :: Integer

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

112+ , stParaStyles :: ParaStyleMap

113+ , stCharStyles :: CharStyleMap

110 , stFirstPara :: Bool

114 , stFirstPara :: Bool

111 }

115 }

112

116

127 , stChangesAuthor = "unknown"

131 , stChangesAuthor = "unknown"

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

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

129 , stPrintWidth = 1

133 , stPrintWidth = 1

130− , stHeadingStyles = []

134+ , stParaStyles = ParaStyleMap M.empty

135+ , stCharStyles = CharStyleMap M.empty

131 , stFirstPara = False

136 , stFirstPara = False

132 }

137 }

133

138

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

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

219 filter ((==Just "xmlns") . qPrefix . attrKey) .

224 filter ((==Just "xmlns") . qPrefix . attrKey) .

220 elAttribs $ styledoc

225 elAttribs $ styledoc

221− let headingStyles =

222− let

223− mywURI = lookup "w" styleNamespaces

226+ mywURI = lookup "w" styleNamespaces

224− myName name = QName name mywURI (Just "w")

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

225− getAttrStyleId = findAttr (myName "styleId")

228+ getAttrStyleId = findAttr (myName "styleId")

229+ getAttrType = findAttr (myName "type")

230+ isParaStyle = (Just "paragraph" ==) . getAttrType

231+ isCharStyle = (Just "character" ==) . getAttrType

226− getNameVal = findChild (myName "name") >=> findAttr (myName "val")

232+ getNameVal = findChild (myName "name") >=> findAttr (myName "val") >=> return . map toLower

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

228− | otherwise = Nothing

229− getEngHeader = getAttrStyleId >=> stripPrefix "Heading" >=> getNum

230− getIntHeader = getNameVal >=> stripPrefix "heading " >=> getNum

231− toTuple getF = liftM2 (,) <$> getF <*> getAttrStyleId

233+ genStyleItem f e | f e = liftM2 (,) <$> getNameVal <*> getAttrStyleId $ e

232− toMap getF = mapMaybe (toTuple getF) $

234+ | otherwise = Nothing

233− findChildren (myName "style") styledoc

235+ genStyleMap f = M.fromList $ mapMaybe (genStyleItem f) $ findChildren (myName "style") styledoc

234− select a b | not $ null a = a

236+ paraStyles = ParaStyleMap $ genStyleMap isParaStyle

235− | otherwise = b

237+ charStyles = CharStyleMap $ genStyleMap isCharStyle

236− in

237− select (toMap getEngHeader) (toMap getIntHeader)

238

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

240 defaultWriterState{ stChangesAuthor = fromMaybe "unknown" username

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

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

243− , stHeadingStyles = headingStyles}

243+ , stParaStyles = paraStyles

244+ , stCharStyles = charStyles}

244 let epochtime = floor $ utcTimeToPOSIXSeconds utctime

245 let epochtime = floor $ utcTimeToPOSIXSeconds utctime

245 let imgs = M.elems $ stImages st

246 let imgs = M.elems $ stImages st

246

247

602 Just (MetaBlocks [Para xs]) -> xs

603 Just (MetaBlocks [Para xs]) -> xs

603 Just (MetaInlines xs) -> xs

604 Just (MetaInlines xs) -> xs

604 _ -> []

605 _ -> []

605− title <- withParaProp (pStyle "Title") $ blocksToOpenXML opts [Para tit | not (null tit)]

606+ title <- withParaPropM (pStyleM "Title") $ blocksToOpenXML opts [Para tit | not (null tit)]

606− subtitle <- withParaProp (pStyle "Subtitle") $ blocksToOpenXML opts [Para subtitle' | not (null subtitle')]

607+ subtitle <- withParaPropM (pStyleM "Subtitle") $ blocksToOpenXML opts [Para subtitle' | not (null subtitle')]

607− authors <- withParaProp (pStyle "Author") $ blocksToOpenXML opts $

608+ authors <- withParaPropM (pStyleM "Author") $ blocksToOpenXML opts $

608 map Para auths

609 map Para auths

609− date <- withParaProp (pStyle "Date") $ blocksToOpenXML opts [Para dat | not (null dat)]

610+ date <- withParaPropM (pStyleM "Date") $ blocksToOpenXML opts [Para dat | not (null dat)]

610 abstract <- if null abstract'

611 abstract <- if null abstract'

611 then return []

612 then return []

612− else withParaProp (pStyle "Abstract") $ blocksToOpenXML opts abstract'

613+ else withParaPropM (pStyleM "Abstract") $ blocksToOpenXML opts abstract'

613 let convertSpace (Str x : Space : Str y : xs) = Str (x ++ " " ++ y) : xs

614 let convertSpace (Str x : Space : Str y : xs) = Str (x ++ " " ++ y) : xs

614 convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs

615 convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs

615 convertSpace xs = xs

616 convertSpace xs = xs

623blocksToOpenXML :: WriterOptions -> [Block] -> WS [Element]

624blocksToOpenXML :: WriterOptions -> [Block] -> WS [Element]

624blocksToOpenXML opts bls = concat `fmap` mapM (blockToOpenXML opts) bls

625blocksToOpenXML opts bls = concat `fmap` mapM (blockToOpenXML opts) bls

625

626

627+getStyleId :: String -> M.Map String String -> String

628+getStyleId s = M.findWithDefault (filter (/=' ') s) (map toLower s)

629+

626−pStyle :: String -> Element

630+pStyle :: String -> ParaStyleMap -> Element

627−pStyle sty = mknode "w:pStyle" [("w:val",sty)] ()

631+pStyle sty (ParaStyleMap m) = mknode "w:pStyle" [("w:val",sty')] ()

632+ where

633+ sty' = getStyleId sty m

634+

635+pStyleM :: String -> WS XML.Element

636+pStyleM = flip fmap (gets stParaStyles) . pStyle

637+

638+rStyle :: String -> CharStyleMap -> Element

639+rStyle sty (CharStyleMap m) = mknode "w:rStyle" [("w:val",sty')] ()

640+ where

641+ sty' = getStyleId sty m

628

642

629−rStyle :: String -> Element

643+rStyleM :: String -> WS XML.Element

630−rStyle sty = mknode "w:rStyle" [("w:val",sty)] ()

644+rStyleM = flip fmap (gets stCharStyles) . rStyle

631

645

632getUniqueId :: MonadIO m => m String

646getUniqueId :: MonadIO m => m String

633-- the + 20 is to ensure that there are no clashes with the rIds

647-- the + 20 is to ensure that there are no clashes with the rIds

641 let (hs, bs') = span isHeaderBlock bs

655 let (hs, bs') = span isHeaderBlock bs

642 header <- blocksToOpenXML opts hs

656 header <- blocksToOpenXML opts hs

643 -- We put the Bibliography style on paragraphs after the header

657 -- We put the Bibliography style on paragraphs after the header

644− rest <- withParaProp (pStyle "Bibliography") $ blocksToOpenXML opts bs'

658+ rest <- withParaPropM (pStyleM "Bibliography") $ blocksToOpenXML opts bs'

645 return (header ++ rest)

659 return (header ++ rest)

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

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

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

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

648 setFirstPara

662 setFirstPara

649− headingStyles <- gets stHeadingStyles

663+ paraProps <- withParaPropM (pStyleM ("Heading "++show lev)) $

650− paraProps <- maybe id (withParaProp . pStyle) (lookup lev headingStyles) $

651 getParaProps False

664 getParaProps False

652 contents <- inlinesToOpenXML opts lst

665 contents <- inlinesToOpenXML opts lst

653 usedIdents <- gets stSectionIds

666 usedIdents <- gets stSectionIds

660 ,("w:name",bookmarkName)] ()

673 ,("w:name",bookmarkName)] ()

661 let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] ()

674 let bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] ()

662 return [mknode "w:p" [] (paraProps ++ [bookmarkStart, bookmarkEnd] ++ contents)]

675 return [mknode "w:p" [] (paraProps ++ [bookmarkStart, bookmarkEnd] ++ contents)]

663−blockToOpenXML opts (Plain lst) = withParaProp (pStyle "Compact")

676+blockToOpenXML opts (Plain lst) = withParaPropM (pStyleM "Compact")

664 $ blockToOpenXML opts (Para lst)

677 $ blockToOpenXML opts (Para lst)

665-- title beginning with fig: indicates that the image is a figure

678-- title beginning with fig: indicates that the image is a figure

666blockToOpenXML opts (Para [Image alt (src,'f':'i':'g':':':tit)]) = do

679blockToOpenXML opts (Para [Image alt (src,'f':'i':'g':':':tit)]) = do

667 setFirstPara

680 setFirstPara

668 paraProps <- getParaProps False

681 paraProps <- getParaProps False

669 contents <- inlinesToOpenXML opts [Image alt (src,tit)]

682 contents <- inlinesToOpenXML opts [Image alt (src,tit)]

670− captionNode <- withParaProp (pStyle "ImageCaption")

683+ captionNode <- withParaPropM (pStyleM "Image Caption")

671 $ blockToOpenXML opts (Para alt)

684 $ blockToOpenXML opts (Para alt)

672 return $ mknode "w:p" [] (paraProps ++ contents) : captionNode

685 return $ mknode "w:p" [] (paraProps ++ contents) : captionNode

673-- fixDisplayMath sometimes produces a Para [] as artifact

686-- fixDisplayMath sometimes produces a Para [] as artifact

674blockToOpenXML _ (Para []) = return []

687blockToOpenXML _ (Para []) = return []

675blockToOpenXML opts (Para lst) = do

688blockToOpenXML opts (Para lst) = do

676− isFirstPara <- gets stFirstPara

689+ isFirstPara <- gets stFirstPara

677 paraProps <- getParaProps $ case lst of

690 paraProps <- getParaProps $ case lst of

678 [Math DisplayMath _] -> True

691 [Math DisplayMath _] -> True

679 _ -> False

692 _ -> False

693+ pSM <- gets stParaStyles

680 let paraProps' = case paraProps of

694 let paraProps' = case paraProps of

681− [] | isFirstPara -> [mknode "w:pPr" [] [(pStyle "FirstParagraph")]]

695+ [] | isFirstPara -> [mknode "w:pPr" [] [(pStyle "First Paragraph" pSM)]]

682− [] -> [mknode "w:pPr" [] [(pStyle "BodyText")]]

696+ [] -> [mknode "w:pPr" [] [(pStyle "Body Text" pSM)]]

683 ps -> ps

697 ps -> ps

684 modify $ \s -> s { stFirstPara = False }

698 modify $ \s -> s { stFirstPara = False }

685 contents <- inlinesToOpenXML opts lst

699 contents <- inlinesToOpenXML opts lst

688 | format == Format "openxml" = return [ x | Elem x <- parseXML str ]

702 | format == Format "openxml" = return [ x | Elem x <- parseXML str ]

689 | otherwise = return []

703 | otherwise = return []

690blockToOpenXML opts (BlockQuote blocks) = do

704blockToOpenXML opts (BlockQuote blocks) = do

691− p <- withParaProp (pStyle "BlockQuote") $ blocksToOpenXML opts blocks

705+ p <- withParaPropM (pStyleM "Block Quote") $ blocksToOpenXML opts blocks

692 setFirstPara

706 setFirstPara

693 return p

707 return p

694blockToOpenXML opts (CodeBlock attrs str) = do

708blockToOpenXML opts (CodeBlock attrs str) = do

695− p <- withParaProp (pStyle "SourceCode") $ (blockToOpenXML opts $ Para [Code attrs str])

709+ p <- withParaPropM (pStyleM "Source Code") (blockToOpenXML opts $ Para [Code attrs str])

696 setFirstPara

710 setFirstPara

697 return p

711 return p

698blockToOpenXML _ HorizontalRule = do

712blockToOpenXML _ HorizontalRule = do

707 let captionStr = stringify caption

721 let captionStr = stringify caption

708 caption' <- if null caption

722 caption' <- if null caption

709 then return []

723 then return []

710− else withParaProp (pStyle "TableCaption")

724+ else withParaPropM (pStyleM "Table Caption")

711 $ blockToOpenXML opts (Para caption)

725 $ blockToOpenXML opts (Para caption)

712 let alignmentFor al = mknode "w:jc" [("w:val",alignmentToString al)] ()

726 let alignmentFor al = mknode "w:jc" [("w:val",alignmentToString al)] ()

713 let cellToOpenXML (al, cell) = withParaProp (alignmentFor al)

727 let cellToOpenXML (al, cell) = withParaProp (alignmentFor al)

767

781

768definitionListItemToOpenXML :: WriterOptions -> ([Inline],[[Block]]) -> WS [Element]

782definitionListItemToOpenXML :: WriterOptions -> ([Inline],[[Block]]) -> WS [Element]

769definitionListItemToOpenXML opts (term,defs) = do

783definitionListItemToOpenXML opts (term,defs) = do

770− term' <- withParaProp (pStyle "DefinitionTerm")

784+ term' <- withParaPropM (pStyleM "Definition Term")

771 $ blockToOpenXML opts (Para term)

785 $ blockToOpenXML opts (Para term)

772− defs' <- withParaProp (pStyle "Definition")

786+ defs' <- withParaPropM (pStyleM "Definition")

773 $ concat `fmap` mapM (blocksToOpenXML opts) defs

787 $ concat `fmap` mapM (blocksToOpenXML opts) defs

774 return $ term' ++ defs'

788 return $ term' ++ defs'

775

789

833 popTextProp

847 popTextProp

834 return res

848 return res

835

849

850+withTextPropM :: WS Element -> WS a -> WS a

851+withTextPropM = (. flip withTextProp) . (>>=)

852+

836getParaProps :: Bool -> WS [Element]

853getParaProps :: Bool -> WS [Element]

837getParaProps displayMathPara = do

854getParaProps displayMathPara = do

838 props <- gets stParaProperties

855 props <- gets stParaProperties

861 popParaProp

878 popParaProp

862 return res

879 return res

863

880

881+withParaPropM :: WS Element -> WS a -> WS a

882+withParaPropM = (. flip withParaProp) . (>>=)

883+

864formattedString :: String -> WS [Element]

884formattedString :: String -> WS [Element]

865formattedString str = do

885formattedString str = do

866 props <- getTextProps

886 props <- getTextProps

943 Right r -> return [r]

963 Right r -> return [r]

944 Left _ -> inlinesToOpenXML opts (texMathToInlines mathType str)

964 Left _ -> inlinesToOpenXML opts (texMathToInlines mathType str)

945inlineToOpenXML opts (Cite _ lst) = inlinesToOpenXML opts lst

965inlineToOpenXML opts (Cite _ lst) = inlinesToOpenXML opts lst

946−inlineToOpenXML opts (Code attrs str) =

966+inlineToOpenXML opts (Code attrs str) = do

947− withTextProp (rStyle "VerbatimChar")

967+ rSM <- gets stCharStyles

948− $ if writerHighlight opts

949− then case highlight formatOpenXML attrs str of

950− Nothing -> unhighlighted

951− Just h -> return h

952− else unhighlighted

953− where unhighlighted = intercalate [br] `fmap`

968+ let unhighlighted = intercalate [br] `fmap`

954− (mapM formattedString $ lines str)

969+ (mapM formattedString $ lines str)

955− formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok)

970+ formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok)

956− toHlTok (toktype,tok) = mknode "w:r" []

971+ toHlTok (toktype,tok) = mknode "w:r" []

957− [ mknode "w:rPr" []

972+ [ mknode "w:rPr" []

958− [ rStyle $ show toktype ]

973+ [ rStyle (show toktype) rSM ]

959− , mknode "w:t" [("xml:space","preserve")] tok ]

974+ , mknode "w:t" [("xml:space","preserve")] tok ]

975+ withTextProp (rStyle "Verbatim Char" rSM)

976+ $ if writerHighlight opts

977+ then case highlight formatOpenXML attrs str of

978+ Nothing -> unhighlighted

979+ Just h -> return h

980+ else unhighlighted

960inlineToOpenXML opts (Note bs) = do

981inlineToOpenXML opts (Note bs) = do

961 notes <- gets stFootnotes

982 notes <- gets stFootnotes

962 notenum <- getUniqueId

983 notenum <- getUniqueId

984+ rSM <- gets stCharStyles

963 let notemarker = mknode "w:r" []

985 let notemarker = mknode "w:r" []

964− [ mknode "w:rPr" [] (rStyle "FootnoteRef")

986+ [ mknode "w:rPr" [] (rStyle "Footnote Ref" rSM)

965 , mknode "w:footnoteRef" [] () ]

987 , mknode "w:footnoteRef" [] () ]

966 let notemarkerXml = RawInline (Format "openxml") $ ppElement notemarker

988 let notemarkerXml = RawInline (Format "openxml") $ ppElement notemarker

967 let insertNoteRef (Plain ils : xs) = Plain (notemarkerXml : ils) : xs

989 let insertNoteRef (Plain ils : xs) = Plain (notemarkerXml : ils) : xs

971 oldParaProperties <- gets stParaProperties

993 oldParaProperties <- gets stParaProperties

972 oldTextProperties <- gets stTextProperties

994 oldTextProperties <- gets stTextProperties

973 modify $ \st -> st{ stListLevel = -1, stParaProperties = [], stTextProperties = [] }

995 modify $ \st -> st{ stListLevel = -1, stParaProperties = [], stTextProperties = [] }

974− contents <- withParaProp (pStyle "FootnoteText") $ blocksToOpenXML opts

996+ contents <- withParaPropM (pStyleM "Footnote Text") $ blocksToOpenXML opts

975 $ insertNoteRef bs

997 $ insertNoteRef bs

976 modify $ \st -> st{ stListLevel = oldListLevel, stParaProperties = oldParaProperties,

998 modify $ \st -> st{ stListLevel = oldListLevel, stParaProperties = oldParaProperties,

977 stTextProperties = oldTextProperties }

999 stTextProperties = oldTextProperties }

978 let newnote = mknode "w:footnote" [("w:id", notenum)] $ contents

1000 let newnote = mknode "w:footnote" [("w:id", notenum)] $ contents

979 modify $ \s -> s{ stFootnotes = newnote : notes }

1001 modify $ \s -> s{ stFootnotes = newnote : notes }

980 return [ mknode "w:r" []

1002 return [ mknode "w:r" []

981− [ mknode "w:rPr" [] (rStyle "FootnoteRef")

1003+ [ mknode "w:rPr" [] (rStyle "Footnote Ref" rSM)

982 , mknode "w:footnoteReference" [("w:id", notenum)] () ] ]

1004 , mknode "w:footnoteReference" [("w:id", notenum)] () ] ]

983-- internal link:

1005-- internal link:

984inlineToOpenXML opts (Link txt ('#':xs,_)) = do

1006inlineToOpenXML opts (Link txt ('#':xs,_)) = do

985− contents <- withTextProp (rStyle "Link") $ inlinesToOpenXML opts txt

1007+ contents <- withTextPropM (rStyleM "Link") $ inlinesToOpenXML opts txt

986 return [ mknode "w:hyperlink" [("w:anchor",xs)] contents ]

1008 return [ mknode "w:hyperlink" [("w:anchor",xs)] contents ]

987-- external link:

1009-- external link:

988inlineToOpenXML opts (Link txt (src,_)) = do

1010inlineToOpenXML opts (Link txt (src,_)) = do

989− contents <- withTextProp (rStyle "Link") $ inlinesToOpenXML opts txt

1011+ contents <- withTextPropM (rStyleM "Link") $ inlinesToOpenXML opts txt

990 extlinks <- gets stExternalLinks

1012 extlinks <- gets stExternalLinks

991 id' <- case M.lookup src extlinks of

1013 id' <- case M.lookup src extlinks of

992 Just i -> return i

1014 Just i -> return i

1088 [ mknode "w:p" [] $

1110 [ mknode "w:p" [] $

1089 [ mknode "w:r" [] $

1111 [ mknode "w:r" [] $

1090 [ mknode "w:continuationSeparator" [] ()]]]]

1112 [ mknode "w:continuationSeparator" [] ()]]]]

1091−

1113+

1092parseXml :: Archive -> Archive -> String -> IO Element

1114parseXml :: Archive -> Archive -> String -> IO Element

1093parseXml refArchive distArchive relpath =

1115parseXml refArchive distArchive relpath =

1094 case ((findEntryByPath relpath refArchive `mplus`

1116 case ((findEntryByPath relpath refArchive `mplus`