diff options
| -rw-r--r-- | src/Text/Pandoc/Writers/Docx.hs | 134 |
1 files changed, 75 insertions, 59 deletions
diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 4cb879e6a..97048e980 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -441,7 +441,7 @@ writeDocx opts doc = do Nothing -> mknode "w:sectPr" [] () -- let sectpr = fromMaybe (mknode "w:sectPr" [] ()) mbsectpr' - let contents' = contents ++ [sectpr] + let contents' = contents ++ [Elem sectpr] let docContents = mknode "w:document" stdAttributes $ mknode "w:body" [] contents' @@ -538,7 +538,8 @@ writeDocx opts doc = do -- docProps/custom.xml let customProperties :: [(String, String)] - customProperties = [(T.unpack k, T.unpack $ lookupMetaString k meta) | k <- M.keys (unMeta meta) + customProperties = [ (T.unpack k, T.unpack $ lookupMetaString k meta) + | k <- M.keys (unMeta meta) , k `notElem` (["title", "author", "keywords"] ++ extraCoreProps)] let mkCustomProp (k, v) pid = mknode "property" @@ -788,7 +789,7 @@ makeTOC opts = do mknode "w:docPartUnique" [] ()] -- w:docPartObj ), -- w:sdtPr - mknode "w:sdtContent" [] (title++[ + mknode "w:sdtContent" [] (title ++ [ Elem $ mknode "w:p" [] ( mknode "w:r" [] [ mknode "w:fldChar" [("w:fldCharType","begin"),("w:dirty","true")] (), @@ -802,7 +803,9 @@ makeTOC opts = do -- | Convert Pandoc document to two lists of -- OpenXML elements (the main document and footnotes). -writeOpenXML :: (PandocMonad m) => WriterOptions -> Pandoc -> WS m ([Element], [Element],[Element]) +writeOpenXML :: (PandocMonad m) + => WriterOptions -> Pandoc + -> WS m ([Content], [Element], [Element]) writeOpenXML opts (Pandoc meta blocks) = do let tit = docTitle meta let auths = docAuthors meta @@ -830,6 +833,7 @@ writeOpenXML opts (Pandoc meta blocks) = do return $ mknode "w:comment" [('w':':':T.unpack k,T.unpack v) | (k,v) <- kvs] [ mknode "w:p" [] $ + map Elem [ mknode "w:pPr" [] [ mknode "w:pStyle" [("w:val", "CommentText")] () ] , mknode "w:r" [] @@ -844,11 +848,11 @@ writeOpenXML opts (Pandoc meta blocks) = do toc <- if includeTOC then makeTOC opts else return [] - let meta' = title ++ subtitle ++ authors ++ date ++ abstract ++ toc + let meta' = title ++ subtitle ++ authors ++ date ++ abstract ++ map Elem toc return (meta' ++ doc', notes', comments') -- | Convert a list of Pandoc blocks to OpenXML. -blocksToOpenXML :: (PandocMonad m) => WriterOptions -> [Block] -> WS m [Element] +blocksToOpenXML :: (PandocMonad m) => WriterOptions -> [Block] -> WS m [Content] blocksToOpenXML opts = fmap concat . mapM (blockToOpenXML opts) . separateTables -- Word combines adjacent tables unless you put an empty paragraph between @@ -884,10 +888,10 @@ dynamicStyleKey :: T.Text dynamicStyleKey = "custom-style" -- | Convert a Pandoc block element to OpenXML. -blockToOpenXML :: (PandocMonad m) => WriterOptions -> Block -> WS m [Element] +blockToOpenXML :: (PandocMonad m) => WriterOptions -> Block -> WS m [Content] blockToOpenXML opts blk = withDirection $ blockToOpenXML' opts blk -blockToOpenXML' :: (PandocMonad m) => WriterOptions -> Block -> WS m [Element] +blockToOpenXML' :: (PandocMonad m) => WriterOptions -> Block -> WS m [Content] blockToOpenXML' _ Null = return [] blockToOpenXML' opts (Div (ident,_classes,kvs) bs) = do stylemod <- case lookup dynamicStyleKey kvs of @@ -921,18 +925,18 @@ blockToOpenXML' opts (Header lev (ident,_,kvs) lst) = do Just n -> do num <- withTextPropM (rStyleM "SectionNumber") (inlineToOpenXML opts (Str n)) - return $ num ++ [mknode "w:r" [] [mknode "w:tab" [] ()]] + return $ num ++ [Elem $ mknode "w:r" [] [mknode "w:tab" [] ()]] Nothing -> return [] else return [] contents <- (number ++) <$> inlinesToOpenXML opts lst if T.null ident - then return [mknode "w:p" [] (paraProps ++ contents)] + then return [Elem $ mknode "w:p" [] (map Elem paraProps ++ contents)] else do let bookmarkName = ident modify $ \s -> s{ stSectionIds = Set.insert bookmarkName $ stSectionIds s } bookmarkedContents <- wrapBookmark bookmarkName contents - return [mknode "w:p" [] (paraProps ++ bookmarkedContents)] + return [Elem $ mknode "w:p" [] (map Elem paraProps ++ bookmarkedContents)] blockToOpenXML' opts (Plain lst) = do isInTable <- gets stInTable isInList <- gets stInList @@ -952,7 +956,9 @@ blockToOpenXML' opts (Para [Image attr alt (src,T.stripPrefix "fig:" -> Just tit contents <- inlinesToOpenXML opts [Image attr alt (src,tit)] captionNode <- withParaPropM (pStyleM "Image Caption") $ blockToOpenXML opts (Para alt) - return $ mknode "w:p" [] (paraProps ++ contents) : captionNode + return $ + Elem (mknode "w:p" [] (map Elem paraProps ++ contents)) + : captionNode blockToOpenXML' opts (Para lst) | null lst && not (isEnabled Ext_empty_paragraphs opts) = return [] | otherwise = do @@ -969,10 +975,10 @@ blockToOpenXML' opts (Para lst) ps -> ps modify $ \s -> s { stFirstPara = False } contents <- inlinesToOpenXML opts lst - return [mknode "w:p" [] (paraProps' ++ contents)] + return [Elem $ mknode "w:p" [] (map Elem paraProps' ++ contents)] blockToOpenXML' opts (LineBlock lns) = blockToOpenXML opts $ linesToPara lns blockToOpenXML' _ b@(RawBlock format str) - | format == Format "openxml" = return [ x | Elem x <- parseXML str ] + | format == Format "openxml" = return (parseXML str) | otherwise = do report $ BlockNotRendered b return [] @@ -987,7 +993,7 @@ blockToOpenXML' opts (CodeBlock attrs@(ident, _, _) str) = do wrapBookmark ident p blockToOpenXML' _ HorizontalRule = do setFirstPara - return [ + return [ Elem $ mknode "w:p" [] $ mknode "w:r" [] $ mknode "w:pict" [] $ mknode "v:rect" [("style","width:0;height:1.5pt"), ("o:hralign","center"), @@ -1006,26 +1012,28 @@ blockToOpenXML' opts (Table _ blkCapt specs thead tbody tfoot) = do -- Not in the spec but in Word 2007, 2010. See #4953. let cellToOpenXML (al, cell) = do es <- withParaProp (alignmentFor al) $ blocksToOpenXML opts cell - return $ if any (\e -> qName (elName e) == "p") es + return $ if any (\e -> qName (elName e) == "p") (onlyElems es) then es - else es ++ [mknode "w:p" [] ()] + else es ++ [Elem $ mknode "w:p" [] ()] headers' <- mapM cellToOpenXML $ zip aligns headers rows' <- mapM (mapM cellToOpenXML . zip aligns) rows - let borderProps = mknode "w:tcPr" [] + let borderProps = Elem $ mknode "w:tcPr" [] [ mknode "w:tcBorders" [] $ mknode "w:bottom" [("w:val","single")] () , mknode "w:vAlign" [("w:val","bottom")] () ] compactStyle <- pStyleM "Compact" - let emptyCell' = [mknode "w:p" [] [mknode "w:pPr" [] [compactStyle]]] + let emptyCell' = [Elem $ mknode "w:p" [] [mknode "w:pPr" [] [compactStyle]]] let mkcell border contents = mknode "w:tc" [] $ [ borderProps | border ] ++ if null contents then emptyCell' else contents - let mkrow border cells = mknode "w:tr" [] $ - [mknode "w:trPr" [] [ - mknode "w:cnfStyle" [("w:firstRow","1")] ()] | border] - ++ map (mkcell border) cells + let mkrow border cells = + mknode "w:tr" [] $ + [ mknode "w:trPr" [] + [ mknode "w:cnfStyle" [("w:firstRow","1")] ()] + | border] + ++ map (mkcell border) cells let textwidth = 7920 -- 5.5 in in twips, 1/20 pt let fullrow = 5000 -- 100% specified in pct let rowwidth = fullrow * sum widths @@ -1035,7 +1043,8 @@ blockToOpenXML' opts (Table _ blkCapt specs thead tbody tfoot) = do modify $ \s -> s { stInTable = False } return $ caption' ++ - [mknode "w:tbl" [] + [Elem $ + mknode "w:tbl" [] ( mknode "w:tblPr" [] ( mknode "w:tblStyle" [("w:val","Table")] () : mknode "w:tblW" [("w:type", "pct"), ("w:w", show rowwidth)] () : @@ -1070,7 +1079,9 @@ blockToOpenXML' opts (DefinitionList items) = do setFirstPara return l -definitionListItemToOpenXML :: (PandocMonad m) => WriterOptions -> ([Inline],[[Block]]) -> WS m [Element] +definitionListItemToOpenXML :: (PandocMonad m) + => WriterOptions -> ([Inline],[[Block]]) + -> WS m [Content] definitionListItemToOpenXML opts (term,defs) = do term' <- withParaPropM (pStyleM "Definition Term") $ blockToOpenXML opts (Para term) @@ -1083,8 +1094,11 @@ addList marker = do lists <- gets stLists modify $ \st -> st{ stLists = lists ++ [marker] } -listItemToOpenXML :: (PandocMonad m) => WriterOptions -> Int -> [Block] -> WS m [Element] -listItemToOpenXML _ _ [] = return [] +listItemToOpenXML :: (PandocMonad m) + => WriterOptions + -> Int -> [Block] + -> WS m [Content] +listItemToOpenXML _ _ [] = return [] listItemToOpenXML opts numid (first:rest) = do oldInList <- gets stInList modify $ \st -> st{ stInList = True } @@ -1111,7 +1125,7 @@ alignmentToString alignment = case alignment of AlignDefault -> "left" -- | Convert a list of inline elements to OpenXML. -inlinesToOpenXML :: (PandocMonad m) => WriterOptions -> [Inline] -> WS m [Element] +inlinesToOpenXML :: PandocMonad m => WriterOptions -> [Inline] -> WS m [Content] inlinesToOpenXML opts lst = concat `fmap` mapM (inlineToOpenXML opts) lst withNumId :: (PandocMonad m) => Int -> WS m a -> WS m a @@ -1186,12 +1200,12 @@ setFirstPara :: PandocMonad m => WS m () setFirstPara = modify $ \s -> s { stFirstPara = True } -- | Convert an inline element to OpenXML. -inlineToOpenXML :: PandocMonad m => WriterOptions -> Inline -> WS m [Element] +inlineToOpenXML :: PandocMonad m => WriterOptions -> Inline -> WS m [Content] inlineToOpenXML opts il = withDirection $ inlineToOpenXML' opts il -inlineToOpenXML' :: PandocMonad m => WriterOptions -> Inline -> WS m [Element] +inlineToOpenXML' :: PandocMonad m => WriterOptions -> Inline -> WS m [Content] inlineToOpenXML' _ (Str str) = - formattedString str + map Elem <$> formattedString str inlineToOpenXML' opts Space = inlineToOpenXML opts (Str " ") inlineToOpenXML' opts SoftBreak = inlineToOpenXML opts (Str " ") inlineToOpenXML' opts (Span ("",["csl-block"],[]) ils) = @@ -1199,10 +1213,11 @@ inlineToOpenXML' opts (Span ("",["csl-block"],[]) ils) = inlineToOpenXML' opts (Span ("",["csl-left-margin"],[]) ils) = inlinesToOpenXML opts ils inlineToOpenXML' opts (Span ("",["csl-right-inline"],[]) ils) = - ([mknode "w:r" [] - (mknode "w:t" - [("xml:space","preserve")] - ("\t" :: String))] ++) + ([Elem $ + mknode "w:r" [] + (mknode "w:t" + [("xml:space","preserve")] + ("\t" :: String))] ++) <$> inlinesToOpenXML opts ils inlineToOpenXML' opts (Span ("",["csl-indent"],[]) ils) = inlinesToOpenXML opts ils @@ -1212,18 +1227,18 @@ inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do let ident' = fromMaybe ident (lookup "id" kvs) kvs' = filter (("id" /=) . fst) kvs modify $ \st -> st{ stComments = (("id",ident'):kvs', ils) : stComments st } - return [ mknode "w:commentRangeStart" [("w:id", T.unpack ident')] () ] + return [ Elem $ mknode "w:commentRangeStart" [("w:id", T.unpack ident')] () ] inlineToOpenXML' _ (Span (ident,["comment-end"],kvs) _) = -- prefer the "id" in kvs, since that is the one produced by the docx -- reader. let ident' = fromMaybe ident (lookup "id" kvs) - in - return [ mknode "w:commentRangeEnd" [("w:id", T.unpack ident')] () - , mknode "w:r" [] - [ mknode "w:rPr" [] - [ mknode "w:rStyle" [("w:val", "CommentReference")] () ] - , mknode "w:commentReference" [("w:id", T.unpack ident')] () ] - ] + in return . map Elem $ + [ mknode "w:commentRangeEnd" [("w:id", T.unpack ident')] () + , mknode "w:r" [] + [ mknode "w:rPr" [] + [ mknode "w:rStyle" [("w:val", "CommentReference")] () ] + , mknode "w:commentReference" [("w:id", T.unpack ident')] () ] + ] inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do stylemod <- case lookup dynamicStyleKey kvs of Just (fromString . T.unpack -> sty) -> do @@ -1255,8 +1270,9 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do modify $ \s -> s{stInsId = insId + 1} return $ \f -> do x <- f - return [ mknode "w:ins" - (("w:id", show insId) : changeAuthorDate) x] + return [Elem $ + mknode "w:ins" + (("w:id", show insId) : changeAuthorDate) x] else return id delmod <- if "deletion" `elem` classes then do @@ -1265,8 +1281,8 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do modify $ \s -> s{stDelId = delId + 1} return $ \f -> local (\env->env{envInDel=True}) $ do x <- f - return [mknode "w:del" - (("w:id", show delId) : changeAuthorDate) x] + return [Elem $ mknode "w:del" + (("w:id", show delId) : changeAuthorDate) x] else return id contents <- insmod $ delmod $ dirmod $ stylemod $ pmod $ inlinesToOpenXML opts ils @@ -1294,9 +1310,9 @@ inlineToOpenXML' opts (SmallCaps lst) = inlineToOpenXML' opts (Strikeout lst) = withTextProp (mknode "w:strike" [] ()) $ inlinesToOpenXML opts lst -inlineToOpenXML' _ LineBreak = return [br] +inlineToOpenXML' _ LineBreak = return [Elem br] inlineToOpenXML' _ il@(RawInline f str) - | f == Format "openxml" = return [ x | Elem x <- parseXML str ] + | f == Format "openxml" = return (parseXML str) | otherwise = do report $ InlineNotRendered il return [] @@ -1309,13 +1325,13 @@ inlineToOpenXML' opts (Math mathType str) = do when (mathType == DisplayMath) setFirstPara res <- (lift . lift) (convertMath writeOMML mathType str) case res of - Right r -> return [r] + Right r -> return [Elem r] Left il -> inlineToOpenXML' opts il inlineToOpenXML' opts (Cite _ lst) = inlinesToOpenXML opts lst inlineToOpenXML' opts (Code attrs str) = do let alltoktypes = [KeywordTok ..] tokTypesMap <- mapM (\tt -> (,) tt <$> rStyleM (fromString $ show tt)) alltoktypes - let unhighlighted = intercalate [br] `fmap` + let unhighlighted = (map Elem . intercalate [br]) `fmap` mapM formattedString (T.lines str) formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok) toHlTok (toktype,tok) = @@ -1328,7 +1344,7 @@ inlineToOpenXML' opts (Code attrs str) = do then unhighlighted else case highlight (writerSyntaxMap opts) formatOpenXML attrs str of - Right h -> return h + Right h -> return (map Elem h) Left msg -> do unless (T.null msg) $ report $ CouldNotHighlight msg unhighlighted @@ -1351,14 +1367,14 @@ inlineToOpenXML' opts (Note bs) = do $ insertNoteRef bs) let newnote = mknode "w:footnote" [("w:id", notenum)] contents modify $ \s -> s{ stFootnotes = newnote : notes } - return [ mknode "w:r" [] + return [ Elem $ mknode "w:r" [] [ mknode "w:rPr" [] footnoteStyle , mknode "w:footnoteReference" [("w:id", notenum)] () ] ] -- internal link: inlineToOpenXML' opts (Link _ txt (T.uncons -> Just ('#', xs),_)) = do contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt return - [ mknode "w:hyperlink" [("w:anchor", T.unpack $ toBookmarkName xs)] contents ] + [ Elem $ mknode "w:hyperlink" [("w:anchor", T.unpack $ toBookmarkName xs)] contents ] -- external link: inlineToOpenXML' opts (Link _ txt (src,_)) = do contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt @@ -1370,7 +1386,7 @@ inlineToOpenXML' opts (Link _ txt (src,_)) = do modify $ \st -> st{ stExternalLinks = M.insert (T.unpack src) i extlinks } return i - return [ mknode "w:hyperlink" [("r:id",id')] contents ] + return [ Elem $ mknode "w:hyperlink" [("r:id",id')] contents ] inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do pageWidth <- asks envPrintWidth imgs <- gets stImages @@ -1434,7 +1450,7 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do imgElt wrapBookmark imgident =<< case stImage of - Just imgData -> return [generateImgElt imgData] + Just imgData -> return [Elem $ generateImgElt imgData] Nothing -> ( do --try (img, mt) <- P.fetchItem src ident <- ("rId"++) `fmap` getUniqueId @@ -1462,7 +1478,7 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do else do -- insert mime type to use in constructing [Content_Types].xml modify $ \st -> st { stImages = M.insert (T.unpack src) imgData $ stImages st } - return [generateImgElt imgData] + return [Elem $ generateImgElt imgData] ) `catchError` ( \e -> do report $ CouldNotFetchResource src $ T.pack (show e) @@ -1512,7 +1528,7 @@ withDirection x = do , envTextProperties = EnvProps textStyle textProps' } -wrapBookmark :: (PandocMonad m) => T.Text -> [Element] -> WS m [Element] +wrapBookmark :: (PandocMonad m) => T.Text -> [Content] -> WS m [Content] wrapBookmark "" contents = return contents wrapBookmark ident contents = do id' <- getUniqueId @@ -1520,7 +1536,7 @@ wrapBookmark ident contents = do [("w:id", id') ,("w:name", T.unpack $ toBookmarkName ident)] () bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] () - return $ bookmarkStart : contents ++ [bookmarkEnd] + return $ Elem bookmarkStart : contents ++ [Elem bookmarkEnd] -- Word imposes a 40 character limit on bookmark names and requires -- that they begin with a letter. So we just use a hash of the |