{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Writers.Docx ( writeDocx ) where
import Codec.Archive.Zip
import Control.Applicative ((<|>))
import Control.Monad.Except (catchError, throwError)
import Control.Monad.Reader
import Control.Monad.State.Strict
import qualified Data.ByteString.Lazy as BL
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)
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.Collate.Lang (renderLang)
import Text.Pandoc.Class (PandocMonad, report, toLang, translateTerm,
getMediaBag)
import Text.Pandoc.MediaBag (lookupMedia, MediaItem(..))
import qualified Text.Pandoc.Translations as Term
import qualified Text.Pandoc.Class.PandocMonad as P
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
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)
squashProps :: EnvProps -> [Element]
squashProps :: EnvProps -> [Element]
squashProps (EnvProps Nothing es :: [Element]
es) = [Element]
es
squashProps (EnvProps (Just e :: Element
e) es :: [Element]
es) = Element
e Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
es
renumIdMap :: Int -> [Element] -> M.Map Text Text
renumIdMap :: Int -> [Element] -> Map Text Text
renumIdMap _ [] = Map Text Text
forall k a. Map k a
M.empty
renumIdMap n :: Int
n (e :: Element
e:es :: [Element]
es)
| Just oldId :: Text
oldId <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e =
Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
oldId ("rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n) (Int -> [Element] -> Map Text Text
renumIdMap (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+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 f :: QName -> Bool
f val :: Text
val = (Attr -> Attr) -> [Attr] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map ((Attr -> Attr) -> [Attr] -> [Attr])
-> (Attr -> Attr) -> [Attr] -> [Attr]
forall a b. (a -> b) -> a -> b
$
\a :: 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 f :: QName -> Bool
f renumMap :: Map Text Text
renumMap e :: Element
e
| Just oldId :: Text
oldId <- (QName -> Bool) -> Element -> Maybe Text
findAttrBy QName -> Bool
f Element
e
, Just newId :: Text
newId <- Text -> Map Text Text -> Maybe Text
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 f :: QName -> Bool
f renumMap :: Map Text Text
renumMap = (Element -> Element) -> [Element] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ((QName -> Bool) -> Map Text Text -> Element -> Element
renumId QName -> Bool
f Map Text Text
renumMap)
stripInvalidChars :: Text -> Text
stripInvalidChars :: Text -> Text
stripInvalidChars = (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
isValidChar
isValidChar :: Char -> Bool
isValidChar :: Char -> Bool
isValidChar '\t' = Bool
True
isValidChar '\n' = Bool
True
isValidChar '\r' = Bool
True
isValidChar '\xFFFE' = Bool
False
isValidChar '\xFFFF' = Bool
False
isValidChar c :: Char
c = (' ' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\xD7FF') Bool -> Bool -> Bool
|| ('\xE000' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c)
writeDocx :: (PandocMonad m)
=> WriterOptions
-> Pandoc
-> m BL.ByteString
writeDocx :: WriterOptions -> Pandoc -> m ByteString
writeDocx opts :: WriterOptions
opts doc :: Pandoc
doc = do
let Pandoc meta :: Meta
meta blocks :: [Block]
blocks = (Block -> Block) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
fixDisplayMath Pandoc
doc
let blocks' :: [Block]
blocks' = Bool -> Maybe Int -> [Block] -> [Block]
makeSections Bool
True Maybe Int
forall a. Maybe a
Nothing [Block]
blocks
let doc' :: Pandoc
doc' = Meta -> [Block] -> Pandoc
Pandoc Meta
meta [Block]
blocks'
Maybe Text
username <- Text -> m (Maybe Text)
forall (m :: * -> *). PandocMonad m => Text -> m (Maybe Text)
P.lookupEnv "USERNAME"
UTCTime
utctime <- m UTCTime
forall (m :: * -> *). PandocMonad m => m UTCTime
P.getTimestamp
Maybe FilePath
oldUserDataDir <- m (Maybe FilePath)
forall (m :: * -> *). PandocMonad m => m (Maybe FilePath)
P.getUserDataDir
Maybe FilePath -> m ()
forall (m :: * -> *). PandocMonad m => Maybe FilePath -> m ()
P.setUserDataDir Maybe FilePath
forall a. Maybe a
Nothing
ByteString
res <- FilePath -> m ByteString
forall (m :: * -> *). PandocMonad m => FilePath -> m ByteString
P.readDefaultDataFile "reference.docx"
Maybe FilePath -> m ()
forall (m :: * -> *). PandocMonad m => Maybe FilePath -> m ()
P.setUserDataDir Maybe FilePath
oldUserDataDir
let distArchive :: Archive
distArchive = ByteString -> Archive
toArchive (ByteString -> Archive) -> ByteString -> Archive
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
res
Archive
refArchive <- case WriterOptions -> Maybe FilePath
writerReferenceDoc WriterOptions
opts of
Just f :: FilePath
f -> ByteString -> Archive
toArchive (ByteString -> Archive) -> m ByteString -> m Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m ByteString
forall (m :: * -> *). PandocMonad m => FilePath -> m ByteString
P.readFileLazy FilePath
f
Nothing -> ByteString -> Archive
toArchive (ByteString -> Archive)
-> (ByteString -> ByteString) -> ByteString -> Archive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> Archive) -> m ByteString -> m Archive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
FilePath -> m ByteString
forall (m :: * -> *). PandocMonad m => FilePath -> m ByteString
P.readDataFile "reference.docx"
Element
parsedDoc <- Archive -> Archive -> FilePath -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "word/document.xml"
let wname :: (Text -> Bool) -> QName -> Bool
wname f :: Text -> Bool
f qn :: QName
qn = QName -> Maybe Text
qPrefix QName
qn Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "w" Bool -> Bool -> Bool
&& Text -> Bool
f (QName -> Text
qName QName
qn)
let mbsectpr :: Maybe Element
mbsectpr = (QName -> Bool) -> Element -> Maybe Element
filterElementName ((Text -> Bool) -> QName -> Bool
wname (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
=="sectPr")) Element
parsedDoc
let mbpgsz :: Maybe Element
mbpgsz = Maybe Element
mbsectpr Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> Element -> Maybe Element
filterElementName ((Text -> Bool) -> QName -> Bool
wname (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
=="pgSz"))
let mbAttrSzWidth :: Maybe Text
mbAttrSzWidth = Maybe Element
mbpgsz Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
=="w") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) ([Attr] -> Maybe Text)
-> (Element -> [Attr]) -> Element -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs
let mbpgmar :: Maybe Element
mbpgmar = Maybe Element
mbsectpr Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> Element -> Maybe Element
filterElementName ((Text -> Bool) -> QName -> Bool
wname (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
=="pgMar"))
let mbAttrMarLeft :: Maybe Text
mbAttrMarLeft = Maybe Element
mbpgmar Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
=="left") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) ([Attr] -> Maybe Text)
-> (Element -> [Attr]) -> Element -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs
let mbAttrMarRight :: Maybe Text
mbAttrMarRight = Maybe Element
mbpgmar Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
=="right") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) ([Attr] -> Maybe Text)
-> (Element -> [Attr]) -> Element -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs
let pgContentWidth :: Maybe Integer
pgContentWidth = do
Integer
w <- Maybe Text
mbAttrSzWidth Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
Integer
r <- Maybe Text
mbAttrMarRight Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
Integer
l <- Maybe Text
mbAttrMarLeft Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
Integer -> Maybe Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
l
Maybe Lang
mblang <- Maybe Text -> m (Maybe Lang)
forall (m :: * -> *). PandocMonad m => Maybe Text -> m (Maybe Lang)
toLang (Maybe Text -> m (Maybe Lang)) -> Maybe Text -> m (Maybe Lang)
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Meta -> Maybe Text
getLang WriterOptions
opts Meta
meta
let addLang :: Element -> Element
addLang :: Element -> Element
addLang = case Maybe Lang
mblang of
Nothing -> Element -> Element
forall a. a -> a
id
Just l :: Lang
l -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Element -> Element) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (Text -> Element -> Element
go (Lang -> Text
renderLang Lang
l)))
where
go :: Text -> Element -> Element
go :: Text -> Element -> Element
go l :: Text
l e' :: Element
e'
| QName -> Text
qName (Element -> QName
elName Element
e') Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "lang"
= Element
e'{ elAttribs :: [Attr]
elAttribs = (Attr -> Attr) -> [Attr] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Attr -> Attr
setvalattr Text
l) ([Attr] -> [Attr]) -> [Attr] -> [Attr]
forall a b. (a -> b) -> a -> b
$ Element -> [Attr]
elAttribs Element
e' }
| Bool
otherwise = Element
e'
setvalattr :: Text -> Attr -> Attr
setvalattr l :: Text
l (XML.Attr qn :: QName
qn@(QName "val" _ _) _) = QName -> Text -> Attr
XML.Attr QName
qn Text
l
setvalattr _ x :: Attr
x = Attr
x
let stylepath :: FilePath
stylepath = "word/styles.xml"
Element
styledoc <- Element -> Element
addLang (Element -> Element) -> m Element -> m Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Archive -> Archive -> FilePath -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive FilePath
stylepath
let styleMaps :: StyleMaps
styleMaps = Archive -> StyleMaps
getStyleMaps Archive
refArchive
let tocTitle :: [Inline]
tocTitle = case Text -> Meta -> [Inline]
lookupMetaInlines "toc-title" Meta
meta of
[] -> WriterState -> [Inline]
stTocTitle WriterState
defaultWriterState
ls :: [Inline]
ls -> [Inline]
ls
let initialSt :: WriterState
initialSt = WriterState
defaultWriterState {
stStyleMaps :: StyleMaps
stStyleMaps = StyleMaps
styleMaps
, stTocTitle :: [Inline]
stTocTitle = [Inline]
tocTitle
, stCurId :: Int
stCurId = 20
}
let isRTLmeta :: Bool
isRTLmeta = case Text -> Meta -> Maybe MetaValue
lookupMeta "dir" Meta
meta of
Just (MetaString "rtl") -> Bool
True
Just (MetaInlines [Str "rtl"]) -> Bool
True
_ -> Bool
False
let env :: WriterEnv
env = WriterEnv
defaultWriterEnv {
envRTL :: Bool
envRTL = Bool
isRTLmeta
, envChangesAuthor :: Text
envChangesAuthor = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "unknown" Maybe Text
username
, envChangesDate :: Text
envChangesDate = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale "%FT%XZ" UTCTime
utctime
, envPrintWidth :: Integer
envPrintWidth = Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 420 (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` 20) Maybe Integer
pgContentWidth
}
((contents :: [Content]
contents, footnotes :: [Element]
footnotes, comments :: [Element]
comments), st :: WriterState
st) <- StateT WriterState m ([Content], [Element], [Element])
-> WriterState
-> m (([Content], [Element], [Element]), WriterState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
(ReaderT
WriterEnv (StateT WriterState m) ([Content], [Element], [Element])
-> WriterEnv
-> StateT WriterState m ([Content], [Element], [Element])
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
(WriterOptions
-> Pandoc
-> ReaderT
WriterEnv (StateT WriterState m) ([Content], [Element], [Element])
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 = POSIXTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer) -> POSIXTime -> Integer
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
utctime
let imgs :: [(FilePath, FilePath, Maybe Text, ByteString)]
imgs = Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> [(FilePath, FilePath, Maybe Text, ByteString)]
forall k a. Map k a -> [a]
M.elems (Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> [(FilePath, FilePath, Maybe Text, ByteString)])
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> [(FilePath, FilePath, Maybe Text, ByteString)]
forall a b. (a -> b) -> a -> b
$ WriterState
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages WriterState
st
let toImageEntry :: (a, FilePath, c, ByteString) -> Entry
toImageEntry (_,path :: FilePath
path,_,img :: ByteString
img) = FilePath -> Integer -> ByteString -> Entry
toEntry ("word/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path) Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toLazy ByteString
img
let imageEntries :: [Entry]
imageEntries = ((FilePath, FilePath, Maybe Text, ByteString) -> Entry)
-> [(FilePath, FilePath, Maybe Text, ByteString)] -> [Entry]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath, Maybe Text, ByteString) -> Entry
forall a c. (a, FilePath, c, ByteString) -> Entry
toImageEntry [(FilePath, FilePath, Maybe Text, ByteString)]
imgs
let stdAttributes :: [(Text, Text)]
stdAttributes =
[("xmlns:w","http://schemas.openxmlformats.org/wordprocessingml/2006/main")
,("xmlns:m","http://schemas.openxmlformats.org/officeDocument/2006/math")
,("xmlns:r","http://schemas.openxmlformats.org/officeDocument/2006/relationships")
,("xmlns:o","urn:schemas-microsoft-com:office:office")
,("xmlns:v","urn:schemas-microsoft-com:vml")
,("xmlns:w10","urn:schemas-microsoft-com:office:word")
,("xmlns:a","http://schemas.openxmlformats.org/drawingml/2006/main")
,("xmlns:pic","http://schemas.openxmlformats.org/drawingml/2006/picture")
,("xmlns:wp","http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing")]
Element
parsedRels <- Archive -> Archive -> FilePath -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "word/_rels/document.xml.rels"
let isHeaderNode :: Element -> Bool
isHeaderNode e :: Element
e = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships/header"
let isFooterNode :: Element -> Bool
isFooterNode e :: Element
e = QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "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 "Target" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing)
let mkOverrideNode :: (FilePath, Text) -> Element
mkOverrideNode (part' :: FilePath
part', contentType' :: Text
contentType') = Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Override"
[("PartName", FilePath -> Text
T.pack FilePath
part')
,("ContentType", Text
contentType')] ()
let mkImageOverride :: (a, FilePath, Maybe Text, d) -> Element
mkImageOverride (_, imgpath :: FilePath
imgpath, mbMimeType :: Maybe Text
mbMimeType, _) =
(FilePath, Text) -> Element
mkOverrideNode ("/word/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
imgpath,
Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "application/octet-stream" Maybe Text
mbMimeType)
let mkMediaOverride :: FilePath -> Element
mkMediaOverride imgpath :: FilePath
imgpath =
(FilePath, Text) -> Element
mkOverrideNode ("/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
imgpath, FilePath -> Text
getMimeTypeDef FilePath
imgpath)
let overrides :: [Element]
overrides = ((FilePath, Text) -> Element) -> [(FilePath, Text)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Text) -> Element
mkOverrideNode (
[("/word/webSettings.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.webSettings+xml")
,("/word/numbering.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.numbering+xml")
,("/word/settings.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.settings+xml")
,("/word/theme/theme1.xml",
"application/vnd.openxmlformats-officedocument.theme+xml")
,("/word/fontTable.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.fontTable+xml")
,("/docProps/app.xml",
"application/vnd.openxmlformats-officedocument.extended-properties+xml")
,("/docProps/core.xml",
"application/vnd.openxmlformats-package.core-properties+xml")
,("/docProps/custom.xml",
"application/vnd.openxmlformats-officedocument.custom-properties+xml")
,("/word/styles.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.styles+xml")
,("/word/document.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.document.main+xml")
,("/word/comments.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.comments+xml")
,("/word/footnotes.xml",
"application/vnd.openxmlformats-officedocument.wordprocessingml.footnotes+xml")
] [(FilePath, Text)] -> [(FilePath, Text)] -> [(FilePath, Text)]
forall a. [a] -> [a] -> [a]
++
(Element -> (FilePath, Text)) -> [Element] -> [(FilePath, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Element
x -> (FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (Text -> FilePath
T.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("/word/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) (Element -> Maybe Text
extractTarget Element
x),
"application/vnd.openxmlformats-officedocument.wordprocessingml.header+xml")) [Element]
headers [(FilePath, Text)] -> [(FilePath, Text)] -> [(FilePath, Text)]
forall a. [a] -> [a] -> [a]
++
(Element -> (FilePath, Text)) -> [Element] -> [(FilePath, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Element
x -> (FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (Text -> FilePath
T.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("/word/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)) (Element -> Maybe Text
extractTarget Element
x),
"application/vnd.openxmlformats-officedocument.wordprocessingml.footer+xml")) [Element]
footers) [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
((FilePath, FilePath, Maybe Text, ByteString) -> Element)
-> [(FilePath, FilePath, Maybe Text, ByteString)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath, Maybe Text, ByteString) -> Element
forall a d. (a, FilePath, Maybe Text, d) -> Element
mkImageOverride [(FilePath, FilePath, Maybe Text, ByteString)]
imgs [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
[ FilePath -> Element
mkMediaOverride (Entry -> FilePath
eRelativePath Entry
e)
| Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
, "word/media/" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> FilePath
eRelativePath Entry
e ]
let defaultnodes :: [Element]
defaultnodes = [Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Default"
[("Extension","xml"),("ContentType","application/xml")] (),
Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Default"
[("Extension","rels"),("ContentType","application/vnd.openxmlformats-package.relationships+xml")] ()]
let contentTypesDoc :: Element
contentTypesDoc = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Types" [("xmlns","http://schemas.openxmlformats.org/package/2006/content-types")] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [Element]
defaultnodes [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
overrides
let contentTypesEntry :: Entry
contentTypesEntry = FilePath -> Integer -> ByteString -> Entry
toEntry "[Content_Types].xml" Integer
epochtime
(ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
contentTypesDoc
let toBaseRel :: (Text, Text, Text) -> Element
toBaseRel (url' :: Text
url', id' :: Text
id', target' :: Text
target') = Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Relationship"
[("Type",Text
url')
,("Id",Text
id')
,("Target",Text
target')] ()
let baserels' :: [Element]
baserels' = ((Text, Text, Text) -> Element)
-> [(Text, Text, Text)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text, Text) -> Element
toBaseRel
[("http://schemas.openxmlformats.org/officeDocument/2006/relationships/numbering",
"rId1",
"numbering.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles",
"rId2",
"styles.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/settings",
"rId3",
"settings.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/webSettings",
"rId4",
"webSettings.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/fontTable",
"rId5",
"fontTable.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/theme",
"rId6",
"theme/theme1.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/footnotes",
"rId7",
"footnotes.xml")
,("http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments",
"rId8",
"comments.xml")
]
let idMap :: Map Text Text
idMap = Int -> [Element] -> Map Text Text
renumIdMap ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
baserels' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ([Element]
headers [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
footers)
let renumHeaders :: [Element]
renumHeaders = (QName -> Bool) -> Map Text Text -> [Element] -> [Element]
renumIds (\q :: QName
q -> QName -> Text
qName QName
q Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Id") Map Text Text
idMap [Element]
headers
let renumFooters :: [Element]
renumFooters = (QName -> Bool) -> Map Text Text -> [Element] -> [Element]
renumIds (\q :: QName
q -> QName -> Text
qName QName
q Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Id") Map Text Text
idMap [Element]
footers
let baserels :: [Element]
baserels = [Element]
baserels' [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
renumHeaders [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
renumFooters
let toImgRel :: (FilePath, FilePath, c, d) -> Element
toImgRel (ident :: FilePath
ident,path :: FilePath
path,_,_) = Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"),("Id",FilePath -> Text
T.pack FilePath
ident),("Target",FilePath -> Text
T.pack FilePath
path)] ()
let imgrels :: [Element]
imgrels = ((FilePath, FilePath, Maybe Text, ByteString) -> Element)
-> [(FilePath, FilePath, Maybe Text, ByteString)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath, Maybe Text, ByteString) -> Element
forall c d. (FilePath, FilePath, c, d) -> Element
toImgRel [(FilePath, FilePath, Maybe Text, ByteString)]
imgs
let toLinkRel :: (Text, Text) -> Element
toLinkRel (src :: Text
src,ident :: Text
ident) = Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Relationship" [("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink"),("Id",Text
ident),("Target",Text
src),("TargetMode","External") ] ()
let linkrels :: [Element]
linkrels = ((Text, Text) -> Element) -> [(Text, Text)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Element
toLinkRel ([(Text, Text)] -> [Element]) -> [(Text, Text)] -> [Element]
forall a b. (a -> b) -> a -> b
$ Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text Text -> [(Text, Text)])
-> Map Text Text -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ WriterState -> Map Text Text
stExternalLinks WriterState
st
let reldoc :: Element
reldoc = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [Element]
baserels [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
imgrels [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
linkrels
let relEntry :: Entry
relEntry = FilePath -> Integer -> ByteString -> Entry
toEntry "word/_rels/document.xml.rels" Integer
epochtime
(ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
reldoc
let sectpr :: Element
sectpr = case Maybe Element
mbsectpr of
Just sectpr' :: Element
sectpr' -> let cs :: [Element]
cs = (QName -> Bool) -> Map Text Text -> [Element] -> [Element]
renumIds
(\q :: QName
q -> QName -> Text
qName QName
q Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "id" Bool -> Bool -> Bool
&& QName -> Maybe Text
qPrefix QName
q Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "r")
Map Text Text
idMap
(Element -> [Element]
elChildren Element
sectpr')
in
[Attr] -> Element -> Element
add_attrs (Element -> [Attr]
elAttribs Element
sectpr') (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:sectPr" [] [Element]
cs
Nothing -> Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:sectPr" [] ()
let contents' :: [Content]
contents' = [Content]
contents [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Element -> Content
Elem Element
sectpr]
let docContents :: Element
docContents = Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:document" [(Text, Text)]
stdAttributes
(Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:body" [] [Content]
contents'
let contentEntry :: Entry
contentEntry = FilePath -> Integer -> ByteString -> Entry
toEntry "word/document.xml" Integer
epochtime
(ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
docContents
let notes :: Element
notes = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:footnotes" [(Text, Text)]
stdAttributes [Element]
footnotes
let footnotesEntry :: Entry
footnotesEntry = FilePath -> Integer -> ByteString -> Entry
toEntry "word/footnotes.xml" Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
notes
let footnoteRelEntry :: Entry
footnoteRelEntry = FilePath -> Integer -> ByteString -> Entry
toEntry "word/_rels/footnotes.xml.rels" Integer
epochtime
(ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml (Element -> ByteString) -> Element -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Relationships" [("xmlns","http://schemas.openxmlformats.org/package/2006/relationships")]
[Element]
linkrels
let commentsEntry :: Entry
commentsEntry = FilePath -> Integer -> ByteString -> Entry
toEntry "word/comments.xml" Integer
epochtime
(ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml (Element -> ByteString) -> Element -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:comments" [(Text, Text)]
stdAttributes [Element]
comments
let newDynamicParaProps :: [ParaStyleName]
newDynamicParaProps = (ParaStyleName -> Bool) -> [ParaStyleName] -> [ParaStyleName]
forall a. (a -> Bool) -> [a] -> [a]
filter
(\sty :: ParaStyleName
sty -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ParaStyleName -> Map ParaStyleName ParStyle -> Bool
forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName ParaStyleName
sty (Map ParaStyleName ParStyle -> Bool)
-> Map ParaStyleName ParStyle -> Bool
forall a b. (a -> b) -> a -> b
$ StyleMaps -> Map ParaStyleName ParStyle
smParaStyle StyleMaps
styleMaps)
(Set ParaStyleName -> [ParaStyleName]
forall a. Set a -> [a]
Set.toList (Set ParaStyleName -> [ParaStyleName])
-> Set ParaStyleName -> [ParaStyleName]
forall a b. (a -> b) -> a -> b
$ WriterState -> Set ParaStyleName
stDynamicParaProps WriterState
st)
newDynamicTextProps :: [CharStyleName]
newDynamicTextProps = (CharStyleName -> Bool) -> [CharStyleName] -> [CharStyleName]
forall a. (a -> Bool) -> [a] -> [a]
filter
(\sty :: CharStyleName
sty -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CharStyleName -> Map CharStyleName CharStyle -> Bool
forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName CharStyleName
sty (Map CharStyleName CharStyle -> Bool)
-> Map CharStyleName CharStyle -> Bool
forall a b. (a -> b) -> a -> b
$ StyleMaps -> Map CharStyleName CharStyle
smCharStyle StyleMaps
styleMaps)
(Set CharStyleName -> [CharStyleName]
forall a. Set a -> [a]
Set.toList (Set CharStyleName -> [CharStyleName])
-> Set CharStyleName -> [CharStyleName]
forall a b. (a -> b) -> a -> b
$ WriterState -> Set CharStyleName
stDynamicTextProps WriterState
st)
let newstyles :: [Element]
newstyles = (ParaStyleName -> Element) -> [ParaStyleName] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ParaStyleName -> Element
newParaPropToOpenXml [ParaStyleName]
newDynamicParaProps [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
(CharStyleName -> Element) -> [CharStyleName] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map CharStyleName -> Element
newTextPropToOpenXml [CharStyleName]
newDynamicTextProps [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
[Element] -> (Style -> [Element]) -> Maybe Style -> [Element]
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 [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++
(Element -> Content) -> [Element] -> [Content]
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 (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
styledoc'
let numpath :: FilePath
numpath = "word/numbering.xml"
Element
numbering <- Archive -> Archive -> FilePath -> m Element
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 e :: Element
e =
case (QName -> Bool) -> Element -> Maybe Text
findAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "abstractNumId") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) Element
e Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead of
Just numid :: Int
numid -> Int
numid Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (990 :: Int)
Nothing ->
case (QName -> Bool) -> Element -> Maybe Text
findAttrBy ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "numId") (Text -> Bool) -> (QName -> Text) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) Element
e Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead of
Just numid :: Int
numid -> Int
numid Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (1000 :: Int)
Nothing -> Bool
False
let oldElts :: [Element]
oldElts = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Element -> Bool) -> Element -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Bool
pandocAdded) ([Element] -> [Element]) -> [Element] -> [Element]
forall a b. (a -> b) -> a -> b
$ [Content] -> [Element]
onlyElems (Element -> [Content]
elContent Element
numbering)
let allElts :: [Element]
allElts = [Element]
oldElts [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
newNumElts
let numEntry :: Entry
numEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
numpath Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
numbering{ elContent :: [Content]
elContent =
[Element -> Content
Elem Element
e | Element
e <- [Element]
allElts
, QName -> Text
qName (Element -> QName
elName Element
e) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "abstractNum" ] [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++
[Element -> Content
Elem Element
e | Element
e <- [Element]
allElts
, QName -> Text
qName (Element -> QName
elName Element
e) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "num" ] }
let keywords :: [Text]
keywords = case Text -> Meta -> Maybe MetaValue
lookupMeta "keywords" Meta
meta of
Just (MetaList xs :: [MetaValue]
xs) -> (MetaValue -> Text) -> [MetaValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map MetaValue -> Text
forall a. Walkable Inline a => a -> Text
stringify [MetaValue]
xs
_ -> []
let docPropsPath :: FilePath
docPropsPath = "docProps/core.xml"
let extraCoreProps :: [Text]
extraCoreProps = ["subject","lang","category","description"]
let extraCorePropsMap :: Map Text Text
extraCorePropsMap = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Text)] -> Map Text Text)
-> [(Text, Text)] -> Map Text Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
extraCoreProps
["dc:subject","dc:language","cp:category","dc:description"]
let lookupMetaString' :: Text -> Meta -> Text
lookupMetaString' :: Text -> Meta -> Text
lookupMetaString' key' :: Text
key' meta' :: Meta
meta' =
case Text
key' of
"description" -> Text -> [Text] -> Text
T.intercalate "_x000d_\n" ((Block -> Text) -> [Block] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Text
forall a. Walkable Inline a => a -> Text
stringify ([Block] -> [Text]) -> [Block] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Meta -> [Block]
lookupMetaBlocks "description" Meta
meta')
key'' :: Text
key'' -> Text -> Meta -> Text
lookupMetaString Text
key'' Meta
meta'
let docProps :: Element
docProps = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "cp:coreProperties"
[("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties")
,("xmlns:dc","http://purl.org/dc/elements/1.1/")
,("xmlns:dcterms","http://purl.org/dc/terms/")
,("xmlns:dcmitype","http://purl.org/dc/dcmitype/")
,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")]
([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Text -> Element
mktnode "dc:title" [] ([Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify ([Inline] -> Text) -> [Inline] -> Text
forall a b. (a -> b) -> a -> b
$ Meta -> [Inline]
docTitle Meta
meta)
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Text -> [(Text, Text)] -> Text -> Element
mktnode "dc:creator" [] (Text -> [Text] -> Text
T.intercalate "; " (([Inline] -> Text) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify ([[Inline]] -> [Text]) -> [[Inline]] -> [Text]
forall a b. (a -> b) -> a -> b
$ Meta -> [[Inline]]
docAuthors Meta
meta))
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [ Text -> [(Text, Text)] -> Text -> Element
mktnode (Text -> Text -> Map Text Text -> Text
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault "" Text
k Map Text Text
extraCorePropsMap) [] (Text -> Meta -> Text
lookupMetaString' Text
k Meta
meta)
| Text
k <- Map Text MetaValue -> [Text]
forall k a. Map k a -> [k]
M.keys (Meta -> Map Text MetaValue
unMeta Meta
meta), Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
extraCoreProps]
[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ Text -> [(Text, Text)] -> Text -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "cp:keywords" [] (Text -> [Text] -> Text
T.intercalate ", " [Text]
keywords)
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (\x :: Text
x -> [ Text -> [(Text, Text)] -> Text -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] Text
x
, Text -> [(Text, Text)] -> Text -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] Text
x
]) (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale "%FT%XZ" UTCTime
utctime)
let docPropsEntry :: Entry
docPropsEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
docPropsPath Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
docProps
let customProperties :: [(Text, Text)]
customProperties :: [(Text, Text)]
customProperties = [ (Text
k, Text -> Meta -> Text
lookupMetaString Text
k Meta
meta)
| Text
k <- Map Text MetaValue -> [Text]
forall k a. Map k a -> [k]
M.keys (Meta -> Map Text MetaValue
unMeta Meta
meta)
, Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (["title", "author", "keywords"]
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
extraCoreProps)]
let mkCustomProp :: (Text, t) -> a -> Element
mkCustomProp (k :: Text
k, v :: t
v) pid :: a
pid = Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "property"
[("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
,("pid", a -> Text
forall a. Show a => a -> Text
tshow a
pid)
,("name", Text
k)] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> t -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "vt:lpwstr" [] t
v
let customPropsPath :: FilePath
customPropsPath = "docProps/custom.xml"
let customProps :: Element
customProps = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Properties"
[("xmlns","http://schemas.openxmlformats.org/officeDocument/2006/custom-properties")
,("xmlns:vt","http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")
] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Int -> Element)
-> [(Text, Text)] -> [Int] -> [Element]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Text, Text) -> Int -> Element
forall a t. (Show a, Node t) => (Text, t) -> a -> Element
mkCustomProp [(Text, Text)]
customProperties [(2 :: Int)..]
let customPropsEntry :: Entry
customPropsEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
customPropsPath Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
customProps
let relsPath :: FilePath
relsPath = "_rels/.rels"
let rels :: Element
rels = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Relationships" [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ([(Text, Text)] -> Element) -> [[(Text, Text)]] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\attrs :: [(Text, Text)]
attrs -> Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "Relationship" [(Text, Text)]
attrs ())
[ [("Id","rId1")
,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument")
,("Target","word/document.xml")]
, [("Id","rId4")
,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties")
,("Target","docProps/app.xml")]
, [("Id","rId3")
,("Type","http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties")
,("Target","docProps/core.xml")]
, [("Id","rId5")
,("Type","http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties")
,("Target","docProps/custom.xml")]
]
let relsEntry :: Entry
relsEntry = FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
relsPath Integer
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
rels
let settingsPath :: FilePath
settingsPath = "word/settings.xml"
settingsList :: [Text]
settingsList = [ "zoom"
, "embedSystemFonts"
, "doNotTrackMoves"
, "defaultTabStop"
, "drawingGridHorizontalSpacing"
, "drawingGridVerticalSpacing"
, "displayHorizontalDrawingGridEvery"
, "displayVerticalDrawingGridEvery"
, "characterSpacingControl"
, "savePreviewPicture"
, "mathPr"
, "themeFontLang"
, "decimalSymbol"
, "listSeparator"
, "autoHyphenation"
, "consecutiveHyphenLimit"
, "hyphenationZone"
, "doNotHyphenateCap"
, "evenAndOddHeaders"
, "proofState"
, "compat"
]
Entry
settingsEntry <- Archive -> Archive -> FilePath -> Integer -> [Text] -> m Entry
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 arch :: Archive
arch path :: FilePath
path =
m Entry -> (Entry -> m Entry) -> Maybe Entry -> m Entry
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PandocError -> m Entry
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Entry) -> PandocError -> m Entry
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError
(Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " missing in reference docx")
Entry -> m Entry
forall (m :: * -> *) a. Monad m => a -> m a
return
(FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
path Archive
arch Maybe Entry -> Maybe Entry -> Maybe Entry
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
path Archive
distArchive)
Entry
docPropsAppEntry <- Archive -> FilePath -> m Entry
forall (m :: * -> *).
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive "docProps/app.xml"
Entry
themeEntry <- Archive -> FilePath -> m Entry
forall (m :: * -> *).
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive "word/theme/theme1.xml"
Entry
fontTableEntry <- Archive -> FilePath -> m Entry
forall (m :: * -> *).
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive "word/fontTable.xml"
Entry
webSettingsEntry <- Archive -> FilePath -> m Entry
forall (m :: * -> *).
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive "word/webSettings.xml"
[Entry]
headerFooterEntries <- (FilePath -> m Entry) -> [FilePath] -> m [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Archive -> FilePath -> m Entry
forall (m :: * -> *).
MonadError PandocError m =>
Archive -> FilePath -> m Entry
entryFromArchive Archive
refArchive (FilePath -> m Entry)
-> (FilePath -> FilePath) -> FilePath -> m Entry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("word/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++)) ([FilePath] -> m [Entry]) -> [FilePath] -> m [Entry]
forall a b. (a -> b) -> a -> b
$
(Element -> Maybe FilePath) -> [Element] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Text -> FilePath) -> Maybe Text -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack (Maybe Text -> Maybe FilePath)
-> (Element -> Maybe Text) -> Element -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Maybe Text
extractTarget)
([Element]
headers [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
footers)
let miscRelEntries :: [Entry]
miscRelEntries = [ Entry
e | Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
, "word/_rels/" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> FilePath
eRelativePath Entry
e
, ".xml.rels" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` Entry -> FilePath
eRelativePath Entry
e
, Entry -> FilePath
eRelativePath Entry
e FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "word/_rels/document.xml.rels"
, Entry -> FilePath
eRelativePath Entry
e FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "word/_rels/footnotes.xml.rels" ]
let otherMediaEntries :: [Entry]
otherMediaEntries = [ Entry
e | Entry
e <- Archive -> [Entry]
zEntries Archive
refArchive
, "word/media/" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Entry -> FilePath
eRelativePath Entry
e ]
let archive :: Archive
archive = (Entry -> Archive -> Archive) -> Archive -> [Entry] -> Archive
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
addEntryToArchive Archive
emptyArchive ([Entry] -> Archive) -> [Entry] -> Archive
forall a b. (a -> b) -> a -> b
$
Entry
contentTypesEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
relsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
contentEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
relEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
Entry
footnoteRelEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
numEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
styleEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
footnotesEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
Entry
commentsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
Entry
docPropsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
docPropsAppEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
customPropsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
Entry
themeEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
Entry
fontTableEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
settingsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entry
webSettingsEntry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
:
[Entry]
imageEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
headerFooterEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++
[Entry]
miscRelEntries [Entry] -> [Entry] -> [Entry]
forall a. [a] -> [a] -> [a]
++ [Entry]
otherMediaEntries
ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ Archive -> ByteString
fromArchive Archive
archive
newParaPropToOpenXml :: ParaStyleName -> Element
newParaPropToOpenXml :: ParaStyleName -> Element
newParaPropToOpenXml (ParaStyleName -> Text
forall a. FromStyleName a => a -> Text
fromStyleName -> Text
s) =
let styleId :: Text
styleId = (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
s
in Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:style" [ ("w:type", "paragraph")
, ("w:customStyle", "1")
, ("w:styleId", Text
styleId)]
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:name" [("w:val", Text
s)] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:basedOn" [("w:val","BodyText")] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:qFormat" [] ()
]
newTextPropToOpenXml :: CharStyleName -> Element
newTextPropToOpenXml :: CharStyleName -> Element
newTextPropToOpenXml (CharStyleName -> Text
forall a. FromStyleName a => a -> Text
fromStyleName -> Text
s) =
let styleId :: Text
styleId = (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) Text
s
in Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:style" [ ("w:type", "character")
, ("w:customStyle", "1")
, ("w:styleId", Text
styleId)]
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:name" [("w:val", Text
s)] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:basedOn" [("w:val","BodyTextChar")] ()
]
styleToOpenXml :: StyleMaps -> Style -> [Element]
styleToOpenXml :: StyleMaps -> Style -> [Element]
styleToOpenXml sm :: StyleMaps
sm style :: Style
style =
Maybe Element -> [Element]
forall a. Maybe a -> [a]
maybeToList Maybe Element
parStyle [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ (TokenType -> Maybe Element) -> [TokenType] -> [Element]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TokenType -> Maybe Element
toStyle [TokenType]
alltoktypes
where alltoktypes :: [TokenType]
alltoktypes = TokenType -> TokenType -> [TokenType]
forall a. Enum a => a -> a -> [a]
enumFromTo TokenType
KeywordTok TokenType
NormalTok
toStyle :: TokenType -> Maybe Element
toStyle toktype :: TokenType
toktype | CharStyleName -> Map CharStyleName CharStyle -> Bool
forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName (FilePath -> CharStyleName
forall a. IsString a => FilePath -> a
fromString (FilePath -> CharStyleName) -> FilePath -> CharStyleName
forall a b. (a -> b) -> a -> b
$ TokenType -> FilePath
forall a. Show a => a -> FilePath
show TokenType
toktype) (StyleMaps -> Map CharStyleName CharStyle
smCharStyle StyleMaps
sm) = Maybe Element
forall a. Maybe a
Nothing
| Bool
otherwise = Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:style" [("w:type","character"),
("w:customStyle","1"),("w:styleId", TokenType -> Text
forall a. Show a => a -> Text
tshow TokenType
toktype)]
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:name" [("w:val", TokenType -> Text
forall a. Show a => a -> Text
tshow TokenType
toktype)] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:basedOn" [("w:val","VerbatimChar")] ()
, Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:color" [("w:val", TokenType -> Text
tokCol TokenType
toktype)] ()
| TokenType -> Text
tokCol TokenType
toktype Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "auto" ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:shd" [("w:val","clear")
,("w:fill",TokenType -> Text
tokBg TokenType
toktype)] ()
| TokenType -> Text
tokBg TokenType
toktype Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "auto" ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:b" [] () | (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenBold TokenType
toktype ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:i" [] () | (TokenStyle -> Bool) -> TokenType -> Bool
tokFeature TokenStyle -> Bool
tokenItalic TokenType
toktype ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "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 f :: TokenStyle -> Bool
f toktype :: TokenType
toktype = Bool -> (TokenStyle -> Bool) -> Maybe TokenStyle -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TokenStyle -> Bool
f (Maybe TokenStyle -> Bool) -> Maybe TokenStyle -> Bool
forall a b. (a -> b) -> a -> b
$ TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles
tokCol :: TokenType -> Text
tokCol toktype :: TokenType
toktype = Text -> (Color -> Text) -> Maybe Color -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "auto" (FilePath -> Text
T.pack (FilePath -> Text) -> (Color -> FilePath) -> Color -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 (FilePath -> FilePath) -> (Color -> FilePath) -> Color -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> FilePath
forall a. FromColor a => Color -> a
fromColor)
(Maybe Color -> Text) -> Maybe Color -> Text
forall a b. (a -> b) -> a -> b
$ (TokenStyle -> Maybe Color
tokenColor (TokenStyle -> Maybe Color) -> Maybe TokenStyle -> Maybe Color
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles)
Maybe Color -> Maybe Color -> Maybe Color
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
defaultColor Style
style
tokBg :: TokenType -> Text
tokBg toktype :: TokenType
toktype = Text -> (Color -> Text) -> Maybe Color -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "auto" (FilePath -> Text
T.pack (FilePath -> Text) -> (Color -> FilePath) -> Color -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 (FilePath -> FilePath) -> (Color -> FilePath) -> Color -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> FilePath
forall a. FromColor a => Color -> a
fromColor)
(Maybe Color -> Text) -> Maybe Color -> Text
forall a b. (a -> b) -> a -> b
$ (TokenStyle -> Maybe Color
tokenBackground (TokenStyle -> Maybe Color) -> Maybe TokenStyle -> Maybe Color
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TokenType -> Map TokenType TokenStyle -> Maybe TokenStyle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TokenType
toktype Map TokenType TokenStyle
tokStyles)
Maybe Color -> Maybe Color -> Maybe Color
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Style -> Maybe Color
backgroundColor Style
style
parStyle :: Maybe Element
parStyle | ParaStyleName -> Map ParaStyleName ParStyle -> Bool
forall sn sty. (Ord sn, HasStyleId sty) => sn -> Map sn sty -> Bool
hasStyleName "Source Code" (StyleMaps -> Map ParaStyleName ParStyle
smParaStyle StyleMaps
sm) = Maybe Element
forall a. Maybe a
Nothing
| Bool
otherwise = Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:style" [("w:type","paragraph"),
("w:customStyle","1"),("w:styleId","SourceCode")]
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:name" [("w:val","Source Code")] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:basedOn" [("w:val","Normal")] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:link" [("w:val","VerbatimChar")] ()
, Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:pPr" []
([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:wordWrap" [("w:val","off")] ()
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:
[Element] -> (Color -> [Element]) -> Maybe Color -> [Element]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\col :: Color
col -> [Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:shd" [("w:val","clear"),("w:fill", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Color -> FilePath
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 :: Archive -> Archive -> FilePath -> Integer -> [Text] -> m Entry
copyChildren refArchive :: Archive
refArchive distArchive :: Archive
distArchive path :: FilePath
path timestamp :: Integer
timestamp elNames :: [Text]
elNames = do
Element
ref <- Archive -> Archive -> FilePath -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive FilePath
path
Element
dist <- Archive -> Archive -> FilePath -> m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
distArchive Archive
distArchive FilePath
path
let elsToCopy :: [Element]
elsToCopy =
(Element -> Element) -> [Element] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Element
cleanElem ([Element] -> [Element]) -> [Element] -> [Element]
forall a b. (a -> b) -> a -> b
$ (QName -> Bool) -> Element -> [Element]
filterChildrenName (\e :: QName
e -> QName -> Text
qName QName
e Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
elNames) Element
ref
let elsToKeep :: [Element]
elsToKeep =
[Element
e | Elem e :: Element
e <- Element -> [Content]
elContent Element
dist, Bool -> Bool
not ((Element -> Bool) -> [Element] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Element -> Element -> Bool
hasSameNameAs Element
e) [Element]
elsToCopy)]
Entry -> m Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> m Entry) -> Entry -> m Entry
forall a b. (a -> b) -> a -> b
$ FilePath -> Integer -> ByteString -> Entry
toEntry FilePath
path Integer
timestamp (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
dist{
elContent :: [Content]
elContent = (Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
elsToKeep [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ (Element -> Content) -> [Element] -> [Content]
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 Text -> Text -> Bool
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=Maybe Text
forall a. Maybe a
Nothing}}
baseListId :: Int
baseListId :: Int
baseListId = 1000
mkNumbering :: [ListMarker] -> [Element]
mkNumbering :: [ListMarker] -> [Element]
mkNumbering lists :: [ListMarker]
lists =
[Element]
elts [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ (ListMarker -> Int -> Element)
-> [ListMarker] -> [Int] -> [Element]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ListMarker -> Int -> Element
mkNum [ListMarker]
lists [Int
baseListId..(Int
baseListId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ListMarker] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ListMarker]
lists Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)]
where elts :: [Element]
elts = (ListMarker -> Element) -> [ListMarker] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ListMarker -> Element
mkAbstractNum ([ListMarker] -> [ListMarker]
forall a. Ord a => [a] -> [a]
ordNub [ListMarker]
lists)
maxListLevel :: Int
maxListLevel :: Int
maxListLevel = 8
mkNum :: ListMarker -> Int -> Element
mkNum :: ListMarker -> Int -> Element
mkNum marker :: ListMarker
marker numid :: Int
numid =
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:num" [("w:numId",Int -> Text
forall a. Show a => a -> Text
tshow Int
numid)]
([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:abstractNumId" [("w:val",ListMarker -> Text
listMarkerToId ListMarker
marker)] ()
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: case ListMarker
marker of
NoMarker -> []
BulletMarker -> []
NumberMarker _ _ start :: Int
start ->
(Int -> Element) -> [Int] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\lvl :: Int
lvl -> Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:lvlOverride" [("w:ilvl",Int -> Text
forall a. Show a => a -> Text
tshow (Int
lvl :: Int))]
(Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:startOverride" [("w:val",Int -> Text
forall a. Show a => a -> Text
tshow Int
start)] ())
[0..Int
maxListLevel]
mkAbstractNum :: ListMarker -> Element
mkAbstractNum :: ListMarker -> Element
mkAbstractNum marker :: ListMarker
marker =
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:abstractNum" [("w:abstractNumId",ListMarker -> Text
listMarkerToId ListMarker
marker)]
([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:nsid" [("w:val", "A" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ListMarker -> Text
listMarkerToId ListMarker
marker)] ()
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:multiLevelType" [("w:val","multilevel")] ()
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (Int -> Element) -> [Int] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (ListMarker -> Int -> Element
mkLvl ListMarker
marker)
[0..Int
maxListLevel]
mkLvl :: ListMarker -> Int -> Element
mkLvl :: ListMarker -> Int -> Element
mkLvl marker :: ListMarker
marker lvl :: Int
lvl =
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:lvl" [("w:ilvl",Int -> Text
forall a. Show a => a -> Text
tshow Int
lvl)] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:start" [("w:val",Text
start)] ()
| ListMarker
marker ListMarker -> ListMarker -> Bool
forall a. Eq a => a -> a -> Bool
/= ListMarker
NoMarker Bool -> Bool -> Bool
&& ListMarker
marker ListMarker -> ListMarker -> Bool
forall a. Eq a => a -> a -> Bool
/= ListMarker
BulletMarker ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:numFmt" [("w:val",Text
fmt)] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:lvlText" [("w:val", Text
lvltxt)] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:lvlJc" [("w:val","left")] ()
, Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:pPr" []
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:ind" [ ("w:left",Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
step)
, ("w:hanging",Int -> Text
forall a. Show a => a -> Text
tshow (Int
hang :: Int))
] ()
]
]
where (fmt :: Text
fmt, lvltxt :: Text
lvltxt, start :: Text
start) =
case ListMarker
marker of
NoMarker -> ("bullet"," ","1")
BulletMarker -> ("bullet",Int -> Text
forall t p. (IsString p, Integral t) => t -> p
bulletFor Int
lvl,"1")
NumberMarker st :: ListNumberStyle
st de :: ListNumberDelim
de n :: Int
n -> (ListNumberStyle -> Int -> Text
forall p t. (IsString p, Integral t) => ListNumberStyle -> t -> p
styleFor ListNumberStyle
st Int
lvl
,ListNumberDelim -> Text -> Text
forall a. (Semigroup a, IsString a) => ListNumberDelim -> a -> a
patternFor ListNumberDelim
de ("%" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1))
,Int -> Text
forall a. Show a => a -> Text
tshow Int
n)
step :: Int
step = 720
hang :: Int
hang = 480
bulletFor :: t -> p
bulletFor 0 = "\x2022"
bulletFor 1 = "\x2013"
bulletFor 2 = "\x2022"
bulletFor 3 = "\x2013"
bulletFor 4 = "\x2022"
bulletFor 5 = "\x2013"
bulletFor x :: t
x = t -> p
bulletFor (t
x t -> t -> t
forall a. Integral a => a -> a -> a
`mod` 6)
styleFor :: ListNumberStyle -> t -> p
styleFor UpperAlpha _ = "upperLetter"
styleFor LowerAlpha _ = "lowerLetter"
styleFor UpperRoman _ = "upperRoman"
styleFor LowerRoman _ = "lowerRoman"
styleFor Decimal _ = "decimal"
styleFor DefaultStyle 0 = "decimal"
styleFor DefaultStyle 1 = "lowerLetter"
styleFor DefaultStyle 2 = "lowerRoman"
styleFor DefaultStyle 3 = "decimal"
styleFor DefaultStyle 4 = "lowerLetter"
styleFor DefaultStyle 5 = "lowerRoman"
styleFor DefaultStyle x :: t
x = ListNumberStyle -> t -> p
styleFor ListNumberStyle
DefaultStyle (t
x t -> t -> t
forall a. Integral a => a -> a -> a
`mod` 6)
styleFor _ _ = "decimal"
patternFor :: ListNumberDelim -> a -> a
patternFor OneParen s :: a
s = a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> ")"
patternFor TwoParens s :: a
s = "(" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> ")"
patternFor _ s :: a
s = a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> "."
getNumId :: (PandocMonad m) => WS m Int
getNumId :: WS m Int
getNumId = (((Int
baseListId Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> ([ListMarker] -> Int) -> [ListMarker] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ListMarker] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([ListMarker] -> Int)
-> ReaderT WriterEnv (StateT WriterState m) [ListMarker]
-> WS m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (WriterState -> [ListMarker])
-> ReaderT WriterEnv (StateT WriterState m) [ListMarker]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [ListMarker]
stLists
makeTOC :: (PandocMonad m) => WriterOptions -> WS m [Element]
makeTOC :: WriterOptions -> WS m [Element]
makeTOC opts :: WriterOptions
opts = do
let depth :: Text
depth = "1-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow (WriterOptions -> Int
writerTOCDepth WriterOptions
opts)
let tocCmd :: Text
tocCmd = "TOC \\o \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
depth Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\" \\h \\z \\u"
[Inline]
tocTitle <- (WriterState -> [Inline])
-> ReaderT WriterEnv (StateT WriterState m) [Inline]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [Inline]
stTocTitle
[Content]
title <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "TOC Heading") (WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [[Inline] -> Block
Para [Inline]
tocTitle])
[Element] -> WS m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return
[Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:sdt" [] [
Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:sdtPr" [] (
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:docPartObj" []
[Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:docPartGallery" [("w:val","Table of Contents")] (),
Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:docPartUnique" [] ()]
),
Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:sdtContent" [] ([Content]
title [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [ Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:p" [] (
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" [] [
Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:fldChar" [("w:fldCharType","begin"),("w:dirty","true")] (),
Text -> [(Text, Text)] -> Text -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:instrText" [("xml:space","preserve")] Text
tocCmd,
Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:fldChar" [("w:fldCharType","separate")] (),
Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:fldChar" [("w:fldCharType","end")] ()
]
)
])
]]
writeOpenXML :: (PandocMonad m)
=> WriterOptions -> Pandoc
-> WS m ([Content], [Element], [Element])
writeOpenXML :: WriterOptions -> Pandoc -> WS m ([Content], [Element], [Element])
writeOpenXML opts :: WriterOptions
opts (Pandoc meta :: Meta
meta blocks :: [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 "abstract" Meta
meta
let subtitle' :: [Inline]
subtitle' = Text -> Meta -> [Inline]
lookupMetaInlines "subtitle" Meta
meta
let includeTOC :: Bool
includeTOC = WriterOptions -> Bool
writerTableOfContents WriterOptions
opts Bool -> Bool -> Bool
|| Text -> Meta -> Bool
lookupMetaBool "toc" Meta
meta
[Content]
title <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Title") (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [[Inline] -> Block
Para [Inline]
tit | Bool -> Bool
not ([Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
tit)]
[Content]
subtitle <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Subtitle") (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [[Inline] -> Block
Para [Inline]
subtitle' | Bool -> Bool
not ([Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
subtitle')]
[Content]
authors <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Author") (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts ([Block] -> WS m [Content]) -> [Block] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$
([Inline] -> Block) -> [[Inline]] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Block
Para [[Inline]]
auths
[Content]
date <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Date") (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [[Inline] -> Block
Para [Inline]
dat | Bool -> Bool
not ([Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
dat)]
[Content]
abstract <- if [Block] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
abstract'
then [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Abstract") (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
abstract'
let convertSpace :: [Inline] -> [Inline]
convertSpace (Str x :: Text
x : Space : Str y :: Text
y : xs :: [Inline]
xs) = Text -> Inline
Str (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
xs
convertSpace (Str x :: Text
x : Str y :: Text
y : xs :: [Inline]
xs) = Text -> Inline
Str (Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
y) Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
xs
convertSpace xs :: [Inline]
xs = [Inline]
xs
let blocks' :: [Block]
blocks' = ([Inline] -> [Inline]) -> [Block] -> [Block]
forall a b. (Data a, Data b) => (a -> a) -> b -> b
bottomUp [Inline] -> [Inline]
convertSpace [Block]
blocks
[Content]
doc' <- WS m ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara WS m () -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
blocks'
[Element]
notes' <- [Element] -> [Element]
forall a. [a] -> [a]
reverse ([Element] -> [Element])
-> ReaderT WriterEnv (StateT WriterState m) [Element]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterState -> [Element])
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [Element]
stFootnotes
[([(Text, Text)], [Inline])]
comments <- [([(Text, Text)], [Inline])] -> [([(Text, Text)], [Inline])]
forall a. [a] -> [a]
reverse ([([(Text, Text)], [Inline])] -> [([(Text, Text)], [Inline])])
-> ReaderT
WriterEnv (StateT WriterState m) [([(Text, Text)], [Inline])]
-> ReaderT
WriterEnv (StateT WriterState m) [([(Text, Text)], [Inline])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterState -> [([(Text, Text)], [Inline])])
-> ReaderT
WriterEnv (StateT WriterState m) [([(Text, Text)], [Inline])]
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 (kvs :: [(Text, Text)]
kvs, ils :: [Inline]
ils) = do
[Content]
annotation <- WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
Element -> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> ReaderT WriterEnv (StateT WriterState m) Element)
-> Element -> ReaderT WriterEnv (StateT WriterState m) Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:comment" [("w:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k, Text
v) | (k :: Text
k,v :: Text
v) <- [(Text, Text)]
kvs]
[ Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:p" [] ([Content] -> Element) -> [Content] -> Element
forall a b. (a -> b) -> a -> b
$
(Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem
[ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:pPr" []
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:pStyle" [("w:val", "CommentText")] () ]
, Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" []
[ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rPr" []
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rStyle" [("w:val", "CommentReference")] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:annotationRef" [] ()
]
]
] [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
annotation
]
[Element]
comments' <- (([(Text, Text)], [Inline]) -> WS m Element)
-> [([(Text, Text)], [Inline])]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(Text, Text)], [Inline]) -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
([(Text, Text)], [Inline])
-> ReaderT WriterEnv (StateT WriterState m) Element
toComment [([(Text, Text)], [Inline])]
comments
[Element]
toc <- if Bool
includeTOC
then WriterOptions -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> WS m [Element]
makeTOC WriterOptions
opts
else [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return []
let meta' :: [Content]
meta' = [Content]
title [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
subtitle [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
authors [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
date [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
abstract [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ (Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
toc
([Content], [Element], [Element])
-> WS m ([Content], [Element], [Element])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content]
meta' [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
doc', [Element]
notes', [Element]
comments')
blocksToOpenXML :: (PandocMonad m) => WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML :: WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML opts :: WriterOptions
opts = ([[Content]] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
-> WS m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Content]] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ReaderT WriterEnv (StateT WriterState m) [[Content]]
-> WS m [Content])
-> ([Block]
-> ReaderT WriterEnv (StateT WriterState m) [[Content]])
-> [Block]
-> WS m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> WS m [Content])
-> [Block] -> ReaderT WriterEnv (StateT WriterState m) [[Content]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Block -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts) ([Block] -> ReaderT WriterEnv (StateT WriterState m) [[Content]])
-> ([Block] -> [Block])
-> [Block]
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> [Block]
separateTables ([Block] -> [Block]) -> ([Block] -> [Block]) -> [Block] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> Bool) -> [Block] -> [Block]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Block -> Bool) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Bool
isForeignRawBlock)
isForeignRawBlock :: Block -> Bool
isForeignRawBlock :: Block -> Bool
isForeignRawBlock (RawBlock format :: Format
format _) = Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
/= "openxml"
isForeignRawBlock _ = Bool
False
separateTables :: [Block] -> [Block]
separateTables :: [Block] -> [Block]
separateTables [] = []
separateTables (x :: Block
x@Table{}:xs :: [Block]
xs@(Table{}:_)) =
Block
x Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: Format -> Text -> Block
RawBlock (Text -> Format
Format "openxml") "<w:p />" Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block] -> [Block]
separateTables [Block]
xs
separateTables (x :: Block
x:xs :: [Block]
xs) = Block
x Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block] -> [Block]
separateTables [Block]
xs
rStyleM :: (PandocMonad m) => CharStyleName -> WS m XML.Element
rStyleM :: CharStyleName -> WS m Element
rStyleM styleName :: CharStyleName
styleName = do
Map CharStyleName CharStyle
cStyleMap <- (WriterState -> Map CharStyleName CharStyle)
-> ReaderT
WriterEnv (StateT WriterState m) (Map CharStyleName CharStyle)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StyleMaps -> Map CharStyleName CharStyle
smCharStyle (StyleMaps -> Map CharStyleName CharStyle)
-> (WriterState -> StyleMaps)
-> WriterState
-> Map CharStyleName CharStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterState -> StyleMaps
stStyleMaps)
let sty' :: StyleId CharStyle
sty' = CharStyleName -> Map CharStyleName CharStyle -> StyleId CharStyle
forall sn sty.
(Ord sn, FromStyleName sn, IsString (StyleId sty),
HasStyleId sty) =>
sn -> Map sn sty -> StyleId sty
getStyleIdFromName CharStyleName
styleName Map CharStyleName CharStyle
cStyleMap
Element -> WS m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> WS m Element) -> Element -> WS m Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rStyle" [("w:val", CharStyleId -> Text
forall a. FromStyleId a => a -> Text
fromStyleId CharStyleId
sty')] ()
getUniqueId :: (PandocMonad m) => WS m Text
getUniqueId :: WS m Text
getUniqueId = do
Int
n <- (WriterState -> Int)
-> ReaderT WriterEnv (StateT WriterState m) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stCurId
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{stCurId :: Int
stCurId = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1}
Text -> WS m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> WS m Text) -> Text -> WS m Text
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall a. Show a => a -> Text
tshow Int
n
dynamicStyleKey :: Text
dynamicStyleKey :: Text
dynamicStyleKey = "custom-style"
blockToOpenXML :: (PandocMonad m) => WriterOptions -> Block -> WS m [Content]
blockToOpenXML :: WriterOptions -> Block -> WS m [Content]
blockToOpenXML opts :: WriterOptions
opts blk :: Block
blk = WS m [Content] -> WS m [Content]
forall (m :: * -> *) a. PandocMonad m => WS m a -> WS m a
withDirection (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Block -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML' WriterOptions
opts Block
blk
blockToOpenXML' :: (PandocMonad m) => WriterOptions -> Block -> WS m [Content]
blockToOpenXML' :: WriterOptions -> Block -> WS m [Content]
blockToOpenXML' _ Null = [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
blockToOpenXML' opts :: WriterOptions
opts (Div (ident :: Text
ident,_classes :: [Text]
_classes,kvs :: [(Text, Text)]
kvs) bs :: [Block]
bs) = do
WS m [Content] -> WS m [Content]
stylemod <- case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
dynamicStyleKey [(Text, Text)]
kvs of
Just (FilePath -> ParaStyleName
forall a. IsString a => FilePath -> a
fromString (FilePath -> ParaStyleName)
-> (Text -> FilePath) -> Text -> ParaStyleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack -> ParaStyleName
sty) -> do
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \s :: WriterState
s ->
WriterState
s{stDynamicParaProps :: Set ParaStyleName
stDynamicParaProps = ParaStyleName -> Set ParaStyleName -> Set ParaStyleName
forall a. Ord a => a -> Set a -> Set a
Set.insert ParaStyleName
sty
(WriterState -> Set ParaStyleName
stDynamicParaProps WriterState
s)}
(WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return ((WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv
(StateT WriterState m)
(WS m [Content] -> WS m [Content]))
-> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall a b. (a -> b) -> a -> b
$ WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM ParaStyleName
sty)
_ -> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return WS m [Content] -> WS m [Content]
forall a. a -> a
id
WS m [Content] -> WS m [Content]
dirmod <- case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "dir" [(Text, Text)]
kvs of
Just "rtl" -> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return ((WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv
(StateT WriterState m)
(WS m [Content] -> WS m [Content]))
-> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall a b. (a -> b) -> a -> b
$ (WriterEnv -> WriterEnv) -> WS m [Content] -> WS m [Content]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env { envRTL :: Bool
envRTL = Bool
True })
Just "ltr" -> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return ((WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv
(StateT WriterState m)
(WS m [Content] -> WS m [Content]))
-> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall a b. (a -> b) -> a -> b
$ (WriterEnv -> WriterEnv) -> WS m [Content] -> WS m [Content]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env { envRTL :: Bool
envRTL = Bool
False })
_ -> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return WS m [Content] -> WS m [Content]
forall a. a -> a
id
let (hs :: [Block]
hs, bs' :: [Block]
bs') = if Text
ident Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "refs"
then (Block -> Bool) -> [Block] -> ([Block], [Block])
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "refs"
then WS m Element -> WS m a -> WS m a
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Bibliography")
else WS m a -> WS m a
forall a. a -> a
id
[Content]
header <- WS m [Content] -> WS m [Content]
dirmod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
stylemod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
hs
[Content]
contents <- WS m [Content] -> WS m [Content]
dirmod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
forall a. WS m a -> WS m a
bibmod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
stylemod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
bs'
Text -> [Content] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
ident ([Content] -> WS m [Content]) -> [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [Content]
header [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> [Content]
contents
blockToOpenXML' opts :: WriterOptions
opts (Header lev :: Int
lev (ident :: Text
ident,_,kvs :: [(Text, Text)]
kvs) lst :: [Inline]
lst) = do
ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
[Element]
paraProps <- WS m Element -> WS m [Element] -> WS m [Element]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM (FilePath -> ParaStyleName
forall a. IsString a => FilePath -> a
fromString (FilePath -> ParaStyleName) -> FilePath -> ParaStyleName
forall a b. (a -> b) -> a -> b
$ "Heading "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show Int
lev)) (WS m [Element] -> WS m [Element])
-> WS m [Element] -> WS m [Element]
forall a b. (a -> b) -> a -> b
$
Bool -> WS m [Element]
forall (m :: * -> *). PandocMonad m => Bool -> WS m [Element]
getParaProps Bool
False
[Content]
number <-
if WriterOptions -> Bool
writerNumberSections WriterOptions
opts
then
case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "number" [(Text, Text)]
kvs of
Just n :: Text
n -> do
[Content]
num <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (CharStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM "SectionNumber")
(WriterOptions -> Inline -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts (Text -> Inline
Str Text
n))
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> WS m [Content]) -> [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [Content]
num [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" [] [Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:tab" [] ()]]
Nothing -> [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Content]
contents <- ([Content]
number [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++) ([Content] -> [Content]) -> WS m [Content] -> WS m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
if Text -> Bool
T.null Text
ident
then [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:p" [] ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
paraProps [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
contents)]
else do
let bookmarkName :: Text
bookmarkName = Text
ident
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \s :: WriterState
s -> WriterState
s{ stSectionIds :: Set Text
stSectionIds = Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
bookmarkName
(Set Text -> Set Text) -> Set Text -> Set Text
forall a b. (a -> b) -> a -> b
$ WriterState -> Set Text
stSectionIds WriterState
s }
[Content]
bookmarkedContents <- Text -> [Content] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
bookmarkName [Content]
contents
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:p" [] ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
paraProps [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
bookmarkedContents)]
blockToOpenXML' opts :: WriterOptions
opts (Plain lst :: [Inline]
lst) = do
Bool
isInTable <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stInTable
Bool
isInList <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stInList
let block :: WS m [Content]
block = WriterOptions -> Block -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts ([Inline] -> Block
Para [Inline]
lst)
Element
prop <- ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Compact"
if Bool
isInTable Bool -> Bool -> Bool
|| Bool
isInList
then Element -> WS m [Content] -> WS m [Content]
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' opts :: WriterOptions
opts (SimpleFigure attr :: Attr
attr@(imgident :: Text
imgident, _, _) alt :: [Inline]
alt (src :: Text
src, tit :: Text
tit)) = do
ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
Int
fignum <- (WriterState -> Int)
-> ReaderT WriterEnv (StateT WriterState m) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stNextFigureNum
Bool
-> ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
alt) (ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ())
-> ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stNextFigureNum :: Int
stNextFigureNum = Int
fignum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 }
let refid :: Text
refid = if Text -> Bool
T.null Text
imgident
then "ref_fig" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
fignum
else "ref_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imgident
Text
figname <- Term -> ReaderT WriterEnv (StateT WriterState m) Text
forall (m :: * -> *). PandocMonad m => Term -> m Text
translateTerm Term
Term.Figure
Element
prop <- ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM (ParaStyleName -> WS m Element) -> ParaStyleName -> WS m Element
forall a b. (a -> b) -> a -> b
$
if [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
alt
then "Figure"
else "Captioned Figure"
[Element]
paraProps <- (WriterEnv -> WriterEnv) -> WS m [Element] -> WS m [Element]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env { envParaProperties :: EnvProps
envParaProperties = Maybe Element -> [Element] -> EnvProps
EnvProps (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
prop) [] EnvProps -> EnvProps -> EnvProps
forall a. Semigroup a => a -> a -> a
<> WriterEnv -> EnvProps
envParaProperties WriterEnv
env }) (Bool -> WS m [Element]
forall (m :: * -> *). PandocMonad m => Bool -> WS m [Element]
getParaProps Bool
False)
[Content]
contents <- WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
alt (Text
src,Text
tit)]
[Content]
captionNode <- if [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
alt
then [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Image Caption")
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Block -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts
(Block -> WS m [Content]) -> Block -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Block
Para
([Inline] -> Block) -> [Inline] -> Block
forall a b. (a -> b) -> a -> b
$ if Extension -> WriterOptions -> Bool
forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_native_numbering WriterOptions
opts
then Attr -> [Inline] -> Inline
Span (Text
refid,[],[])
[Text -> Inline
Str (Text
figname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\160"),
Format -> Text -> Inline
RawInline (Text -> Format
Format "openxml")
("<w:fldSimple w:instr=\"SEQ Figure"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " \\* ARABIC \"><w:r><w:t>"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
fignum
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "</w:t></w:r></w:fldSimple>")] Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: Text -> Inline
Str ": " Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
alt
else [Inline]
alt
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> WS m [Content]) -> [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$
Element -> Content
Elem (Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:p" [] ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
paraProps [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
contents))
Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
captionNode
blockToOpenXML' opts :: WriterOptions
opts (Para lst :: [Inline]
lst)
| [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
lst Bool -> Bool -> Bool
&& Bool -> Bool
not (Extension -> WriterOptions -> Bool
forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_empty_paragraphs WriterOptions
opts) = [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = do
Bool
isFirstPara <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stFirstPara
let displayMathPara :: Bool
displayMathPara = case [Inline]
lst of
[x :: Inline
x] -> Inline -> Bool
isDisplayMath Inline
x
_ -> Bool
False
[Element]
paraProps <- Bool -> WS m [Element]
forall (m :: * -> *). PandocMonad m => Bool -> WS m [Element]
getParaProps Bool
displayMathPara
Element
bodyTextStyle <- ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM (ParaStyleName -> WS m Element) -> ParaStyleName -> WS m Element
forall a b. (a -> b) -> a -> b
$ if Bool
isFirstPara
then "First Paragraph"
else "Body Text"
let paraProps' :: [Element]
paraProps' = case [Element]
paraProps of
[] -> [Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:pPr" [] [Element
bodyTextStyle]]
ps :: [Element]
ps -> [Element]
ps
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \s :: WriterState
s -> WriterState
s { stFirstPara :: Bool
stFirstPara = Bool
False }
[Content]
contents <- WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:p" [] ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
paraProps' [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
contents)]
blockToOpenXML' opts :: WriterOptions
opts (LineBlock lns :: [[Inline]]
lns) = WriterOptions -> Block -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts (Block -> WS m [Content]) -> Block -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [[Inline]] -> Block
linesToPara [[Inline]]
lns
blockToOpenXML' _ b :: Block
b@(RawBlock format :: Format
format str :: Text
str)
| Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Format
Format "openxml" = [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [
CData -> Content
Text (CDataKind -> Text -> Maybe Integer -> CData
CData CDataKind
CDataRaw Text
str Maybe Integer
forall a. Maybe a
Nothing)
]
| Bool
otherwise = do
LogMessage -> ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> ReaderT WriterEnv (StateT WriterState m) ())
-> LogMessage -> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ Block -> LogMessage
BlockNotRendered Block
b
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
blockToOpenXML' opts :: WriterOptions
opts (BlockQuote blocks :: [Block]
blocks) = do
[Content]
p <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Block Text")
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
blocks
ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
p
blockToOpenXML' opts :: WriterOptions
opts (CodeBlock attrs :: Attr
attrs@(ident :: Text
ident, _, _) str :: Text
str) = do
[Content]
p <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Source Code") (WriterOptions -> Block -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts (Block -> WS m [Content]) -> Block -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [Inline] -> Block
Para [Attr -> Text -> Inline
Code Attr
attrs Text
str])
ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
Text -> [Content] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
ident [Content]
p
blockToOpenXML' _ HorizontalRule = do
ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:p" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:pict" []
(Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "v:rect" [("style","width:0;height:1.5pt"),
("o:hralign","center"),
("o:hrstd","t"),("o:hr","t")] () ]
blockToOpenXML' opts :: WriterOptions
opts (Table attr :: Attr
attr caption :: Caption
caption colspecs :: [ColSpec]
colspecs thead :: TableHead
thead tbodies :: [TableBody]
tbodies tfoot :: TableFoot
tfoot) =
WriterOptions
-> ([Block] -> WS m [Content]) -> Table -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> ([Block] -> WS m [Content]) -> Table -> WS m [Content]
tableToOpenXML WriterOptions
opts
(WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts)
(Attr
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> Table
Grid.toTable Attr
attr Caption
caption [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot)
blockToOpenXML' opts :: WriterOptions
opts el :: Block
el
| BulletList lst :: [[Block]]
lst <- Block
el = ListMarker -> [[Block]] -> WS m [Content]
forall (m :: * -> *) (t :: * -> *).
(PandocMonad m, Traversable t) =>
ListMarker
-> t [Block] -> ReaderT WriterEnv (StateT WriterState m) [Content]
addOpenXMLList ListMarker
BulletMarker [[Block]]
lst
| OrderedList (start :: Int
start, numstyle :: ListNumberStyle
numstyle, numdelim :: ListNumberDelim
numdelim) lst :: [[Block]]
lst <- Block
el
= ListMarker -> [[Block]] -> WS m [Content]
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 marker :: ListMarker
marker lst :: t [Block]
lst = do
ListMarker -> WS m ()
forall (m :: * -> *). PandocMonad m => ListMarker -> WS m ()
addList ListMarker
marker
Int
numid <- WS m Int
forall (m :: * -> *). PandocMonad m => WS m Int
getNumId
[Content]
l <- ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (m :: * -> *) a. PandocMonad m => WS m a -> WS m a
asList (ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content])
-> ReaderT WriterEnv (StateT WriterState m) [Content]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
forall a b. (a -> b) -> a -> b
$ t [Content] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (t [Content] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) (t [Content])
-> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ([Block] -> ReaderT WriterEnv (StateT WriterState m) [Content])
-> t [Block]
-> ReaderT WriterEnv (StateT WriterState m) (t [Content])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions
-> Int
-> [Block]
-> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Int -> [Block] -> WS m [Content]
listItemToOpenXML WriterOptions
opts Int
numid) t [Block]
lst
WS m ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
[Content] -> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
l
blockToOpenXML' opts :: WriterOptions
opts (DefinitionList items :: [([Inline], [[Block]])]
items) = do
[Content]
l <- [[Content]] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Content]] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
-> WS m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (([Inline], [[Block]]) -> WS m [Content])
-> [([Inline], [[Block]])]
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> ([Inline], [[Block]]) -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> ([Inline], [[Block]]) -> WS m [Content]
definitionListItemToOpenXML WriterOptions
opts) [([Inline], [[Block]])]
items
ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
l
definitionListItemToOpenXML :: (PandocMonad m)
=> WriterOptions -> ([Inline],[[Block]])
-> WS m [Content]
definitionListItemToOpenXML :: WriterOptions -> ([Inline], [[Block]]) -> WS m [Content]
definitionListItemToOpenXML opts :: WriterOptions
opts (term :: [Inline]
term,defs :: [[Block]]
defs) = do
[Content]
term' <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Definition Term")
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Block -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Block -> WS m [Content]
blockToOpenXML WriterOptions
opts ([Inline] -> Block
Para [Inline]
term)
[Content]
defs' <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Definition")
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [[Content]] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Content]] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
-> WS m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ([Block] -> WS m [Content])
-> [[Block]]
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts) [[Block]]
defs
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> WS m [Content]) -> [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [Content]
term' [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Content]
defs'
addList :: (PandocMonad m) => ListMarker -> WS m ()
addList :: ListMarker -> WS m ()
addList marker :: ListMarker
marker = do
[ListMarker]
lists <- (WriterState -> [ListMarker])
-> ReaderT WriterEnv (StateT WriterState m) [ListMarker]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [ListMarker]
stLists
(WriterState -> WriterState) -> WS m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState) -> WS m ())
-> (WriterState -> WriterState) -> WS m ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stLists :: [ListMarker]
stLists = [ListMarker]
lists [ListMarker] -> [ListMarker] -> [ListMarker]
forall a. [a] -> [a] -> [a]
++ [ListMarker
marker] }
listItemToOpenXML :: (PandocMonad m)
=> WriterOptions
-> Int -> [Block]
-> WS m [Content]
listItemToOpenXML :: WriterOptions -> Int -> [Block] -> WS m [Content]
listItemToOpenXML opts :: WriterOptions
opts numid :: Int
numid bs :: [Block]
bs = do
Bool
oldInList <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stInList
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stInList :: Bool
stInList = Bool
True }
let isListBlock :: Block -> Bool
isListBlock = \case
BulletList{} -> Bool
True
OrderedList{} -> Bool
True
_ -> Bool
False
let bs' :: [Block]
bs' = case [Block]
bs of
[] -> []
first :: Block
first:rest :: [Block]
rest -> if Block -> Bool
isListBlock Block
first
then [Inline] -> Block
Plain [Text -> Inline
Str ""]Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:Block
firstBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[Block]
rest
else Block
firstBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[Block]
rest
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stNumIdUsed :: Bool
stNumIdUsed = Bool
False }
[Content]
contents <- Int -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a. PandocMonad m => Int -> WS m a -> WS m a
withNumId Int
numid (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts [Block]
bs'
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stInList :: Bool
stInList = Bool
oldInList }
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
contents
inlinesToOpenXML :: PandocMonad m => WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML :: WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML opts :: WriterOptions
opts lst :: [Inline]
lst = [[Content]] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Content]] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) [[Content]]
-> WS m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Inline -> WS m [Content])
-> [Inline] -> ReaderT WriterEnv (StateT WriterState m) [[Content]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Inline -> WS m [Content]
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 :: Int -> WS m a -> WS m a
withNumId numid :: Int
numid = (WriterEnv -> WriterEnv) -> WS m a -> WS m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((WriterEnv -> WriterEnv) -> WS m a -> WS m a)
-> (WriterEnv -> WriterEnv) -> WS m a -> WS m a
forall a b. (a -> b) -> a -> b
$ \env :: WriterEnv
env -> WriterEnv
env{ envListNumId :: Int
envListNumId = Int
numid }
asList :: (PandocMonad m) => WS m a -> WS m a
asList :: WS m a -> WS m a
asList = (WriterEnv -> WriterEnv) -> WS m a -> WS m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((WriterEnv -> WriterEnv) -> WS m a -> WS m a)
-> (WriterEnv -> WriterEnv) -> WS m a -> WS m a
forall a b. (a -> b) -> a -> b
$ \env :: WriterEnv
env -> WriterEnv
env{ envListLevel :: Int
envListLevel = WriterEnv -> Int
envListLevel WriterEnv
env Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 }
getTextProps :: (PandocMonad m) => WS m [Element]
getTextProps :: WS m [Element]
getTextProps = do
EnvProps
props <- (WriterEnv -> EnvProps)
-> ReaderT WriterEnv (StateT WriterState m) EnvProps
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> EnvProps
envTextProperties
let squashed :: [Element]
squashed = EnvProps -> [Element]
squashProps EnvProps
props
[Element] -> WS m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rPr" [] [Element]
squashed | (Bool -> Bool
not (Bool -> Bool) -> ([Element] -> Bool) -> [Element] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [Element]
squashed]
withTextProp :: PandocMonad m => Element -> WS m a -> WS m a
withTextProp :: Element -> WS m a -> WS m a
withTextProp d :: Element
d p :: WS m a
p =
(WriterEnv -> WriterEnv) -> WS m a -> WS m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env {envTextProperties :: EnvProps
envTextProperties = EnvProps
ep EnvProps -> EnvProps -> EnvProps
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 (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
d) [] else Maybe Element -> [Element] -> EnvProps
EnvProps Maybe Element
forall a. Maybe a
Nothing [Element
d]
withTextPropM :: PandocMonad m => WS m Element -> WS m a -> WS m a
withTextPropM :: WS m Element -> WS m a -> WS m a
withTextPropM md :: WS m Element
md p :: WS m a
p = do
Element
d <- WS m Element
md
Element -> WS m a -> WS m a
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 :: Bool -> WS m [Element]
getParaProps displayMathPara :: Bool
displayMathPara = do
EnvProps
props <- (WriterEnv -> EnvProps)
-> ReaderT WriterEnv (StateT WriterState m) EnvProps
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> EnvProps
envParaProperties
Int
listLevel <- (WriterEnv -> Int) -> ReaderT WriterEnv (StateT WriterState m) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envListLevel
Int
numid <- (WriterEnv -> Int) -> ReaderT WriterEnv (StateT WriterState m) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envListNumId
Bool
numIdUsed <- (WriterState -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Bool
stNumIdUsed
let numid' :: Int
numid' = if Bool
numIdUsed then Int
baseListId else Int
numid
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stNumIdUsed :: Bool
stNumIdUsed = Bool
True }
let listPr :: [Element]
listPr = [Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:numPr" []
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:ilvl" [("w:val",Int -> Text
forall a. Show a => a -> Text
tshow Int
listLevel)] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:numId" [("w:val",Int -> Text
forall a. Show a => a -> Text
tshow Int
numid')] () ] | Int
listLevel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
displayMathPara]
[Element] -> WS m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Element] -> WS m [Element]) -> [Element] -> WS m [Element]
forall a b. (a -> b) -> a -> b
$ case [Element]
listPr [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ EnvProps -> [Element]
squashProps EnvProps
props of
[] -> []
ps :: [Element]
ps -> [Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:pPr" [] [Element]
ps]
formattedString :: PandocMonad m => Text -> WS m [Element]
formattedString :: Text -> WS m [Element]
formattedString str :: Text
str =
case (Char -> Bool) -> Text -> [Text]
splitTextBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='\173') Text
str of
[w :: Text
w] -> Text -> WS m [Element]
forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString' Text
w
ws :: [Text]
ws -> do
[Element]
sh <- [Element] -> WS m [Element]
forall (m :: * -> *). PandocMonad m => [Element] -> WS m [Element]
formattedRun [Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:softHyphen" [] ()]
[Element] -> [[Element]] -> [Element]
forall a. [a] -> [[a]] -> [a]
intercalate [Element]
sh ([[Element]] -> [Element])
-> ReaderT WriterEnv (StateT WriterState m) [[Element]]
-> WS m [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> WS m [Element])
-> [Text] -> ReaderT WriterEnv (StateT WriterState m) [[Element]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> WS m [Element]
forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString' [Text]
ws
formattedString' :: PandocMonad m => Text -> WS m [Element]
formattedString' :: Text -> WS m [Element]
formattedString' str :: Text
str = do
Bool
inDel <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envInDel
[Element] -> WS m [Element]
forall (m :: * -> *). PandocMonad m => [Element] -> WS m [Element]
formattedRun [ Text -> [(Text, Text)] -> Text -> Element
mktnode (if Bool
inDel then "w:delText" else "w:t")
[("xml:space","preserve")] (Text -> Text
stripInvalidChars Text
str) ]
formattedRun :: PandocMonad m => [Element] -> WS m [Element]
formattedRun :: [Element] -> WS m [Element]
formattedRun els :: [Element]
els = do
[Element]
props <- WS m [Element]
forall (m :: * -> *). PandocMonad m => WS m [Element]
getTextProps
[Element] -> WS m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [Element]
props [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
els ]
inlineToOpenXML :: PandocMonad m => WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML :: WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML opts :: WriterOptions
opts il :: Inline
il = WS m [Content] -> WS m [Content]
forall (m :: * -> *) a. PandocMonad m => WS m a -> WS m a
withDirection (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> Inline -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML' WriterOptions
opts Inline
il
inlineToOpenXML' :: PandocMonad m => WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML' :: WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML' _ (Str str :: Text
str) =
(Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem ([Element] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) [Element]
-> WS m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString Text
str
inlineToOpenXML' opts :: WriterOptions
opts Space = WriterOptions -> Inline -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts (Text -> Inline
Str " ")
inlineToOpenXML' opts :: WriterOptions
opts SoftBreak = WriterOptions -> Inline -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML WriterOptions
opts (Text -> Inline
Str " ")
inlineToOpenXML' opts :: WriterOptions
opts (Span ("",["csl-block"],[]) ils :: [Inline]
ils) =
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' opts :: WriterOptions
opts (Span ("",["csl-left-margin"],[]) ils :: [Inline]
ils) =
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' opts :: WriterOptions
opts (Span ("",["csl-right-inline"],[]) ils :: [Inline]
ils) =
([Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" []
(Text -> [(Text, Text)] -> Text -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:t"
[("xml:space","preserve")]
("\t" :: Text))] [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++)
([Content] -> [Content]) -> WS m [Content] -> WS m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' opts :: WriterOptions
opts (Span ("",["csl-indent"],[]) ils :: [Inline]
ils) =
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
inlineToOpenXML' _ (Span (ident :: Text
ident,["comment-start"],kvs :: [(Text, Text)]
kvs) ils :: [Inline]
ils) = do
let ident' :: Text
ident' = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
ident (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "id" [(Text, Text)]
kvs)
kvs' :: [(Text, Text)]
kvs' = ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (("id" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [(Text, Text)]
kvs
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stComments :: [([(Text, Text)], [Inline])]
stComments = (("id",Text
ident')(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:[(Text, Text)]
kvs', [Inline]
ils) ([(Text, Text)], [Inline])
-> [([(Text, Text)], [Inline])] -> [([(Text, Text)], [Inline])]
forall a. a -> [a] -> [a]
: WriterState -> [([(Text, Text)], [Inline])]
stComments WriterState
st }
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:commentRangeStart" [("w:id", Text
ident')] () ]
inlineToOpenXML' _ (Span (ident :: Text
ident,["comment-end"],kvs :: [(Text, Text)]
kvs) _) =
let ident' :: Text
ident' = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
ident (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "id" [(Text, Text)]
kvs)
in [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> WS m [Content])
-> ([Element] -> [Content]) -> [Element] -> WS m [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem ([Element] -> WS m [Content]) -> [Element] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:commentRangeEnd" [("w:id", Text
ident')] ()
, Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" []
[ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rPr" []
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rStyle" [("w:val", "CommentReference")] () ]
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:commentReference" [("w:id", Text
ident')] () ]
]
inlineToOpenXML' opts :: WriterOptions
opts (Span (ident :: Text
ident,classes :: [Text]
classes,kvs :: [(Text, Text)]
kvs) ils :: [Inline]
ils) = do
WS m [Content] -> WS m [Content]
stylemod <- case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
dynamicStyleKey [(Text, Text)]
kvs of
Just (FilePath -> CharStyleName
forall a. IsString a => FilePath -> a
fromString (FilePath -> CharStyleName)
-> (Text -> FilePath) -> Text -> CharStyleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack -> CharStyleName
sty) -> do
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \s :: WriterState
s ->
WriterState
s{stDynamicTextProps :: Set CharStyleName
stDynamicTextProps = CharStyleName -> Set CharStyleName -> Set CharStyleName
forall a. Ord a => a -> Set a -> Set a
Set.insert CharStyleName
sty
(WriterState -> Set CharStyleName
stDynamicTextProps WriterState
s)}
(WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return ((WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv
(StateT WriterState m)
(WS m [Content] -> WS m [Content]))
-> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall a b. (a -> b) -> a -> b
$ WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (CharStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM CharStyleName
sty)
_ -> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return WS m [Content] -> WS m [Content]
forall a. a -> a
id
let dirmod :: ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
dirmod = case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "dir" [(Text, Text)]
kvs of
Just "rtl" -> (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env { envRTL :: Bool
envRTL = Bool
True })
Just "ltr" -> (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env { envRTL :: Bool
envRTL = Bool
False })
_ -> ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
forall a. a -> a
id
off :: Text -> WS m a -> WS m a
off x :: Text
x = Element -> WS m a -> WS m a
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode Text
x [("w:val","0")] ())
pmod :: WS m a -> WS m a
pmod = (if "csl-no-emph" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes then Text -> WS m a -> WS m a
forall (m :: * -> *) a. PandocMonad m => Text -> WS m a -> WS m a
off "w:i" else WS m a -> WS m a
forall a. a -> a
id) (WS m a -> WS m a) -> (WS m a -> WS m a) -> WS m a -> WS m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(if "csl-no-strong" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes then Text -> WS m a -> WS m a
forall (m :: * -> *) a. PandocMonad m => Text -> WS m a -> WS m a
off "w:b" else WS m a -> WS m a
forall a. a -> a
id) (WS m a -> WS m a) -> (WS m a -> WS m a) -> WS m a -> WS m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(if "csl-no-smallcaps" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes
then Text -> WS m a -> WS m a
forall (m :: * -> *) a. PandocMonad m => Text -> WS m a -> WS m a
off "w:smallCaps"
else WS m a -> WS m a
forall a. a -> a
id)
getChangeAuthorDate :: ReaderT WriterEnv (StateT WriterState m) [(Text, Text)]
getChangeAuthorDate = do
Text
defaultAuthor <- (WriterEnv -> Text)
-> ReaderT WriterEnv (StateT WriterState m) Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Text
envChangesAuthor
let author :: Text
author = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
defaultAuthor (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "author" [(Text, Text)]
kvs)
let mdate :: Maybe Text
mdate = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "date" [(Text, Text)]
kvs
[(Text, Text)]
-> ReaderT WriterEnv (StateT WriterState m) [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Text)]
-> ReaderT WriterEnv (StateT WriterState m) [(Text, Text)])
-> [(Text, Text)]
-> ReaderT WriterEnv (StateT WriterState m) [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ ("w:author", Text
author) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:
[(Text, Text)]
-> (Text -> [(Text, Text)]) -> Maybe Text -> [(Text, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\date :: Text
date -> [("w:date", Text
date)]) Maybe Text
mdate
WS m [Content] -> WS m [Content]
insmod <- if "insertion" Text -> [Text] -> Bool
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 <- (WriterState -> Int)
-> ReaderT WriterEnv (StateT WriterState m) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stInsId
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \s :: WriterState
s -> WriterState
s{stInsId :: Int
stInsId = Int
insId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1}
(WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return ((WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv
(StateT WriterState m)
(WS m [Content] -> WS m [Content]))
-> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall a b. (a -> b) -> a -> b
$ \f :: WS m [Content]
f -> do
[Content]
x <- WS m [Content]
f
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:ins"
(("w:id", Int -> Text
forall a. Show a => a -> Text
tshow Int
insId) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
changeAuthorDate) [Content]
x]
else (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return WS m [Content] -> WS m [Content]
forall a. a -> a
id
WS m [Content] -> WS m [Content]
delmod <- if "deletion" Text -> [Text] -> Bool
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 <- (WriterState -> Int)
-> ReaderT WriterEnv (StateT WriterState m) Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Int
stDelId
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \s :: WriterState
s -> WriterState
s{stDelId :: Int
stDelId = Int
delId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1}
(WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return ((WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv
(StateT WriterState m)
(WS m [Content] -> WS m [Content]))
-> (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall a b. (a -> b) -> a -> b
$ \f :: WS m [Content]
f -> (WriterEnv -> WriterEnv) -> WS m [Content] -> WS m [Content]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env->WriterEnv
env{envInDel :: Bool
envInDel=Bool
True}) (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ do
[Content]
x <- WS m [Content]
f
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:del"
(("w:id", Int -> Text
forall a. Show a => a -> Text
tshow Int
delId) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
changeAuthorDate) [Content]
x]
else (WS m [Content] -> WS m [Content])
-> ReaderT
WriterEnv (StateT WriterState m) (WS m [Content] -> WS m [Content])
forall (m :: * -> *) a. Monad m => a -> m a
return WS m [Content] -> WS m [Content]
forall a. a -> a
id
[Content]
contents <- WS m [Content] -> WS m [Content]
insmod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
delmod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
forall a.
ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
dirmod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
stylemod (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WS m [Content] -> WS m [Content]
forall a.
ReaderT WriterEnv (StateT WriterState m) a
-> ReaderT WriterEnv (StateT WriterState m) a
pmod
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
ils
Text -> [Content] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
ident [Content]
contents
inlineToOpenXML' opts :: WriterOptions
opts (Strong lst :: [Inline]
lst) =
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:b" [] ()) (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:bCs" [] ()) (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' opts :: WriterOptions
opts (Emph lst :: [Inline]
lst) =
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:i" [] ()) (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:iCs" [] ()) (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' opts :: WriterOptions
opts (Underline lst :: [Inline]
lst) =
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:u" [("w:val","single")] ()) (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' opts :: WriterOptions
opts (Subscript lst :: [Inline]
lst) =
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:vertAlign" [("w:val","subscript")] ())
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' opts :: WriterOptions
opts (Superscript lst :: [Inline]
lst) =
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:vertAlign" [("w:val","superscript")] ())
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' opts :: WriterOptions
opts (SmallCaps lst :: [Inline]
lst) =
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:smallCaps" [] ())
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' opts :: WriterOptions
opts (Strikeout lst :: [Inline]
lst) =
Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
Element -> WS m a -> WS m a
withTextProp (Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:strike" [] ())
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' _ LineBreak = [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem Element
br]
inlineToOpenXML' _ il :: Inline
il@(RawInline f :: Format
f str :: Text
str)
| Format
f Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Format
Format "openxml" = [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return
[CData -> Content
Text (CDataKind -> Text -> Maybe Integer -> CData
CData CDataKind
CDataRaw Text
str Maybe Integer
forall a. Maybe a
Nothing)]
| Bool
otherwise = do
LogMessage -> ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> ReaderT WriterEnv (StateT WriterState m) ())
-> LogMessage -> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ Inline -> LogMessage
InlineNotRendered Inline
il
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return []
inlineToOpenXML' opts :: WriterOptions
opts (Quoted quoteType :: QuoteType
quoteType lst :: [Inline]
lst) =
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts ([Inline] -> WS m [Content]) -> [Inline] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [Text -> Inline
Str Text
open] [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
++ [Inline]
lst [Inline] -> [Inline] -> [Inline]
forall a. [a] -> [a] -> [a]
++ [Text -> Inline
Str Text
close]
where (open :: Text
open, close :: Text
close) = case QuoteType
quoteType of
SingleQuote -> ("\x2018", "\x2019")
DoubleQuote -> ("\x201C", "\x201D")
inlineToOpenXML' opts :: WriterOptions
opts (Math mathType :: MathType
mathType str :: Text
str) = do
Bool
-> ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MathType
mathType MathType -> MathType -> Bool
forall a. Eq a => a -> a -> Bool
== MathType
DisplayMath) ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => WS m ()
setFirstPara
Either Inline Element
res <- (StateT WriterState m (Either Inline Element)
-> ReaderT WriterEnv (StateT WriterState m) (Either Inline Element)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT WriterState m (Either Inline Element)
-> ReaderT
WriterEnv (StateT WriterState m) (Either Inline Element))
-> (m (Either Inline Element)
-> StateT WriterState m (Either Inline Element))
-> m (Either Inline Element)
-> ReaderT WriterEnv (StateT WriterState m) (Either Inline Element)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either Inline Element)
-> StateT WriterState m (Either Inline Element)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) ((DisplayType -> [Exp] -> Element)
-> MathType -> Text -> m (Either Inline Element)
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 r :: Element
r -> [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Element -> Element
fromXLElement Element
r]
Left il :: Inline
il -> WriterOptions -> Inline -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Inline -> WS m [Content]
inlineToOpenXML' WriterOptions
opts Inline
il
inlineToOpenXML' opts :: WriterOptions
opts (Cite _ lst :: [Inline]
lst) = WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
lst
inlineToOpenXML' opts :: WriterOptions
opts (Code attrs :: Attr
attrs str :: Text
str) = do
let alltoktypes :: [TokenType]
alltoktypes = [TokenType
KeywordTok ..]
[(TokenType, Element)]
tokTypesMap <- (TokenType
-> ReaderT WriterEnv (StateT WriterState m) (TokenType, Element))
-> [TokenType]
-> ReaderT WriterEnv (StateT WriterState m) [(TokenType, Element)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\tt :: TokenType
tt -> (,) TokenType
tt (Element -> (TokenType, Element))
-> WS m Element
-> ReaderT WriterEnv (StateT WriterState m) (TokenType, Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CharStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM (FilePath -> CharStyleName
forall a. IsString a => FilePath -> a
fromString (FilePath -> CharStyleName) -> FilePath -> CharStyleName
forall a b. (a -> b) -> a -> b
$ TokenType -> FilePath
forall a. Show a => a -> FilePath
show TokenType
tt)) [TokenType]
alltoktypes
let unhighlighted :: WS m [Content]
unhighlighted = ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem ([Element] -> [Content])
-> ([[Element]] -> [Element]) -> [[Element]] -> [Content]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> [[Element]] -> [Element]
forall a. [a] -> [[a]] -> [a]
intercalate [Element
br]) ([[Element]] -> [Content])
-> ReaderT WriterEnv (StateT WriterState m) [[Element]]
-> WS m [Content]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
(Text -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [Text] -> ReaderT WriterEnv (StateT WriterState m) [[Element]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *). PandocMonad m => Text -> WS m [Element]
formattedString (Text -> [Text]
T.lines Text
str)
formatOpenXML :: p -> [[(TokenType, t)]] -> [Element]
formatOpenXML _fmtOpts :: p
_fmtOpts = [Element] -> [[Element]] -> [Element]
forall a. [a] -> [[a]] -> [a]
intercalate [Element
br] ([[Element]] -> [Element])
-> ([[(TokenType, t)]] -> [[Element]])
-> [[(TokenType, t)]]
-> [Element]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(TokenType, t)] -> [Element])
-> [[(TokenType, t)]] -> [[Element]]
forall a b. (a -> b) -> [a] -> [b]
map (((TokenType, t) -> Element) -> [(TokenType, t)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (TokenType, t) -> Element
forall t. Node t => (TokenType, t) -> Element
toHlTok)
toHlTok :: (TokenType, t) -> Element
toHlTok (toktype :: TokenType
toktype,tok :: t
tok) =
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" []
[ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
Maybe Element -> [Element]
forall a. Maybe a -> [a]
maybeToList (TokenType -> [(TokenType, Element)] -> Maybe Element
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TokenType
toktype [(TokenType, Element)]
tokTypesMap)
, Text -> [(Text, Text)] -> t -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:t" [("xml:space","preserve")] t
tok ]
WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (CharStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM "Verbatim Char")
(WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ if Maybe Style -> Bool
forall a. Maybe a -> Bool
isNothing (WriterOptions -> Maybe Style
writerHighlightStyle WriterOptions
opts)
then WS m [Content]
unhighlighted
else case SyntaxMap
-> (FormatOptions -> [SourceLine] -> [Element])
-> Attr
-> Text
-> Either Text [Element]
forall a.
SyntaxMap
-> (FormatOptions -> [SourceLine] -> a)
-> Attr
-> Text
-> Either Text a
highlight (WriterOptions -> SyntaxMap
writerSyntaxMap WriterOptions
opts)
FormatOptions -> [SourceLine] -> [Element]
forall t p. Node t => p -> [[(TokenType, t)]] -> [Element]
formatOpenXML Attr
attrs Text
str of
Right h :: [Element]
h -> [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
h)
Left msg :: Text
msg -> do
Bool
-> ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
msg) (ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ())
-> ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ LogMessage -> ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> ReaderT WriterEnv (StateT WriterState m) ())
-> LogMessage -> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
CouldNotHighlight Text
msg
WS m [Content]
unhighlighted
inlineToOpenXML' opts :: WriterOptions
opts (Note bs :: [Block]
bs) = do
[Element]
notes <- (WriterState -> [Element])
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> [Element]
stFootnotes
Text
notenum <- ReaderT WriterEnv (StateT WriterState m) Text
forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
Element
footnoteStyle <- CharStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM "Footnote Reference"
let notemarker :: Element
notemarker = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" []
[ Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rPr" [] Element
footnoteStyle
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:footnoteRef" [] () ]
let notemarkerXml :: Inline
notemarkerXml = Format -> Text -> Inline
RawInline (Text -> Format
Format "openxml") (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ Element -> Text
ppElement Element
notemarker
let insertNoteRef :: [Block] -> [Block]
insertNoteRef (Plain ils :: [Inline]
ils : xs :: [Block]
xs) = [Inline] -> Block
Plain (Inline
notemarkerXml Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: Inline
Space Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
xs
insertNoteRef (Para ils :: [Inline]
ils : xs :: [Block]
xs) = [Inline] -> Block
Para (Inline
notemarkerXml Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: Inline
Space Inline -> [Inline] -> [Inline]
forall a. a -> [a] -> [a]
: [Inline]
ils) Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
xs
insertNoteRef xs :: [Block]
xs = [Inline] -> Block
Para [Inline
notemarkerXml] Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
xs
[Content]
contents <- (WriterEnv -> WriterEnv) -> WS m [Content] -> WS m [Content]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env{ envListLevel :: Int
envListLevel = -1
, envParaProperties :: EnvProps
envParaProperties = EnvProps
forall a. Monoid a => a
mempty
, envTextProperties :: EnvProps
envTextProperties = EnvProps
forall a. Monoid a => a
mempty })
(WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withParaPropM (ParaStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
ParaStyleName -> WS m Element
pStyleM "Footnote Text") (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Block] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Block] -> WS m [Content]
blocksToOpenXML WriterOptions
opts
([Block] -> WS m [Content]) -> [Block] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ [Block] -> [Block]
insertNoteRef [Block]
bs)
let newnote :: Element
newnote = Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:footnote" [("w:id", Text
notenum)] [Content]
contents
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \s :: WriterState
s -> WriterState
s{ stFootnotes :: [Element]
stFootnotes = Element
newnote Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
notes }
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" []
[ Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rPr" [] Element
footnoteStyle
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:footnoteReference" [("w:id", Text
notenum)] () ] ]
inlineToOpenXML' opts :: WriterOptions
opts (Link _ txt :: [Inline]
txt (Text -> Maybe (Char, Text)
T.uncons -> Just ('#', xs :: Text
xs),_)) = do
[Content]
contents <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (CharStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM "Hyperlink") (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
txt
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:hyperlink" [("w:anchor", Text -> Text
toBookmarkName Text
xs)] [Content]
contents ]
inlineToOpenXML' opts :: WriterOptions
opts (Link _ txt :: [Inline]
txt (src :: Text
src,_)) = do
[Content]
contents <- WS m Element -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a.
PandocMonad m =>
WS m Element -> WS m a -> WS m a
withTextPropM (CharStyleName -> WS m Element
forall (m :: * -> *).
PandocMonad m =>
CharStyleName -> WS m Element
rStyleM "Hyperlink") (WS m [Content] -> WS m [Content])
-> WS m [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
txt
Map Text Text
extlinks <- (WriterState -> Map Text Text)
-> ReaderT WriterEnv (StateT WriterState m) (Map Text Text)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Text Text
stExternalLinks
Text
id' <- case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
src Map Text Text
extlinks of
Just i :: Text
i -> Text -> ReaderT WriterEnv (StateT WriterState m) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
Nothing -> do
Text
i <- ("rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> ReaderT WriterEnv (StateT WriterState m) Text
-> ReaderT WriterEnv (StateT WriterState m) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT WriterEnv (StateT WriterState m) Text
forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st{ stExternalLinks :: Map Text Text
stExternalLinks =
Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
src Text
i Map Text Text
extlinks }
Text -> ReaderT WriterEnv (StateT WriterState m) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
i
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Content] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:hyperlink" [("r:id",Text
id')] [Content]
contents ]
inlineToOpenXML' opts :: WriterOptions
opts (Image attr :: Attr
attr@(imgident :: Text
imgident, _, _) alt :: [Inline]
alt (src :: Text
src, title :: Text
title)) = do
Integer
pageWidth <- (WriterEnv -> Integer)
-> ReaderT WriterEnv (StateT WriterState m) Integer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Integer
envPrintWidth
Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
imgs <- (WriterState
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString))
-> ReaderT
WriterEnv
(StateT WriterState m)
(Map FilePath (FilePath, FilePath, Maybe Text, ByteString))
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 = FilePath
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> Maybe (FilePath, FilePath, Maybe Text, ByteString)
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 (ident :: FilePath
ident, _fp :: b
_fp, mt :: Maybe Text
mt, img :: ByteString
img) = do
Text
docprid <- WS m Text
forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
Text
nvpicprid <- WS m Text
forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
(blipAttrs :: [(Text, Text)]
blipAttrs, blipContents :: [Element]
blipContents) <-
case (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=';') (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mt of
Just "image/svg+xml" -> do
MediaBag
mediabag <- ReaderT WriterEnv (StateT WriterState m) MediaBag
forall (m :: * -> *). PandocMonad m => m MediaBag
getMediaBag
Maybe FilePath
mbFallback <-
case FilePath -> MediaBag -> Maybe MediaItem
lookupMedia (Text -> FilePath
T.unpack (Text
src Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".png")) MediaBag
mediabag of
Just item :: MediaItem
item -> do
FilePath
id' <- Text -> FilePath
T.unpack (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> FilePath)
-> WS m Text -> ReaderT WriterEnv (StateT WriterState m) FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WS m Text
forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
let fp' :: FilePath
fp' = "media/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
id' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ".png"
let imgdata :: (FilePath, FilePath, Maybe Text, ByteString)
imgdata = (FilePath
id',
FilePath
fp',
Text -> Maybe Text
forall a. a -> Maybe a
Just (MediaItem -> Text
mediaMimeType MediaItem
item),
ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ MediaItem -> ByteString
mediaContents MediaItem
item)
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st { stImages :: Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages =
FilePath
-> (FilePath, FilePath, Maybe Text, ByteString)
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
fp' (FilePath, FilePath, Maybe Text, ByteString)
imgdata (Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString))
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
forall a b. (a -> b) -> a -> b
$ WriterState
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages WriterState
st }
Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe FilePath))
-> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
id'
Nothing -> Maybe FilePath
-> ReaderT WriterEnv (StateT WriterState m) (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
let extLst :: Element
extLst = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:extLst" []
[ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:ext"
[("uri","{28A0092B-C50C-407E-A947-70E740481C1C}")]
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a14:useLocalDpi"
[("xmlns:a14","http://schemas.microsoft.com/office/drawing/2010/main"),
("val","0")] () ]
, Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:ext"
[("uri","{96DAC541-7B7A-43D3-8B79-37D633B846F1}")]
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "asvg:svgBlip"
[("xmlns:asvg", "http://schemas.microsoft.com/office/drawing/2016/SVG/main"),
("r:embed",FilePath -> Text
T.pack FilePath
ident)] () ]
]
([(Text, Text)], [Element])
-> ReaderT
WriterEnv (StateT WriterState m) ([(Text, Text)], [Element])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Text)]
-> (FilePath -> [(Text, Text)]) -> Maybe FilePath -> [(Text, Text)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\id'' :: FilePath
id'' -> [("r:embed", FilePath -> Text
T.pack FilePath
id'')]) Maybe FilePath
mbFallback,
[Element
extLst])
_ -> ([(Text, Text)], [Element])
-> ReaderT
WriterEnv (StateT WriterState m) ([(Text, Text)], [Element])
forall (m :: * -> *) a. Monad m => a -> m a
return ([("r:embed", FilePath -> Text
T.pack FilePath
ident)], [])
let
(xpt :: Double
xpt,ypt :: Double
ypt) = WriterOptions -> Attr -> ImageSize -> (Double, Double)
desiredSizeInPoints WriterOptions
opts Attr
attr
((Text -> ImageSize)
-> (ImageSize -> ImageSize) -> Either Text ImageSize -> ImageSize
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ImageSize -> Text -> ImageSize
forall a b. a -> b -> a
const ImageSize
forall a. Default a => a
def) ImageSize -> ImageSize
forall a. a -> a
id (WriterOptions -> ByteString -> Either Text ImageSize
imageSize WriterOptions
opts ByteString
img))
(xemu :: Integer
xemu,yemu :: Integer
yemu) = (Double, Double) -> Integer -> (Integer, Integer)
fitToPage (Double
xpt Double -> Double -> Double
forall a. Num a => a -> a -> a
* 12700, Double
ypt Double -> Double -> Double
forall a. Num a => a -> a -> a
* 12700)
(Integer
pageWidth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* 12700)
cNvPicPr :: Element
cNvPicPr = Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "pic:cNvPicPr" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:picLocks" [("noChangeArrowheads","1")
,("noChangeAspect","1")] ()
nvPicPr :: Element
nvPicPr = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "pic:nvPicPr" []
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "pic:cNvPr"
[("descr",Text
src)
,("id", Text
nvpicprid)
,("name","Picture")] ()
, Element
cNvPicPr ]
blipFill :: Element
blipFill = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "pic:blipFill" []
[ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:blip" [(Text, Text)]
blipAttrs [Element]
blipContents
, Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:stretch" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:fillRect" [] ()
]
xfrm :: Element
xfrm = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:xfrm" []
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:off" [("x","0"),("y","0")] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:ext" [("cx",Integer -> Text
forall a. Show a => a -> Text
tshow Integer
xemu)
,("cy",Integer -> Text
forall a. Show a => a -> Text
tshow Integer
yemu)] () ]
prstGeom :: Element
prstGeom = Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:prstGeom" [("prst","rect")] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:avLst" [] ()
ln :: Element
ln = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:ln" [("w","9525")]
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:noFill" [] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:headEnd" [] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:tailEnd" [] () ]
spPr :: Element
spPr = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "pic:spPr" [("bwMode","auto")]
[Element
xfrm, Element
prstGeom, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:noFill" [] (), Element
ln]
graphic :: Element
graphic = Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:graphic" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "a:graphicData"
[("uri","http://schemas.openxmlformats.org/drawingml/2006/picture")]
[ Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "pic:pic" []
[ Element
nvPicPr
, Element
blipFill
, Element
spPr
]
]
imgElt :: Element
imgElt = Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> Element -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:drawing" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "wp:inline" []
[ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "wp:extent" [("cx",Integer -> Text
forall a. Show a => a -> Text
tshow Integer
xemu),("cy",Integer -> Text
forall a. Show a => a -> Text
tshow Integer
yemu)] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "wp:effectExtent"
[("b","0"),("l","0"),("r","0"),("t","0")] ()
, Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "wp:docPr"
[ ("descr", [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Inline]
alt)
, ("title", Text
title)
, ("id", Text
docprid)
, ("name","Picture")
] ()
, Element
graphic
]
[Content] -> ReaderT WriterEnv (StateT WriterState m) [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element -> Content
Elem Element
imgElt]
Text -> [Content] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
Text -> [Content] -> WS m [Content]
wrapBookmark Text
imgident ([Content] -> WS m [Content]) -> WS m [Content] -> WS m [Content]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Maybe (FilePath, FilePath, Maybe Text, ByteString)
stImage of
Just imgData :: (FilePath, FilePath, Maybe Text, ByteString)
imgData -> (FilePath, FilePath, Maybe Text, ByteString) -> WS m [Content]
forall (m :: * -> *) b.
PandocMonad m =>
(FilePath, b, Maybe Text, ByteString)
-> ReaderT WriterEnv (StateT WriterState m) [Content]
generateImgElt (FilePath, FilePath, Maybe Text, ByteString)
imgData
Nothing -> ( do
(img :: ByteString
img, mt :: Maybe Text
mt) <- Text
-> ReaderT
WriterEnv (StateT WriterState m) (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
P.fetchItem Text
src
Text
ident <- ("rId" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> ReaderT WriterEnv (StateT WriterState m) Text
-> ReaderT WriterEnv (StateT WriterState m) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT WriterEnv (StateT WriterState m) Text
forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
let
imgext :: Text
imgext = case Maybe Text
mt Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Text
extensionFromMimeType of
Just x :: Text
x -> "." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x
Nothing -> case ByteString -> Maybe ImageType
imageType ByteString
img of
Just Png -> ".png"
Just Jpeg -> ".jpeg"
Just Gif -> ".gif"
Just Pdf -> ".pdf"
Just Eps -> ".eps"
Just Svg -> ".svg"
Just Emf -> ".emf"
Just Tiff -> ".tiff"
Nothing -> ""
imgpath :: Text
imgpath = "media/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
imgext
mbMimeType :: Maybe Text
mbMimeType = Maybe Text
mt Maybe Text -> Maybe Text -> Maybe Text
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
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
alt
else do
(WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ())
-> (WriterState -> WriterState)
-> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ \st :: WriterState
st -> WriterState
st { stImages :: Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages = FilePath
-> (FilePath, FilePath, Maybe Text, ByteString)
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
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 (Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString))
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
forall a b. (a -> b) -> a -> b
$ WriterState
-> Map FilePath (FilePath, FilePath, Maybe Text, ByteString)
stImages WriterState
st }
(FilePath, FilePath, Maybe Text, ByteString) -> WS m [Content]
forall (m :: * -> *) b.
PandocMonad m =>
(FilePath, b, Maybe Text, ByteString)
-> ReaderT WriterEnv (StateT WriterState m) [Content]
generateImgElt (FilePath, FilePath, Maybe Text, ByteString)
imgData
)
WS m [Content] -> (PandocError -> WS m [Content]) -> WS m [Content]
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` ( \e :: PandocError
e -> do
LogMessage -> ReaderT WriterEnv (StateT WriterState m) ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> ReaderT WriterEnv (StateT WriterState m) ())
-> LogMessage -> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LogMessage
CouldNotFetchResource Text
src (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (PandocError -> FilePath
forall a. Show a => a -> FilePath
show PandocError
e)
WriterOptions -> [Inline] -> WS m [Content]
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Inline] -> WS m [Content]
inlinesToOpenXML WriterOptions
opts [Inline]
alt
)
br :: Element
br :: Element
br = Text -> [(Text, Text)] -> [Element] -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:r" [] [Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:br" [] ()]
withDirection :: PandocMonad m => WS m a -> WS m a
withDirection :: WS m a -> WS m a
withDirection x :: WS m a
x = do
Bool
isRTL <- (WriterEnv -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Bool
envRTL
EnvProps
paraProps <- (WriterEnv -> EnvProps)
-> ReaderT WriterEnv (StateT WriterState m) EnvProps
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> EnvProps
envParaProperties
EnvProps
textProps <- (WriterEnv -> EnvProps)
-> ReaderT WriterEnv (StateT WriterState m) EnvProps
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> EnvProps
envTextProperties
let paraProps' :: [Element]
paraProps' = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter (\e :: Element
e -> (QName -> Text
qName (QName -> Text) -> (Element -> QName) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> QName
elName) Element
e Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "bidi") (EnvProps -> [Element]
otherElements EnvProps
paraProps)
textProps' :: [Element]
textProps' = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter (\e :: Element
e -> (QName -> Text
qName (QName -> Text) -> (Element -> QName) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> QName
elName) Element
e Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= "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
then ((WriterEnv -> WriterEnv) -> WS m a -> WS m a)
-> WS m a -> (WriterEnv -> WriterEnv) -> WS m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WriterEnv -> WriterEnv) -> WS m a -> WS m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local WS m a
x ((WriterEnv -> WriterEnv) -> WS m a)
-> (WriterEnv -> WriterEnv) -> WS m a
forall a b. (a -> b) -> a -> b
$
\env :: WriterEnv
env -> WriterEnv
env { envParaProperties :: EnvProps
envParaProperties = Maybe Element -> [Element] -> EnvProps
EnvProps Maybe Element
paraStyle ([Element] -> EnvProps) -> [Element] -> EnvProps
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:bidi" [] () Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
paraProps'
, envTextProperties :: EnvProps
envTextProperties = Maybe Element -> [Element] -> EnvProps
EnvProps Maybe Element
textStyle ([Element] -> EnvProps) -> [Element] -> EnvProps
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:rtl" [] () Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
textProps'
}
else ((WriterEnv -> WriterEnv) -> WS m a -> WS m a)
-> WS m a -> (WriterEnv -> WriterEnv) -> WS m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WriterEnv -> WriterEnv) -> WS m a -> WS m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local WS m a
x ((WriterEnv -> WriterEnv) -> WS m a)
-> (WriterEnv -> WriterEnv) -> WS m a
forall a b. (a -> b) -> a -> b
$ \env :: 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 :: Text -> [Content] -> WS m [Content]
wrapBookmark "" contents :: [Content]
contents = [Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return [Content]
contents
wrapBookmark ident :: Text
ident contents :: [Content]
contents = do
Text
id' <- WS m Text
forall (m :: * -> *). PandocMonad m => WS m Text
getUniqueId
let bookmarkStart :: Element
bookmarkStart = Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:bookmarkStart"
[("w:id", Text
id')
,("w:name", Text -> Text
toBookmarkName Text
ident)] ()
bookmarkEnd :: Element
bookmarkEnd = Text -> [(Text, Text)] -> () -> Element
forall t. Node t => Text -> [(Text, Text)] -> t -> Element
mknode "w:bookmarkEnd" [("w:id", Text
id')] ()
[Content] -> WS m [Content]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Content] -> WS m [Content]) -> [Content] -> WS m [Content]
forall a b. (a -> b) -> a -> b
$ Element -> Content
Elem Element
bookmarkStart Content -> [Content] -> [Content]
forall a. a -> [a] -> [a]
: [Content]
contents [Content] -> [Content] -> [Content]
forall a. [a] -> [a] -> [a]
++ [Element -> Content
Elem Element
bookmarkEnd]
toBookmarkName :: Text -> Text
toBookmarkName :: Text -> Text
toBookmarkName s :: Text
s
| Just (c :: Char
c, _) <- Text -> Maybe (Char, Text)
T.uncons Text
s
, Char -> Bool
isLetter Char
c
, Text -> Int
T.length Text
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 40 = Text
s
| Bool
otherwise = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ 'X' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop 1 (Digest SHA1State -> FilePath
forall t. Digest t -> FilePath
showDigest (ByteString -> Digest SHA1State
sha1 (Text -> ByteString
fromTextLazy (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict Text
s)))