From a2870a1aeb534b5cb237f2cff9448ca714574b35 Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Fri, 12 Jan 2018 17:28:58 -0500 Subject: Powerpoint writer: Improve templating using `--reference-doc` Templating should work much more reliably now. There is still some problem with image placement when we change sizes. A further commit will address this. --- src/Text/Pandoc/Writers/Powerpoint.hs | 214 +++++++++++++++++++++++----------- 1 file changed, 145 insertions(+), 69 deletions(-) (limited to 'src/Text/Pandoc/Writers') diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs index af19ec93b..7fa327668 100644 --- a/src/Text/Pandoc/Writers/Powerpoint.hs +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -36,11 +36,11 @@ import Control.Monad.Except (throwError) import Control.Monad.Reader import Control.Monad.State import Codec.Archive.Zip -import Data.List (intercalate, stripPrefix, isPrefixOf, nub) +import Data.List (intercalate, stripPrefix, nub, union) import Data.Default import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) -import System.FilePath.Posix (splitDirectories, splitExtension) +import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension) import Text.XML.Light import qualified Text.XML.Light.Cursor as XMLC import Text.Pandoc.Definition @@ -61,6 +61,7 @@ import qualified Data.Map as M import Data.Maybe (mapMaybe, listToMaybe, maybeToList, catMaybes) import Text.Pandoc.ImageSize import Control.Applicative ((<|>)) +import System.FilePath.Glob import Text.TeXMath import Text.Pandoc.Writers.Math (convertMath) @@ -90,9 +91,13 @@ writePowerpoint opts (Pandoc meta blks) = do Just n -> n Nothing -> getSlideLevel blks' } - runP env def $ do pres <- blocksToPresentation blks' - archv <- presentationToArchive pres - return $ fromArchive archv + + let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive + } + + runP env st $ do pres <- blocksToPresentation blks' + archv <- presentationToArchive pres + return $ fromArchive archv concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs) @@ -149,6 +154,8 @@ data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String) , stNoteIds :: M.Map Int [Block] -- associate anchors with slide id , stAnchorMap :: M.Map String Int + -- media inherited from the template. + , stTemplateMedia :: [FilePath] } deriving (Show, Eq) instance Default WriterState where @@ -157,8 +164,25 @@ instance Default WriterState where , stMediaGlobalIds = mempty , stNoteIds = mempty , stAnchorMap= mempty + , stTemplateMedia = [] } +-- This populates the global ids map with images already in the +-- template, so the ids won't be used by images introduced by the +-- user. +initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int +initialGlobalIds refArchive distArchive = + let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive + mediaPaths = filter (match (compile "ppt/media/image")) archiveFiles + + go :: FilePath -> Maybe (FilePath, Int) + go fp = do + s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp + (n, _) <- listToMaybe $ reads s + return (fp, n) + in + M.fromList $ mapMaybe go mediaPaths + type P m = ReaderT WriterEnv (StateT WriterState m) runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a @@ -760,75 +784,111 @@ copyFileToArchive arch fp = do Nothing -> fail $ fp ++ " missing in reference file" Just e -> return $ addEntryToArchive e arch -getMediaFiles :: PandocMonad m => P m [FilePath] -getMediaFiles = do +-- getMediaFiles :: PandocMonad m => P m [FilePath] +-- getMediaFiles = do +-- refArchive <- asks envRefArchive +-- distArchive <- asks envDistArchive +-- let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive +-- return $ filter (isPrefixOf "ppt/media") allEntries + + +-- copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive +-- copyFileToArchiveIfExists arch fp = do +-- refArchive <- asks envRefArchive +-- distArchive <- asks envDistArchive +-- case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of +-- Nothing -> return $ arch +-- Just e -> return $ addEntryToArchive e arch + +inheritedPatterns :: [Pattern] +inheritedPatterns = map compile [ "_rels/.rels" + , "docProps/app.xml" + , "docProps/core.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/viewProps.xml" + , "ppt/tableStyles.xml" + , "ppt/media/image*" + ] + +patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath] +patternToFilePaths pat = do refArchive <- asks envRefArchive distArchive <- asks envDistArchive - let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive - return $ filter (isPrefixOf "ppt/media") allEntries + let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive + return $ filter (match pat) archiveFiles + +patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath] +patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats + +-- requiredFiles :: [FilePath] +-- requiredFiles = inheritedFiles + +-- inheritedFiles :: [FilePath] +-- inheritedFiles = [ "_rels/.rels" +-- , "docProps/app.xml" +-- , "docProps/core.xml" +-- , "ppt/slideLayouts/slideLayout4.xml" +-- , "ppt/slideLayouts/_rels/slideLayout9.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout10.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout5.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout7.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout8.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout11.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" +-- , "ppt/slideLayouts/_rels/slideLayout6.xml.rels" +-- , "ppt/slideLayouts/slideLayout2.xml" +-- , "ppt/slideLayouts/slideLayout8.xml" +-- , "ppt/slideLayouts/slideLayout11.xml" +-- , "ppt/slideLayouts/slideLayout3.xml" +-- , "ppt/slideLayouts/slideLayout6.xml" +-- , "ppt/slideLayouts/slideLayout9.xml" +-- , "ppt/slideLayouts/slideLayout5.xml" +-- , "ppt/slideLayouts/slideLayout7.xml" +-- , "ppt/slideLayouts/slideLayout1.xml" +-- , "ppt/slideLayouts/slideLayout10.xml" +-- -- , "ppt/_rels/presentation.xml.rels" +-- , "ppt/theme/theme1.xml" +-- , "ppt/presProps.xml" +-- -- , "ppt/slides/_rels/slide1.xml.rels" +-- -- , "ppt/slides/_rels/slide2.xml.rels" +-- -- This is the one we're +-- -- going to build +-- -- , "ppt/slides/slide2.xml" +-- -- , "ppt/slides/slide1.xml" +-- , "ppt/viewProps.xml" +-- , "ppt/tableStyles.xml" +-- , "ppt/slideMasters/_rels/slideMaster1.xml.rels" +-- , "ppt/slideMasters/slideMaster1.xml" +-- -- , "ppt/presentation.xml" +-- -- , "[Content_Types].xml" +-- ] + +-- -- Here are some that might not be there. We won't fail if they're not +-- possibleInheritedFiles :: [FilePath] +-- possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ] -copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive -copyFileToArchiveIfExists arch fp = do - refArchive <- asks envRefArchive - distArchive <- asks envDistArchive - case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of - Nothing -> return $ arch - Just e -> return $ addEntryToArchive e arch - -inheritedFiles :: [FilePath] -inheritedFiles = [ "_rels/.rels" - , "docProps/app.xml" - , "docProps/core.xml" - , "ppt/slideLayouts/slideLayout4.xml" - , "ppt/slideLayouts/_rels/slideLayout9.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout10.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout5.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout7.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout8.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout11.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" - , "ppt/slideLayouts/_rels/slideLayout6.xml.rels" - , "ppt/slideLayouts/slideLayout2.xml" - , "ppt/slideLayouts/slideLayout8.xml" - , "ppt/slideLayouts/slideLayout11.xml" - , "ppt/slideLayouts/slideLayout3.xml" - , "ppt/slideLayouts/slideLayout6.xml" - , "ppt/slideLayouts/slideLayout9.xml" - , "ppt/slideLayouts/slideLayout5.xml" - , "ppt/slideLayouts/slideLayout7.xml" - , "ppt/slideLayouts/slideLayout1.xml" - , "ppt/slideLayouts/slideLayout10.xml" - -- , "ppt/_rels/presentation.xml.rels" - , "ppt/theme/theme1.xml" - , "ppt/presProps.xml" - -- , "ppt/slides/_rels/slide1.xml.rels" - -- , "ppt/slides/_rels/slide2.xml.rels" - -- This is the one we're - -- going to build - -- , "ppt/slides/slide2.xml" - -- , "ppt/slides/slide1.xml" - , "ppt/viewProps.xml" - , "ppt/tableStyles.xml" - , "ppt/slideMasters/_rels/slideMaster1.xml.rels" - , "ppt/slideMasters/slideMaster1.xml" - -- , "ppt/presentation.xml" - -- , "[Content_Types].xml" - ] - --- Here are some that might not be there. We won't fail if they're not -possibleInheritedFiles :: [FilePath] -possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ] presentationToArchive :: PandocMonad m => Presentation -> P m Archive presentationToArchive p@(Presentation _ slides) = do - newArch <- foldM copyFileToArchive emptyArchive inheritedFiles - mediaDir <- getMediaFiles - newArch' <- foldM copyFileToArchiveIfExists newArch $ - possibleInheritedFiles ++ mediaDir + filePaths <- patternsToFilePaths inheritedPatterns + newArch' <- foldM copyFileToArchive emptyArchive filePaths + + -- set the template media to the relevant fps: + + -- we register any media fp in the filepaths + -- mediaDir <- getMediaFiles + -- newArch' <- foldM copyFileToArchiveIfExists newArch $ + -- possibleInheritedFiles ++ mediaDir -- presentation entry and rels. We have to do the rels first to make -- sure we know the correct offset for the rIds. presEntry <- presentationToPresEntry p @@ -1808,6 +1868,17 @@ contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToEleme pathToOverride :: FilePath -> Maybe OverrideContentType pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp) +mediaFileContentType :: FilePath -> Maybe DefaultContentType +mediaFileContentType fp = case takeExtension fp of + '.' : ext -> Just $ + DefaultContentType { defContentTypesExt = ext + , defContentTypesType = + case getMimeType fp of + Just mt -> mt + Nothing -> "application/octet-stream" + } + _ -> Nothing + mediaContentType :: MediaInfo -> Maybe DefaultContentType mediaContentType mInfo | Just ('.' : ext) <- mInfoExt mInfo = @@ -1822,11 +1893,16 @@ mediaContentType mInfo presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes presentationToContentTypes (Presentation _ slides) = do mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds + filePaths <- patternsToFilePaths inheritedPatterns + let mediaFps = filter (match (compile "ppt/media/image*")) filePaths let defaults = [ DefaultContentType "xml" "application/xml" , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" ] - mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos - inheritedOverrides = mapMaybe pathToOverride inheritedFiles + mediaDefaults = nub $ + (mapMaybe mediaContentType $ mediaInfos) ++ + (mapMaybe mediaFileContentType $ mediaFps) + + inheritedOverrides = mapMaybe pathToOverride filePaths presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] slideOverrides = mapMaybe -- cgit v1.2.3