git.iko.soy/typeable/pandoc
on master help sign in
Powerpoint writer: Improve templating using `--reference-doc`
a2870a1Jesse Rosenthal
src/Text/Pandoc/Writers/Powerpoint.hs+145−69
compare with master
unifiedsplit
@@ -36,11 +36,11 @@ import Control.Monad.Except (throwError)
36import Control.Monad.Reader
36import Control.Monad.Reader
37import Control.Monad.State
37import Control.Monad.State
38import Codec.Archive.Zip
38import Codec.Archive.Zip
39−import Data.List (intercalate, stripPrefix, isPrefixOf, nub)
39+import Data.List (intercalate, stripPrefix, nub, union)
40import Data.Default
40import Data.Default
41import Data.Time.Clock (UTCTime)
41import Data.Time.Clock (UTCTime)
42import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
42import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
43−import System.FilePath.Posix (splitDirectories, splitExtension)
43+import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)
44import Text.XML.Light
44import Text.XML.Light
45import qualified Text.XML.Light.Cursor as XMLC
45import qualified Text.XML.Light.Cursor as XMLC
46import Text.Pandoc.Definition
46import Text.Pandoc.Definition
@@ -61,6 +61,7 @@ import qualified Data.Map as M
61import Data.Maybe (mapMaybe, listToMaybe, maybeToList, catMaybes)
61import Data.Maybe (mapMaybe, listToMaybe, maybeToList, catMaybes)
62import Text.Pandoc.ImageSize
62import Text.Pandoc.ImageSize
63import Control.Applicative ((<|>))
63import Control.Applicative ((<|>))
64+import System.FilePath.Glob
64
65
65import Text.TeXMath
66import Text.TeXMath
66import Text.Pandoc.Writers.Math (convertMath)
67import Text.Pandoc.Writers.Math (convertMath)
@@ -90,9 +91,13 @@ writePowerpoint opts (Pandoc meta blks) = do
90 Just n -> n
91 Just n -> n
91 Nothing -> getSlideLevel blks'
92 Nothing -> getSlideLevel blks'
92 }
93 }
94+
95+ let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
96+ }
97+
93− runP env def $ do pres <- blocksToPresentation blks'
98+ runP env st $ do pres <- blocksToPresentation blks'
94− archv <- presentationToArchive pres
99+ archv <- presentationToArchive pres
95− return $ fromArchive archv
100+ return $ fromArchive archv
96
101
97concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
102concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
98concatMapM f xs = liftM concat (mapM f xs)
103concatMapM f xs = liftM concat (mapM f xs)
@@ -149,6 +154,8 @@ data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String)
149 , stNoteIds :: M.Map Int [Block]
154 , stNoteIds :: M.Map Int [Block]
150 -- associate anchors with slide id
155 -- associate anchors with slide id
151 , stAnchorMap :: M.Map String Int
156 , stAnchorMap :: M.Map String Int
157+ -- media inherited from the template.
158+ , stTemplateMedia :: [FilePath]
152 } deriving (Show, Eq)
159 } deriving (Show, Eq)
153
160
154instance Default WriterState where
161instance Default WriterState where
@@ -157,8 +164,25 @@ instance Default WriterState where
157 , stMediaGlobalIds = mempty
164 , stMediaGlobalIds = mempty
158 , stNoteIds = mempty
165 , stNoteIds = mempty
159 , stAnchorMap= mempty
166 , stAnchorMap= mempty
167+ , stTemplateMedia = []
160 }
168 }
161
169
170+-- This populates the global ids map with images already in the
171+-- template, so the ids won't be used by images introduced by the
172+-- user.
173+initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int
174+initialGlobalIds refArchive distArchive =
175+ let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
176+ mediaPaths = filter (match (compile "ppt/media/image")) archiveFiles
177+
178+ go :: FilePath -> Maybe (FilePath, Int)
179+ go fp = do
180+ s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp
181+ (n, _) <- listToMaybe $ reads s
182+ return (fp, n)
183+ in
184+ M.fromList $ mapMaybe go mediaPaths
185+
162type P m = ReaderT WriterEnv (StateT WriterState m)
186type P m = ReaderT WriterEnv (StateT WriterState m)
163
187
164runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
188runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
@@ -760,75 +784,111 @@ copyFileToArchive arch fp = do
760 Nothing -> fail $ fp ++ " missing in reference file"
784 Nothing -> fail $ fp ++ " missing in reference file"
761 Just e -> return $ addEntryToArchive e arch
785 Just e -> return $ addEntryToArchive e arch
762
786
763−getMediaFiles :: PandocMonad m => P m [FilePath]
787+-- getMediaFiles :: PandocMonad m => P m [FilePath]
764−getMediaFiles = do
788+-- getMediaFiles = do
789+-- refArchive <- asks envRefArchive
790+-- distArchive <- asks envDistArchive
791+-- let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive
792+-- return $ filter (isPrefixOf "ppt/media") allEntries
793+
794+
795+-- copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive
796+-- copyFileToArchiveIfExists arch fp = do
797+-- refArchive <- asks envRefArchive
798+-- distArchive <- asks envDistArchive
799+-- case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
800+-- Nothing -> return $ arch
801+-- Just e -> return $ addEntryToArchive e arch
802+
803+inheritedPatterns :: [Pattern]
804+inheritedPatterns = map compile [ "_rels/.rels"
805+ , "docProps/app.xml"
806+ , "docProps/core.xml"
807+ , "ppt/slideLayouts/slideLayout*.xml"
808+ , "ppt/slideLayouts/_rels/slideLayout*.xml.rels"
809+ , "ppt/slideMasters/slideMaster1.xml"
810+ , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
811+ , "ppt/theme/theme1.xml"
812+ , "ppt/theme/_rels/theme1.xml.rels"
813+ , "ppt/presProps.xml"
814+ , "ppt/viewProps.xml"
815+ , "ppt/tableStyles.xml"
816+ , "ppt/media/image*"
817+ ]
818+
819+patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]
820+patternToFilePaths pat = do
765 refArchive <- asks envRefArchive
821 refArchive <- asks envRefArchive
766 distArchive <- asks envDistArchive
822 distArchive <- asks envDistArchive
767− let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive
768− return $ filter (isPrefixOf "ppt/media") allEntries
769
823
824+ let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
825+ return $ filter (match pat) archiveFiles
826+
827+patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]
828+patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats
829+
830+-- requiredFiles :: [FilePath]
831+-- requiredFiles = inheritedFiles
832+
833+-- inheritedFiles :: [FilePath]
834+-- inheritedFiles = [ "_rels/.rels"
835+-- , "docProps/app.xml"
836+-- , "docProps/core.xml"
837+-- , "ppt/slideLayouts/slideLayout4.xml"
838+-- , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"
839+-- , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
840+-- , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"
841+-- , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
842+-- , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
843+-- , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"
844+-- , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"
845+-- , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"
846+-- , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"
847+-- , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
848+-- , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"
849+-- , "ppt/slideLayouts/slideLayout2.xml"
850+-- , "ppt/slideLayouts/slideLayout8.xml"
851+-- , "ppt/slideLayouts/slideLayout11.xml"
852+-- , "ppt/slideLayouts/slideLayout3.xml"
853+-- , "ppt/slideLayouts/slideLayout6.xml"
854+-- , "ppt/slideLayouts/slideLayout9.xml"
855+-- , "ppt/slideLayouts/slideLayout5.xml"
856+-- , "ppt/slideLayouts/slideLayout7.xml"
857+-- , "ppt/slideLayouts/slideLayout1.xml"
858+-- , "ppt/slideLayouts/slideLayout10.xml"
859+-- -- , "ppt/_rels/presentation.xml.rels"
860+-- , "ppt/theme/theme1.xml"
861+-- , "ppt/presProps.xml"
862+-- -- , "ppt/slides/_rels/slide1.xml.rels"
863+-- -- , "ppt/slides/_rels/slide2.xml.rels"
864+-- -- This is the one we're
865+-- -- going to build
866+-- -- , "ppt/slides/slide2.xml"
867+-- -- , "ppt/slides/slide1.xml"
868+-- , "ppt/viewProps.xml"
869+-- , "ppt/tableStyles.xml"
870+-- , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
871+-- , "ppt/slideMasters/slideMaster1.xml"
872+-- -- , "ppt/presentation.xml"
873+-- -- , "[Content_Types].xml"
874+-- ]
875+
876+-- -- Here are some that might not be there. We won't fail if they're not
877+-- possibleInheritedFiles :: [FilePath]
878+-- possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ]
770
879
771−copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive
772−copyFileToArchiveIfExists arch fp = do
773− refArchive <- asks envRefArchive
774− distArchive <- asks envDistArchive
775− case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
776− Nothing -> return $ arch
777− Just e -> return $ addEntryToArchive e arch
778−
779−inheritedFiles :: [FilePath]
780−inheritedFiles = [ "_rels/.rels"
781− , "docProps/app.xml"
782− , "docProps/core.xml"
783− , "ppt/slideLayouts/slideLayout4.xml"
784− , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"
785− , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
786− , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"
787− , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
788− , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
789− , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"
790− , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"
791− , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"
792− , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"
793− , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
794− , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"
795− , "ppt/slideLayouts/slideLayout2.xml"
796− , "ppt/slideLayouts/slideLayout8.xml"
797− , "ppt/slideLayouts/slideLayout11.xml"
798− , "ppt/slideLayouts/slideLayout3.xml"
799− , "ppt/slideLayouts/slideLayout6.xml"
800− , "ppt/slideLayouts/slideLayout9.xml"
801− , "ppt/slideLayouts/slideLayout5.xml"
802− , "ppt/slideLayouts/slideLayout7.xml"
803− , "ppt/slideLayouts/slideLayout1.xml"
804− , "ppt/slideLayouts/slideLayout10.xml"
805− -- , "ppt/_rels/presentation.xml.rels"
806− , "ppt/theme/theme1.xml"
807− , "ppt/presProps.xml"
808− -- , "ppt/slides/_rels/slide1.xml.rels"
809− -- , "ppt/slides/_rels/slide2.xml.rels"
810− -- This is the one we're
811− -- going to build
812− -- , "ppt/slides/slide2.xml"
813− -- , "ppt/slides/slide1.xml"
814− , "ppt/viewProps.xml"
815− , "ppt/tableStyles.xml"
816− , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
817− , "ppt/slideMasters/slideMaster1.xml"
818− -- , "ppt/presentation.xml"
819− -- , "[Content_Types].xml"
820− ]
821−
822−-- Here are some that might not be there. We won't fail if they're not
823−possibleInheritedFiles :: [FilePath]
824−possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ]
825
880
826presentationToArchive :: PandocMonad m => Presentation -> P m Archive
881presentationToArchive :: PandocMonad m => Presentation -> P m Archive
827presentationToArchive p@(Presentation _ slides) = do
882presentationToArchive p@(Presentation _ slides) = do
883+ filePaths <- patternsToFilePaths inheritedPatterns
828− newArch <- foldM copyFileToArchive emptyArchive inheritedFiles
884+ newArch' <- foldM copyFileToArchive emptyArchive filePaths
885+
886+ -- set the template media to the relevant fps:
887+
888+ -- we register any media fp in the filepaths
829− mediaDir <- getMediaFiles
889+ -- mediaDir <- getMediaFiles
830− newArch' <- foldM copyFileToArchiveIfExists newArch $
890+ -- newArch' <- foldM copyFileToArchiveIfExists newArch $
831− possibleInheritedFiles ++ mediaDir
891+ -- possibleInheritedFiles ++ mediaDir
832 -- presentation entry and rels. We have to do the rels first to make
892 -- presentation entry and rels. We have to do the rels first to make
833 -- sure we know the correct offset for the rIds.
893 -- sure we know the correct offset for the rIds.
834 presEntry <- presentationToPresEntry p
894 presEntry <- presentationToPresEntry p
@@ -1808,6 +1868,17 @@ contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToEleme
1808pathToOverride :: FilePath -> Maybe OverrideContentType
1868pathToOverride :: FilePath -> Maybe OverrideContentType
1809pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)
1869pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)
1810
1870
1871+mediaFileContentType :: FilePath -> Maybe DefaultContentType
1872+mediaFileContentType fp = case takeExtension fp of
1873+ '.' : ext -> Just $
1874+ DefaultContentType { defContentTypesExt = ext
1875+ , defContentTypesType =
1876+ case getMimeType fp of
1877+ Just mt -> mt
1878+ Nothing -> "application/octet-stream"
1879+ }
1880+ _ -> Nothing
1881+
1811mediaContentType :: MediaInfo -> Maybe DefaultContentType
1882mediaContentType :: MediaInfo -> Maybe DefaultContentType
1812mediaContentType mInfo
1883mediaContentType mInfo
1813 | Just ('.' : ext) <- mInfoExt mInfo =
1884 | Just ('.' : ext) <- mInfoExt mInfo =
@@ -1822,11 +1893,16 @@ mediaContentType mInfo
1822presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
1893presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
1823presentationToContentTypes (Presentation _ slides) = do
1894presentationToContentTypes (Presentation _ slides) = do
1824 mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
1895 mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
1896+ filePaths <- patternsToFilePaths inheritedPatterns
1897+ let mediaFps = filter (match (compile "ppt/media/image*")) filePaths
1825 let defaults = [ DefaultContentType "xml" "application/xml"
1898 let defaults = [ DefaultContentType "xml" "application/xml"
1826 , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
1899 , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
1827 ]
1900 ]
1901+ mediaDefaults = nub $
1828− mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos
1902+ (mapMaybe mediaContentType $ mediaInfos) ++
1903+ (mapMaybe mediaFileContentType $ mediaFps)
1904+
1829− inheritedOverrides = mapMaybe pathToOverride inheritedFiles
1905+ inheritedOverrides = mapMaybe pathToOverride filePaths
1830 presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
1906 presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
1831 slideOverrides =
1907 slideOverrides =
1832 mapMaybe
1908 mapMaybe