diff options
| -rw-r--r-- | src/Text/Pandoc/Writers/Powerpoint/Output.hs | 10 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Powerpoint/Presentation.hs | 41 |
2 files changed, 39 insertions, 12 deletions
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index 8ef5665fa..45ae86352 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -213,7 +213,7 @@ requiredFiles = [ "docProps/app.xml" presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive -presentationToArchiveP p@(Presentation slides) = do +presentationToArchiveP p@(Presentation _ slides) = do filePaths <- patternsToFilePaths inheritedPatterns -- make sure all required files are available: @@ -247,7 +247,7 @@ presentationToArchiveP p@(Presentation slides) = do [contentTypesEntry, relsEntry, presEntry, presRelsEntry] makeSlideIdMap :: Presentation -> M.Map SlideId Int -makeSlideIdMap (Presentation slides) = +makeSlideIdMap (Presentation _ slides) = M.fromList $ (map slideId slides) `zip` [1..] presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive @@ -1142,7 +1142,7 @@ getRels = do return $ mapMaybe elementToRel relElems presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] -presentationToRels (Presentation slides) = do +presentationToRels (Presentation _ slides) = do mySlideRels <- mapM slideToPresRel slides rels <- getRels let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels @@ -1288,7 +1288,7 @@ slideToSldIdElement slide = do return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element -presentationToSldIdLst (Presentation slides) = do +presentationToSldIdLst (Presentation _ slides) = do ids <- mapM slideToSldIdElement slides return $ mknode "p:sldIdLst" [] ids @@ -1384,7 +1384,7 @@ mediaContentType mInfo | otherwise = Nothing presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes -presentationToContentTypes (Presentation slides) = do +presentationToContentTypes (Presentation _ slides) = do mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds filePaths <- patternsToFilePaths inheritedPatterns let mediaFps = filter (match (compile "ppt/media/image*")) filePaths diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index 495675aad..1300bbe39 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -66,6 +66,7 @@ import Text.Pandoc.Slides (getSlideLevel) import Text.Pandoc.Options import Text.Pandoc.Logging import Text.Pandoc.Walk +import Text.Pandoc.Compat.Time (UTCTime) import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element" import Text.Pandoc.Writers.Shared (metaValueToInlines) import qualified Data.Map as M @@ -161,9 +162,16 @@ concatMapM f xs = liftM concat (mapM f xs) type Pixels = Integer -data Presentation = Presentation [Slide] +data Presentation = Presentation DocProps [Slide] deriving (Show) +data DocProps = DocProps { dcTitle :: Maybe String + , dcSubject :: Maybe String + , dcCreator :: Maybe String + , dcKeywords :: Maybe [String] + , dcCreated :: Maybe UTCTime + } deriving (Show, Eq) + data Slide = Slide { slideId :: SlideId , slideLayout :: Layout @@ -796,8 +804,8 @@ replaceAnchor (Run rProps s) return $ Run rProps' s replaceAnchor pe = return pe -blocksToPresentation :: [Block] -> Pres Presentation -blocksToPresentation blks = do +blocksToPresentationSlides :: [Block] -> Pres [Slide] +blocksToPresentationSlides blks = do opts <- asks envOpts metadataslides <- maybeToList <$> getMetaSlide -- As far as I can tell, if we want to have a variable-length toc in @@ -836,17 +844,36 @@ blocksToPresentation blks = do return [endNotesSlide] let slides = metadataslides ++ tocSlides ++ bodyslides ++ endNotesSlides - slides' <- mapM (applyToSlide replaceAnchor) slides - return $ Presentation slides' + mapM (applyToSlide replaceAnchor) slides + +metaToDocProps :: Meta -> DocProps +metaToDocProps meta = + let keywords = case lookupMeta "keywords" meta of + Just (MetaList xs) -> Just $ map Shared.stringify xs + _ -> Nothing + + authors = case lookupMeta "author" meta of + Just (MetaList xs) -> Just $ map Shared.stringify xs + _ -> Nothing + in + DocProps{ dcTitle = Shared.stringify <$> lookupMeta "title" meta + , dcSubject = Shared.stringify <$> lookupMeta "subject" meta + , dcCreator = (intercalate "; ") <$> authors + , dcKeywords = keywords + , dcCreated = Nothing + } documentToPresentation :: WriterOptions -> Pandoc -> (Presentation, [LogMessage]) -documentToPresentation opts (Pandoc meta blks) = do +documentToPresentation opts (Pandoc meta blks) = let env = def { envOpts = opts , envMetadata = meta , envSlideLevel = case writerSlideLevel opts of Just lvl -> lvl Nothing -> getSlideLevel blks } - runPres env def $ blocksToPresentation blks + (presSlides, msgs) = runPres env def $ blocksToPresentationSlides blks + docProps = metaToDocProps meta + in + (Presentation docProps presSlides, msgs) |