From dcc6e6b777ff6f35331118346ee2ebe845740e7e Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Wed, 3 Jan 2018 10:18:43 -0500 Subject: Powerpoint writer: Implement two-column slides. This uses the columns/column div format described in the pandoc manual. At the moment, only two columns (half the screen each) are allowed. Custom widths are not supported. --- src/Text/Pandoc/Writers/Powerpoint.hs | 107 ++++++++++++++++++++++++++++++---- 1 file changed, 95 insertions(+), 12 deletions(-) diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs index ab3b2eabf..7aed2e43f 100644 --- a/src/Text/Pandoc/Writers/Powerpoint.hs +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -43,6 +43,7 @@ import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import System.FilePath.Posix (splitDirectories, splitExtension) import Text.XML.Light +import qualified Text.XML.Light.Cursor as XMLC import Text.Pandoc.Definition import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Class (PandocMonad) @@ -191,10 +192,14 @@ data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem] , metadataSlideAuthors :: [[ParaElem]] , metadataSlideDate :: [ParaElem] } - | TitleSlide { titleSlideHeader :: [ParaElem]} - | ContentSlide { contentSlideHeader :: [ParaElem] + | TitleSlide { slideHeader :: [ParaElem]} + | ContentSlide { slideHeader :: [ParaElem] , contentSlideContent :: [Shape] } + | TwoColumnSlide { slideHeader :: [ParaElem] + , twoColumnSlideLeft :: [Shape] + , twoColumnSlideRight :: [Shape] + } deriving (Show, Eq) data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape @@ -553,6 +558,12 @@ splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do (Header n _ _) : [] | n == slideLevel -> splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks +splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [d]]) blks + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks splitBlocks :: Monad m => [Block] -> P m [[Block]] @@ -562,25 +573,37 @@ blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide blocksToSlide' lvl ((Header n _ ils) : blks) | n < lvl = do hdr <- inlinesToParElems ils - return $ TitleSlide {titleSlideHeader = hdr} + return $ TitleSlide {slideHeader = hdr} | n == lvl = do hdr <- inlinesToParElems ils - inNoteSlide <- asks envInNoteSlide - shapes <- if inNoteSlide - then forceFontSize noteSize $ blocksToShapes blks - else blocksToShapes blks - return $ ContentSlide { contentSlideHeader = hdr - , contentSlideContent = shapes - } + -- Now get the slide without the header, and then add the header + -- in. + slide <- blocksToSlide' lvl blks + return $ slide {slideHeader = hdr} +blocksToSlide' _ (blk : blks) + | Div (_, classes, _) divBlks <- blk + , "columns" `elem` classes + , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks + , "column" `elem` clsL, "column" `elem` clsR = do + unless (null blks) + (mapM (P.report . BlockNotRendered) blks >> return ()) + unless (null remaining) + (mapM (P.report . BlockNotRendered) remaining >> return ()) + shapesL <- blocksToShapes blksL + shapesR <- blocksToShapes blksR + return $ TwoColumnSlide { slideHeader = [] + , twoColumnSlideLeft = shapesL + , twoColumnSlideRight = shapesR + } blocksToSlide' _ (blk : blks) = do inNoteSlide <- asks envInNoteSlide shapes <- if inNoteSlide then forceFontSize noteSize $ blocksToShapes (blk : blks) else blocksToShapes (blk : blks) - return $ ContentSlide { contentSlideHeader = [] + return $ ContentSlide { slideHeader = [] , contentSlideContent = shapes } -blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = [] +blocksToSlide' _ [] = return $ ContentSlide { slideHeader = [] , contentSlideContent = [] } @@ -776,6 +799,7 @@ getLayout slide = do (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml" (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml" (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml" + (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml" distArchive <- asks envDistArchive root <- case findEntryByPath layoutpath distArchive of Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of @@ -1377,6 +1401,53 @@ contentToElement layout hdrShape shapes spTree contentToElement _ _ _ = return $ mknode "p:sp" [] () +setIdx'' :: NameSpaces -> String -> Content -> Content +setIdx'' _ idx (Elem element) = + let tag = XMLC.getTag element + attrs = XMLC.tagAttribs tag + idxKey = (QName "idx" Nothing Nothing) + attrs' = Attr idxKey idx : (filter (\a -> attrKey a /= idxKey) attrs) + tag' = tag {XMLC.tagAttribs = attrs'} + in Elem $ XMLC.setTag tag' element +setIdx'' _ _ c = c + +setIdx' :: NameSpaces -> String -> XMLC.Cursor -> XMLC.Cursor +setIdx' ns idx cur = + let modifiedCur = XMLC.modifyContent (setIdx'' ns idx) cur + in + case XMLC.nextDF modifiedCur of + Just cur' -> setIdx' ns idx cur' + Nothing -> XMLC.root modifiedCur + +setIdx :: NameSpaces -> String -> Element -> Element +setIdx ns idx element = + let cur = XMLC.fromContent (Elem element) + cur' = setIdx' ns idx cur + in + case XMLC.toTree cur' of + Elem element' -> element' + _ -> element + +twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element +twoColumnToElement layout hdrShape shapesL shapesR + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" hdrShape + let hdrShapeElements = if null hdrShape + then [] + else [element] + contentElementsL <- shapesToElements layout shapesL + contentElementsR <- shapesToElements layout shapesR + let contentElementsL' = map (setIdx ns "1") contentElementsL + contentElementsR' = map (setIdx ns "2") contentElementsR + return $ + replaceNamedChildren ns "p" "sp" + (hdrShapeElements ++ contentElementsL' ++ contentElementsR') + spTree +twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] () + + titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element titleToElement layout titleElems | ns <- elemToNameSpaces layout @@ -1422,6 +1493,17 @@ slideToElement s@(ContentSlide hdrElems shapes) = do ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") ] [mknode "p:cSld" [] [spTree]] +slideToElement s@(TwoColumnSlide hdrElems shapesL shapesR) = do + layout <- getLayout s + spTree <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) $ + twoColumnToElement 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 s@(TitleSlide hdrElems) = do layout <- getLayout s spTree <- titleToElement layout hdrElems @@ -1574,6 +1656,7 @@ slideToSlideRelElement slide idNum = do (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml" (TitleSlide _) -> "../slideLayouts/slideLayout3.xml" (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml" + (TwoColumnSlide _ _ _) -> "../slideLayouts/slideLayout4.xml" linkIds <- gets stLinkIds mediaIds <- gets stMediaIds -- cgit v1.2.3