pptx: Support footers in the reference doc

In PowerPoint, it’s possible to specify footers across all slides,
containing a date (optionally automatically updated to today’s date),
the slide number (optionally starting from a higher number than 1), and
static text. There’s also an option to hide the footer on the title
slide.

Before this commit, none of that footer content was pulled through from
the reference doc: this commit supports all the functionality listed
above.

There is one behaviour which may not be immediately obvious: if the
reference doc specifies a fixed date (i.e. not automatically updating),
and there’s a date specified in the metadata for the document, the
footer date is replaced by the metadata date.

- Include date, slide number, and static footer content from reference
  doc
- Respect “slide number starts from” option
- Respect “Don’t show on title slide” option
- Add tests

1 files changed, 88 insertions, 15 deletions

diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
index 1431469d3..acfd446de 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TupleSections #-}
 {- |
@@ -159,7 +160,7 @@ data SlideLayoutsOf a = SlideLayouts
   , comparison :: a
   , contentWithCaption :: a
   , blank :: a
-  } deriving (Show, Functor, Foldable, Traversable)
+  } deriving (Show, Eq, Functor, Foldable, Traversable)
 
 data SlideLayout = SlideLayout
   { slElement :: Element
@@ -197,12 +198,14 @@ data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int LinkTarget)
                                -- (FP, Local ID, Global ID, Maybe Mime)
                                , stMediaIds :: M.Map Int [MediaInfo]
                                , stMediaGlobalIds :: M.Map FilePath Int
+                               , stFooterInfo :: Maybe FooterInfo
                                } deriving (Show, Eq)
 
 instance Default WriterState where
   def = WriterState { stLinkIds = mempty
                     , stMediaIds = mempty
                     , stMediaGlobalIds = mempty
+                    , stFooterInfo = Nothing
                     }
 
 type P m = ReaderT WriterEnv (StateT WriterState m)
@@ -316,8 +319,14 @@ presentationToArchiveP p@(Presentation docProps slides) = do
         else id
   let newArch' = foldr f newArch slideLayouts
 
-  -- Update the master to make sure it includes any layouts we've just added
   master <- getMaster
+  refArchive <- asks envRefArchive
+  distArchive <- asks envDistArchive
+  presentationElement <- parseXml refArchive distArchive "ppt/presentation.xml"
+  modify (\s -> s {stFooterInfo =
+                   getFooterInfo slideLayouts master presentationElement})
+
+  -- Update the master to make sure it includes any layouts we've just added
   masterRels <- getMasterRels
   let (updatedMasterElem, updatedMasterRelElem) = updateMasterElems slideLayouts master masterRels
   updatedMasterEntry <- elemToEntry "ppt/slideMasters/slideMaster1.xml" updatedMasterElem
@@ -432,6 +441,56 @@ updateMasterElems layouts master masterRels = (updatedMaster, updatedMasterRels)
         getIdAttribute (Elem e) = findAttr (QName "id" Nothing Nothing) e
         getIdAttribute _ = Nothing
 
+data FooterInfo = FooterInfo
+  { fiDate :: SlideLayoutsOf (Maybe Element)
+  , fiFooter :: SlideLayoutsOf (Maybe Element)
+  , fiSlideNumber :: SlideLayoutsOf (Maybe Element)
+  , fiShowOnFirstSlide :: Bool
+  } deriving (Show, Eq)
+
+getFooterInfo :: SlideLayouts -> Element -> Element -> Maybe FooterInfo
+getFooterInfo layouts master presentation = do
+  let ns = elemToNameSpaces master
+  hf <- findChild (elemName ns "p" "hf") master
+  let fiDate = getShape "dt" hf . slElement <$> layouts
+      fiFooter = getShape "ftr" hf . slElement <$> layouts
+      fiSlideNumber = getShape "sldNum" hf . slElement <$> layouts
+      fiShowOnFirstSlide =
+        fromMaybe True
+        (getBooleanAttribute "showSpecialPlsOnTitleSld" presentation)
+  pure FooterInfo{..}
+    where
+      getShape t hf layout =
+        if fromMaybe True (getBooleanAttribute t hf)
+        then do
+          let ns = elemToNameSpaces layout
+          cSld <- findChild (elemName ns "p" "cSld") layout
+          spTree <- findChild (elemName ns "p" "spTree") cSld
+          let containsPlaceholder sp = fromMaybe False $ do
+                nvSpPr <- findChild (elemName ns "p" "nvSpPr") sp
+                nvPr <- findChild (elemName ns "p" "nvPr") nvSpPr
+                ph <- findChild (elemName ns "p" "ph") nvPr
+                placeholderType <- findAttr (QName "type" Nothing Nothing) ph
+                pure (placeholderType == t)
+          listToMaybe (filterChildren containsPlaceholder spTree)
+        else Nothing
+
+      getBooleanAttribute t e =
+        (`elem` ["1", "true"]) <$>
+          (findAttr (QName t Nothing Nothing) e)
+
+footerElements ::
+  PandocMonad m =>
+  (forall a. SlideLayoutsOf a -> a) ->
+  P m [Content]
+footerElements layout = do
+  footerInfo <- gets stFooterInfo
+  pure
+    $ Elem <$>
+      (toList (footerInfo >>= layout . fiDate)
+       <> toList (footerInfo >>= layout . fiFooter)
+       <> toList (footerInfo >>= layout . fiSlideNumber))
+
 makeSlideIdMap :: Presentation -> M.Map SlideId Int
 makeSlideIdMap (Presentation _ slides) =
   M.fromList $ map slideId slides `zip` [1..]
@@ -1372,13 +1431,14 @@ contentToElement layout hdrShape shapes
       (shapeId, element) <- nonBodyTextToElement layout [PHType "title"] hdrShape
       let hdrShapeElements = [Elem element | not (null hdrShape)]
           contentHeaderId = if null hdrShape then Nothing else shapeId
-      content <- local
+      content' <- local
                          (\env -> env {envPlaceholder = Placeholder ObjType 0})
                          (shapesToElements layout shapes)
-      let contentContentIds = mapMaybe fst content
-          contentElements = snd <$> content
+      let contentContentIds = mapMaybe fst content'
+          contentElements = snd <$> content'
+      footer <- footerElements content
       return ( Just ContentShapeIds{..}
-             , buildSpTree ns spTree (hdrShapeElements <> contentElements)
+             , buildSpTree ns spTree (hdrShapeElements <> contentElements <> footer)
              )
 contentToElement _ _ _ = return (Nothing, mknode "p:sp" [] ())
 
@@ -1412,10 +1472,11 @@ twoColumnToElement layout hdrShape shapesL shapesR
           contentElementsR = snd <$> contentR
       -- let contentElementsL' = map (setIdx ns "1") contentElementsL
       --     contentElementsR' = map (setIdx ns "2") contentElementsR
+      footer <- footerElements twoColumn
       return
         $ (Just TwoColumnShapeIds{..}, )
         $ buildSpTree ns spTree
-        $ hdrShapeElements <> contentElementsL <> contentElementsR
+        $ hdrShapeElements <> contentElementsL <> contentElementsR <> footer
 twoColumnToElement _ _ _ _ = return (Nothing, mknode "p:sp" [] ())
 
 data ComparisonShapeIds = ComparisonShapeIds
@@ -1456,6 +1517,7 @@ comparisonToElement layout hdrShape (shapesL1, shapesL2) (shapesR1, shapesR2)
                          (shapesToElements layout shapesR2)
       let comparisonRightContentIds = mapMaybe fst contentR2
           contentElementsR2 = snd <$> contentR2
+      footer <- footerElements comparison
       return
         $ (Just ComparisonShapeIds{..}, )
         $ buildSpTree ns spTree
@@ -1464,7 +1526,7 @@ comparisonToElement layout hdrShape (shapesL1, shapesL2) (shapesR1, shapesR2)
                   , contentElementsL2
                   , contentElementsR1
                   , contentElementsR2
-                  ]
+                  ] <> footer
 comparisonToElement _ _ _ _= return (Nothing, mknode "p:sp" [] ())
 
 data ContentWithCaptionShapeIds = ContentWithCaptionShapeIds
@@ -1495,13 +1557,14 @@ contentWithCaptionToElement layout hdrShape textShapes contentShapes
                        (shapesToElements layout contentShapes)
       let contentWithCaptionContentIds = mapMaybe fst content
           contentElements = snd <$> content
+      footer <- footerElements contentWithCaption
       return
         $ (Just ContentWithCaptionShapeIds{..}, )
         $ buildSpTree ns spTree
         $ mconcat [ hdrShapeElements
                   , textElements
                   , contentElements
-                  ]
+                  ] <> footer
 contentWithCaptionToElement _ _ _ _ = return (Nothing, mknode "p:sp" [] ())
 
 blankToElement ::
@@ -1511,8 +1574,8 @@ blankToElement ::
 blankToElement layout
   | ns <- elemToNameSpaces layout
   , Just cSld <- findChild (elemName ns "p" "cSld") layout
-  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
-      return $ buildSpTree ns spTree []
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld =
+      buildSpTree ns spTree <$> footerElements blank
 blankToElement _ = return $ mknode "p:sp" [] ()
 
 newtype TitleShapeIds = TitleShapeIds
@@ -1531,7 +1594,10 @@ titleToElement layout titleElems
       (shapeId, element) <- nonBodyTextToElement layout [PHType "title", PHType "ctrTitle"] titleElems
       let titleShapeElements = [Elem element | not (null titleElems)]
           titleHeaderId = if null titleElems then Nothing else shapeId
-      return $ (Just TitleShapeIds{..}, ) $ buildSpTree ns spTree titleShapeElements
+      footer <- footerElements title
+      return
+        $ (Just TitleShapeIds{..}, )
+        $ buildSpTree ns spTree (titleShapeElements <> footer)
 titleToElement _ _ = return (Nothing, mknode "p:sp" [] ())
 
 data MetadataShapeIds = MetadataShapeIds
@@ -1561,13 +1627,20 @@ metadataToElement layout titleElems subtitleElems authorsElems dateElems
           metadataTitleId = if null titleElems then Nothing else titleId
           subtitleShapeElements = [subtitleElement | not (null subtitleAndAuthorElems)]
           metadataSubtitleId = if null subtitleAndAuthorElems then Nothing else subtitleId
-          dateShapeElements = [dateElement | not (null dateElems)]
+      footerInfo <- gets stFooterInfo
+      footer <- (if maybe False fiShowOnFirstSlide footerInfo
+                 then id
+                 else const []) <$> footerElements metadata
+      let dateShapeElements = [dateElement
+                              | not (null dateElems
+                                || isJust (footerInfo >>= metadata . fiDate))
+                              ]
           metadataDateId = if null dateElems then Nothing else dateId
       return
         $ (Just MetadataShapeIds{..}, )
         $ buildSpTree ns spTree
-        $ map Elem
-        $ titleShapeElements <> subtitleShapeElements <> dateShapeElements
+        $ map Elem (titleShapeElements <> subtitleShapeElements <> dateShapeElements)
+        <> footer
 metadataToElement _ _ _ _ _ = return (Nothing, mknode "p:sp" [] ())
 
 slideToElement :: PandocMonad m => Slide -> P m Element