{-# LANGUAGE PatternGuards       #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeApplications    #-}
{- |
   Module      : Text.Pandoc.Writers.Docx
   Copyright   : Copyright (C) 2012-2023 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.Applicative ((<|>))
import Control.Monad (MonadPlus(mplus), unless, when)
import Control.Monad.Except (catchError, throwError)
import Control.Monad.Reader
    ( asks, MonadReader(local), MonadTrans(lift), ReaderT(runReaderT) )
import Control.Monad.State.Strict ( StateT(runStateT), gets, modify )
import qualified Data.ByteString.Lazy as BL
import Data.Containers.ListUtils (nubOrd)
import Data.Char (isSpace, isLetter)
import Data.List (intercalate, isPrefixOf, isSuffixOf)
import Data.String (fromString)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList, isJust)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import Data.Time.Clock.POSIX
import Data.Digest.Pure.SHA (sha1, showDigest)
import Skylighting
import Text.Pandoc.Class (PandocMonad, report, toLang, getMediaBag)
import Text.Pandoc.Translations (Term(Abstract), translateTerm)
import Text.Pandoc.MediaBag (lookupMedia, MediaItem(..))
import qualified Text.Pandoc.Translations as Term
import qualified Text.Pandoc.Class.PandocMonad as P
import Text.Pandoc.Data (readDataFile, readDefaultDataFile)
import Data.Time
import Text.Pandoc.UTF8 (fromTextLazy)
import Text.Pandoc.Definition
import Text.Pandoc.Generic
import Text.Pandoc.Highlighting (highlight)
import Text.Pandoc.Error
import Text.Pandoc.ImageSize
import Text.Pandoc.Logging
import Text.Pandoc.MIME (extensionFromMimeType, getMimeType, getMimeTypeDef)
import Text.Pandoc.Options
import Text.Pandoc.Writers.Docx.StyleMap
import Text.Pandoc.Writers.Docx.Table as Table
import Text.Pandoc.Writers.Docx.Types
import Text.Pandoc.Shared
import Text.Pandoc.Walk
import qualified Text.Pandoc.Writers.GridTable as Grid
import Text.Pandoc.Writers.Math
import Text.Pandoc.Writers.Shared
import Text.TeXMath
import Text.Pandoc.Writers.OOXML
import Text.Pandoc.XML.Light as XML
import Data.Generics (mkT, everywhere)
import Text.Collate.Lang (renderLang, Lang(..))

squashProps :: EnvProps -> [Element]
squashProps :: EnvProps -> [Element]
squashProps (EnvProps Maybe Element
Nothing [Element]
es) = [Element]
es
squashProps (EnvProps (Just Element
e) [Element]
es) = Element
e forall a. a -> [a] -> [a]
: [Element]
es

renumIdMap :: Int -> [Element] -> M.Map Text Text
renumIdMap :: Int -> [Element] -> Map Text Text
renumIdMap Int
_ [] = forall k a. Map k a
M.empty
renumIdMap Int
n (Element
e:[Element]
es)
  | Just Text
oldId <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Id" forall a. Maybe a
Nothing forall a. Maybe a
Nothing) Element
e =
      forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
oldId (Text
"rId" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
n) (Int -> [Element] -> Map Text Text
renumIdMap (Int
nforall a. Num a => a -> a -> a
+Int
1) [Element]
es)
  | Bool
otherwise = Int -> [Element] -> Map Text Text
renumIdMap Int
n [Element]
es

replaceAttr :: (QName -> Bool) -> Text -> [XML.Attr] -> [XML.Attr]
replaceAttr :: (QName -> Bool) -> Text -> [Attr] -> [Attr]
replaceAttr QName -> Bool
f Text
val = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$
    \Attr
a -> if QName -> Bool
f (Attr -> QName
attrKey Attr
a) then QName -> Text -> Attr
XML.Attr (Attr -> QName
attrKey Attr
a) Text
val else Attr
a

renumId :: (QName -> Bool) -> M.Map Text Text -> Element -> Element
renumId :: (QName -> Bool) -> Map Text Text -> Element -> Element
renumId QName -> Bool
f Map Text Text
renumMap Element
e
  | Just Text
oldId <- (QName -> Bool) -> Element -> Maybe Text
findAttrBy QName -> Bool
f Element
e
  , Just Text
newId <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
oldId Map Text Text
renumMap =
    let attrs' :: [Attr]
attrs' = (QName -> Bool) -> Text -> [Attr] -> [Attr]
replaceAttr QName -> Bool
f Text
newId (Element -> [Attr]
elAttribs Element
e)
    in
     Element
e { elAttribs :: [Attr]
elAttribs = [Attr]
attrs' }
  | Bool
otherwise = Element
e

renumIds :: (QName -> Bool) -> M.Map Text Text -> [Element] -> [Element]
renumIds :: (QName -> Bool) -> Map Text Text -> [Element] -> [Element]
renumIds QName -> Bool
f Map Text Text
renumMap = forall a b. (a -> b) -> [a] -> [b]
map ((QName -> Bool) -> Map Text Text -> Element -> Element
renumId QName -> Bool
f Map Text Text
renumMap)

-- | Certain characters are invalid in XML even if escaped.
-- See #1992
stripInvalidChars :: Text -> Text
stripInvalidChars :: Text -> Text
stripInvalidChars = (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
isValidChar

-- | See XML reference
isValidChar :: Char -> Bool
isValidChar :: Char -> Bool
isValidChar Char
'\t' = Bool
True
isValidChar Char
'\n' = Bool
True
isValidChar Char
'\r' = Bool
True
isValidChar Char
'\xFFFE' = Bool
False
isValidChar Char
'\xFFFF' = Bool
False
isValidChar Char
c = (Char
' ' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\xD7FF') Bool -> Bool -> Bool
|| (Char
'\xE000' forall a. Ord a => a -> a -> Bool
<= Char
c)

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
  let Pandoc Meta
meta [Block]
blocks = forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
fixDisplayMath Pandoc
doc
  forall (m :: * -> *). PandocMonad m => Meta -> m ()
setupTranslations Meta
meta
  let blocks' :: [Block]
blocks' = Bool -> Maybe Int -> [Block] -> [Block]
makeSections Bool
True forall a. Maybe a
Nothing [Block]
blocks
  let doc' :: Pandoc
doc' = Meta -> [Block] -> Pandoc
Pandoc Meta
meta [Block]
blocks'

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

  Element
parsedDoc <- forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive FilePath
"word/document.xml"
  let wname :: (Text -> Bool) -> QName -> Bool
wname Text -> Bool
f QName
qn = QName -> Maybe Text
qPrefix QName
qn forall a. Eq a => a -> a -> Bool
== 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 (forall a. Eq a => a -> a -> Bool
==Text
"sectPr")) Element
parsedDoc

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

  let mbpgmar :: Maybe Element
mbpgmar = Maybe Element
mbsectpr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> Element -> Maybe Element
filterElementName ((Text -> Bool) -> QName -> Bool
wname (forall a. Eq a => a -> a -> Bool
==Text
"pgMar"))
  let mbAttrMarLeft :: Maybe Text
mbAttrMarLeft = Maybe Element
mbpgmar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((forall a. Eq a => a -> a -> Bool
==Text
"left") forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs
  let mbAttrMarRight :: Maybe Text
mbAttrMarRight = Maybe Element
mbpgmar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((forall a. Eq a => a -> a -> Bool
==Text
"right") forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
                         Integer
r <- Maybe Text
mbAttrMarRight forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
                         Integer
l <- Maybe Text
mbAttrMarLeft forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
                         forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer
w forall a. Num a => a -> a -> a
- Integer
r forall a. Num a => a -> a -> a
- Integer
l

  -- styles
  Maybe Lang
mblang <- forall (m :: * -> *). PandocMonad m => Maybe Text -> m (Maybe Lang)
toLang forall a b. (a -> b) -> a -> b
$ WriterOptions -> Meta -> Maybe Text
getLang WriterOptions
opts Meta
meta
  -- TODO FIXME avoid this generic traversal!
  -- lang is in w:docDefaults /  w:rPr  /  w:lang
  let addLang :: Element -> Element
      addLang :: Element -> Element
addLang = case Maybe Lang
mblang of
                  Maybe Lang
Nothing -> forall a. a -> a
id
                  Just Lang
l  -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (Lang -> Element -> Element
go Lang
l))
        where
          go :: Lang -> Element -> Element
          go :: Lang -> Element -> Element
go Lang
lang Element
e'
           | QName -> Text
qName (Element -> QName
elName Element
e') forall a. Eq a => a -> a -> Bool
== Text
"lang"
             = if Lang -> Bool
isEastAsianLang Lang
lang
                  then Element
e'{ elAttribs :: [Attr]
elAttribs =
                             forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Attr -> Attr
setattr Text
"eastAsia" (Lang -> Text
renderLang Lang
lang)) forall a b. (a -> b) -> a -> b
$
                             Element -> [Attr]
elAttribs Element
e' }
                  else
                    if Lang -> Bool
isBidiLang Lang
lang
                       then Element
e'{ elAttribs :: [Attr]
elAttribs =
                                 forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Attr -> Attr
setattr Text
"bidi" (Lang -> Text
renderLang Lang
lang)) forall a b. (a -> b) -> a -> b
$
                                 Element -> [Attr]
elAttribs Element
e' }
                       else Element
e'{ elAttribs :: [Attr]
elAttribs =
                                 forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Attr -> Attr
setattr Text
"val" (Lang -> Text
renderLang Lang
lang)) forall a b. (a -> b) -> a -> b
$
                                 Element -> [Attr]
elAttribs Element
e' }
           | Bool
otherwise = Element
e'

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

          isEastAsianLang :: Lang -> Bool
isEastAsianLang Lang{ langLanguage :: Lang -> Text
langLanguage = Text
lang } =
             Text
lang forall a. Eq a => a -> a -> Bool
== Text
"zh" Bool -> Bool -> Bool
|| Text
lang forall a. Eq a => a -> a -> Bool
== Text
"jp" Bool -> Bool -> Bool
|| Text
lang forall a. Eq a => a -> a -> Bool
== Text
"ko"
          isBidiLang :: Lang -> Bool
isBidiLang Lang{ langLanguage :: Lang -> Text
langLanguage = Text
lang } =
             Text
lang forall a. Eq a => a -> a -> Bool
== Text
"he" Bool -> Bool -> Bool
|| Text
lang forall a. Eq a => a -> a -> Bool
== Text
"ar"

  let stylepath :: FilePath
stylepath = FilePath
"word/styles.xml"
  Element
styledoc <- Element -> Element
addLang forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive FilePath
stylepath

  -- parse styledoc for heading styles
  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 initialSt :: WriterState
initialSt = WriterState
defaultWriterState {
          stStyleMaps :: StyleMaps
stStyleMaps  = StyleMaps
styleMaps
        , stTocTitle :: [Inline]
stTocTitle   = [Inline]
tocTitle
        , stCurId :: Int
stCurId      = Int
20
        }

  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 :: Bool
envRTL = Bool
isRTLmeta
        , envChangesAuthor :: Text
envChangesAuthor = forall a. a -> Maybe a -> a
fromMaybe Text
"unknown" Maybe Text
username
        , envChangesDate :: Text
envChangesDate   = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%FT%XZ" UTCTime
utctime
        , envPrintWidth :: Integer
envPrintWidth = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
420 (forall a. Integral a => a -> a -> a
`quot` Integer
20) Maybe Integer
pgContentWidth
        }


  (([Content]
contents, [Element]
footnotes, [Element]
comments), WriterState
st) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
                         (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
                          (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> WS m ([Content], [Element], [Element])
writeOpenXML WriterOptions
opts{writerWrapText :: WrapOption
writerWrapText = WrapOption
WrapNone} Pandoc
doc')
                          WriterEnv
env)
                         WriterState
initialSt
  let epochtime :: Integer
epochtime = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
utctime
  let imgs :: [(FilePath, FilePath, Maybe Text, ByteString)]
imgs = forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ WriterState
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages WriterState
st

  -- create entries for images in word/media/...
  let toImageEntry :: (a, FilePath, c, ByteString) -> Entry
toImageEntry (a
_,FilePath
path,c
_,ByteString
img) = FilePath -> Integer -> ByteString -> Entry
toEntry (FilePath
"word/" forall a. [a] -> [a] -> [a]
++ FilePath
path) Integer
epochtime forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toLazy ByteString
img
  let imageEntries :: [Entry]
imageEntries = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {c}. (a, FilePath, c, ByteString) -> Entry
toImageEntry [(FilePath, FilePath, Maybe Text, ByteString)]
imgs

  let 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")]


  Element
parsedRels <- forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive FilePath
"word/_rels/document.xml.rels"
  let isHeaderNode :: Element -> Bool
isHeaderNode Element
e = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Type" forall a. Maybe a
Nothing forall a. Maybe a
Nothing) Element
e forall a. Eq a => a -> a -> Bool
== 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" forall a. Maybe a
Nothing forall a. Maybe a
Nothing) Element
e forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/footer"
  let headers :: [Element]
headers = (Element -> Bool) -> Element -> [Element]
filterElements Element -> Bool
isHeaderNode Element
parsedRels
  let footers :: [Element]
footers = (Element -> Bool) -> Element -> [Element]
filterElements Element -> Bool
isFooterNode Element
parsedRels

  let extractTarget :: Element -> Maybe Text
extractTarget = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Target" forall a. Maybe a
Nothing forall a. Maybe a
Nothing)

  -- we create [Content_Types].xml and word/_rels/document.xml.rels
  -- from scratch rather than reading from reference.docx,
  -- because Word sometimes changes these files when a reference.docx is modified,
  -- e.g. deleting the reference to footnotes.xml or removing default entries
  -- for image content types.

  -- [Content_Types].xml
  let mkOverrideNode :: (FilePath, Text) -> Element
mkOverrideNode (FilePath
part', Text
contentType') = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Override"
               [(Text
"PartName", FilePath -> Text
T.pack FilePath
part')
               ,(Text
"ContentType", Text
contentType')] ()
  let mkImageOverride :: (a, FilePath, Maybe Text, d) -> Element
mkImageOverride (a
_, FilePath
imgpath, Maybe Text
mbMimeType, d
_) =
          (FilePath, Text) -> Element
mkOverrideNode (FilePath
"/word/" forall a. Semigroup a => a -> a -> a
<> FilePath
imgpath,
                          forall a. a -> Maybe a -> a
fromMaybe Text
"application/octet-stream" Maybe Text
mbMimeType)
  let mkMediaOverride :: FilePath -> Element
mkMediaOverride FilePath
imgpath =
          (FilePath, Text) -> Element
mkOverrideNode (FilePath
"/" forall a. Semigroup a => a -> a -> a
<> FilePath
imgpath, FilePath -> Text
getMimeTypeDef FilePath
imgpath)
  let overrides :: [Element]
overrides = forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Text) -> Element
mkOverrideNode (
                  [(FilePath
"/word/webSettings.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.webSettings+xml")
                  ,(FilePath
"/word/numbering.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.numbering+xml")
                  ,(FilePath
"/word/settings.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.settings+xml")
                  ,(FilePath
"/word/theme/theme1.xml",
                    Text
"application/vnd.openxmlformats-officedocument.theme+xml")
                  ,(FilePath
"/word/fontTable.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.fontTable+xml")
                  ,(FilePath
"/docProps/app.xml",
                    Text
"application/vnd.openxmlformats-officedocument.extended-properties+xml")
                  ,(FilePath
"/docProps/core.xml",
                    Text
"application/vnd.openxmlformats-package.core-properties+xml")
                  ,(FilePath
"/docProps/custom.xml",
                    Text
"application/vnd.openxmlformats-officedocument.custom-properties+xml")
                  ,(FilePath
"/word/styles.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.styles+xml")
                  ,(FilePath
"/word/document.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml")
                  ,(FilePath
"/word/comments.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.comments+xml")
                  ,(FilePath
"/word/footnotes.xml",
                    Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml")
                  ] forall a. [a] -> [a] -> [a]
++
                  forall a b. (a -> b) -> [a] -> [b]
map (\Element
x -> (forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"/word/" forall a. Semigroup a => a -> a -> a
<>)) (Element -> Maybe Text
extractTarget Element
x),
                       Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.header+xml")) [Element]
headers forall a. [a] -> [a] -> [a]
++
                  forall a b. (a -> b) -> [a] -> [b]
map (\Element
x -> (forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"/word/" forall a. Semigroup a => a -> a -> a
<>)) (Element -> Maybe Text
extractTarget Element
x),
                       Text
"application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml")) [Element]
footers) forall a. [a] -> [a] -> [a]
++
                    forall a b. (a -> b) -> [a] -> [b]
map forall {a} {d}. (a, FilePath, Maybe Text, d) -> Element
mkImageOverride [(FilePath, FilePath, Maybe Text, ByteString)]
imgs forall a. [a] -> [a] -> [a]
++
                    [ FilePath -> Element
mkMediaOverride (Entry -> FilePath
eRelativePath Entry
e)
                        | Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
                        , FilePath
"word/media/" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> FilePath
eRelativePath Entry
e ]

  let mkDefaultNode :: (Text, Text) -> Element
mkDefaultNode (Text
ext, Text
mt) =
        forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Default" [(Text
"Extension",Text
ext),(Text
"ContentType",Text
mt)] ()
  let defaultnodes :: [Element]
defaultnodes = 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")]
  let contentTypesDoc :: Element
contentTypesDoc = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Types" [(Text
"xmlns",Text
"http://schemas.openxmlformats.org/package/2006/content-types")] forall a b. (a -> b) -> a -> b
$ [Element]
defaultnodes forall a. [a] -> [a] -> [a]
++ [Element]
overrides
  let contentTypesEntry :: Entry
contentTypesEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
"[Content_Types].xml" Integer
epochtime
        forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
contentTypesDoc

  -- word/_rels/document.xml.rels
  let toBaseRel :: (Text, Text, Text) -> Element
toBaseRel (Text
url', Text
id', Text
target') = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Relationship"
                                          [(Text
"Type",Text
url')
                                          ,(Text
"Id",Text
id')
                                          ,(Text
"Target",Text
target')] ()
  let baserels' :: [Element]
baserels' = forall a b. (a -> b) -> [a] -> [b]
map (Text, Text, Text) -> Element
toBaseRel
                    [(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/numbering",
                      Text
"rId1",
                      Text
"numbering.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles",
                      Text
"rId2",
                      Text
"styles.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/settings",
                      Text
"rId3",
                      Text
"settings.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/webSettings",
                      Text
"rId4",
                      Text
"webSettings.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/fontTable",
                      Text
"rId5",
                      Text
"fontTable.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme",
                      Text
"rId6",
                      Text
"theme/theme1.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/footnotes",
                      Text
"rId7",
                      Text
"footnotes.xml")
                    ,(Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments",
                      Text
"rId8",
                      Text
"comments.xml")
                    ]

  let idMap :: Map Text Text
idMap = Int -> [Element] -> Map Text Text
renumIdMap (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
baserels' forall a. Num a => a -> a -> a
+ Int
1) ([Element]
headers forall a. [a] -> [a] -> [a]
++ [Element]
footers)
  let renumHeaders :: [Element]
renumHeaders = (QName -> Bool) -> Map Text Text -> [Element] -> [Element]
renumIds (\QName
q -> QName -> Text
qName QName
q forall a. Eq a => a -> a -> Bool
== Text
"Id") Map Text Text
idMap [Element]
headers
  let renumFooters :: [Element]
renumFooters = (QName -> Bool) -> Map Text Text -> [Element] -> [Element]
renumIds (\QName
q -> QName -> Text
qName QName
q forall a. Eq a => a -> a -> Bool
== Text
"Id") Map Text Text
idMap [Element]
footers
  let baserels :: [Element]
baserels = [Element]
baserels' forall a. [a] -> [a] -> [a]
++ [Element]
renumHeaders forall a. [a] -> [a] -> [a]
++ [Element]
renumFooters
  let toImgRel :: (FilePath, FilePath, c, d) -> Element
toImgRel (FilePath
ident,FilePath
path,c
_,d
_) =  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",FilePath -> Text
T.pack FilePath
ident),(Text
"Target",FilePath -> Text
T.pack FilePath
path)] ()
  let imgrels :: [Element]
imgrels = forall a b. (a -> b) -> [a] -> [b]
map forall {c} {d}. (FilePath, FilePath, c, d) -> Element
toImgRel [(FilePath, FilePath, Maybe Text, ByteString)]
imgs
  let toLinkRel :: (Text, Text) -> Element
toLinkRel (Text
src,Text
ident) =  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") ] ()
  let linkrels :: [Element]
linkrels = forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Element
toLinkRel forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ WriterState -> Map Text Text
stExternalLinks WriterState
st
  let reldoc :: Element
reldoc = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Relationships" [(Text
"xmlns",Text
"http://schemas.openxmlformats.org/package/2006/relationships")] forall a b. (a -> b) -> a -> b
$ [Element]
baserels forall a. [a] -> [a] -> [a]
++ [Element]
imgrels forall a. [a] -> [a] -> [a]
++ [Element]
linkrels
  let relEntry :: Entry
relEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
"word/_rels/document.xml.rels" Integer
epochtime
        forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
reldoc


  -- adjust contents to add sectPr from reference.docx
  let sectpr :: Element
sectpr = case Maybe Element
mbsectpr of
        Just Element
sectpr' -> let cs :: [Element]
cs = (QName -> Bool) -> Map Text Text -> [Element] -> [Element]
renumIds
                                 (\QName
q -> QName -> Text
qName QName
q forall a. Eq a => a -> a -> Bool
== Text
"id" Bool -> Bool -> Bool
&& QName -> Maybe Text
qPrefix QName
q forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"r")
                                 Map Text Text
idMap
                                 (Element -> [Element]
elChildren Element
sectpr')
                        in
                         [Attr] -> Element -> Element
add_attrs (Element -> [Attr]
elAttribs Element
sectpr') forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:sectPr" [] [Element]
cs
        Maybe Element
Nothing      -> forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:sectPr" [] ()

  -- let sectpr = fromMaybe (mknode "w:sectPr" [] ()) mbsectpr'
  let contents' :: [Content]
contents' = [Content]
contents forall a. [a] -> [a] -> [a]
++ [Element -> Content
Elem Element
sectpr]
  let docContents :: Element
docContents = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:document" [(Text, Text)]
stdAttributes
                    forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:body" [] [Content]
contents'



  -- word/document.xml
  let contentEntry :: Entry
contentEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
"word/document.xml" Integer
epochtime
                     forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
docContents

  -- footnotes
  let notes :: Element
notes = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:footnotes" [(Text, Text)]
stdAttributes [Element]
footnotes
  let footnotesEntry :: Entry
footnotesEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
"word/footnotes.xml" Integer
epochtime forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
notes

  -- footnote rels
  let footnoteRelEntry :: Entry
footnoteRelEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
"word/_rels/footnotes.xml.rels" Integer
epochtime
        forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Relationships" [(Text
"xmlns",Text
"http://schemas.openxmlformats.org/package/2006/relationships")]
        [Element]
linkrels

  -- comments
  let commentsEntry :: Entry
commentsEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
"word/comments.xml" Integer
epochtime
        forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:comments" [(Text, Text)]
stdAttributes [Element]
comments

  -- styles

  -- We only want to inject paragraph and text properties that
  -- are not already in the style map. Note that keys in the stylemap
  -- are normalized as lowercase.
  let newDynamicParaProps :: [ParaStyleName]
newDynamicParaProps = forall a. (a -> Bool) -> [a] -> [a]
filter
        (\ParaStyleName
sty -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName ParaStyleName
sty forall a b. (a -> b) -> a -> b
$ StyleMaps -> ParaStyleNameMap
smParaStyle StyleMaps
styleMaps)
        (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ WriterState -> Set ParaStyleName
stDynamicParaProps WriterState
st)

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

  let newstyles :: [Element]
newstyles = forall a b. (a -> b) -> [a] -> [b]
map ParaStyleName -> Element
newParaPropToOpenXml [ParaStyleName]
newDynamicParaProps forall a. [a] -> [a] -> [a]
++
                  forall a b. (a -> b) -> [a] -> [b]
map CharStyleName -> Element
newTextPropToOpenXml [CharStyleName]
newDynamicTextProps forall a. [a] -> [a] -> [a]
++
                  forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (StyleMaps -> Style -> [Element]
styleToOpenXml StyleMaps
styleMaps) (WriterOptions -> Maybe Style
writerHighlightStyle WriterOptions
opts)
  let styledoc' :: Element
styledoc' = Element
styledoc{ elContent :: [Content]
elContent = Element -> [Content]
elContent Element
styledoc forall a. [a] -> [a] -> [a]
++
                                           forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
newstyles }
  let styleEntry :: Entry
styleEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
stylepath Integer
epochtime forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
styledoc'

  -- construct word/numbering.xml
  let numpath :: FilePath
numpath = FilePath
"word/numbering.xml"
  Element
numbering <- forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive FilePath
numpath
  let newNumElts :: [Element]
newNumElts = [ListMarker] -> [Element]
mkNumbering (WriterState -> [ListMarker]
stLists WriterState
st)
  let pandocAdded :: Element -> Bool
pandocAdded Element
e =
       case (QName -> Bool) -> Element -> Maybe Text
findAttrBy ((forall a. Eq a => a -> a -> Bool
== Text
"abstractNumId") forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) Element
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead of
         Just Int
numid -> Int
numid forall a. Ord a => a -> a -> Bool
>= (Int
990 :: Int)
         Maybe Int
Nothing    ->
           case (QName -> Bool) -> Element -> Maybe Text
findAttrBy ((forall a. Eq a => a -> a -> Bool
== Text
"numId") forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) Element
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead of
             Just Int
numid -> Int
numid forall a. Ord a => a -> a -> Bool
>= (Int
1000 :: Int)
             Maybe Int
Nothing    -> Bool
False
  let oldElts :: [Element]
oldElts = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Bool
pandocAdded) forall a b. (a -> b) -> a -> b
$ [Content] -> [Element]
onlyElems (Element -> [Content]
elContent Element
numbering)
  let allElts :: [Element]
allElts = [Element]
oldElts forall a. [a] -> [a] -> [a]
++ [Element]
newNumElts
  let numEntry :: Entry
numEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
numpath Integer
epochtime forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
numbering{ elContent :: [Content]
elContent =
                       -- we want all the abstractNums first, then the nums,
                       -- otherwise things break:
                       [Element -> Content
Elem Element
e | Element
e <- [Element]
allElts
                               , QName -> Text
qName (Element -> QName
elName Element
e) forall a. Eq a => a -> a -> Bool
== Text
"abstractNum" ] forall a. [a] -> [a] -> [a]
++
                       [Element -> Content
Elem Element
e | Element
e <- [Element]
allElts
                               , QName -> Text
qName (Element -> QName
elName Element
e) forall a. Eq a => a -> a -> Bool
== Text
"num" ] }

  let keywords :: [Text]
keywords = case Text -> Meta -> Maybe MetaValue
lookupMeta Text
"keywords" Meta
meta of
                       Just (MetaList [MetaValue]
xs) -> forall a b. (a -> b) -> [a] -> [b]
map forall a. Walkable Inline a => a -> Text
stringify [MetaValue]
xs
                       Maybe MetaValue
_                  -> []

  -- docProps/core.xml
  let docPropsPath :: FilePath
docPropsPath = FilePath
"docProps/core.xml"
  let extraCoreProps :: [Text]
extraCoreProps = [Text
"subject",Text
"lang",Text
"category",Text
"description"]
  let extraCorePropsMap :: Map Text Text
extraCorePropsMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
extraCoreProps
                       [Text
"dc:subject",Text
"dc:language",Text
"cp:category",Text
"dc:description"]
  let 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" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Walkable Inline a => a -> Text
stringify 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'

  let docProps :: Element
docProps = 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")]
          forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Text -> Element
mktnode Text
"dc:title" [] (forall a. Walkable Inline a => a -> Text
stringify forall a b. (a -> b) -> a -> b
$ Meta -> [Inline]
docTitle Meta
meta)
          forall a. a -> [a] -> [a]
: Text -> [(Text, Text)] -> Text -> Element
mktnode Text
"dc:creator" [] (Text -> [Text] -> Text
T.intercalate Text
"; " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Walkable Inline a => a -> Text
stringify forall a b. (a -> b) -> a -> b
$ Meta -> [[Inline]]
docAuthors Meta
meta))
          forall a. a -> [a] -> [a]
: [ Text -> [(Text, Text)] -> Text -> Element
mktnode (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 <- forall k a. Map k a -> [k]
M.keys (Meta -> Map Text MetaValue
unMeta Meta
meta), Text
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
extraCoreProps]
          forall a. [a] -> [a] -> [a]
++ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"cp:keywords" [] (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
keywords)
          forall a. a -> [a] -> [a]
: (\Text
x -> [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"dcterms:created" [(Text
"xsi:type",Text
"dcterms:W3CDTF")] Text
x
                   , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"dcterms:modified" [(Text
"xsi:type",Text
"dcterms:W3CDTF")] Text
x
                   ]) (FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%FT%XZ" UTCTime
utctime)
  let docPropsEntry :: Entry
docPropsEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
docPropsPath Integer
epochtime forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
docProps

  -- docProps/custom.xml
  let customProperties :: [(Text, Text)]
      customProperties :: [(Text, Text)]
customProperties = [ (Text
k, Text -> Meta -> Text
lookupMetaString Text
k Meta
meta)
                         | Text
k <- forall k a. Map k a -> [k]
M.keys (Meta -> Map Text MetaValue
unMeta Meta
meta)
                         , Text
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Text
"title", Text
"author", Text
"keywords"]
                                       forall a. [a] -> [a] -> [a]
++ [Text]
extraCoreProps)]
  let mkCustomProp :: (Text, t) -> a -> Element
mkCustomProp (Text
k, t
v) a
pid = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"property"
         [(Text
"fmtid",Text
"{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
         ,(Text
"pid", forall a. Show a => a -> Text
tshow a
pid)
         ,(Text
"name", Text
k)] forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"vt:lpwstr" [] t
v
  let customPropsPath :: FilePath
customPropsPath = FilePath
"docProps/custom.xml"
  let customProps :: Element
customProps = 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")
          ] forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {t} {a}. (Node t, Show a) => (Text, t) -> a -> Element
mkCustomProp [(Text, Text)]
customProperties [(Int
2 :: Int)..]
  let customPropsEntry :: Entry
customPropsEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
customPropsPath Integer
epochtime forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
customProps

  let relsPath :: FilePath
relsPath = FilePath
"_rels/.rels"
  let rels :: Element
rels = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"Relationships" [(Text
"xmlns", Text
"http://schemas.openxmlformats.org/package/2006/relationships")]
        forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\[(Text, Text)]
attrs -> 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")]
        ]
  let relsEntry :: Entry
relsEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
relsPath Integer
epochtime forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
rels

  -- we use dist archive for settings.xml, because Word sometimes
  -- adds references to footnotes or endnotes we don't have...
  -- we do, however, copy some settings over from reference
  let settingsPath :: FilePath
settingsPath = FilePath
"word/settings.xml"
      settingsList :: [Text]
settingsList = [ Text
"zoom"
                     , Text
"mirrorMargins"
                     , Text
"embedSystemFonts"
                     , Text
"doNotTrackMoves"
                     , Text
"defaultTabStop"
                     , Text
"drawingGridHorizontalSpacing"
                     , Text
"drawingGridVerticalSpacing"
                     , Text
"displayHorizontalDrawingGridEvery"
                     , Text
"displayVerticalDrawingGridEvery"
                     , Text
"characterSpacingControl"
                     , Text
"savePreviewPicture"
                     , Text
"mathPr"
                     , Text
"themeFontLang"
                     , Text
"decimalSymbol"
                     , Text
"listSeparator"
                     , Text
"autoHyphenation"
                     , Text
"consecutiveHyphenLimit"
                     , Text
"hyphenationZone"
                     , Text
"doNotHyphenateCap"
                     , Text
"evenAndOddHeaders"
                     , Text
"proofState"
                     , Text
"compat"
                     ]
  Entry
settingsEntry <- forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> Integer -> [Text] -> m Entry
copyChildren Archive
refArchive Archive
distArchive FilePath
settingsPath Integer
epochtime [Text]
settingsList

  let entryFromArchive :: Archive -> FilePath -> m Entry
entryFromArchive Archive
arch FilePath
path =
         forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError
                           forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ FilePath
path forall a. [a] -> [a] -> [a]
++ FilePath
" missing in reference docx")
               forall (m :: * -> *) a. Monad m => a -> m a
return
               (FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
path Archive
arch forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
path Archive
distArchive)
  Entry
docPropsAppEntry <- forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive FilePath
"docProps/app.xml"
  Entry
themeEntry <- forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive FilePath
"word/theme/theme1.xml"
  Entry
fontTableEntry <- forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive FilePath
"word/fontTable.xml"
  let fontTableRelsEntries :: [Entry]
fontTableRelsEntries = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$
       FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
"word/_rels/fontTable.xml.rels" Archive
refArchive
  let fontEntries :: [Entry]
fontEntries = [Entry
entry | Entry
entry <- Archive -> [Entry]
zEntries Archive
refArchive
                           , FilePath
"word/fonts/" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Entry -> FilePath
eRelativePath Entry
entry)]
                        -- or parse fontTable.xml.rels?
  Entry
webSettingsEntry <- forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive FilePath
"word/webSettings.xml"
  [Entry]
headerFooterEntries <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *}.
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"word/" forall a. [a] -> [a] -> [a]
++)) forall a b. (a -> b) -> a -> b
$
                         forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Maybe Text
extractTarget)
                         ([Element]
headers forall a. [a] -> [a] -> [a]
++ [Element]
footers)
  let miscRelEntries :: [Entry]
miscRelEntries = [ Entry
e | Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
                       , FilePath
"word/_rels/" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> FilePath
eRelativePath Entry
e
                       , FilePath
".xml.rels" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Entry -> FilePath
eRelativePath Entry
e
                       , Entry -> FilePath
eRelativePath Entry
e forall a. Eq a => a -> a -> Bool
/= FilePath
"word/_rels/document.xml.rels"
                       , Entry -> FilePath
eRelativePath Entry
e forall a. Eq a => a -> a -> Bool
/= FilePath
"word/_rels/footnotes.xml.rels" ]
  let otherMediaEntries :: [Entry]
otherMediaEntries = [ Entry
e | Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
                          , FilePath
"word/media/" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> FilePath
eRelativePath Entry
e ]

  -- Create archive
  let archive :: Archive
archive = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
addEntryToArchive Archive
emptyArchive forall a b. (a -> b) -> a -> b
$
                  Entry
contentTypesEntry forall a. a -> [a] -> [a]
: Entry
relsEntry forall a. a -> [a] -> [a]
: Entry
contentEntry forall a. a -> [a] -> [a]
: Entry
relEntry forall a. a -> [a] -> [a]
:
                  Entry
footnoteRelEntry forall a. a -> [a] -> [a]
: Entry
numEntry forall a. a -> [a] -> [a]
: Entry
styleEntry forall a. a -> [a] -> [a]
: Entry
footnotesEntry forall a. a -> [a] -> [a]
:
                  Entry
commentsEntry forall a. a -> [a] -> [a]
:
                  Entry
docPropsEntry forall a. a -> [a] -> [a]
: Entry
docPropsAppEntry forall a. a -> [a] -> [a]
: Entry
customPropsEntry forall a. a -> [a] -> [a]
:
                  Entry
themeEntry forall a. a -> [a] -> [a]
:
                  Entry
settingsEntry forall a. a -> [a] -> [a]
: Entry
webSettingsEntry forall a. a -> [a] -> [a]
:
                  Entry
fontTableEntry forall a. a -> [a] -> [a]
:
                  [Entry]
fontTableRelsEntries forall a. [a] -> [a] -> [a]
++ [Entry]
fontEntries forall a. [a] -> [a] -> [a]
++
                  [Entry]
imageEntries forall a. [a] -> [a] -> [a]
++ [Entry]
headerFooterEntries forall a. [a] -> [a] -> [a]
++
                  [Entry]
miscRelEntries forall a. [a] -> [a] -> [a]
++ [Entry]
otherMediaEntries
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Archive -> ByteString
fromArchive Archive
archive

newParaPropToOpenXml :: ParaStyleName -> Element
newParaPropToOpenXml :: ParaStyleName -> Element
newParaPropToOpenXml (forall a. FromStyleName a => a -> Text
fromStyleName -> Text
s) =
  let styleId :: Text
styleId = (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
s
  in 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)]
     [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:name" [(Text
"w:val", Text
s)] ()
     , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:basedOn" [(Text
"w:val",Text
"BodyText")] ()
     , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:qFormat" [] ()
     ]

newTextPropToOpenXml :: CharStyleName -> Element
newTextPropToOpenXml :: CharStyleName -> Element
newTextPropToOpenXml (forall a. FromStyleName a => a -> Text
fromStyleName -> Text
s) =
  let styleId :: Text
styleId = (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
s
  in 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)]
     [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:name" [(Text
"w:val", Text
s)] ()
     , 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 =
  forall a. Maybe a -> [a]
maybeToList Maybe Element
parStyle forall a. [a] -> [a] -> [a]
++ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TokenType -> Maybe Element
toStyle [TokenType]
alltoktypes
  where alltoktypes :: [TokenType]
alltoktypes = forall a. Enum a => a -> a -> [a]
enumFromTo TokenType
KeywordTok TokenType
NormalTok
        toStyle :: TokenType -> Maybe Element
toStyle TokenType
toktype | forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show TokenType
toktype) (StyleMaps -> CharStyleNameMap
smCharStyle StyleMaps
sm) = forall a. Maybe a
Nothing
                        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                          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", forall a. Show a => a -> Text
tshow TokenType
toktype)]
                             [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:name" [(Text
"w:val", forall a. Show a => a -> Text
tshow TokenType
toktype)] ()
                             , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:basedOn" [(Text
"w:val",Text
"VerbatimChar")] ()
                             , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" [] forall a b. (a -> b) -> a -> b
$
                               [ 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 forall a. Eq a => a -> a -> Bool
/= Text
"auto" ] forall a. [a] -> [a] -> [a]
++
                               [ 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 forall a. Eq a => a -> a -> Bool
/= Text
"auto" ] forall a. [a] -> [a] -> [a]
++
                               [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:b" [] () | (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenBold TokenType
toktype ] forall a. [a] -> [a] -> [a]
++
                               [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:i" [] () | (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenItalic TokenType
toktype ] forall a. [a] -> [a] -> [a]
++
                               [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:u" [] () | (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenUnderline TokenType
toktype ]
                             ]
        tokStyles :: Map TokenType TokenStyle
tokStyles = Style -> Map TokenType TokenStyle
tokenStyles Style
style
        tokFeature :: (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
f TokenType
toktype = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TokenStyle -> Bool
f forall a b. (a -> b) -> a -> b
$ 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"auto" (FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromColor a => Color -> a
fromColor)
                         forall a b. (a -> b) -> a -> b
$ (TokenStyle -> Maybe Color
tokenColor forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles)
                           forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
defaultColor Style
style
        tokBg :: TokenType -> Text
tokBg TokenType
toktype = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"auto" (FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromColor a => Color -> a
fromColor)
                         forall a b. (a -> b) -> a -> b
$ (TokenStyle -> Maybe Color
tokenBackground forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles)
                           forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
backgroundColor Style
style
        parStyle :: Maybe Element
parStyle | forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName ParaStyleName
"Source Code" (StyleMaps -> ParaStyleNameMap
smParaStyle StyleMaps
sm) = forall a. Maybe a
Nothing
                 | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                   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")]
                             [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:name" [(Text
"w:val",Text
"Source Code")] ()
                             , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:basedOn" [(Text
"w:val",Text
"Normal")] ()
                             , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:link" [(Text
"w:val",Text
"VerbatimChar")] ()
                             , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pPr" []
                               forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:wordWrap" [(Text
"w:val",Text
"off")] ()
                               forall a. a -> [a] -> [a]
:
                         forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Color
col -> [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:shd" [(Text
"w:val",Text
"clear"),(Text
"w:fill", FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ 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 -> FilePath -> Integer -> [Text] -> m Entry
copyChildren Archive
refArchive Archive
distArchive FilePath
path Integer
timestamp [Text]
elNames = do
  Element
ref  <- forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive FilePath
path
  Element
dist <- forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
distArchive Archive
distArchive FilePath
path
  let elsToCopy :: [Element]
elsToCopy =
        forall a b. (a -> b) -> [a] -> [b]
map Element -> Element
cleanElem forall a b. (a -> b) -> a -> b
$ (QName -> Bool) -> Element -> [Element]
filterChildrenName (\QName
e -> QName -> Text
qName QName
e forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
elNames) Element
ref
  let elsToKeep :: [Element]
elsToKeep =
        [Element
e | Elem Element
e <- Element -> [Content]
elContent Element
dist, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Element -> Element -> Bool
hasSameNameAs Element
e) [Element]
elsToCopy)]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
path Integer
timestamp forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
dist{
      elContent :: [Content]
elContent = forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
elsToKeep forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
elsToCopy
    }
  where
    hasSameNameAs :: Element -> Element -> Bool
hasSameNameAs (Element {elName :: Element -> QName
elName = QName
n1}) (Element {elName :: Element -> QName
elName = QName
n2}) =
      QName -> Text
qName QName
n1 forall a. Eq a => a -> a -> Bool
== QName -> Text
qName QName
n2
    cleanElem :: Element -> Element
cleanElem el :: Element
el@Element{elName :: Element -> QName
elName=QName
name} = Element
el{elName :: QName
elName=QName
name{qURI :: Maybe Text
qURI=forall a. Maybe a
Nothing}}

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

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

maxListLevel :: Int
maxListLevel :: Int
maxListLevel = Int
8

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

mkAbstractNum :: ListMarker -> Element
mkAbstractNum :: ListMarker -> Element
mkAbstractNum ListMarker
marker =
  forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:abstractNum" [(Text
"w:abstractNumId",ListMarker -> Text
listMarkerToId ListMarker
marker)]
    forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:nsid" [(Text
"w:val", Text
"A" forall a. Semigroup a => a -> a -> a
<> ListMarker -> Text
listMarkerToId ListMarker
marker)] ()
    forall a. a -> [a] -> [a]
: forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:multiLevelType" [(Text
"w:val",Text
"multilevel")] ()
    forall a. a -> [a] -> [a]
: 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 =
  forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:lvl" [(Text
"w:ilvl",forall a. Show a => a -> Text
tshow Int
lvl)] forall a b. (a -> b) -> a -> b
$
    [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:start" [(Text
"w:val",Text
start)] ()
      | ListMarker
marker forall a. Eq a => a -> a -> Bool
/= ListMarker
NoMarker Bool -> Bool -> Bool
&& ListMarker
marker forall a. Eq a => a -> a -> Bool
/= ListMarker
BulletMarker ] forall a. [a] -> [a] -> [a]
++
    [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:numFmt" [(Text
"w:val",Text
fmt)] ()
    , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:lvlText" [(Text
"w:val", Text
lvltxt)] ()
    , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:lvlJc" [(Text
"w:val",Text
"left")] ()
    , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pPr" []
      [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:ind" [ (Text
"w:left",forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ Int
lvl forall a. Num a => a -> a -> a
* Int
step forall a. Num a => a -> a -> a
+ Int
step)
                       , (Text
"w:hanging",forall a. Show a => a -> Text
tshow (Int
hang :: Int))
                       ] ()
      ]
    ]
    where (Text
fmt, Text
lvltxt, Text
start) =
            case ListMarker
marker of
                 ListMarker
NoMarker             -> (Text
"bullet",Text
" ",Text
"1")
                 ListMarker
BulletMarker         -> (Text
"bullet",forall {t} {a}. (IsString a, Integral t) => t -> a
bulletFor Int
lvl,Text
"1")
                 NumberMarker ListNumberStyle
st ListNumberDelim
de Int
n -> (forall {a} {t}.
(IsString a, Integral t) =>
ListNumberStyle -> t -> a
styleFor ListNumberStyle
st Int
lvl
                                         ,forall {a}. (Semigroup a, IsString a) => ListNumberDelim -> a -> a
patternFor ListNumberDelim
de (Text
"%" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (Int
lvl forall a. Num a => a -> a -> a
+ Int
1))
                                         ,forall a. Show a => a -> Text
tshow Int
n)
          step :: Int
step = Int
720
          hang :: Int
hang = Int
480
          bulletFor :: t -> a
bulletFor t
0 = a
"\x2022"  -- filled circle
          bulletFor t
1 = a
"\x2013"  -- en dash
          bulletFor t
2 = a
"\x2022"  -- hyphen bullet
          bulletFor t
3 = a
"\x2013"
          bulletFor t
4 = a
"\x2022"
          bulletFor t
5 = a
"\x2013"
          bulletFor t
x = t -> a
bulletFor (t
x forall a. Integral a => a -> a -> a
`mod` t
6)
          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 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 forall a. Semigroup a => a -> a -> a
<> a
")"
          patternFor ListNumberDelim
TwoParens a
s = a
"(" forall a. Semigroup a => a -> a -> a
<> a
s forall a. Semigroup a => a -> a -> a
<> a
")"
          patternFor ListNumberDelim
_ a
s         = a
s forall a. Semigroup a => a -> a -> a
<> a
"."

getNumId :: (PandocMonad m) => WS m Int
getNumId :: forall (m :: * -> *). PandocMonad m => WS m Int
getNumId = (((Int
baseListId forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [ListMarker]
stLists


makeTOC :: (PandocMonad m) => WriterOptions -> WS m [Element]
makeTOC :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> WS m [Element]
makeTOC WriterOptions
opts = do
  let depth :: Text
depth = Text
"1-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow (WriterOptions -> Int
writerTOCDepth WriterOptions
opts)
  let tocCmd :: Text
tocCmd = Text
"TOC \\o \"" forall a. Semigroup a => a -> a -> a
<> Text
depth forall a. Semigroup a => a -> a -> a
<> Text
"\" \\h \\z \\u"
  [Inline]
tocTitle <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [Inline]
stTocTitle
  [Content]
title <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"TOC Heading") (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [[Inline] -> Block
Para [Inline]
tocTitle])
  forall (m :: * -> *) a. Monad m => a -> m a
return
    [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:sdt" [] [
      forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:sdtPr" [] (
        forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:docPartObj" []
          [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:docPartGallery" [(Text
"w:val",Text
"Table of Contents")] (),
          forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:docPartUnique" [] ()]
         -- w:docPartObj
      ), -- w:sdtPr
      forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:sdtContent" [] ([Content]
title forall a. [a] -> [a] -> [a]
++ [ Element -> Content
Elem forall a b. (a -> b) -> a -> b
$
        forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:p" [] (
          forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" [] [
            forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:fldChar" [(Text
"w:fldCharType",Text
"begin"),(Text
"w:dirty",Text
"true")] (),
            forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:instrText" [(Text
"xml:space",Text
"preserve")] Text
tocCmd,
            forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:fldChar" [(Text
"w:fldCharType",Text
"separate")] (),
            forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:fldChar" [(Text
"w:fldCharType",Text
"end")] ()
          ] -- w:r
        ) -- w:p
      ])
    ]] -- w:sdt

-- | Convert Pandoc document to two lists of
-- OpenXML elements (the main document and footnotes).
writeOpenXML :: (PandocMonad m)
             => WriterOptions -> Pandoc
             -> WS m ([Content], [Element], [Element])
writeOpenXML :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> WS m ([Content], [Element], [Element])
writeOpenXML WriterOptions
opts (Pandoc Meta
meta [Block]
blocks) = do
  let tit :: [Inline]
tit = Meta -> [Inline]
docTitle Meta
meta
  let auths :: [[Inline]]
auths = Meta -> [[Inline]]
docAuthors Meta
meta
  let dat :: [Inline]
dat = Meta -> [Inline]
docDate Meta
meta
  let abstract' :: [Block]
abstract' = Text -> Meta -> [Block]
lookupMetaBlocks Text
"abstract" Meta
meta
  let subtitle' :: [Inline]
subtitle' = Text -> Meta -> [Inline]
lookupMetaInlines Text
"subtitle" Meta
meta
  let includeTOC :: Bool
includeTOC = WriterOptions -> Bool
writerTableOfContents WriterOptions
opts Bool -> Bool -> Bool
|| Text -> Meta -> Bool
lookupMetaBool Text
"toc" Meta
meta
  [Content]
title <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Title") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [[Inline] -> Block
Para [Inline]
tit | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
tit)]
  [Content]
subtitle <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Subtitle") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [[Inline] -> Block
Para [Inline]
subtitle' | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
subtitle')]
  [Content]
authors <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Author") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts forall a b. (a -> b) -> a -> b
$
       forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Block
Para [[Inline]]
auths
  [Content]
date <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Date") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [[Inline] -> Block
Para [Inline]
dat | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
dat)]
  [Content]
abstract <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
abstract'
                 then forall (m :: * -> *) a. Monad m => a -> m a
return []
                 else do
                   Text
abstractTitle <- case Text -> Meta -> Maybe MetaValue
lookupMeta Text
"abstract-title" Meta
meta of
                       Just (MetaBlocks [Block]
bs)   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Walkable Inline a => a -> Text
stringify [Block]
bs
                       Just (MetaInlines [Inline]
ils) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Walkable Inline a => a -> Text
stringify [Inline]
ils
                       Just (MetaString Text
s)    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
                       Maybe MetaValue
_                      -> forall (m :: * -> *). PandocMonad m => Term -> m Text
translateTerm Term
Abstract
                   [Content]
abstractTit <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"AbstractTitle") forall a b. (a -> b) -> a -> b
$
                                   forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts
                                     [[Inline] -> Block
Para [Text -> Inline
Str Text
abstractTitle]]
                   [Content]
abstractContents <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Abstract") forall a b. (a -> b) -> a -> b
$
                                         forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
abstract'
                   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Content]
abstractTit forall a. Semigroup a => a -> a -> a
<> [Content]
abstractContents

  let convertSpace :: [Inline] -> [Inline]
convertSpace (Str Text
x : Inline
Space : Str Text
y : [Inline]
xs) = Text -> Inline
Str (Text
x forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
y) forall a. a -> [a] -> [a]
: [Inline]
xs
      convertSpace (Str Text
x : Str Text
y : [Inline]
xs)         = Text -> Inline
Str (Text
x forall a. Semigroup a => a -> a -> a
<> Text
y) forall a. a -> [a] -> [a]
: [Inline]
xs
      convertSpace [Inline]
xs                           = [Inline]
xs
  let blocks' :: [Block]
blocks' = forall a b. (Data a, Data b) => (a -> a) -> b -> b
bottomUp [Inline] -> [Inline]
convertSpace [Block]
blocks
  [Content]
doc' <- forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
blocks'
  [Element]
notes' <- forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [Element]
stFootnotes
  [([(Text, Text)], [Inline])]
comments <- forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [([(Text, Text)], [Inline])]
stComments
  let toComment :: ([(Text, Text)], [Inline])
-> ReaderT WriterEnv (StateT WriterState m) Element
toComment ([(Text, Text)]
kvs, [Inline]
ils) = do
        [Content]
annotation <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
          forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:comment" [(Text
"w:" forall a. Semigroup a => a -> a -> a
<> Text
k, Text
v) | (Text
k,Text
v) <- [(Text, Text)]
kvs]
            [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:p" [] forall a b. (a -> b) -> a -> b
$
              forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem
              [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pPr" []
                [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pStyle" [(Text
"w:val", Text
"CommentText")] () ]
              , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" []
                [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" []
                  [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rStyle" [(Text
"w:val", Text
"CommentReference")] ()
                  , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:annotationRef" [] ()
                  ]
                ]
              ] forall a. [a] -> [a] -> [a]
++ [Content]
annotation
            ]
  [Element]
comments' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}.
PandocMonad m =>
([(Text, Text)], [Inline])
-> ReaderT WriterEnv (StateT WriterState m) Element
toComment [([(Text, Text)], [Inline])]
comments
  [Element]
toc <- if Bool
includeTOC
            then forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> WS m [Element]
makeTOC WriterOptions
opts
            else forall (m :: * -> *) a. Monad m => a -> m a
return []
  let meta' :: [Content]
meta' = [Content]
title forall a. [a] -> [a] -> [a]
++ [Content]
subtitle forall a. [a] -> [a] -> [a]
++ [Content]
authors forall a. [a] -> [a] -> [a]
++ [Content]
date forall a. [a] -> [a] -> [a]
++ [Content]
abstract forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
toc
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Content]
meta' forall a. [a] -> [a] -> [a]
++ [Content]
doc', [Element]
notes', [Element]
comments')

-- | Convert a list of Pandoc blocks to OpenXML.
blocksToOpenXML :: (PandocMonad m) => WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> [Block]
separateTables forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Bool
isForeignRawBlock)

isForeignRawBlock :: Block -> Bool
isForeignRawBlock :: Block -> Bool
isForeignRawBlock (RawBlock Format
format Text
_) = Format
format forall a. Eq a => a -> a -> Bool
/= Format
"openxml"
isForeignRawBlock Block
_                   = Bool
False

-- Word combines adjacent tables unless you put an empty paragraph between
-- them.  See #4315.
separateTables :: [Block] -> [Block]
separateTables :: [Block] -> [Block]
separateTables [] = []
separateTables (x :: Block
x@Table{}:xs :: [Block]
xs@(Table{}:[Block]
_)) =
  Block
x forall a. a -> [a] -> [a]
: Format -> Text -> Block
RawBlock (Text -> Format
Format Text
"openxml") Text
"<w:p />" forall a. a -> [a] -> [a]
: [Block] -> [Block]
separateTables [Block]
xs
separateTables (Block
x:[Block]
xs) = Block
x forall a. a -> [a] -> [a]
: [Block] -> [Block]
separateTables [Block]
xs

rStyleM :: (PandocMonad m) => CharStyleName -> WS m XML.Element
rStyleM :: forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM CharStyleName
styleName = do
  CharStyleNameMap
cStyleMap <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StyleMaps -> CharStyleNameMap
smCharStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterState -> StyleMaps
stStyleMaps)
  let sty' :: StyleId CharStyle
sty' = forall sn sty.
(Ord sn, FromStyleName sn, IsString (StyleId sty),
 HasStyleId sty) =>
sn -> Map sn sty -> StyleId sty
getStyleIdFromName CharStyleName
styleName CharStyleNameMap
cStyleMap
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rStyle" [(Text
"w:val", forall a. FromStyleId a => a -> Text
fromStyleId CharStyleId
sty')] ()

getUniqueId :: (PandocMonad m) => WS m Text
getUniqueId :: forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId = do
  Int
n <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stCurId
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{stCurId :: Int
stCurId = Int
n forall a. Num a => a -> a -> a
+ Int
1}
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
tshow Int
n

-- | Key for specifying user-defined docx styles.
dynamicStyleKey :: Text
dynamicStyleKey :: Text
dynamicStyleKey = Text
"custom-style"

-- | Convert a Pandoc block element to OpenXML.
blockToOpenXML :: (PandocMonad m) => WriterOptions -> Block -> WS m [Content]
blockToOpenXML :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts Block
blk = forall (m :: * -> *) a. PandocMonad m => WS m a -> WS m a
withDirection forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML' WriterOptions
opts Block
blk

blockToOpenXML' :: (PandocMonad m) => WriterOptions -> Block -> WS m [Content]
blockToOpenXML' :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML' WriterOptions
opts (Div (Text
ident,[Text]
_classes,[(Text, Text)]
kvs) [Block]
bs) = do
  WS m [Content] -> WS m [Content]
stylemod <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
dynamicStyleKey [(Text, Text)]
kvs of
                   Just (forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack -> ParaStyleName
sty) -> do
                      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s ->
                        WriterState
s{stDynamicParaProps :: Set ParaStyleName
stDynamicParaProps = forall a. Ord a => a -> Set a -> Set a
Set.insert ParaStyleName
sty
                             (WriterState -> Set ParaStyleName
stDynamicParaProps WriterState
s)}
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
sty)
                   Maybe Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
  WS m [Content] -> WS m [Content]
dirmod <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"dir" [(Text, Text)]
kvs of
                 Just Text
"rtl" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envRTL :: Bool
envRTL = Bool
True })
                 Just Text
"ltr" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envRTL :: Bool
envRTL = Bool
False })
                 Maybe Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
  let ([Block]
hs, [Block]
bs') = if Text
ident forall a. Eq a => a -> a -> Bool
== Text
"refs"
                     then forall a. (a -> Bool) -> [a] -> ([a], [a])
span Block -> Bool
isHeaderBlock [Block]
bs
                     else ([], [Block]
bs)
  let bibmod :: WS m a -> WS m a
bibmod = if Text
ident forall a. Eq a => a -> a -> Bool
== Text
"refs"
                  then forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Bibliography")
                  else forall a. a -> a
id
  let langmod :: ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
langmod = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"lang" [(Text, Text)]
kvs of
                  Maybe Text
Nothing -> forall a. a -> a
id
                  Just Text
lang -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env{envLang :: Maybe Text
envLang = forall a. a -> Maybe a
Just Text
lang})
  [Content]
header <- WS m [Content] -> WS m [Content]
dirmod forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
stylemod forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
hs
  [Content]
contents <- WS m [Content] -> WS m [Content]
dirmod forall a b. (a -> b) -> a -> b
$ forall {a}. WS m a -> WS m a
bibmod forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
stylemod forall a b. (a -> b) -> a -> b
$ forall {a}. WS m a -> WS m a
langmod forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
bs'
  forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
ident forall a b. (a -> b) -> a -> b
$ [Content]
header forall a. Semigroup a => a -> a -> a
<> [Content]
contents
blockToOpenXML' WriterOptions
opts (Header Int
lev (Text
ident,[Text]
_,[(Text, Text)]
kvs) [Inline]
lst) = do
  forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
  [Element]
paraProps <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ FilePath
"Heading "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> FilePath
show Int
lev)) forall a b. (a -> b) -> a -> b
$
                    forall (m :: * -> *). PandocMonad m => Bool -> WS m [Element]
getParaProps Bool
False
  [Content]
number <-
        if WriterOptions -> Bool
writerNumberSections WriterOptions
opts
           then
             case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"number" [(Text, Text)]
kvs of
                Just Text
n -> do
                   [Content]
num <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM CharStyleName
"SectionNumber")
                            (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts (Text -> Inline
Str Text
n))
                   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Content]
num forall a. [a] -> [a] -> [a]
++ [Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" [] [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:tab" [] ()]]
                Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
           else forall (m :: * -> *) a. Monad m => a -> m a
return []
  [Content]
contents <- ([Content]
number forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
  if Text -> Bool
T.null Text
ident
     then forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:p" [] (forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
paraProps forall a. [a] -> [a] -> [a]
++ [Content]
contents)]
     else do
       let bookmarkName :: Text
bookmarkName = Text
ident
       forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s -> WriterState
s{ stSectionIds :: Set Text
stSectionIds = forall a. Ord a => a -> Set a -> Set a
Set.insert Text
bookmarkName
                                      forall a b. (a -> b) -> a -> b
$ WriterState -> Set Text
stSectionIds WriterState
s }
       [Content]
bookmarkedContents <- forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
bookmarkName [Content]
contents
       forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:p" [] (forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
paraProps forall a. [a] -> [a] -> [a]
++ [Content]
bookmarkedContents)]
blockToOpenXML' WriterOptions
opts (Plain [Inline]
lst) = do
  Bool
isInTable <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stInTable
  Bool
isInList <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stInList
  let block :: WS m [Content]
block = forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts ([Inline] -> Block
Para [Inline]
lst)
  Element
prop <- forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Compact"
  if Bool
isInTable Bool -> Bool -> Bool
|| Bool
isInList
     then forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withParaProp Element
prop WS m [Content]
block
     else WS m [Content]
block
blockToOpenXML' WriterOptions
opts (Para [Inline]
lst)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
lst Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_empty_paragraphs WriterOptions
opts) = forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise = do
      Bool
isFirstPara <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stFirstPara
      let displayMathPara :: Bool
displayMathPara = case [Inline]
lst of
                                 [Inline
x] -> Inline -> Bool
isDisplayMath Inline
x
                                 [Inline]
_   -> Bool
False
      [Element]
paraProps <- forall (m :: * -> *). PandocMonad m => Bool -> WS m [Element]
getParaProps Bool
displayMathPara
      Element
bodyTextStyle <- forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM forall a b. (a -> b) -> a -> b
$ if Bool
isFirstPara
                       then ParaStyleName
"First Paragraph"
                       else ParaStyleName
"Body Text"
      let paraProps' :: [Element]
paraProps' = case [Element]
paraProps of
            []               -> [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pPr" [] [Element
bodyTextStyle]]
            [Element]
ps               -> [Element]
ps
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s -> WriterState
s { stFirstPara :: Bool
stFirstPara = Bool
False }
      [Content]
contents <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
      forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:p" [] (forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
paraProps' forall a. [a] -> [a] -> [a]
++ [Content]
contents)]
blockToOpenXML' WriterOptions
opts (LineBlock [[Inline]]
lns) = forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts forall a b. (a -> b) -> a -> b
$ [[Inline]] -> Block
linesToPara [[Inline]]
lns
blockToOpenXML' WriterOptions
_ b :: Block
b@(RawBlock Format
format Text
str)
  | Format
format forall a. Eq a => a -> a -> Bool
== Text -> Format
Format Text
"openxml" = forall (m :: * -> *) a. Monad m => a -> m a
return [
        CData -> Content
Text (CDataKind -> Text -> Maybe Integer -> CData
CData CDataKind
CDataRaw Text
str forall a. Maybe a
Nothing)
      ]
  | Bool
otherwise                  = do
      forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Block -> LogMessage
BlockNotRendered Block
b
      forall (m :: * -> *) a. Monad m => a -> m a
return []
blockToOpenXML' WriterOptions
opts (BlockQuote [Block]
blocks) = do
  Bool
inNote <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envInNote
  [Content]
p <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM
                       (if Bool
inNote
                           then ParaStyleName
"Footnote Block Text"
                           else ParaStyleName
"Block Text"))
       forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
blocks
  forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
  forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
p
blockToOpenXML' WriterOptions
opts (CodeBlock attrs :: (Text, [Text], [(Text, Text)])
attrs@(Text
ident, [Text]
_, [(Text, Text)]
_) Text
str) = do
  [Content]
p <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Source Code") (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts forall a b. (a -> b) -> a -> b
$ [Inline] -> Block
Para [(Text, [Text], [(Text, Text)]) -> Text -> Inline
Code (Text, [Text], [(Text, Text)])
attrs Text
str])
  forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
  forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
ident [Content]
p
blockToOpenXML' WriterOptions
_ Block
HorizontalRule = do
  forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
  forall (m :: * -> *) a. Monad m => a -> m a
return [ Element -> Content
Elem forall a b. (a -> b) -> a -> b
$
    forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:p" [] forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" [] forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pict" []
    forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"v:rect" [(Text
"style",Text
"width:0;height:1.5pt"),
                       (Text
"o:hralign",Text
"center"),
                       (Text
"o:hrstd",Text
"t"),(Text
"o:hr",Text
"t")] () ]
blockToOpenXML' WriterOptions
opts (Table (Text, [Text], [(Text, Text)])
attr Caption
caption [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot) = do
  -- Remove extra paragraph indentation due to list items (#5947).
  -- This means that tables in lists will not be indented, but it
  -- avoids unwanted indentation in each cell.
  [Content]
content <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> ([Block] -> WS m [Content]) -> Table -> WS m [Content]
tableToOpenXML WriterOptions
opts
              (forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env{ envListLevel :: Int
envListLevel = -Int
1 }) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts)
                 ((Text, [Text], [(Text, Text)])
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> Table
Grid.toTable (Text, [Text], [(Text, Text)])
attr Caption
caption [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot)
  let (Text
tableId, [Text]
_, [(Text, Text)]
_) = (Text, [Text], [(Text, Text)])
attr
  forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
tableId [Content]
content
blockToOpenXML' WriterOptions
opts Block
el
  | BulletList [[Block]]
lst <- Block
el = forall {m :: * -> *} {t :: * -> *}.
(PandocMonad m, Traversable t) =>
ListMarker
-> t [Block] -> ReaderT WriterEnv (StateT WriterState m) [Content]
addOpenXMLList ListMarker
BulletMarker [[Block]]
lst
  | OrderedList (Int
start, ListNumberStyle
numstyle, ListNumberDelim
numdelim) [[Block]]
lst <- Block
el
  = forall {m :: * -> *} {t :: * -> *}.
(PandocMonad m, Traversable t) =>
ListMarker
-> t [Block] -> ReaderT WriterEnv (StateT WriterState m) [Content]
addOpenXMLList (ListNumberStyle -> ListNumberDelim -> Int -> ListMarker
NumberMarker ListNumberStyle
numstyle ListNumberDelim
numdelim Int
start) [[Block]]
lst
  where
    addOpenXMLList :: ListMarker
-> t [Block] -> ReaderT WriterEnv (StateT WriterState m) [Content]
addOpenXMLList ListMarker
marker t [Block]
lst = do
      forall (m :: * -> *). PandocMonad m => ListMarker -> WS m ()
addList ListMarker
marker
      Int
numid  <- forall (m :: * -> *). PandocMonad m => WS m Int
getNumId
      Maybe Int
exampleid <- case ListMarker
marker of
                        NumberMarker ListNumberStyle
Example ListNumberDelim
_ Int
_ -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Maybe Int
stExampleId
                        ListMarker
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      [Content]
l <- forall (m :: * -> *) a. PandocMonad m => WS m a -> WS m a
asList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Int -> [Block] -> WS m [Content]
listItemToOpenXML WriterOptions
opts forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Int
numid Maybe Int
exampleid) t [Block]
lst
      forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
      forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
l
blockToOpenXML' WriterOptions
opts (DefinitionList [([Inline], [[Block]])]
items) = do
  [Content]
l <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> ([Inline], [[Block]]) -> WS m [Content]
definitionListItemToOpenXML WriterOptions
opts) [([Inline], [[Block]])]
items
  forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
  forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
l
blockToOpenXML' WriterOptions
opts (Figure (Text
ident, [Text]
_, [(Text, Text)]
_) (Caption Maybe [Inline]
_ [Block]
longcapt) [Block]
body) = do
  forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
  Int
fignum <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stNextFigureNum
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
longcapt) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stNextFigureNum :: Int
stNextFigureNum = Int
fignum forall a. Num a => a -> a -> a
+ Int
1 }
  let refid :: Text
refid = if Text -> Bool
T.null Text
ident
              then Text
"ref_fig" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
fignum
              else Text
"ref_" forall a. Semigroup a => a -> a -> a
<> Text
ident
  Text
figname <- forall (m :: * -> *). PandocMonad m => Term -> m Text
translateTerm Term
Term.Figure
  Element
prop <- forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM forall a b. (a -> b) -> a -> b
$
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
longcapt
    then ParaStyleName
"Figure"
    else ParaStyleName
"Captioned Figure"
  [Element]
paraProps <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
    (\WriterEnv
env -> WriterEnv
env { envParaProperties :: EnvProps
envParaProperties = Maybe Element -> [Element] -> EnvProps
EnvProps (forall a. a -> Maybe a
Just Element
prop) [] forall a. Semigroup a => a -> a -> a
<>
                                       WriterEnv -> EnvProps
envParaProperties WriterEnv
env })
    (forall (m :: * -> *). PandocMonad m => Bool -> WS m [Element]
getParaProps Bool
False)

  -- Figure contents
  let simpleImage :: Inline -> ReaderT WriterEnv (StateT WriterState m) Content
simpleImage Inline
x = do
        [Content]
imgXML <- forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts Inline
x
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Element -> Content
Elem (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:p" [] (forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
paraProps forall a. [a] -> [a] -> [a]
++ [Content]
imgXML))
  Content
contentsNode <- case [Block]
body of
    [Plain [img :: Inline
img@Image {}]] -> forall {m :: * -> *}.
PandocMonad m =>
Inline -> ReaderT WriterEnv (StateT WriterState m) Content
simpleImage Inline
img
    [Para  [img :: Inline
img@Image {}]] -> forall {m :: * -> *}.
PandocMonad m =>
Inline -> ReaderT WriterEnv (StateT WriterState m) Content
simpleImage Inline
img
    [Block]
_                      -> forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m Content
toFigureTable WriterOptions
opts [Block]
body
  -- Caption
  let imageCaption :: [Block] -> WS m [Content]
imageCaption = forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Image Caption")
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts
  let fstCaptionPara :: [Inline] -> Block
fstCaptionPara [Inline]
inlns = [Inline] -> Block
Para forall a b. (a -> b) -> a -> b
$
        if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_native_numbering WriterOptions
opts
        then [Inline]
inlns
        else let rawfld :: Inline
rawfld = Format -> Text -> Inline
RawInline (Text -> Format
Format Text
"openxml") forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                          [ Text
"<w:fldSimple w:instr=\"SEQ Figure"
                          , Text
" \\* ARABIC \"><w:r><w:t>"
                          , forall a. Show a => a -> Text
tshow Int
fignum
                          , Text
"</w:t></w:r></w:fldSimple>"
                          ]
             in (Text, [Text], [(Text, Text)]) -> [Inline] -> Inline
Span (Text
refid,[],[]) [Text -> Inline
Str (Text
figname forall a. Semigroup a => a -> a -> a
<> Text
"\160") , Inline
rawfld]
                forall a. a -> [a] -> [a]
: Text -> Inline
Str Text
": " forall a. a -> [a] -> [a]
: [Inline]
inlns
  [Content]
captionNode <- case [Block]
longcapt of
    []              -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    (Para [Inline]
xs  : [Block]
bs) -> [Block] -> WS m [Content]
imageCaption ([Inline] -> Block
fstCaptionPara [Inline]
xs forall a. a -> [a] -> [a]
: [Block]
bs)
    (Plain [Inline]
xs : [Block]
bs) -> [Block] -> WS m [Content]
imageCaption ([Inline] -> Block
fstCaptionPara [Inline]
xs forall a. a -> [a] -> [a]
: [Block]
bs)
    [Block]
_               -> [Block] -> WS m [Content]
imageCaption [Block]
longcapt
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Content
contentsNode forall a. a -> [a] -> [a]
: [Content]
captionNode

toFigureTable :: PandocMonad m
              => WriterOptions -> [Block] -> WS m Content
toFigureTable :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m Content
toFigureTable WriterOptions
opts [Block]
blks = do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s -> WriterState
s { stInTable :: Bool
stInTable = Bool
True }
  let ncols :: Int
ncols = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Block]
blks
  let textwidth :: Double
textwidth = Double
7920  -- 5.5 in in twips       (1 twip == 1/20 pt)
  let cellfrac :: Double
cellfrac = Double
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ncols
  let colwidth :: Text
colwidth = forall a. Show a => a -> Text
tshow @Integer forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
textwidth forall a. Num a => a -> a -> a
* Double
cellfrac) -- twips
  let gridCols :: [Element]
gridCols = forall a. Int -> a -> [a]
replicate Int
ncols forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:gridCol" [(Text
"w:w", Text
colwidth)] ()
  let scaleImage :: Inline -> Inline
scaleImage = \case
        Image attr :: (Text, [Text], [(Text, Text)])
attr@(Text
ident, [Text]
classes, [(Text, Text)]
attribs) [Inline]
alt (Text, Text)
tgt ->
          let dimWidth :: Dimension
dimWidth  = case Direction -> (Text, [Text], [(Text, Text)]) -> Maybe Dimension
dimension Direction
Width (Text, [Text], [(Text, Text)])
attr of
                            Maybe Dimension
Nothing -> Double -> Dimension
Percent (Double
cellfrac forall a. Num a => a -> a -> a
* Double
100)
                            Just Dimension
d  -> Double -> Dimension -> Dimension
scaleDimension Double
cellfrac Dimension
d
              dimHeight :: Maybe Dimension
dimHeight = Double -> Dimension -> Dimension
scaleDimension Double
cellfrac forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Direction -> (Text, [Text], [(Text, Text)]) -> Maybe Dimension
dimension Direction
Height (Text, [Text], [(Text, Text)])
attr
              attribs' :: [(Text, Text)]
attribs' = (forall a. Show a => a -> Text
tshow Direction
Width, forall a. Show a => a -> Text
tshow Dimension
dimWidth) forall a. a -> [a] -> [a]
:
                         (case Maybe Dimension
dimHeight of
                            Maybe Dimension
Nothing -> forall a. a -> a
id
                            Just Dimension
h  -> ((forall a. Show a => a -> Text
tshow Direction
Height, forall a. Show a => a -> Text
tshow Dimension
h) forall a. a -> [a] -> [a]
:))
                         [ (Text
k, Text
v) | (Text
k, Text
v) <- [(Text, Text)]
attribs
                                  , Text
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"width", Text
"height"]
                                  ]
          in (Text, [Text], [(Text, Text)])
-> [Inline] -> (Text, Text) -> Inline
Image (Text
ident, [Text]
classes, [(Text, Text)]
attribs') [Inline]
alt (Text, Text)
tgt
        Inline
x -> Inline
x
  let blockToCell :: Block -> OOXMLCell
blockToCell = (Text, [Text], [(Text, Text)])
-> Alignment -> RowSpan -> ColSpan -> [Block] -> OOXMLCell
Table.OOXMLCell (Text, [Text], [(Text, Text)])
nullAttr Alignment
AlignCenter RowSpan
1 ColSpan
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
scaleImage
  Element
tblBody <- forall (m :: * -> *).
PandocMonad m =>
([Block] -> WS m [Content]) -> OOXMLRow -> WS m Element
Table.rowToOpenXML (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
             RowType
-> (Text, [Text], [(Text, Text)]) -> [OOXMLCell] -> OOXMLRow
Table.OOXMLRow RowType
Table.BodyRow (Text, [Text], [(Text, Text)])
nullAttr forall a b. (a -> b) -> a -> b
$
             forall a b. (a -> b) -> [a] -> [b]
map Block -> OOXMLCell
blockToCell [Block]
blks
  let tbl :: Element
tbl = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:tbl" []
        ( forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:tblPr" []
          ( forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:tblStyle" [(Text
"w:val",Text
"FigureTable")] () forall a. a -> [a] -> [a]
:
            forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:tblW" [ (Text
"w:type", Text
"auto"), (Text
"w:w", Text
"0") ] () forall a. a -> [a] -> [a]
:
            forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:tblLook" [ (Text
"w:firstRow", Text
"0")
                               , (Text
"w:lastRow", Text
"0")
                               , (Text
"w:firstColumn", Text
"0")
                               , (Text
"w:lastColumn", Text
"0")
                               ] () forall a. a -> [a] -> [a]
:
            forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:jc" [(Text
"w:val",Text
"center")] () forall a. a -> [a] -> [a]
:
            []
          )
          forall a. a -> [a] -> [a]
: forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:tblGrid" [] [Element]
gridCols
          forall a. a -> [a] -> [a]
: [Element
tblBody]
        )
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s -> WriterState
s { stInTable :: Bool
stInTable = Bool
False }
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Element -> Content
Elem Element
tbl


definitionListItemToOpenXML  :: (PandocMonad m)
                             => WriterOptions -> ([Inline],[[Block]])
                             -> WS m [Content]
definitionListItemToOpenXML :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> ([Inline], [[Block]]) -> WS m [Content]
definitionListItemToOpenXML WriterOptions
opts ([Inline]
term,[[Block]]
defs) = do
  [Content]
term' <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Definition Term")
           forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts ([Inline] -> Block
Para [Inline]
term)
  [Content]
defs' <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Definition")
           forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts) [[Block]]
defs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Content]
term' forall a. [a] -> [a] -> [a]
++ [Content]
defs'

addList :: (PandocMonad m) => ListMarker -> WS m ()
addList :: forall (m :: * -> *). PandocMonad m => ListMarker -> WS m ()
addList ListMarker
marker = do
  [ListMarker]
lists <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [ListMarker]
stLists
  Maybe Int
lastExampleId <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Maybe Int
stExampleId
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stLists :: [ListMarker]
stLists = [ListMarker]
lists forall a. [a] -> [a] -> [a]
++ case ListMarker
marker of
                                         -- Use only first occurrence of Example for list declaration to avoid overhead
                                         NumberMarker ListNumberStyle
Example ListNumberDelim
_ Int
_ | forall a. Maybe a -> Bool
isJust Maybe Int
lastExampleId -> []
                                         ListMarker
_ -> [ListMarker
marker]
                    , stExampleId :: Maybe Int
stExampleId = case ListMarker
marker of
                                         -- Reuse the same identifier for all other occurrences of Example
                                         NumberMarker ListNumberStyle
Example ListNumberDelim
_ Int
_ -> Maybe Int
lastExampleId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just (Int
baseListId forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [ListMarker]
lists)
                                         ListMarker
_ -> Maybe Int
lastExampleId
                  }

listItemToOpenXML :: (PandocMonad m)
                  => WriterOptions
                  -> Int -> [Block]
                  -> WS m [Content]
listItemToOpenXML :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Int -> [Block] -> WS m [Content]
listItemToOpenXML WriterOptions
opts Int
numid [Block]
bs = do
  Bool
oldInList <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stInList
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stInList :: Bool
stInList = Bool
True }
  let isListBlock :: Block -> Bool
isListBlock = \case
        BulletList{}  -> Bool
True
        OrderedList{} -> Bool
True
        Block
_             -> Bool
False
  -- Prepend an empty string if the first entry is another
  -- list. Otherwise the outer bullet will disappear.
  let bs' :: [Block]
bs' = case [Block]
bs of
                 [] -> []
                 Block
first:[Block]
rest -> if Block -> Bool
isListBlock Block
first
                               then [Inline] -> Block
Plain [Text -> Inline
Str Text
""]forall a. a -> [a] -> [a]
:Block
firstforall a. a -> [a] -> [a]
:[Block]
rest
                               else Block
firstforall a. a -> [a] -> [a]
:[Block]
rest
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stNumIdUsed :: Bool
stNumIdUsed = Bool
False }
  [Content]
contents <- forall (m :: * -> *) a. PandocMonad m => Int -> WS m a -> WS m a
withNumId Int
numid forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
bs'
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stInList :: Bool
stInList = Bool
oldInList }
  forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
contents

-- | Convert a list of inline elements to OpenXML.
inlinesToOpenXML :: PandocMonad m => WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts) [Inline]
lst

withNumId :: (PandocMonad m) => Int -> WS m a -> WS m a
withNumId :: forall (m :: * -> *) a. PandocMonad m => Int -> WS m a -> WS m a
withNumId Int
numid = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \WriterEnv
env -> WriterEnv
env{ envListNumId :: Int
envListNumId = Int
numid }

asList :: (PandocMonad m) => WS m a -> WS m a
asList :: forall (m :: * -> *) a. PandocMonad m => WS m a -> WS m a
asList = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ \WriterEnv
env -> WriterEnv
env{ envListLevel :: Int
envListLevel = WriterEnv -> Int
envListLevel WriterEnv
env forall a. Num a => a -> a -> a
+ Int
1 }

getTextProps :: (PandocMonad m) => WS m [Element]
getTextProps :: forall (m :: * -> *). PandocMonad m => WS m [Element]
getTextProps = do
  EnvProps
props <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> EnvProps
envTextProperties
  Maybe Text
mblang <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Maybe Text
envLang
  let langnode :: EnvProps
langnode = case Maybe Text
mblang of
                   Maybe Text
Nothing -> forall a. Monoid a => a
mempty
                   Just Text
l  -> Maybe Element -> [Element] -> EnvProps
EnvProps forall a. Maybe a
Nothing
                               [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:lang" [(Text
"w:val", Text
l)] ()]
  let squashed :: [Element]
squashed = EnvProps -> [Element]
squashProps (EnvProps
props forall a. Semigroup a => a -> a -> a
<> EnvProps
langnode)
  forall (m :: * -> *) a. Monad m => a -> m a
return [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" [] [Element]
squashed | (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [Element]
squashed]

withTextProp :: PandocMonad m => Element -> WS m a -> WS m a
withTextProp :: forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp Element
d WS m a
p =
  forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env {envTextProperties :: EnvProps
envTextProperties = EnvProps
ep forall a. Semigroup a => a -> a -> a
<> WriterEnv -> EnvProps
envTextProperties WriterEnv
env}) WS m a
p
  where ep :: EnvProps
ep = if Element -> Bool
isStyle Element
d then Maybe Element -> [Element] -> EnvProps
EnvProps (forall a. a -> Maybe a
Just Element
d) [] else Maybe Element -> [Element] -> EnvProps
EnvProps forall a. Maybe a
Nothing [Element
d]

withTextPropM :: PandocMonad m => WS m Element -> WS m a -> WS m a
withTextPropM :: forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM WS m Element
md WS m a
p = do
  Element
d <- WS m Element
md
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp Element
d WS m a
p

getParaProps :: PandocMonad m => Bool -> WS m [Element]
getParaProps :: forall (m :: * -> *). PandocMonad m => Bool -> WS m [Element]
getParaProps Bool
displayMathPara = do
  EnvProps
props <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> EnvProps
envParaProperties
  Int
listLevel <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envListLevel
  Int
numid <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envListNumId
  Bool
numIdUsed <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stNumIdUsed
  -- clear numId after first use to support multiple paragraphs in the same bullet
  -- baseListId is the code for no list marker
  let numid' :: Int
numid' = if Bool
numIdUsed then Int
baseListId else Int
numid
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stNumIdUsed :: Bool
stNumIdUsed = Bool
True }
  let listPr :: [Element]
listPr = [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:numPr" []
                [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:ilvl" [(Text
"w:val",forall a. Show a => a -> Text
tshow Int
listLevel)] ()
                , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:numId" [(Text
"w:val",forall a. Show a => a -> Text
tshow Int
numid')] () ] | Int
listLevel forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
displayMathPara]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [Element]
listPr forall a. [a] -> [a] -> [a]
++ EnvProps -> [Element]
squashProps EnvProps
props of
                [] -> []
                [Element]
ps -> [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:pPr" [] [Element]
ps]

formattedString :: PandocMonad m => Text -> WS m [Element]
formattedString :: forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString Text
str =
  -- properly handle soft hyphens
  case (Char -> Bool) -> Text -> [Text]
splitTextBy (forall a. Eq a => a -> a -> Bool
==Char
'\173') Text
str of
      [Text
w] -> forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString' Text
w
      [Text]
ws  -> do
         [Element]
sh <- forall (m :: * -> *). PandocMonad m => [Element] -> WS m [Element]
formattedRun [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:softHyphen" [] ()]
         forall a. [a] -> [[a]] -> [a]
intercalate [Element]
sh forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString' [Text]
ws

formattedString' :: PandocMonad m => Text -> WS m [Element]
formattedString' :: forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString' Text
str = do
  Bool
inDel <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envInDel
  forall (m :: * -> *). PandocMonad m => [Element] -> WS m [Element]
formattedRun [ Text -> [(Text, Text)] -> Text -> Element
mktnode (if Bool
inDel then Text
"w:delText" else Text
"w:t")
                 [(Text
"xml:space",Text
"preserve")] (Text -> Text
stripInvalidChars Text
str) ]

formattedRun :: PandocMonad m => [Element] -> WS m [Element]
formattedRun :: forall (m :: * -> *). PandocMonad m => [Element] -> WS m [Element]
formattedRun [Element]
els = do
  [Element]
props <- forall (m :: * -> *). PandocMonad m => WS m [Element]
getTextProps
  forall (m :: * -> *) a. Monad m => a -> m a
return [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" [] forall a b. (a -> b) -> a -> b
$ [Element]
props forall a. [a] -> [a] -> [a]
++ [Element]
els ]

-- | Convert an inline element to OpenXML.
inlineToOpenXML :: PandocMonad m => WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts Inline
il = forall (m :: * -> *) a. PandocMonad m => WS m a -> WS m a
withDirection forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML' WriterOptions
opts Inline
il

inlineToOpenXML' :: PandocMonad m => WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML' :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML' WriterOptions
_ (Str Text
str) =
  forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString Text
str
inlineToOpenXML' WriterOptions
opts Inline
Space = forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts (Text -> Inline
Str Text
" ")
inlineToOpenXML' WriterOptions
opts Inline
SoftBreak = forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts (Text -> Inline
Str Text
" ")
inlineToOpenXML' WriterOptions
opts (Span (Text
"",[Text
"mark"],[]) [Inline]
ils) =
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:highlight" [(Text
"w:val",Text
"yellow")] ()) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' WriterOptions
opts (Span (Text
"",[Text
"csl-block"],[]) [Inline]
ils) =
  forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' WriterOptions
opts (Span (Text
"",[Text
"csl-left-margin"],[]) [Inline]
ils) =
  forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' WriterOptions
opts (Span (Text
"",[Text
"csl-right-inline"],[]) [Inline]
ils) =
   ([Element -> Content
Elem forall a b. (a -> b) -> a -> b
$
     forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" []
     (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:t"
       [(Text
"xml:space",Text
"preserve")]
       (Text
"\t" :: Text))] forall a. [a] -> [a] -> [a]
++)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' WriterOptions
opts (Span (Text
"",[Text
"csl-indent"],[]) [Inline]
ils) =
  forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' WriterOptions
_ (Span (Text
ident,[Text
"comment-start"],[(Text, Text)]
kvs) [Inline]
ils) = do
  -- prefer the "id" in kvs, since that is the one produced by the docx
  -- reader.
  let ident' :: Text
ident' = forall a. a -> Maybe a -> a
fromMaybe Text
ident (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"id" [(Text, Text)]
kvs)
      kvs' :: [(Text, Text)]
kvs' = forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
"id" forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Text)]
kvs
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stComments :: [([(Text, Text)], [Inline])]
stComments = ((Text
"id",Text
ident')forall a. a -> [a] -> [a]
:[(Text, Text)]
kvs', [Inline]
ils) forall a. a -> [a] -> [a]
: WriterState -> [([(Text, Text)], [Inline])]
stComments WriterState
st }
  forall (m :: * -> *) a. Monad m => a -> m a
return [ Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:commentRangeStart" [(Text
"w:id", Text
ident')] () ]
inlineToOpenXML' WriterOptions
_ (Span (Text
ident,[Text
"comment-end"],[(Text, Text)]
kvs) [Inline]
_) =
  -- prefer the "id" in kvs, since that is the one produced by the docx
  -- reader.
  let ident' :: Text
ident' = forall a. a -> Maybe a -> a
fromMaybe Text
ident (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"id" [(Text, Text)]
kvs)
  in forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem forall a b. (a -> b) -> a -> b
$
     [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:commentRangeEnd" [(Text
"w:id", Text
ident')] ()
     , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" []
       [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" []
         [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rStyle" [(Text
"w:val", Text
"CommentReference")] () ]
       , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:commentReference" [(Text
"w:id", Text
ident')] () ]
     ]
inlineToOpenXML' WriterOptions
opts (Span (Text
ident,[Text]
classes,[(Text, Text)]
kvs) [Inline]
ils) = do
  ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
stylemod <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
dynamicStyleKey [(Text, Text)]
kvs of
                   Just (forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack -> CharStyleName
sty) -> do
                      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s ->
                        WriterState
s{stDynamicTextProps :: Set CharStyleName
stDynamicTextProps = forall a. Ord a => a -> Set a -> Set a
Set.insert CharStyleName
sty
                              (WriterState -> Set CharStyleName
stDynamicTextProps WriterState
s)}
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM CharStyleName
sty)
                   Maybe Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
  let dirmod :: ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
dirmod = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"dir" [(Text, Text)]
kvs of
                 Just Text
"rtl" -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envRTL :: Bool
envRTL = Bool
True })
                 Just Text
"ltr" -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env { envRTL :: Bool
envRTL = Bool
False })
                 Maybe Text
_          -> forall a. a -> a
id
      off :: Text -> WS m a -> WS m a
off Text
x = forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
x [(Text
"w:val",Text
"0")] ())
      pmod :: WS m a -> WS m a
pmod =  (if Text
"csl-no-emph" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes then forall {m :: * -> *} {a}. PandocMonad m => Text -> WS m a -> WS m a
off Text
"w:i" else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              (if Text
"csl-no-strong" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes then forall {m :: * -> *} {a}. PandocMonad m => Text -> WS m a -> WS m a
off Text
"w:b" else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              (if Text
"csl-no-smallcaps" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
                  then forall {m :: * -> *} {a}. PandocMonad m => Text -> WS m a -> WS m a
off Text
"w:smallCaps"
                  else forall a. a -> a
id)
      getChangeAuthorDate :: ReaderT WriterEnv (StateT WriterState m) [(Text, Text)]
getChangeAuthorDate = do
        Text
defaultAuthor <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Text
envChangesAuthor
        let author :: Text
author = forall a. a -> Maybe a -> a
fromMaybe Text
defaultAuthor (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"author" [(Text, Text)]
kvs)
        let mdate :: Maybe Text
mdate = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"date" [(Text, Text)]
kvs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Text
"w:author", Text
author) forall a. a -> [a] -> [a]
:
                   forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
date -> [(Text
"w:date", Text
date)]) Maybe Text
mdate
  ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
insmod <- if Text
"insertion" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
               then do
                 [(Text, Text)]
changeAuthorDate <- ReaderT WriterEnv (StateT WriterState m) [(Text, Text)]
getChangeAuthorDate
                 Int
insId <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stInsId
                 forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s -> WriterState
s{stInsId :: Int
stInsId = Int
insId forall a. Num a => a -> a -> a
+ Int
1}
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ReaderT WriterEnv (StateT WriterState m) [Content]
f -> do
                   [Content]
x <- ReaderT WriterEnv (StateT WriterState m) [Content]
f
                   forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem forall a b. (a -> b) -> a -> b
$
                           forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:ins"
                             ((Text
"w:id", forall a. Show a => a -> Text
tshow Int
insId) forall a. a -> [a] -> [a]
: [(Text, Text)]
changeAuthorDate) [Content]
x]
               else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
  ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
delmod <- if Text
"deletion" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
               then do
                 [(Text, Text)]
changeAuthorDate <- ReaderT WriterEnv (StateT WriterState m) [(Text, Text)]
getChangeAuthorDate
                 Int
delId <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stDelId
                 forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s -> WriterState
s{stDelId :: Int
stDelId = Int
delId forall a. Num a => a -> a -> a
+ Int
1}
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ReaderT WriterEnv (StateT WriterState m) [Content]
f -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env->WriterEnv
env{envInDel :: Bool
envInDel=Bool
True}) forall a b. (a -> b) -> a -> b
$ do
                   [Content]
x <- ReaderT WriterEnv (StateT WriterState m) [Content]
f
                   forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:del"
                             ((Text
"w:id", forall a. Show a => a -> Text
tshow Int
delId) forall a. a -> [a] -> [a]
: [(Text, Text)]
changeAuthorDate) [Content]
x]
               else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id
  let langmod :: ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
langmod = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"lang" [(Text, Text)]
kvs of
                  Maybe Text
Nothing -> forall a. a -> a
id
                  Just Text
lang -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env{envLang :: Maybe Text
envLang = forall a. a -> Maybe a
Just Text
lang})
  [Content]
contents <- ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
insmod forall a b. (a -> b) -> a -> b
$ ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
delmod forall a b. (a -> b) -> a -> b
$ forall {a}.
ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
dirmod forall a b. (a -> b) -> a -> b
$ ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
stylemod forall a b. (a -> b) -> a -> b
$ forall {a}.
ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
pmod forall a b. (a -> b) -> a -> b
$
              forall {a}.
ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
langmod forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
  forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
ident [Content]
contents
inlineToOpenXML' WriterOptions
opts (Strong [Inline]
lst) =
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:b" [] ()) forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:bCs" [] ()) forall a b. (a -> b) -> a -> b
$ -- needed for LTR, #6911
  forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' WriterOptions
opts (Emph [Inline]
lst) =
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:i" [] ()) forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:iCs" [] ()) forall a b. (a -> b) -> a -> b
$  -- needed for LTR, #6911
  forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' WriterOptions
opts (Underline [Inline]
lst) =
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:u" [(Text
"w:val",Text
"single")] ()) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' WriterOptions
opts (Subscript [Inline]
lst) =
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:vertAlign" [(Text
"w:val",Text
"subscript")] ())
  forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' WriterOptions
opts (Superscript [Inline]
lst) =
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:vertAlign" [(Text
"w:val",Text
"superscript")] ())
  forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' WriterOptions
opts (SmallCaps [Inline]
lst) =
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:smallCaps" [] ())
  forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' WriterOptions
opts (Strikeout [Inline]
lst) =
  forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:strike" [] ())
  forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' WriterOptions
_ Inline
LineBreak = forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem Element
br]
inlineToOpenXML' WriterOptions
_ il :: Inline
il@(RawInline Format
f Text
str)
  | Format
f forall a. Eq a => a -> a -> Bool
== Text -> Format
Format Text
"openxml" = forall (m :: * -> *) a. Monad m => a -> m a
return
                            [CData -> Content
Text (CDataKind -> Text -> Maybe Integer -> CData
CData CDataKind
CDataRaw Text
str forall a. Maybe a
Nothing)]
  | Bool
otherwise             = do
      forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Inline -> LogMessage
InlineNotRendered Inline
il
      forall (m :: * -> *) a. Monad m => a -> m a
return []
inlineToOpenXML' WriterOptions
opts (Quoted QuoteType
quoteType [Inline]
lst) =
  forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts forall a b. (a -> b) -> a -> b
$ [Text -> Inline
Str Text
open] forall a. [a] -> [a] -> [a]
++ [Inline]
lst forall a. [a] -> [a] -> [a]
++ [Text -> Inline
Str Text
close]
    where (Text
open, Text
close) = case QuoteType
quoteType of
                            QuoteType
SingleQuote -> (Text
"\x2018", Text
"\x2019")
                            QuoteType
DoubleQuote -> (Text
"\x201C", Text
"\x201D")
inlineToOpenXML' WriterOptions
opts (Math MathType
mathType Text
str) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MathType
mathType forall a. Eq a => a -> a -> Bool
== MathType
DisplayMath) forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
  Either Inline Element
res <- (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (forall (m :: * -> *) a.
PandocMonad m =>
(DisplayType -> [Exp] -> a)
-> MathType -> Text -> m (Either Inline a)
convertMath DisplayType -> [Exp] -> Element
writeOMML MathType
mathType Text
str)
  case Either Inline Element
res of
       Right Element
r -> forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ Element -> Element
fromXLElement Element
r]
       Left Inline
il -> forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML' WriterOptions
opts Inline
il
inlineToOpenXML' WriterOptions
opts (Cite [Citation]
_ [Inline]
lst) = forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' WriterOptions
opts (Code (Text, [Text], [(Text, Text)])
attrs Text
str) = do
  let alltoktypes :: [TokenType]
alltoktypes = [TokenType
KeywordTok ..]
  [(TokenType, Element)]
tokTypesMap <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\TokenType
tt -> (,) TokenType
tt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM (forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show TokenType
tt)) [TokenType]
alltoktypes
  let unhighlighted :: ReaderT WriterEnv (StateT WriterState m) [Content]
unhighlighted = (forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
intercalate [Element
br]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
                       forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString (Text -> [Text]
T.lines Text
str)
      formatOpenXML :: p -> [[(TokenType, t)]] -> [Element]
formatOpenXML p
_fmtOpts = forall a. [a] -> [[a]] -> [a]
intercalate [Element
br] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall {t}. Node t => (TokenType, t) -> Element
toHlTok)
      toHlTok :: (TokenType, t) -> Element
toHlTok (TokenType
toktype,t
tok) =
        forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" []
          [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" [] forall a b. (a -> b) -> a -> b
$
            forall a. Maybe a -> [a]
maybeToList (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TokenType
toktype [(TokenType, Element)]
tokTypesMap)
            , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:t" [(Text
"xml:space",Text
"preserve")] t
tok ]
  forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM CharStyleName
"Verbatim Char")
    forall a b. (a -> b) -> a -> b
$ if forall a. Maybe a -> Bool
isNothing (WriterOptions -> Maybe Style
writerHighlightStyle WriterOptions
opts)
          then ReaderT WriterEnv (StateT WriterState m) [Content]
unhighlighted
          else case forall a.
SyntaxMap
-> (FormatOptions -> [SourceLine] -> a)
-> (Text, [Text], [(Text, Text)])
-> Text
-> Either Text a
highlight (WriterOptions -> SyntaxMap
writerSyntaxMap WriterOptions
opts)
                      forall {t} {p}. Node t => p -> [[(TokenType, t)]] -> [Element]
formatOpenXML (Text, [Text], [(Text, Text)])
attrs Text
str of
                    Right [Element]
h  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
h)
                    Left Text
msg -> do
                      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
msg) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
CouldNotHighlight Text
msg
                      ReaderT WriterEnv (StateT WriterState m) [Content]
unhighlighted
inlineToOpenXML' WriterOptions
opts (Note [Block]
bs) = do
  [Element]
notes <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [Element]
stFootnotes
  Text
notenum <- forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
  Element
footnoteStyle <- forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM CharStyleName
"Footnote Reference"
  let notemarker :: Element
notemarker = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" []
                   [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" [] Element
footnoteStyle
                   , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:footnoteRef" [] () ]
  let notemarkerXml :: Inline
notemarkerXml = Format -> Text -> Inline
RawInline (Text -> Format
Format Text
"openxml") forall a b. (a -> b) -> a -> b
$ Element -> Text
ppElement Element
notemarker
  let insertNoteRef :: [Block] -> [Block]
insertNoteRef (Plain [Inline]
ils : [Block]
xs) = [Inline] -> Block
Plain (Inline
notemarkerXml forall a. a -> [a] -> [a]
: Inline
Space forall a. a -> [a] -> [a]
: [Inline]
ils) forall a. a -> [a] -> [a]
: [Block]
xs
      insertNoteRef (Para [Inline]
ils  : [Block]
xs) = [Inline] -> Block
Para  (Inline
notemarkerXml forall a. a -> [a] -> [a]
: Inline
Space forall a. a -> [a] -> [a]
: [Inline]
ils) forall a. a -> [a] -> [a]
: [Block]
xs
      insertNoteRef [Block]
xs               = [Inline] -> Block
Para [Inline
notemarkerXml] forall a. a -> [a] -> [a]
: [Block]
xs

  [Content]
contents <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\WriterEnv
env -> WriterEnv
env{ envListLevel :: Int
envListLevel = -Int
1
                                , envParaProperties :: EnvProps
envParaProperties = forall a. Monoid a => a
mempty
                                , envTextProperties :: EnvProps
envTextProperties = forall a. Monoid a => a
mempty
                                , envInNote :: Bool
envInNote = Bool
True })
              (forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
"Footnote Text") forall a b. (a -> b) -> a -> b
$
               forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts forall a b. (a -> b) -> a -> b
$ [Block] -> [Block]
insertNoteRef [Block]
bs)
  let newnote :: Element
newnote = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:footnote" [(Text
"w:id", Text
notenum)] [Content]
contents
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
s -> WriterState
s{ stFootnotes :: [Element]
stFootnotes = Element
newnote forall a. a -> [a] -> [a]
: [Element]
notes }
  forall (m :: * -> *) a. Monad m => a -> m a
return [ Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" []
           [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rPr" [] Element
footnoteStyle
           , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:footnoteReference" [(Text
"w:id", Text
notenum)] () ] ]
-- internal link:
inlineToOpenXML' WriterOptions
opts (Link (Text, [Text], [(Text, Text)])
_ [Inline]
txt (Text -> Maybe (Char, Text)
T.uncons -> Just (Char
'#', Text
xs),Text
_)) = do
  [Content]
contents <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM CharStyleName
"Hyperlink") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
txt
  forall (m :: * -> *) a. Monad m => a -> m a
return
    [ Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:hyperlink" [(Text
"w:anchor", Text -> Text
toBookmarkName Text
xs)] [Content]
contents ]
-- external link:
inlineToOpenXML' WriterOptions
opts (Link (Text, [Text], [(Text, Text)])
_ [Inline]
txt (Text
src,Text
_)) = do
  [Content]
contents <- forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM CharStyleName
"Hyperlink") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
txt
  Map Text Text
extlinks <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Text Text
stExternalLinks
  Text
id' <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
src Map Text Text
extlinks of
            Just Text
i   -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
            Maybe Text
Nothing  -> do
              Text
i <- (Text
"rId" forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
              forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st{ stExternalLinks :: Map Text Text
stExternalLinks =
                        forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
src Text
i Map Text Text
extlinks }
              forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
  forall (m :: * -> *) a. Monad m => a -> m a
return [ Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:hyperlink" [(Text
"r:id",Text
id')] [Content]
contents ]
inlineToOpenXML' WriterOptions
opts (Image attr :: (Text, [Text], [(Text, Text)])
attr@(Text
imgident, [Text]
_, [(Text, Text)]
_) [Inline]
alt (Text
src, Text
title)) = do
  Integer
pageWidth <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Integer
envPrintWidth
  Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
imgs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages
  let
    stImage :: Maybe (FilePath, FilePath, Maybe Text, ByteString)
stImage = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> FilePath
T.unpack Text
src) Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
imgs
    generateImgElt :: (FilePath, b, Maybe Text, ByteString)
-> ReaderT WriterEnv (StateT WriterState m) [Content]
generateImgElt (FilePath
ident, b
_fp, Maybe Text
mt, ByteString
img) = do
      Text
docprid <- forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
      Text
nvpicprid <- forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
      ([(Text, Text)]
blipAttrs, [Element]
blipContents) <-
        case (Char -> Bool) -> Text -> Text
T.takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
';') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mt of
          Just Text
"image/svg+xml" -> do
            -- get fallback png
            MediaBag
mediabag <- forall (m :: * -> *). PandocMonad m => m MediaBag
getMediaBag
            Maybe FilePath
mbFallback <-
              case FilePath -> MediaBag -> Maybe MediaItem
lookupMedia (Text -> FilePath
T.unpack (Text
src forall a. Semigroup a => a -> a -> a
<> Text
".png")) MediaBag
mediabag of
                Just MediaItem
item -> do
                  FilePath
id' <- Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"rId" forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
                  let fp' :: FilePath
fp' = FilePath
"media/" forall a. Semigroup a => a -> a -> a
<> FilePath
id' forall a. Semigroup a => a -> a -> a
<> FilePath
".png"
                  let imgdata :: (FilePath, FilePath, Maybe Text, ByteString)
imgdata = (FilePath
id',
                                 FilePath
fp',
                                 forall a. a -> Maybe a
Just (MediaItem -> Text
mediaMimeType MediaItem
item),
                                 ByteString -> ByteString
BL.toStrict forall a b. (a -> b) -> a -> b
$ MediaItem -> ByteString
mediaContents MediaItem
item)
                  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st { stImages :: Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages =
                            forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
fp' (FilePath, FilePath, Maybe Text, ByteString)
imgdata forall a b. (a -> b) -> a -> b
$ WriterState
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages WriterState
st }
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FilePath
id'
                Maybe MediaItem
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            let extLst :: Element
extLst = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:extLst" []
                            [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:ext"
                              [(Text
"uri",Text
"{28A0092B-C50C-407E-A947-70E740481C1C}")]
                              [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a14:useLocalDpi"
                                [(Text
"xmlns:a14",Text
"http://schemas.microsoft.com/office/drawing/2010/main"),
                                 (Text
"val",Text
"0")] () ]
                            , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:ext"
                              [(Text
"uri",Text
"{96DAC541-7B7A-43D3-8B79-37D633B846F1}")]
                              [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"asvg:svgBlip"
                                [(Text
"xmlns:asvg", Text
"http://schemas.microsoft.com/office/drawing/2016/SVG/main"),
                                 (Text
"r:embed",FilePath -> Text
T.pack FilePath
ident)] () ]
                            ]
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
id'' -> [(Text
"r:embed", FilePath -> Text
T.pack FilePath
id'')]) Maybe FilePath
mbFallback,
                    [Element
extLst])
          Maybe Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text
"r:embed", FilePath -> Text
T.pack FilePath
ident)], [])
      let
        (Double
xpt,Double
ypt) = WriterOptions
-> (Text, [Text], [(Text, Text)]) -> ImageSize -> (Double, Double)
desiredSizeInPoints WriterOptions
opts (Text, [Text], [(Text, Text)])
attr
               (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Default a => a
def) forall a. a -> a
id (WriterOptions -> ByteString -> Either Text ImageSize
imageSize WriterOptions
opts ByteString
img))
        -- 12700 emu = 1 pt
        pageWidthPt :: Integer
pageWidthPt = case Direction -> (Text, [Text], [(Text, Text)]) -> Maybe Dimension
dimension Direction
Width (Text, [Text], [(Text, Text)])
attr of
                        Just (Percent Double
a) -> Integer
pageWidth forall a. Num a => a -> a -> a
* (forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Double
a forall a. Num a => a -> a -> a
* Double
127)
                        Maybe Dimension
_                -> Integer
pageWidth forall a. Num a => a -> a -> a
* Integer
12700
        (Integer
xemu,Integer
yemu) = (Double, Double) -> Integer -> (Integer, Integer)
fitToPage (Double
xpt forall a. Num a => a -> a -> a
* Double
12700, Double
ypt forall a. Num a => a -> a -> a
* Double
12700) Integer
pageWidthPt
        cNvPicPr :: Element
cNvPicPr = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"pic:cNvPicPr" [] forall a b. (a -> b) -> a -> b
$
                         forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:picLocks" [(Text
"noChangeArrowheads",Text
"1")
                                             ,(Text
"noChangeAspect",Text
"1")] ()
        nvPicPr :: Element
nvPicPr  = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"pic:nvPicPr" []
                        [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"pic:cNvPr"
                            [(Text
"descr",Text
src)
                            ,(Text
"id", Text
nvpicprid)
                            ,(Text
"name",Text
"Picture")] ()
                        , Element
cNvPicPr ]
        blipFill :: Element
blipFill = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"pic:blipFill" []
          [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:blip" [(Text, Text)]
blipAttrs [Element]
blipContents
          , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:stretch" [] forall a b. (a -> b) -> a -> b
$
              forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:fillRect" [] ()
          ]
        xfrm :: Element
xfrm =    forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:xfrm" []
                        [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:off" [(Text
"x",Text
"0"),(Text
"y",Text
"0")] ()
                        , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:ext" [(Text
"cx",forall a. Show a => a -> Text
tshow Integer
xemu)
                                         ,(Text
"cy",forall a. Show a => a -> Text
tshow Integer
yemu)] () ]
        prstGeom :: Element
prstGeom = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:prstGeom" [(Text
"prst",Text
"rect")] forall a b. (a -> b) -> a -> b
$
                         forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:avLst" [] ()
        ln :: Element
ln =      forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:ln" [(Text
"w",Text
"9525")]
                        [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:noFill" [] ()
                        , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:headEnd" [] ()
                        , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:tailEnd" [] () ]
        spPr :: Element
spPr =    forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"pic:spPr" [(Text
"bwMode",Text
"auto")]
                        [Element
xfrm, Element
prstGeom, forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:noFill" [] (), Element
ln]
        graphic :: Element
graphic = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:graphic" [] forall a b. (a -> b) -> a -> b
$
          forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"a:graphicData"
            [(Text
"uri",Text
"http://schemas.openxmlformats.org/drawingml/2006/picture")]
            [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"pic:pic" []
              [ Element
nvPicPr
              , Element
blipFill
              , Element
spPr
              ]
            ]
        imgElt :: Element
imgElt = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" [] forall a b. (a -> b) -> a -> b
$
          forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:drawing" [] forall a b. (a -> b) -> a -> b
$
            forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"wp:inline" []
              [ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"wp:extent" [(Text
"cx",forall a. Show a => a -> Text
tshow Integer
xemu),(Text
"cy",forall a. Show a => a -> Text
tshow Integer
yemu)] ()
              , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"wp:effectExtent"
                [(Text
"b",Text
"0"),(Text
"l",Text
"0"),(Text
"r",Text
"0"),(Text
"t",Text
"0")] ()
              , forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"wp:docPr"
                [ (Text
"descr", forall a. Walkable Inline a => a -> Text
stringify [Inline]
alt)
                , (Text
"title", Text
title)
                , (Text
"id", Text
docprid)
                , (Text
"name",Text
"Picture")
                ] ()
              , Element
graphic
              ]
      forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem Element
imgElt]

  forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
imgident forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Maybe (FilePath, FilePath, Maybe Text, ByteString)
stImage of
    Just (FilePath, FilePath, Maybe Text, ByteString)
imgData -> forall {m :: * -> *} {b}.
PandocMonad m =>
(FilePath, b, Maybe Text, ByteString)
-> ReaderT WriterEnv (StateT WriterState m) [Content]
generateImgElt (FilePath, FilePath, Maybe Text, ByteString)
imgData
    Maybe (FilePath, FilePath, Maybe Text, ByteString)
Nothing -> ( do --try
      (ByteString
img, Maybe Text
mt) <- forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem Text
src
      Text
ident <- (Text
"rId" forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId

      let
        imgext :: Text
imgext = case Maybe Text
mt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Text
extensionFromMimeType of
          Just Text
x    -> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
x
          Maybe Text
Nothing   -> case ByteString -> Maybe ImageType
imageType ByteString
img of
            Just ImageType
Png  -> Text
".png"
            Just ImageType
Jpeg -> Text
".jpeg"
            Just ImageType
Gif  -> Text
".gif"
            Just ImageType
Pdf  -> Text
".pdf"
            Just ImageType
Eps  -> Text
".eps"
            Just ImageType
Svg  -> Text
".svg"
            Just ImageType
Emf  -> Text
".emf"
            Just ImageType
Tiff -> Text
".tiff"
            Maybe ImageType
Nothing   -> Text
""
        imgpath :: Text
imgpath = Text
"media/" forall a. Semigroup a => a -> a -> a
<> Text
ident forall a. Semigroup a => a -> a -> a
<> Text
imgext
        mbMimeType :: Maybe Text
mbMimeType = Maybe Text
mt forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePath -> Maybe Text
getMimeType (Text -> FilePath
T.unpack Text
imgpath)

        imgData :: (FilePath, FilePath, Maybe Text, ByteString)
imgData = (Text -> FilePath
T.unpack Text
ident, Text -> FilePath
T.unpack Text
imgpath, Maybe Text
mbMimeType, ByteString
img)

      if Text -> Bool
T.null Text
imgext
         then -- without an extension there is no rule for content type
           forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
alt -- return alt to avoid corrupted docx
         else do
           -- insert mime type to use in constructing [Content_Types].xml
           forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \WriterState
st -> WriterState
st { stImages :: Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text -> FilePath
T.unpack Text
src) (FilePath, FilePath, Maybe Text, ByteString)
imgData forall a b. (a -> b) -> a -> b
$ WriterState
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages WriterState
st }
           forall {m :: * -> *} {b}.
PandocMonad m =>
(FilePath, b, Maybe Text, ByteString)
-> ReaderT WriterEnv (StateT WriterState m) [Content]
generateImgElt (FilePath, FilePath, Maybe Text, ByteString)
imgData
      )
      forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` ( \PandocError
e -> do
        forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Text -> Text -> LogMessage
CouldNotFetchResource Text
src forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show PandocError
e)
        -- emit alt text
        forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
alt
      )

br :: Element
br :: Element
br = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:r" [] [forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:br" [] ()]


withDirection :: PandocMonad m => WS m a -> WS m a
withDirection :: forall (m :: * -> *) a. PandocMonad m => WS m a -> WS m a
withDirection WS m a
x = do
  Bool
isRTL <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envRTL
  EnvProps
paraProps <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> EnvProps
envParaProperties
  EnvProps
textProps <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> EnvProps
envTextProperties
  -- We want to clean all bidirection (bidi) and right-to-left (rtl)
  -- properties from the props first. This is because we don't want
  -- them to stack up.
  let paraProps' :: [Element]
paraProps' = forall a. (a -> Bool) -> [a] -> [a]
filter (\Element
e -> (QName -> Text
qName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> QName
elName) Element
e forall a. Eq a => a -> a -> Bool
/= Text
"bidi") (EnvProps -> [Element]
otherElements EnvProps
paraProps)
      textProps' :: [Element]
textProps' = forall a. (a -> Bool) -> [a] -> [a]
filter (\Element
e -> (QName -> Text
qName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> QName
elName) Element
e forall a. Eq a => a -> a -> Bool
/= Text
"rtl") (EnvProps -> [Element]
otherElements EnvProps
textProps)
      paraStyle :: Maybe Element
paraStyle = EnvProps -> Maybe Element
styleElement EnvProps
paraProps
      textStyle :: Maybe Element
textStyle = EnvProps -> Maybe Element
styleElement EnvProps
textProps
  if Bool
isRTL
    -- if we are going right-to-left, we (re?)add the properties.
    then forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local WS m a
x forall a b. (a -> b) -> a -> b
$
         \WriterEnv
env -> WriterEnv
env { envParaProperties :: EnvProps
envParaProperties = Maybe Element -> [Element] -> EnvProps
EnvProps Maybe Element
paraStyle forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:bidi" [] () forall a. a -> [a] -> [a]
: [Element]
paraProps'
                     , envTextProperties :: EnvProps
envTextProperties = Maybe Element -> [Element] -> EnvProps
EnvProps Maybe Element
textStyle forall a b. (a -> b) -> a -> b
$ forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:rtl" [] () forall a. a -> [a] -> [a]
: [Element]
textProps'
                     }
    else forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local WS m a
x forall a b. (a -> b) -> a -> b
$ \WriterEnv
env -> WriterEnv
env { envParaProperties :: EnvProps
envParaProperties = Maybe Element -> [Element] -> EnvProps
EnvProps Maybe Element
paraStyle [Element]
paraProps'
                                    , envTextProperties :: EnvProps
envTextProperties = Maybe Element -> [Element] -> EnvProps
EnvProps Maybe Element
textStyle [Element]
textProps'
                                    }

wrapBookmark :: (PandocMonad m) => Text -> [Content] -> WS m [Content]
wrapBookmark :: forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
"" [Content]
contents = forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
contents
wrapBookmark Text
ident [Content]
contents = do
  Text
id' <- forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
  let bookmarkStart :: Element
bookmarkStart = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:bookmarkStart"
                       [(Text
"w:id", Text
id')
                       ,(Text
"w:name", Text -> Text
toBookmarkName Text
ident)] ()
      bookmarkEnd :: Element
bookmarkEnd = forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
"w:bookmarkEnd" [(Text
"w:id", Text
id')] ()
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Element -> Content
Elem Element
bookmarkStart forall a. a -> [a] -> [a]
: [Content]
contents forall a. [a] -> [a] -> [a]
++ [Element -> Content
Elem Element
bookmarkEnd]

-- Word imposes a 40 character limit on bookmark names and requires
-- that they begin with a letter.  So we just use a hash of the
-- identifier when otherwise we'd have an illegal bookmark name.
toBookmarkName :: Text -> Text
toBookmarkName :: Text -> Text
toBookmarkName Text
s
  | Just (Char
c, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
s
  , Char -> Bool
isLetter Char
c
  , Text -> Int
T.length Text
s forall a. Ord a => a -> a -> Bool
<= Int
40 = Text
s
  | Bool
otherwise = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Char
'X' forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [a]
drop Int
1 (forall t. Digest t -> FilePath
showDigest (ByteString -> Digest SHA1State
sha1 (Text -> ByteString
fromTextLazy forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict Text
s)))