pptx-footers: Replace fixed dates with yaml date

2 files changed, 44 insertions, 8 deletions

diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
index acfd446de..f4700e8c1 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
@@ -323,8 +323,10 @@ presentationToArchiveP p@(Presentation docProps slides) = do
   refArchive <- asks envRefArchive
   distArchive <- asks envDistArchive
   presentationElement <- parseXml refArchive distArchive "ppt/presentation.xml"
-  modify (\s -> s {stFooterInfo =
-                   getFooterInfo slideLayouts master presentationElement})
+  modify (\s ->
+    s {stFooterInfo =
+        getFooterInfo (dcDate docProps) slideLayouts master presentationElement
+      })
 
   -- Update the master to make sure it includes any layouts we've just added
   masterRels <- getMasterRels
@@ -448,11 +450,19 @@ data FooterInfo = FooterInfo
   , fiShowOnFirstSlide :: Bool
   } deriving (Show, Eq)
 
-getFooterInfo :: SlideLayouts -> Element -> Element -> Maybe FooterInfo
-getFooterInfo layouts master presentation = do
+getFooterInfo :: Maybe Text -> SlideLayouts -> Element -> Element -> Maybe FooterInfo
+getFooterInfo date layouts master presentation = do
   let ns = elemToNameSpaces master
   hf <- findChild (elemName ns "p" "hf") master
-  let fiDate = getShape "dt" hf . slElement <$> layouts
+  let fiDate = let
+        f layoutDate =
+          case date of
+            Nothing -> layoutDate
+            Just d ->
+              if dateIsAutomatic (elemToNameSpaces layoutDate) layoutDate
+              then layoutDate
+              else replaceDate d layoutDate
+        in fmap f . getShape "dt" hf . slElement <$> layouts
       fiFooter = getShape "ftr" hf . slElement <$> layouts
       fiSlideNumber = getShape "sldNum" hf . slElement <$> layouts
       fiShowOnFirstSlide =
@@ -475,6 +485,29 @@ getFooterInfo layouts master presentation = do
           listToMaybe (filterChildren containsPlaceholder spTree)
         else Nothing
 
+      dateIsAutomatic :: NameSpaces -> Element -> Bool
+      dateIsAutomatic ns shape = isJust $ do
+        txBody <- findChild (elemName ns "p" "txBody") shape
+        p <- findChild (elemName ns "a" "p") txBody
+        findChild (elemName ns "a" "fld") p
+
+      replaceDate :: Text -> Element -> Element
+      replaceDate newDate e =
+        e { elContent =
+            case (elName e) of
+              QName "t" _ (Just "a") ->
+                [ Text (CData { cdVerbatim = CDataText
+                              , cdData = newDate
+                              , cdLine = Nothing
+                              })
+                ]
+              _ -> ifElem (replaceDate newDate) <$> elContent e
+           }
+
+      ifElem :: (Element -> Element) -> (Content -> Content)
+      ifElem f (Elem e) = Elem (f e)
+      ifElem _ c = c
+
       getBooleanAttribute t e =
         (`elem` ["1", "true"]) <$>
           (findAttr (QName t Nothing Nothing) e)
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
index fb4518bd7..327774cd8 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
@@ -55,7 +55,6 @@ import Text.Pandoc.Slides (getSlideLevel)
 import Text.Pandoc.Options
 import Text.Pandoc.Logging
 import Text.Pandoc.Walk
-import Data.Time (UTCTime)
 import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"
 import Text.Pandoc.Shared (tshow)
 import Text.Pandoc.Writers.Shared (lookupMetaInlines, lookupMetaBlocks
@@ -193,7 +192,7 @@ data DocProps = DocProps { dcTitle :: Maybe T.Text
                          , dcKeywords :: Maybe [T.Text]
                          , dcDescription :: Maybe T.Text
                          , cpCategory :: Maybe T.Text
-                         , dcCreated :: Maybe UTCTime
+                         , dcDate :: Maybe T.Text
                          , customProperties :: Maybe [(T.Text, T.Text)]
                          } deriving (Show, Eq)
 
@@ -1149,7 +1148,11 @@ metaToDocProps meta =
             , dcKeywords = keywords
             , dcDescription = description
             , cpCategory = Shared.stringify <$> lookupMeta "category" meta
-            , dcCreated = Nothing
+            , dcDate =
+              let t = Shared.stringify (docDate meta)
+              in if T.null t
+                 then Nothing
+                 else Just t
             , customProperties = customProperties'
             }