lee/pandoc
1
0
Fork 0
mirror of https://github.com/jgm/pandoc.git synced 2026-08-26 18:26:36 +00:00
Code Issues Packages Projects Releases Wiki Activity

Powerpoint writer: Use slideids to simplify code.

Browse Source
This commit is contained in:
Jesse Rosenthal
2018-01-17 16:40:32 -05:00
parent 63a2507d0e
commit 0d53efeddb
2 changed files with 91 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Text/Pandoc/Writers/Powerpoint/Output.hs
+66 -37
View File
@@ -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)
src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
+25 -23
View File
@@ -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)