0d53efe · typeable/pandoc

git.iko.soy/typeable/pandoc

Powerpoint writer: Use slideids to simplify code.

commit0d53efeddb34ecafefecb731d5b90b98571cefa2 authorJesse Rosenthal <jrosenthal@jhu.edu> dateWed 17 Jan 2018, 13:31 (9 years ago) parent63a2507

2 files changed+91−60

compare with master

unifiedsplit

src/Text/Pandoc/Writers/Powerpoint/Output.hs+66−37 src/Text/Pandoc/Writers/Powerpoint/Presentation.hs+25−23

src/Text/Pandoc/Writers/Powerpoint/Output.hs+66−37

@@ -105,6 +105,7 @@ data WriterEnv = WriterEnv { envRefArchive :: Archive

105105 -- the rId number

106106 , envSlideIdOffset :: Int

107107 , envContentType :: ContentType

108+ , envSlideIdMap :: M.Map SlideId Int

108109 }

109110 deriving (Show)

110111

@@ -120,6 +121,7 @@ instance Default WriterEnv where

120121 , envCurSlideId = 1

121122 , envSlideIdOffset = 1

122123 , envContentType = NormalContent

124+ , envSlideIdMap = mempty

123125 }

124126

125127data ContentType = NormalContent

@@ -231,8 +233,8 @@ presentationToArchiveP p@(Presentation slides) = do

231233 -- sure we know the correct offset for the rIds.

232234 presEntry <- presentationToPresEntry p

233235 presRelsEntry <- presentationToRelsEntry p

234− slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]

235− slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]

236+ slideEntries <- mapM slideToEntry slides

237+ slideRelEntries <- mapM slideToSlideRelEntry slides

236238 -- These have to come after everything, because they need the info

237239 -- built up in the state.

238240 mediaEntries <- makeMediaEntries

@@ -244,6 +246,10 @@ presentationToArchiveP p@(Presentation slides) = do

244246 mediaEntries ++

245247 [contentTypesEntry, relsEntry, presEntry, presRelsEntry]

246248

249+makeSlideIdMap :: Presentation -> M.Map SlideId Int

250+makeSlideIdMap (Presentation slides) =

251+ M.fromList $ (map slideId slides) `zip` [1..]

252+

247253presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive

248254presentationToArchive opts pres = do

249255 distArchive <- (toArchive . BL.fromStrict) <$>

@@ -266,6 +272,7 @@ presentationToArchive opts pres = do

266272 , envUTCTime = utctime

267273 , envOpts = opts

268274 , envPresentationSize = presSize

275+ , envSlideIdMap = makeSlideIdMap pres

269276 }

270277

271278 let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive

@@ -1069,13 +1076,31 @@ slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems da

10691076

10701077-----------------------------------------------------------------------

10711078

1072−slideToFilePath :: Slide -> Int -> FilePath

1073−slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"

1079+getSlideIdNum :: PandocMonad m => SlideId -> P m Int

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."

10741087

1075−slideToSlideId :: Monad m => Slide -> Int -> P m String

1076−slideToSlideId _ idNum = do

1077− n <- asks envSlideIdOffset

1078− return $ "rId" ++ (show $ idNum + n)

1088+slideNum :: PandocMonad m => Slide -> P m Int

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

1102+ offset <- asks envSlideIdOffset

1103+ return $ "rId" ++ (show $ n + offset)

10791104

10801105

10811106data Relationship = Relationship { relId :: Int

@@ -1096,11 +1121,12 @@ elementToRel element

10961121 return $ Relationship num type' target

10971122 | otherwise = Nothing

10981123

1099−slideToPresRel :: Monad m => Slide -> Int -> P m Relationship

1100−slideToPresRel slide idNum = do

1124+slideToPresRel :: PandocMonad m => Slide -> P m Relationship

1125+slideToPresRel slide = do

1126+ idNum <- slideNum slide

11011127 n <- asks envSlideIdOffset

11021128 let rId = idNum + n

1103− fp = "slides/" ++ slideToFilePath slide idNum

1129+ fp = "slides/" ++ idNumToFilePath idNum

11041130 return $ Relationship { relId = rId

11051131 , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"

11061132 , relTarget = fp

@@ -1117,7 +1143,7 @@ getRels = do

11171143

11181144presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]

11191145presentationToRels (Presentation slides) = do

1120− mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]

1146+ mySlideRels <- mapM slideToPresRel slides

11211147 rels <- getRels

11221148 let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels

11231149 -- We want to make room for the slides in the id space. The slides

@@ -1184,27 +1210,30 @@ elemToEntry fp element = do

11841210 epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime

11851211 return $ toEntry fp epochtime $ renderXml element

11861212

1187−slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry

1188−slideToEntry slide idNum = do

1213+slideToEntry :: PandocMonad m => Slide -> P m Entry

1214+slideToEntry slide = do

1215+ idNum <- slideNum slide

11891216 local (\env -> env{envCurSlideId = idNum}) $ do

11901217 element <- slideToElement slide

1191− elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element

1218+ elemToEntry ("ppt/slides/" ++ idNumToFilePath idNum) element

11921219

1193−slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry

1194−slideToSlideRelEntry slide idNum = do

1195− element <- slideToSlideRelElement slide idNum

1196− elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element

1220+slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry

1221+slideToSlideRelEntry slide = do

1222+ idNum <- slideNum slide

1223+ element <- slideToSlideRelElement slide

1224+ elemToEntry ("ppt/slides/_rels/" ++ idNumToFilePath idNum ++ ".rels") element

11971225

11981226linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element

1199−linkRelElement idNum (InternalTarget num) = do

1227+linkRelElement rIdNum (InternalTarget targetId) = do

1228+ targetIdNum <- getSlideIdNum targetId

12001229 return $

1201− mknode "Relationship" [ ("Id", "rId" ++ show idNum)

1230+ mknode "Relationship" [ ("Id", "rId" ++ show rIdNum)

12021231 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")

1203− , ("Target", "slide" ++ show num ++ ".xml")

1232+ , ("Target", "slide" ++ show targetIdNum ++ ".xml")

12041233 ] ()

1205−linkRelElement idNum (ExternalTarget (url, _)) = do

1234+linkRelElement rIdNum (ExternalTarget (url, _)) = do

12061235 return $

1207− mknode "Relationship" [ ("Id", "rId" ++ show idNum)

1236+ mknode "Relationship" [ ("Id", "rId" ++ show rIdNum)

12081237 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")

12091238 , ("Target", url)

12101239 , ("TargetMode", "External")

@@ -1224,8 +1253,9 @@ mediaRelElement mInfo =

12241253 , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)

12251254 ] ()

12261255

1227−slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element

1228−slideToSlideRelElement slide idNum = do

1256+slideToSlideRelElement :: PandocMonad m => Slide -> P m Element

1257+slideToSlideRelElement slide = do

1258+ idNum <- slideNum slide

12291259 let target = case slide of

12301260 (Slide _ (MetadataSlide _ _ _ _) _) -> "../slideLayouts/slideLayout1.xml"

12311261 (Slide _ (TitleSlide _) _) -> "../slideLayouts/slideLayout3.xml"

@@ -1250,15 +1280,16 @@ slideToSlideRelElement slide idNum = do

12501280 , ("Target", target)] ()

12511281 ] ++ linkRels ++ mediaRels)

12521282

1253−slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element

1254−slideToSldIdElement slide idNum = do

1255− let id' = show $ idNum + 255

1256− rId <- slideToSlideId slide idNum

1283+slideToSldIdElement :: PandocMonad m => Slide -> P m Element

1284+slideToSldIdElement slide = do

1285+ n <- slideNum slide

1286+ let id' = show $ n + 255

1287+ rId <- slideToRelId slide

12571288 return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()

12581289

12591290presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element

12601291presentationToSldIdLst (Presentation slides) = do

1261− ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])

1292+ ids <- mapM slideToSldIdElement slides

12621293 return $ mknode "p:sldIdLst" [] ids

12631294

12641295presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element

@@ -1366,12 +1397,10 @@ presentationToContentTypes (Presentation slides) = do

13661397

13671398 inheritedOverrides = mapMaybe pathToOverride filePaths

13681399 presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]

1369− slideOverrides =

1370− mapMaybe

1371− (\(s, n) ->

1372− pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)

1373− (zip slides [1..])

1374− -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]

1400+ relativePaths <- mapM slideToFilePath slides

1401+ let slideOverrides = mapMaybe

1402+ (\fp -> pathToOverride $ "ppt/slides/" ++ fp)

1403+ relativePaths

13751404 return $ ContentTypes

13761405 (defaults ++ mediaDefaults)

13771406 (inheritedOverrides ++ presOverride ++ slideOverrides)

src/Text/Pandoc/Writers/Powerpoint/Presentation.hs+25−23

@@ -128,11 +128,13 @@ data Presentation = Presentation [Slide]

128128 deriving (Show)

129129

130130

131−data Slide = Slide SlideId Layout (Maybe Notes)

132− deriving (Show, Eq)

131+data Slide = Slide { slideId :: SlideId

132+ , slideLayout :: Layout

133+ , slideNotes :: (Maybe Notes)

134+ } deriving (Show, Eq)

133135

134136newtype SlideId = SlideId String

135− deriving (Show, Eq)

137+ deriving (Show, Eq, Ord)

136138

137139-- In theory you could have anything on a notes slide but it seems

138140-- designed mainly for one textbox, so we'll just put in the contents

@@ -316,9 +318,9 @@ isListType _ = False

316318registerAnchorId :: String -> Pres ()

317319registerAnchorId anchor = do

318320 anchorMap <- gets stAnchorMap

319− slideId <- asks envCurSlideId

321+ sldId <- asks envCurSlideId

320322 unless (null anchor) $

321− modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}

323+ modify $ \st -> st {stAnchorMap = M.insert anchor sldId anchorMap}

322324

323325-- Currently hardcoded, until I figure out how to make it dynamic.

324326blockQuoteSize :: Pixels

@@ -529,20 +531,20 @@ blocksToSlide' :: Int -> [Block] -> Pres Slide

529531blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)

530532 | n < lvl = do

531533 registerAnchorId ident

532− slideId <- asks envCurSlideId

534+ sldId <- asks envCurSlideId

533535 hdr <- inlinesToParElems ils

534− return $ Slide slideId (TitleSlide {titleSlideHeader = hdr}) Nothing

536+ return $ Slide sldId (TitleSlide {titleSlideHeader = hdr}) Nothing

535537 | n == lvl = do

536538 registerAnchorId ident

537539 hdr <- inlinesToParElems ils

538540 -- Now get the slide without the header, and then add the header

539541 -- in.

540− (Slide slideId layout mbNotes) <- blocksToSlide' lvl blks

541− let layout' = case layout of

542+ slide <- blocksToSlide' lvl blks

543+ let layout = case slideLayout slide of

542544 ContentSlide _ cont -> ContentSlide hdr cont

543545 TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR

544− layout'' -> layout''

545− return $ Slide slideId layout' mbNotes

546+ layout' -> layout'

547+ return $ slide{slideLayout = layout}

546548blocksToSlide' _ (blk : blks)

547549 | Div (_, classes, _) divBlks <- blk

548550 , "columns" `elem` classes

@@ -562,9 +564,9 @@ blocksToSlide' _ (blk : blks)

562564 [] -> []

563565 shapesL <- blocksToShapes blksL'

564566 shapesR <- blocksToShapes blksR'

565− slideId <- asks envCurSlideId

567+ sldId <- asks envCurSlideId

566568 return $ Slide

567− slideId

569+ sldId

568570 TwoColumnSlide { twoColumnSlideHeader = []

569571 , twoColumnSlideLeft = shapesL

570572 , twoColumnSlideRight = shapesR

@@ -575,19 +577,19 @@ blocksToSlide' _ (blk : blks) = do

575577 shapes <- if inNoteSlide

576578 then forceFontSize noteSize $ blocksToShapes (blk : blks)

577579 else blocksToShapes (blk : blks)

578− slideId <- asks envCurSlideId

580+ sldId <- asks envCurSlideId

579581 return $

580582 Slide

581− slideId

583+ sldId

582584 ContentSlide { contentSlideHeader = []

583585 , contentSlideContent = shapes

584586 }

585587 Nothing

586588blocksToSlide' _ [] = do

587− slideId <- asks envCurSlideId

589+ sldId <- asks envCurSlideId

588590 return $

589591 Slide

590− slideId

592+ sldId

591593 ContentSlide { contentSlideHeader = []

592594 , contentSlideContent = []

593595 }

@@ -645,13 +647,13 @@ getMetaSlide = do

645647 _ -> []

646648 authors <- mapM inlinesToParElems $ docAuthors meta

647649 date <- inlinesToParElems $ docDate meta

648− slideId <- asks envCurSlideId

650+ sldId <- asks envCurSlideId

649651 if null title && null subtitle && null authors && null date

650652 then return Nothing

651653 else return $

652654 Just $

653655 Slide

654− slideId

656+ sldId

655657 MetadataSlide { metadataSlideTitle = title

656658 , metadataSlideSubtitle = subtitle

657659 , metadataSlideAuthors = authors

@@ -737,13 +739,13 @@ applyToLayout f (TwoColumnSlide hdr contentL contentR) = do

737739 return $ TwoColumnSlide hdr' contentL' contentR'

738740

739741applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide

740−applyToSlide f (Slide slideId layout mbNotes) = do

741− layout' <- applyToLayout f layout

742− mbNotes' <- case mbNotes of

742+applyToSlide f slide = do

743+ layout' <- applyToLayout f $ slideLayout slide

744+ mbNotes' <- case slideNotes slide of

743745 Just (Notes notes) -> (Just . Notes) <$>

744746 mapM (applyToParagraph f) notes

745747 Nothing -> return Nothing

746− return $ Slide slideId layout' mbNotes'

748+ return slide{slideLayout = layout', slideNotes = mbNotes'}

747749

748750replaceAnchor :: ParaElem -> Pres ParaElem

749751replaceAnchor (Run rProps s)