From 8cf58d96e0801d8073e118f05279a9f473efcee0 Mon Sep 17 00:00:00 2001
From: Albert Krewinkel <albert@zeitkraut.de>
Date: Sun, 13 Dec 2020 14:09:53 +0100
Subject: [PATCH] Docx writer: use Content instead of Element.
---
src/Text/Pandoc/Writers/Docx.hs | 134 ++++++++++++++++++--------------
1 file 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