pandoc-3.7: src/Text/Pandoc/Writers/Docx.hs
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Writers.Docx
Copyright : Copyright (C) 2012-2024 John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : John MacFarlane <jgm@berkeley.edu>
Stability : alpha
Portability : portable
Conversion of 'Pandoc' documents to docx.
-}
module Text.Pandoc.Writers.Docx ( writeDocx ) where
import Codec.Archive.Zip
( Archive(zEntries),
addEntryToArchive,
emptyArchive,
findEntryByPath,
fromArchive,
toArchive,
toEntry,
Entry(eRelativePath) )
import Control.Monad (MonadPlus(mplus), foldM)
import Control.Monad.Except (throwError)
import Control.Monad.Reader ( ReaderT(runReaderT) )
import Control.Monad.State.Strict ( StateT(runStateT) )
import qualified Data.ByteString.Lazy as BL
import Data.Containers.ListUtils (nubOrd)
import Data.Char (isSpace)
import Data.List (isPrefixOf, isSuffixOf)
import Data.String (fromString)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text (Text)
import Data.Time.Clock.POSIX
import Skylighting
import Text.Pandoc.Class (PandocMonad, toLang)
import qualified Text.Pandoc.Class.PandocMonad as P
import Text.Pandoc.Data (readDataFile, readDefaultDataFile)
import Data.Time
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.Definition
import Text.Pandoc.Error
import Text.Pandoc.MIME (getMimeTypeDef)
import Text.Pandoc.Options
import Text.Pandoc.Readers.Docx.Parse (extractTarget)
import Text.Pandoc.Writers.Docx.StyleMap
import Text.Pandoc.Writers.Docx.Types
import Text.Pandoc.Writers.Docx.OpenXML (writeOpenXML, maxListLevel)
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import Text.Pandoc.Writers.Shared
import Text.Pandoc.Writers.OOXML
import Text.Pandoc.XML.Light as XML
import Data.Generics (mkT, everywhere)
import Text.Collate.Lang (renderLang, Lang(..))
writeDocx :: (PandocMonad m)
=> WriterOptions -- ^ Writer options
-> Pandoc -- ^ Document to convert
-> m BL.ByteString
writeDocx opts doc = do
let Pandoc meta blocks = walk fixDisplayMath doc
setupTranslations meta
let blocks' = makeSectionsWithOffsets (writerNumberOffset opts)
True Nothing blocks
let doc' = Pandoc meta blocks'
username <- P.lookupEnv "USERNAME"
utctime <- P.getTimestamp
oldUserDataDir <- P.getUserDataDir
P.setUserDataDir Nothing
res <- readDefaultDataFile "reference.docx"
P.setUserDataDir oldUserDataDir
let distArchive = toArchive $ BL.fromStrict res
refArchive <- case writerReferenceDoc opts of
Just f -> toArchive . BL.fromStrict . fst
<$> P.fetchItem (T.pack f)
Nothing -> toArchive . BL.fromStrict <$>
readDataFile "reference.docx"
parsedDoc <- parseXml refArchive distArchive "word/document.xml"
let wname f qn = qPrefix qn == Just "w" && f (qName qn)
let mbsectpr = filterElementName (wname (=="sectPr")) parsedDoc
-- Gets the template size
let mbpgsz = mbsectpr >>= filterElementName (wname (=="pgSz"))
let mbAttrSzWidth = mbpgsz >>= lookupAttrBy ((=="w") . qName) . elAttribs
let mbpgmar = mbsectpr >>= filterElementName (wname (=="pgMar"))
let mbAttrMarLeft = mbpgmar >>= lookupAttrBy ((=="left") . qName) . elAttribs
let mbAttrMarRight = mbpgmar >>= lookupAttrBy ((=="right") . qName) . elAttribs
-- Get the available area (converting the size and the margins to int and
-- doing the difference
let pgContentWidth = do
w <- mbAttrSzWidth >>= safeRead
r <- mbAttrMarRight >>= safeRead
l <- mbAttrMarLeft >>= safeRead
pure $ w - r - l
-- styles
mblang <- toLang $ getLang opts meta
-- TODO FIXME avoid this generic traversal!
-- lang is in w:docDefaults / w:rPr / w:lang
let addLang :: Element -> Element
addLang = case mblang of
Nothing -> id
Just l -> everywhere (mkT (go l))
where
go :: Lang -> Element -> Element
go lang e'
| qName (elName e') == "lang"
= if isEastAsianLang lang
then e'{ elAttribs =
map (setattr "eastAsia" (renderLang lang)) $
elAttribs e' }
else
if isBidiLang lang
then e'{ elAttribs =
map (setattr "bidi" (renderLang lang)) $
elAttribs e' }
else e'{ elAttribs =
map (setattr "val" (renderLang lang)) $
elAttribs e' }
| otherwise = e'
setattr attrname l (XML.Attr qn@(QName s _ _) _)
| s == attrname = XML.Attr qn l
setattr _ _ x = x
isEastAsianLang Lang{ langLanguage = lang } =
lang == "zh" || lang == "ja" || lang == "ko"
isBidiLang Lang{ langLanguage = lang } =
lang == "he" || lang == "ar"
let stylepath = "word/styles.xml"
styledoc <- addLang <$> parseXml refArchive distArchive stylepath
-- parse styledoc for heading styles
let styleMaps = getStyleMaps refArchive
let tocTitle = case lookupMetaInlines "toc-title" meta of
[] -> stTocTitle defaultWriterState
ls -> ls
let isRTLmeta = case lookupMeta "dir" meta of
Just (MetaString "rtl") -> True
Just (MetaInlines [Str "rtl"]) -> True
_ -> False
let env = defaultWriterEnv {
envRTL = isRTLmeta
, envChangesAuthor = fromMaybe "unknown" username
, envChangesDate = T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime
, envPrintWidth = maybe 420 (`quot` 20) pgContentWidth
}
let isImageNode e = findAttr (QName "Type" Nothing Nothing) e == Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"
let isHeaderNode e = findAttr (QName "Type" Nothing Nothing) e == Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships/header"
let isFooterNode e = findAttr (QName "Type" Nothing Nothing) e == Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships/footer"
parsedRels <- filterElements
(\e -> isImageNode e || isHeaderNode e || isFooterNode e)
<$> parseXml refArchive distArchive "word/_rels/document.xml.rels"
let getRelId e =
case findAttr (QName "Id" Nothing Nothing) e of
Just ident -> T.stripPrefix "rId" ident >>= safeRead
Nothing -> Nothing
let relIds = mapMaybe getRelId parsedRels
let maxRelId = if null relIds then 0 else maximum relIds
let headers = filter isHeaderNode parsedRels
let footers = filter isFooterNode parsedRels
-- word/_rels/document.xml.rels
let addBaseRel (url', target') (maxId, rels) =
case [e | e <- rels
, findAttr (QName "Target" Nothing Nothing) e ==
Just target'] of
[] -> (maxId + 1, mknode "Relationship"
[("Type",url')
,("Id","rId" <> tshow (maxId + 1))
,("Target",target')] () : rels)
_ -> (maxId, rels)
let (newMaxRelId, baserels) = foldr addBaseRel (maxRelId, parsedRels)
[("http://schemas.openxmlformats.org/officeDocument/2006/relationships/numbering",
"numbering.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles",
"styles.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/settings",
"settings.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/webSettings",
"webSettings.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/fontTable",
"fontTable.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme",
"theme/theme1.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/footnotes",
"footnotes.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments",
"comments.xml")
]
let initialSt = defaultWriterState {
stStyleMaps = styleMaps
, stTocTitle = tocTitle
, stCurId = newMaxRelId + 1
}
-- adjust contents to add sectPr from reference.docx
let sectpr = case mbsectpr of
Just sectpr' -> add_attrs (elAttribs sectpr') $ mknode "w:sectPr" []
(elChildren sectpr')
Nothing -> mknode "w:sectPr" []
[ mknode "w:footnotePr" []
[ mknode "w:numRestart" [("w:val","eachSect")] () ]
]
((contents, footnotes, comments), st) <- runStateT
(runReaderT
(writeOpenXML opts{ writerWrapText = WrapNone }
doc')
env{ envSectPr = Just sectpr })
initialSt
let epochtime = floor $ utcTimeToPOSIXSeconds utctime
let imgs = M.elems $ stImages st
-- create entries for images in word/media/...
let toImageEntry (_,path,_,img) = toEntry ("word/" ++ path) epochtime $ toLazy img
let imageEntries = map toImageEntry imgs
let stdAttributes =
[("xmlns:w","http://schemas.openxmlformats.org/wordprocessingml/2006/main")
,("xmlns:m","http://schemas.openxmlformats.org/officeDocument/2006/math")
,("xmlns:r","http://schemas.openxmlformats.org/officeDocument/2006/relationships")
,("xmlns:o","urn:schemas-microsoft-com:office:office")
,("xmlns:v","urn:schemas-microsoft-com:vml")
,("xmlns:w10","urn:schemas-microsoft-com:office:word")
,("xmlns:a","http://schemas.openxmlformats.org/drawingml/2006/main")
,("xmlns:pic","http://schemas.openxmlformats.org/drawingml/2006/picture")
,("xmlns:wp","http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing")]
-- we create [Content_Types].xml and word/_rels/document.xml.rels
-- from scratch rather than reading from reference.docx,
-- because Word sometimes changes these files when a reference.docx is modified,
-- e.g. deleting the reference to footnotes.xml or removing default entries
-- for image content types.
-- [Content_Types].xml
let mkOverrideNode (part', contentType') = mknode "Override"
[("PartName", T.pack part')
,("ContentType", contentType')] ()
let mkImageOverride (_, imgpath, mbMimeType, _) =
mkOverrideNode ("/word/" <> imgpath,
fromMaybe "application/octet-stream" mbMimeType)
let mkMediaOverride imgpath =
mkOverrideNode ("/" <> imgpath, getMimeTypeDef imgpath)
let overrides = map mkOverrideNode (
[("/word/webSettings.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.webSettings+xml")
,("/word/numbering.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.numbering+xml")
,("/word/settings.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.settings+xml")
,("/word/theme/theme1.xml",
"application/vnd.openxmlformats-officedocument.theme+xml")
,("/word/fontTable.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.fontTable+xml")
,("/docProps/app.xml",
"application/vnd.openxmlformats-officedocument.extended-properties+xml")
,("/docProps/core.xml",
"application/vnd.openxmlformats-package.core-properties+xml")
,("/docProps/custom.xml",
"application/vnd.openxmlformats-officedocument.custom-properties+xml")
,("/word/styles.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.styles+xml")
,("/word/document.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml")
,("/word/comments.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.comments+xml")
,("/word/footnotes.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml")
] ++
map (\x -> (maybe "" (T.unpack . ("/word/" <>)) (extractTarget x),
"application/vnd.openxmlformats-officedocument.wordprocessingml.header+xml")) headers ++
map (\x -> (maybe "" (T.unpack . ("/word/" <>)) (extractTarget x),
"application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml")) footers) ++
map mkImageOverride imgs ++
[ mkMediaOverride (eRelativePath e)
| e <- zEntries refArchive
, "word/media/" `isPrefixOf` eRelativePath e ]
let mkDefaultNode (ext, mt) =
mknode "Default" [("Extension",ext),("ContentType",mt)] ()
let defaultnodes = map mkDefaultNode
[("xml", "application/xml"),
("rels", "application/vnd.openxmlformats-package.relationships+xml"),
("odttf",
"application/vnd.openxmlformats-officedocument.obfuscatedFont")]
let contentTypesDoc = mknode "Types" [("xmlns","http://schemas.openxmlformats.org/package/2006/content-types")] $ defaultnodes ++ overrides
let contentTypesEntry = toEntry "[Content_Types].xml" epochtime
$ renderXml contentTypesDoc
let toImgRel (ident,path,_,_) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",T.pack ident),("Target",T.pack path)] ()
let imgrels = map toImgRel imgs
let toLinkRel (src,ident) = mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink"),("Id",ident),("Target",src),("TargetMode","External") ] ()
let linkrels = map toLinkRel $ M.toList $ stExternalLinks st
let reldoc = mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")] $ baserels ++ imgrels ++ linkrels
let relEntry = toEntry "word/_rels/document.xml.rels" epochtime
$ renderXml reldoc
let contents' = BL.fromStrict $ UTF8.fromText contents
-- word/document.xml
let contentEntry = toEntry "word/document.xml" epochtime contents'
-- footnotes
let notes = mknode "w:footnotes" stdAttributes footnotes
let footnotesEntry = toEntry "word/footnotes.xml" epochtime $ renderXml notes
-- footnote rels
let footnoteRelEntry = toEntry "word/_rels/footnotes.xml.rels" epochtime
$ renderXml $ mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
linkrels
-- comments
let commentsEntry = toEntry "word/comments.xml" epochtime
$ renderXml $ mknode "w:comments" stdAttributes comments
-- styles
-- We only want to inject paragraph and text properties that
-- are not already in the style map. Note that keys in the stylemap
-- are normalized as lowercase.
let newDynamicParaProps = filter
(\sty -> not $ hasStyleName sty $ smParaStyle styleMaps)
(Set.toList $ stDynamicParaProps st)
newDynamicTextProps = filter
(\sty -> not $ hasStyleName sty $ smCharStyle styleMaps)
(Set.toList $ stDynamicTextProps st)
let newstyles = map newParaPropToOpenXml newDynamicParaProps ++
map newTextPropToOpenXml newDynamicTextProps ++
maybe [] (styleToOpenXml styleMaps) (writerHighlightStyle opts)
let styledoc' = styledoc{ elContent = elContent styledoc ++
map Elem newstyles }
let styleEntry = toEntry stylepath epochtime $ renderXml styledoc'
-- construct word/numbering.xml
let numpath = "word/numbering.xml"
numbering <- parseXml refArchive distArchive numpath
let newNumElts = mkNumbering (stLists st)
let pandocAdded e =
case findAttrBy ((== "abstractNumId") . qName) e >>= safeRead of
Just numid -> numid >= (990 :: Int)
Nothing ->
case findAttrBy ((== "numId") . qName) e >>= safeRead of
Just numid -> numid >= (1000 :: Int)
Nothing -> False
let oldElts = filter (not . pandocAdded) $ onlyElems (elContent numbering)
let allElts = oldElts ++ newNumElts
let numEntry = toEntry numpath epochtime $ renderXml numbering{ elContent =
-- we want all the abstractNums first, then the nums,
-- otherwise things break:
[Elem e | e <- allElts
, qName (elName e) == "abstractNum" ] ++
[Elem e | e <- allElts
, qName (elName e) == "num" ] }
let keywords = case lookupMeta "keywords" meta of
Just (MetaList xs) -> map stringify xs
_ -> []
-- docProps/core.xml
let docPropsPath = "docProps/core.xml"
let extraCoreProps = ["subject","lang","category","description"]
let extraCorePropsMap = M.fromList $ zip extraCoreProps
["dc:subject","dc:language","cp:category","dc:description"]
let lookupMetaString' :: Text -> Meta -> Text
lookupMetaString' key' meta' =
case key' of
"description" -> T.intercalate "_x000d_\n" (map stringify $ lookupMetaBlocks "description" meta')
key'' -> lookupMetaString key'' meta'
let docProps = mknode "cp:coreProperties"
[("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties")
,("xmlns:dc","http://purl.org/dc/elements/1.1/")
,("xmlns:dcterms","http://purl.org/dc/terms/")
,("xmlns:dcmitype","http://purl.org/dc/dcmitype/")
,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")]
$ mktnode "dc:title" [] (stringify $ docTitle meta)
: mktnode "dc:creator" [] (T.intercalate "; " (map stringify $ docAuthors meta))
: [ mktnode (M.findWithDefault "" k extraCorePropsMap) [] (lookupMetaString' k meta)
| k <- M.keys (unMeta meta), k `elem` extraCoreProps]
++ mknode "cp:keywords" [] (T.intercalate ", " keywords)
: (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x
, mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x
]) (T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime)
let docPropsEntry = toEntry docPropsPath epochtime $ renderXml docProps
-- docProps/custom.xml
let customProperties :: [(Text, Text)]
customProperties = [ (k, lookupMetaString k meta)
| k <- M.keys (unMeta meta)
, k `notElem` (["title", "author", "keywords"]
++ extraCoreProps)]
let mkCustomProp (k, v) pid = mknode "property"
[("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
,("pid", tshow pid)
,("name", k)] $ mknode "vt:lpwstr" [] v
let customPropsPath = "docProps/custom.xml"
let customProps = mknode "Properties"
[("xmlns","http://schemas.openxmlformats.org/officeDocument/2006/custom-properties")
,("xmlns:vt","http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")
] $ zipWith mkCustomProp customProperties [(2 :: Int)..]
let customPropsEntry = toEntry customPropsPath epochtime $ renderXml customProps
let relsPath = "_rels/.rels"
let rels = mknode "Relationships" [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
$ map (\attrs -> mknode "Relationship" attrs ())
[ [("Id","rId1")
,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument")
,("Target","word/document.xml")]
, [("Id","rId4")
,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties")
,("Target","docProps/app.xml")]
, [("Id","rId3")
,("Type","http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties")
,("Target","docProps/core.xml")]
, [("Id","rId5")
,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties")
,("Target","docProps/custom.xml")]
]
let relsEntry = toEntry relsPath epochtime $ renderXml rels
-- we use dist archive for settings.xml, because Word sometimes
-- adds references to footnotes or endnotes we don't have...
-- we do, however, copy some settings over from reference
let settingsPath = "word/settings.xml"
settingsEntry <- copyChildren refArchive distArchive settingsPath epochtime
-- note: these must go in the following order:
[ "writeProtection"
, "view"
, "zoom"
, "removePersonalInformation"
, "removeDateAndTime"
, "doNotDisplayPageBoundaries"
, "displayBackgroundShape"
, "printPostScriptOverText"
, "printFractionalCharacterWidth"
, "printFormsData"
, "embedTrueTypeFonts"
, "embedSystemFonts"
, "saveSubsetFonts"
, "saveFormsData"
, "mirrorMargins"
, "alignBordersAndEdges"
, "bordersDoNotSurroundHeader"
, "bordersDoNotSurroundFooter"
, "gutterAtTop"
, "hideSpellingErrors"
, "hideGrammaticalErrors"
, "activeWritingStyle"
, "proofState"
, "formsDesign"
, "attachedTemplate"
, "linkStyles"
, "stylePaneFormatFilter"
, "stylePaneSortMethod"
, "documentType"
, "mailMerge"
, "revisionView"
, "trackRevisions"
, "doNotTrackMoves"
, "doNotTrackFormatting"
, "documentProtection"
, "autoFormatOverride"
, "styleLockTheme"
, "styleLockQFSet"
, "defaultTabStop"
, "autoHyphenation"
, "consecutiveHyphenLimit"
, "hyphenationZone"
, "doNotHyphenateCaps"
, "showEnvelope"
, "summaryLength"
, "clickAndTypeStyle"
, "defaultTableStyle"
, "evenAndOddHeaders"
, "bookFoldRevPrinting"
, "bookFoldPrinting"
, "bookFoldPrintingSheets"
, "drawingGridHorizontalSpacing"
, "drawingGridVerticalSpacing"
, "displayHorizontalDrawingGridEvery"
, "displayVerticalDrawingGridEvery"
, "doNotUseMarginsForDrawingGridOrigin"
, "drawingGridHorizontalOrigin"
, "drawingGridVerticalOrigin"
, "doNotShadeFormData"
, "noPunctuationKerning"
, "characterSpacingControl"
, "printTwoOnOne"
, "strictFirstAndLastChars"
, "noLineBreaksAfter"
, "noLineBreaksBefore"
, "savePreviewPicture"
, "doNotValidateAgainstSchema"
, "saveInvalidXml"
, "ignoreMixedContent"
, "alwaysShowPlaceholderText"
, "doNotDemarcateInvalidXml"
, "saveXmlDataOnly"
, "useXSLTWhenSaving"
, "saveThroughXslt"
, "showXMLTags"
, "alwaysMergeEmptyNamespace"
, "updateFields"
, "hdrShapeDefaults"
-- , "footnotePr" -- this can cause problems, see #9522
-- , "endnotePr"
, "compat"
, "docVars"
, "rsids"
, "attachedSchema"
, "themeFontLang"
, "clrSchemeMapping"
, "doNotIncludeSubdocsInStats"
, "doNotAutoCompressPictures"
, "forceUpgrade"
, "captions"
, "readModeInkLockDown"
, "smartTagType"
, "shapeDefaults"
, "doNotEmbedSmartTags"
, "decimalSymbol"
, "listSeparator" ]
let entryFromArchive arch path =
maybe (throwError $ PandocSomeError
$ T.pack $ path ++ " missing in reference docx")
return
(findEntryByPath path arch `mplus` findEntryByPath path distArchive)
docPropsAppEntry <- entryFromArchive refArchive "docProps/app.xml"
themeEntry <- entryFromArchive refArchive "word/theme/theme1.xml"
fontTableEntry <- entryFromArchive refArchive "word/fontTable.xml"
let fontTableRelsEntries = maybeToList $
findEntryByPath "word/_rels/fontTable.xml.rels" refArchive
let fontEntries = [entry | entry <- zEntries refArchive
, "word/fonts/" `isPrefixOf` (eRelativePath entry)]
-- or parse fontTable.xml.rels?
webSettingsEntry <- entryFromArchive refArchive "word/webSettings.xml"
headerFooterEntries <- mapM (entryFromArchive refArchive . ("word/" ++)) $
mapMaybe (fmap T.unpack . extractTarget)
(headers ++ footers)
let miscRelEntries = [ e | e <- zEntries refArchive
, "word/_rels/" `isPrefixOf` eRelativePath e
, ".xml.rels" `isSuffixOf` eRelativePath e
, eRelativePath e /= "word/_rels/document.xml.rels"
, eRelativePath e /= "word/_rels/footnotes.xml.rels" ]
let otherMediaEntries = [ e | e <- zEntries refArchive
, "word/media/" `isPrefixOf` eRelativePath e ]
-- Create archive
let archive = foldr addEntryToArchive emptyArchive $
contentTypesEntry : relsEntry : contentEntry : relEntry :
footnoteRelEntry : numEntry : styleEntry : footnotesEntry :
commentsEntry :
docPropsEntry : docPropsAppEntry : customPropsEntry :
themeEntry :
settingsEntry : webSettingsEntry :
fontTableEntry :
fontTableRelsEntries ++ fontEntries ++
imageEntries ++ headerFooterEntries ++
miscRelEntries ++ otherMediaEntries
return $ fromArchive archive
newParaPropToOpenXml :: ParaStyleName -> Element
newParaPropToOpenXml (fromStyleName -> s) =
let styleId = T.filter (not . isSpace) s
in mknode "w:style" [ ("w:type", "paragraph")
, ("w:customStyle", "1")
, ("w:styleId", styleId)]
[ mknode "w:name" [("w:val", s)] ()
, mknode "w:basedOn" [("w:val","BodyText")] ()
, mknode "w:qFormat" [] ()
]
newTextPropToOpenXml :: CharStyleName -> Element
newTextPropToOpenXml (fromStyleName -> s) =
let styleId = T.filter (not . isSpace) s
in mknode "w:style" [ ("w:type", "character")
, ("w:customStyle", "1")
, ("w:styleId", styleId)]
[ mknode "w:name" [("w:val", s)] ()
, mknode "w:basedOn" [("w:val","BodyTextChar")] ()
]
styleToOpenXml :: StyleMaps -> Style -> [Element]
styleToOpenXml sm style =
maybeToList parStyle ++ mapMaybe toStyle alltoktypes
where alltoktypes = enumFromTo KeywordTok NormalTok
toStyle toktype | hasStyleName (fromString $ show toktype) (smCharStyle sm) = Nothing
| otherwise = Just $
mknode "w:style" [("w:type","character"),
("w:customStyle","1"),("w:styleId", tshow toktype)]
[ mknode "w:name" [("w:val", tshow toktype)] ()
, mknode "w:basedOn" [("w:val","VerbatimChar")] ()
, mknode "w:rPr" [] $
[ mknode "w:b" [] () | tokFeature tokenBold toktype ] ++
[ mknode "w:i" [] () | tokFeature tokenItalic toktype ] ++
[ mknode "w:color" [("w:val", tokCol toktype)] ()
| tokCol toktype /= "auto" ] ++
[ mknode "w:u" [] () | tokFeature tokenUnderline toktype ] ++
[ mknode "w:shd" [("w:val","clear")
,("w:fill",tokBg toktype)] ()
| tokBg toktype /= "auto" ]
]
tokStyles = tokenStyles style
tokFeature f toktype = maybe False f $ M.lookup toktype tokStyles
tokCol toktype = maybe "auto" (T.pack . drop 1 . fromColor)
$ (tokenColor =<< M.lookup toktype tokStyles)
`mplus` defaultColor style
tokBg toktype = maybe "auto" (T.pack . drop 1 . fromColor)
$ (tokenBackground =<< M.lookup toktype tokStyles)
`mplus` backgroundColor style
parStyle | hasStyleName "Source Code" (smParaStyle sm) = Nothing
| otherwise = Just $
mknode "w:style" [("w:type","paragraph"),
("w:customStyle","1"),("w:styleId","SourceCode")]
[ mknode "w:name" [("w:val","Source Code")] ()
, mknode "w:basedOn" [("w:val","Normal")] ()
, mknode "w:link" [("w:val","VerbatimChar")] ()
, mknode "w:pPr" []
$ mknode "w:wordWrap" [("w:val","off")] ()
:
maybe [] (\col -> [mknode "w:shd" [("w:val","clear"),("w:fill", T.pack $ drop 1 $ fromColor col)] ()]) (backgroundColor style)
]
copyChildren :: (PandocMonad m)
=> Archive -> Archive -> String -> Integer -> [Text] -> m Entry
copyChildren refArchive distArchive path timestamp elNames = do
ref <- parseXml refArchive distArchive path
dist <- parseXml distArchive distArchive path
els <- foldM (addEl ref dist) [] (reverse elNames)
return $ toEntry path timestamp
$ renderXml dist{ elContent = map cleanElem els }
where
addEl ref dist els name =
case filterChildName (hasName name) ref `mplus`
filterChildName (hasName name) dist of
Just el -> pure (el : els)
Nothing -> pure els
hasName name = (== name) . qName
cleanElem el@Element{elName=name} = Elem el{elName=name{qURI=Nothing}}
-- this is the lowest number used for a list numId
baseListId :: Int
baseListId = 1000
mkNumbering :: [ListMarker] -> [Element]
mkNumbering lists =
elts ++ zipWith mkNum lists [baseListId..(baseListId + length lists - 1)]
where elts = map mkAbstractNum (nubOrd lists)
mkNum :: ListMarker -> Int -> Element
mkNum marker numid =
mknode "w:num" [("w:numId",tshow numid)]
$ mknode "w:abstractNumId" [("w:val",listMarkerToId marker)] ()
: case marker of
NoMarker -> []
BulletMarker -> []
CheckboxMarker _ -> []
NumberMarker _ _ start ->
map (\lvl -> mknode "w:lvlOverride" [("w:ilvl",tshow (lvl :: Int))]
$ mknode "w:startOverride" [("w:val",tshow start)] ())
[0..maxListLevel]
mkAbstractNum :: ListMarker -> Element
mkAbstractNum marker =
mknode "w:abstractNum" [("w:abstractNumId",listMarkerToId marker)]
$ mknode "w:nsid" [("w:val", T.justifyRight 8 '0' ("A" <> listMarkerToId marker))] ()
: mknode "w:multiLevelType" [("w:val","multilevel")] ()
: map (mkLvl marker)
[0..maxListLevel]
mkLvl :: ListMarker -> Int -> Element
mkLvl marker lvl =
mknode "w:lvl" [("w:ilvl",tshow lvl)] $
(case marker of
NumberMarker{} -> [mknode "w:start" [("w:val",start)] ()]
_ -> []) ++
[ mknode "w:numFmt" [("w:val",fmt)] ()
, mknode "w:lvlText" [("w:val", lvltxt)] ()
, mknode "w:lvlJc" [("w:val","left")] ()
, mknode "w:pPr" [] $
mknode "w:ind" [ ("w:left",tshow $ lvl * step + step)
, ("w:hanging",tshow hang)
] ()
] ++
maybe [] (\font ->
[ mknode "w:rPr" []
[ mknode "w:rFonts" [ ("w:ascii", font)
, ("w:hAnsi", font)
, ("w:cs", font)
, ("w:hint", "default") ] () ]]) mbfont
where (fmt, lvltxt, mbfont, start) =
case marker of
NoMarker -> ("bullet"," ", Nothing, "1")
BulletMarker -> bulletFor lvl
CheckboxMarker False -> ("bullet","\9744", Nothing, "1")
CheckboxMarker True -> ("bullet","\9746", Nothing, "1")
NumberMarker st de n -> (styleFor st lvl
,patternFor de ("%" <> tshow (lvl + 1))
,Nothing
,tshow n)
step = 720
hang :: Int
hang = 360
bulletFor 0 = ("bullet", "\xf0b7", Just "Symbol", "1") -- filled circle
bulletFor 1 = ("bullet", "o", Just "Courier New", "1") -- open o
bulletFor 2 = ("bullet", "\xf0a7", Just "Wingdings", "1") -- closed box
bulletFor x = bulletFor (x `mod` 3)
styleFor UpperAlpha _ = "upperLetter"
styleFor LowerAlpha _ = "lowerLetter"
styleFor UpperRoman _ = "upperRoman"
styleFor LowerRoman _ = "lowerRoman"
styleFor Decimal _ = "decimal"
styleFor DefaultStyle 0 = "decimal"
styleFor DefaultStyle 1 = "lowerLetter"
styleFor DefaultStyle 2 = "lowerRoman"
styleFor DefaultStyle 3 = "decimal"
styleFor DefaultStyle 4 = "lowerLetter"
styleFor DefaultStyle 5 = "lowerRoman"
styleFor DefaultStyle x = styleFor DefaultStyle (x `mod` 6)
styleFor _ _ = "decimal"
patternFor OneParen s = s <> ")"
patternFor TwoParens s = "(" <> s <> ")"
patternFor _ s = s <> "."