diff options
| -rw-r--r-- | src/Text/Pandoc/Writers/Powerpoint/Output.hs | 103 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Powerpoint/Presentation.hs | 48 |
2 files changed, 91 insertions, 60 deletions
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index 752a57047..8ef5665fa 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -105,6 +105,7 @@ data WriterEnv = WriterEnv { envRefArchive :: Archive -- the rId number , envSlideIdOffset :: Int , envContentType :: ContentType + , envSlideIdMap :: M.Map SlideId Int } deriving (Show) @@ -120,6 +121,7 @@ instance Default WriterEnv where , envCurSlideId = 1 , envSlideIdOffset = 1 , envContentType = NormalContent + , envSlideIdMap = mempty } data ContentType = NormalContent @@ -231,8 +233,8 @@ presentationToArchiveP p@(Presentation slides) = do -- sure we know the correct offset for the rIds. presEntry <- presentationToPresEntry p presRelsEntry <- presentationToRelsEntry p - slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..] - slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..] + slideEntries <- mapM slideToEntry slides + slideRelEntries <- mapM slideToSlideRelEntry slides -- These have to come after everything, because they need the info -- built up in the state. mediaEntries <- makeMediaEntries @@ -244,6 +246,10 @@ presentationToArchiveP p@(Presentation slides) = do mediaEntries ++ [contentTypesEntry, relsEntry, presEntry, presRelsEntry] +makeSlideIdMap :: Presentation -> M.Map SlideId Int +makeSlideIdMap (Presentation slides) = + M.fromList $ (map slideId slides) `zip` [1..] + presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive presentationToArchive opts pres = do distArchive <- (toArchive . BL.fromStrict) <$> @@ -266,6 +272,7 @@ presentationToArchive opts pres = do , envUTCTime = utctime , envOpts = opts , envPresentationSize = presSize + , envSlideIdMap = makeSlideIdMap pres } let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive @@ -1069,13 +1076,31 @@ slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems da ----------------------------------------------------------------------- -slideToFilePath :: Slide -> Int -> FilePath -slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml" +getSlideIdNum :: PandocMonad m => SlideId -> P m Int +getSlideIdNum sldId = do + slideIdMap <- asks envSlideIdMap + case M.lookup sldId slideIdMap of + Just n -> return n + Nothing -> throwError $ + PandocShouldNeverHappenError $ + "Slide Id " ++ (show sldId) ++ " not found." -slideToSlideId :: Monad m => Slide -> Int -> P m String -slideToSlideId _ idNum = do - n <- asks envSlideIdOffset - return $ "rId" ++ (show $ idNum + n) +slideNum :: PandocMonad m => Slide -> P m Int +slideNum slide = getSlideIdNum $ slideId slide + +idNumToFilePath :: Int -> FilePath +idNumToFilePath idNum = "slide" ++ (show $ idNum) ++ ".xml" + +slideToFilePath :: PandocMonad m => Slide -> P m FilePath +slideToFilePath slide = do + idNum <- slideNum slide + return $ "slide" ++ (show $ idNum) ++ ".xml" + +slideToRelId :: PandocMonad m => Slide -> P m String +slideToRelId slide = do + n <- slideNum slide + offset <- asks envSlideIdOffset + return $ "rId" ++ (show $ n + offset) data Relationship = Relationship { relId :: Int @@ -1096,11 +1121,12 @@ elementToRel element return $ Relationship num type' target | otherwise = Nothing -slideToPresRel :: Monad m => Slide -> Int -> P m Relationship -slideToPresRel slide idNum = do +slideToPresRel :: PandocMonad m => Slide -> P m Relationship +slideToPresRel slide = do + idNum <- slideNum slide n <- asks envSlideIdOffset let rId = idNum + n - fp = "slides/" ++ slideToFilePath slide idNum + fp = "slides/" ++ idNumToFilePath idNum return $ Relationship { relId = rId , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" , relTarget = fp @@ -1117,7 +1143,7 @@ getRels = do presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] presentationToRels (Presentation slides) = do - mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..] + mySlideRels <- mapM slideToPresRel slides rels <- getRels let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels -- We want to make room for the slides in the id space. The slides @@ -1184,27 +1210,30 @@ elemToEntry fp element = do epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime return $ toEntry fp epochtime $ renderXml element -slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry -slideToEntry slide idNum = do +slideToEntry :: PandocMonad m => Slide -> P m Entry +slideToEntry slide = do + idNum <- slideNum slide local (\env -> env{envCurSlideId = idNum}) $ do element <- slideToElement slide - elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element + elemToEntry ("ppt/slides/" ++ idNumToFilePath idNum) element -slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry -slideToSlideRelEntry slide idNum = do - element <- slideToSlideRelElement slide idNum - elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element +slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry +slideToSlideRelEntry slide = do + idNum <- slideNum slide + element <- slideToSlideRelElement slide + elemToEntry ("ppt/slides/_rels/" ++ idNumToFilePath idNum ++ ".rels") element linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element -linkRelElement idNum (InternalTarget num) = do +linkRelElement rIdNum (InternalTarget targetId) = do + targetIdNum <- getSlideIdNum targetId return $ - mknode "Relationship" [ ("Id", "rId" ++ show idNum) + mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") - , ("Target", "slide" ++ show num ++ ".xml") + , ("Target", "slide" ++ show targetIdNum ++ ".xml") ] () -linkRelElement idNum (ExternalTarget (url, _)) = do +linkRelElement rIdNum (ExternalTarget (url, _)) = do return $ - mknode "Relationship" [ ("Id", "rId" ++ show idNum) + mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") , ("Target", url) , ("TargetMode", "External") @@ -1224,8 +1253,9 @@ mediaRelElement mInfo = , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext) ] () -slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element -slideToSlideRelElement slide idNum = do +slideToSlideRelElement :: PandocMonad m => Slide -> P m Element +slideToSlideRelElement slide = do + idNum <- slideNum slide let target = case slide of (Slide _ (MetadataSlide _ _ _ _) _) -> "../slideLayouts/slideLayout1.xml" (Slide _ (TitleSlide _) _) -> "../slideLayouts/slideLayout3.xml" @@ -1250,15 +1280,16 @@ slideToSlideRelElement slide idNum = do , ("Target", target)] () ] ++ linkRels ++ mediaRels) -slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element -slideToSldIdElement slide idNum = do - let id' = show $ idNum + 255 - rId <- slideToSlideId slide idNum +slideToSldIdElement :: PandocMonad m => Slide -> P m Element +slideToSldIdElement slide = do + n <- slideNum slide + let id' = show $ n + 255 + rId <- slideToRelId slide return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element presentationToSldIdLst (Presentation slides) = do - ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..]) + ids <- mapM slideToSldIdElement slides return $ mknode "p:sldIdLst" [] ids presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element @@ -1366,12 +1397,10 @@ presentationToContentTypes (Presentation slides) = do inheritedOverrides = mapMaybe pathToOverride filePaths presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] - slideOverrides = - mapMaybe - (\(s, n) -> - pathToOverride $ "ppt/slides/" ++ slideToFilePath s n) - (zip slides [1..]) - -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"] + relativePaths <- mapM slideToFilePath slides + let slideOverrides = mapMaybe + (\fp -> pathToOverride $ "ppt/slides/" ++ fp) + relativePaths return $ ContentTypes (defaults ++ mediaDefaults) (inheritedOverrides ++ presOverride ++ slideOverrides) diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index 1825a048e..3f98dceea 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -128,11 +128,13 @@ data Presentation = Presentation [Slide] deriving (Show) -data Slide = Slide SlideId Layout (Maybe Notes) - deriving (Show, Eq) +data Slide = Slide { slideId :: SlideId + , slideLayout :: Layout + , slideNotes :: (Maybe Notes) + } deriving (Show, Eq) newtype SlideId = SlideId String - deriving (Show, Eq) + deriving (Show, Eq, Ord) -- 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 @@ -316,9 +318,9 @@ isListType _ = False registerAnchorId :: String -> Pres () registerAnchorId anchor = do anchorMap <- gets stAnchorMap - slideId <- asks envCurSlideId + sldId <- asks envCurSlideId unless (null anchor) $ - modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap} + modify $ \st -> st {stAnchorMap = M.insert anchor sldId anchorMap} -- Currently hardcoded, until I figure out how to make it dynamic. blockQuoteSize :: Pixels @@ -529,20 +531,20 @@ blocksToSlide' :: Int -> [Block] -> Pres Slide blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks) | n < lvl = do registerAnchorId ident - slideId <- asks envCurSlideId + sldId <- asks envCurSlideId hdr <- inlinesToParElems ils - return $ Slide slideId (TitleSlide {titleSlideHeader = hdr}) Nothing + return $ Slide sldId (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 slideId layout mbNotes) <- blocksToSlide' lvl blks - let layout' = case layout of + slide <- blocksToSlide' lvl blks + let layout = case slideLayout slide of ContentSlide _ cont -> ContentSlide hdr cont TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR - layout'' -> layout'' - return $ Slide slideId layout' mbNotes + layout' -> layout' + return $ slide{slideLayout = layout} blocksToSlide' _ (blk : blks) | Div (_, classes, _) divBlks <- blk , "columns" `elem` classes @@ -562,9 +564,9 @@ blocksToSlide' _ (blk : blks) [] -> [] shapesL <- blocksToShapes blksL' shapesR <- blocksToShapes blksR' - slideId <- asks envCurSlideId + sldId <- asks envCurSlideId return $ Slide - slideId + sldId TwoColumnSlide { twoColumnSlideHeader = [] , twoColumnSlideLeft = shapesL , twoColumnSlideRight = shapesR @@ -575,19 +577,19 @@ blocksToSlide' _ (blk : blks) = do shapes <- if inNoteSlide then forceFontSize noteSize $ blocksToShapes (blk : blks) else blocksToShapes (blk : blks) - slideId <- asks envCurSlideId + sldId <- asks envCurSlideId return $ Slide - slideId + sldId ContentSlide { contentSlideHeader = [] , contentSlideContent = shapes } Nothing blocksToSlide' _ [] = do - slideId <- asks envCurSlideId + sldId <- asks envCurSlideId return $ Slide - slideId + sldId ContentSlide { contentSlideHeader = [] , contentSlideContent = [] } @@ -645,13 +647,13 @@ getMetaSlide = do _ -> [] authors <- mapM inlinesToParElems $ docAuthors meta date <- inlinesToParElems $ docDate meta - slideId <- asks envCurSlideId + sldId <- asks envCurSlideId if null title && null subtitle && null authors && null date then return Nothing else return $ Just $ Slide - slideId + sldId MetadataSlide { metadataSlideTitle = title , metadataSlideSubtitle = subtitle , metadataSlideAuthors = authors @@ -737,13 +739,13 @@ applyToLayout f (TwoColumnSlide hdr contentL contentR) = do 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 +applyToSlide f slide = do + layout' <- applyToLayout f $ slideLayout slide + mbNotes' <- case slideNotes slide of Just (Notes notes) -> (Just . Notes) <$> mapM (applyToParagraph f) notes Nothing -> return Nothing - return $ Slide slideId layout' mbNotes' + return slide{slideLayout = layout', slideNotes = mbNotes'} replaceAnchor :: ParaElem -> Pres ParaElem replaceAnchor (Run rProps s) |