aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc')
-rw-r--r--src/Text/Pandoc/Writers/Powerpoint/Output.hs103
-rw-r--r--src/Text/Pandoc/Writers/Powerpoint/Presentation.hs48
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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 19:40:37 +0000