{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternGuards #-}
module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive
) where
import Prelude
import Control.Monad.Except (throwError, catchError)
import Control.Monad.Reader
import Control.Monad.State
import Codec.Archive.Zip
import Data.Char (toUpper)
import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse)
import Data.Default
import qualified Data.Text as T
import Data.Time (formatTime, defaultTimeLocale)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)
import Text.XML.Light
import Text.Pandoc.Definition
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.Class (PandocMonad)
import Text.Pandoc.Error (PandocError(..))
import qualified Text.Pandoc.Class as P
import Text.Pandoc.Options
import Text.Pandoc.MIME
import qualified Data.ByteString.Lazy as BL
import Text.Pandoc.Writers.OOXML
import qualified Data.Map as M
import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, maybeToList, catMaybes, isNothing)
import Text.Pandoc.ImageSize
import Control.Applicative ((<|>))
import System.FilePath.Glob
import Text.DocTemplates (FromContext(lookupContext))
import Text.TeXMath
import Text.Pandoc.Writers.Math (convertMath)
import Text.Pandoc.Writers.Powerpoint.Presentation
import Skylighting (fromColor)
type EMU = Integer
pixelsToEmu :: Pixels -> EMU
pixelsToEmu :: Pixels -> Pixels
pixelsToEmu = (12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
*)
initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int
initialGlobalIds :: Archive -> Archive -> Map FilePath Int
initialGlobalIds refArchive :: Archive
refArchive distArchive :: Archive
distArchive =
let archiveFiles :: [FilePath]
archiveFiles = Archive -> [FilePath]
filesInArchive Archive
refArchive [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
`union` Archive -> [FilePath]
filesInArchive Archive
distArchive
mediaPaths :: [FilePath]
mediaPaths = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf "ppt/media/image") [FilePath]
archiveFiles
go :: FilePath -> Maybe (FilePath, Int)
go :: FilePath -> Maybe (FilePath, Int)
go fp :: FilePath
fp = do
FilePath
s <- FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "ppt/media/image" (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath) -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath, FilePath)
splitExtension FilePath
fp
(n :: Int
n, _) <- [(Int, FilePath)] -> Maybe (Int, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Int, FilePath)] -> Maybe (Int, FilePath))
-> [(Int, FilePath)] -> Maybe (Int, FilePath)
forall a b. (a -> b) -> a -> b
$ ReadS Int
forall a. Read a => ReadS a
reads FilePath
s
(FilePath, Int) -> Maybe (FilePath, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
fp, Int
n)
in
[(FilePath, Int)] -> Map FilePath Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(FilePath, Int)] -> Map FilePath Int)
-> [(FilePath, Int)] -> Map FilePath Int
forall a b. (a -> b) -> a -> b
$ (FilePath -> Maybe (FilePath, Int))
-> [FilePath] -> [(FilePath, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe (FilePath, Int)
go [FilePath]
mediaPaths
getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer)
getPresentationSize :: Archive -> Archive -> Maybe (Pixels, Pixels)
getPresentationSize refArchive :: Archive
refArchive distArchive :: Archive
distArchive = do
Entry
entry <- FilePath -> Archive -> Maybe Entry
findEntryByPath "ppt/presentation.xml" Archive
refArchive Maybe Entry -> Maybe Entry -> Maybe Entry
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
FilePath -> Archive -> Maybe Entry
findEntryByPath "ppt/presentation.xml" Archive
distArchive
Element
presElement <- FilePath -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc (FilePath -> Maybe Element) -> FilePath -> Maybe Element
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
UTF8.toStringLazy (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
fromEntry Entry
entry
let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
presElement
Element
sldSize <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "sldSz") Element
presElement
FilePath
cxS <- QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "cx" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
sldSize
FilePath
cyS <- QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "cy" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
sldSize
(cx :: Pixels
cx, _) <- [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Pixels, FilePath)] -> Maybe (Pixels, FilePath))
-> [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a b. (a -> b) -> a -> b
$ ReadS Pixels
forall a. Read a => ReadS a
reads FilePath
cxS :: Maybe (Integer, String)
(cy :: Pixels
cy, _) <- [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Pixels, FilePath)] -> Maybe (Pixels, FilePath))
-> [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a b. (a -> b) -> a -> b
$ ReadS Pixels
forall a. Read a => ReadS a
reads FilePath
cyS :: Maybe (Integer, String)
(Pixels, Pixels) -> Maybe (Pixels, Pixels)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pixels
cx Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700, Pixels
cy Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700)
data WriterEnv = WriterEnv { WriterEnv -> Archive
envRefArchive :: Archive
, WriterEnv -> Archive
envDistArchive :: Archive
, WriterEnv -> UTCTime
envUTCTime :: UTCTime
, WriterEnv -> WriterOptions
envOpts :: WriterOptions
, WriterEnv -> (Pixels, Pixels)
envPresentationSize :: (Integer, Integer)
, :: Bool
, WriterEnv -> Bool
envInList :: Bool
, WriterEnv -> Bool
envInNoteSlide :: Bool
, WriterEnv -> Int
envCurSlideId :: Int
, WriterEnv -> Int
envSlideIdOffset :: Int
, WriterEnv -> ContentType
envContentType :: ContentType
, WriterEnv -> Map SlideId Int
envSlideIdMap :: M.Map SlideId Int
, WriterEnv -> Map Int Int
envSpeakerNotesIdMap :: M.Map Int Int
}
deriving (Int -> WriterEnv -> ShowS
[WriterEnv] -> ShowS
WriterEnv -> FilePath
(Int -> WriterEnv -> ShowS)
-> (WriterEnv -> FilePath)
-> ([WriterEnv] -> ShowS)
-> Show WriterEnv
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [WriterEnv] -> ShowS
$cshowList :: [WriterEnv] -> ShowS
show :: WriterEnv -> FilePath
$cshow :: WriterEnv -> FilePath
showsPrec :: Int -> WriterEnv -> ShowS
$cshowsPrec :: Int -> WriterEnv -> ShowS
Show)
instance Default WriterEnv where
def :: WriterEnv
def = WriterEnv :: Archive
-> Archive
-> UTCTime
-> WriterOptions
-> (Pixels, Pixels)
-> Bool
-> Bool
-> Bool
-> Int
-> Int
-> ContentType
-> Map SlideId Int
-> Map Int Int
-> WriterEnv
WriterEnv { envRefArchive :: Archive
envRefArchive = Archive
emptyArchive
, envDistArchive :: Archive
envDistArchive = Archive
emptyArchive
, envUTCTime :: UTCTime
envUTCTime = POSIXTime -> UTCTime
posixSecondsToUTCTime 0
, envOpts :: WriterOptions
envOpts = WriterOptions
forall a. Default a => a
def
, envPresentationSize :: (Pixels, Pixels)
envPresentationSize = (720, 540)
, envSlideHasHeader :: Bool
envSlideHasHeader = Bool
False
, envInList :: Bool
envInList = Bool
False
, envInNoteSlide :: Bool
envInNoteSlide = Bool
False
, envCurSlideId :: Int
envCurSlideId = 1
, envSlideIdOffset :: Int
envSlideIdOffset = 1
, envContentType :: ContentType
envContentType = ContentType
NormalContent
, envSlideIdMap :: Map SlideId Int
envSlideIdMap = Map SlideId Int
forall a. Monoid a => a
mempty
, envSpeakerNotesIdMap :: Map Int Int
envSpeakerNotesIdMap = Map Int Int
forall a. Monoid a => a
mempty
}
data ContentType = NormalContent
| TwoColumnLeftContent
| TwoColumnRightContent
deriving (Int -> ContentType -> ShowS
[ContentType] -> ShowS
ContentType -> FilePath
(Int -> ContentType -> ShowS)
-> (ContentType -> FilePath)
-> ([ContentType] -> ShowS)
-> Show ContentType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ContentType] -> ShowS
$cshowList :: [ContentType] -> ShowS
show :: ContentType -> FilePath
$cshow :: ContentType -> FilePath
showsPrec :: Int -> ContentType -> ShowS
$cshowsPrec :: Int -> ContentType -> ShowS
Show, ContentType -> ContentType -> Bool
(ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool) -> Eq ContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentType -> ContentType -> Bool
$c/= :: ContentType -> ContentType -> Bool
== :: ContentType -> ContentType -> Bool
$c== :: ContentType -> ContentType -> Bool
Eq)
data MediaInfo = MediaInfo { MediaInfo -> FilePath
mInfoFilePath :: FilePath
, MediaInfo -> Int
mInfoLocalId :: Int
, MediaInfo -> Int
mInfoGlobalId :: Int
, MediaInfo -> Maybe MimeType
mInfoMimeType :: Maybe MimeType
, MediaInfo -> Maybe MimeType
mInfoExt :: Maybe T.Text
, MediaInfo -> Bool
mInfoCaption :: Bool
} deriving (Int -> MediaInfo -> ShowS
[MediaInfo] -> ShowS
MediaInfo -> FilePath
(Int -> MediaInfo -> ShowS)
-> (MediaInfo -> FilePath)
-> ([MediaInfo] -> ShowS)
-> Show MediaInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MediaInfo] -> ShowS
$cshowList :: [MediaInfo] -> ShowS
show :: MediaInfo -> FilePath
$cshow :: MediaInfo -> FilePath
showsPrec :: Int -> MediaInfo -> ShowS
$cshowsPrec :: Int -> MediaInfo -> ShowS
Show, MediaInfo -> MediaInfo -> Bool
(MediaInfo -> MediaInfo -> Bool)
-> (MediaInfo -> MediaInfo -> Bool) -> Eq MediaInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MediaInfo -> MediaInfo -> Bool
$c/= :: MediaInfo -> MediaInfo -> Bool
== :: MediaInfo -> MediaInfo -> Bool
$c== :: MediaInfo -> MediaInfo -> Bool
Eq)
data WriterState = WriterState { WriterState -> Map Int (Map Int LinkTarget)
stLinkIds :: M.Map Int (M.Map Int LinkTarget)
, WriterState -> Map Int [MediaInfo]
stMediaIds :: M.Map Int [MediaInfo]
, WriterState -> Map FilePath Int
stMediaGlobalIds :: M.Map FilePath Int
} deriving (Int -> WriterState -> ShowS
[WriterState] -> ShowS
WriterState -> FilePath
(Int -> WriterState -> ShowS)
-> (WriterState -> FilePath)
-> ([WriterState] -> ShowS)
-> Show WriterState
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [WriterState] -> ShowS
$cshowList :: [WriterState] -> ShowS
show :: WriterState -> FilePath
$cshow :: WriterState -> FilePath
showsPrec :: Int -> WriterState -> ShowS
$cshowsPrec :: Int -> WriterState -> ShowS
Show, WriterState -> WriterState -> Bool
(WriterState -> WriterState -> Bool)
-> (WriterState -> WriterState -> Bool) -> Eq WriterState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriterState -> WriterState -> Bool
$c/= :: WriterState -> WriterState -> Bool
== :: WriterState -> WriterState -> Bool
$c== :: WriterState -> WriterState -> Bool
Eq)
instance Default WriterState where
def :: WriterState
def = WriterState :: Map Int (Map Int LinkTarget)
-> Map Int [MediaInfo] -> Map FilePath Int -> WriterState
WriterState { stLinkIds :: Map Int (Map Int LinkTarget)
stLinkIds = Map Int (Map Int LinkTarget)
forall a. Monoid a => a
mempty
, stMediaIds :: Map Int [MediaInfo]
stMediaIds = Map Int [MediaInfo]
forall a. Monoid a => a
mempty
, stMediaGlobalIds :: Map FilePath Int
stMediaGlobalIds = Map FilePath Int
forall a. Monoid a => a
mempty
}
type P m = ReaderT WriterEnv (StateT WriterState m)
runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
runP :: WriterEnv -> WriterState -> P m a -> m a
runP env :: WriterEnv
env st :: WriterState
st p :: P m a
p = StateT WriterState m a -> WriterState -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (P m a -> WriterEnv -> StateT WriterState m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT P m a
p WriterEnv
env) WriterState
st
findAttrText :: QName -> Element -> Maybe T.Text
findAttrText :: QName -> Element -> Maybe MimeType
findAttrText n :: QName
n = (FilePath -> MimeType) -> Maybe FilePath -> Maybe MimeType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> MimeType
T.pack (Maybe FilePath -> Maybe MimeType)
-> (Element -> Maybe FilePath) -> Element -> Maybe MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Element -> Maybe FilePath
findAttr QName
n
monospaceFont :: Monad m => P m T.Text
monospaceFont :: P m MimeType
monospaceFont = do
Context MimeType
vars <- WriterOptions -> Context MimeType
writerVariables (WriterOptions -> Context MimeType)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
-> ReaderT WriterEnv (StateT WriterState m) (Context MimeType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOpts
case MimeType -> Context MimeType -> Maybe MimeType
forall a b. FromContext a b => MimeType -> Context a -> Maybe b
lookupContext "monofont" Context MimeType
vars of
Just s :: MimeType
s -> MimeType -> P m MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return MimeType
s
Nothing -> MimeType -> P m MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return "Courier"
fontSizeAttributes :: Monad m => RunProps -> P m [(String, String)]
fontSizeAttributes :: RunProps -> P m NameSpaces
fontSizeAttributes RunProps { rPropForceSize :: RunProps -> Maybe Pixels
rPropForceSize = Just sz :: Pixels
sz } =
NameSpaces -> P m NameSpaces
forall (m :: * -> *) a. Monad m => a -> m a
return [("sz", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ Pixels
sz Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 100)]
fontSizeAttributes _ = NameSpaces -> P m NameSpaces
forall (m :: * -> *) a. Monad m => a -> m a
return []
copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive
copyFileToArchive :: Archive -> FilePath -> P m Archive
copyFileToArchive arch :: Archive
arch fp :: FilePath
fp = do
Archive
refArchive <- (WriterEnv -> Archive) -> P m Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive) -> P m Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
case FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
fp Archive
refArchive Maybe Entry -> Maybe Entry -> Maybe Entry
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
fp Archive
distArchive of
Nothing -> PandocError -> P m Archive
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m Archive) -> PandocError -> P m Archive
forall a b. (a -> b) -> a -> b
$ MimeType -> PandocError
PandocSomeError
(MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$ FilePath -> MimeType
T.pack
(FilePath -> MimeType) -> FilePath -> MimeType
forall a b. (a -> b) -> a -> b
$ FilePath
fp FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> " missing in reference file"
Just e :: Entry
e -> Archive -> P m Archive
forall (m :: * -> *) a. Monad m => a -> m a
return (Archive -> P m Archive) -> Archive -> P m Archive
forall a b. (a -> b) -> a -> b
$ Entry -> Archive -> Archive
addEntryToArchive Entry
e Archive
arch
alwaysInheritedPatterns :: [Pattern]
alwaysInheritedPatterns :: [Pattern]
alwaysInheritedPatterns =
(FilePath -> Pattern) -> [FilePath] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Pattern
compile [ "docProps/app.xml"
, "ppt/slideLayouts/slideLayout*.xml"
, "ppt/slideLayouts/_rels/slideLayout*.xml.rels"
, "ppt/slideMasters/slideMaster1.xml"
, "ppt/slideMasters/_rels/slideMaster1.xml.rels"
, "ppt/theme/theme1.xml"
, "ppt/theme/_rels/theme1.xml.rels"
, "ppt/presProps.xml"
, "ppt/tableStyles.xml"
, "ppt/media/image*"
]
contingentInheritedPatterns :: Presentation -> [Pattern]
contingentInheritedPatterns :: Presentation -> [Pattern]
contingentInheritedPatterns pres :: Presentation
pres = [] [Pattern] -> [Pattern] -> [Pattern]
forall a. Semigroup a => a -> a -> a
<>
if Presentation -> Bool
presHasSpeakerNotes Presentation
pres
then (FilePath -> Pattern) -> [FilePath] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Pattern
compile [ "ppt/notesMasters/notesMaster*.xml"
, "ppt/notesMasters/_rels/notesMaster*.xml.rels"
, "ppt/theme/theme2.xml"
, "ppt/theme/_rels/theme2.xml.rels"
]
else []
inheritedPatterns :: Presentation -> [Pattern]
inheritedPatterns :: Presentation -> [Pattern]
inheritedPatterns pres :: Presentation
pres =
[Pattern]
alwaysInheritedPatterns [Pattern] -> [Pattern] -> [Pattern]
forall a. Semigroup a => a -> a -> a
<> Presentation -> [Pattern]
contingentInheritedPatterns Presentation
pres
patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]
patternToFilePaths :: Pattern -> P m [FilePath]
patternToFilePaths pat :: Pattern
pat = do
Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
let archiveFiles :: [FilePath]
archiveFiles = Archive -> [FilePath]
filesInArchive Archive
refArchive [FilePath] -> [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a] -> [a]
`union` Archive -> [FilePath]
filesInArchive Archive
distArchive
[FilePath] -> P m [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> P m [FilePath]) -> [FilePath] -> P m [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pattern -> FilePath -> Bool
match Pattern
pat) [FilePath]
archiveFiles
patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]
patternsToFilePaths :: [Pattern] -> P m [FilePath]
patternsToFilePaths pats :: [Pattern]
pats = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath])
-> ReaderT WriterEnv (StateT WriterState m) [[FilePath]]
-> P m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern -> P m [FilePath])
-> [Pattern]
-> ReaderT WriterEnv (StateT WriterState m) [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern -> P m [FilePath]
forall (m :: * -> *). PandocMonad m => Pattern -> P m [FilePath]
patternToFilePaths [Pattern]
pats
requiredFiles :: [FilePath]
requiredFiles :: [FilePath]
requiredFiles = [ "docProps/app.xml"
, "ppt/presProps.xml"
, "ppt/slideLayouts/slideLayout1.xml"
, "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
, "ppt/slideLayouts/slideLayout2.xml"
, "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
, "ppt/slideLayouts/slideLayout3.xml"
, "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
, "ppt/slideLayouts/slideLayout4.xml"
, "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
, "ppt/slideMasters/slideMaster1.xml"
, "ppt/slideMasters/_rels/slideMaster1.xml.rels"
, "ppt/theme/theme1.xml"
, "ppt/tableStyles.xml"
]
presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive
presentationToArchiveP :: Presentation -> P m Archive
presentationToArchiveP p :: Presentation
p@(Presentation docProps :: DocProps
docProps slides :: [Slide]
slides) = do
[FilePath]
filePaths <- [Pattern] -> P m [FilePath]
forall (m :: * -> *). PandocMonad m => [Pattern] -> P m [FilePath]
patternsToFilePaths ([Pattern] -> P m [FilePath]) -> [Pattern] -> P m [FilePath]
forall a b. (a -> b) -> a -> b
$ Presentation -> [Pattern]
inheritedPatterns Presentation
p
let missingFiles :: [FilePath]
missingFiles = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\fp :: FilePath
fp -> Bool -> Bool
not (FilePath
fp FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
filePaths)) [FilePath]
requiredFiles
Bool
-> ReaderT WriterEnv (StateT WriterState m) ()
-> ReaderT WriterEnv (StateT WriterState m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
missingFiles)
(PandocError -> ReaderT WriterEnv (StateT WriterState m) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> ReaderT WriterEnv (StateT WriterState m) ())
-> PandocError -> ReaderT WriterEnv (StateT WriterState m) ()
forall a b. (a -> b) -> a -> b
$
MimeType -> PandocError
PandocSomeError (MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$
"The following required files are missing:\n" MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<>
([MimeType] -> MimeType
T.unlines ([MimeType] -> MimeType) -> [MimeType] -> MimeType
forall a b. (a -> b) -> a -> b
$ (FilePath -> MimeType) -> [FilePath] -> [MimeType]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> MimeType
T.pack (FilePath -> MimeType) -> ShowS -> FilePath -> MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (" " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>)) [FilePath]
missingFiles)
)
Archive
newArch' <- (Archive -> FilePath -> P m Archive)
-> Archive -> [FilePath] -> P m Archive
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Archive -> FilePath -> P m Archive
forall (m :: * -> *).
PandocMonad m =>
Archive -> FilePath -> P m Archive
copyFileToArchive Archive
emptyArchive [FilePath]
filePaths
Entry
viewPropsEntry <- P m Entry
forall (m :: * -> *). PandocMonad m => P m Entry
makeViewPropsEntry
Entry
docPropsEntry <- DocProps -> P m Entry
forall (m :: * -> *). PandocMonad m => DocProps -> P m Entry
docPropsToEntry DocProps
docProps
Entry
docCustomPropsEntry <- DocProps -> P m Entry
forall (m :: * -> *). PandocMonad m => DocProps -> P m Entry
docCustomPropsToEntry DocProps
docProps
Entry
relsEntry <- P m Entry
forall (m :: * -> *). PandocMonad m => P m Entry
topLevelRelsEntry
Entry
presEntry <- Presentation -> P m Entry
forall (m :: * -> *). PandocMonad m => Presentation -> P m Entry
presentationToPresEntry Presentation
p
Entry
presRelsEntry <- Presentation -> P m Entry
forall (m :: * -> *). PandocMonad m => Presentation -> P m Entry
presentationToRelsEntry Presentation
p
[Entry]
slideEntries <- (Slide -> P m Entry)
-> [Slide] -> ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> P m Entry
forall (m :: * -> *). PandocMonad m => Slide -> P m Entry
slideToEntry [Slide]
slides
[Entry]
slideRelEntries <- (Slide -> P m Entry)
-> [Slide] -> ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> P m Entry
forall (m :: * -> *). PandocMonad m => Slide -> P m Entry
slideToSlideRelEntry [Slide]
slides
[Entry]
spkNotesEntries <- [Maybe Entry] -> [Entry]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Entry] -> [Entry])
-> ReaderT WriterEnv (StateT WriterState m) [Maybe Entry]
-> ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Entry))
-> [Slide]
-> ReaderT WriterEnv (StateT WriterState m) [Maybe Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Entry)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Entry)
slideToSpeakerNotesEntry [Slide]
slides
[Entry]
spkNotesRelEntries <- [Maybe Entry] -> [Entry]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Entry] -> [Entry])
-> ReaderT WriterEnv (StateT WriterState m) [Maybe Entry]
-> ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Entry))
-> [Slide]
-> ReaderT WriterEnv (StateT WriterState m) [Maybe Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Entry)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Entry)
slideToSpeakerNotesRelEntry [Slide]
slides
[Entry]
mediaEntries <- ReaderT WriterEnv (StateT WriterState m) [Entry]
forall (m :: * -> *). PandocMonad m => P m [Entry]
makeMediaEntries
Entry
contentTypesEntry <- Presentation -> P m ContentTypes
forall (m :: * -> *).
PandocMonad m =>
Presentation -> P m ContentTypes
presentationToContentTypes Presentation
p P m ContentTypes -> (ContentTypes -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ContentTypes -> P m Entry
forall (m :: * -> *). PandocMonad m => ContentTypes -> P m Entry
contentTypesToEntry
Archive -> P m Archive
forall (m :: * -> *) a. Monad m => a -> m a
return (Archive -> P m Archive) -> Archive -> P m Archive
forall a b. (a -> b) -> a -> b
$ (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
newArch' ([Entry] -> Archive) -> [Entry] -> Archive
forall a b. (a -> b) -> a -> b
$
[Entry]
slideEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
[Entry]
slideRelEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
[Entry]
spkNotesEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
[Entry]
spkNotesRelEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
[Entry]
mediaEntries [Entry] -> [Entry] -> [Entry]
forall a. Semigroup a => a -> a -> a
<>
[Entry
contentTypesEntry, Entry
docPropsEntry, Entry
docCustomPropsEntry, Entry
relsEntry,
Entry
presEntry, Entry
presRelsEntry, Entry
viewPropsEntry]
makeSlideIdMap :: Presentation -> M.Map SlideId Int
makeSlideIdMap :: Presentation -> Map SlideId Int
makeSlideIdMap (Presentation _ slides :: [Slide]
slides) =
[(SlideId, Int)] -> Map SlideId Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(SlideId, Int)] -> Map SlideId Int)
-> [(SlideId, Int)] -> Map SlideId Int
forall a b. (a -> b) -> a -> b
$ ((Slide -> SlideId) -> [Slide] -> [SlideId]
forall a b. (a -> b) -> [a] -> [b]
map Slide -> SlideId
slideId [Slide]
slides) [SlideId] -> [Int] -> [(SlideId, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [1..]
makeSpeakerNotesMap :: Presentation -> M.Map Int Int
makeSpeakerNotesMap :: Presentation -> Map Int Int
makeSpeakerNotesMap (Presentation _ slides :: [Slide]
slides) =
[(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int, Int)] -> Map Int Int) -> [(Int, Int)] -> Map Int Int
forall a b. (a -> b) -> a -> b
$ (((Slide, Int) -> Maybe Int) -> [(Slide, Int)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Slide, Int) -> Maybe Int
forall a. (Slide, a) -> Maybe a
f ([(Slide, Int)] -> [Int]) -> [(Slide, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Slide]
slides [Slide] -> [Int] -> [(Slide, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [1..]) [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [1..]
where f :: (Slide, a) -> Maybe a
f (Slide _ _ notes :: SpeakerNotes
notes, n :: a
n) = if SpeakerNotes
notes SpeakerNotes -> SpeakerNotes -> Bool
forall a. Eq a => a -> a -> Bool
== SpeakerNotes
forall a. Monoid a => a
mempty
then Maybe a
forall a. Maybe a
Nothing
else a -> Maybe a
forall a. a -> Maybe a
Just a
n
presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive
presentationToArchive :: WriterOptions -> Presentation -> m Archive
presentationToArchive opts :: WriterOptions
opts pres :: Presentation
pres = do
Archive
distArchive <- (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.readDefaultDataFile "reference.pptx"
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.pptx"
UTCTime
utctime <- m UTCTime
forall (m :: * -> *). PandocMonad m => m UTCTime
P.getCurrentTime
(Pixels, Pixels)
presSize <- case Archive -> Archive -> Maybe (Pixels, Pixels)
getPresentationSize Archive
refArchive Archive
distArchive of
Just sz :: (Pixels, Pixels)
sz -> (Pixels, Pixels) -> m (Pixels, Pixels)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pixels, Pixels)
sz
Nothing -> PandocError -> m (Pixels, Pixels)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m (Pixels, Pixels))
-> PandocError -> m (Pixels, Pixels)
forall a b. (a -> b) -> a -> b
$
MimeType -> PandocError
PandocSomeError (MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$
"Could not determine presentation size"
let env :: WriterEnv
env = WriterEnv
forall a. Default a => a
def { envRefArchive :: Archive
envRefArchive = Archive
refArchive
, envDistArchive :: Archive
envDistArchive = Archive
distArchive
, envUTCTime :: UTCTime
envUTCTime = UTCTime
utctime
, envOpts :: WriterOptions
envOpts = WriterOptions
opts
, envPresentationSize :: (Pixels, Pixels)
envPresentationSize = (Pixels, Pixels)
presSize
, envSlideIdMap :: Map SlideId Int
envSlideIdMap = Presentation -> Map SlideId Int
makeSlideIdMap Presentation
pres
, envSpeakerNotesIdMap :: Map Int Int
envSpeakerNotesIdMap = Presentation -> Map Int Int
makeSpeakerNotesMap Presentation
pres
}
let st :: WriterState
st = WriterState
forall a. Default a => a
def { stMediaGlobalIds :: Map FilePath Int
stMediaGlobalIds = Archive -> Archive -> Map FilePath Int
initialGlobalIds Archive
refArchive Archive
distArchive
}
WriterEnv -> WriterState -> P m Archive -> m Archive
forall (m :: * -> *) a.
Monad m =>
WriterEnv -> WriterState -> P m a -> m a
runP WriterEnv
env WriterState
st (P m Archive -> m Archive) -> P m Archive -> m Archive
forall a b. (a -> b) -> a -> b
$ Presentation -> P m Archive
forall (m :: * -> *). PandocMonad m => Presentation -> P m Archive
presentationToArchiveP Presentation
pres
presHasSpeakerNotes :: Presentation -> Bool
presHasSpeakerNotes :: Presentation -> Bool
presHasSpeakerNotes (Presentation _ slides :: [Slide]
slides) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (SpeakerNotes -> Bool) -> [SpeakerNotes] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (SpeakerNotes
forall a. Monoid a => a
mempty SpeakerNotes -> SpeakerNotes -> Bool
forall a. Eq a => a -> a -> Bool
==) ([SpeakerNotes] -> Bool) -> [SpeakerNotes] -> Bool
forall a b. (a -> b) -> a -> b
$ (Slide -> SpeakerNotes) -> [Slide] -> [SpeakerNotes]
forall a b. (a -> b) -> [a] -> [b]
map Slide -> SpeakerNotes
slideSpeakerNotes [Slide]
slides
curSlideHasSpeakerNotes :: PandocMonad m => P m Bool
curSlideHasSpeakerNotes :: P m Bool
curSlideHasSpeakerNotes =
Int -> Map Int Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (Int -> Map Int Int -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) Int
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterEnv -> Int) -> ReaderT WriterEnv (StateT WriterState m) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envCurSlideId ReaderT WriterEnv (StateT WriterState m) (Map Int Int -> Bool)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
-> P m Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
getLayout :: PandocMonad m => Layout -> P m Element
getLayout :: Layout -> P m Element
getLayout layout :: Layout
layout = do
let layoutpath :: FilePath
layoutpath = case Layout
layout of
(MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml"
(TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml"
(ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml"
(TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml"
Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive FilePath
layoutpath
shapeHasId :: NameSpaces -> T.Text -> Element -> Bool
shapeHasId :: NameSpaces -> MimeType -> Element -> Bool
shapeHasId ns :: NameSpaces
ns ident :: MimeType
ident element :: Element
element
| Just nvSpPr :: Element
nvSpPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "nvSpPr") Element
element
, Just cNvPr :: Element
cNvPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cNvPr") Element
nvSpPr
, Just nm :: MimeType
nm <- QName -> Element -> Maybe MimeType
findAttrText (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "id" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
cNvPr =
MimeType
nm MimeType -> MimeType -> Bool
forall a. Eq a => a -> a -> Bool
== MimeType
ident
| Bool
otherwise = Bool
False
getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element
getContentShape :: NameSpaces -> Element -> P m Element
getContentShape ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem
| NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns "p" "spTree" Element
spTreeElem = do
ContentType
contentType <- (WriterEnv -> ContentType)
-> ReaderT WriterEnv (StateT WriterState m) ContentType
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> ContentType
envContentType
let contentShapes :: [Element]
contentShapes = NameSpaces -> Element -> PHType -> [Element]
getShapesByPlaceHolderType NameSpaces
ns Element
spTreeElem PHType
ObjType
case ContentType
contentType of
NormalContent | (sp :: Element
sp : _) <- [Element]
contentShapes -> Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
sp
TwoColumnLeftContent | (sp :: Element
sp : _) <- [Element]
contentShapes -> Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
sp
TwoColumnRightContent | (_ : sp :: Element
sp : _) <- [Element]
contentShapes -> Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
sp
_ -> PandocError -> P m Element
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m Element) -> PandocError -> P m Element
forall a b. (a -> b) -> a -> b
$
MimeType -> PandocError
PandocSomeError (MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$
"Could not find shape for Powerpoint content"
getContentShape _ _ = PandocError -> P m Element
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m Element) -> PandocError -> P m Element
forall a b. (a -> b) -> a -> b
$
MimeType -> PandocError
PandocSomeError (MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$
"Attempted to find content on non shapeTree"
getShapeDimensions :: NameSpaces
-> Element
-> Maybe ((Integer, Integer), (Integer, Integer))
getShapeDimensions :: NameSpaces -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getShapeDimensions ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns "p" "sp" Element
element = do
Element
spPr <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spPr") Element
element
Element
xfrm <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "a" "xfrm") Element
spPr
Element
off <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "a" "off") Element
xfrm
FilePath
xS <- QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "x" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
off
FilePath
yS <- QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "y" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
off
Element
ext <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "a" "ext") Element
xfrm
FilePath
cxS <- QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "cx" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
ext
FilePath
cyS <- QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "cy" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
ext
(x :: Pixels
x, _) <- [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Pixels, FilePath)] -> Maybe (Pixels, FilePath))
-> [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a b. (a -> b) -> a -> b
$ ReadS Pixels
forall a. Read a => ReadS a
reads FilePath
xS
(y :: Pixels
y, _) <- [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Pixels, FilePath)] -> Maybe (Pixels, FilePath))
-> [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a b. (a -> b) -> a -> b
$ ReadS Pixels
forall a. Read a => ReadS a
reads FilePath
yS
(cx :: Pixels
cx, _) <- [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Pixels, FilePath)] -> Maybe (Pixels, FilePath))
-> [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a b. (a -> b) -> a -> b
$ ReadS Pixels
forall a. Read a => ReadS a
reads FilePath
cxS
(cy :: Pixels
cy, _) <- [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Pixels, FilePath)] -> Maybe (Pixels, FilePath))
-> [(Pixels, FilePath)] -> Maybe (Pixels, FilePath)
forall a b. (a -> b) -> a -> b
$ ReadS Pixels
forall a. Read a => ReadS a
reads FilePath
cyS
((Pixels, Pixels), (Pixels, Pixels))
-> Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return (((Pixels, Pixels), (Pixels, Pixels))
-> Maybe ((Pixels, Pixels), (Pixels, Pixels)))
-> ((Pixels, Pixels), (Pixels, Pixels))
-> Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall a b. (a -> b) -> a -> b
$ ((Pixels
x Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700, Pixels
y Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700), (Pixels
cx Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700, Pixels
cy Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` 12700))
| Bool
otherwise = Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall a. Maybe a
Nothing
getMasterShapeDimensionsById :: T.Text
-> Element
-> Maybe ((Integer, Integer), (Integer, Integer))
getMasterShapeDimensionsById :: MimeType -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getMasterShapeDimensionsById ident :: MimeType
ident master :: Element
master = do
let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
master
Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
master
Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld
Element
sp <- (Element -> Bool) -> Element -> Maybe Element
filterChild (\e :: Element
e -> (NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns "p" "sp" Element
e) Bool -> Bool -> Bool
&& (NameSpaces -> MimeType -> Element -> Bool
shapeHasId NameSpaces
ns MimeType
ident Element
e)) Element
spTree
NameSpaces -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getShapeDimensions NameSpaces
ns Element
sp
getContentShapeSize :: PandocMonad m
=> NameSpaces
-> Element
-> Element
-> P m ((Integer, Integer), (Integer, Integer))
getContentShapeSize :: NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
getContentShapeSize ns :: NameSpaces
ns layout :: Element
layout master :: Element
master
| NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns "p" "sldLayout" Element
layout
, Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
, Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
Element
sp <- NameSpaces -> Element -> P m Element
forall (m :: * -> *).
PandocMonad m =>
NameSpaces -> Element -> P m Element
getContentShape NameSpaces
ns Element
spTree
case NameSpaces -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getShapeDimensions NameSpaces
ns Element
sp of
Just sz :: ((Pixels, Pixels), (Pixels, Pixels))
sz -> ((Pixels, Pixels), (Pixels, Pixels))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pixels, Pixels), (Pixels, Pixels))
sz
Nothing -> do let mbSz :: Maybe ((Pixels, Pixels), (Pixels, Pixels))
mbSz =
QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "nvSpPr") Element
sp Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cNvPr") Maybe Element -> (Element -> Maybe MimeType) -> Maybe MimeType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
QName -> Element -> Maybe MimeType
findAttrText (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "id" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Maybe MimeType
-> (MimeType -> Maybe ((Pixels, Pixels), (Pixels, Pixels)))
-> Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(MimeType -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels)))
-> Element
-> MimeType
-> Maybe ((Pixels, Pixels), (Pixels, Pixels))
forall a b c. (a -> b -> c) -> b -> a -> c
flip MimeType -> Element -> Maybe ((Pixels, Pixels), (Pixels, Pixels))
getMasterShapeDimensionsById Element
master
case Maybe ((Pixels, Pixels), (Pixels, Pixels))
mbSz of
Just sz' :: ((Pixels, Pixels), (Pixels, Pixels))
sz' -> ((Pixels, Pixels), (Pixels, Pixels))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pixels, Pixels), (Pixels, Pixels))
sz'
Nothing -> PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels)))
-> PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall a b. (a -> b) -> a -> b
$
MimeType -> PandocError
PandocSomeError (MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$
"Couldn't find necessary content shape size"
getContentShapeSize _ _ _ = PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels)))
-> PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall a b. (a -> b) -> a -> b
$
MimeType -> PandocError
PandocSomeError (MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$
"Attempted to find content shape size in non-layout"
buildSpTree :: NameSpaces -> Element -> [Element] -> Element
buildSpTree :: NameSpaces -> Element -> [Element] -> Element
buildSpTree ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem newShapes :: [Element]
newShapes =
Element
emptySpTreeElem { elContent :: [Content]
elContent = [Content]
newContent }
where newContent :: [Content]
newContent = Element -> [Content]
elContent Element
emptySpTreeElem [Content] -> [Content] -> [Content]
forall a. Semigroup a => a -> a -> a
<> (Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem [Element]
newShapes
emptySpTreeElem :: Element
emptySpTreeElem = Element
spTreeElem { elContent :: [Content]
elContent = (Content -> Bool) -> [Content] -> [Content]
forall a. (a -> Bool) -> [a] -> [a]
filter Content -> Bool
fn (Element -> [Content]
elContent Element
spTreeElem) }
fn :: Content -> Bool
fn :: Content -> Bool
fn (Elem e :: Element
e) = NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns "p" "nvGrpSpPr" Element
e Bool -> Bool -> Bool
||
NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns "p" "grpSpPr" Element
e
fn _ = Bool
True
replaceNamedChildren :: NameSpaces
-> String
-> String
-> [Element]
-> Element
-> Element
replaceNamedChildren :: NameSpaces
-> FilePath -> FilePath -> [Element] -> Element -> Element
replaceNamedChildren ns :: NameSpaces
ns prefix :: FilePath
prefix name :: FilePath
name newKids :: [Element]
newKids element :: Element
element =
Element
element { elContent :: [Content]
elContent = [[Content]] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Content]] -> [Content]) -> [[Content]] -> [Content]
forall a b. (a -> b) -> a -> b
$ Bool -> [Content] -> [[Content]]
fun Bool
True ([Content] -> [[Content]]) -> [Content] -> [[Content]]
forall a b. (a -> b) -> a -> b
$ Element -> [Content]
elContent Element
element }
where
fun :: Bool -> [Content] -> [[Content]]
fun :: Bool -> [Content] -> [[Content]]
fun _ [] = []
fun switch :: Bool
switch ((Elem e :: Element
e) : conts :: [Content]
conts) | NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns FilePath
prefix FilePath
name Element
e =
if Bool
switch
then ((Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem ([Element] -> [Content]) -> [Element] -> [Content]
forall a b. (a -> b) -> a -> b
$ [Element]
newKids) [Content] -> [[Content]] -> [[Content]]
forall a. a -> [a] -> [a]
: Bool -> [Content] -> [[Content]]
fun Bool
False [Content]
conts
else Bool -> [Content] -> [[Content]]
fun Bool
False [Content]
conts
fun switch :: Bool
switch (cont :: Content
cont : conts :: [Content]
conts) = [Content
cont] [Content] -> [[Content]] -> [[Content]]
forall a. a -> [a] -> [a]
: Bool -> [Content] -> [[Content]]
fun Bool
switch [Content]
conts
registerLink :: PandocMonad m => LinkTarget -> P m Int
registerLink :: LinkTarget -> P m Int
registerLink link :: LinkTarget
link = do
Int
curSlideId <- (WriterEnv -> Int) -> P m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envCurSlideId
Map Int (Map Int LinkTarget)
linkReg <- (WriterState -> Map Int (Map Int LinkTarget))
-> ReaderT
WriterEnv (StateT WriterState m) (Map Int (Map Int LinkTarget))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int (Map Int LinkTarget)
stLinkIds
Map Int [MediaInfo]
mediaReg <- (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
Bool
hasSpeakerNotes <- P m Bool
forall (m :: * -> *). PandocMonad m => P m Bool
curSlideHasSpeakerNotes
let maxLinkId :: Int
maxLinkId = case Int -> Map Int (Map Int LinkTarget) -> Maybe (Map Int LinkTarget)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int (Map Int LinkTarget)
linkReg of
Just mp :: Map Int LinkTarget
mp -> case Map Int LinkTarget -> [Int]
forall k a. Map k a -> [k]
M.keys Map Int LinkTarget
mp of
[] -> if Bool
hasSpeakerNotes then 2 else 1
ks :: [Int]
ks -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ks
Nothing -> if Bool
hasSpeakerNotes then 2 else 1
maxMediaId :: Int
maxMediaId = case Int -> Map Int [MediaInfo] -> Maybe [MediaInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int [MediaInfo]
mediaReg of
Just [] -> if Bool
hasSpeakerNotes then 2 else 1
Just mInfos :: [MediaInfo]
mInfos -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (MediaInfo -> Int) -> [MediaInfo] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map MediaInfo -> Int
mInfoLocalId [MediaInfo]
mInfos
Nothing -> if Bool
hasSpeakerNotes then 2 else 1
maxId :: Int
maxId = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
maxLinkId Int
maxMediaId
slideLinks :: Map Int LinkTarget
slideLinks = case Int -> Map Int (Map Int LinkTarget) -> Maybe (Map Int LinkTarget)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int (Map Int LinkTarget)
linkReg of
Just mp :: Map Int LinkTarget
mp -> Int -> LinkTarget -> Map Int LinkTarget -> Map Int LinkTarget
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Int
maxId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) LinkTarget
link Map Int LinkTarget
mp
Nothing -> Int -> LinkTarget -> Map Int LinkTarget
forall k a. k -> a -> Map k a
M.singleton (Int
maxId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) LinkTarget
link
(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{ stLinkIds :: Map Int (Map Int LinkTarget)
stLinkIds = Int
-> Map Int LinkTarget
-> Map Int (Map Int LinkTarget)
-> Map Int (Map Int LinkTarget)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
curSlideId Map Int LinkTarget
slideLinks Map Int (Map Int LinkTarget)
linkReg}
Int -> P m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> P m Int) -> Int -> P m Int
forall a b. (a -> b) -> a -> b
$ Int
maxId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo
registerMedia :: FilePath -> [ParaElem] -> P m MediaInfo
registerMedia fp :: FilePath
fp caption :: [ParaElem]
caption = do
Int
curSlideId <- (WriterEnv -> Int) -> ReaderT WriterEnv (StateT WriterState m) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envCurSlideId
Map Int (Map Int LinkTarget)
linkReg <- (WriterState -> Map Int (Map Int LinkTarget))
-> ReaderT
WriterEnv (StateT WriterState m) (Map Int (Map Int LinkTarget))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int (Map Int LinkTarget)
stLinkIds
Map Int [MediaInfo]
mediaReg <- (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
Map FilePath Int
globalIds <- (WriterState -> Map FilePath Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map FilePath Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map FilePath Int
stMediaGlobalIds
Bool
hasSpeakerNotes <- P m Bool
forall (m :: * -> *). PandocMonad m => P m Bool
curSlideHasSpeakerNotes
let maxLinkId :: Int
maxLinkId = case Int -> Map Int (Map Int LinkTarget) -> Maybe (Map Int LinkTarget)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int (Map Int LinkTarget)
linkReg of
Just mp :: Map Int LinkTarget
mp -> case Map Int LinkTarget -> [Int]
forall k a. Map k a -> [k]
M.keys Map Int LinkTarget
mp of
[] -> if Bool
hasSpeakerNotes then 2 else 1
ks :: [Int]
ks -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ks
Nothing -> if Bool
hasSpeakerNotes then 2 else 1
maxMediaId :: Int
maxMediaId = case Int -> Map Int [MediaInfo] -> Maybe [MediaInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int [MediaInfo]
mediaReg of
Just [] -> if Bool
hasSpeakerNotes then 2 else 1
Just mInfos :: [MediaInfo]
mInfos -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (MediaInfo -> Int) -> [MediaInfo] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map MediaInfo -> Int
mInfoLocalId [MediaInfo]
mInfos
Nothing -> if Bool
hasSpeakerNotes then 2 else 1
maxLocalId :: Int
maxLocalId = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
maxLinkId Int
maxMediaId
maxGlobalId :: Int
maxGlobalId = case Map FilePath Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map FilePath Int
globalIds of
[] -> 0
ids :: [Int]
ids -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
ids
(imgBytes :: ByteString
imgBytes, mbMt :: Maybe MimeType
mbMt) <- MimeType
-> ReaderT
WriterEnv (StateT WriterState m) (ByteString, Maybe MimeType)
forall (m :: * -> *).
PandocMonad m =>
MimeType -> m (ByteString, Maybe MimeType)
P.fetchItem (MimeType
-> ReaderT
WriterEnv (StateT WriterState m) (ByteString, Maybe MimeType))
-> MimeType
-> ReaderT
WriterEnv (StateT WriterState m) (ByteString, Maybe MimeType)
forall a b. (a -> b) -> a -> b
$ FilePath -> MimeType
T.pack FilePath
fp
let imgExt :: Maybe MimeType
imgExt = (Maybe MimeType
mbMt Maybe MimeType -> (MimeType -> Maybe MimeType) -> Maybe MimeType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MimeType -> Maybe MimeType
extensionFromMimeType Maybe MimeType -> (MimeType -> Maybe MimeType) -> Maybe MimeType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\x :: MimeType
x -> MimeType -> Maybe MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ "." MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> MimeType
x))
Maybe MimeType -> Maybe MimeType -> Maybe MimeType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
case ByteString -> Maybe ImageType
imageType ByteString
imgBytes of
Just Png -> MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just ".png"
Just Jpeg -> MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just ".jpeg"
Just Gif -> MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just ".gif"
Just Pdf -> MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just ".pdf"
Just Eps -> MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just ".eps"
Just Svg -> MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just ".svg"
Just Emf -> MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just ".emf"
Nothing -> Maybe MimeType
forall a. Maybe a
Nothing
let newGlobalId :: Int
newGlobalId = case FilePath -> Map FilePath Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
fp Map FilePath Int
globalIds of
Just ident :: Int
ident -> Int
ident
Nothing -> Int
maxGlobalId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
let newGlobalIds :: Map FilePath Int
newGlobalIds = FilePath -> Int -> Map FilePath Int -> Map FilePath Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
fp Int
newGlobalId Map FilePath Int
globalIds
let mediaInfo :: MediaInfo
mediaInfo = MediaInfo :: FilePath
-> Int
-> Int
-> Maybe MimeType
-> Maybe MimeType
-> Bool
-> MediaInfo
MediaInfo { mInfoFilePath :: FilePath
mInfoFilePath = FilePath
fp
, mInfoLocalId :: Int
mInfoLocalId = Int
maxLocalId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
, mInfoGlobalId :: Int
mInfoGlobalId = Int
newGlobalId
, mInfoMimeType :: Maybe MimeType
mInfoMimeType = Maybe MimeType
mbMt
, mInfoExt :: Maybe MimeType
mInfoExt = Maybe MimeType
imgExt
, mInfoCaption :: Bool
mInfoCaption = (Bool -> Bool
not (Bool -> Bool) -> ([ParaElem] -> Bool) -> [ParaElem] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [ParaElem]
caption
}
let slideMediaInfos :: [MediaInfo]
slideMediaInfos = case Int -> Map Int [MediaInfo] -> Maybe [MediaInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
curSlideId Map Int [MediaInfo]
mediaReg of
Just minfos :: [MediaInfo]
minfos -> MediaInfo
mediaInfo MediaInfo -> [MediaInfo] -> [MediaInfo]
forall a. a -> [a] -> [a]
: [MediaInfo]
minfos
Nothing -> [MediaInfo
mediaInfo]
(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{ stMediaIds :: Map Int [MediaInfo]
stMediaIds = Int -> [MediaInfo] -> Map Int [MediaInfo] -> Map Int [MediaInfo]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
curSlideId [MediaInfo]
slideMediaInfos Map Int [MediaInfo]
mediaReg
, stMediaGlobalIds :: Map FilePath Int
stMediaGlobalIds = Map FilePath Int
newGlobalIds
}
MediaInfo -> P m MediaInfo
forall (m :: * -> *) a. Monad m => a -> m a
return MediaInfo
mediaInfo
makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry
makeMediaEntry :: MediaInfo -> P m Entry
makeMediaEntry mInfo :: MediaInfo
mInfo = do
Pixels
epochtime <- (POSIXTime -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Pixels)
-> (UTCTime -> POSIXTime) -> UTCTime -> Pixels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds) (UTCTime -> Pixels)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
-> ReaderT WriterEnv (StateT WriterState m) Pixels
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterEnv -> UTCTime)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> UTCTime
envUTCTime
(imgBytes :: ByteString
imgBytes, _) <- MimeType
-> ReaderT
WriterEnv (StateT WriterState m) (ByteString, Maybe MimeType)
forall (m :: * -> *).
PandocMonad m =>
MimeType -> m (ByteString, Maybe MimeType)
P.fetchItem (FilePath -> MimeType
T.pack (FilePath -> MimeType) -> FilePath -> MimeType
forall a b. (a -> b) -> a -> b
$ MediaInfo -> FilePath
mInfoFilePath MediaInfo
mInfo)
let ext :: MimeType
ext = case MediaInfo -> Maybe MimeType
mInfoExt MediaInfo
mInfo of
Just e :: MimeType
e -> MimeType
e
Nothing -> ""
let fp :: FilePath
fp = "ppt/media/image" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ MediaInfo -> Int
mInfoGlobalId MediaInfo
mInfo) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> MimeType -> FilePath
T.unpack MimeType
ext
Entry -> P m Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> P m Entry) -> Entry -> P m Entry
forall a b. (a -> b) -> a -> b
$ FilePath -> Pixels -> ByteString -> Entry
toEntry FilePath
fp Pixels
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
imgBytes
makeMediaEntries :: PandocMonad m => P m [Entry]
makeMediaEntries :: P m [Entry]
makeMediaEntries = do
Map Int [MediaInfo]
mediaInfos <- (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
let allInfos :: [MediaInfo]
allInfos = [[MediaInfo]] -> [MediaInfo]
forall a. Monoid a => [a] -> a
mconcat ([[MediaInfo]] -> [MediaInfo]) -> [[MediaInfo]] -> [MediaInfo]
forall a b. (a -> b) -> a -> b
$ Map Int [MediaInfo] -> [[MediaInfo]]
forall k a. Map k a -> [a]
M.elems Map Int [MediaInfo]
mediaInfos
(MediaInfo -> ReaderT WriterEnv (StateT WriterState m) Entry)
-> [MediaInfo] -> P m [Entry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM MediaInfo -> ReaderT WriterEnv (StateT WriterState m) Entry
forall (m :: * -> *). PandocMonad m => MediaInfo -> P m Entry
makeMediaEntry [MediaInfo]
allInfos
getMaster :: PandocMonad m => P m Element
getMaster :: P m Element
getMaster = do
Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/slideMasters/slideMaster1.xml"
captionHeight :: Integer
captionHeight :: Pixels
captionHeight = 40
createCaption :: PandocMonad m
=> ((Integer, Integer), (Integer, Integer))
-> [ParaElem]
-> P m Element
createCaption :: ((Pixels, Pixels), (Pixels, Pixels)) -> [ParaElem] -> P m Element
createCaption contentShapeDimensions :: ((Pixels, Pixels), (Pixels, Pixels))
contentShapeDimensions paraElements :: [ParaElem]
paraElements = do
let para :: Paragraph
para = ParaProps -> [ParaElem] -> Paragraph
Paragraph ParaProps
forall a. Default a => a
def{pPropAlign :: Maybe Algnment
pPropAlign = Algnment -> Maybe Algnment
forall a. a -> Maybe a
Just Algnment
AlgnCenter} [ParaElem]
paraElements
[Element]
elements <- (Paragraph -> P m Element)
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Paragraph -> P m Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement [Paragraph
para]
let ((x :: Pixels
x, y :: Pixels
y), (cx :: Pixels
cx, cy :: Pixels
cy)) = ((Pixels, Pixels), (Pixels, Pixels))
contentShapeDimensions
let txBody :: Element
txBody = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] (), FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] [ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvSpPr" []
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvSpPr" [("txBox", "1")] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ()
]
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:spPr" []
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:xfrm" []
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:off" [("x", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
x),
("y", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* (Pixels
y Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
+ Pixels
cy Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
- Pixels
captionHeight))] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:ext" [("cx", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
cx),
("cy", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
captionHeight)] ()
]
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:prstGeom" [("prst", "rect")]
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:avLst" [] ()
]
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:noFill" [] ()
]
, Element
txBody
]
makePicElements :: PandocMonad m
=> Element
-> PicProps
-> MediaInfo
-> [ParaElem]
-> P m [Element]
makePicElements :: Element -> PicProps -> MediaInfo -> [ParaElem] -> P m [Element]
makePicElements layout :: Element
layout picProps :: PicProps
picProps mInfo :: MediaInfo
mInfo alt :: [ParaElem]
alt = do
WriterOptions
opts <- (WriterEnv -> WriterOptions)
-> ReaderT WriterEnv (StateT WriterState m) WriterOptions
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> WriterOptions
envOpts
(pageWidth :: Pixels
pageWidth, pageHeight :: Pixels
pageHeight) <- (WriterEnv -> (Pixels, Pixels))
-> ReaderT WriterEnv (StateT WriterState m) (Pixels, Pixels)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> (Pixels, Pixels)
envPresentationSize
let hasCaption :: Bool
hasCaption = MediaInfo -> Bool
mInfoCaption MediaInfo
mInfo
(imgBytes :: ByteString
imgBytes, _) <- MimeType
-> ReaderT
WriterEnv (StateT WriterState m) (ByteString, Maybe MimeType)
forall (m :: * -> *).
PandocMonad m =>
MimeType -> m (ByteString, Maybe MimeType)
P.fetchItem (FilePath -> MimeType
T.pack (FilePath -> MimeType) -> FilePath -> MimeType
forall a b. (a -> b) -> a -> b
$ MediaInfo -> FilePath
mInfoFilePath MediaInfo
mInfo)
let (pxX :: Pixels
pxX, pxY :: Pixels
pxY) = case WriterOptions -> ByteString -> Either MimeType ImageSize
imageSize WriterOptions
opts ByteString
imgBytes of
Right sz :: ImageSize
sz -> ImageSize -> (Pixels, Pixels)
sizeInPixels (ImageSize -> (Pixels, Pixels)) -> ImageSize -> (Pixels, Pixels)
forall a b. (a -> b) -> a -> b
$ ImageSize
sz
Left _ -> ImageSize -> (Pixels, Pixels)
sizeInPixels (ImageSize -> (Pixels, Pixels)) -> ImageSize -> (Pixels, Pixels)
forall a b. (a -> b) -> a -> b
$ ImageSize
forall a. Default a => a
def
Element
master <- P m Element
forall (m :: * -> *). PandocMonad m => P m Element
getMaster
let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
layout
((x :: Pixels
x, y :: Pixels
y), (cx :: Pixels
cx, cytmp :: Pixels
cytmp)) <- NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *).
PandocMonad m =>
NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
getContentShapeSize NameSpaces
ns Element
layout Element
master
P m ((Pixels, Pixels), (Pixels, Pixels))
-> (PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels)))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
(\_ -> ((Pixels, Pixels), (Pixels, Pixels))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((0, 0), (Pixels
pageWidth, Pixels
pageHeight)))
let cy :: Pixels
cy = if Bool
hasCaption then Pixels
cytmp Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
- Pixels
captionHeight else Pixels
cytmp
let imgRatio :: Double
imgRatio = Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
pxX Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
pxY :: Double
boxRatio :: Double
boxRatio = Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cy :: Double
(dimX :: Double
dimX, dimY :: Double
dimY) = if Double
imgRatio Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
boxRatio
then (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cx, Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
imgRatio)
else (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
imgRatio, Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cy)
(dimX' :: Pixels
dimX', dimY' :: Pixels
dimY') = (Double -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Double
dimX Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 12700, Double -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Double
dimY Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 12700) :: (Integer, Integer)
(xoff :: Double
xoff, yoff :: Double
yoff) = (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
dimX) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 2,
Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Pixels -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixels
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
dimY) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 2)
(xoff' :: Pixels
xoff', yoff' :: Pixels
yoff') = (Double -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Double
xoff Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 12700, Double -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
round Double
yoff Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* 12700) :: (Integer, Integer)
let cNvPicPr :: Element
cNvPicPr = FilePath -> NameSpaces -> Element -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPicPr" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:picLocks" [("noGrp","1")
,("noChangeAspect","1")] ()
let cNvPrAttr :: NameSpaces
cNvPrAttr = [("descr", MediaInfo -> FilePath
mInfoFilePath MediaInfo
mInfo), ("id","0"),("name","Picture 1")]
Element
cNvPr <- case PicProps -> Maybe LinkTarget
picPropLink PicProps
picProps of
Just link :: LinkTarget
link -> do Int
idNum <- LinkTarget -> P m Int
forall (m :: * -> *). PandocMonad m => LinkTarget -> P m Int
registerLink LinkTarget
link
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> Element -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPr" NameSpaces
cNvPrAttr (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:hlinkClick" [("r:id", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idNum)] ()
Nothing -> Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPr" NameSpaces
cNvPrAttr ()
let nvPicPr :: Element
nvPicPr = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvPicPr" []
[ Element
cNvPr
, Element
cNvPicPr
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ()]
let blipFill :: Element
blipFill = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:blipFill" []
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:blip" [("r:embed", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ MediaInfo -> Int
mInfoLocalId MediaInfo
mInfo))] ()
, FilePath -> NameSpaces -> Element -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:stretch" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:fillRect" [] () ]
let xfrm :: Element
xfrm = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:xfrm" []
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:off" [("x",Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
xoff'), ("y",Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
yoff')] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:ext" [("cx",Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
dimX')
,("cy",Pixels -> FilePath
forall a. Show a => a -> FilePath
show Pixels
dimY')] () ]
let prstGeom :: Element
prstGeom = FilePath -> NameSpaces -> Element -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:prstGeom" [("prst","rect")] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:avLst" [] ()
let ln :: Element
ln = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:ln" [("w","9525")]
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:noFill" [] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:headEnd" [] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:tailEnd" [] () ]
let spPr :: Element
spPr = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:spPr" [("bwMode","auto")]
[Element
xfrm, Element
prstGeom, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:noFill" [] (), Element
ln]
let picShape :: Element
picShape = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:pic" []
[ Element
nvPicPr
, Element
blipFill
, Element
spPr ]
if Bool
hasCaption
then do Element
cap <- ((Pixels, Pixels), (Pixels, Pixels)) -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
((Pixels, Pixels), (Pixels, Pixels)) -> [ParaElem] -> P m Element
createCaption ((Pixels
x, Pixels
y), (Pixels
cx, Pixels
cytmp)) [ParaElem]
alt
[Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element
picShape, Element
cap]
else [Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element
picShape]
paraElemToElements :: PandocMonad m => ParaElem -> P m [Element]
paraElemToElements :: ParaElem -> P m [Element]
paraElemToElements Break = [Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:br" [] ()]
paraElemToElements (Run rpr :: RunProps
rpr s :: MimeType
s) = do
NameSpaces
sizeAttrs <- RunProps -> P m NameSpaces
forall (m :: * -> *). Monad m => RunProps -> P m NameSpaces
fontSizeAttributes RunProps
rpr
let attrs :: NameSpaces
attrs = NameSpaces
sizeAttrs NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(if RunProps -> Bool
rPropBold RunProps
rpr then [("b", "1")] else []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(if RunProps -> Bool
rPropItalics RunProps
rpr then [("i", "1")] else []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(if RunProps -> Bool
rPropUnderline RunProps
rpr then [("u", "sng")] else []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(case RunProps -> Maybe Strikethrough
rStrikethrough RunProps
rpr of
Just NoStrike -> [("strike", "noStrike")]
Just SingleStrike -> [("strike", "sngStrike")]
Just DoubleStrike -> [("strike", "dblStrike")]
Nothing -> []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(case RunProps -> Maybe Int
rBaseline RunProps
rpr of
Just n :: Int
n -> [("baseline", Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)]
Nothing -> []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(case RunProps -> Maybe Capitals
rCap RunProps
rpr of
Just NoCapitals -> [("cap", "none")]
Just SmallCapitals -> [("cap", "small")]
Just AllCapitals -> [("cap", "all")]
Nothing -> []) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
[]
[Element]
linkProps <- case RunProps -> Maybe LinkTarget
rLink RunProps
rpr of
Just link :: LinkTarget
link -> do
Int
idNum <- LinkTarget -> P m Int
forall (m :: * -> *). PandocMonad m => LinkTarget -> P m Int
registerLink LinkTarget
link
[Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Element] -> P m [Element]) -> [Element] -> P m [Element]
forall a b. (a -> b) -> a -> b
$ case LinkTarget
link of
InternalTarget _ ->
let linkAttrs :: NameSpaces
linkAttrs =
[ ("r:id", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idNum)
, ("action", "ppaction://hlinksldjump")
]
in [FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:hlinkClick" NameSpaces
linkAttrs ()]
ExternalTarget _ ->
let linkAttrs :: NameSpaces
linkAttrs =
[ ("r:id", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idNum)
]
in [FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:hlinkClick" NameSpaces
linkAttrs ()]
Nothing -> [Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return []
let colorContents :: [Element]
colorContents = case RunProps -> Maybe Color
rSolidFill RunProps
rpr of
Just color :: Color
color ->
case Color -> FilePath
forall a. FromColor a => Color -> a
fromColor Color
color of
'#':hx :: FilePath
hx -> [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:solidFill" []
[FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:srgbClr" [("val", (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper FilePath
hx)] ()]
]
_ -> []
Nothing -> []
MimeType
codeFont <- P m MimeType
forall (m :: * -> *). Monad m => P m MimeType
monospaceFont
let codeContents :: [Element]
codeContents = if RunProps -> Bool
rPropCode RunProps
rpr
then [FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:latin" [("typeface", MimeType -> FilePath
T.unpack MimeType
codeFont)] ()]
else []
let propContents :: [Element]
propContents = [Element]
linkProps [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
colorContents [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
codeContents
[Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:r" [] [ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:rPr" NameSpaces
attrs ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [Element]
propContents
, FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:t" [] (FilePath -> Element) -> FilePath -> Element
forall a b. (a -> b) -> a -> b
$ MimeType -> FilePath
T.unpack MimeType
s
]]
paraElemToElements (MathElem mathType :: MathType
mathType texStr :: TeXString
texStr) = do
Either Inline Element
res <- (DisplayType -> [Exp] -> Element)
-> MathType
-> MimeType
-> ReaderT WriterEnv (StateT WriterState m) (Either Inline Element)
forall (m :: * -> *) a.
PandocMonad m =>
(DisplayType -> [Exp] -> a)
-> MathType -> MimeType -> m (Either Inline a)
convertMath DisplayType -> [Exp] -> Element
writeOMML MathType
mathType (TeXString -> MimeType
unTeXString TeXString
texStr)
case Either Inline Element
res of
Right r :: Element
r -> [Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> NameSpaces -> Element -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a14:m" [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Element -> Element
addMathInfo Element
r]
Left (Str s :: MimeType
s) -> ParaElem -> P m [Element]
forall (m :: * -> *). PandocMonad m => ParaElem -> P m [Element]
paraElemToElements (RunProps -> MimeType -> ParaElem
Run RunProps
forall a. Default a => a
def MimeType
s)
Left _ -> PandocError -> P m [Element]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m [Element]) -> PandocError -> P m [Element]
forall a b. (a -> b) -> a -> b
$ MimeType -> PandocError
PandocShouldNeverHappenError "non-string math fallback"
paraElemToElements (RawOOXMLParaElem str :: MimeType
str) = [Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Element
x | Elem x :: Element
x <- MimeType -> [Content]
forall s. XmlSource s => s -> [Content]
parseXML MimeType
str ]
addMathInfo :: Element -> Element
addMathInfo :: Element -> Element
addMathInfo element :: Element
element =
let mathspace :: Attr
mathspace = Attr :: QName -> FilePath -> Attr
Attr { attrKey :: QName
attrKey = (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "m" Maybe FilePath
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "xmlns"))
, attrVal :: FilePath
attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"
}
in Attr -> Element -> Element
add_attr Attr
mathspace Element
element
surroundWithMathAlternate :: Element -> Element
surroundWithMathAlternate :: Element -> Element
surroundWithMathAlternate element :: Element
element =
case QName -> Element -> Maybe Element
findElement (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "m" Maybe FilePath
forall a. Maybe a
Nothing (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "a14")) Element
element of
Just _ ->
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "mc:AlternateContent"
[("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")
] [ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "mc:Choice"
[ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")
, ("Requires", "a14")] [ Element
element ]
]
Nothing -> Element
element
paragraphToElement :: PandocMonad m => Paragraph -> P m Element
paragraphToElement :: Paragraph -> P m Element
paragraphToElement par :: Paragraph
par = do
let
attrs :: NameSpaces
attrs = [("lvl", Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ ParaProps -> Int
pPropLevel (ParaProps -> Int) -> ParaProps -> Int
forall a b. (a -> b) -> a -> b
$ Paragraph -> ParaProps
paraProps Paragraph
par)] NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(case ParaProps -> Maybe Pixels
pPropMarginLeft (Paragraph -> ParaProps
paraProps Paragraph
par) of
Just px :: Pixels
px -> [("marL", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ Pixels -> Pixels
pixelsToEmu Pixels
px)]
Nothing -> []
) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(case ParaProps -> Maybe Pixels
pPropIndent (Paragraph -> ParaProps
paraProps Paragraph
par) of
Just px :: Pixels
px -> [("indent", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ Pixels -> Pixels
pixelsToEmu Pixels
px)]
Nothing -> []
) NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<>
(case ParaProps -> Maybe Algnment
pPropAlign (Paragraph -> ParaProps
paraProps Paragraph
par) of
Just AlgnLeft -> [("algn", "l")]
Just AlgnRight -> [("algn", "r")]
Just AlgnCenter -> [("algn", "ctr")]
Nothing -> []
)
props :: [Element]
props = [] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<>
(case ParaProps -> Maybe Pixels
pPropSpaceBefore (ParaProps -> Maybe Pixels) -> ParaProps -> Maybe Pixels
forall a b. (a -> b) -> a -> b
$ Paragraph -> ParaProps
paraProps Paragraph
par of
Just px :: Pixels
px -> [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:spcBef" [] [
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:spcPts" [("val", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 100 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
px)] ()
]
]
Nothing -> []
) [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<>
(case ParaProps -> Maybe BulletType
pPropBullet (ParaProps -> Maybe BulletType) -> ParaProps -> Maybe BulletType
forall a b. (a -> b) -> a -> b
$ Paragraph -> ParaProps
paraProps Paragraph
par of
Just Bullet -> []
Just (AutoNumbering attrs' :: ListAttributes
attrs') ->
[FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:buAutoNum" (ListAttributes -> NameSpaces
autoNumAttrs ListAttributes
attrs') ()]
Nothing -> [FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:buNone" [] ()]
)
[Element]
paras <- [[Element]] -> [Element]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[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
<$> (ParaElem -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [ParaElem]
-> ReaderT WriterEnv (StateT WriterState m) [[Element]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ParaElem -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *). PandocMonad m => ParaElem -> P m [Element]
paraElemToElements (Paragraph -> [ParaElem]
paraElems Paragraph
par)
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:p" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:pPr" NameSpaces
attrs [Element]
props] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
paras
shapeToElement :: PandocMonad m => Element -> Shape -> P m Element
shapeToElement :: Element -> Shape -> P m Element
shapeToElement layout :: Element
layout (TextBox paras :: [Paragraph]
paras)
| NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
, Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
, Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
Element
sp <- NameSpaces -> Element -> P m Element
forall (m :: * -> *).
PandocMonad m =>
NameSpaces -> Element -> P m Element
getContentShape NameSpaces
ns Element
spTree
[Element]
elements <- (Paragraph -> P m Element)
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Paragraph -> P m Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement [Paragraph]
paras
let txBody :: Element
txBody = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] (), FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements
emptySpPr :: Element
emptySpPr = FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:spPr" [] ()
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
Element -> Element
surroundWithMathAlternate (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
NameSpaces
-> FilePath -> FilePath -> [Element] -> Element -> Element
replaceNamedChildren NameSpaces
ns "p" "txBody" [Element
txBody] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
NameSpaces
-> FilePath -> FilePath -> [Element] -> Element -> Element
replaceNamedChildren NameSpaces
ns "p" "spPr" [Element
emptySpPr] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
Element
sp
shapeToElement _ _ = Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ()
shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]
shapeToElements :: Element -> Shape -> P m [Element]
shapeToElements layout :: Element
layout (Pic picProps :: PicProps
picProps fp :: FilePath
fp alt :: [ParaElem]
alt) = do
MediaInfo
mInfo <- FilePath -> [ParaElem] -> P m MediaInfo
forall (m :: * -> *).
PandocMonad m =>
FilePath -> [ParaElem] -> P m MediaInfo
registerMedia FilePath
fp [ParaElem]
alt
case MediaInfo -> Maybe MimeType
mInfoExt MediaInfo
mInfo of
Just _ -> do
Element -> PicProps -> MediaInfo -> [ParaElem] -> P m [Element]
forall (m :: * -> *).
PandocMonad m =>
Element -> PicProps -> MediaInfo -> [ParaElem] -> P m [Element]
makePicElements Element
layout PicProps
picProps MediaInfo
mInfo [ParaElem]
alt
Nothing -> Element -> Shape -> P m [Element]
forall (m :: * -> *).
PandocMonad m =>
Element -> Shape -> P m [Element]
shapeToElements Element
layout (Shape -> P m [Element]) -> Shape -> P m [Element]
forall a b. (a -> b) -> a -> b
$ [Paragraph] -> Shape
TextBox [ParaProps -> [ParaElem] -> Paragraph
Paragraph ParaProps
forall a. Default a => a
def [ParaElem]
alt]
shapeToElements layout :: Element
layout (GraphicFrame tbls :: [Graphic]
tbls cptn :: [ParaElem]
cptn) =
Element -> [Graphic] -> [ParaElem] -> P m [Element]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Graphic] -> [ParaElem] -> P m [Element]
graphicFrameToElements Element
layout [Graphic]
tbls [ParaElem]
cptn
shapeToElements _ (RawOOXMLShape str :: MimeType
str) = [Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Element
x | Elem x :: Element
x <- MimeType -> [Content]
forall s. XmlSource s => s -> [Content]
parseXML MimeType
str ]
shapeToElements layout :: Element
layout shp :: Shape
shp = do
Element
element <- Element -> Shape -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> Shape -> P m Element
shapeToElement Element
layout Shape
shp
[Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element
element]
shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element]
shapesToElements :: Element -> [Shape] -> P m [Element]
shapesToElements layout :: Element
layout shps :: [Shape]
shps = do
[[Element]] -> [Element]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Element]] -> [Element])
-> ReaderT WriterEnv (StateT WriterState m) [[Element]]
-> P m [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Shape -> P m [Element])
-> [Shape] -> ReaderT WriterEnv (StateT WriterState m) [[Element]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Element -> Shape -> P m [Element]
forall (m :: * -> *).
PandocMonad m =>
Element -> Shape -> P m [Element]
shapeToElements Element
layout) [Shape]
shps
graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element]
graphicFrameToElements :: Element -> [Graphic] -> [ParaElem] -> P m [Element]
graphicFrameToElements layout :: Element
layout tbls :: [Graphic]
tbls caption :: [ParaElem]
caption = do
Element
master <- P m Element
forall (m :: * -> *). PandocMonad m => P m Element
getMaster
(pageWidth :: Pixels
pageWidth, pageHeight :: Pixels
pageHeight) <- (WriterEnv -> (Pixels, Pixels))
-> ReaderT WriterEnv (StateT WriterState m) (Pixels, Pixels)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> (Pixels, Pixels)
envPresentationSize
let ns :: NameSpaces
ns = Element -> NameSpaces
elemToNameSpaces Element
layout
((x :: Pixels
x, y :: Pixels
y), (cx :: Pixels
cx, cytmp :: Pixels
cytmp)) <- NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *).
PandocMonad m =>
NameSpaces
-> Element -> Element -> P m ((Pixels, Pixels), (Pixels, Pixels))
getContentShapeSize NameSpaces
ns Element
layout Element
master
P m ((Pixels, Pixels), (Pixels, Pixels))
-> (PandocError -> P m ((Pixels, Pixels), (Pixels, Pixels)))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError`
(\_ -> ((Pixels, Pixels), (Pixels, Pixels))
-> P m ((Pixels, Pixels), (Pixels, Pixels))
forall (m :: * -> *) a. Monad m => a -> m a
return ((0, 0), (Pixels
pageWidth, Pixels
pageHeight)))
let cy :: Pixels
cy = if (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
caption) then Pixels
cytmp Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
- Pixels
captionHeight else Pixels
cytmp
[Element]
elements <- (Graphic -> P m Element) -> [Graphic] -> P m [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pixels -> Graphic -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Pixels -> Graphic -> P m Element
graphicToElement Pixels
cx) [Graphic]
tbls
let graphicFrameElts :: Element
graphicFrameElts =
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:graphicFrame" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvGraphicFramePr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvGraphicFramePr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:ph" [("idx", "1")] ()]
]
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:xfrm" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:off" [("x", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
x), ("y", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
y)] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:ext" [("cx", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
cx), ("cy", Pixels -> FilePath
forall a. Show a => a -> FilePath
show (Pixels -> FilePath) -> Pixels -> FilePath
forall a b. (a -> b) -> a -> b
$ 12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
cy)] ()
]
] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements
if (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
caption)
then do Element
capElt <- ((Pixels, Pixels), (Pixels, Pixels)) -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
((Pixels, Pixels), (Pixels, Pixels)) -> [ParaElem] -> P m Element
createCaption ((Pixels
x, Pixels
y), (Pixels
cx, Pixels
cytmp)) [ParaElem]
caption
[Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element
graphicFrameElts, Element
capElt]
else [Element] -> P m [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return [Element
graphicFrameElts]
getDefaultTableStyle :: PandocMonad m => P m (Maybe T.Text)
getDefaultTableStyle :: P m (Maybe MimeType)
getDefaultTableStyle = do
Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
Element
tblStyleLst <- Archive
-> Archive
-> FilePath
-> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/tableStyles.xml"
Maybe MimeType -> P m (Maybe MimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MimeType -> P m (Maybe MimeType))
-> Maybe MimeType -> P m (Maybe MimeType)
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe MimeType
findAttrText (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "def" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
tblStyleLst
graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element
graphicToElement :: Pixels -> Graphic -> P m Element
graphicToElement tableWidth :: Pixels
tableWidth (Tbl tblPr :: TableProps
tblPr hdrCells :: [[Paragraph]]
hdrCells rows :: [[[Paragraph]]]
rows) = do
let colWidths :: [Pixels]
colWidths = if [[Paragraph]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Paragraph]]
hdrCells
then case [[[Paragraph]]]
rows of
r :: [[Paragraph]]
r : _ | Bool -> Bool
not ([[Paragraph]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Paragraph]]
r) -> Int -> Pixels -> [Pixels]
forall a. Int -> a -> [a]
replicate ([[Paragraph]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Paragraph]]
r) (Pixels -> [Pixels]) -> Pixels -> [Pixels]
forall a b. (a -> b) -> a -> b
$
(Pixels
tableWidth Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` (Int -> Pixels
forall a. Integral a => a -> Pixels
toInteger (Int -> Pixels) -> Int -> Pixels
forall a b. (a -> b) -> a -> b
$ [[Paragraph]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Paragraph]]
r))
_ -> []
else Int -> Pixels -> [Pixels]
forall a. Int -> a -> [a]
replicate ([[Paragraph]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Paragraph]]
hdrCells) (Pixels -> [Pixels]) -> Pixels -> [Pixels]
forall a b. (a -> b) -> a -> b
$
(Pixels
tableWidth Pixels -> Pixels -> Pixels
forall a. Integral a => a -> a -> a
`div` (Int -> Pixels
forall a. Integral a => a -> Pixels
toInteger (Int -> Pixels) -> Int -> Pixels
forall a b. (a -> b) -> a -> b
$ [[Paragraph]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Paragraph]]
hdrCells))
let cellToOpenXML :: [Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
cellToOpenXML paras :: [Paragraph]
paras =
do [Element]
elements <- (Paragraph -> ReaderT WriterEnv (StateT WriterState m) Element)
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Paragraph -> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement [Paragraph]
paras
let elements' :: [Element]
elements' = if [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
elements
then [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:p" [] [FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:endParaRPr" [] ()]]
else [Element]
elements
[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
$
[FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
([ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()]
[Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements')]
[[Element]]
headers' <- ([Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [[Paragraph]]
-> ReaderT WriterEnv (StateT WriterState m) [[Element]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
[Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
cellToOpenXML [[Paragraph]]
hdrCells
[[[Element]]]
rows' <- ([[Paragraph]]
-> ReaderT WriterEnv (StateT WriterState m) [[Element]])
-> [[[Paragraph]]]
-> ReaderT WriterEnv (StateT WriterState m) [[[Element]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [[Paragraph]]
-> ReaderT WriterEnv (StateT WriterState m) [[Element]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
[Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element]
cellToOpenXML) [[[Paragraph]]]
rows
let borderProps :: Element
borderProps = FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:tcPr" [] ()
let emptyCell :: [Element]
emptyCell = [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:p" [] [FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:pPr" [] ()]]
let mkcell :: Bool -> [Element] -> Element
mkcell border :: Bool
border contents :: [Element]
contents = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:tc" []
([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ (if [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
contents
then [Element]
emptyCell
else [Element]
contents) [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [ Element
borderProps | Bool
border ]
let mkrow :: Bool -> [[Element]] -> Element
mkrow border :: Bool
border cells :: [[Element]]
cells = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:tr" [("h", "0")] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ([Element] -> Element) -> [[Element]] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> [Element] -> Element
mkcell Bool
border) [[Element]]
cells
let mkgridcol :: Pixels -> Element
mkgridcol w :: Pixels
w = FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:gridCol"
[("w", Pixels -> FilePath
forall a. Show a => a -> FilePath
show ((12700 Pixels -> Pixels -> Pixels
forall a. Num a => a -> a -> a
* Pixels
w) :: Integer))] ()
let hasHeader :: Bool
hasHeader = Bool -> Bool
not (([Paragraph] -> Bool) -> [[Paragraph]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Paragraph] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Paragraph]]
hdrCells)
Maybe MimeType
mbDefTblStyle <- P m (Maybe MimeType)
forall (m :: * -> *). PandocMonad m => P m (Maybe MimeType)
getDefaultTableStyle
let tblPrElt :: Element
tblPrElt = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:tblPr"
[ ("firstRow", if TableProps -> Bool
tblPrFirstRow TableProps
tblPr then "1" else "0")
, ("bandRow", if TableProps -> Bool
tblPrBandRow TableProps
tblPr then "1" else "0")
] (case Maybe MimeType
mbDefTblStyle of
Nothing -> []
Just sty :: MimeType
sty -> [FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:tableStyleId" [] (FilePath -> Element) -> FilePath -> Element
forall a b. (a -> b) -> a -> b
$ MimeType -> FilePath
T.unpack MimeType
sty])
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:graphic" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:tbl" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ Element
tblPrElt
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:tblGrid" [] (if (Pixels -> Bool) -> [Pixels] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Pixels -> Pixels -> Bool
forall a. Eq a => a -> a -> Bool
==0) [Pixels]
colWidths
then []
else (Pixels -> Element) -> [Pixels] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map Pixels -> Element
mkgridcol [Pixels]
colWidths)
]
[Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [ Bool -> [[Element]] -> Element
mkrow Bool
True [[Element]]
headers' | Bool
hasHeader ] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> ([[Element]] -> Element) -> [[[Element]]] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> [[Element]] -> Element
mkrow Bool
False) [[[Element]]]
rows'
]
]
data PHType = PHType T.Text | ObjType
deriving (Int -> PHType -> ShowS
[PHType] -> ShowS
PHType -> FilePath
(Int -> PHType -> ShowS)
-> (PHType -> FilePath) -> ([PHType] -> ShowS) -> Show PHType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PHType] -> ShowS
$cshowList :: [PHType] -> ShowS
show :: PHType -> FilePath
$cshow :: PHType -> FilePath
showsPrec :: Int -> PHType -> ShowS
$cshowsPrec :: Int -> PHType -> ShowS
Show, PHType -> PHType -> Bool
(PHType -> PHType -> Bool)
-> (PHType -> PHType -> Bool) -> Eq PHType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PHType -> PHType -> Bool
$c/= :: PHType -> PHType -> Bool
== :: PHType -> PHType -> Bool
$c== :: PHType -> PHType -> Bool
Eq)
findPHType :: NameSpaces -> Element -> PHType -> Bool
findPHType :: NameSpaces -> Element -> PHType -> Bool
findPHType ns :: NameSpaces
ns spElem :: Element
spElem phType :: PHType
phType
| NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns "p" "sp" Element
spElem =
let mbPHElem :: Maybe Element
mbPHElem = (Element -> Maybe Element
forall a. a -> Maybe a
Just Element
spElem Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "nvSpPr") Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "nvPr") Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "ph"))
in
case Maybe Element
mbPHElem of
Just phElem :: Element
phElem | (PHType tp :: MimeType
tp) <- PHType
phType ->
case QName -> Element -> Maybe MimeType
findAttrText (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "type" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
phElem of
Just tp' :: MimeType
tp' -> MimeType
tp MimeType -> MimeType -> Bool
forall a. Eq a => a -> a -> Bool
== MimeType
tp'
Nothing -> Bool
False
Just phElem :: Element
phElem | PHType
ObjType <- PHType
phType ->
case QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "type" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
phElem of
Just _ -> Bool
False
Nothing -> Bool
True
Nothing -> Bool
False
findPHType _ _ _ = Bool
False
getShapesByPlaceHolderType :: NameSpaces -> Element -> PHType -> [Element]
getShapesByPlaceHolderType :: NameSpaces -> Element -> PHType -> [Element]
getShapesByPlaceHolderType ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem phType :: PHType
phType
| NameSpaces -> FilePath -> FilePath -> Element -> Bool
isElem NameSpaces
ns "p" "spTree" Element
spTreeElem =
(Element -> Bool) -> Element -> [Element]
filterChildren (\e :: Element
e -> NameSpaces -> Element -> PHType -> Bool
findPHType NameSpaces
ns Element
e PHType
phType) Element
spTreeElem
| Bool
otherwise = []
getShapeByPlaceHolderType :: NameSpaces -> Element -> PHType -> Maybe Element
getShapeByPlaceHolderType :: NameSpaces -> Element -> PHType -> Maybe Element
getShapeByPlaceHolderType ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem phType :: PHType
phType =
[Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe ([Element] -> Maybe Element) -> [Element] -> Maybe Element
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> PHType -> [Element]
getShapesByPlaceHolderType NameSpaces
ns Element
spTreeElem PHType
phType
getShapeByPlaceHolderTypes :: NameSpaces -> Element -> [PHType] -> Maybe Element
getShapeByPlaceHolderTypes :: NameSpaces -> Element -> [PHType] -> Maybe Element
getShapeByPlaceHolderTypes _ _ [] = Maybe Element
forall a. Maybe a
Nothing
getShapeByPlaceHolderTypes ns :: NameSpaces
ns spTreeElem :: Element
spTreeElem (s :: PHType
s:ss :: [PHType]
ss) =
case NameSpaces -> Element -> PHType -> Maybe Element
getShapeByPlaceHolderType NameSpaces
ns Element
spTreeElem PHType
s of
Just element :: Element
element -> Element -> Maybe Element
forall a. a -> Maybe a
Just Element
element
Nothing -> NameSpaces -> Element -> [PHType] -> Maybe Element
getShapeByPlaceHolderTypes NameSpaces
ns Element
spTreeElem [PHType]
ss
nonBodyTextToElement :: PandocMonad m => Element -> [PHType] -> [ParaElem] -> P m Element
nonBodyTextToElement :: Element -> [PHType] -> [ParaElem] -> P m Element
nonBodyTextToElement layout :: Element
layout phTypes :: [PHType]
phTypes paraElements :: [ParaElem]
paraElements
| NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
, Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
, Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld
, Just sp :: Element
sp <- NameSpaces -> Element -> [PHType] -> Maybe Element
getShapeByPlaceHolderTypes NameSpaces
ns Element
spTree [PHType]
phTypes = do
let hdrPara :: Paragraph
hdrPara = ParaProps -> [ParaElem] -> Paragraph
Paragraph ParaProps
forall a. Default a => a
def [ParaElem]
paraElements
Element
element <- Paragraph -> P m Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement Paragraph
hdrPara
let txBody :: Element
txBody = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] (), FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<>
[Element
element]
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ NameSpaces
-> FilePath -> FilePath -> [Element] -> Element -> Element
replaceNamedChildren NameSpaces
ns "p" "txBody" [Element
txBody] Element
sp
| Bool
otherwise = Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ()
contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element
contentToElement :: Element -> [ParaElem] -> [Shape] -> P m Element
contentToElement layout :: Element
layout hdrShape :: [ParaElem]
hdrShape shapes :: [Shape]
shapes
| NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
, Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
, Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
Element
element <- Element -> [PHType] -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m Element
nonBodyTextToElement Element
layout [MimeType -> PHType
PHType "title"] [ParaElem]
hdrShape
let hdrShapeElements :: [Element]
hdrShapeElements = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape
then []
else [Element
element]
[Element]
contentElements <- (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) [Element]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
(\env :: WriterEnv
env -> WriterEnv
env {envContentType :: ContentType
envContentType = ContentType
NormalContent})
(Element
-> [Shape] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [Element]
shapesToElements Element
layout [Shape]
shapes)
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Element] -> Element
buildSpTree NameSpaces
ns Element
spTree ([Element]
hdrShapeElements [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
contentElements)
contentToElement _ _ _ = Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ()
twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element
twoColumnToElement :: Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element
twoColumnToElement layout :: Element
layout hdrShape :: [ParaElem]
hdrShape shapesL :: [Shape]
shapesL shapesR :: [Shape]
shapesR
| NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
, Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
, Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
Element
element <- Element -> [PHType] -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m Element
nonBodyTextToElement Element
layout [MimeType -> PHType
PHType "title"] [ParaElem]
hdrShape
let hdrShapeElements :: [Element]
hdrShapeElements = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrShape
then []
else [Element
element]
[Element]
contentElementsL <- (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) [Element]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
(\env :: WriterEnv
env -> WriterEnv
env {envContentType :: ContentType
envContentType =ContentType
TwoColumnLeftContent})
(Element
-> [Shape] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [Element]
shapesToElements Element
layout [Shape]
shapesL)
[Element]
contentElementsR <- (WriterEnv -> WriterEnv)
-> ReaderT WriterEnv (StateT WriterState m) [Element]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
(\env :: WriterEnv
env -> WriterEnv
env {envContentType :: ContentType
envContentType =ContentType
TwoColumnRightContent})
(Element
-> [Shape] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
Element -> [Shape] -> P m [Element]
shapesToElements Element
layout [Shape]
shapesR)
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Element] -> Element
buildSpTree NameSpaces
ns Element
spTree ([Element]
hdrShapeElements [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
contentElementsL [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
contentElementsR)
twoColumnToElement _ _ _ _= Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ()
titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element
titleToElement :: Element -> [ParaElem] -> P m Element
titleToElement layout :: Element
layout titleElems :: [ParaElem]
titleElems
| NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
, Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
, Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
Element
element <- Element -> [PHType] -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m Element
nonBodyTextToElement Element
layout [MimeType -> PHType
PHType "title", MimeType -> PHType
PHType "ctrTitle"] [ParaElem]
titleElems
let titleShapeElements :: [Element]
titleShapeElements = if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
titleElems
then []
else [Element
element]
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Element] -> Element
buildSpTree NameSpaces
ns Element
spTree [Element]
titleShapeElements
titleToElement _ _ = Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ()
metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element
metadataToElement :: Element
-> [ParaElem]
-> [ParaElem]
-> [[ParaElem]]
-> [ParaElem]
-> P m Element
metadataToElement layout :: Element
layout titleElems :: [ParaElem]
titleElems subtitleElems :: [ParaElem]
subtitleElems authorsElems :: [[ParaElem]]
authorsElems dateElems :: [ParaElem]
dateElems
| NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
layout
, Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
layout
, Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld = do
[Element]
titleShapeElements <- if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
titleElems
then [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else [P m Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Element -> [PHType] -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m Element
nonBodyTextToElement Element
layout [MimeType -> PHType
PHType "ctrTitle"] [ParaElem]
titleElems]
let combinedAuthorElems :: [ParaElem]
combinedAuthorElems = [ParaElem] -> [[ParaElem]] -> [ParaElem]
forall a. [a] -> [[a]] -> [a]
intercalate [ParaElem
Break] [[ParaElem]]
authorsElems
subtitleAndAuthorElems :: [ParaElem]
subtitleAndAuthorElems = [ParaElem] -> [[ParaElem]] -> [ParaElem]
forall a. [a] -> [[a]] -> [a]
intercalate [ParaElem
Break, ParaElem
Break] [[ParaElem]
subtitleElems, [ParaElem]
combinedAuthorElems]
[Element]
subtitleShapeElements <- if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
subtitleAndAuthorElems
then [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else [P m Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Element -> [PHType] -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m Element
nonBodyTextToElement Element
layout [MimeType -> PHType
PHType "subTitle"] [ParaElem]
subtitleAndAuthorElems]
[Element]
dateShapeElements <- if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
dateElems
then [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else [P m Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Element -> [PHType] -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [PHType] -> [ParaElem] -> P m Element
nonBodyTextToElement Element
layout [MimeType -> PHType
PHType "dt"] [ParaElem]
dateElems]
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Element] -> Element
buildSpTree NameSpaces
ns Element
spTree ([Element]
titleShapeElements [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
subtitleShapeElements [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
dateShapeElements)
metadataToElement _ _ _ _ _ = Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ()
slideToElement :: PandocMonad m => Slide -> P m Element
slideToElement :: Slide -> P m Element
slideToElement (Slide _ l :: Layout
l@(ContentSlide hdrElems :: [ParaElem]
hdrElems shapes :: [Shape]
shapes) _ )= do
Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
Element
spTree <- (WriterEnv -> WriterEnv) -> P m Element -> P m Element
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrElems
then WriterEnv
env
else WriterEnv
env{envSlideHasHeader :: Bool
envSlideHasHeader=Bool
True}) (P m Element -> P m Element) -> P m Element -> P m Element
forall a b. (a -> b) -> a -> b
$
Element -> [ParaElem] -> [Shape] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [ParaElem] -> [Shape] -> P m Element
contentToElement Element
layout [ParaElem]
hdrElems [Shape]
shapes
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sld"
[ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
] [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cSld" [] [Element
spTree]]
slideToElement (Slide _ l :: Layout
l@(TwoColumnSlide hdrElems :: [ParaElem]
hdrElems shapesL :: [Shape]
shapesL shapesR :: [Shape]
shapesR) _) = do
Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
Element
spTree <- (WriterEnv -> WriterEnv) -> P m Element -> P m Element
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> if [ParaElem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ParaElem]
hdrElems
then WriterEnv
env
else WriterEnv
env{envSlideHasHeader :: Bool
envSlideHasHeader=Bool
True}) (P m Element -> P m Element) -> P m Element -> P m Element
forall a b. (a -> b) -> a -> b
$
Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element
twoColumnToElement Element
layout [ParaElem]
hdrElems [Shape]
shapesL [Shape]
shapesR
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sld"
[ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
] [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cSld" [] [Element
spTree]]
slideToElement (Slide _ l :: Layout
l@(TitleSlide hdrElems :: [ParaElem]
hdrElems) _) = do
Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
Element
spTree <- Element -> [ParaElem] -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element -> [ParaElem] -> P m Element
titleToElement Element
layout [ParaElem]
hdrElems
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sld"
[ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
] [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cSld" [] [Element
spTree]]
slideToElement (Slide _ l :: Layout
l@(MetadataSlide titleElems :: [ParaElem]
titleElems subtitleElems :: [ParaElem]
subtitleElems authorElems :: [[ParaElem]]
authorElems dateElems :: [ParaElem]
dateElems) _) = do
Element
layout <- Layout -> P m Element
forall (m :: * -> *). PandocMonad m => Layout -> P m Element
getLayout Layout
l
Element
spTree <- Element
-> [ParaElem]
-> [ParaElem]
-> [[ParaElem]]
-> [ParaElem]
-> P m Element
forall (m :: * -> *).
PandocMonad m =>
Element
-> [ParaElem]
-> [ParaElem]
-> [[ParaElem]]
-> [ParaElem]
-> P m Element
metadataToElement Element
layout [ParaElem]
titleElems [ParaElem]
subtitleElems [[ParaElem]]
authorElems [ParaElem]
dateElems
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sld"
[ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
] [FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cSld" [] [Element
spTree]]
getNotesMaster :: PandocMonad m => P m Element
getNotesMaster :: P m Element
getNotesMaster = do
Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/notesMasters/notesMaster1.xml"
getSlideNumberFieldId :: PandocMonad m => Element -> P m T.Text
getSlideNumberFieldId :: Element -> P m MimeType
getSlideNumberFieldId notesMaster :: Element
notesMaster
| NameSpaces
ns <- Element -> NameSpaces
elemToNameSpaces Element
notesMaster
, Just cSld :: Element
cSld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "cSld") Element
notesMaster
, Just spTree :: Element
spTree <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "spTree") Element
cSld
, Just sp :: Element
sp <- NameSpaces -> Element -> PHType -> Maybe Element
getShapeByPlaceHolderType NameSpaces
ns Element
spTree (MimeType -> PHType
PHType "sldNum")
, Just txBody :: Element
txBody <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "p" "txBody") Element
sp
, Just p :: Element
p <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "a" "p") Element
txBody
, Just fld :: Element
fld <- QName -> Element -> Maybe Element
findChild (NameSpaces -> FilePath -> FilePath -> QName
elemName NameSpaces
ns "a" "fld") Element
p
, Just fldId :: MimeType
fldId <- QName -> Element -> Maybe MimeType
findAttrText (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "id" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
fld =
MimeType -> P m MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return MimeType
fldId
| Bool
otherwise = PandocError -> P m MimeType
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m MimeType) -> PandocError -> P m MimeType
forall a b. (a -> b) -> a -> b
$
MimeType -> PandocError
PandocSomeError (MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$
"No field id for slide numbers in notesMaster.xml"
speakerNotesSlideImage :: Element
speakerNotesSlideImage :: Element
speakerNotesSlideImage =
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvSpPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPr" [ ("id", "2")
, ("name", "Slide Image Placeholder 1")
] ()
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvSpPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:spLocks" [ ("noGrp", "1")
, ("noRot", "1")
, ("noChangeAspect", "1")
] ()
]
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:ph" [("type", "sldImg")] ()]
]
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:spPr" [] ()
]
removeParaLinks :: Paragraph -> Paragraph
removeParaLinks :: Paragraph -> Paragraph
removeParaLinks paragraph :: Paragraph
paragraph = Paragraph
paragraph{paraElems :: [ParaElem]
paraElems = (ParaElem -> ParaElem) -> [ParaElem] -> [ParaElem]
forall a b. (a -> b) -> [a] -> [b]
map ParaElem -> ParaElem
f (Paragraph -> [ParaElem]
paraElems Paragraph
paragraph)}
where f :: ParaElem -> ParaElem
f (Run rProps :: RunProps
rProps s :: MimeType
s) = RunProps -> MimeType -> ParaElem
Run RunProps
rProps{rLink :: Maybe LinkTarget
rLink=Maybe LinkTarget
forall a. Maybe a
Nothing} MimeType
s
f pe :: ParaElem
pe = ParaElem
pe
spaceParas :: [Paragraph] -> [Paragraph]
spaceParas :: [Paragraph] -> [Paragraph]
spaceParas = Paragraph -> [Paragraph] -> [Paragraph]
forall a. a -> [a] -> [a]
intersperse (ParaProps -> [ParaElem] -> Paragraph
Paragraph ParaProps
forall a. Default a => a
def [])
speakerNotesBody :: PandocMonad m => [Paragraph] -> P m Element
speakerNotesBody :: [Paragraph] -> P m Element
speakerNotesBody paras :: [Paragraph]
paras = do
[Element]
elements <- (Paragraph -> P m Element)
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Paragraph -> P m Element
forall (m :: * -> *). PandocMonad m => Paragraph -> P m Element
paragraphToElement ([Paragraph] -> ReaderT WriterEnv (StateT WriterState m) [Element])
-> [Paragraph]
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall a b. (a -> b) -> a -> b
$ [Paragraph] -> [Paragraph]
spaceParas ([Paragraph] -> [Paragraph]) -> [Paragraph] -> [Paragraph]
forall a b. (a -> b) -> a -> b
$ (Paragraph -> Paragraph) -> [Paragraph] -> [Paragraph]
forall a b. (a -> b) -> [a] -> [b]
map Paragraph -> Paragraph
removeParaLinks [Paragraph]
paras
let txBody :: Element
txBody = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] (), FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
elements
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvSpPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPr" [ ("id", "3")
, ("name", "Notes Placeholder 2")
] ()
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvSpPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:spLocks" [("noGrp", "1")] ()]
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:ph" [("type", "body"), ("idx", "1")] ()]
]
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:spPr" [] ()
, Element
txBody
]
speakerNotesSlideNumber :: Int -> T.Text -> Element
speakerNotesSlideNumber :: Int -> MimeType -> Element
speakerNotesSlideNumber pgNum :: Int
pgNum fieldId :: MimeType
fieldId =
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sp" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvSpPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPr" [ ("id", "4")
, ("name", "Slide Number Placeholder 3")
] ()
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvSpPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:spLocks" [("noGrp", "1")] ()]
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:ph" [ ("type", "sldNum")
, ("sz", "quarter")
, ("idx", "10")
] ()
]
]
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:spPr" [] ()
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:txBody" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:bodyPr" [] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:lstStyle" [] ()
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:p" [] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:fld" [ ("id", MimeType -> FilePath
T.unpack MimeType
fieldId)
, ("type", "slidenum")
]
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:rPr" [("lang", "en-US")] ()
, FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:t" [] (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
pgNum)
]
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:endParaRPr" [("lang", "en-US")] ()
]
]
]
slideToSpeakerNotesElement :: PandocMonad m => Slide -> P m (Maybe Element)
slideToSpeakerNotesElement :: Slide -> P m (Maybe Element)
slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes [])) = Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Element
forall a. Maybe a
Nothing
slideToSpeakerNotesElement slide :: Slide
slide@(Slide _ _ (SpeakerNotes paras :: [Paragraph]
paras)) = do
Element
master <- P m Element
forall (m :: * -> *). PandocMonad m => P m Element
getNotesMaster
MimeType
fieldId <- Element -> P m MimeType
forall (m :: * -> *). PandocMonad m => Element -> P m MimeType
getSlideNumberFieldId Element
master
Int
num <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
let imgShape :: Element
imgShape = Element
speakerNotesSlideImage
sldNumShape :: Element
sldNumShape = Int -> MimeType -> Element
speakerNotesSlideNumber Int
num MimeType
fieldId
Element
bodyShape <- [Paragraph] -> P m Element
forall (m :: * -> *). PandocMonad m => [Paragraph] -> P m Element
speakerNotesBody [Paragraph]
paras
Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Element -> P m (Maybe Element))
-> Maybe Element -> P m (Maybe Element)
forall a b. (a -> b) -> a -> b
$ Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:notes"
[ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main")
, ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships")
, ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
] [ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cSld" []
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:spTree" []
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvGrpSpPr" []
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvPr" [("id", "1"), ("name", "")] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:cNvGrpSpPr" [] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:nvPr" [] ()
]
, FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:grpSpPr" []
[ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:xfrm" []
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:off" [("x", "0"), ("y", "0")] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:ext" [("cx", "0"), ("cy", "0")] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:chOff" [("x", "0"), ("y", "0")] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "a:chExt" [("cx", "0"), ("cy", "0")] ()
]
]
, Element
imgShape
, Element
bodyShape
, Element
sldNumShape
]
]
]
getSlideIdNum :: PandocMonad m => SlideId -> P m Int
getSlideIdNum :: SlideId -> P m Int
getSlideIdNum sldId :: SlideId
sldId = do
Map SlideId Int
slideIdMap <- (WriterEnv -> Map SlideId Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map SlideId Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map SlideId Int
envSlideIdMap
case SlideId -> Map SlideId Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SlideId
sldId Map SlideId Int
slideIdMap of
Just n :: Int
n -> Int -> P m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
Nothing -> PandocError -> P m Int
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> P m Int) -> PandocError -> P m Int
forall a b. (a -> b) -> a -> b
$
MimeType -> PandocError
PandocShouldNeverHappenError (MimeType -> PandocError) -> MimeType -> PandocError
forall a b. (a -> b) -> a -> b
$
"Slide Id " MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> FilePath -> MimeType
T.pack (SlideId -> FilePath
forall a. Show a => a -> FilePath
show SlideId
sldId) MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> " not found."
slideNum :: PandocMonad m => Slide -> P m Int
slideNum :: Slide -> P m Int
slideNum slide :: Slide
slide = SlideId -> P m Int
forall (m :: * -> *). PandocMonad m => SlideId -> P m Int
getSlideIdNum (SlideId -> P m Int) -> SlideId -> P m Int
forall a b. (a -> b) -> a -> b
$ Slide -> SlideId
slideId Slide
slide
idNumToFilePath :: Int -> FilePath
idNumToFilePath :: Int -> FilePath
idNumToFilePath idNum :: Int
idNum = "slide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Int
idNum) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml"
slideToFilePath :: PandocMonad m => Slide -> P m FilePath
slideToFilePath :: Slide -> P m FilePath
slideToFilePath slide :: Slide
slide = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
FilePath -> P m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> P m FilePath) -> FilePath -> P m FilePath
forall a b. (a -> b) -> a -> b
$ "slide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Int
idNum) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml"
slideToRelId :: PandocMonad m => Slide -> P m T.Text
slideToRelId :: Slide -> P m MimeType
slideToRelId slide :: Slide
slide = do
Int
n <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
Int
offset <- (WriterEnv -> Int) -> P m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envSlideIdOffset
MimeType -> P m MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return (MimeType -> P m MimeType) -> MimeType -> P m MimeType
forall a b. (a -> b) -> a -> b
$ "rId" MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> FilePath -> MimeType
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset)
data Relationship = Relationship { Relationship -> Int
relId :: Int
, Relationship -> MimeType
relType :: MimeType
, Relationship -> FilePath
relTarget :: FilePath
} deriving (Int -> Relationship -> ShowS
[Relationship] -> ShowS
Relationship -> FilePath
(Int -> Relationship -> ShowS)
-> (Relationship -> FilePath)
-> ([Relationship] -> ShowS)
-> Show Relationship
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Relationship] -> ShowS
$cshowList :: [Relationship] -> ShowS
show :: Relationship -> FilePath
$cshow :: Relationship -> FilePath
showsPrec :: Int -> Relationship -> ShowS
$cshowsPrec :: Int -> Relationship -> ShowS
Show, Relationship -> Relationship -> Bool
(Relationship -> Relationship -> Bool)
-> (Relationship -> Relationship -> Bool) -> Eq Relationship
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Relationship -> Relationship -> Bool
$c/= :: Relationship -> Relationship -> Bool
== :: Relationship -> Relationship -> Bool
$c== :: Relationship -> Relationship -> Bool
Eq)
elementToRel :: Element -> Maybe Relationship
elementToRel :: Element -> Maybe Relationship
elementToRel element :: Element
element
| Element -> QName
elName Element
element QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "Relationship" (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just "http://schemas.openxmlformats.org/package/2006/relationships") Maybe FilePath
forall a. Maybe a
Nothing =
do FilePath
rId <- QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "Id" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
element
FilePath
numStr <- FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix "rId" FilePath
rId
Int
num <- case ReadS Int
forall a. Read a => ReadS a
reads FilePath
numStr :: [(Int, String)] of
(n :: Int
n, _) : _ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
[] -> Maybe Int
forall a. Maybe a
Nothing
MimeType
type' <- QName -> Element -> Maybe MimeType
findAttrText (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "Type" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
element
FilePath
target <- QName -> Element -> Maybe FilePath
findAttr (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "Target" Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing) Element
element
Relationship -> Maybe Relationship
forall (m :: * -> *) a. Monad m => a -> m a
return (Relationship -> Maybe Relationship)
-> Relationship -> Maybe Relationship
forall a b. (a -> b) -> a -> b
$ Int -> MimeType -> FilePath -> Relationship
Relationship Int
num MimeType
type' FilePath
target
| Bool
otherwise = Maybe Relationship
forall a. Maybe a
Nothing
slideToPresRel :: PandocMonad m => Slide -> P m Relationship
slideToPresRel :: Slide -> P m Relationship
slideToPresRel slide :: Slide
slide = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
Int
n <- (WriterEnv -> Int) -> P m Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Int
envSlideIdOffset
let rId :: Int
rId = Int
idNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
fp :: FilePath
fp = "slides/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
idNumToFilePath Int
idNum
Relationship -> P m Relationship
forall (m :: * -> *) a. Monad m => a -> m a
return (Relationship -> P m Relationship)
-> Relationship -> P m Relationship
forall a b. (a -> b) -> a -> b
$ Relationship :: Int -> MimeType -> FilePath -> Relationship
Relationship { relId :: Int
relId = Int
rId
, relType :: MimeType
relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
, relTarget :: FilePath
relTarget = FilePath
fp
}
getRels :: PandocMonad m => P m [Relationship]
getRels :: P m [Relationship]
getRels = do
Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
Element
relsElem <- Archive
-> Archive
-> FilePath
-> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/_rels/presentation.xml.rels"
let globalNS :: FilePath
globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"
let relElems :: [Element]
relElems = QName -> Element -> [Element]
findChildren (FilePath -> Maybe FilePath -> Maybe FilePath -> QName
QName "Relationship" (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
globalNS) Maybe FilePath
forall a. Maybe a
Nothing) Element
relsElem
[Relationship] -> P m [Relationship]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Relationship] -> P m [Relationship])
-> [Relationship] -> P m [Relationship]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe Relationship) -> [Element] -> [Relationship]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe Relationship
elementToRel [Element]
relElems
presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]
presentationToRels :: Presentation -> P m [Relationship]
presentationToRels pres :: Presentation
pres@(Presentation _ slides :: [Slide]
slides) = do
[Relationship]
mySlideRels <- (Slide -> ReaderT WriterEnv (StateT WriterState m) Relationship)
-> [Slide] -> P m [Relationship]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> ReaderT WriterEnv (StateT WriterState m) Relationship
forall (m :: * -> *). PandocMonad m => Slide -> P m Relationship
slideToPresRel [Slide]
slides
let notesMasterRels :: [Relationship]
notesMasterRels =
if Presentation -> Bool
presHasSpeakerNotes Presentation
pres
then [Relationship :: Int -> MimeType -> FilePath -> Relationship
Relationship { relId :: Int
relId = [Relationship] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Relationship]
mySlideRels Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2
, relType :: MimeType
relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster"
, relTarget :: FilePath
relTarget = "notesMasters/notesMaster1.xml"
}]
else []
insertedRels :: [Relationship]
insertedRels = [Relationship]
mySlideRels [Relationship] -> [Relationship] -> [Relationship]
forall a. Semigroup a => a -> a -> a
<> [Relationship]
notesMasterRels
[Relationship]
rels <- P m [Relationship]
forall (m :: * -> *). PandocMonad m => P m [Relationship]
getRels
let relsWeKeep :: [Relationship]
relsWeKeep = (Relationship -> Bool) -> [Relationship] -> [Relationship]
forall a. (a -> Bool) -> [a] -> [a]
filter
(\r :: Relationship
r -> Relationship -> MimeType
relType Relationship
r MimeType -> MimeType -> Bool
forall a. Eq a => a -> a -> Bool
/= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" Bool -> Bool -> Bool
&&
Relationship -> MimeType
relType Relationship
r MimeType -> MimeType -> Bool
forall a. Eq a => a -> a -> Bool
/= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster")
[Relationship]
rels
let minRelNotOne :: Int
minRelNotOne = case (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (1Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Relationship -> Int) -> [Relationship] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Relationship -> Int
relId [Relationship]
relsWeKeep of
[] -> 0
l :: [Int]
l -> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
l
modifyRelNum :: Int -> Int
modifyRelNum :: Int -> Int
modifyRelNum 1 = 1
modifyRelNum n :: Int
n = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
minRelNotOne Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Relationship] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Relationship]
insertedRels
relsWeKeep' :: [Relationship]
relsWeKeep' = (Relationship -> Relationship) -> [Relationship] -> [Relationship]
forall a b. (a -> b) -> [a] -> [b]
map (\r :: Relationship
r -> Relationship
r{relId :: Int
relId = Int -> Int
modifyRelNum (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Relationship -> Int
relId Relationship
r}) [Relationship]
relsWeKeep
[Relationship] -> P m [Relationship]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Relationship] -> P m [Relationship])
-> [Relationship] -> P m [Relationship]
forall a b. (a -> b) -> a -> b
$ [Relationship]
insertedRels [Relationship] -> [Relationship] -> [Relationship]
forall a. Semigroup a => a -> a -> a
<> [Relationship]
relsWeKeep'
topLevelRels :: [Relationship]
topLevelRels :: [Relationship]
topLevelRels =
[ Relationship :: Int -> MimeType -> FilePath -> Relationship
Relationship { relId :: Int
relId = 1
, relType :: MimeType
relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument"
, relTarget :: FilePath
relTarget = "ppt/presentation.xml"
}
, Relationship :: Int -> MimeType -> FilePath -> Relationship
Relationship { relId :: Int
relId = 2
, relType :: MimeType
relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties"
, relTarget :: FilePath
relTarget = "docProps/core.xml"
}
, Relationship :: Int -> MimeType -> FilePath -> Relationship
Relationship { relId :: Int
relId = 3
, relType :: MimeType
relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/extended-properties"
, relTarget :: FilePath
relTarget = "docProps/app.xml"
}
, Relationship :: Int -> MimeType -> FilePath -> Relationship
Relationship { relId :: Int
relId = 4
, relType :: MimeType
relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties"
, relTarget :: FilePath
relTarget = "docProps/custom.xml"
}
]
topLevelRelsEntry :: PandocMonad m => P m Entry
topLevelRelsEntry :: P m Entry
topLevelRelsEntry = FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "_rels/.rels" (Element -> P m Entry) -> Element -> P m Entry
forall a b. (a -> b) -> a -> b
$ [Relationship] -> Element
relsToElement [Relationship]
topLevelRels
relToElement :: Relationship -> Element
relToElement :: Relationship -> Element
relToElement rel :: Relationship
rel = FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Relationship -> Int
relId Relationship
rel))
, ("Type", MimeType -> FilePath
T.unpack (MimeType -> FilePath) -> MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ Relationship -> MimeType
relType Relationship
rel)
, ("Target", Relationship -> FilePath
relTarget Relationship
rel) ] ()
relsToElement :: [Relationship] -> Element
relsToElement :: [Relationship] -> Element
relsToElement rels :: [Relationship]
rels = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationships"
[("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
((Relationship -> Element) -> [Relationship] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map Relationship -> Element
relToElement [Relationship]
rels)
presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry
presentationToRelsEntry :: Presentation -> P m Entry
presentationToRelsEntry pres :: Presentation
pres = do
[Relationship]
rels <- Presentation -> P m [Relationship]
forall (m :: * -> *).
PandocMonad m =>
Presentation -> P m [Relationship]
presentationToRels Presentation
pres
FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "ppt/_rels/presentation.xml.rels" (Element -> P m Entry) -> Element -> P m Entry
forall a b. (a -> b) -> a -> b
$ [Relationship] -> Element
relsToElement [Relationship]
rels
elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry
elemToEntry :: FilePath -> Element -> P m Entry
elemToEntry fp :: FilePath
fp element :: Element
element = do
Pixels
epochtime <- (POSIXTime -> Pixels
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Pixels)
-> (UTCTime -> POSIXTime) -> UTCTime -> Pixels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds) (UTCTime -> Pixels)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
-> ReaderT WriterEnv (StateT WriterState m) Pixels
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterEnv -> UTCTime)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> UTCTime
envUTCTime
Entry -> P m Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> P m Entry) -> Entry -> P m Entry
forall a b. (a -> b) -> a -> b
$ FilePath -> Pixels -> ByteString -> Entry
toEntry FilePath
fp Pixels
epochtime (ByteString -> Entry) -> ByteString -> Entry
forall a b. (a -> b) -> a -> b
$ Element -> ByteString
renderXml Element
element
slideToEntry :: PandocMonad m => Slide -> P m Entry
slideToEntry :: Slide -> P m Entry
slideToEntry slide :: Slide
slide = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
(WriterEnv -> WriterEnv) -> P m Entry -> P m Entry
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env{envCurSlideId :: Int
envCurSlideId = Int
idNum}) (P m Entry -> P m Entry) -> P m Entry -> P m Entry
forall a b. (a -> b) -> a -> b
$ do
Element
element <- Slide -> P m Element
forall (m :: * -> *). PandocMonad m => Slide -> P m Element
slideToElement Slide
slide
FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry ("ppt/slides/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
idNumToFilePath Int
idNum) Element
element
slideToSpeakerNotesEntry :: PandocMonad m => Slide -> P m (Maybe Entry)
slideToSpeakerNotesEntry :: Slide -> P m (Maybe Entry)
slideToSpeakerNotesEntry slide :: Slide
slide = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
(WriterEnv -> WriterEnv) -> P m (Maybe Entry) -> P m (Maybe Entry)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: WriterEnv
env -> WriterEnv
env{envCurSlideId :: Int
envCurSlideId = Int
idNum}) (P m (Maybe Entry) -> P m (Maybe Entry))
-> P m (Maybe Entry) -> P m (Maybe Entry)
forall a b. (a -> b) -> a -> b
$ do
Maybe Element
mbElement <- Slide -> P m (Maybe Element)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Element)
slideToSpeakerNotesElement Slide
slide
Maybe Int
mbNotesIdNum <- do Map Int Int
mp <- (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
Maybe Int -> ReaderT WriterEnv (StateT WriterState m) (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> ReaderT WriterEnv (StateT WriterState m) (Maybe Int))
-> Maybe Int
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int Int
mp
case Maybe Element
mbElement of
Just element :: Element
element | Just notesIdNum :: Int
notesIdNum <- Maybe Int
mbNotesIdNum ->
Entry -> Maybe Entry
forall a. a -> Maybe a
Just (Entry -> Maybe Entry)
-> ReaderT WriterEnv (StateT WriterState m) Entry
-> P m (Maybe Entry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
FilePath
-> Element -> ReaderT WriterEnv (StateT WriterState m) Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry
("ppt/notesSlides/notesSlide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
notesIdNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml")
Element
element
_ -> Maybe Entry -> P m (Maybe Entry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Entry
forall a. Maybe a
Nothing
slideToSpeakerNotesRelElement :: PandocMonad m => Slide -> P m (Maybe Element)
slideToSpeakerNotesRelElement :: Slide -> P m (Maybe Element)
slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes [])) = Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Element
forall a. Maybe a
Nothing
slideToSpeakerNotesRelElement slide :: Slide
slide@(Slide _ _ _) = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Element -> P m (Maybe Element))
-> Maybe Element -> P m (Maybe Element)
forall a b. (a -> b) -> a -> b
$ Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationships"
[("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId2")
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
, ("Target", "../slides/slide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
idNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml")
] ()
, FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId1")
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster")
, ("Target", "../notesMasters/notesMaster1.xml")
] ()
]
slideToSpeakerNotesRelEntry :: PandocMonad m => Slide -> P m (Maybe Entry)
slideToSpeakerNotesRelEntry :: Slide -> P m (Maybe Entry)
slideToSpeakerNotesRelEntry slide :: Slide
slide = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
Maybe Element
mbElement <- Slide -> P m (Maybe Element)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Element)
slideToSpeakerNotesRelElement Slide
slide
Map Int Int
mp <- (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
let mbNotesIdNum :: Maybe Int
mbNotesIdNum = Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int Int
mp
case Maybe Element
mbElement of
Just element :: Element
element | Just notesIdNum :: Int
notesIdNum <- Maybe Int
mbNotesIdNum ->
Entry -> Maybe Entry
forall a. a -> Maybe a
Just (Entry -> Maybe Entry)
-> ReaderT WriterEnv (StateT WriterState m) Entry
-> P m (Maybe Entry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
FilePath
-> Element -> ReaderT WriterEnv (StateT WriterState m) Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry
("ppt/notesSlides/_rels/notesSlide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
notesIdNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml.rels")
Element
element
_ -> Maybe Entry -> P m (Maybe Entry)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Entry
forall a. Maybe a
Nothing
slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry
slideToSlideRelEntry :: Slide -> P m Entry
slideToSlideRelEntry slide :: Slide
slide = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
Element
element <- Slide -> P m Element
forall (m :: * -> *). PandocMonad m => Slide -> P m Element
slideToSlideRelElement Slide
slide
FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry ("ppt/slides/_rels/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
idNumToFilePath Int
idNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".rels") Element
element
linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element
linkRelElement :: Int -> LinkTarget -> P m Element
linkRelElement rIdNum :: Int
rIdNum (InternalTarget targetId :: SlideId
targetId) = do
Int
targetIdNum <- SlideId -> P m Int
forall (m :: * -> *). PandocMonad m => SlideId -> P m Int
getSlideIdNum SlideId
targetId
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
rIdNum)
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
, ("Target", "slide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
targetIdNum FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml")
] ()
linkRelElement rIdNum :: Int
rIdNum (ExternalTarget (url :: MimeType
url, _)) = do
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
rIdNum)
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
, ("Target", MimeType -> FilePath
T.unpack MimeType
url)
, ("TargetMode", "External")
] ()
linkRelElements :: PandocMonad m => M.Map Int LinkTarget -> P m [Element]
linkRelElements :: Map Int LinkTarget -> P m [Element]
linkRelElements mp :: Map Int LinkTarget
mp = ((Int, LinkTarget)
-> ReaderT WriterEnv (StateT WriterState m) Element)
-> [(Int, LinkTarget)] -> P m [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(n :: Int
n, lnk :: LinkTarget
lnk) -> Int
-> LinkTarget -> ReaderT WriterEnv (StateT WriterState m) Element
forall (m :: * -> *).
PandocMonad m =>
Int -> LinkTarget -> P m Element
linkRelElement Int
n LinkTarget
lnk) (Map Int LinkTarget -> [(Int, LinkTarget)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int LinkTarget
mp)
mediaRelElement :: MediaInfo -> Element
mediaRelElement :: MediaInfo -> Element
mediaRelElement mInfo :: MediaInfo
mInfo =
let ext :: MimeType
ext = case MediaInfo -> Maybe MimeType
mInfoExt MediaInfo
mInfo of
Just e :: MimeType
e -> MimeType
e
Nothing -> ""
in
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ MediaInfo -> Int
mInfoLocalId MediaInfo
mInfo))
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
, ("Target", "../media/image" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ MediaInfo -> Int
mInfoGlobalId MediaInfo
mInfo) FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> MimeType -> FilePath
T.unpack MimeType
ext)
] ()
speakerNotesSlideRelElement :: PandocMonad m => Slide -> P m (Maybe Element)
speakerNotesSlideRelElement :: Slide -> P m (Maybe Element)
speakerNotesSlideRelElement slide :: Slide
slide = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
Map Int Int
mp <- (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
Maybe Element -> P m (Maybe Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Element -> P m (Maybe Element))
-> Maybe Element -> P m (Maybe Element)
forall a b. (a -> b) -> a -> b
$ case Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int Int
mp of
Nothing -> Maybe Element
forall a. Maybe a
Nothing
Just n :: Int
n ->
let target :: FilePath
target = "../notesSlides/notesSlide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml"
in Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId2")
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesSlide")
, ("Target", FilePath
target)
] ()
slideToSlideRelElement :: PandocMonad m => Slide -> P m Element
slideToSlideRelElement :: Slide -> P m Element
slideToSlideRelElement slide :: Slide
slide = do
Int
idNum <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
let target :: FilePath
target = case Slide
slide of
(Slide _ (MetadataSlide _ _ _ _) _) -> "../slideLayouts/slideLayout1.xml"
(Slide _ (TitleSlide _) _) -> "../slideLayouts/slideLayout3.xml"
(Slide _ (ContentSlide _ _) _) -> "../slideLayouts/slideLayout2.xml"
(Slide _ (TwoColumnSlide _ _ _) _) -> "../slideLayouts/slideLayout4.xml"
[Element]
speakerNotesRels <- Maybe Element -> [Element]
forall a. Maybe a -> [a]
maybeToList (Maybe Element -> [Element])
-> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Slide -> ReaderT WriterEnv (StateT WriterState m) (Maybe Element)
forall (m :: * -> *). PandocMonad m => Slide -> P m (Maybe Element)
speakerNotesSlideRelElement Slide
slide
Map Int (Map Int LinkTarget)
linkIds <- (WriterState -> Map Int (Map Int LinkTarget))
-> ReaderT
WriterEnv (StateT WriterState m) (Map Int (Map Int LinkTarget))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int (Map Int LinkTarget)
stLinkIds
Map Int [MediaInfo]
mediaIds <- (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
[Element]
linkRels <- case Int -> Map Int (Map Int LinkTarget) -> Maybe (Map Int LinkTarget)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int (Map Int LinkTarget)
linkIds of
Just mp :: Map Int LinkTarget
mp -> Map Int LinkTarget
-> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *).
PandocMonad m =>
Map Int LinkTarget -> P m [Element]
linkRelElements Map Int LinkTarget
mp
Nothing -> [Element] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return []
let mediaRels :: [Element]
mediaRels = case Int -> Map Int [MediaInfo] -> Maybe [MediaInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
idNum Map Int [MediaInfo]
mediaIds of
Just mInfos :: [MediaInfo]
mInfos -> (MediaInfo -> Element) -> [MediaInfo] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map MediaInfo -> Element
mediaRelElement [MediaInfo]
mInfos
Nothing -> []
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationships"
[("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
([FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Relationship" [ ("Id", "rId1")
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")
, ("Target", FilePath
target)] ()
] [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
speakerNotesRels [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
linkRels [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> [Element]
mediaRels)
slideToSldIdElement :: PandocMonad m => Slide -> P m Element
slideToSldIdElement :: Slide -> P m Element
slideToSldIdElement slide :: Slide
slide = do
Int
n <- Slide -> P m Int
forall (m :: * -> *). PandocMonad m => Slide -> P m Int
slideNum Slide
slide
let id' :: FilePath
id' = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 255
MimeType
rId <- Slide -> P m MimeType
forall (m :: * -> *). PandocMonad m => Slide -> P m MimeType
slideToRelId Slide
slide
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sldId" [("id", FilePath
id'), ("r:id", MimeType -> FilePath
T.unpack MimeType
rId)] ()
presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
presentationToSldIdLst :: Presentation -> P m Element
presentationToSldIdLst (Presentation _ slides :: [Slide]
slides) = do
[Element]
ids <- (Slide -> P m Element)
-> [Slide] -> ReaderT WriterEnv (StateT WriterState m) [Element]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> P m Element
forall (m :: * -> *). PandocMonad m => Slide -> P m Element
slideToSldIdElement [Slide]
slides
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:sldIdLst" [] [Element]
ids
presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element
presentationToPresentationElement :: Presentation -> P m Element
presentationToPresentationElement pres :: Presentation
pres@(Presentation _ slds :: [Slide]
slds) = do
Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
Element
element <- Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/presentation.xml"
Element
sldIdLst <- Presentation -> P m Element
forall (m :: * -> *). PandocMonad m => Presentation -> P m Element
presentationToSldIdLst Presentation
pres
let modifySldIdLst :: Content -> Content
modifySldIdLst :: Content -> Content
modifySldIdLst (Elem e :: Element
e) = case Element -> QName
elName Element
e of
(QName "sldIdLst" _ _) -> Element -> Content
Elem Element
sldIdLst
_ -> Element -> Content
Elem Element
e
modifySldIdLst ct :: Content
ct = Content
ct
notesMasterRId :: Int
notesMasterRId = [Slide] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Slide]
slds Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2
notesMasterElem :: Element
notesMasterElem = FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "p:notesMasterIdLst" []
[ FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode
"p:NotesMasterId"
[("r:id", "rId" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
notesMasterRId)]
()
]
removeUnwantedMaster' :: Content -> [Content]
removeUnwantedMaster' :: Content -> [Content]
removeUnwantedMaster' (Elem e :: Element
e) = case Element -> QName
elName Element
e of
(QName "notesMasterIdLst" _ _) -> []
(QName "handoutMasterIdLst" _ _) -> []
_ -> [Element -> Content
Elem Element
e]
removeUnwantedMaster' ct :: Content
ct = [Content
ct]
removeUnwantedMaster :: [Content] -> [Content]
removeUnwantedMaster :: [Content] -> [Content]
removeUnwantedMaster = (Content -> [Content]) -> [Content] -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Content -> [Content]
removeUnwantedMaster'
insertNotesMaster' :: Content -> [Content]
insertNotesMaster' :: Content -> [Content]
insertNotesMaster' (Elem e :: Element
e) = case Element -> QName
elName Element
e of
(QName "sldMasterIdLst" _ _) -> [Element -> Content
Elem Element
e, Element -> Content
Elem Element
notesMasterElem]
_ -> [Element -> Content
Elem Element
e]
insertNotesMaster' ct :: Content
ct = [Content
ct]
insertNotesMaster :: [Content] -> [Content]
insertNotesMaster :: [Content] -> [Content]
insertNotesMaster = if Presentation -> Bool
presHasSpeakerNotes Presentation
pres
then (Content -> [Content]) -> [Content] -> [Content]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Content -> [Content]
insertNotesMaster'
else [Content] -> [Content]
forall a. a -> a
id
newContent :: [Content]
newContent = [Content] -> [Content]
insertNotesMaster ([Content] -> [Content]) -> [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$
[Content] -> [Content]
removeUnwantedMaster ([Content] -> [Content]) -> [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$
(Content -> Content) -> [Content] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Content -> Content
modifySldIdLst ([Content] -> [Content]) -> [Content] -> [Content]
forall a b. (a -> b) -> a -> b
$
Element -> [Content]
elContent Element
element
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ Element
element{elContent :: [Content]
elContent = [Content]
newContent}
presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry
presentationToPresEntry :: Presentation -> P m Entry
presentationToPresEntry pres :: Presentation
pres = Presentation -> P m Element
forall (m :: * -> *). PandocMonad m => Presentation -> P m Element
presentationToPresentationElement Presentation
pres P m Element -> (Element -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "ppt/presentation.xml"
docPropsElement :: PandocMonad m => DocProps -> P m Element
docPropsElement :: DocProps -> P m Element
docPropsElement docProps :: DocProps
docProps = do
UTCTime
utctime <- (WriterEnv -> UTCTime)
-> ReaderT WriterEnv (StateT WriterState m) UTCTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> UTCTime
envUTCTime
let keywords :: MimeType
keywords = case DocProps -> Maybe [MimeType]
dcKeywords DocProps
docProps of
Just xs :: [MimeType]
xs -> MimeType -> [MimeType] -> MimeType
T.intercalate ", " [MimeType]
xs
Nothing -> ""
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> 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
$ (FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "dc:title" [] (FilePath -> Element) -> FilePath -> Element
forall a b. (a -> b) -> a -> b
$ FilePath -> (MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" MimeType -> FilePath
T.unpack (Maybe MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe MimeType
dcTitle DocProps
docProps)
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "dc:creator" [] (FilePath -> Element) -> FilePath -> Element
forall a b. (a -> b) -> a -> b
$ FilePath -> (MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" MimeType -> FilePath
T.unpack (Maybe MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe MimeType
dcCreator DocProps
docProps)
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "cp:keywords" [] (FilePath -> Element) -> FilePath -> Element
forall a b. (a -> b) -> a -> b
$ MimeType -> FilePath
T.unpack MimeType
keywords)
Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (if Maybe MimeType -> Bool
forall a. Maybe a -> Bool
isNothing (DocProps -> Maybe MimeType
dcSubject DocProps
docProps) then [] else
[FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "dc:subject" [] (FilePath -> Element) -> FilePath -> Element
forall a b. (a -> b) -> a -> b
$ FilePath -> (MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" MimeType -> FilePath
T.unpack (Maybe MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe MimeType
dcSubject DocProps
docProps])
[Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> (if Maybe MimeType -> Bool
forall a. Maybe a -> Bool
isNothing (DocProps -> Maybe MimeType
dcDescription DocProps
docProps) then [] else
[FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "dc:description" [] (FilePath -> Element) -> FilePath -> Element
forall a b. (a -> b) -> a -> b
$ FilePath -> (MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" MimeType -> FilePath
T.unpack (Maybe MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe MimeType
dcDescription DocProps
docProps])
[Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> (if Maybe MimeType -> Bool
forall a. Maybe a -> Bool
isNothing (DocProps -> Maybe MimeType
cpCategory DocProps
docProps) then [] else
[FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "cp:category" [] (FilePath -> Element) -> FilePath -> Element
forall a b. (a -> b) -> a -> b
$ FilePath -> (MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" MimeType -> FilePath
T.unpack (Maybe MimeType -> FilePath) -> Maybe MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe MimeType
cpCategory DocProps
docProps])
[Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<> (\x :: FilePath
x -> [ FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] FilePath
x
, FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] FilePath
x
]) (TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale "%FT%XZ" UTCTime
utctime)
docPropsToEntry :: PandocMonad m => DocProps -> P m Entry
docPropsToEntry :: DocProps -> P m Entry
docPropsToEntry docProps :: DocProps
docProps = DocProps -> P m Element
forall (m :: * -> *). PandocMonad m => DocProps -> P m Element
docPropsElement DocProps
docProps P m Element -> (Element -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "docProps/core.xml"
docCustomPropsElement :: PandocMonad m => DocProps -> P m Element
docCustomPropsElement :: DocProps -> P m Element
docCustomPropsElement docProps :: DocProps
docProps = do
let mkCustomProp :: (MimeType, MimeType) -> a -> Element
mkCustomProp (k :: MimeType
k, v :: MimeType
v) pid :: a
pid = FilePath -> NameSpaces -> Element -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "property"
[("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
,("pid", a -> FilePath
forall a. Show a => a -> FilePath
show a
pid)
,("name", MimeType -> FilePath
T.unpack MimeType
k)] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> FilePath -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "vt:lpwstr" [] (MimeType -> FilePath
T.unpack MimeType
v)
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$ FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> 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
$ ((MimeType, MimeType) -> Int -> Element)
-> [(MimeType, MimeType)] -> [Int] -> [Element]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (MimeType, MimeType) -> Int -> Element
forall a. Show a => (MimeType, MimeType) -> a -> Element
mkCustomProp ([(MimeType, MimeType)]
-> Maybe [(MimeType, MimeType)] -> [(MimeType, MimeType)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(MimeType, MimeType)] -> [(MimeType, MimeType)])
-> Maybe [(MimeType, MimeType)] -> [(MimeType, MimeType)]
forall a b. (a -> b) -> a -> b
$ DocProps -> Maybe [(MimeType, MimeType)]
customProperties DocProps
docProps) [(2 :: Int)..]
docCustomPropsToEntry :: PandocMonad m => DocProps -> P m Entry
docCustomPropsToEntry :: DocProps -> P m Entry
docCustomPropsToEntry docProps :: DocProps
docProps = DocProps -> P m Element
forall (m :: * -> *). PandocMonad m => DocProps -> P m Element
docCustomPropsElement DocProps
docProps P m Element -> (Element -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "docProps/custom.xml"
viewPropsElement :: PandocMonad m => P m Element
viewPropsElement :: P m Element
viewPropsElement = do
Archive
refArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envRefArchive
Archive
distArchive <- (WriterEnv -> Archive)
-> ReaderT WriterEnv (StateT WriterState m) Archive
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Archive
envDistArchive
Element
viewPrElement <- Archive -> Archive -> FilePath -> P m Element
forall (m :: * -> *).
PandocMonad m =>
Archive -> Archive -> FilePath -> m Element
parseXml Archive
refArchive Archive
distArchive "ppt/viewProps.xml"
let notLastView :: Text.XML.Light.Attr -> Bool
notLastView :: Attr -> Bool
notLastView attr :: Attr
attr = (QName -> FilePath
qName (QName -> FilePath) -> QName -> FilePath
forall a b. (a -> b) -> a -> b
$ Attr -> QName
attrKey Attr
attr) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "lastView"
Element -> P m Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> P m Element) -> Element -> P m Element
forall a b. (a -> b) -> a -> b
$
Element
viewPrElement {elAttribs :: [Attr]
elAttribs = (Attr -> Bool) -> [Attr] -> [Attr]
forall a. (a -> Bool) -> [a] -> [a]
filter Attr -> Bool
notLastView (Element -> [Attr]
elAttribs Element
viewPrElement)}
makeViewPropsEntry :: PandocMonad m => P m Entry
makeViewPropsEntry :: P m Entry
makeViewPropsEntry = P m Element
forall (m :: * -> *). PandocMonad m => P m Element
viewPropsElement P m Element -> (Element -> P m Entry) -> P m Entry
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "ppt/viewProps.xml"
defaultContentTypeToElem :: DefaultContentType -> Element
defaultContentTypeToElem :: DefaultContentType -> Element
defaultContentTypeToElem dct :: DefaultContentType
dct =
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Default"
[("Extension", MimeType -> FilePath
T.unpack (MimeType -> FilePath) -> MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ DefaultContentType -> MimeType
defContentTypesExt DefaultContentType
dct),
("ContentType", MimeType -> FilePath
T.unpack (MimeType -> FilePath) -> MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ DefaultContentType -> MimeType
defContentTypesType DefaultContentType
dct)]
()
overrideContentTypeToElem :: OverrideContentType -> Element
overrideContentTypeToElem :: OverrideContentType -> Element
overrideContentTypeToElem oct :: OverrideContentType
oct =
FilePath -> NameSpaces -> () -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Override"
[("PartName", OverrideContentType -> FilePath
overrideContentTypesPart OverrideContentType
oct),
("ContentType", MimeType -> FilePath
T.unpack (MimeType -> FilePath) -> MimeType -> FilePath
forall a b. (a -> b) -> a -> b
$ OverrideContentType -> MimeType
overrideContentTypesType OverrideContentType
oct)]
()
contentTypesToElement :: ContentTypes -> Element
contentTypesToElement :: ContentTypes -> Element
contentTypesToElement ct :: ContentTypes
ct =
let ns :: FilePath
ns = "http://schemas.openxmlformats.org/package/2006/content-types"
in
FilePath -> NameSpaces -> [Element] -> Element
forall t. Node t => FilePath -> NameSpaces -> t -> Element
mknode "Types" [("xmlns", FilePath
ns)] ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
((DefaultContentType -> Element)
-> [DefaultContentType] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map DefaultContentType -> Element
defaultContentTypeToElem ([DefaultContentType] -> [Element])
-> [DefaultContentType] -> [Element]
forall a b. (a -> b) -> a -> b
$ ContentTypes -> [DefaultContentType]
contentTypesDefaults ContentTypes
ct) [Element] -> [Element] -> [Element]
forall a. Semigroup a => a -> a -> a
<>
((OverrideContentType -> Element)
-> [OverrideContentType] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map OverrideContentType -> Element
overrideContentTypeToElem ([OverrideContentType] -> [Element])
-> [OverrideContentType] -> [Element]
forall a b. (a -> b) -> a -> b
$ ContentTypes -> [OverrideContentType]
contentTypesOverrides ContentTypes
ct)
data DefaultContentType = DefaultContentType
{ DefaultContentType -> MimeType
defContentTypesExt :: T.Text
, DefaultContentType -> MimeType
defContentTypesType:: MimeType
}
deriving (Int -> DefaultContentType -> ShowS
[DefaultContentType] -> ShowS
DefaultContentType -> FilePath
(Int -> DefaultContentType -> ShowS)
-> (DefaultContentType -> FilePath)
-> ([DefaultContentType] -> ShowS)
-> Show DefaultContentType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DefaultContentType] -> ShowS
$cshowList :: [DefaultContentType] -> ShowS
show :: DefaultContentType -> FilePath
$cshow :: DefaultContentType -> FilePath
showsPrec :: Int -> DefaultContentType -> ShowS
$cshowsPrec :: Int -> DefaultContentType -> ShowS
Show, DefaultContentType -> DefaultContentType -> Bool
(DefaultContentType -> DefaultContentType -> Bool)
-> (DefaultContentType -> DefaultContentType -> Bool)
-> Eq DefaultContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefaultContentType -> DefaultContentType -> Bool
$c/= :: DefaultContentType -> DefaultContentType -> Bool
== :: DefaultContentType -> DefaultContentType -> Bool
$c== :: DefaultContentType -> DefaultContentType -> Bool
Eq)
data OverrideContentType = OverrideContentType
{ OverrideContentType -> FilePath
overrideContentTypesPart :: FilePath
, OverrideContentType -> MimeType
overrideContentTypesType :: MimeType
}
deriving (Int -> OverrideContentType -> ShowS
[OverrideContentType] -> ShowS
OverrideContentType -> FilePath
(Int -> OverrideContentType -> ShowS)
-> (OverrideContentType -> FilePath)
-> ([OverrideContentType] -> ShowS)
-> Show OverrideContentType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [OverrideContentType] -> ShowS
$cshowList :: [OverrideContentType] -> ShowS
show :: OverrideContentType -> FilePath
$cshow :: OverrideContentType -> FilePath
showsPrec :: Int -> OverrideContentType -> ShowS
$cshowsPrec :: Int -> OverrideContentType -> ShowS
Show, OverrideContentType -> OverrideContentType -> Bool
(OverrideContentType -> OverrideContentType -> Bool)
-> (OverrideContentType -> OverrideContentType -> Bool)
-> Eq OverrideContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OverrideContentType -> OverrideContentType -> Bool
$c/= :: OverrideContentType -> OverrideContentType -> Bool
== :: OverrideContentType -> OverrideContentType -> Bool
$c== :: OverrideContentType -> OverrideContentType -> Bool
Eq)
data ContentTypes = ContentTypes { ContentTypes -> [DefaultContentType]
contentTypesDefaults :: [DefaultContentType]
, ContentTypes -> [OverrideContentType]
contentTypesOverrides :: [OverrideContentType]
}
deriving (Int -> ContentTypes -> ShowS
[ContentTypes] -> ShowS
ContentTypes -> FilePath
(Int -> ContentTypes -> ShowS)
-> (ContentTypes -> FilePath)
-> ([ContentTypes] -> ShowS)
-> Show ContentTypes
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ContentTypes] -> ShowS
$cshowList :: [ContentTypes] -> ShowS
show :: ContentTypes -> FilePath
$cshow :: ContentTypes -> FilePath
showsPrec :: Int -> ContentTypes -> ShowS
$cshowsPrec :: Int -> ContentTypes -> ShowS
Show, ContentTypes -> ContentTypes -> Bool
(ContentTypes -> ContentTypes -> Bool)
-> (ContentTypes -> ContentTypes -> Bool) -> Eq ContentTypes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentTypes -> ContentTypes -> Bool
$c/= :: ContentTypes -> ContentTypes -> Bool
== :: ContentTypes -> ContentTypes -> Bool
$c== :: ContentTypes -> ContentTypes -> Bool
Eq)
contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry
contentTypesToEntry :: ContentTypes -> P m Entry
contentTypesToEntry ct :: ContentTypes
ct = FilePath -> Element -> P m Entry
forall (m :: * -> *).
PandocMonad m =>
FilePath -> Element -> P m Entry
elemToEntry "[Content_Types].xml" (Element -> P m Entry) -> Element -> P m Entry
forall a b. (a -> b) -> a -> b
$ ContentTypes -> Element
contentTypesToElement ContentTypes
ct
pathToOverride :: FilePath -> Maybe OverrideContentType
pathToOverride :: FilePath -> Maybe OverrideContentType
pathToOverride fp :: FilePath
fp = FilePath -> MimeType -> OverrideContentType
OverrideContentType ("/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
fp) (MimeType -> OverrideContentType)
-> Maybe MimeType -> Maybe OverrideContentType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> Maybe MimeType
getContentType FilePath
fp)
mediaFileContentType :: FilePath -> Maybe DefaultContentType
mediaFileContentType :: FilePath -> Maybe DefaultContentType
mediaFileContentType fp :: FilePath
fp = case ShowS
takeExtension FilePath
fp of
'.' : ext :: FilePath
ext -> DefaultContentType -> Maybe DefaultContentType
forall a. a -> Maybe a
Just (DefaultContentType -> Maybe DefaultContentType)
-> DefaultContentType -> Maybe DefaultContentType
forall a b. (a -> b) -> a -> b
$
DefaultContentType :: MimeType -> MimeType -> DefaultContentType
DefaultContentType { defContentTypesExt :: MimeType
defContentTypesExt = FilePath -> MimeType
T.pack FilePath
ext
, defContentTypesType :: MimeType
defContentTypesType =
case FilePath -> Maybe MimeType
getMimeType FilePath
fp of
Just mt :: MimeType
mt -> MimeType
mt
Nothing -> "application/octet-stream"
}
_ -> Maybe DefaultContentType
forall a. Maybe a
Nothing
mediaContentType :: MediaInfo -> Maybe DefaultContentType
mediaContentType :: MediaInfo -> Maybe DefaultContentType
mediaContentType mInfo :: MediaInfo
mInfo
| Just t :: MimeType
t <- MediaInfo -> Maybe MimeType
mInfoExt MediaInfo
mInfo
, Just ('.', ext :: MimeType
ext) <- MimeType -> Maybe (Char, MimeType)
T.uncons MimeType
t =
DefaultContentType -> Maybe DefaultContentType
forall a. a -> Maybe a
Just (DefaultContentType -> Maybe DefaultContentType)
-> DefaultContentType -> Maybe DefaultContentType
forall a b. (a -> b) -> a -> b
$ DefaultContentType :: MimeType -> MimeType -> DefaultContentType
DefaultContentType { defContentTypesExt :: MimeType
defContentTypesExt = MimeType
ext
, defContentTypesType :: MimeType
defContentTypesType =
case MediaInfo -> Maybe MimeType
mInfoMimeType MediaInfo
mInfo of
Just mt :: MimeType
mt -> MimeType
mt
Nothing -> "application/octet-stream"
}
| Bool
otherwise = Maybe DefaultContentType
forall a. Maybe a
Nothing
getSpeakerNotesFilePaths :: PandocMonad m => P m [FilePath]
getSpeakerNotesFilePaths :: P m [FilePath]
getSpeakerNotesFilePaths = do
Map Int Int
mp <- (WriterEnv -> Map Int Int)
-> ReaderT WriterEnv (StateT WriterState m) (Map Int Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> Map Int Int
envSpeakerNotesIdMap
let notesIdNums :: [Int]
notesIdNums = Map Int Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map Int Int
mp
[FilePath] -> P m [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> P m [FilePath]) -> [FilePath] -> P m [FilePath]
forall a b. (a -> b) -> a -> b
$ (Int -> FilePath) -> [Int] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\n :: Int
n -> "ppt/notesSlides/notesSlide" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".xml") [Int]
notesIdNums
presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
presentationToContentTypes :: Presentation -> P m ContentTypes
presentationToContentTypes p :: Presentation
p@(Presentation _ slides :: [Slide]
slides) = do
[MediaInfo]
mediaInfos <- ([[MediaInfo]] -> [MediaInfo]
forall a. Monoid a => [a] -> a
mconcat ([[MediaInfo]] -> [MediaInfo])
-> (Map Int [MediaInfo] -> [[MediaInfo]])
-> Map Int [MediaInfo]
-> [MediaInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int [MediaInfo] -> [[MediaInfo]]
forall k a. Map k a -> [a]
M.elems) (Map Int [MediaInfo] -> [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) [MediaInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WriterState -> Map Int [MediaInfo])
-> ReaderT WriterEnv (StateT WriterState m) (Map Int [MediaInfo])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets WriterState -> Map Int [MediaInfo]
stMediaIds
[FilePath]
filePaths <- [Pattern] -> P m [FilePath]
forall (m :: * -> *). PandocMonad m => [Pattern] -> P m [FilePath]
patternsToFilePaths ([Pattern] -> P m [FilePath]) -> [Pattern] -> P m [FilePath]
forall a b. (a -> b) -> a -> b
$ Presentation -> [Pattern]
inheritedPatterns Presentation
p
let mediaFps :: [FilePath]
mediaFps = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pattern -> FilePath -> Bool
match (FilePath -> Pattern
compile "ppt/media/image*")) [FilePath]
filePaths
let defaults :: [DefaultContentType]
defaults = [ MimeType -> MimeType -> DefaultContentType
DefaultContentType "xml" "application/xml"
, MimeType -> MimeType -> DefaultContentType
DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
]
mediaDefaults :: [DefaultContentType]
mediaDefaults = [DefaultContentType] -> [DefaultContentType]
forall a. Eq a => [a] -> [a]
nub ([DefaultContentType] -> [DefaultContentType])
-> [DefaultContentType] -> [DefaultContentType]
forall a b. (a -> b) -> a -> b
$
((MediaInfo -> Maybe DefaultContentType)
-> [MediaInfo] -> [DefaultContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MediaInfo -> Maybe DefaultContentType
mediaContentType ([MediaInfo] -> [DefaultContentType])
-> [MediaInfo] -> [DefaultContentType]
forall a b. (a -> b) -> a -> b
$ [MediaInfo]
mediaInfos) [DefaultContentType]
-> [DefaultContentType] -> [DefaultContentType]
forall a. Semigroup a => a -> a -> a
<>
((FilePath -> Maybe DefaultContentType)
-> [FilePath] -> [DefaultContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe DefaultContentType
mediaFileContentType ([FilePath] -> [DefaultContentType])
-> [FilePath] -> [DefaultContentType]
forall a b. (a -> b) -> a -> b
$ [FilePath]
mediaFps)
inheritedOverrides :: [OverrideContentType]
inheritedOverrides = (FilePath -> Maybe OverrideContentType)
-> [FilePath] -> [OverrideContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe OverrideContentType
pathToOverride [FilePath]
filePaths
createdOverrides :: [OverrideContentType]
createdOverrides = (FilePath -> Maybe OverrideContentType)
-> [FilePath] -> [OverrideContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe OverrideContentType
pathToOverride [ "docProps/core.xml"
, "docProps/custom.xml"
, "ppt/presentation.xml"
, "ppt/viewProps.xml"
]
[FilePath]
relativePaths <- (Slide -> ReaderT WriterEnv (StateT WriterState m) FilePath)
-> [Slide] -> P m [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Slide -> ReaderT WriterEnv (StateT WriterState m) FilePath
forall (m :: * -> *). PandocMonad m => Slide -> P m FilePath
slideToFilePath [Slide]
slides
let slideOverrides :: [OverrideContentType]
slideOverrides = (FilePath -> Maybe OverrideContentType)
-> [FilePath] -> [OverrideContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\fp :: FilePath
fp -> FilePath -> Maybe OverrideContentType
pathToOverride (FilePath -> Maybe OverrideContentType)
-> FilePath -> Maybe OverrideContentType
forall a b. (a -> b) -> a -> b
$ "ppt/slides/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
fp)
[FilePath]
relativePaths
[OverrideContentType]
speakerNotesOverrides <- ((FilePath -> Maybe OverrideContentType)
-> [FilePath] -> [OverrideContentType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe OverrideContentType
pathToOverride) ([FilePath] -> [OverrideContentType])
-> P m [FilePath]
-> ReaderT WriterEnv (StateT WriterState m) [OverrideContentType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P m [FilePath]
forall (m :: * -> *). PandocMonad m => P m [FilePath]
getSpeakerNotesFilePaths
ContentTypes -> P m ContentTypes
forall (m :: * -> *) a. Monad m => a -> m a
return (ContentTypes -> P m ContentTypes)
-> ContentTypes -> P m ContentTypes
forall a b. (a -> b) -> a -> b
$ [DefaultContentType] -> [OverrideContentType] -> ContentTypes
ContentTypes
([DefaultContentType]
defaults [DefaultContentType]
-> [DefaultContentType] -> [DefaultContentType]
forall a. Semigroup a => a -> a -> a
<> [DefaultContentType]
mediaDefaults)
([OverrideContentType]
inheritedOverrides [OverrideContentType]
-> [OverrideContentType] -> [OverrideContentType]
forall a. Semigroup a => a -> a -> a
<> [OverrideContentType]
createdOverrides [OverrideContentType]
-> [OverrideContentType] -> [OverrideContentType]
forall a. Semigroup a => a -> a -> a
<> [OverrideContentType]
slideOverrides [OverrideContentType]
-> [OverrideContentType] -> [OverrideContentType]
forall a. Semigroup a => a -> a -> a
<> [OverrideContentType]
speakerNotesOverrides)
presML :: T.Text
presML :: MimeType
presML = "application/vnd.openxmlformats-officedocument.presentationml"
noPresML :: T.Text
noPresML :: MimeType
noPresML = "application/vnd.openxmlformats-officedocument"
getContentType :: FilePath -> Maybe MimeType
getContentType :: FilePath -> Maybe MimeType
getContentType fp :: FilePath
fp
| FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ppt/presentation.xml" = MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".presentation.main+xml"
| FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ppt/presProps.xml" = MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".presProps+xml"
| FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ppt/viewProps.xml" = MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".viewProps+xml"
| FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "ppt/tableStyles.xml" = MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".tableStyles+xml"
| FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "docProps/core.xml" = MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ "application/vnd.openxmlformats-package.core-properties+xml"
| FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "docProps/custom.xml" = MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ "application/vnd.openxmlformats-officedocument.custom-properties+xml"
| FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "docProps/app.xml" = MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
noPresML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".extended-properties+xml"
| "ppt" : "slideMasters" : f :: FilePath
f : [] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
, (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".slideMaster+xml"
| "ppt" : "slides" : f :: FilePath
f : [] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
, (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".slide+xml"
| "ppt" : "notesMasters" : f :: FilePath
f : [] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
, (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".notesMaster+xml"
| "ppt" : "notesSlides" : f :: FilePath
f : [] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
, (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".notesSlide+xml"
| "ppt" : "theme" : f :: FilePath
f : [] <- FilePath -> [FilePath]
splitDirectories FilePath
fp
, (_, ".xml") <- FilePath -> (FilePath, FilePath)
splitExtension FilePath
f =
MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
noPresML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".theme+xml"
| "ppt" : "slideLayouts" : _ : [] <- FilePath -> [FilePath]
splitDirectories FilePath
fp=
MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ MimeType
presML MimeType -> MimeType -> MimeType
forall a. Semigroup a => a -> a -> a
<> ".slideLayout+xml"
| Bool
otherwise = Maybe MimeType
forall a. Maybe a
Nothing
autoNumAttrs :: ListAttributes -> [(String, String)]
autoNumAttrs :: ListAttributes -> NameSpaces
autoNumAttrs (startNum :: Int
startNum, numStyle :: ListNumberStyle
numStyle, numDelim :: ListNumberDelim
numDelim) =
NameSpaces
numAttr NameSpaces -> NameSpaces -> NameSpaces
forall a. Semigroup a => a -> a -> a
<> NameSpaces
typeAttr
where
numAttr :: NameSpaces
numAttr = if Int
startNum Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1
then []
else [("startAt", Int -> FilePath
forall a. Show a => a -> FilePath
show Int
startNum)]
typeAttr :: NameSpaces
typeAttr = [("type", FilePath
typeString FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
delimString)]
typeString :: FilePath
typeString = case ListNumberStyle
numStyle of
Decimal -> "arabic"
UpperAlpha -> "alphaUc"
LowerAlpha -> "alphaLc"
UpperRoman -> "romanUc"
LowerRoman -> "romanLc"
_ -> "arabic"
delimString :: FilePath
delimString = case ListNumberDelim
numDelim of
Period -> "Period"
OneParen -> "ParenR"
TwoParens -> "ParenBoth"
_ -> "Period"