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

MANUAL.txt

@@ -1182,11 +1182,15 @@ header when requesting a document from a URL:
         - Title and Content
         - Section Header
         - Two Content
+        - Comparison
+        - Content with Caption
+        - Blank
 
         For each name, the first layout found with that name will be used.
         If no layout is found with one of the names, pandoc will output a
         warning and use the layout with that name from the default reference
-        doc instead.
+        doc instead. (How these layouts are used is described in [PowerPoint
+        layout choice](#powerpoint-layout-choice).)
 
         All templates included with a recent version of MS PowerPoint
         will fit these criteria. (You can click on `Layout` under the
@@ -1195,8 +1199,8 @@ header when requesting a document from a URL:
         You can also modify the default `reference.pptx`: first run
         `pandoc -o custom-reference.pptx --print-default-data-file
         reference.pptx`, and then modify `custom-reference.pptx`
-        in MS PowerPoint (pandoc will use the first four layout
-        slides, as mentioned above).
+        in MS PowerPoint (pandoc will use the layouts with the names
+        listed above).
 
 `--epub-cover-image=`*FILE*
 
@@ -5833,6 +5837,48 @@ you use deeper nesting of section levels with reveal.js unless you set
 `--slide-level=0` (which lets reveal.js produce a one-dimensional layout
 and only interprets horizontal rules as slide boundaries).
 
+### PowerPoint layout choice
+
+When creating slides, the pptx writer chooses from a number of pre-defined
+layouts, based on the content of the slide:
+
+Title Slide
+:   This layout is used for the initial slide, which is generated and
+    filled from the metadata fields `date`, `author`, and `title`, if
+    they are present.
+
+Section Header
+:   This layout is used for what pandoc calls “title slides”, i.e.
+    slides which start with a header which is above the slide level in
+    the hierarchy.
+
+Two Content
+:   This layout is used for two-column slides, i.e. slides containing a
+    div with class `columns` which contains at least two divs with class
+    `column`.
+
+Comparison
+:   This layout is used instead of “Two Content” for any two-column
+    slides in which at least one column contains text followed by
+    non-text (e.g. an image or a table).
+
+Content with Caption
+:   This layout is used for any non-two-column slides which contain text
+    followed by non-text (e.g. an image or a table).
+
+Blank
+:   This layout is used for any slides which only contain blank content,
+    e.g. a slide containing only speaker notes, or a slide containing
+    only a non-breaking space.
+
+Title and Content
+:   This layout is used for all slides which do not match the criteria
+    for another layout.
+
+These layouts are chosen from the default pptx reference doc included with
+pandoc, unless an alternative reference doc is specified using
+`--reference-doc`.
+
 ## Incremental lists
 
 By default, these writers produce lists that display "all at once."

pandoc.cabal

@@ -380,17 +380,31 @@ extra-source-files:
                  test/rtf/*.native
                  test/rtf/*.rtf
                  test/pptx/*.pptx
+                 test/pptx/blanks/just-speaker-notes/input.native
+                 test/pptx/blanks/just-speaker-notes/*.pptx
+                 test/pptx/blanks/nbsp-in-body/input.native
+                 test/pptx/blanks/nbsp-in-body/*.pptx
+                 test/pptx/blanks/nbsp-in-heading/input.native
+                 test/pptx/blanks/nbsp-in-heading/*.pptx
                  test/pptx/code-custom/*.pptx
                  test/pptx/code/input.native
                  test/pptx/code/*.pptx
-                 test/pptx/comparison-both-columns/input.native
-                 test/pptx/comparison-both-columns/*.pptx
-                 test/pptx/comparison-extra-text/input.native
-                 test/pptx/comparison-extra-text/*.pptx
-                 test/pptx/comparison-non-text-first/input.native
-                 test/pptx/comparison-non-text-first/*.pptx
-                 test/pptx/comparison-one-column/input.native
-                 test/pptx/comparison-one-column/*.pptx
+                 test/pptx/content-with-caption/heading-text-image/input.native
+                 test/pptx/content-with-caption/heading-text-image/*.pptx
+                 test/pptx/content-with-caption/image-text/input.native
+                 test/pptx/content-with-caption/image-text/*.pptx
+                 test/pptx/content-with-caption/text-image/input.native
+                 test/pptx/content-with-caption/text-image/*.pptx
+                 test/pptx/comparison/both-columns/input.native
+                 test/pptx/comparison/both-columns/*.pptx
+                 test/pptx/comparison/extra-image/input.native
+                 test/pptx/comparison/extra-image/*.pptx
+                 test/pptx/comparison/extra-text/input.native
+                 test/pptx/comparison/extra-text/*.pptx
+                 test/pptx/comparison/non-text-first/input.native
+                 test/pptx/comparison/non-text-first/*.pptx
+                 test/pptx/comparison/one-column/input.native
+                 test/pptx/comparison/one-column/*.pptx
                  test/pptx/document-properties-short-desc/input.native
                  test/pptx/document-properties-short-desc/*.pptx
                  test/pptx/document-properties/input.native

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
@@ -554,6 +565,9 @@ getLayout layout = getElement <$> getSlideLayouts
         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:
@@ -1804,6 +1928,9 @@ slideToSlideRelElement slide = do
         (Slide _ TitleSlide{} _)              -> title
         (Slide _ ContentSlide{} _)            -> content
         (Slide _ TwoColumnSlide{} _)          -> twoColumn
+        (Slide _ ComparisonSlide{} _)         -> comparison
+        (Slide _ ContentWithCaptionSlide{} _) -> contentWithCaption
+        (Slide _ BlankSlide _)                -> blank
 
   speakerNotesRels <- maybeToList <$> speakerNotesSlideRelElement slide
 

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,14 +676,9 @@ 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
-            []     -> []
+      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
@@ -654,23 +686,46 @@ bodyBlocksToSlide _ (blk : blks) spkNotes
               sldId
               (TwoColumnSlide [] shapesL shapesR)
               spkNotes
-bodyBlocksToSlide _ (blk : blks) spkNotes = do
-      inNoteSlide <- asks envInNoteSlide
-      shapes <- if inNoteSlide
-                then forceFontSize noteSize $ blocksToShapes (blk : blks)
-                else blocksToShapes (blk : blks)
+      let mkComparison blksL1  blksL2 blksR1 blksR2 = do
+            shapesL1 <- blocksToShapes blksL1
+            shapesL2 <- blocksToShapes blksL2
+            shapesR1 <- blocksToShapes blksR1
+            shapesR2 <- blocksToShapes blksR2
             sldId <- asks envCurSlideId
-      return $
-        Slide
+            return $ Slide
               sldId
-        (ContentSlide [] shapes)
+              (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
+      sldId <- asks envCurSlideId
+      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

test/Tests/Writers/Powerpoint.hs

@@ -166,9 +166,66 @@ tests = groupPptxTests [ pptxTests "Inline formatting"
                          "pptx/slide-level-0/h1-with-table/output.pptx"
                        , pptxTests ("Using slide level 0, if the first thing on "
                                     <> "a slide is a heading it's used as the "
-                                    <> "slide title (two headings forces a "
-                                    <> "slide break though)")
+                                    <> "slide title (content with caption layout)")
                          def { writerSlideLevel = Just 0 }
                          "pptx/slide-level-0/h1-h2-with-table/input.native"
                          "pptx/slide-level-0/h1-h2-with-table/output.pptx"
+                       , pptxTests ("comparison layout used when two columns "
+                                    <> "contain text plus non-text")
+                         def
+                         "pptx/comparison/both-columns/input.native"
+                         "pptx/comparison/both-columns/output.pptx"
+                       , pptxTests ("comparison layout used even when only one "
+                                    <> "column contains text plus non-text")
+                         def
+                         "pptx/comparison/one-column/input.native"
+                         "pptx/comparison/one-column/output.pptx"
+                       , pptxTests ("extra text in one column in comparison "
+                                    <> "layout gets overlaid")
+                         def
+                         "pptx/comparison/extra-text/input.native"
+                         "pptx/comparison/extra-text/output.pptx"
+                       , pptxTests ("extra image in one column in comparison "
+                                   <> "layout gets overlaid")
+                         def
+                         "pptx/comparison/extra-image/input.native"
+                         "pptx/comparison/extra-image/output.pptx"
+                       , pptxTests "comparison not used if the non-text comes first"
+                         def
+                         "pptx/comparison/non-text-first/input.native"
+                         "pptx/comparison/non-text-first/output.pptx"
+                       , pptxTests ("Heading, text and an image on the same "
+                                    <> "slide uses the Content with Caption "
+                                    <> "layout")
+                         def
+                         "pptx/content-with-caption/heading-text-image/input.native"
+                         "pptx/content-with-caption/heading-text-image/output.pptx"
+                       , pptxTests ("Text and an image on the same "
+                                    <> "slide uses the Content with Caption "
+                                    <> "layout")
+                         def
+                         "pptx/content-with-caption/text-image/input.native"
+                         "pptx/content-with-caption/text-image/output.pptx"
+                       , pptxTests ("If the image comes first, Content with "
+                                    <> "Caption is not used")
+                         def
+                         "pptx/content-with-caption/image-text/input.native"
+                         "pptx/content-with-caption/image-text/output.pptx"
+                       , pptxTests ("If a slide contains only speaker notes, the "
+                                    <> "Blank layout is used")
+                         def
+                         "pptx/blanks/just-speaker-notes/input.native"
+                         "pptx/blanks/just-speaker-notes/output.pptx"
+                       , pptxTests ("If a slide contains only an empty heading "
+                                    <> "with a body of only non-breaking spaces"
+                                    <> ", the Blank layout is used")
+                         def
+                         "pptx/blanks/nbsp-in-body/input.native"
+                         "pptx/blanks/nbsp-in-body/output.pptx"
+                       , pptxTests ("If a slide contains only a heading "
+                                    <> "containing only non-breaking spaces, "
+                                    <> "the Blank layout is used")
+                         def
+                         "pptx/blanks/nbsp-in-heading/input.native"
+                         "pptx/blanks/nbsp-in-heading/output.pptx"
                        ]

test/pptx/blanks/just-speaker-notes/input.native

@@ -0,0 +1,7 @@
+[Header 1 ("first-slide",[],[]) [Str "First",Space,Str "slide"]
+,Para [Str "Nothing",Space,Str "to",Space,Str "see",Space,Str "here"]
+,Header 1 ("section",[],[]) []
+,Div ("",["notes"],[])
+ [Para [Str "Some",Space,Str "notes",Space,Str "here:",Space,Str "this",Space,Str "first",Space,Str "slide",Space,Str "should",Space,Str "use",Space,Str "the",Space,Str "Blank",Space,Str "template"]]
+,Header 1 ("third-slide",[],[]) [Str "Third",Space,Str "slide"]
+,Para [Str "The",Space,Str "second",Space,Str "slide",Space,Str "should",Space,Str "be",Space,Str "blank"]]

test/pptx/blanks/nbsp-in-body/input.native

@@ -0,0 +1,6 @@
+[Header 1 ("first-slide",[],[]) [Str "First",Space,Str "slide"]
+,Para [Str "Uninteresting,",Space,Str "normal"]
+,Header 1 ("section",[],[]) []
+,Para [Str "\160"]
+,Header 1 ("third-slide",[],[]) [Str "Third",Space,Str "slide"]
+,Para [Str "Was",Space,Str "the",Space,Str "previous",Space,Str "one",Space,Str "blank?"]]

test/pptx/blanks/nbsp-in-heading/input.native

@@ -0,0 +1,5 @@
+[Header 1 ("first-slide",[],[]) [Str "First",Space,Str "slide"]
+,Para [Str "Uninteresting,",Space,Str "normal"]
+,Header 1 ("section",[],[]) [Str "\160"]
+,Header 1 ("third-slide",[],[]) [Str "Third",Space,Str "slide"]
+,Para [Str "Was",Space,Str "the",Space,Str "previous",Space,Str "one",Space,Str "blank?"]]

test/pptx/comparison/both-columns/input.native

@@ -0,0 +1,23 @@
+[Header 1 ("a-slide",[],[]) [Str "A",Space,Str "slide"]
+,Div ("",["columns"],[])
+ [Div ("",["column"],[])
+  [Para [Str "A",Space,Str "paragraph",Space,Str "here"]
+  ,Table ("",[],[]) (Caption Nothing
+   [])
+   [(AlignDefault,ColWidth 0.125)
+   ,(AlignDefault,ColWidth 0.125)]
+   (TableHead ("",[],[])
+   [])
+   [(TableBody ("",[],[]) (RowHeadColumns 0)
+    []
+    [Row ("",[],[])
+     [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "plus"]]
+     ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "a",Space,Str "table"]]]])]
+   (TableFoot ("",[],[])
+   [])
+  ,Para [Str "Then",Space,Str "some",Space,Str "more",Space,Str "text"]]
+ ,Div ("",["column"],[])
+  [Para [Str "A",Space,Str "paragraph",Space,Str "here"]
+  ,Para [Image ("",[],[]) [Str "Plus",Space,Str "an",Space,Str "image"] ("lalune.jpg","fig:")]]]]

test/pptx/comparison/extra-image/input.native

@@ -0,0 +1,24 @@
+[Header 1 ("a-slide",[],[]) [Str "A",Space,Str "slide"]
+,Div ("",["columns"],[])
+ [Div ("",["column"],[])
+  [Para [Str "A",Space,Str "paragraph",Space,Str "here"]
+  ,Table ("",[],[]) (Caption Nothing
+   [])
+   [(AlignDefault,ColWidth 0.125)
+   ,(AlignDefault,ColWidth 0.125)]
+   (TableHead ("",[],[])
+   [])
+   [(TableBody ("",[],[]) (RowHeadColumns 0)
+    []
+    [Row ("",[],[])
+     [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "plus"]]
+     ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "a",Space,Str "table"]]]])]
+   (TableFoot ("",[],[])
+   [])
+  ,Para [Str "Then",Space,Str "some",Space,Str "more",Space,Str "text"]]
+ ,Div ("",["column"],[])
+  [Para [Str "A",Space,Str "paragraph",Space,Str "here"]
+  ,Para [Image ("",[],[]) [Str "Plus",Space,Str "an",Space,Str "image"] ("lalune.jpg","fig:")]
+  ,Para [Image ("",[],[]) [Str "And",Space,Str "another",Space,Str "image"] ("lalune.jpg","fig:")]]]]

test/pptx/comparison/extra-text/input.native

@@ -0,0 +1,23 @@
+[Header 1 ("a-slide",[],[]) [Str "A",Space,Str "slide"]
+,Div ("",["columns"],[])
+ [Div ("",["column"],[])
+  [Para [Str "A",Space,Str "paragraph",Space,Str "here"]
+  ,Table ("",[],[]) (Caption Nothing
+   [])
+   [(AlignDefault,ColWidth 0.125)
+   ,(AlignDefault,ColWidth 0.125)]
+   (TableHead ("",[],[])
+   [])
+   [(TableBody ("",[],[]) (RowHeadColumns 0)
+    []
+    [Row ("",[],[])
+     [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "plus"]]
+     ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "a",Space,Str "table"]]]])]
+   (TableFoot ("",[],[])
+   [])
+  ,Para [Str "Then",Space,Str "some",Space,Str "more",Space,Str "text"]]
+ ,Div ("",["column"],[])
+  [Para [Str "A",Space,Str "paragraph",Space,Str "here"]
+  ,Para [Image ("",[],[]) [Str "Plus",Space,Str "an",Space,Str "image"] ("lalune.jpg","fig:")]]]]

test/pptx/comparison/non-text-first/input.native

@@ -0,0 +1,21 @@
+[Header 1 ("a-slide",[],[]) [Str "A",Space,Str "slide"]
+,Div ("",["columns"],[])
+ [Div ("",["column"],[])
+  [Table ("",[],[]) (Caption Nothing
+   [])
+   [(AlignDefault,ColWidth 0.125)
+   ,(AlignDefault,ColWidth 0.125)]
+   (TableHead ("",[],[])
+   [])
+   [(TableBody ("",[],[]) (RowHeadColumns 0)
+    []
+    [Row ("",[],[])
+     [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "a"]]
+     ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "table"]]]])]
+   (TableFoot ("",[],[])
+   [])
+  ,Para [Str "Plus",Space,Str "a",Space,Str "paragraph",Space,Str "here"]]
+ ,Div ("",["column"],[])
+  [Para [Image ("",[],[]) [Str "Just",Space,Str "an",Space,Str "image",Space,Str "on",Space,Str "this",Space,Str "side"] ("lalune.jpg","fig:")]]]]

test/pptx/comparison/one-column/input.native

@@ -0,0 +1,21 @@
+[Header 1 ("a-slide",[],[]) [Str "A",Space,Str "slide"]
+,Div ("",["columns"],[])
+ [Div ("",["column"],[])
+  [Para [Str "A",Space,Str "paragraph",Space,Str "here"]
+  ,Table ("",[],[]) (Caption Nothing
+   [])
+   [(AlignDefault,ColWidth 0.125)
+   ,(AlignDefault,ColWidth 0.125)]
+   (TableHead ("",[],[])
+   [])
+   [(TableBody ("",[],[]) (RowHeadColumns 0)
+    []
+    [Row ("",[],[])
+     [Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "plus"]]
+     ,Cell ("",[],[]) AlignDefault (RowSpan 1) (ColSpan 1)
+      [Plain [Str "a",Space,Str "table"]]]])]
+   (TableFoot ("",[],[])
+   [])]
+ ,Div ("",["column"],[])
+  [Para [Str "Only",Space,Str "a",Space,Str "paragraph",Space,Str "here"]]]]

test/pptx/content-with-caption/heading-text-image/input.native

@@ -0,0 +1,3 @@
+[Header 1 ("a-slide",[],[]) [Str "A",Space,Str "slide"]
+,Para [Str "Some",Space,Str "text",Space,Str "here"]
+,Para [Image ("",[],[]) [Str "Followed",Space,Str "by",Space,Str "a",Space,Str "picture"] ("lalune.jpg","fig:")]]

test/pptx/content-with-caption/image-text/input.native

@@ -0,0 +1,2 @@
+[Para [Image ("",[],[]) [Str "The",Space,Str "picture",Space,Str "first"] ("lalune.jpg","fig:")]
+,Para [Str "Then",Space,Str "some",Space,Str "text",Space,Str "here"]]

test/pptx/content-with-caption/text-image/input.native

@@ -0,0 +1,2 @@
+[Para [Str "Some",Space,Str "text",Space,Str "here"]
+,Para [Image ("",[],[]) [Str "Followed",Space,Str "by",Space,Str "a",Space,Str "picture"] ("lalune.jpg","fig:")]]