diff options
| -rw-r--r-- | src/Text/Pandoc/Writers/Powerpoint/Output.hs | 30 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Powerpoint/Presentation.hs | 115 |
2 files changed, 97 insertions, 48 deletions
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index 1ea940497..752a57047 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -279,9 +279,9 @@ presentationToArchive opts pres = do -------------------------------------------------- -getLayout :: PandocMonad m => Slide -> P m Element -getLayout slide = do - let layoutpath = case slide of +getLayout :: PandocMonad m => Layout -> P m Element +getLayout layout = do + let layoutpath = case layout of (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml" (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml" (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml" @@ -1028,8 +1028,8 @@ metadataToElement layout titleElems subtitleElems authorsElems dateElems metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () slideToElement :: PandocMonad m => Slide -> P m Element -slideToElement s@(ContentSlide hdrElems shapes) = do - layout <- getLayout s +slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ )= do + layout <- getLayout l spTree <- local (\env -> if null hdrElems then env else env{envSlideHasHeader=True}) $ @@ -1039,8 +1039,8 @@ 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 +slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do + layout <- getLayout l spTree <- local (\env -> if null hdrElems then env else env{envSlideHasHeader=True}) $ @@ -1050,16 +1050,16 @@ slideToElement s@(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 s@(TitleSlide hdrElems) = do - layout <- getLayout s +slideToElement (Slide _ l@(TitleSlide hdrElems) _) = do + layout <- getLayout l spTree <- titleToElement layout hdrElems 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@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do - layout <- getLayout s +slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems dateElems) _) = do + layout <- getLayout l spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems return $ mknode "p:sld" [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), @@ -1227,10 +1227,10 @@ mediaRelElement mInfo = slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element slideToSlideRelElement slide idNum = do let target = case slide of - (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml" - (TitleSlide _) -> "../slideLayouts/slideLayout3.xml" - (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml" - (TwoColumnSlide _ _ _) -> "../slideLayouts/slideLayout4.xml" + (Slide _ (MetadataSlide _ _ _ _) _) -> "../slideLayouts/slideLayout1.xml" + (Slide _ (TitleSlide _) _) -> "../slideLayouts/slideLayout3.xml" + (Slide _ (ContentSlide _ _) _) -> "../slideLayouts/slideLayout2.xml" + (Slide _ (TwoColumnSlide _ _ _) _) -> "../slideLayouts/slideLayout4.xml" linkIds <- gets stLinkIds mediaIds <- gets stMediaIds diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index 5046922ce..1825a048e 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -35,6 +35,9 @@ Presentation. module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation , Presentation(..) , Slide(..) + , Layout(..) + , Notes(..) + , SlideId(..) , Shape(..) , Graphic(..) , BulletType(..) @@ -76,7 +79,7 @@ data WriterEnv = WriterEnv { envMetadata :: Meta , envSlideHasHeader :: Bool , envInList :: Bool , envInNoteSlide :: Bool - , envCurSlideId :: Int + , envCurSlideId :: SlideId } deriving (Show) @@ -89,13 +92,13 @@ instance Default WriterEnv where , envSlideHasHeader = False , envInList = False , envInNoteSlide = False - , envCurSlideId = 1 + , envCurSlideId = SlideId "1" } data WriterState = WriterState { stNoteIds :: M.Map Int [Block] -- associate anchors with slide id - , stAnchorMap :: M.Map String Int + , stAnchorMap :: M.Map String SlideId , stLog :: [LogMessage] } deriving (Show, Eq) @@ -124,7 +127,20 @@ type Pixels = Integer data Presentation = Presentation [Slide] deriving (Show) -data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem] + +data Slide = Slide SlideId Layout (Maybe Notes) + deriving (Show, Eq) + +newtype SlideId = SlideId String + deriving (Show, Eq) + +-- In theory you could have anything on a notes slide but it seems +-- designed mainly for one textbox, so we'll just put in the contents +-- of that textbox, to avoid other shapes that won't work as well. +newtype Notes = Notes [Paragraph] + deriving (Show, Eq) + +data Layout = MetadataSlide { metadataSlideTitle :: [ParaElem] , metadataSlideSubtitle :: [ParaElem] , metadataSlideAuthors :: [[ParaElem]] , metadataSlideDate :: [ParaElem] @@ -204,7 +220,7 @@ data Capitals = NoCapitals | SmallCapitals | AllCapitals type URL = String data LinkTarget = ExternalTarget (URL, String) - | InternalTarget Int -- slideId + | InternalTarget SlideId deriving (Show, Eq) data RunProps = RunProps { rPropBold :: Bool @@ -513,18 +529,20 @@ blocksToSlide' :: Int -> [Block] -> Pres Slide blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks) | n < lvl = do registerAnchorId ident + slideId <- asks envCurSlideId hdr <- inlinesToParElems ils - return $ TitleSlide {titleSlideHeader = hdr} + return $ Slide slideId (TitleSlide {titleSlideHeader = hdr}) Nothing | n == lvl = do registerAnchorId ident hdr <- inlinesToParElems ils -- Now get the slide without the header, and then add the header -- in. - slide <- blocksToSlide' lvl blks - return $ case slide of - ContentSlide _ cont -> ContentSlide hdr cont - TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR - slide' -> slide' + (Slide slideId layout mbNotes) <- blocksToSlide' lvl blks + let layout' = case layout of + ContentSlide _ cont -> ContentSlide hdr cont + TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR + layout'' -> layout'' + return $ Slide slideId layout' mbNotes blocksToSlide' _ (blk : blks) | Div (_, classes, _) divBlks <- blk , "columns" `elem` classes @@ -544,21 +562,36 @@ blocksToSlide' _ (blk : blks) [] -> [] shapesL <- blocksToShapes blksL' shapesR <- blocksToShapes blksR' - return $ TwoColumnSlide { twoColumnSlideHeader = [] - , twoColumnSlideLeft = shapesL - , twoColumnSlideRight = shapesR - } + slideId <- asks envCurSlideId + return $ Slide + slideId + TwoColumnSlide { twoColumnSlideHeader = [] + , twoColumnSlideLeft = shapesL + , twoColumnSlideRight = shapesR + } + Nothing blocksToSlide' _ (blk : blks) = do inNoteSlide <- asks envInNoteSlide shapes <- if inNoteSlide then forceFontSize noteSize $ blocksToShapes (blk : blks) else blocksToShapes (blk : blks) - return $ ContentSlide { contentSlideHeader = [] - , contentSlideContent = shapes - } -blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = [] - , contentSlideContent = [] - } + slideId <- asks envCurSlideId + return $ + Slide + slideId + ContentSlide { contentSlideHeader = [] + , contentSlideContent = shapes + } + Nothing +blocksToSlide' _ [] = do + slideId <- asks envCurSlideId + return $ + Slide + slideId + ContentSlide { contentSlideHeader = [] + , contentSlideContent = [] + } + Nothing blocksToSlide :: [Block] -> Pres Slide blocksToSlide blks = do @@ -612,13 +645,20 @@ getMetaSlide = do _ -> [] authors <- mapM inlinesToParElems $ docAuthors meta date <- inlinesToParElems $ docDate meta + slideId <- asks envCurSlideId if null title && null subtitle && null authors && null date then return Nothing - else return $ Just $ MetadataSlide { metadataSlideTitle = title - , metadataSlideSubtitle = subtitle - , metadataSlideAuthors = authors - , metadataSlideDate = date - } + else return $ + Just $ + Slide + slideId + MetadataSlide { metadataSlideTitle = title + , metadataSlideSubtitle = subtitle + , metadataSlideAuthors = authors + , metadataSlideDate = date + } + Nothing + -- adapted from the markdown writer elementToListItem :: Shared.Element -> Pres [Block] elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do @@ -676,26 +716,35 @@ applyToShape f (TextBox paras) = do paras' <- mapM (applyToParagraph f) paras return $ TextBox paras' -applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide -applyToSlide f (MetadataSlide title subtitle authors date) = do +applyToLayout :: Monad m => (ParaElem -> m ParaElem) -> Layout -> m Layout +applyToLayout f (MetadataSlide title subtitle authors date) = do title' <- mapM f title subtitle' <- mapM f subtitle authors' <- mapM (mapM f) authors date' <- mapM f date return $ MetadataSlide title' subtitle' authors' date' -applyToSlide f (TitleSlide title) = do +applyToLayout f (TitleSlide title) = do title' <- mapM f title return $ TitleSlide title' -applyToSlide f (ContentSlide hdr content) = do +applyToLayout f (ContentSlide hdr content) = do hdr' <- mapM f hdr content' <- mapM (applyToShape f) content return $ ContentSlide hdr' content' -applyToSlide f (TwoColumnSlide hdr contentL contentR) = do +applyToLayout f (TwoColumnSlide hdr contentL contentR) = do hdr' <- mapM f hdr contentL' <- mapM (applyToShape f) contentL contentR' <- mapM (applyToShape f) contentR return $ TwoColumnSlide hdr' contentL' contentR' +applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide +applyToSlide f (Slide slideId layout mbNotes) = do + layout' <- applyToLayout f layout + mbNotes' <- case mbNotes of + Just (Notes notes) -> (Just . Notes) <$> + mapM (applyToParagraph f) notes + Nothing -> return Nothing + return $ Slide slideId layout' mbNotes' + replaceAnchor :: ParaElem -> Pres ParaElem replaceAnchor (Run rProps s) | Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do @@ -728,7 +777,7 @@ blocksToPresentation blks = do let bodyStartNum = tocStartNum + tocSlidesLength blksLst <- splitBlocks blks bodyslides <- mapM - (\(bs, n) -> local (\st -> st{envCurSlideId = n}) (blocksToSlide bs)) + (\(bs, n) -> local (\st -> st{envCurSlideId = SlideId $ show n}) (blocksToSlide bs)) (zip blksLst [bodyStartNum..]) let endNoteStartNum = bodyStartNum + length bodyslides endNotesSlideBlocks <- makeEndNotesSlideBlocks @@ -742,7 +791,7 @@ blocksToPresentation blks = do endNotesSlides <- if null endNotesSlideBlocks then return [] else do endNotesSlide <- local - (\env -> env { envCurSlideId = endNoteStartNum + (\env -> env { envCurSlideId = SlideId $ show endNoteStartNum , envInNoteSlide = True }) (blocksToSlide $ endNotesSlideBlocks) |