content: {-# LANGUAGE PatternGuards       #-}
  {-# LANGUAGE RankNTypes          #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE ViewPatterns        #-}
  {-# LANGUAGE FlexibleContexts    #-}
  {-# LANGUAGE OverloadedStrings   #-}
  {- |
     Module      : Text.Pandoc.Writers.Docx
     Copyright   : Copyright (C) 2012-2025 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.Highlighting (defaultStyle)
  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 ++
                    (case writerHighlightMethod opts of
                       Skylighting sty -> styleToOpenXml styleMaps sty
                       DefaultHighlighting -> styleToOpenXml styleMaps
                                                defaultStyle
                       _ -> [])
    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 <> "."
  