From b82a01b6883c1f6a9ce5d3edd80d5a2453ecef9e Mon Sep 17 00:00:00 2001 From: Emily Bourke 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