From b82a01b6883c1f6a9ce5d3edd80d5a2453ecef9e Mon Sep 17 00:00:00 2001
From: Emily Bourke <undergroundquizscene@protonmail.com>
Date: Thu, 19 Aug 2021 15:53:21 +0100
Subject: pptx: Add support for more layouts
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
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
---
src/Text/Pandoc/Writers/Powerpoint/Output.hs | 179 ++++++++++++++++---
src/Text/Pandoc/Writers/Powerpoint/Presentation.hs | 189 +++++++++++++++++----
2 files changed, 313 insertions(+), 55 deletions(-)
(limited to 'src')
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
--
cgit v1.2.3