{-# 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 as B
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 (MimeType, getMimeTypeDef)
import Text.Pandoc.Options
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 Text.Collate.Lang (renderLang, Lang(..))

writeDocx :: (PandocMonad m)
          => WriterOptions  -- ^ Writer options
          -> Pandoc         -- ^ Document to convert
          -> m BL.ByteString
writeDocx opts doc = do
  -- Phase 1: Document preprocessing
  let Pandoc meta blocks = walk fixDisplayMath doc
  setupTranslations meta
  let blocks' = makeSectionsWithOffsets (writerNumberOffset opts)
                   True Nothing blocks
  let doc' = Pandoc meta blocks'

  -- Phase 2: Archive loading
  (refArchive, distArchive, username, utctime) <- loadArchives opts
  let epochtime = floor $ utcTimeToPOSIXSeconds utctime

  -- Phase 3: Page layout extraction
  (mbsectpr, pgContentWidth) <- extractPageLayout refArchive distArchive

  -- Phase 4: Language & style setup
  mblang <- toLang $ getLang opts meta
  let addLang = mkLangTransformer mblang
  styledoc <- addLang <$> parseXml refArchive distArchive "word/styles.xml"
  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
        }

  -- Phase 5: Relationship extraction
  (baserels, headers, footers, newMaxRelId) <- extractRelationships refArchive distArchive

  let initialSt = defaultWriterState {
          stStyleMaps  = styleMaps
        , stTocTitle   = tocTitle
        , stCurId      = newMaxRelId + 1
        }

  -- Phase 6: Core content generation
  -- adjust contents to add sectPr from reference.docx
  let sectpr = case mbsectpr of
        Just sectpr' -> setWmlPrefix 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 imgs = M.elems $ stImages st

  -- Phase 7: XML document construction
  -- 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.
  let contentTypesEntry = mkContentTypesEntry epochtime imgs headers footers refArchive
  let relEntry = mkDocumentRelsEntry epochtime baserels imgs (stExternalLinks st)
  let contentEntry = toEntry "word/document.xml" epochtime
                       (BL.fromStrict $ UTF8.fromText contents)
  let footnotesEntry = mkFootnotesEntry epochtime footnotes
  let footnoteRelEntry = mkFootnoteRelsEntry epochtime (stExternalLinks st)
  let commentsEntry = mkCommentsEntry epochtime comments
  let styleEntry = mkStylesEntry epochtime styledoc styleMaps st opts
  numEntry <- mkNumberingEntry refArchive distArchive epochtime (stLists st)
  let docPropsEntry = mkCorePropsEntry epochtime utctime meta
  let customPropsEntry = mkCustomPropsEntry epochtime meta
  let relsEntry = mkPackageRelsEntry epochtime

  -- 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
  settingsEntry <- copyChildren refArchive distArchive "word/settings.xml"
                     epochtime settingsElementNames

  -- Phase 8: Archive assembly
  let toImageEntry (_, path, _, img) = toEntry ("word/" ++ path) epochtime $ toLazy img
  let imageEntries = map toImageEntry imgs

  refEntries <- collectReferenceEntries refArchive distArchive headers footers

  let archive = foldr addEntryToArchive emptyArchive $
                  contentTypesEntry : relsEntry : contentEntry : relEntry :
                  footnoteRelEntry : numEntry : styleEntry : footnotesEntry :
                  commentsEntry :
                  docPropsEntry : customPropsEntry :
                  settingsEntry :
                  imageEntries ++ refEntries
  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

-- | Standard XML namespace attributes for docx elements
stdAttributes :: [(Text, Text)]
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")]

-- | Settings elements to copy from reference.docx (order matters)
settingsElementNames :: [Text]
settingsElementNames =
  [ "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" ]

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 <> "."

-- | Build language transformer function for modifying XML elements.
-- Navigates directly to w:docDefaults/w:rPr/w:lang instead of generic traversal.
mkLangTransformer :: Maybe Lang -> (Element -> Element)
mkLangTransformer Nothing  = id
mkLangTransformer (Just lang) = modifyAtPath path updateLangAttrs
  where
    -- Path is: w:docDefaults / w:rPrDefault / w:rPr / w:lang
    path = [named "docDefaults", named "rPrDefault", named "rPr", named "lang"]
    named n = (== n) . qName

    updateLangAttrs e
      | isEastAsianLang lang = e{ elAttribs = map (setattr "eastAsia") $ elAttribs e }
      | isBidiLang lang      = e{ elAttribs = map (setattr "bidi") $ elAttribs e }
      | otherwise            = e{ elAttribs = map (setattr "val") $ elAttribs e }

    setattr attrname (XML.Attr qn@(QName s _ _) _)
      | s == attrname  = XML.Attr qn (renderLang lang)
    setattr _ x        = x

    isEastAsianLang Lang{ langLanguage = l } = l == "zh" || l == "ja" || l == "ko"
    isBidiLang Lang{ langLanguage = l } = l == "he" || l == "ar"

-- | Modify an element at a specific path in the XML tree.
-- The path is a list of predicates that match element names at each level.
modifyAtPath :: [(QName -> Bool)] -> (Element -> Element) -> Element -> Element
modifyAtPath [] f e = f e
modifyAtPath (p:ps) f e = e{ elContent = map go (elContent e) }
  where
    go (Elem el) | p (elName el) = Elem (modifyAtPath ps f el)
    go c = c

setWmlPrefix :: Element -> Element
setWmlPrefix el =
  add_attrs (map fixWmlAttr (elAttribs el)) $
    mknode "w:sectPr" [] (map fixWmlChild (elChildren el))
  where
    fixWmlAttr attr = attr{ attrKey = fixWmlQName (attrKey attr) }
    fixWmlQName qn
      | isWmlNamespace qn = qn{ qPrefix = Just "w" }
      | otherwise = qn
    fixWmlChild e
      | qPrefix (elName e) /= Just "w"
      , isWmlNamespace (elName e) =
          e{ elName = fixWmlQName (elName e)
           , elAttribs = map fixWmlAttr (elAttribs e) }
      | otherwise = e

-- | Load reference and distribution archives
loadArchives :: PandocMonad m
             => WriterOptions
             -> m (Archive, Archive, Maybe Text, UTCTime)
loadArchives opts = do
  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"
  return (refArchive, distArchive, username, utctime)

isWmlNamespace :: QName -> Bool
isWmlNamespace qn =
  qURI qn == Just
    "http://schemas.openxmlformats.org/wordprocessingml/2006/main" ||
  qURI qn == Just "http://purl.oclc.org/ooxml/wordprocessingml/main"

-- | Extract page dimensions from template
extractPageLayout :: PandocMonad m
                  => Archive -> Archive -> m (Maybe Element, Maybe Integer)
extractPageLayout refArchive distArchive = do
  parsedDoc <- parseXml refArchive distArchive "word/document.xml"
  let wname f qn = isWmlNamespace qn && 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

  return (mbsectpr, pgContentWidth)

-- | Parse and augment relationships from reference.docx
extractRelationships :: PandocMonad m
                     => Archive -> Archive
                     -> m ([Element], [Element], [Element], Int)
extractRelationships refArchive distArchive = do
  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")
                    ]

  return (baserels, headers, footers, newMaxRelId)

-- | Create footnotes XML entry
mkFootnotesEntry :: Integer -> [Element] -> Entry
mkFootnotesEntry epochtime footnotes =
  let notes = mknode "w:footnotes" stdAttributes footnotes
  in toEntry "word/footnotes.xml" epochtime $ renderXml notes

-- | Create footnote relationships entry
mkFootnoteRelsEntry :: Integer -> M.Map Text Text -> Entry
mkFootnoteRelsEntry epochtime externalLinks =
  let linkrels = map toLinkRel $ M.toList externalLinks
      toLinkRel (src, ident) = mknode "Relationship"
        [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
        ,("Id",ident)
        ,("Target",src)
        ,("TargetMode","External")] ()
  in toEntry "word/_rels/footnotes.xml.rels" epochtime
       $ renderXml $ mknode "Relationships"
           [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
           linkrels

-- | Create comments XML entry
mkCommentsEntry :: Integer -> [Element] -> Entry
mkCommentsEntry epochtime comments =
  toEntry "word/comments.xml" epochtime
    $ renderXml $ mknode "w:comments" stdAttributes comments

-- | Create package-level relationships entry
mkPackageRelsEntry :: Integer -> Entry
mkPackageRelsEntry epochtime =
  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")]
        ]
  in toEntry "_rels/.rels" epochtime $ renderXml rels

-- | Create content types manifest entry
mkContentTypesEntry :: Integer
                    -> [(String, String, Maybe MimeType, B.ByteString)]  -- imgs
                    -> [Element]  -- headers
                    -> [Element]  -- footers
                    -> Archive    -- refArchive
                    -> Entry
mkContentTypesEntry epochtime imgs headers footers refArchive =
  let mkOverrideNode (part', contentType') = mknode "Override"
           [("PartName", T.pack part')
           ,("ContentType", contentType')] ()
      mkImageOverride (_, imgpath, mbMimeType, _) =
          mkOverrideNode ("/word/" <> imgpath,
                          fromMaybe "application/octet-stream" mbMimeType)
      mkMediaOverride imgpath =
          mkOverrideNode ("/" <> imgpath, getMimeTypeDef imgpath)
      unrelativize ('/':xs) = '/':xs
      unrelativize xs = "/word/" ++ xs
      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 "" (unrelativize . T.unpack) (extractTarget x),
                       "application/vnd.openxmlformats-officedocument.wordprocessingml.header+xml")) headers ++
                  map (\x -> (maybe "" (unrelativize . T.unpack) (extractTarget x),
                       "application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml")) footers) ++
                    map mkImageOverride imgs ++
                    [ mkMediaOverride (eRelativePath e)
                        | e <- zEntries refArchive
                        , "word/media/" `isPrefixOf` eRelativePath e
                        , not ("/" `isSuffixOf` eRelativePath e) ]
      mkDefaultNode (ext, mt) =
        mknode "Default" [("Extension",ext),("ContentType",mt)] ()
      defaultnodes = map mkDefaultNode
        [("xml", "application/xml"),
         ("rels", "application/vnd.openxmlformats-package.relationships+xml"),
         ("odttf",
           "application/vnd.openxmlformats-officedocument.obfuscatedFont")]
      contentTypesDoc = mknode "Types"
        [("xmlns","http://schemas.openxmlformats.org/package/2006/content-types")]
        $ defaultnodes ++ overrides
  in toEntry "[Content_Types].xml" epochtime $ renderXml contentTypesDoc

-- | Create document relationships entry
mkDocumentRelsEntry :: Integer
                    -> [Element]  -- baserels
                    -> [(String, String, Maybe MimeType, B.ByteString)]  -- imgs
                    -> M.Map Text Text  -- externalLinks
                    -> Entry
mkDocumentRelsEntry epochtime baserels imgs externalLinks =
  let toImgRel (ident, path, _, _) = mknode "Relationship"
        [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
        ,("Id",T.pack ident)
        ,("Target",T.pack path)] ()
      imgrels = map toImgRel imgs
      toLinkRel (src, ident) = mknode "Relationship"
        [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
        ,("Id",ident)
        ,("Target",src)
        ,("TargetMode","External")] ()
      linkrels = map toLinkRel $ M.toList externalLinks
      reldoc = mknode "Relationships"
        [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
        $ baserels ++ imgrels ++ linkrels
  in toEntry "word/_rels/document.xml.rels" epochtime $ renderXml reldoc

-- | Create styles entry with dynamic additions
mkStylesEntry :: Integer -> Element -> StyleMaps -> WriterState -> WriterOptions -> Entry
mkStylesEntry epochtime styledoc styleMaps st opts =
  let stylepath = "word/styles.xml"
      -- 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.
      newDynamicParaProps = filter
        (\sty -> not $ hasStyleName sty $ smParaStyle styleMaps)
        (Set.toList $ stDynamicParaProps st)

      newDynamicTextProps = filter
        (\sty -> not $ hasStyleName sty $ smCharStyle styleMaps)
        (Set.toList $ stDynamicTextProps st)

      newstyles = map newParaPropToOpenXml newDynamicParaProps ++
                  map newTextPropToOpenXml newDynamicTextProps ++
                  (case writerHighlightMethod opts of
                     Skylighting sty -> styleToOpenXml styleMaps sty
                     DefaultHighlighting -> styleToOpenXml styleMaps
                                              defaultStyle
                     _ -> [])
      styledoc' = styledoc{ elContent = elContent styledoc ++
                                           map Elem newstyles }
  in toEntry stylepath epochtime $ renderXml styledoc'

-- | Create core document properties entry
mkCorePropsEntry :: Integer -> UTCTime -> Meta -> Entry
mkCorePropsEntry epochtime utctime meta =
  let metaValueToText (MetaString s)    = s
      metaValueToText (MetaInlines ils) = stringify ils
      metaValueToText (MetaBlocks bs)   = stringify bs
      metaValueToText (MetaBool b)      = T.pack (show b)
      metaValueToText _                 = ""
      keywords = case lookupMeta "keywords" meta of
                       Just (MetaList xs) -> map metaValueToText xs
                       _                  -> []
      docPropsPath = "docProps/core.xml"
      extraCoreProps = ["subject","lang","category","description"]
      extraCorePropsMap = M.fromList $ zip extraCoreProps
                       ["dc:subject","dc:language","cp:category","dc:description"]
      lookupMetaString' :: Text -> Meta -> Text
      lookupMetaString' key' meta' =
        case key' of
             "description" -> T.intercalate "_x000d_\n"
                                (map stringify $ lookupMetaBlocks "description" meta')
             key''         -> lookupMetaString key'' meta'

      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)
  in toEntry docPropsPath epochtime $ renderXml docProps

-- | Create custom document properties entry
mkCustomPropsEntry :: Integer -> Meta -> Entry
mkCustomPropsEntry epochtime meta =
  let extraCoreProps = ["subject","lang","category","description"]
      customProperties :: [(Text, Text)]
      customProperties = [ (k, lookupMetaString k meta)
                         | k <- M.keys (unMeta meta)
                         , k `notElem` (["title", "author", "keywords"]
                                       ++ extraCoreProps)]
      mkCustomProp (k, v) pid = mknode "property"
         [("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
         ,("pid", tshow pid)
         ,("name", k)] $ mknode "vt:lpwstr" [] v
      customPropsPath = "docProps/custom.xml"
      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)..]
  in toEntry customPropsPath epochtime $ renderXml customProps

-- | Create numbering entry
mkNumberingEntry :: PandocMonad m
                 => Archive -> Archive -> Integer -> [ListMarker] -> m Entry
mkNumberingEntry refArchive distArchive epochtime lists = do
  let numpath = "word/numbering.xml"
  numbering <- parseXml refArchive distArchive numpath
  let newNumElts = mkNumbering lists
  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
  return $ 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" ] }

-- | Collect auxiliary entries from reference archive
collectReferenceEntries :: PandocMonad m
                        => Archive -> Archive -> [Element] -> [Element]
                        -> m [Entry]
collectReferenceEntries refArchive distArchive headers footers = do
  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)]
  webSettingsEntry <- entryFromArchive refArchive "word/webSettings.xml"
  let unrelativize ('/':xs) = xs
      unrelativize xs = "word/" ++ xs
  headerFooterEntries <- mapM (entryFromArchive refArchive . unrelativize) $
                         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 ]
  return $ docPropsAppEntry : themeEntry : fontTableEntry : webSettingsEntry
         : fontTableRelsEntries ++ fontEntries ++ headerFooterEntries
         ++ miscRelEntries ++ otherMediaEntries

extractTarget :: Element -> Maybe Text
extractTarget = findAttr (QName "Target" Nothing Nothing)
