{-# 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.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 Text.Collate.Lang (renderLang, Lang(..))

writeDocx :: (PandocMonad m)
          => WriterOptions  -- ^ Writer options
          -> Pandoc         -- ^ Document to convert
          -> m BL.ByteString
writeDocx :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m ByteString
writeDocx WriterOptions
opts Pandoc
doc = do
  -- Phase 1: Document preprocessing
  let Pandoc Meta
meta [Block]
blocks = (Block -> Block) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
fixDisplayMath Pandoc
doc
  Meta -> m ()
forall (m :: * -> *). PandocMonad m => Meta -> m ()
setupTranslations Meta
meta
  let blocks' :: [Block]
blocks' = [Int] -> Bool -> Maybe Int -> [Block] -> [Block]
makeSectionsWithOffsets (WriterOptions -> [Int]
writerNumberOffset WriterOptions
opts)
                   Bool
True Maybe Int
forall a. Maybe a
Nothing [Block]
blocks
  let doc' :: Pandoc
doc' = Meta -> [Block] -> Pandoc
Pandoc Meta
meta [Block]
blocks'

  -- Phase 2: Archive loading
  (Archive
refArchive, Archive
distArchive, Maybe Text
username, UTCTime
utctime) <- WriterOptions -> m (Archive, Archive, Maybe Text, UTCTime)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> m (Archive, Archive, Maybe Text, UTCTime)
loadArchives WriterOptions
opts
  let epochtime :: Integer
epochtime = POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer) -> POSIXTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
utctime

  -- Phase 3: Page layout extraction
  (Maybe Element
mbsectpr, Maybe Integer
pgContentWidth) <- Archive -> Archive -> m (Maybe Element, Maybe Integer)
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> m (Maybe Element, Maybe Integer)
extractPageLayout Archive
refArchive Archive
distArchive

  -- Phase 4: Language & style setup
  Maybe Lang
mblang <- Maybe Text -> m (Maybe Lang)
forall (m :: * -> *). PandocMonad m => Maybe Text -> m (Maybe Lang)
toLang (Maybe Text -> m (Maybe Lang)) -> Maybe Text -> m (Maybe Lang)
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Meta -> Maybe Text
getLang WriterOptions
opts Meta
meta
  let addLang :: Element -> Element
addLang = Maybe Lang -> Element -> Element
mkLangTransformer Maybe Lang
mblang
  Element
styledoc <- Element -> Element
addLang (Element -> Element) -> m Element -> m Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Archive -> Archive -> String -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> String -> m Element
parseXml Archive
refArchive Archive
distArchive String
"word/styles.xml"
  let styleMaps :: StyleMaps
styleMaps = Archive -> StyleMaps
getStyleMaps Archive
refArchive

  let tocTitle :: [Inline]
tocTitle = case Text -> Meta -> [Inline]
lookupMetaInlines Text
"toc-title" Meta
meta of
                   [] -> WriterState -> [Inline]
stTocTitle WriterState
defaultWriterState
                   [Inline]
ls -> [Inline]
ls

  let isRTLmeta :: Bool
isRTLmeta = case Text -> Meta -> Maybe MetaValue
lookupMeta Text
"dir" Meta
meta of
        Just (MetaString Text
"rtl")        -> Bool
True
        Just (MetaInlines [Str Text
"rtl"]) -> Bool
True
        Maybe MetaValue
_                              -> Bool
False

  let env :: WriterEnv
env = WriterEnv
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
  ([Element]
baserels, [Element]
headers, [Element]
footers, Int
newMaxRelId) <- Archive -> Archive -> m ([Element], [Element], [Element], Int)
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> m ([Element], [Element], [Element], Int)
extractRelationships Archive
refArchive Archive
distArchive

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

  -- Phase 6: Core content generation
  -- adjust contents to add sectPr from reference.docx
  let sectpr :: Element
sectpr = case Maybe Element
mbsectpr of
        Just Element
sectpr' -> [Attr] -> Element -> Element
add_attrs (Element -> [Attr]
elAttribs Element
sectpr') (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:sectPr" []
                             (Element -> [Element]
elChildren Element
sectpr')
        Maybe Element
Nothing      -> Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:sectPr" []
                          [ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:footnotePr" []
                            [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:numRestart" [(Text
"w:val",Text
"eachSect")] () ]
                          ]

  ((Text
contents, [Element]
footnotes, [Element]
comments), WriterState
st) <- StateT WriterState m (Text, [Element], [Element])
-> WriterState -> m ((Text, [Element], [Element]), WriterState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
                         (ReaderT
  WriterEnv (StateT WriterState m) (Text, [Element], [Element])
-> WriterEnv -> StateT WriterState m (Text, [Element], [Element])
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
                          (WriterOptions
-> Pandoc
-> ReaderT
     WriterEnv (StateT WriterState m) (Text, [Element], [Element])
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> WS m (Text, [Element], [Element])
writeOpenXML WriterOptions
opts{ writerWrapText = WrapNone }
                                        Pandoc
doc')
                          WriterEnv
env{ envSectPr = Just sectpr })
                         WriterState
initialSt
  let imgs :: [(String, String, Maybe Text, ByteString)]
imgs = Map String (String, String, Maybe Text, ByteString)
-> [(String, String, Maybe Text, ByteString)]
forall k a. Map k a -> [a]
M.elems (Map String (String, String, Maybe Text, ByteString)
 -> [(String, String, Maybe Text, ByteString)])
-> Map String (String, String, Maybe Text, ByteString)
-> [(String, String, Maybe Text, ByteString)]
forall a b. (a -> b) -> a -> b
$ WriterState -> Map String (String, String, Maybe Text, ByteString)
stImages WriterState
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 :: Entry
contentTypesEntry = Integer
-> [(String, String, Maybe Text, ByteString)]
-> [Element]
-> [Element]
-> Archive
-> Entry
mkContentTypesEntry Integer
epochtime [(String, String, Maybe Text, ByteString)]
imgs [Element]
headers [Element]
footers Archive
refArchive
  let relEntry :: Entry
relEntry = Integer
-> [Element]
-> [(String, String, Maybe Text, ByteString)]
-> Map Text Text
-> Entry
mkDocumentRelsEntry Integer
epochtime [Element]
baserels [(String, String, Maybe Text, ByteString)]
imgs (WriterState -> Map Text Text
stExternalLinks WriterState
st)
  let contentEntry :: Entry
contentEntry = String -> Integer -> ByteString -> Entry
toEntry String
"word/document.xml" Integer
epochtime
                       (ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
UTF8.fromText Text
contents)
  let footnotesEntry :: Entry
footnotesEntry = Integer -> [Element] -> Entry
mkFootnotesEntry Integer
epochtime [Element]
footnotes
  let footnoteRelEntry :: Entry
footnoteRelEntry = Integer -> Map Text Text -> Entry
mkFootnoteRelsEntry Integer
epochtime (WriterState -> Map Text Text
stExternalLinks WriterState
st)
  let commentsEntry :: Entry
commentsEntry = Integer -> [Element] -> Entry
mkCommentsEntry Integer
epochtime [Element]
comments
  let styleEntry :: Entry
styleEntry = Integer
-> Element -> StyleMaps -> WriterState -> WriterOptions -> Entry
mkStylesEntry Integer
epochtime Element
styledoc StyleMaps
styleMaps WriterState
st WriterOptions
opts
  Entry
numEntry <- Archive -> Archive -> Integer -> [ListMarker] -> m Entry
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> Integer -> [ListMarker] -> m Entry
mkNumberingEntry Archive
refArchive Archive
distArchive Integer
epochtime (WriterState -> [ListMarker]
stLists WriterState
st)
  let docPropsEntry :: Entry
docPropsEntry = Integer -> UTCTime -> Meta -> Entry
mkCorePropsEntry Integer
epochtime UTCTime
utctime Meta
meta
  let customPropsEntry :: Entry
customPropsEntry = Integer -> Meta -> Entry
mkCustomPropsEntry Integer
epochtime Meta
meta
  let relsEntry :: Entry
relsEntry = Integer -> Entry
mkPackageRelsEntry Integer
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
  Entry
settingsEntry <- Archive -> Archive -> String -> Integer -> [Text] -> m Entry
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> String -> Integer -> [Text] -> m Entry
copyChildren Archive
refArchive Archive
distArchive String
"word/settings.xml"
                     Integer
epochtime [Text]
settingsElementNames

  -- Phase 8: Archive assembly
  let toImageEntry :: (a, String, c, ByteString) -> Entry
toImageEntry (a
_, String
path, c
_, ByteString
img) = String -> Integer -> ByteString -> Entry
toEntry (String
"word/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path) Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toLazy ByteString
img
  let imageEntries :: [Entry]
imageEntries = ((String, String, Maybe Text, ByteString) -> Entry)
-> [(String, String, Maybe Text, ByteString)] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, Maybe Text, ByteString) -> Entry
forall {a} {c}. (a, String, c, ByteString) -> Entry
toImageEntry [(String, String, Maybe Text, ByteString)]
imgs

  [Entry]
refEntries <- Archive -> Archive -> [Element] -> [Element] -> m [Entry]
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> [Element] -> [Element] -> m [Entry]
collectReferenceEntries Archive
refArchive Archive
distArchive [Element]
headers [Element]
footers

  let archive :: Archive
archive = (Entry -> Archive -> Archive) -> Archive -> [Entry] -> Archive
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
addEntryToArchive Archive
emptyArchive ([Entry] -> Archive) -> [Entry] -> Archive
forall a b. (a -> b) -> a -> b
$
                  Entry
contentTypesEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
relsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
contentEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
relEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
                  Entry
footnoteRelEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
numEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
styleEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
footnotesEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
                  Entry
commentsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
                  Entry
docPropsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
customPropsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
                  Entry
settingsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
                  [Entry]
imageEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
refEntries
  ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Archive -> ByteString
fromArchive Archive
archive

newParaPropToOpenXml :: ParaStyleName -> Element
newParaPropToOpenXml :: ParaStyleName -> Element
newParaPropToOpenXml (ParaStyleName -> Text
forall a. FromStyleName a => a -> Text
fromStyleName -> Text
s) =
  let styleId :: Text
styleId = (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
s
  in Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:style" [ (Text
"w:type", Text
"paragraph")
                      , (Text
"w:customStyle", Text
"1")
                      , (Text
"w:styleId", Text
styleId)]
     [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:name" [(Text
"w:val", Text
s)] ()
     , Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:basedOn" [(Text
"w:val",Text
"BodyText")] ()
     , Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:qFormat" [] ()
     ]

newTextPropToOpenXml :: CharStyleName -> Element
newTextPropToOpenXml :: CharStyleName -> Element
newTextPropToOpenXml (CharStyleName -> Text
forall a. FromStyleName a => a -> Text
fromStyleName -> Text
s) =
  let styleId :: Text
styleId = (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
s
  in Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:style" [ (Text
"w:type", Text
"character")
                      , (Text
"w:customStyle", Text
"1")
                      , (Text
"w:styleId", Text
styleId)]
     [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:name" [(Text
"w:val", Text
s)] ()
     , Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:basedOn" [(Text
"w:val",Text
"BodyTextChar")] ()
     ]

styleToOpenXml :: StyleMaps -> Style -> [Element]
styleToOpenXml :: StyleMaps -> Style -> [Element]
styleToOpenXml StyleMaps
sm Style
style =
  Maybe Element -> [Element]
forall a. Maybe a -> [a]
maybeToList Maybe Element
parStyle [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ (TokenType -> Maybe Element) -> [TokenType] -> [Element]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TokenType -> Maybe Element
toStyle [TokenType]
alltoktypes
  where alltoktypes :: [TokenType]
alltoktypes = TokenType -> TokenType -> [TokenType]
forall a. Enum a => a -> a -> [a]
enumFromTo TokenType
KeywordTok TokenType
NormalTok
        toStyle :: TokenType -> Maybe Element
toStyle TokenType
toktype | CharStyleName -> Map CharStyleName CharStyle -> Bool
forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName (String -> CharStyleName
forall a. IsString a => String -> a
fromString (String -> CharStyleName) -> String -> CharStyleName
forall a b. (a -> b) -> a -> b
$ TokenType -> String
forall a. Show a => a -> String
show TokenType
toktype) (StyleMaps -> Map CharStyleName CharStyle
smCharStyle StyleMaps
sm) = Maybe Element
forall a. Maybe a
Nothing
                        | Bool
otherwise = Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
                          Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:style" [(Text
"w:type",Text
"character"),
                           (Text
"w:customStyle",Text
"1"),(Text
"w:styleId", TokenType -> Text
forall a. Show a => a -> Text
tshow TokenType
toktype)]
                             [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:name" [(Text
"w:val", TokenType -> Text
forall a. Show a => a -> Text
tshow TokenType
toktype)] ()
                             , Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:basedOn" [(Text
"w:val",Text
"VerbatimChar")] ()
                             , Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
                               [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:b" [] () | (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenBold TokenType
toktype ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                               [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:i" [] () | (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenItalic TokenType
toktype ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                               [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:color" [(Text
"w:val", TokenType -> Text
tokCol TokenType
toktype)] ()
                                 | TokenType -> Text
tokCol TokenType
toktype Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"auto" ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                               [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:u" [] () | (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenUnderline TokenType
toktype ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                               [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:shd" [(Text
"w:val",Text
"clear")
                                                ,(Text
"w:fill",TokenType -> Text
tokBg TokenType
toktype)] ()
                                 | TokenType -> Text
tokBg TokenType
toktype Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"auto" ]
                             ]
        tokStyles :: Map TokenType TokenStyle
tokStyles = Style -> Map TokenType TokenStyle
tokenStyles Style
style
        tokFeature :: (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
f TokenType
toktype = Bool -> (TokenStyle -> Bool) -> Maybe TokenStyle -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TokenStyle -> Bool
f (Maybe TokenStyle -> Bool) -> Maybe TokenStyle -> Bool
forall a b. (a -> b) -> a -> b
$ TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles
        tokCol :: TokenType -> Text
tokCol TokenType
toktype = Text -> (Color -> Text) -> Maybe Color -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"auto" (String -> Text
T.pack (String -> Text) -> (Color -> String) -> Color -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (Color -> String) -> Color -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> String
forall a. FromColor a => Color -> a
fromColor)
                         (Maybe Color -> Text) -> Maybe Color -> Text
forall a b. (a -> b) -> a -> b
$ (TokenStyle -> Maybe Color
tokenColor (TokenStyle -> Maybe Color) -> Maybe TokenStyle -> Maybe Color
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles)
                           Maybe Color -> Maybe Color -> Maybe Color
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
defaultColor Style
style
        tokBg :: TokenType -> Text
tokBg TokenType
toktype = Text -> (Color -> Text) -> Maybe Color -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"auto" (String -> Text
T.pack (String -> Text) -> (Color -> String) -> Color -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (Color -> String) -> Color -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> String
forall a. FromColor a => Color -> a
fromColor)
                         (Maybe Color -> Text) -> Maybe Color -> Text
forall a b. (a -> b) -> a -> b
$ (TokenStyle -> Maybe Color
tokenBackground (TokenStyle -> Maybe Color) -> Maybe TokenStyle -> Maybe Color
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles)
                           Maybe Color -> Maybe Color -> Maybe Color
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
backgroundColor Style
style
        parStyle :: Maybe Element
parStyle | ParaStyleName -> Map ParaStyleName ParStyle -> Bool
forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName ParaStyleName
"Source Code" (StyleMaps -> Map ParaStyleName ParStyle
smParaStyle StyleMaps
sm) = Maybe Element
forall a. Maybe a
Nothing
                 | Bool
otherwise = Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
                   Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:style" [(Text
"w:type",Text
"paragraph"),
                           (Text
"w:customStyle",Text
"1"),(Text
"w:styleId",Text
"SourceCode")]
                             [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:name" [(Text
"w:val",Text
"Source Code")] ()
                             , Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:basedOn" [(Text
"w:val",Text
"Normal")] ()
                             , Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:link" [(Text
"w:val",Text
"VerbatimChar")] ()
                             , Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pPr" []
                               ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:wordWrap" [(Text
"w:val",Text
"off")] ()
                               Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:
                         [Element] -> (Color -> [Element]) -> Maybe Color -> [Element]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Color
col -> [Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:shd" [(Text
"w:val",Text
"clear"),(Text
"w:fill", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Color -> String
forall a. FromColor a => Color -> a
fromColor Color
col)] ()]) (Style -> Maybe Color
backgroundColor Style
style)
                             ]

copyChildren :: (PandocMonad m)
             => Archive -> Archive -> String -> Integer -> [Text] -> m Entry
copyChildren :: forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> String -> Integer -> [Text] -> m Entry
copyChildren Archive
refArchive Archive
distArchive String
path Integer
timestamp [Text]
elNames = do
  Element
ref  <- Archive -> Archive -> String -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> String -> m Element
parseXml Archive
refArchive Archive
distArchive String
path
  Element
dist <- Archive -> Archive -> String -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> String -> m Element
parseXml Archive
distArchive Archive
distArchive String
path
  [Element]
els <- ([Element] -> Text -> m [Element])
-> [Element] -> [Text] -> m [Element]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Element -> Element -> [Element] -> Text -> m [Element]
forall {f :: * -> *}.
Applicative f =>
Element -> Element -> [Element] -> Text -> f [Element]
addEl Element
ref Element
dist) [] ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
elNames)
  Entry -> m Entry
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> m Entry) -> Entry -> m Entry
forall a b. (a -> b) -> a -> b
$ String -> Integer -> ByteString -> Entry
toEntry String
path Integer
timestamp
         (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
dist{ elContent = map cleanElem els }
  where
    addEl :: Element -> Element -> [Element] -> Text -> f [Element]
addEl Element
ref Element
dist [Element]
els Text
name =
      case (QName -> Bool) -> Element -> Maybe Element
filterChildName (Text -> QName -> Bool
hasName Text
name) Element
ref Maybe Element -> Maybe Element -> Maybe Element
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
             (QName -> Bool) -> Element -> Maybe Element
filterChildName (Text -> QName -> Bool
hasName Text
name) Element
dist of
        Just Element
el -> [Element] -> f [Element]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element
el Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
els)
        Maybe Element
Nothing -> [Element] -> f [Element]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Element]
els
    hasName :: Text -> QName -> Bool
hasName Text
name = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name) (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName
    cleanElem :: Element -> Content
cleanElem el :: Element
el@Element{elName :: Element -> QName
elName=QName
name} = Element -> Content
Elem Element
el{elName=name{qURI=Nothing}}

-- this is the lowest number used for a list numId
baseListId :: Int
baseListId :: Int
baseListId = Int
1000

-- | Standard XML namespace attributes for docx elements
stdAttributes :: [(Text, Text)]
stdAttributes :: [(Text, Text)]
stdAttributes =
  [(Text
"xmlns:w",Text
"http://schemas.openxmlformats.org/wordprocessingml/2006/main")
  ,(Text
"xmlns:m",Text
"http://schemas.openxmlformats.org/officeDocument/2006/math")
  ,(Text
"xmlns:r",Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships")
  ,(Text
"xmlns:o",Text
"urn:schemas-microsoft-com:office:office")
  ,(Text
"xmlns:v",Text
"urn:schemas-microsoft-com:vml")
  ,(Text
"xmlns:w10",Text
"urn:schemas-microsoft-com:office:word")
  ,(Text
"xmlns:a",Text
"http://schemas.openxmlformats.org/drawingml/2006/main")
  ,(Text
"xmlns:pic",Text
"http://schemas.openxmlformats.org/drawingml/2006/picture")
  ,(Text
"xmlns:wp",Text
"http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing")]

-- | Settings elements to copy from reference.docx (order matters)
settingsElementNames :: [Text]
settingsElementNames :: [Text]
settingsElementNames =
  [ Text
"writeProtection"
  , Text
"view"
  , Text
"zoom"
  , Text
"removePersonalInformation"
  , Text
"removeDateAndTime"
  , Text
"doNotDisplayPageBoundaries"
  , Text
"displayBackgroundShape"
  , Text
"printPostScriptOverText"
  , Text
"printFractionalCharacterWidth"
  , Text
"printFormsData"
  , Text
"embedTrueTypeFonts"
  , Text
"embedSystemFonts"
  , Text
"saveSubsetFonts"
  , Text
"saveFormsData"
  , Text
"mirrorMargins"
  , Text
"alignBordersAndEdges"
  , Text
"bordersDoNotSurroundHeader"
  , Text
"bordersDoNotSurroundFooter"
  , Text
"gutterAtTop"
  , Text
"hideSpellingErrors"
  , Text
"hideGrammaticalErrors"
  , Text
"activeWritingStyle"
  , Text
"proofState"
  , Text
"formsDesign"
  , Text
"attachedTemplate"
  , Text
"linkStyles"
  , Text
"stylePaneFormatFilter"
  , Text
"stylePaneSortMethod"
  , Text
"documentType"
  , Text
"mailMerge"
  , Text
"revisionView"
  , Text
"trackRevisions"
  , Text
"doNotTrackMoves"
  , Text
"doNotTrackFormatting"
  , Text
"documentProtection"
  , Text
"autoFormatOverride"
  , Text
"styleLockTheme"
  , Text
"styleLockQFSet"
  , Text
"defaultTabStop"
  , Text
"autoHyphenation"
  , Text
"consecutiveHyphenLimit"
  , Text
"hyphenationZone"
  , Text
"doNotHyphenateCaps"
  , Text
"showEnvelope"
  , Text
"summaryLength"
  , Text
"clickAndTypeStyle"
  , Text
"defaultTableStyle"
  , Text
"evenAndOddHeaders"
  , Text
"bookFoldRevPrinting"
  , Text
"bookFoldPrinting"
  , Text
"bookFoldPrintingSheets"
  , Text
"drawingGridHorizontalSpacing"
  , Text
"drawingGridVerticalSpacing"
  , Text
"displayHorizontalDrawingGridEvery"
  , Text
"displayVerticalDrawingGridEvery"
  , Text
"doNotUseMarginsForDrawingGridOrigin"
  , Text
"drawingGridHorizontalOrigin"
  , Text
"drawingGridVerticalOrigin"
  , Text
"doNotShadeFormData"
  , Text
"noPunctuationKerning"
  , Text
"characterSpacingControl"
  , Text
"printTwoOnOne"
  , Text
"strictFirstAndLastChars"
  , Text
"noLineBreaksAfter"
  , Text
"noLineBreaksBefore"
  , Text
"savePreviewPicture"
  , Text
"doNotValidateAgainstSchema"
  , Text
"saveInvalidXml"
  , Text
"ignoreMixedContent"
  , Text
"alwaysShowPlaceholderText"
  , Text
"doNotDemarcateInvalidXml"
  , Text
"saveXmlDataOnly"
  , Text
"useXSLTWhenSaving"
  , Text
"saveThroughXslt"
  , Text
"showXMLTags"
  , Text
"alwaysMergeEmptyNamespace"
  , Text
"updateFields"
  , Text
"hdrShapeDefaults"
  -- , "footnotePr" -- this can cause problems, see #9522
  -- , "endnotePr"
  , Text
"compat"
  , Text
"docVars"
  , Text
"rsids"
  , Text
"attachedSchema"
  , Text
"themeFontLang"
  , Text
"clrSchemeMapping"
  , Text
"doNotIncludeSubdocsInStats"
  , Text
"doNotAutoCompressPictures"
  , Text
"forceUpgrade"
  , Text
"captions"
  , Text
"readModeInkLockDown"
  , Text
"smartTagType"
  , Text
"shapeDefaults"
  , Text
"doNotEmbedSmartTags"
  , Text
"decimalSymbol"
  , Text
"listSeparator" ]

mkNumbering :: [ListMarker] -> [Element]
mkNumbering :: [ListMarker] -> [Element]
mkNumbering [ListMarker]
lists =
  [Element]
elts [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ (ListMarker -> Int -> Element)
-> [ListMarker] -> [Int] -> [Element]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ListMarker -> Int -> Element
mkNum [ListMarker]
lists [Int
baseListId..(Int
baseListId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ListMarker] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ListMarker]
lists Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
    where elts :: [Element]
elts = (ListMarker -> Element) -> [ListMarker] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ListMarker -> Element
mkAbstractNum ([ListMarker] -> [ListMarker]
forall a. Ord a => [a] -> [a]
nubOrd [ListMarker]
lists)

mkNum :: ListMarker -> Int -> Element
mkNum :: ListMarker -> Int -> Element
mkNum ListMarker
marker Int
numid =
  Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:num" [(Text
"w:numId",Int -> Text
forall a. Show a => a -> Text
tshow Int
numid)]
   ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:abstractNumId" [(Text
"w:val",ListMarker -> Text
listMarkerToId ListMarker
marker)] ()
   Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: case ListMarker
marker of
       ListMarker
NoMarker     -> []
       ListMarker
BulletMarker -> []
       CheckboxMarker Bool
_ -> []
       NumberMarker ListNumberStyle
_ ListNumberDelim
_ Int
start ->
          (Int -> Element) -> [Int] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
lvl -> Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:lvlOverride" [(Text
"w:ilvl",Int -> Text
forall a. Show a => a -> Text
tshow (Int
lvl :: Int))]
              (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:startOverride" [(Text
"w:val",Int -> Text
forall a. Show a => a -> Text
tshow Int
start)] ())
                [Int
0..Int
maxListLevel]

mkAbstractNum :: ListMarker -> Element
mkAbstractNum :: ListMarker -> Element
mkAbstractNum ListMarker
marker =
  Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:abstractNum" [(Text
"w:abstractNumId",ListMarker -> Text
listMarkerToId ListMarker
marker)]
    ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:nsid" [(Text
"w:val", Int -> Char -> Text -> Text
T.justifyRight Int
8 Char
'0' (Text
"A" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListMarker -> Text
listMarkerToId ListMarker
marker))] ()
    Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:multiLevelType" [(Text
"w:val",Text
"multilevel")] ()
    Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (Int -> Element) -> [Int] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (ListMarker -> Int -> Element
mkLvl ListMarker
marker)
      [Int
0..Int
maxListLevel]

mkLvl :: ListMarker -> Int -> Element
mkLvl :: ListMarker -> Int -> Element
mkLvl ListMarker
marker Int
lvl =
  Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:lvl" [(Text
"w:ilvl",Int -> Text
forall a. Show a => a -> Text
tshow Int
lvl)] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
    (case ListMarker
marker of
        NumberMarker{} -> [Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:start" [(Text
"w:val",Text
start)] ()]
        ListMarker
_ -> []) [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
    [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:numFmt" [(Text
"w:val",Text
fmt)] ()
    , Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:lvlText" [(Text
"w:val", Text
lvltxt)] ()
    , Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:lvlJc" [(Text
"w:val",Text
"left")] ()
    , Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pPr" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
        Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:ind" [ (Text
"w:left",Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
step)
                       , (Text
"w:hanging",Int -> Text
forall a. Show a => a -> Text
tshow Int
hang)
                       ] ()
    ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
    [Element] -> (Text -> [Element]) -> Maybe Text -> [Element]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
font ->
                [ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" []
                  [ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rFonts" [ (Text
"w:ascii", Text
font)
                                      , (Text
"w:hAnsi", Text
font)
                                      , (Text
"w:cs", Text
font)
                                      , (Text
"w:hint", Text
"default") ] () ]]) Maybe Text
mbfont
    where (Text
fmt, Text
lvltxt, Maybe Text
mbfont, Text
start) =
            case ListMarker
marker of
                 ListMarker
NoMarker             -> (Text
"bullet",Text
" ", Maybe Text
forall a. Maybe a
Nothing, Text
"1")
                 ListMarker
BulletMarker         -> Int -> (Text, Text, Maybe Text, Text)
forall {t} {a} {b} {a} {d}.
(IsString a, IsString b, IsString a, IsString d, Integral t) =>
t -> (a, b, Maybe a, d)
bulletFor Int
lvl
                 CheckboxMarker Bool
False -> (Text
"bullet",Text
"\9744", Maybe Text
forall a. Maybe a
Nothing, Text
"1")
                 CheckboxMarker Bool
True  -> (Text
"bullet",Text
"\9746", Maybe Text
forall a. Maybe a
Nothing, Text
"1")
                 NumberMarker ListNumberStyle
st ListNumberDelim
de Int
n -> (ListNumberStyle -> Int -> Text
forall {a} {t}.
(IsString a, Integral t) =>
ListNumberStyle -> t -> a
styleFor ListNumberStyle
st Int
lvl
                                         ,ListNumberDelim -> Text -> Text
forall {a}. (Semigroup a, IsString a) => ListNumberDelim -> a -> a
patternFor ListNumberDelim
de (Text
"%" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
                                         ,Maybe Text
forall a. Maybe a
Nothing
                                         ,Int -> Text
forall a. Show a => a -> Text
tshow Int
n)
          step :: Int
step = Int
720
          hang :: Int
          hang :: Int
hang = Int
360
          bulletFor :: t -> (a, b, Maybe a, d)
bulletFor t
0 = (a
"bullet", b
"\xf0b7", a -> Maybe a
forall a. a -> Maybe a
Just a
"Symbol", d
"1") -- filled circle
          bulletFor t
1 = (a
"bullet", b
"o", a -> Maybe a
forall a. a -> Maybe a
Just a
"Courier New", d
"1") -- open o
          bulletFor t
2 = (a
"bullet", b
"\xf0a7", a -> Maybe a
forall a. a -> Maybe a
Just a
"Wingdings", d
"1")  -- closed box
          bulletFor t
x = t -> (a, b, Maybe a, d)
bulletFor (t
x t -> t -> t
forall a. Integral a => a -> a -> a
`mod` t
3)
          styleFor :: ListNumberStyle -> t -> a
styleFor ListNumberStyle
UpperAlpha t
_   = a
"upperLetter"
          styleFor ListNumberStyle
LowerAlpha t
_   = a
"lowerLetter"
          styleFor ListNumberStyle
UpperRoman t
_   = a
"upperRoman"
          styleFor ListNumberStyle
LowerRoman t
_   = a
"lowerRoman"
          styleFor ListNumberStyle
Decimal t
_      = a
"decimal"
          styleFor ListNumberStyle
DefaultStyle t
0 = a
"decimal"
          styleFor ListNumberStyle
DefaultStyle t
1 = a
"lowerLetter"
          styleFor ListNumberStyle
DefaultStyle t
2 = a
"lowerRoman"
          styleFor ListNumberStyle
DefaultStyle t
3 = a
"decimal"
          styleFor ListNumberStyle
DefaultStyle t
4 = a
"lowerLetter"
          styleFor ListNumberStyle
DefaultStyle t
5 = a
"lowerRoman"
          styleFor ListNumberStyle
DefaultStyle t
x = ListNumberStyle -> t -> a
styleFor ListNumberStyle
DefaultStyle (t
x t -> t -> t
forall a. Integral a => a -> a -> a
`mod` t
6)
          styleFor ListNumberStyle
_ t
_            = a
"decimal"
          patternFor :: ListNumberDelim -> a -> a
patternFor ListNumberDelim
OneParen a
s  = a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")"
          patternFor ListNumberDelim
TwoParens a
s = a
"(" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")"
          patternFor ListNumberDelim
_ a
s         = a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"."

-- | 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 :: Maybe Lang -> Element -> Element
mkLangTransformer Maybe Lang
Nothing  = Element -> Element
forall a. a -> a
id
mkLangTransformer (Just Lang
lang) = [QName -> Bool] -> (Element -> Element) -> Element -> Element
modifyAtPath [QName -> Bool]
path Element -> Element
updateLangAttrs
  where
    -- Path is: w:docDefaults / w:rPrDefault / w:rPr / w:lang
    path :: [QName -> Bool]
path = [Text -> QName -> Bool
named Text
"docDefaults", Text -> QName -> Bool
named Text
"rPrDefault", Text -> QName -> Bool
named Text
"rPr", Text -> QName -> Bool
named Text
"lang"]
    named :: Text -> QName -> Bool
named Text
n = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
n) (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName

    updateLangAttrs :: Element -> Element
updateLangAttrs Element
e
      | Lang -> Bool
isEastAsianLang Lang
lang = Element
e{ elAttribs = map (setattr "eastAsia") $ elAttribs e }
      | Lang -> Bool
isBidiLang Lang
lang      = Element
e{ elAttribs = map (setattr "bidi") $ elAttribs e }
      | Bool
otherwise            = Element
e{ elAttribs = map (setattr "val") $ elAttribs e }

    setattr :: Text -> Attr -> Attr
setattr Text
attrname (XML.Attr qn :: QName
qn@(QName Text
s Maybe Text
_ Maybe Text
_) Text
_)
      | Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
attrname  = QName -> Text -> Attr
XML.Attr QName
qn (Lang -> Text
renderLang Lang
lang)
    setattr Text
_ Attr
x        = Attr
x

    isEastAsianLang :: Lang -> Bool
isEastAsianLang Lang{ langLanguage :: Lang -> Text
langLanguage = Text
l } = Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"zh" Bool -> Bool -> Bool
|| Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"ja" Bool -> Bool -> Bool
|| Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"ko"
    isBidiLang :: Lang -> Bool
isBidiLang Lang{ langLanguage :: Lang -> Text
langLanguage = Text
l } = Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"he" Bool -> Bool -> Bool
|| Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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 :: [QName -> Bool] -> (Element -> Element) -> Element -> Element
modifyAtPath [] Element -> Element
f Element
e = Element -> Element
f Element
e
modifyAtPath (QName -> Bool
p:[QName -> Bool]
ps) Element -> Element
f Element
e = Element
e{ elContent = map go (elContent e) }
  where
    go :: Content -> Content
go (Elem Element
el) | QName -> Bool
p (Element -> QName
elName Element
el) = Element -> Content
Elem ([QName -> Bool] -> (Element -> Element) -> Element -> Element
modifyAtPath [QName -> Bool]
ps Element -> Element
f Element
el)
    go Content
c = Content
c

-- | Load reference and distribution archives
loadArchives :: PandocMonad m
             => WriterOptions
             -> m (Archive, Archive, Maybe Text, UTCTime)
loadArchives :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> m (Archive, Archive, Maybe Text, UTCTime)
loadArchives WriterOptions
opts = do
  Maybe Text
username <- Text -> m (Maybe Text)
forall (m :: * -> *). PandocMonad m => Text -> m (Maybe Text)
P.lookupEnv Text
"USERNAME"
  UTCTime
utctime <- m UTCTime
forall (m :: * -> *). PandocMonad m => m UTCTime
P.getTimestamp
  Maybe String
oldUserDataDir <- m (Maybe String)
forall (m :: * -> *). PandocMonad m => m (Maybe String)
P.getUserDataDir
  Maybe String -> m ()
forall (m :: * -> *). PandocMonad m => Maybe String -> m ()
P.setUserDataDir Maybe String
forall a. Maybe a
Nothing
  ByteString
res <- String -> m ByteString
forall (m :: * -> *). PandocMonad m => String -> m ByteString
readDefaultDataFile String
"reference.docx"
  Maybe String -> m ()
forall (m :: * -> *). PandocMonad m => Maybe String -> m ()
P.setUserDataDir Maybe String
oldUserDataDir
  let distArchive :: Archive
distArchive = ByteString -> Archive
toArchive (ByteString -> Archive) -> ByteString -> Archive
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
res
  Archive
refArchive <- case WriterOptions -> Maybe String
writerReferenceDoc WriterOptions
opts of
                   Just String
f  -> ByteString -> Archive
toArchive (ByteString -> Archive)
-> ((ByteString, Maybe Text) -> ByteString)
-> (ByteString, Maybe Text)
-> Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> ((ByteString, Maybe Text) -> ByteString)
-> (ByteString, Maybe Text)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Maybe Text) -> ByteString
forall a b. (a, b) -> a
fst
                                 ((ByteString, Maybe Text) -> Archive)
-> m (ByteString, Maybe Text) -> m Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem (String -> Text
T.pack String
f)
                   Maybe String
Nothing -> ByteString -> Archive
toArchive (ByteString -> Archive)
-> (ByteString -> ByteString) -> ByteString -> Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> Archive) -> m ByteString -> m Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        String -> m ByteString
forall (m :: * -> *). PandocMonad m => String -> m ByteString
readDataFile String
"reference.docx"
  (Archive, Archive, Maybe Text, UTCTime)
-> m (Archive, Archive, Maybe Text, UTCTime)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Archive
refArchive, Archive
distArchive, Maybe Text
username, UTCTime
utctime)

-- | Extract page dimensions from template
extractPageLayout :: PandocMonad m
                  => Archive -> Archive -> m (Maybe Element, Maybe Integer)
extractPageLayout :: forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> m (Maybe Element, Maybe Integer)
extractPageLayout Archive
refArchive Archive
distArchive = do
  Element
parsedDoc <- Archive -> Archive -> String -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> String -> m Element
parseXml Archive
refArchive Archive
distArchive String
"word/document.xml"
  let wname :: (Text -> Bool) -> QName -> Bool
wname Text -> Bool
f QName
qn = QName -> Maybe Text
qPrefix QName
qn Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"w" Bool -> Bool -> Bool
&& Text -> Bool
f (QName -> Text
qName QName
qn)
  let mbsectpr :: Maybe Element
mbsectpr = (QName -> Bool) -> Element -> Maybe Element
filterElementName ((Text -> Bool) -> QName -> Bool
wname (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"sectPr")) Element
parsedDoc

  -- Gets the template size
  let mbpgsz :: Maybe Element
mbpgsz = Maybe Element
mbsectpr Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> Element -> Maybe Element
filterElementName ((Text -> Bool) -> QName -> Bool
wname (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"pgSz"))
  let mbAttrSzWidth :: Maybe Text
mbAttrSzWidth = Maybe Element
mbpgsz Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"w") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) ([Attr] -> Maybe Text)
-> (Element -> [Attr]) -> Element -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs

  let mbpgmar :: Maybe Element
mbpgmar = Maybe Element
mbsectpr Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> Element -> Maybe Element
filterElementName ((Text -> Bool) -> QName -> Bool
wname (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"pgMar"))
  let mbAttrMarLeft :: Maybe Text
mbAttrMarLeft = Maybe Element
mbpgmar Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"left") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) ([Attr] -> Maybe Text)
-> (Element -> [Attr]) -> Element -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs
  let mbAttrMarRight :: Maybe Text
mbAttrMarRight = Maybe Element
mbpgmar Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"right") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) ([Attr] -> Maybe Text)
-> (Element -> [Attr]) -> Element -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs

  -- Get the available area (converting the size and the margins to int and
  -- doing the difference
  let pgContentWidth :: Maybe Integer
pgContentWidth = do
                         Integer
w <- Maybe Text
mbAttrSzWidth Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
                         Integer
r <- Maybe Text
mbAttrMarRight Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
                         Integer
l <- Maybe Text
mbAttrMarLeft Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
                         Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
l

  (Maybe Element, Maybe Integer) -> m (Maybe Element, Maybe Integer)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Element
mbsectpr, Maybe Integer
pgContentWidth)

-- | Parse and augment relationships from reference.docx
extractRelationships :: PandocMonad m
                     => Archive -> Archive
                     -> m ([Element], [Element], [Element], Int)
extractRelationships :: forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> m ([Element], [Element], [Element], Int)
extractRelationships Archive
refArchive Archive
distArchive = do
  let isImageNode :: Element -> Bool
isImageNode Element
e = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"
  let isHeaderNode :: Element -> Bool
isHeaderNode Element
e = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/header"
  let isFooterNode :: Element -> Bool
isFooterNode Element
e = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/footer"
  [Element]
parsedRels <- (Element -> Bool) -> Element -> [Element]
filterElements
                  (\Element
e -> Element -> Bool
isImageNode Element
e Bool -> Bool -> Bool
|| Element -> Bool
isHeaderNode Element
e Bool -> Bool -> Bool
|| Element -> Bool
isFooterNode Element
e)
              (Element -> [Element]) -> m Element -> m [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Archive -> Archive -> String -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> String -> m Element
parseXml Archive
refArchive Archive
distArchive String
"word/_rels/document.xml.rels"
  let getRelId :: Element -> Maybe b
getRelId Element
e =
        case QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e of
          Just Text
ident -> Text -> Text -> Maybe Text
T.stripPrefix Text
"rId" Text
ident Maybe Text -> (Text -> Maybe b) -> Maybe b
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe b
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
          Maybe Text
Nothing -> Maybe b
forall a. Maybe a
Nothing
  let relIds :: [Int]
relIds = (Element -> Maybe Int) -> [Element] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe Int
forall {b}. Read b => Element -> Maybe b
getRelId [Element]
parsedRels
  let maxRelId :: Int
maxRelId = if [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
relIds then Int
0 else [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
relIds

  let headers :: [Element]
headers = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter Element -> Bool
isHeaderNode [Element]
parsedRels
  let footers :: [Element]
footers = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter Element -> Bool
isFooterNode [Element]
parsedRels
  -- word/_rels/document.xml.rels
  let addBaseRel :: (Text, Text) -> (a, [Element]) -> (a, [Element])
addBaseRel (Text
url', Text
target') (a
maxId, [Element]
rels) =
        case [Element
e | Element
e <- [Element]
rels
                , QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Target" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
==
                   Text -> Maybe Text
forall a. a -> Maybe a
Just Text
target'] of
          [] -> (a
maxId a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Relationship"
                            [(Text
"Type",Text
url')
                            ,(Text
"Id",Text
"rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
tshow (a
maxId a -> a -> a
forall a. Num a => a -> a -> a
+ a
1))
                            ,(Text
"Target",Text
target')] () Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
rels)
          [Element]
_ -> (a
maxId, [Element]
rels)

  let (Int
newMaxRelId, [Element]
baserels) = ((Text, Text) -> (Int, [Element]) -> (Int, [Element]))
-> (Int, [Element]) -> [(Text, Text)] -> (Int, [Element])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, Text) -> (Int, [Element]) -> (Int, [Element])
forall {a}.
(Num a, Show a) =>
(Text, Text) -> (a, [Element]) -> (a, [Element])
addBaseRel (Int
maxRelId, [Element]
parsedRels)
                    [(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/numbering",
                      Text
"numbering.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles",
                      Text
"styles.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/settings",
                      Text
"settings.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/webSettings",
                      Text
"webSettings.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/fontTable",
                      Text
"fontTable.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme",
                      Text
"theme/theme1.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/footnotes",
                      Text
"footnotes.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments",
                      Text
"comments.xml")
                    ]

  ([Element], [Element], [Element], Int)
-> m ([Element], [Element], [Element], Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Element]
baserels, [Element]
headers, [Element]
footers, Int
newMaxRelId)

-- | Create footnotes XML entry
mkFootnotesEntry :: Integer -> [Element] -> Entry
mkFootnotesEntry :: Integer -> [Element] -> Entry
mkFootnotesEntry Integer
epochtime [Element]
footnotes =
  let notes :: Element
notes = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:footnotes" [(Text, Text)]
stdAttributes [Element]
footnotes
  in String -> Integer -> ByteString -> Entry
toEntry String
"word/footnotes.xml" Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
notes

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

-- | Create comments XML entry
mkCommentsEntry :: Integer -> [Element] -> Entry
mkCommentsEntry :: Integer -> [Element] -> Entry
mkCommentsEntry Integer
epochtime [Element]
comments =
  String -> Integer -> ByteString -> Entry
toEntry String
"word/comments.xml" Integer
epochtime
    (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml (Element -> ByteString) -> Element -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:comments" [(Text, Text)]
stdAttributes [Element]
comments

-- | Create package-level relationships entry
mkPackageRelsEntry :: Integer -> Entry
mkPackageRelsEntry :: Integer -> Entry
mkPackageRelsEntry Integer
epochtime =
  let rels :: Element
rels = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Relationships"
        [(Text
"xmlns", Text
"http://schemas.openxmlformats.org/package/2006/relationships")]
        ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ([(Text, Text)] -> Element) -> [[(Text, Text)]] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\[(Text, Text)]
attrs -> Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Relationship" [(Text, Text)]
attrs ())
        [ [(Text
"Id",Text
"rId1")
          ,(Text
"Type",Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument")
          ,(Text
"Target",Text
"word/document.xml")]
        , [(Text
"Id",Text
"rId4")
          ,(Text
"Type",Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties")
          ,(Text
"Target",Text
"docProps/app.xml")]
        , [(Text
"Id",Text
"rId3")
          ,(Text
"Type",Text
"http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties")
          ,(Text
"Target",Text
"docProps/core.xml")]
        , [(Text
"Id",Text
"rId5")
          ,(Text
"Type",Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties")
          ,(Text
"Target",Text
"docProps/custom.xml")]
        ]
  in String -> Integer -> ByteString -> Entry
toEntry String
"_rels/.rels" Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
rels

-- | Create content types manifest entry
mkContentTypesEntry :: Integer
                    -> [(String, String, Maybe MimeType, B.ByteString)]  -- imgs
                    -> [Element]  -- headers
                    -> [Element]  -- footers
                    -> Archive    -- refArchive
                    -> Entry
mkContentTypesEntry :: Integer
-> [(String, String, Maybe Text, ByteString)]
-> [Element]
-> [Element]
-> Archive
-> Entry
mkContentTypesEntry Integer
epochtime [(String, String, Maybe Text, ByteString)]
imgs [Element]
headers [Element]
footers Archive
refArchive =
  let mkOverrideNode :: (String, Text) -> Element
mkOverrideNode (String
part', Text
contentType') = Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Override"
           [(Text
"PartName", String -> Text
T.pack String
part')
           ,(Text
"ContentType", Text
contentType')] ()
      mkImageOverride :: (a, String, Maybe Text, d) -> Element
mkImageOverride (a
_, String
imgpath, Maybe Text
mbMimeType, d
_) =
          (String, Text) -> Element
mkOverrideNode (String
"/word/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
imgpath,
                          Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"application/octet-stream" Maybe Text
mbMimeType)
      mkMediaOverride :: String -> Element
mkMediaOverride String
imgpath =
          (String, Text) -> Element
mkOverrideNode (String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
imgpath, String -> Text
getMimeTypeDef String
imgpath)
      overrides :: [Element]
overrides = ((String, Text) -> Element) -> [(String, Text)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String, Text) -> Element
mkOverrideNode (
                  [(String
"/word/webSettings.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.webSettings+xml")
                  ,(String
"/word/numbering.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.numbering+xml")
                  ,(String
"/word/settings.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.settings+xml")
                  ,(String
"/word/theme/theme1.xml",
                    Text
"application/vnd.openxmlformats-officedocument.theme+xml")
                  ,(String
"/word/fontTable.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.fontTable+xml")
                  ,(String
"/docProps/app.xml",
                    Text
"application/vnd.openxmlformats-officedocument.extended-properties+xml")
                  ,(String
"/docProps/core.xml",
                    Text
"application/vnd.openxmlformats-package.core-properties+xml")
                  ,(String
"/docProps/custom.xml",
                    Text
"application/vnd.openxmlformats-officedocument.custom-properties+xml")
                  ,(String
"/word/styles.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.styles+xml")
                  ,(String
"/word/document.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml")
                  ,(String
"/word/comments.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.comments+xml")
                  ,(String
"/word/footnotes.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml")
                  ] [(String, Text)] -> [(String, Text)] -> [(String, Text)]
forall a. [a] -> [a] -> [a]
++
                  (Element -> (String, Text)) -> [Element] -> [(String, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\Element
x -> (String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"/word/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) (Element -> Maybe Text
extractTarget Element
x),
                       Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.header+xml")) [Element]
headers [(String, Text)] -> [(String, Text)] -> [(String, Text)]
forall a. [a] -> [a] -> [a]
++
                  (Element -> (String, Text)) -> [Element] -> [(String, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\Element
x -> (String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"/word/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) (Element -> Maybe Text
extractTarget Element
x),
                       Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml")) [Element]
footers) [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                    ((String, String, Maybe Text, ByteString) -> Element)
-> [(String, String, Maybe Text, ByteString)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, Maybe Text, ByteString) -> Element
forall {a} {d}. (a, String, Maybe Text, d) -> Element
mkImageOverride [(String, String, Maybe Text, ByteString)]
imgs [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                    [ String -> Element
mkMediaOverride (Entry -> String
eRelativePath Entry
e)
                        | Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
                        , String
"word/media/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> String
eRelativePath Entry
e
                        , Bool -> Bool
not (String
"/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Entry -> String
eRelativePath Entry
e) ]
      mkDefaultNode :: (Text, Text) -> Element
mkDefaultNode (Text
ext, Text
mt) =
        Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Default" [(Text
"Extension",Text
ext),(Text
"ContentType",Text
mt)] ()
      defaultnodes :: [Element]
defaultnodes = ((Text, Text) -> Element) -> [(Text, Text)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Element
mkDefaultNode
        [(Text
"xml", Text
"application/xml"),
         (Text
"rels", Text
"application/vnd.openxmlformats-package.relationships+xml"),
         (Text
"odttf",
           Text
"application/vnd.openxmlformats-officedocument.obfuscatedFont")]
      contentTypesDoc :: Element
contentTypesDoc = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Types"
        [(Text
"xmlns",Text
"http://schemas.openxmlformats.org/package/2006/content-types")]
        ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [Element]
defaultnodes [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
overrides
  in String -> Integer -> ByteString -> Entry
toEntry String
"[Content_Types].xml" Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
contentTypesDoc

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

-- | Create styles entry with dynamic additions
mkStylesEntry :: Integer -> Element -> StyleMaps -> WriterState -> WriterOptions -> Entry
mkStylesEntry :: Integer
-> Element -> StyleMaps -> WriterState -> WriterOptions -> Entry
mkStylesEntry Integer
epochtime Element
styledoc StyleMaps
styleMaps WriterState
st WriterOptions
opts =
  let stylepath :: String
stylepath = String
"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 :: [ParaStyleName]
newDynamicParaProps = (ParaStyleName -> Bool) -> [ParaStyleName] -> [ParaStyleName]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (\ParaStyleName
sty -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ParaStyleName -> Map ParaStyleName ParStyle -> Bool
forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName ParaStyleName
sty (Map ParaStyleName ParStyle -> Bool)
-> Map ParaStyleName ParStyle -> Bool
forall a b. (a -> b) -> a -> b
$ StyleMaps -> Map ParaStyleName ParStyle
smParaStyle StyleMaps
styleMaps)
        (Set ParaStyleName -> [ParaStyleName]
forall a. Set a -> [a]
Set.toList (Set ParaStyleName -> [ParaStyleName])
-> Set ParaStyleName -> [ParaStyleName]
forall a b. (a -> b) -> a -> b
$ WriterState -> Set ParaStyleName
stDynamicParaProps WriterState
st)

      newDynamicTextProps :: [CharStyleName]
newDynamicTextProps = (CharStyleName -> Bool) -> [CharStyleName] -> [CharStyleName]
forall a. (a -> Bool) -> [a] -> [a]
filter
        (\CharStyleName
sty -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CharStyleName -> Map CharStyleName CharStyle -> Bool
forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName CharStyleName
sty (Map CharStyleName CharStyle -> Bool)
-> Map CharStyleName CharStyle -> Bool
forall a b. (a -> b) -> a -> b
$ StyleMaps -> Map CharStyleName CharStyle
smCharStyle StyleMaps
styleMaps)
        (Set CharStyleName -> [CharStyleName]
forall a. Set a -> [a]
Set.toList (Set CharStyleName -> [CharStyleName])
-> Set CharStyleName -> [CharStyleName]
forall a b. (a -> b) -> a -> b
$ WriterState -> Set CharStyleName
stDynamicTextProps WriterState
st)

      newstyles :: [Element]
newstyles = (ParaStyleName -> Element) -> [ParaStyleName] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ParaStyleName -> Element
newParaPropToOpenXml [ParaStyleName]
newDynamicParaProps [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                  (CharStyleName -> Element) -> [CharStyleName] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map CharStyleName -> Element
newTextPropToOpenXml [CharStyleName]
newDynamicTextProps [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                  (case WriterOptions -> HighlightMethod
writerHighlightMethod WriterOptions
opts of
                     Skylighting Style
sty -> StyleMaps -> Style -> [Element]
styleToOpenXml StyleMaps
styleMaps Style
sty
                     HighlightMethod
DefaultHighlighting -> StyleMaps -> Style -> [Element]
styleToOpenXml StyleMaps
styleMaps
                                              Style
defaultStyle
                     HighlightMethod
_ -> [])
      styledoc' :: Element
styledoc' = Element
styledoc{ elContent = elContent styledoc ++
                                           map Elem newstyles }
  in String -> Integer -> ByteString -> Entry
toEntry String
stylepath Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
styledoc'

-- | Create core document properties entry
mkCorePropsEntry :: Integer -> UTCTime -> Meta -> Entry
mkCorePropsEntry :: Integer -> UTCTime -> Meta -> Entry
mkCorePropsEntry Integer
epochtime UTCTime
utctime Meta
meta =
  let keywords :: [Text]
keywords = case Text -> Meta -> Maybe MetaValue
lookupMeta Text
"keywords" Meta
meta of
                       Just (MetaList [MetaValue]
xs) -> (MetaValue -> Text) -> [MetaValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map MetaValue -> Text
forall a. Walkable Inline a => a -> Text
stringify [MetaValue]
xs
                       Maybe MetaValue
_                  -> []
      docPropsPath :: String
docPropsPath = String
"docProps/core.xml"
      extraCoreProps :: [Text]
extraCoreProps = [Text
"subject",Text
"lang",Text
"category",Text
"description"]
      extraCorePropsMap :: Map Text Text
extraCorePropsMap = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
extraCoreProps
                       [Text
"dc:subject",Text
"dc:language",Text
"cp:category",Text
"dc:description"]
      lookupMetaString' :: Text -> Meta -> Text
      lookupMetaString' :: Text -> Meta -> Text
lookupMetaString' Text
key' Meta
meta' =
        case Text
key' of
             Text
"description" -> Text -> [Text] -> Text
T.intercalate Text
"_x000d_\n"
                                ((Block -> Text) -> [Block] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Text
forall a. Walkable Inline a => a -> Text
stringify ([Block] -> [Text]) -> [Block] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Meta -> [Block]
lookupMetaBlocks Text
"description" Meta
meta')
             Text
key''         -> Text -> Meta -> Text
lookupMetaString Text
key'' Meta
meta'

      docProps :: Element
docProps = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"cp:coreProperties"
          [(Text
"xmlns:cp",Text
"http://schemas.openxmlformats.org/package/2006/metadata/core-properties")
          ,(Text
"xmlns:dc",Text
"http://purl.org/dc/elements/1.1/")
          ,(Text
"xmlns:dcterms",Text
"http://purl.org/dc/terms/")
          ,(Text
"xmlns:dcmitype",Text
"http://purl.org/dc/dcmitype/")
          ,(Text
"xmlns:xsi",Text
"http://www.w3.org/2001/XMLSchema-instance")]
          ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Text -> Element
mktnode Text
"dc:title" [] ([Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify ([Inline] -> Text) -> [Inline] -> Text
forall a b. (a -> b) -> a -> b
$ Meta -> [Inline]
docTitle Meta
meta)
          Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Text -> [(Text, Text)] -> Text -> Element
mktnode Text
"dc:creator" [] (Text -> [Text] -> Text
T.intercalate Text
"; " (([Inline] -> Text) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify ([[Inline]] -> [Text]) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> a -> b
$ Meta -> [[Inline]]
docAuthors Meta
meta))
          Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [ Text -> [(Text, Text)] -> Text -> Element
mktnode (Text -> Text -> Map Text Text -> Text
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Text
"" Text
k Map Text Text
extraCorePropsMap) [] (Text -> Meta -> Text
lookupMetaString' Text
k Meta
meta)
            | Text
k <- Map Text MetaValue -> [Text]
forall k a. Map k a -> [k]
M.keys (Meta -> Map Text MetaValue
unMeta Meta
meta), Text
k Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
extraCoreProps]
          [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ Text -> [(Text, Text)] -> Text -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"cp:keywords" [] (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
keywords)
          Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (\Text
x -> [ Text -> [(Text, Text)] -> Text -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"dcterms:created" [(Text
"xsi:type",Text
"dcterms:W3CDTF")] Text
x
                   , Text -> [(Text, Text)] -> Text -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"dcterms:modified" [(Text
"xsi:type",Text
"dcterms:W3CDTF")] Text
x
                   ]) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%FT%XZ" UTCTime
utctime)
  in String -> Integer -> ByteString -> Entry
toEntry String
docPropsPath Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
docProps

-- | Create custom document properties entry
mkCustomPropsEntry :: Integer -> Meta -> Entry
mkCustomPropsEntry :: Integer -> Meta -> Entry
mkCustomPropsEntry Integer
epochtime Meta
meta =
  let extraCoreProps :: [Text]
extraCoreProps = [Text
"subject",Text
"lang",Text
"category",Text
"description"]
      customProperties :: [(Text, Text)]
      customProperties :: [(Text, Text)]
customProperties = [ (Text
k, Text -> Meta -> Text
lookupMetaString Text
k Meta
meta)
                         | Text
k <- Map Text MetaValue -> [Text]
forall k a. Map k a -> [k]
M.keys (Meta -> Map Text MetaValue
unMeta Meta
meta)
                         , Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Text
"title", Text
"author", Text
"keywords"]
                                       [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
extraCoreProps)]
      mkCustomProp :: (Text, t) -> a -> Element
mkCustomProp (Text
k, t
v) a
pid = Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"property"
         [(Text
"fmtid",Text
"{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
         ,(Text
"pid", a -> Text
forall a. Show a => a -> Text
tshow a
pid)
         ,(Text
"name", Text
k)] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> t -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"vt:lpwstr" [] t
v
      customPropsPath :: String
customPropsPath = String
"docProps/custom.xml"
      customProps :: Element
customProps = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Properties"
          [(Text
"xmlns",Text
"http://schemas.openxmlformats.org/officeDocument/2006/custom-properties")
          ,(Text
"xmlns:vt",Text
"http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")
          ] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Int -> Element)
-> [(Text, Text)] -> [Int] -> [Element]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text, Text) -> Int -> Element
forall {t} {a}. (Node t, Show a) => (Text, t) -> a -> Element
mkCustomProp [(Text, Text)]
customProperties [(Int
2 :: Int)..]
  in String -> Integer -> ByteString -> Entry
toEntry String
customPropsPath Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
customProps

-- | Create numbering entry
mkNumberingEntry :: PandocMonad m
                 => Archive -> Archive -> Integer -> [ListMarker] -> m Entry
mkNumberingEntry :: forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> Integer -> [ListMarker] -> m Entry
mkNumberingEntry Archive
refArchive Archive
distArchive Integer
epochtime [ListMarker]
lists = do
  let numpath :: String
numpath = String
"word/numbering.xml"
  Element
numbering <- Archive -> Archive -> String -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> String -> m Element
parseXml Archive
refArchive Archive
distArchive String
numpath
  let newNumElts :: [Element]
newNumElts = [ListMarker] -> [Element]
mkNumbering [ListMarker]
lists
  let pandocAdded :: Element -> Bool
pandocAdded Element
e =
       case (QName -> Bool) -> Element -> Maybe Text
findAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"abstractNumId") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) Element
e Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead of
         Just Int
numid -> Int
numid Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (Int
990 :: Int)
         Maybe Int
Nothing    ->
           case (QName -> Bool) -> Element -> Maybe Text
findAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"numId") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) Element
e Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead of
             Just Int
numid -> Int
numid Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (Int
1000 :: Int)
             Maybe Int
Nothing    -> Bool
False
  let oldElts :: [Element]
oldElts = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Element -> Bool) -> Element -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Bool
pandocAdded) ([Element] -> [Element]) -> [Element] -> [Element]
forall a b. (a -> b) -> a -> b
$ [Content] -> [Element]
onlyElems (Element -> [Content]
elContent Element
numbering)
  let allElts :: [Element]
allElts = [Element]
oldElts [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
newNumElts
  Entry -> m Entry
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> m Entry) -> Entry -> m Entry
forall a b. (a -> b) -> a -> b
$ String -> Integer -> ByteString -> Entry
toEntry String
numpath Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
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 :: forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> [Element] -> [Element] -> m [Entry]
collectReferenceEntries Archive
refArchive Archive
distArchive [Element]
headers [Element]
footers = do
  let entryFromArchive :: Archive -> String -> m Entry
entryFromArchive Archive
arch String
path =
         m Entry -> (Entry -> m Entry) -> Maybe Entry -> m Entry
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PandocError -> m Entry
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Entry) -> PandocError -> m Entry
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError
                           (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" missing in reference docx")
               Entry -> m Entry
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
               (String -> Archive -> Maybe Entry
findEntryByPath String
path Archive
arch Maybe Entry -> Maybe Entry -> Maybe Entry
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Archive -> Maybe Entry
findEntryByPath String
path Archive
distArchive)
  Entry
docPropsAppEntry <- Archive -> String -> m Entry
forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> String -> m Entry
entryFromArchive Archive
refArchive String
"docProps/app.xml"
  Entry
themeEntry <- Archive -> String -> m Entry
forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> String -> m Entry
entryFromArchive Archive
refArchive String
"word/theme/theme1.xml"
  Entry
fontTableEntry <- Archive -> String -> m Entry
forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> String -> m Entry
entryFromArchive Archive
refArchive String
"word/fontTable.xml"
  let fontTableRelsEntries :: [Entry]
fontTableRelsEntries = Maybe Entry -> [Entry]
forall a. Maybe a -> [a]
maybeToList (Maybe Entry -> [Entry]) -> Maybe Entry -> [Entry]
forall a b. (a -> b) -> a -> b
$
       String -> Archive -> Maybe Entry
findEntryByPath String
"word/_rels/fontTable.xml.rels" Archive
refArchive
  let fontEntries :: [Entry]
fontEntries = [Entry
entry | Entry
entry <- Archive -> [Entry]
zEntries Archive
refArchive
                           , String
"word/fonts/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Entry -> String
eRelativePath Entry
entry)]
  Entry
webSettingsEntry <- Archive -> String -> m Entry
forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> String -> m Entry
entryFromArchive Archive
refArchive String
"word/webSettings.xml"
  [Entry]
headerFooterEntries <- (String -> m Entry) -> [String] -> m [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Archive -> String -> m Entry
forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> String -> m Entry
entryFromArchive Archive
refArchive (String -> m Entry) -> (String -> String) -> String -> m Entry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"word/" String -> String -> String
forall a. [a] -> [a] -> [a]
++)) ([String] -> m [Entry]) -> [String] -> m [Entry]
forall a b. (a -> b) -> a -> b
$
                         (Element -> Maybe String) -> [Element] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Text -> String) -> Maybe Text -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack (Maybe Text -> Maybe String)
-> (Element -> Maybe Text) -> Element -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Maybe Text
extractTarget)
                         ([Element]
headers [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
footers)
  let miscRelEntries :: [Entry]
miscRelEntries = [ Entry
e | Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
                       , String
"word/_rels/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> String
eRelativePath Entry
e
                       , String
".xml.rels" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Entry -> String
eRelativePath Entry
e
                       , Entry -> String
eRelativePath Entry
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"word/_rels/document.xml.rels"
                       , Entry -> String
eRelativePath Entry
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"word/_rels/footnotes.xml.rels" ]
  let otherMediaEntries :: [Entry]
otherMediaEntries = [ Entry
e | Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
                          , String
"word/media/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> String
eRelativePath Entry
e ]
  [Entry] -> m [Entry]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Entry] -> m [Entry]) -> [Entry] -> m [Entry]
forall a b. (a -> b) -> a -> b
$ Entry
docPropsAppEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
themeEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
fontTableEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
webSettingsEntry
         Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: [Entry]
fontTableRelsEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
fontEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
headerFooterEntries
         [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
miscRelEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
otherMediaEntries