pptx: Add support for more layouts

Until now, the pptx writer only supported four slide layouts: “Title
Slide” (used for the automatically generated metadata slide), “Section
Header” (used for headings above the slide level), “Two Column” (used
when there’s a columns div containing at least two column divs), and
“Title and Content” (used for all other slides).

This commit adds support for three more layouts: Comparison, Content
with Caption, and Blank.

- Support “Comparison” slide layout

  This layout is used when a slide contains at least two columns, at
  least one of which contains some text followed by some non-text (e.g.
  an image or table). The text in each column is inserted into the
  “body” placeholder for that column, and the non-text is inserted into
  the ObjType placeholder. Any extra content after the non-text is
  overlaid on top of the preceding content, rather than dropping it
  completely (as currently happens for the two-column layout).

  + Accept straightforward test changes

    Adding the new layout means the “-deleted-layouts” tests have an
    additional layout added to the master and master rels.

  + Add new tests for the comparison layout
  + Add new tests to pandoc.cabal

- Support “Content with Caption” slide layout

  This layout is used when a slide’s body contains some text, followed by
  non-text (e.g. and image or a table). Before now, in this case the image
  or table would break onto a new slide: to get that output again, users
  can add a horizontal rule before the image or table.

  + Accept straightforward tests

    The “-deleted-layouts” tests all have an extra layout and relationship
    in the master for the Content with Caption layout.

  + Accept remove-empty-slides test

    Empty slides are still removed, but the Content with Caption layout is
    now used.

  + Change slide-level-0/h1-h2-with-text description

    This test now triggers the content with caption layout, giving a
    different (but still correct) result.

  + Add new tests for the new layout
  + Add new tests to the cabal file

- Support “Blank” slide layout

  This layout is used when a slide contains only blank content (e.g.
  non-breaking spaces). No content is inserted into any placeholders in
  the layout.

  Fixes #5097.

  + Accept straightforward test changes

    Blank layout now copied over from reference doc as well, when
    layouts have been deleted.

  + Add some new tests

    A slide should use the blank layout if:

    - It contains only speaker notes
    - It contains only an empty heading with a body of nbsps
    - It contains only a heading containing only nbsps

- Change ContentType -> Placeholder

  This type was starting to have a constructor for each placeholder on
  each slide (e.g. `ComparisonUpperLeftContent`). I’ve changed it
  instead to identify a placeholder by type and index, as I think that’s
  clearer and less redundant.

- Describe layout-choosing logic in manual

2 files changed, 313 insertions, 55 deletions

diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
index 0e6a67861..d83fb2182 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RecordWildCards #-}
 {- |
    Module      : Text.Pandoc.Writers.Powerpoint.Output
    Copyright   : Copyright (C) 2017-2020 Jesse Rosenthal
@@ -115,7 +116,7 @@ data WriterEnv = WriterEnv { envRefArchive :: Archive
                            -- the end of the slide file name and
                            -- the rId number
                            , envSlideIdOffset :: Int
-                           , envContentType :: ContentType
+                           , envPlaceholder :: Placeholder
                            , envSlideIdMap :: M.Map SlideId Int
                            -- maps the slide number to the
                            -- corresponding notes id number. If there
@@ -139,7 +140,7 @@ instance Default WriterEnv where
                   , envInNoteSlide = False
                   , envCurSlideId = 1
                   , envSlideIdOffset = 1
-                  , envContentType = NormalContent
+                  , envPlaceholder = Placeholder ObjType 0
                   , envSlideIdMap = mempty
                   , envSpeakerNotesIdMap = mempty
                   , envInSpeakerNotes = False
@@ -153,6 +154,9 @@ data SlideLayoutsOf a = SlideLayouts
   , title :: a
   , content :: a
   , twoColumn :: a
+  , comparison :: a
+  , contentWithCaption :: a
+  , blank :: a
   } deriving (Show, Functor, Foldable, Traversable)
 
 data SlideLayout = SlideLayout
@@ -170,10 +174,14 @@ getSlideLayouts = asks envSlideLayouts >>= maybe (throwError e) pure
     e = PandocSomeError ("Slide layouts aren't defined, even though they should "
       <> "always be. This is a bug in pandoc.")
 
-data ContentType = NormalContent
-                 | TwoColumnLeftContent
-                 | TwoColumnRightContent
-                 deriving (Show, Eq)
+-- | A placeholder within a layout, identified by type and index.
+--
+-- E.g., @Placeholder ObjType 2@ is the third placeholder of type 'ObjType' in
+-- the layout.
+data Placeholder = Placeholder
+  { placeholderType :: PHType
+  , index :: Int
+  } deriving (Show, Eq)
 
 data MediaInfo = MediaInfo { mInfoFilePath :: FilePath
                            , mInfoLocalId  :: Int
@@ -446,6 +454,9 @@ presentationToArchive opts meta pres = do
                                   , title = "Section Header"
                                   , content = "Title and Content"
                                   , twoColumn = "Two Content"
+                                  , comparison = "Comparison"
+                                  , contentWithCaption = "Content with Caption"
+                                  , blank = "Blank"
                                   }
   layouts <- for layoutTitles $ \layoutTitle -> do
         let layout = M.lookup (CI.mk layoutTitle) referenceLayouts
@@ -550,10 +561,13 @@ getLayout layout = getElement <$> getSlideLayouts
   where
     getElement =
       slElement . case layout of
-        MetadataSlide{}  -> metadata
-        TitleSlide{}     -> title
-        ContentSlide{}   -> content
-        TwoColumnSlide{} -> twoColumn
+        MetadataSlide{}           -> metadata
+        TitleSlide{}              -> title
+        ContentSlide{}            -> content
+        TwoColumnSlide{}          -> twoColumn
+        ComparisonSlide{}         -> comparison
+        ContentWithCaptionSlide{} -> contentWithCaption
+        BlankSlide{}              -> blank
 
 shapeHasId :: NameSpaces -> T.Text -> Element -> Bool
 shapeHasId ns ident element
@@ -566,17 +580,31 @@ shapeHasId ns ident element
 getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element
 getContentShape ns spTreeElem
   | isElem ns "p" "spTree" spTreeElem = do
-      contentType <- asks envContentType
-      let contentShapes = getShapesByPlaceHolderType ns spTreeElem ObjType
-      case contentType of
-        NormalContent | (sp : _) <- contentShapes -> return sp
-        TwoColumnLeftContent | (sp : _) <- contentShapes -> return sp
-        TwoColumnRightContent | (_ : sp : _) <- contentShapes -> return sp
-        _ -> throwError $ PandocSomeError
-             "Could not find shape for Powerpoint content"
+      ph@Placeholder{..} <- asks envPlaceholder
+      case drop index (getShapesByPlaceHolderType ns spTreeElem placeholderType) of
+        sp : _ -> return sp
+        [] -> throwError $ PandocSomeError $ missingPlaceholderMessage ph
 getContentShape _ _ = throwError $ PandocSomeError
                       "Attempted to find content on non shapeTree"
 
+missingPlaceholderMessage :: Placeholder -> Text
+missingPlaceholderMessage Placeholder{..} =
+  "Could not find a " <> ordinal
+  <> " placeholder of type " <> placeholderText
+  where
+    ordinal = T.pack (show index) <>
+      case (index `mod` 100, index `mod` 10) of
+        (11, _) -> "th"
+        (12, _) -> "th"
+        (13, _) -> "th"
+        (_,  1) -> "st"
+        (_,  2) -> "nd"
+        (_,  3) -> "rd"
+        _       -> "th"
+    placeholderText = case placeholderType of
+      ObjType -> "obj (or nothing)"
+      PHType t -> t
+
 getShapeDimensions :: NameSpaces
                    -> Element
                    -> Maybe ((Integer, Integer), (Integer, Integer))
@@ -1302,7 +1330,7 @@ contentToElement layout hdrShape shapes
       element <- nonBodyTextToElement layout [PHType "title"] hdrShape
       let hdrShapeElements = [Elem element | not (null hdrShape)]
       contentElements <- local
-                         (\env -> env {envContentType = NormalContent})
+                         (\env -> env {envPlaceholder = Placeholder ObjType 0})
                          (shapesToElements layout shapes)
       return $ buildSpTree ns spTree (hdrShapeElements <> contentElements)
 contentToElement _ _ _ = return $ mknode "p:sp" [] ()
@@ -1315,10 +1343,10 @@ twoColumnToElement layout hdrShape shapesL shapesR
       element <- nonBodyTextToElement layout [PHType "title"] hdrShape
       let hdrShapeElements = [Elem element | not (null hdrShape)]
       contentElementsL <- local
-                          (\env -> env {envContentType =TwoColumnLeftContent})
+                          (\env -> env {envPlaceholder = Placeholder ObjType 0})
                           (shapesToElements layout shapesL)
       contentElementsR <- local
-                          (\env -> env {envContentType =TwoColumnRightContent})
+                          (\env -> env {envPlaceholder = Placeholder ObjType 1})
                           (shapesToElements layout shapesR)
       -- let contentElementsL' = map (setIdx ns "1") contentElementsL
       --     contentElementsR' = map (setIdx ns "2") contentElementsR
@@ -1326,6 +1354,76 @@ twoColumnToElement layout hdrShape shapesL shapesR
         hdrShapeElements <> contentElementsL <> contentElementsR
 twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] ()
 
+comparisonToElement ::
+  PandocMonad m =>
+  Element ->
+  [ParaElem] ->
+  ([Shape], [Shape]) ->
+  ([Shape], [Shape]) ->
+  P m Element
+comparisonToElement layout hdrShape (shapesL1, shapesL2) (shapesR1, shapesR2)
+  | ns <- elemToNameSpaces layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
+      element <- nonBodyTextToElement layout [PHType "title"] hdrShape
+      let hdrShapeElements = [Elem element | not (null hdrShape)]
+      contentElementsL1 <- local
+                          (\env -> env {envPlaceholder = Placeholder (PHType "body") 0})
+                          (shapesToElements layout shapesL1)
+      contentElementsL2 <- local
+                          (\env -> env {envPlaceholder = Placeholder ObjType 0})
+                          (shapesToElements layout shapesL2)
+      contentElementsR1 <- local
+                          (\env -> env {envPlaceholder = Placeholder (PHType "body") 1})
+                          (shapesToElements layout shapesR1)
+      contentElementsR2 <- local
+                          (\env -> env {envPlaceholder = Placeholder ObjType 1})
+                          (shapesToElements layout shapesR2)
+      return $ buildSpTree ns spTree $
+        mconcat [ hdrShapeElements
+                , contentElementsL1
+                , contentElementsL2
+                , contentElementsR1
+                , contentElementsR2
+                ]
+comparisonToElement _ _ _ _= return $ mknode "p:sp" [] ()
+
+contentWithCaptionToElement ::
+  PandocMonad m =>
+  Element ->
+  [ParaElem] ->
+  [Shape] ->
+  [Shape] ->
+  P m Element
+contentWithCaptionToElement layout hdrShape textShapes contentShapes
+  | ns <- elemToNameSpaces layout
+  , Just cSld <- findChild (elemName ns "p" "cSld") layout
+  , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
+      element <- nonBodyTextToElement layout [PHType "title"] hdrShape
+      let hdrShapeElements = [Elem element | not (null hdrShape)]
+      textElements <- local
+                       (\env -> env {envPlaceholder = Placeholder (PHType "body") 0})
+                       (shapesToElements layout textShapes)
+      contentElements <- local
+                          (\env -> env {envPlaceholder = Placeholder ObjType 0})
+                          (shapesToElements layout contentShapes)
+      return $ buildSpTree ns spTree $
+        mconcat [ hdrShapeElements
+                , textElements
+                , contentElements
+                ]
+contentWithCaptionToElement _ _ _ _ = return $ mknode "p:sp" [] ()
+
+blankToElement ::
+  PandocMonad m =>
+  Element ->
+  P m Element
+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 []
+blankToElement _ = return $ mknode "p:sp" [] ()
 
 titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element
 titleToElement layout titleElems
@@ -1380,6 +1478,17 @@ slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do
       ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
       ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
     ] [mknode "p:cSld" [] [spTree]]
+slideToElement (Slide _ l@(ComparisonSlide hdrElems shapesL shapesR) _) = do
+  layout <- getLayout l
+  spTree <- local (\env -> if null hdrElems
+                           then env
+                           else env{envSlideHasHeader=True}) $
+            comparisonToElement layout hdrElems shapesL shapesR
+  return $ mknode "p:sld"
+    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
+      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
+      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
+    ] [mknode "p:cSld" [] [spTree]]
 slideToElement (Slide _ l@(TitleSlide hdrElems) _) = do
   layout <- getLayout l
   spTree <- titleToElement layout hdrElems
@@ -1396,7 +1505,22 @@ slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems da
       ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
       ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
     ] [mknode "p:cSld" [] [spTree]]
-
+slideToElement (Slide _ l@(ContentWithCaptionSlide hdrElems captionShapes contentShapes) _) = do
+  layout <- getLayout l
+  spTree <- contentWithCaptionToElement layout hdrElems captionShapes contentShapes
+  return $ mknode "p:sld"
+    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
+      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
+      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
+    ] [mknode "p:cSld" [] [spTree]]
+slideToElement (Slide _ BlankSlide _) = do
+  layout <- getLayout BlankSlide
+  spTree <- blankToElement layout
+  return $ mknode "p:sld"
+    [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
+      ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
+      ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
+    ] [mknode "p:cSld" [] [spTree]]
 
 --------------------------------------------------------------------
 -- Notes:
@@ -1800,10 +1924,13 @@ slideToSlideRelElement slide = do
   target <- flip fmap getSlideLayouts $
     T.pack . ("../slideLayouts/" <>) . takeFileName .
     slPath . case slide of
-        (Slide _ MetadataSlide{} _)  -> metadata
-        (Slide _ TitleSlide{} _)     -> title
-        (Slide _ ContentSlide{} _)   -> content
-        (Slide _ TwoColumnSlide{} _) -> twoColumn
+        (Slide _ MetadataSlide{} _)           -> metadata
+        (Slide _ TitleSlide{} _)              -> title
+        (Slide _ ContentSlide{} _)            -> content
+        (Slide _ TwoColumnSlide{} _)          -> twoColumn
+        (Slide _ ComparisonSlide{} _)         -> comparison
+        (Slide _ ContentWithCaptionSlide{} _) -> contentWithCaption
+        (Slide _ BlankSlide _)                -> blank
 
   speakerNotesRels <- maybeToList <$> speakerNotesSlideRelElement slide
 
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
index 284b9ae62..10060d975 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE PatternGuards              #-}
 {-# LANGUAGE ViewPatterns               #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {- |
    Module      : Text.Pandoc.Writers.Powerpoint.Presentation
    Copyright   : Copyright (C) 2017-2020 Jesse Rosenthal
@@ -61,11 +62,13 @@ import Text.Pandoc.Writers.Shared (lookupMetaInlines, lookupMetaBlocks
                                  , toLegacyTable)
 import qualified Data.Map as M
 import qualified Data.Set as S
-import Data.Maybe (maybeToList, fromMaybe)
+import Data.Maybe (maybeToList, fromMaybe, listToMaybe)
 import Text.Pandoc.Highlighting
 import qualified Data.Text as T
 import Control.Applicative ((<|>))
 import Skylighting
+import Data.Bifunctor (bimap)
+import Data.Char (isSpace)
 
 data WriterEnv = WriterEnv { envMetadata :: Meta
                            , envRunProps :: RunProps
@@ -195,6 +198,11 @@ data Layout = MetadataSlide [ParaElem] [ParaElem] [[ParaElem]] [ParaElem]
             --             heading    content
             | TwoColumnSlide [ParaElem] [Shape] [Shape]
             --               heading    left    right
+            | ComparisonSlide [ParaElem] ([Shape], [Shape]) ([Shape], [Shape])
+            --                heading  left@(text, content) right@(text, content)
+            | ContentWithCaptionSlide [ParaElem] [Shape] [Shape]
+            --                   heading     text    content
+            | BlankSlide
             deriving (Show, Eq)
 
 data Shape = Pic PicProps FilePath T.Text [ParaElem]
@@ -584,7 +592,30 @@ isImage Image{} = True
 isImage (Link _ (Image{} : _) _) = True
 isImage _ = False
 
-splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[Block]]
+plainOrPara :: Block -> Maybe [Inline]
+plainOrPara (Plain ils) = Just ils
+plainOrPara (Para ils) = Just ils
+plainOrPara _ = Nothing
+
+notText :: Block -> Bool
+notText block | startsWithImage block = True
+notText Table{} = True
+notText _ = False
+
+startsWithImage :: Block -> Bool
+startsWithImage block = fromMaybe False $ do
+  inline <- plainOrPara block >>= listToMaybe
+  pure (isImage inline)
+
+-- | Group blocks into a number of "splits"
+splitBlocks' ::
+  -- | Blocks so far in the current split
+  [Block] ->
+  -- | Splits so far
+  [[Block]] ->
+  -- | All remaining blocks
+  [Block] ->
+  Pres [[Block]]
 splitBlocks' cur acc [] = return $ acc ++ ([cur | not (null cur)])
 splitBlocks' cur acc (HorizontalRule : blks) =
   splitBlocks' [] (acc ++ ([cur | not (null cur)])) blks
@@ -609,7 +640,9 @@ splitBlocks' cur acc (Para (il:ils) : blks) | isImage il = do
                             (acc ++ [cur ++ [Para [il]] ++ nts])
                             (if null ils then blks' else Para ils : blks')
     _ -> splitBlocks' []
-         (acc ++ ([cur | not (null cur)]) ++ [Para [il] : nts])
+         (if any notText cur
+          then acc ++ ([cur | not (null cur)]) ++ [Para [il] : nts]
+          else acc ++ [cur ++ [Para [il]] ++ nts])
          (if null ils then blks' else Para ils : blks')
 splitBlocks' cur acc (tbl@Table{} : blks) = do
   slideLevel <- asks envSlideLevel
@@ -617,7 +650,11 @@ splitBlocks' cur acc (tbl@Table{} : blks) = do
   case cur of
     [Header n _ _] | n == slideLevel || slideLevel == 0 ->
                             splitBlocks' [] (acc ++ [cur ++ [tbl] ++ nts]) blks'
-    _ ->  splitBlocks' [] (acc ++ ([cur | not (null cur)]) ++ [tbl : nts]) blks'
+    _ -> splitBlocks' []
+         (if any notText cur
+          then acc ++ ([cur | not (null cur)]) ++ [tbl : nts]
+          else acc ++ ([cur ++ [tbl] ++ nts]))
+         blks'
 splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes =  do
   slideLevel <- asks envSlideLevel
   let (nts, blks') = span isNotesDiv blks
@@ -639,38 +676,56 @@ bodyBlocksToSlide _ (blk : blks) spkNotes
   , Div (_, clsL, _) blksL : Div (_, clsR, _) blksR : remaining <- divBlks
   , "column" `elem` clsL, "column" `elem` clsR = do
       mapM_ (addLogMessage . BlockNotRendered) (blks ++ remaining)
-      mbSplitBlksL <- splitBlocks blksL
-      mbSplitBlksR <- splitBlocks blksR
-      let blksL' = case mbSplitBlksL of
-            bs : _ -> bs
-            []     -> []
-      let blksR' = case mbSplitBlksR of
-            bs : _ -> bs
-            []     -> []
-      shapesL <- blocksToShapes blksL'
-      shapesR <- blocksToShapes blksR'
-      sldId <- asks envCurSlideId
-      return $ Slide
-        sldId
-        (TwoColumnSlide [] shapesL shapesR)
-        spkNotes
+      let mkTwoColumn left right = do
+            blksL' <- join . take 1 <$> splitBlocks left
+            blksR' <- join . take 1 <$> splitBlocks right
+            shapesL <- blocksToShapes blksL'
+            shapesR <- blocksToShapes blksR'
+            sldId <- asks envCurSlideId
+            return $ Slide
+              sldId
+              (TwoColumnSlide [] shapesL shapesR)
+              spkNotes
+      let mkComparison blksL1  blksL2 blksR1 blksR2 = do
+            shapesL1 <- blocksToShapes blksL1
+            shapesL2 <- blocksToShapes blksL2
+            shapesR1 <- blocksToShapes blksR1
+            shapesR2 <- blocksToShapes blksR2
+            sldId <- asks envCurSlideId
+            return $ Slide
+              sldId
+              (ComparisonSlide [] (shapesL1, shapesL2) (shapesR1, shapesR2))
+              spkNotes
+      case (break notText blksL, break notText blksR) of
+        ((_, []), (_, [])) -> mkTwoColumn blksL blksR
+        (([], _), ([], _)) -> mkTwoColumn blksL blksR
+        ((blksL1, blksL2), (blksR1, blksR2)) -> mkComparison blksL1 blksL2 blksR1 blksR2
 bodyBlocksToSlide _ (blk : blks) spkNotes = do
-      inNoteSlide <- asks envInNoteSlide
-      shapes <- if inNoteSlide
-                then forceFontSize noteSize $ blocksToShapes (blk : blks)
-                else blocksToShapes (blk : blks)
       sldId <- asks envCurSlideId
-      return $
-        Slide
-        sldId
-        (ContentSlide [] shapes)
-        spkNotes
+      inNoteSlide <- asks envInNoteSlide
+      let mkSlide s =
+            Slide sldId s spkNotes
+      if inNoteSlide
+      then mkSlide . ContentSlide [] <$>
+          forceFontSize noteSize (blocksToShapes (blk : blks))
+      else let
+        contentOrBlankSlide =
+          if makesBlankSlide (blk : blks)
+          then pure (mkSlide BlankSlide)
+          else mkSlide . ContentSlide [] <$> blocksToShapes (blk : blks)
+        in case break notText (blk : blks) of
+          ([], _) -> contentOrBlankSlide
+          (_, []) -> contentOrBlankSlide
+          (textBlocks, contentBlocks) -> do
+            textShapes <- blocksToShapes textBlocks
+            contentShapes <- blocksToShapes contentBlocks
+            return (mkSlide (ContentWithCaptionSlide [] textShapes contentShapes))
 bodyBlocksToSlide _ [] spkNotes = do
   sldId <- asks envCurSlideId
   return $
     Slide
     sldId
-    (ContentSlide [] [])
+    BlankSlide
     spkNotes
 
 blocksToSlide' :: Int -> [Block] -> SpeakerNotes -> Pres Slide
@@ -689,6 +744,9 @@ blocksToSlide' lvl (Header n (ident, _, _) ils : blks) spkNotes
       let layout = case slideLayout slide of
             ContentSlide _ cont          -> ContentSlide hdr cont
             TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR
+            ComparisonSlide _ contL contR -> ComparisonSlide hdr contL contR
+            ContentWithCaptionSlide _ text content -> ContentWithCaptionSlide hdr text content
+            BlankSlide -> if all inlineIsBlank ils then BlankSlide else ContentSlide hdr []
             layout'                     -> layout'
       return $ slide{slideLayout = layout}
 blocksToSlide' lvl blks spkNotes = bodyBlocksToSlide lvl blks spkNotes
@@ -834,6 +892,19 @@ applyToLayout f (TwoColumnSlide hdr contentL contentR) = do
   contentL' <- mapM (applyToShape f) contentL
   contentR' <- mapM (applyToShape f) contentR
   return $ TwoColumnSlide hdr' contentL' contentR'
+applyToLayout f (ComparisonSlide hdr (contentL1, contentL2) (contentR1, contentR2)) = do
+  hdr' <- mapM f hdr
+  contentL1' <- mapM (applyToShape f) contentL1
+  contentL2' <- mapM (applyToShape f) contentL2
+  contentR1' <- mapM (applyToShape f) contentR1
+  contentR2' <- mapM (applyToShape f) contentR2
+  return $ ComparisonSlide hdr' (contentL1', contentL2') (contentR1', contentR2')
+applyToLayout f (ContentWithCaptionSlide hdr textShapes contentShapes) = do
+  hdr' <- mapM f hdr
+  textShapes' <- mapM (applyToShape f) textShapes
+  contentShapes' <- mapM (applyToShape f) contentShapes
+  return $ ContentWithCaptionSlide hdr' textShapes' contentShapes'
+applyToLayout _ BlankSlide = pure BlankSlide
 
 applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide
 applyToSlide f slide = do
@@ -885,10 +956,70 @@ emptyLayout layout = case layout of
     all emptyParaElem hdr &&
     all emptyShape shapes1 &&
     all emptyShape shapes2
+  ComparisonSlide hdr (shapesL1, shapesL2) (shapesR1, shapesR2) ->
+    all emptyParaElem hdr &&
+    all emptyShape shapesL1 &&
+    all emptyShape shapesL2 &&
+    all emptyShape shapesR1 &&
+    all emptyShape shapesR2
+  ContentWithCaptionSlide hdr textShapes contentShapes ->
+    all emptyParaElem hdr &&
+    all emptyShape textShapes &&
+    all emptyShape contentShapes
+  BlankSlide -> False
+
 
 emptySlide :: Slide -> Bool
 emptySlide (Slide _ layout notes) = (notes == mempty) && emptyLayout layout
 
+makesBlankSlide :: [Block] -> Bool
+makesBlankSlide = all blockIsBlank
+
+blockIsBlank :: Block -> Bool
+blockIsBlank
+  = \case
+      Plain ins -> all inlineIsBlank ins
+      Para ins -> all inlineIsBlank ins
+      LineBlock inss -> all (all inlineIsBlank) inss
+      CodeBlock _ txt -> textIsBlank txt
+      RawBlock _ txt -> textIsBlank txt
+      BlockQuote bls -> all blockIsBlank bls
+      OrderedList _ blss -> all (all blockIsBlank) blss
+      BulletList blss -> all (all blockIsBlank) blss
+      DefinitionList ds -> all (uncurry (&&) . bimap (all inlineIsBlank) (all (all blockIsBlank))) ds
+      Header _ _ ils -> all inlineIsBlank ils
+      HorizontalRule -> True
+      Table{} -> False
+      Div _ bls -> all blockIsBlank bls
+      Null -> True
+
+textIsBlank :: T.Text -> Bool
+textIsBlank = T.all isSpace
+
+inlineIsBlank :: Inline -> Bool
+inlineIsBlank
+  = \case
+      (Str txt) -> textIsBlank txt
+      (Emph ins) -> all inlineIsBlank ins
+      (Underline ins) -> all inlineIsBlank ins
+      (Strong ins) -> all inlineIsBlank ins
+      (Strikeout ins) -> all inlineIsBlank ins
+      (Superscript ins) -> all inlineIsBlank ins
+      (Subscript ins) -> all inlineIsBlank ins
+      (SmallCaps ins) -> all inlineIsBlank ins
+      (Quoted _ ins) -> all inlineIsBlank ins
+      (Cite _ _) -> False
+      (Code _ txt) -> textIsBlank txt
+      Space -> True
+      SoftBreak -> True
+      LineBreak -> True
+      (Math _ txt) -> textIsBlank txt
+      (RawInline _ txt) -> textIsBlank txt
+      (Link _ ins (t1, t2)) -> all inlineIsBlank ins && textIsBlank t1 && textIsBlank t2
+      (Image _ ins (t1, t2)) -> all inlineIsBlank ins && textIsBlank t1 && textIsBlank t2
+      (Note bls) -> all blockIsBlank bls
+      (Span _ ins) -> all inlineIsBlank ins
+
 blocksToPresentationSlides :: [Block] -> Pres [Slide]
 blocksToPresentationSlides blks = do
   opts <- asks envOpts