git.iko.soy/typeable/pandoc
on master help sign in
Powerpoint writer: Use slideids to simplify code.
0d53efeJesse Rosenthal
src/Text/Pandoc/Writers/Powerpoint/Output.hs+66−37
compare with master
unifiedsplit
@@ -105,6 +105,7 @@ data WriterEnv = WriterEnv { envRefArchive :: Archive
105 -- the rId number
105 -- the rId number
106 , envSlideIdOffset :: Int
106 , envSlideIdOffset :: Int
107 , envContentType :: ContentType
107 , envContentType :: ContentType
108+ , envSlideIdMap :: M.Map SlideId Int
108 }
109 }
109 deriving (Show)
110 deriving (Show)
110
111
@@ -120,6 +121,7 @@ instance Default WriterEnv where
120 , envCurSlideId = 1
121 , envCurSlideId = 1
121 , envSlideIdOffset = 1
122 , envSlideIdOffset = 1
122 , envContentType = NormalContent
123 , envContentType = NormalContent
124+ , envSlideIdMap = mempty
123 }
125 }
124
126
125data ContentType = NormalContent
127data ContentType = NormalContent
@@ -231,8 +233,8 @@ presentationToArchiveP p@(Presentation slides) = do
231 -- sure we know the correct offset for the rIds.
233 -- sure we know the correct offset for the rIds.
232 presEntry <- presentationToPresEntry p
234 presEntry <- presentationToPresEntry p
233 presRelsEntry <- presentationToRelsEntry p
235 presRelsEntry <- presentationToRelsEntry p
234− slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]
236+ slideEntries <- mapM slideToEntry slides
235− slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]
237+ slideRelEntries <- mapM slideToSlideRelEntry slides
236 -- These have to come after everything, because they need the info
238 -- These have to come after everything, because they need the info
237 -- built up in the state.
239 -- built up in the state.
238 mediaEntries <- makeMediaEntries
240 mediaEntries <- makeMediaEntries
@@ -244,6 +246,10 @@ presentationToArchiveP p@(Presentation slides) = do
244 mediaEntries ++
246 mediaEntries ++
245 [contentTypesEntry, relsEntry, presEntry, presRelsEntry]
247 [contentTypesEntry, relsEntry, presEntry, presRelsEntry]
246
248
249+makeSlideIdMap :: Presentation -> M.Map SlideId Int
250+makeSlideIdMap (Presentation slides) =
251+ M.fromList $ (map slideId slides) `zip` [1..]
252+
247presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive
253presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive
248presentationToArchive opts pres = do
254presentationToArchive opts pres = do
249 distArchive <- (toArchive . BL.fromStrict) <$>
255 distArchive <- (toArchive . BL.fromStrict) <$>
@@ -266,6 +272,7 @@ presentationToArchive opts pres = do
266 , envUTCTime = utctime
272 , envUTCTime = utctime
267 , envOpts = opts
273 , envOpts = opts
268 , envPresentationSize = presSize
274 , envPresentationSize = presSize
275+ , envSlideIdMap = makeSlideIdMap pres
269 }
276 }
270
277
271 let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
278 let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
@@ -1069,13 +1076,31 @@ slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems da
1069
1076
1070-----------------------------------------------------------------------
1077-----------------------------------------------------------------------
1071
1078
1072−slideToFilePath :: Slide -> Int -> FilePath
1079+getSlideIdNum :: PandocMonad m => SlideId -> P m Int
1073−slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"
1080+getSlideIdNum sldId = do
1081+ slideIdMap <- asks envSlideIdMap
1082+ case M.lookup sldId slideIdMap of
1083+ Just n -> return n
1084+ Nothing -> throwError $
1085+ PandocShouldNeverHappenError $
1086+ "Slide Id " ++ (show sldId) ++ " not found."
1074
1087
1075−slideToSlideId :: Monad m => Slide -> Int -> P m String
1088+slideNum :: PandocMonad m => Slide -> P m Int
1076−slideToSlideId _ idNum = do
1089+slideNum slide = getSlideIdNum $ slideId slide
1090+
1091+idNumToFilePath :: Int -> FilePath
1092+idNumToFilePath idNum = "slide" ++ (show $ idNum) ++ ".xml"
1093+
1094+slideToFilePath :: PandocMonad m => Slide -> P m FilePath
1095+slideToFilePath slide = do
1096+ idNum <- slideNum slide
1097+ return $ "slide" ++ (show $ idNum) ++ ".xml"
1098+
1099+slideToRelId :: PandocMonad m => Slide -> P m String
1100+slideToRelId slide = do
1101+ n <- slideNum slide
1077− n <- asks envSlideIdOffset
1102+ offset <- asks envSlideIdOffset
1078− return $ "rId" ++ (show $ idNum + n)
1103+ return $ "rId" ++ (show $ n + offset)
1079
1104
1080
1105
1081data Relationship = Relationship { relId :: Int
1106data Relationship = Relationship { relId :: Int
@@ -1096,11 +1121,12 @@ elementToRel element
1096 return $ Relationship num type' target
1121 return $ Relationship num type' target
1097 | otherwise = Nothing
1122 | otherwise = Nothing
1098
1123
1099−slideToPresRel :: Monad m => Slide -> Int -> P m Relationship
1124+slideToPresRel :: PandocMonad m => Slide -> P m Relationship
1100−slideToPresRel slide idNum = do
1125+slideToPresRel slide = do
1126+ idNum <- slideNum slide
1101 n <- asks envSlideIdOffset
1127 n <- asks envSlideIdOffset
1102 let rId = idNum + n
1128 let rId = idNum + n
1103− fp = "slides/" ++ slideToFilePath slide idNum
1129+ fp = "slides/" ++ idNumToFilePath idNum
1104 return $ Relationship { relId = rId
1130 return $ Relationship { relId = rId
1105 , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
1131 , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
1106 , relTarget = fp
1132 , relTarget = fp
@@ -1117,7 +1143,7 @@ getRels = do
1117
1143
1118presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]
1144presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]
1119presentationToRels (Presentation slides) = do
1145presentationToRels (Presentation slides) = do
1120− mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]
1146+ mySlideRels <- mapM slideToPresRel slides
1121 rels <- getRels
1147 rels <- getRels
1122 let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels
1148 let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels
1123 -- We want to make room for the slides in the id space. The slides
1149 -- We want to make room for the slides in the id space. The slides
@@ -1184,27 +1210,30 @@ elemToEntry fp element = do
1184 epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
1210 epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
1185 return $ toEntry fp epochtime $ renderXml element
1211 return $ toEntry fp epochtime $ renderXml element
1186
1212
1187−slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry
1213+slideToEntry :: PandocMonad m => Slide -> P m Entry
1188−slideToEntry slide idNum = do
1214+slideToEntry slide = do
1215+ idNum <- slideNum slide
1189 local (\env -> env{envCurSlideId = idNum}) $ do
1216 local (\env -> env{envCurSlideId = idNum}) $ do
1190 element <- slideToElement slide
1217 element <- slideToElement slide
1191− elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element
1218+ elemToEntry ("ppt/slides/" ++ idNumToFilePath idNum) element
1192
1219
1193−slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry
1220+slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry
1194−slideToSlideRelEntry slide idNum = do
1221+slideToSlideRelEntry slide = do
1222+ idNum <- slideNum slide
1195− element <- slideToSlideRelElement slide idNum
1223+ element <- slideToSlideRelElement slide
1196− elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element
1224+ elemToEntry ("ppt/slides/_rels/" ++ idNumToFilePath idNum ++ ".rels") element
1197
1225
1198linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element
1226linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element
1199−linkRelElement idNum (InternalTarget num) = do
1227+linkRelElement rIdNum (InternalTarget targetId) = do
1228+ targetIdNum <- getSlideIdNum targetId
1200 return $
1229 return $
1201− mknode "Relationship" [ ("Id", "rId" ++ show idNum)
1230+ mknode "Relationship" [ ("Id", "rId" ++ show rIdNum)
1202 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
1231 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
1203− , ("Target", "slide" ++ show num ++ ".xml")
1232+ , ("Target", "slide" ++ show targetIdNum ++ ".xml")
1204 ] ()
1233 ] ()
1205−linkRelElement idNum (ExternalTarget (url, _)) = do
1234+linkRelElement rIdNum (ExternalTarget (url, _)) = do
1206 return $
1235 return $
1207− mknode "Relationship" [ ("Id", "rId" ++ show idNum)
1236+ mknode "Relationship" [ ("Id", "rId" ++ show rIdNum)
1208 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
1237 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
1209 , ("Target", url)
1238 , ("Target", url)
1210 , ("TargetMode", "External")
1239 , ("TargetMode", "External")
@@ -1224,8 +1253,9 @@ mediaRelElement mInfo =
1224 , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)
1253 , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)
1225 ] ()
1254 ] ()
1226
1255
1227−slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element
1256+slideToSlideRelElement :: PandocMonad m => Slide -> P m Element
1228−slideToSlideRelElement slide idNum = do
1257+slideToSlideRelElement slide = do
1258+ idNum <- slideNum slide
1229 let target = case slide of
1259 let target = case slide of
1230 (Slide _ (MetadataSlide _ _ _ _) _) -> "../slideLayouts/slideLayout1.xml"
1260 (Slide _ (MetadataSlide _ _ _ _) _) -> "../slideLayouts/slideLayout1.xml"
1231 (Slide _ (TitleSlide _) _) -> "../slideLayouts/slideLayout3.xml"
1261 (Slide _ (TitleSlide _) _) -> "../slideLayouts/slideLayout3.xml"
@@ -1250,15 +1280,16 @@ slideToSlideRelElement slide idNum = do
1250 , ("Target", target)] ()
1280 , ("Target", target)] ()
1251 ] ++ linkRels ++ mediaRels)
1281 ] ++ linkRels ++ mediaRels)
1252
1282
1253−slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element
1283+slideToSldIdElement :: PandocMonad m => Slide -> P m Element
1254−slideToSldIdElement slide idNum = do
1284+slideToSldIdElement slide = do
1285+ n <- slideNum slide
1255− let id' = show $ idNum + 255
1286+ let id' = show $ n + 255
1256− rId <- slideToSlideId slide idNum
1287+ rId <- slideToRelId slide
1257 return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()
1288 return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()
1258
1289
1259presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
1290presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
1260presentationToSldIdLst (Presentation slides) = do
1291presentationToSldIdLst (Presentation slides) = do
1261− ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])
1292+ ids <- mapM slideToSldIdElement slides
1262 return $ mknode "p:sldIdLst" [] ids
1293 return $ mknode "p:sldIdLst" [] ids
1263
1294
1264presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element
1295presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element
@@ -1366,12 +1397,10 @@ presentationToContentTypes (Presentation slides) = do
1366
1397
1367 inheritedOverrides = mapMaybe pathToOverride filePaths
1398 inheritedOverrides = mapMaybe pathToOverride filePaths
1368 presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
1399 presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
1400+ relativePaths <- mapM slideToFilePath slides
1369− slideOverrides =
1401+ let slideOverrides = mapMaybe
1370− mapMaybe
1371− (\(s, n) ->
1372− pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)
1402+ (\fp -> pathToOverride $ "ppt/slides/" ++ fp)
1373− (zip slides [1..])
1403+ relativePaths
1374− -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]
1375 return $ ContentTypes
1404 return $ ContentTypes
1376 (defaults ++ mediaDefaults)
1405 (defaults ++ mediaDefaults)
1377 (inheritedOverrides ++ presOverride ++ slideOverrides)
1406 (inheritedOverrides ++ presOverride ++ slideOverrides)
src/Text/Pandoc/Writers/Powerpoint/Presentation.hs+25−23
@@ -128,11 +128,13 @@ data Presentation = Presentation [Slide]
128 deriving (Show)
128 deriving (Show)
129
129
130
130
131−data Slide = Slide SlideId Layout (Maybe Notes)
131+data Slide = Slide { slideId :: SlideId
132+ , slideLayout :: Layout
133+ , slideNotes :: (Maybe Notes)
132− deriving (Show, Eq)
134+ } deriving (Show, Eq)
133
135
134newtype SlideId = SlideId String
136newtype SlideId = SlideId String
135− deriving (Show, Eq)
137+ deriving (Show, Eq, Ord)
136
138
137-- In theory you could have anything on a notes slide but it seems
139-- In theory you could have anything on a notes slide but it seems
138-- designed mainly for one textbox, so we'll just put in the contents
140-- designed mainly for one textbox, so we'll just put in the contents
@@ -316,9 +318,9 @@ isListType _ = False
316registerAnchorId :: String -> Pres ()
318registerAnchorId :: String -> Pres ()
317registerAnchorId anchor = do
319registerAnchorId anchor = do
318 anchorMap <- gets stAnchorMap
320 anchorMap <- gets stAnchorMap
319− slideId <- asks envCurSlideId
321+ sldId <- asks envCurSlideId
320 unless (null anchor) $
322 unless (null anchor) $
321− modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}
323+ modify $ \st -> st {stAnchorMap = M.insert anchor sldId anchorMap}
322
324
323-- Currently hardcoded, until I figure out how to make it dynamic.
325-- Currently hardcoded, until I figure out how to make it dynamic.
324blockQuoteSize :: Pixels
326blockQuoteSize :: Pixels
@@ -529,20 +531,20 @@ blocksToSlide' :: Int -> [Block] -> Pres Slide
529blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)
531blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)
530 | n < lvl = do
532 | n < lvl = do
531 registerAnchorId ident
533 registerAnchorId ident
532− slideId <- asks envCurSlideId
534+ sldId <- asks envCurSlideId
533 hdr <- inlinesToParElems ils
535 hdr <- inlinesToParElems ils
534− return $ Slide slideId (TitleSlide {titleSlideHeader = hdr}) Nothing
536+ return $ Slide sldId (TitleSlide {titleSlideHeader = hdr}) Nothing
535 | n == lvl = do
537 | n == lvl = do
536 registerAnchorId ident
538 registerAnchorId ident
537 hdr <- inlinesToParElems ils
539 hdr <- inlinesToParElems ils
538 -- Now get the slide without the header, and then add the header
540 -- Now get the slide without the header, and then add the header
539 -- in.
541 -- in.
540− (Slide slideId layout mbNotes) <- blocksToSlide' lvl blks
542+ slide <- blocksToSlide' lvl blks
541− let layout' = case layout of
543+ let layout = case slideLayout slide of
542 ContentSlide _ cont -> ContentSlide hdr cont
544 ContentSlide _ cont -> ContentSlide hdr cont
543 TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR
545 TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR
544− layout'' -> layout''
546+ layout' -> layout'
545− return $ Slide slideId layout' mbNotes
547+ return $ slide{slideLayout = layout}
546blocksToSlide' _ (blk : blks)
548blocksToSlide' _ (blk : blks)
547 | Div (_, classes, _) divBlks <- blk
549 | Div (_, classes, _) divBlks <- blk
548 , "columns" `elem` classes
550 , "columns" `elem` classes
@@ -562,9 +564,9 @@ blocksToSlide' _ (blk : blks)
562 [] -> []
564 [] -> []
563 shapesL <- blocksToShapes blksL'
565 shapesL <- blocksToShapes blksL'
564 shapesR <- blocksToShapes blksR'
566 shapesR <- blocksToShapes blksR'
565− slideId <- asks envCurSlideId
567+ sldId <- asks envCurSlideId
566 return $ Slide
568 return $ Slide
567− slideId
569+ sldId
568 TwoColumnSlide { twoColumnSlideHeader = []
570 TwoColumnSlide { twoColumnSlideHeader = []
569 , twoColumnSlideLeft = shapesL
571 , twoColumnSlideLeft = shapesL
570 , twoColumnSlideRight = shapesR
572 , twoColumnSlideRight = shapesR
@@ -575,19 +577,19 @@ blocksToSlide' _ (blk : blks) = do
575 shapes <- if inNoteSlide
577 shapes <- if inNoteSlide
576 then forceFontSize noteSize $ blocksToShapes (blk : blks)
578 then forceFontSize noteSize $ blocksToShapes (blk : blks)
577 else blocksToShapes (blk : blks)
579 else blocksToShapes (blk : blks)
578− slideId <- asks envCurSlideId
580+ sldId <- asks envCurSlideId
579 return $
581 return $
580 Slide
582 Slide
581− slideId
583+ sldId
582 ContentSlide { contentSlideHeader = []
584 ContentSlide { contentSlideHeader = []
583 , contentSlideContent = shapes
585 , contentSlideContent = shapes
584 }
586 }
585 Nothing
587 Nothing
586blocksToSlide' _ [] = do
588blocksToSlide' _ [] = do
587− slideId <- asks envCurSlideId
589+ sldId <- asks envCurSlideId
588 return $
590 return $
589 Slide
591 Slide
590− slideId
592+ sldId
591 ContentSlide { contentSlideHeader = []
593 ContentSlide { contentSlideHeader = []
592 , contentSlideContent = []
594 , contentSlideContent = []
593 }
595 }
@@ -645,13 +647,13 @@ getMetaSlide = do
645 _ -> []
647 _ -> []
646 authors <- mapM inlinesToParElems $ docAuthors meta
648 authors <- mapM inlinesToParElems $ docAuthors meta
647 date <- inlinesToParElems $ docDate meta
649 date <- inlinesToParElems $ docDate meta
648− slideId <- asks envCurSlideId
650+ sldId <- asks envCurSlideId
649 if null title && null subtitle && null authors && null date
651 if null title && null subtitle && null authors && null date
650 then return Nothing
652 then return Nothing
651 else return $
653 else return $
652 Just $
654 Just $
653 Slide
655 Slide
654− slideId
656+ sldId
655 MetadataSlide { metadataSlideTitle = title
657 MetadataSlide { metadataSlideTitle = title
656 , metadataSlideSubtitle = subtitle
658 , metadataSlideSubtitle = subtitle
657 , metadataSlideAuthors = authors
659 , metadataSlideAuthors = authors
@@ -737,13 +739,13 @@ applyToLayout f (TwoColumnSlide hdr contentL contentR) = do
737 return $ TwoColumnSlide hdr' contentL' contentR'
739 return $ TwoColumnSlide hdr' contentL' contentR'
738
740
739applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide
741applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide
740−applyToSlide f (Slide slideId layout mbNotes) = do
742+applyToSlide f slide = do
741− layout' <- applyToLayout f layout
743+ layout' <- applyToLayout f $ slideLayout slide
742− mbNotes' <- case mbNotes of
744+ mbNotes' <- case slideNotes slide of
743 Just (Notes notes) -> (Just . Notes) <$>
745 Just (Notes notes) -> (Just . Notes) <$>
744 mapM (applyToParagraph f) notes
746 mapM (applyToParagraph f) notes
745 Nothing -> return Nothing
747 Nothing -> return Nothing
746− return $ Slide slideId layout' mbNotes'
748+ return slide{slideLayout = layout', slideNotes = mbNotes'}
747
749
748replaceAnchor :: ParaElem -> Pres ParaElem
750replaceAnchor :: ParaElem -> Pres ParaElem
749replaceAnchor (Run rProps s)
751replaceAnchor (Run rProps s)