From bfef2cbbf33ac1ebc2a1b90a78a9598b3bc76169 Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Thu, 18 Jan 2018 08:17:09 -0500 Subject: Powerpoint writer: Add docProps to Presentation datatype. This picks up the necessary information from meta and carries it over to the XML output, so Output.hs doesn't need access to the original pandoc information. --- src/Text/Pandoc/Writers/Powerpoint/Output.hs | 10 +++--- 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) -- cgit v1.2.3