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.

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)