From 575a360c6c1c49f6ce04b6dbde0ed167d40b9f48 Mon Sep 17 00:00:00 2001
From: Jesse Rosenthal <jrosenthal@jhu.edu>
Date: Sat, 17 Feb 2018 15:57:40 -0500
Subject: Powerpoint writer: Output speaker notes.
There are a number of interlocking parts here. The main thing to note
is that, to match the MSPowerPoint-generated pptx files, we only
include the notesMaster and notesSlide files if there are notes. This
means we have to be careful with the rIds, and build a number of files
conditionally.
---
src/Text/Pandoc/Writers/Powerpoint/Output.hs | 312 ++++++++++++++++++++++++---
1 file changed, 287 insertions(+), 25 deletions(-)
(limited to 'src/Text/Pandoc/Writers/Powerpoint')
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
index 1ed021086..801e0485e 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
@@ -56,7 +56,7 @@ import Text.Pandoc.MIME
import qualified Data.ByteString.Lazy as BL
import Text.Pandoc.Writers.OOXML
import qualified Data.Map as M
-import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, isJust)
+import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, isJust, maybeToList, catMaybes)
import Text.Pandoc.ImageSize
import Control.Applicative ((<|>))
import System.FilePath.Glob
@@ -109,6 +109,11 @@ data WriterEnv = WriterEnv { envRefArchive :: Archive
, envSlideIdOffset :: Int
, envContentType :: ContentType
, envSlideIdMap :: M.Map SlideId Int
+ -- maps the slide number to the
+ -- corresponding notes id number. If there
+ -- are no notes for a slide, there will be
+ -- no entry in the map for it.
+ , envSpeakerNotesIdMap :: M.Map Int Int
}
deriving (Show)
@@ -125,6 +130,7 @@ instance Default WriterEnv where
, envSlideIdOffset = 1
, envContentType = NormalContent
, envSlideIdMap = mempty
+ , envSpeakerNotesIdMap = mempty
}
data ContentType = NormalContent
@@ -185,7 +191,7 @@ alwaysInheritedPatterns =
-- We only look for these under special conditions
contingentInheritedPatterns :: Presentation -> [Pattern]
contingentInheritedPatterns pres = [] ++
- if hasSpeakerNotes pres
+ if presHasSpeakerNotes pres
then map compile [ "ppt/notesMasters/notesMaster*.xml"
, "ppt/notesMasters/_rels/notesMaster*.xml.rels"
, "ppt/theme/theme2.xml"
@@ -253,6 +259,8 @@ presentationToArchiveP p@(Presentation docProps slides) = do
presRelsEntry <- presentationToRelsEntry p
slideEntries <- mapM slideToEntry slides
slideRelEntries <- mapM slideToSlideRelEntry slides
+ spkNotesEntries <- catMaybes <$> mapM slideToSpeakerNotesEntry slides
+ spkNotesRelEntries <- catMaybes <$> mapM slideToSpeakerNotesRelEntry slides
-- These have to come after everything, because they need the info
-- built up in the state.
mediaEntries <- makeMediaEntries
@@ -261,6 +269,8 @@ presentationToArchiveP p@(Presentation docProps slides) = do
return $ foldr addEntryToArchive newArch' $
slideEntries ++
slideRelEntries ++
+ spkNotesEntries ++
+ spkNotesRelEntries ++
mediaEntries ++
[contentTypesEntry, docPropsEntry, relsEntry, presEntry, presRelsEntry]
@@ -268,6 +278,12 @@ makeSlideIdMap :: Presentation -> M.Map SlideId Int
makeSlideIdMap (Presentation _ slides) =
M.fromList $ (map slideId slides) `zip` [1..]
+makeSpeakerNotesMap :: Presentation -> M.Map Int Int
+makeSpeakerNotesMap (Presentation _ slides) =
+ M.fromList $ (mapMaybe f $ slides `zip` [1..]) `zip` [1..]
+ where f (Slide _ _ Nothing, _) = Nothing
+ f (Slide _ _ (Just _), n) = Just n
+
presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive
presentationToArchive opts pres = do
distArchive <- (toArchive . BL.fromStrict) <$>
@@ -291,6 +307,7 @@ presentationToArchive opts pres = do
, envOpts = opts
, envPresentationSize = presSize
, envSlideIdMap = makeSlideIdMap pres
+ , envSpeakerNotesIdMap = makeSpeakerNotesMap pres
}
let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
@@ -304,8 +321,14 @@ presentationToArchive opts pres = do
-- Check to see if the presentation has speaker notes. This will
-- influence whether we import the notesMaster template.
-hasSpeakerNotes :: Presentation -> Bool
-hasSpeakerNotes (Presentation _ slides) = any isJust $ map slideSpeakerNotes slides
+presHasSpeakerNotes :: Presentation -> Bool
+presHasSpeakerNotes (Presentation _ slides) = any isJust $ map slideSpeakerNotes slides
+
+curSlideHasSpeakerNotes :: PandocMonad m => P m Bool
+curSlideHasSpeakerNotes = do
+ sldId <- asks envCurSlideId
+ notesIdMap <- asks envSpeakerNotesIdMap
+ return $ isJust $ M.lookup sldId notesIdMap
--------------------------------------------------
@@ -448,15 +471,16 @@ registerLink link = do
curSlideId <- asks envCurSlideId
linkReg <- gets stLinkIds
mediaReg <- gets stMediaIds
+ hasSpeakerNotes <- curSlideHasSpeakerNotes
let maxLinkId = case M.lookup curSlideId linkReg of
Just mp -> case M.keys mp of
- [] -> 1
+ [] -> if hasSpeakerNotes then 2 else 1
ks -> maximum ks
- Nothing -> 1
+ Nothing -> if hasSpeakerNotes then 2 else 1
maxMediaId = case M.lookup curSlideId mediaReg of
- Just [] -> 1
+ Just [] -> if hasSpeakerNotes then 2 else 1
Just mInfos -> maximum $ map mInfoLocalId mInfos
- Nothing -> 1
+ Nothing -> if hasSpeakerNotes then 2 else 1
maxId = max maxLinkId maxMediaId
slideLinks = case M.lookup curSlideId linkReg of
Just mp -> M.insert (maxId + 1) link mp
@@ -470,15 +494,16 @@ registerMedia fp caption = do
linkReg <- gets stLinkIds
mediaReg <- gets stMediaIds
globalIds <- gets stMediaGlobalIds
+ hasSpeakerNotes <- curSlideHasSpeakerNotes
let maxLinkId = case M.lookup curSlideId linkReg of
Just mp -> case M.keys mp of
- [] -> 1
+ [] -> if hasSpeakerNotes then 2 else 1
ks -> maximum ks
- Nothing -> 1
+ Nothing -> if hasSpeakerNotes then 2 else 1
maxMediaId = case M.lookup curSlideId mediaReg of
- Just [] -> 1
+ Just [] -> if hasSpeakerNotes then 2 else 1
Just mInfos -> maximum $ map mInfoLocalId mInfos
- Nothing -> 1
+ Nothing -> if hasSpeakerNotes then 2 else 1
maxLocalId = max maxLinkId maxMediaId
maxGlobalId = case M.elems globalIds of
@@ -973,6 +998,21 @@ getShapeByName ns spTreeElem name
filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem
| otherwise = Nothing
+
+
+getShapeByPlaceHolderType :: NameSpaces -> Element -> String -> Maybe Element
+getShapeByPlaceHolderType ns spTreeElem phType
+ | isElem ns "p" "spTree" spTreeElem =
+ let findPhType element = isElem ns "p" "sp" element &&
+ Just phType == (Just element >>=
+ findChild (elemName ns "p" "nvSpPr") >>=
+ findChild (elemName ns "p" "nvPr") >>=
+ findChild (elemName ns "p" "ph") >>=
+ findAttr (QName "type" Nothing Nothing))
+ in
+ filterChild findPhType spTreeElem
+ | otherwise = Nothing
+
-- getShapeById :: NameSpaces -> Element -> String -> Maybe Element
-- getShapeById ns spTreeElem ident
-- | isElem ns "p" "spTree" spTreeElem =
@@ -1109,6 +1149,148 @@ slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems da
("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
] [mknode "p:cSld" [] [spTree]]
+
+--------------------------------------------------------------------
+-- Notes:
+
+getNotesMaster :: PandocMonad m => P m Element
+getNotesMaster = do
+ let notesMasterPath = "ppt/notesMasters/notesMaster1.xml"
+ distArchive <- asks envDistArchive
+ root <- case findEntryByPath notesMasterPath distArchive of
+ Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of
+ Just element -> return $ element
+ Nothing -> throwError $
+ PandocSomeError $
+ notesMasterPath ++ " corrupt in reference file"
+ Nothing -> throwError $
+ PandocSomeError $
+ notesMasterPath ++ " missing in reference file"
+ return root
+
+getSlideNumberFieldId :: PandocMonad m => Element -> P m String
+getSlideNumberFieldId notesMaster
+ | ns <- elemToNameSpaces notesMaster
+ , Just cSld <- findChild (elemName ns "p" "cSld") notesMaster
+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld
+ , Just sp <- getShapeByPlaceHolderType ns spTree "sldNum"
+ , Just txBody <- findChild (elemName ns "p" "txBody") sp
+ , Just p <- findChild (elemName ns "a" "p") txBody
+ , Just fld <- findChild (elemName ns "a" "fld") p
+ , Just fldId <- findAttr (QName "id" Nothing Nothing) fld =
+ return fldId
+ | otherwise = throwError $
+ PandocSomeError $
+ "No field id for slide numbers in notesMaster.xml"
+
+speakerNotesSlideImage :: Element
+speakerNotesSlideImage =
+ mknode "p:sp" [] $
+ [ mknode "p:nvSpPr" [] $
+ [ mknode "p:cNvPr" [ ("id", "2")
+ , ("name", "Slide Image Placeholder 1")
+ ] ()
+ , mknode "p:cNvSpPr" [] $
+ [ mknode "a:spLocks" [ ("noGrp", "1")
+ , ("noRot", "1")
+ , ("noChangeAspect", "1")
+ ] ()
+ ]
+ , mknode "p:nvPr" [] $
+ [ mknode "p:ph" [("type", "sldImg")] ()]
+ ]
+ , mknode "p:spPr" [] ()
+ ]
+
+speakerNotesBody :: PandocMonad m => [Paragraph] -> P m Element
+speakerNotesBody paras = do
+ elements <- mapM paragraphToElement paras
+ let txBody = mknode "p:txBody" [] $
+ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
+ return $
+ mknode "p:sp" [] $
+ [ mknode "p:nvSpPr" [] $
+ [ mknode "p:cNvPr" [ ("id", "3")
+ , ("name", "Notes Placeholder 2")
+ ] ()
+ , mknode "p:cNvSpPr" [] $
+ [ mknode "a:spLocks" [("noGrp", "1")] ()]
+ , mknode "p:nvPr" [] $
+ [ mknode "p:ph" [("type", "body"), ("idx", "1")] ()]
+ ]
+ , mknode "p:spPr" [] ()
+ , txBody
+ ]
+
+speakerNotesSlideNumber :: Int -> String -> Element
+speakerNotesSlideNumber pgNum fieldId =
+ mknode "p:sp" [] $
+ [ mknode "p:nvSpPr" [] $
+ [ mknode "p:cNvPr" [ ("id", "4")
+ , ("name", "Slide Number Placeholder 3")
+ ] ()
+ , mknode "p:cNvSpPr" [] $
+ [ mknode "a:spLocks" [("noGrp", "1")] ()]
+ , mknode "p:nvPr" [] $
+ [ mknode "p:ph" [ ("type", "sldNum")
+ , ("sz", "quarter")
+ , ("idx", "10")
+ ] ()
+ ]
+ ]
+ , mknode "p:spPr" [] ()
+ , mknode "p:txBody" [] $
+ [ mknode "a:bodyPr" [] ()
+ , mknode "a:lstStyle" [] ()
+ , mknode "a:p" [] $
+ [ mknode "a:fld" [ ("id", fieldId)
+ , ("type", "slidenum")
+ ]
+ [ mknode "a:rPr" [("lang", "en-US")] ()
+ , mknode "a:t" [] (show pgNum)
+ ]
+ , mknode "a:endParaRPr" [("lang", "en-US")] ()
+ ]
+ ]
+ ]
+
+slideToSpeakerNotesElement :: PandocMonad m => Slide -> P m (Maybe Element)
+slideToSpeakerNotesElement sld@(Slide _ _ mbNotes)
+ | Nothing <- mbNotes = return Nothing
+ | Just (SpeakerNotes paras) <- mbNotes = do
+ master <- getNotesMaster
+ fieldId <- getSlideNumberFieldId master
+ num <- slideNum sld
+ let imgShape = speakerNotesSlideImage
+ sldNumShape = speakerNotesSlideNumber num fieldId
+ bodyShape <- speakerNotesBody paras
+ return $ Just $
+ mknode "p:notes"
+ [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main")
+ , ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships")
+ , ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
+ ] [ mknode "p:cSld" []
+ [ mknode "p:spTree" []
+ [ mknode "p:nvGrpSpPr" []
+ [ mknode "p:cNvPr" [("id", "1"), ("name", "")] ()
+ , mknode "p:cNvGrpSpPr" [] ()
+ , mknode "p:nvPr" [] ()
+ ]
+ , mknode "p:grpSpPr" []
+ [ mknode "a:xfrm" []
+ [ mknode "a:off" [("x", "0"), ("y", "0")] ()
+ , mknode "a:ext" [("cx", "0"), ("cy", "0")] ()
+ , mknode "a:chOff" [("x", "0"), ("y", "0")] ()
+ , mknode "a:chExt" [("cx", "0"), ("cy", "0")] ()
+ ]
+ ]
+ , imgShape
+ , bodyShape
+ , sldNumShape
+ ]
+ ]
+ ]
+
-----------------------------------------------------------------------
getSlideIdNum :: PandocMonad m => SlideId -> P m Int
@@ -1252,6 +1434,53 @@ slideToEntry slide = do
element <- slideToElement slide
elemToEntry ("ppt/slides/" ++ idNumToFilePath idNum) element
+slideToSpeakerNotesEntry :: PandocMonad m => Slide -> P m (Maybe Entry)
+slideToSpeakerNotesEntry slide = do
+ idNum <- slideNum slide
+ local (\env -> env{envCurSlideId = idNum}) $ do
+ mbElement <- slideToSpeakerNotesElement slide
+ mbNotesIdNum <- do mp <- asks envSpeakerNotesIdMap
+ return $ M.lookup idNum mp
+ case mbElement of
+ Just element | Just notesIdNum <- mbNotesIdNum ->
+ Just <$>
+ elemToEntry
+ ("ppt/notesSlides/notesSlide" ++ show notesIdNum ++ ".xml")
+ element
+ _ -> return Nothing
+
+slideToSpeakerNotesRelElement :: PandocMonad m => Slide -> P m (Maybe Element)
+slideToSpeakerNotesRelElement slide@(Slide _ _ mbNotes)
+ | Nothing <- mbNotes = return Nothing
+ | Just _ <- mbNotes = do
+ idNum <- slideNum slide
+ return $ Just $
+ mknode "Relationships"
+ [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
+ [ mknode "Relationship" [ ("Id", "rId2")
+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
+ , ("Target", "../slides/slide" ++ show idNum ++ ".xml")
+ ] ()
+ , mknode "Relationship" [ ("Id", "rId1")
+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster")
+ , ("Target", "../notesMasters/notesMaster1.xml")
+ ] ()
+ ]
+
+slideToSpeakerNotesRelEntry :: PandocMonad m => Slide -> P m (Maybe Entry)
+slideToSpeakerNotesRelEntry slide = do
+ idNum <- slideNum slide
+ mbElement <- slideToSpeakerNotesRelElement slide
+ mp <- asks envSpeakerNotesIdMap
+ let mbNotesIdNum = M.lookup idNum mp
+ case mbElement of
+ Just element | Just notesIdNum <- mbNotesIdNum ->
+ Just <$>
+ elemToEntry
+ ("ppt/notesSlides/_rels/notesSlide" ++ show notesIdNum ++ ".xml.rels")
+ element
+ _ -> return Nothing
+
slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry
slideToSlideRelEntry slide = do
idNum <- slideNum slide
@@ -1288,6 +1517,20 @@ mediaRelElement mInfo =
, ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)
] ()
+speakerNotesSlideRelElement :: PandocMonad m => Slide -> P m (Maybe Element)
+speakerNotesSlideRelElement slide = do
+ idNum <- slideNum slide
+ mp <- asks envSpeakerNotesIdMap
+ return $ case M.lookup idNum mp of
+ Nothing -> Nothing
+ Just n ->
+ let target = "../notesSlides/notesSlide" ++ show n ++ ".xml"
+ in Just $
+ mknode "Relationship" [ ("Id", "rId2")
+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesSlide")
+ , ("Target", target)
+ ] ()
+
slideToSlideRelElement :: PandocMonad m => Slide -> P m Element
slideToSlideRelElement slide = do
idNum <- slideNum slide
@@ -1297,6 +1540,8 @@ slideToSlideRelElement slide = do
(Slide _ (ContentSlide _ _) _) -> "../slideLayouts/slideLayout2.xml"
(Slide _ (TwoColumnSlide _ _ _) _) -> "../slideLayouts/slideLayout4.xml"
+ speakerNotesRels <- maybeToList <$> speakerNotesSlideRelElement slide
+
linkIds <- gets stLinkIds
mediaIds <- gets stMediaIds
@@ -1313,7 +1558,7 @@ slideToSlideRelElement slide = do
([mknode "Relationship" [ ("Id", "rId1")
, ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")
, ("Target", target)] ()
- ] ++ linkRels ++ mediaRels)
+ ] ++ speakerNotesRels ++ linkRels ++ mediaRels)
slideToSldIdElement :: PandocMonad m => Slide -> P m Element
slideToSldIdElement slide = do
@@ -1328,7 +1573,7 @@ presentationToSldIdLst (Presentation _ slides) = do
return $ mknode "p:sldIdLst" [] ids
presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element
-presentationToPresentationElement pres = do
+presentationToPresentationElement pres@(Presentation _ slds) = do
refArchive <- asks envRefArchive
distArchive <- asks envDistArchive
element <- parseXml refArchive distArchive "ppt/presentation.xml"
@@ -1340,18 +1585,28 @@ presentationToPresentationElement pres = do
_ -> Elem e
modifySldIdLst ct = ct
- removeSpeakerNotes' :: Content -> [Content]
- removeSpeakerNotes' (Elem e) = case elName e of
- (QName "notesMasterIdLst" _ _) -> []
- _ -> [Elem e]
- removeSpeakerNotes' ct = [ct]
+ notesMasterRId = length slds + 2
+
+ modifySpeakerNotes' :: Content -> [Content]
+ modifySpeakerNotes' (Elem e) = case elName e of
+ (QName "notesMasterIdLst" _ _) ->
+ if presHasSpeakerNotes pres
+ then [Elem $
+ mknode "p:notesMasterIdLst" []
+ [ mknode
+ "p:NotesMasterId"
+ [("r:id", "rId" ++ show notesMasterRId)]
+ ()
+ ]
+ ]
+ else []
+ _ -> [Elem e]
+ modifySpeakerNotes' ct = [ct]
- removeSpeakerNotes :: [Content] -> [Content]
- removeSpeakerNotes = if not (hasSpeakerNotes pres)
- then concatMap removeSpeakerNotes'
- else id
+ modifySpeakerNotes :: [Content] -> [Content]
+ modifySpeakerNotes = concatMap modifySpeakerNotes'
- newContent = removeSpeakerNotes $ map modifySldIdLst $ elContent element
+ newContent = modifySpeakerNotes $ map modifySldIdLst $ elContent element
return $ element{elContent = newContent}
@@ -1452,6 +1707,12 @@ mediaContentType mInfo
}
| otherwise = Nothing
+getSpeakerNotesFilePaths :: PandocMonad m => P m [FilePath]
+getSpeakerNotesFilePaths = do
+ mp <- asks envSpeakerNotesIdMap
+ let notesIdNums = M.elems mp
+ return $ map (\n -> "ppt/notesSlides/notesSlide" ++ show n ++ ".xml") notesIdNums
+
presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
presentationToContentTypes p@(Presentation _ slides) = do
mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
@@ -1471,9 +1732,10 @@ presentationToContentTypes p@(Presentation _ slides) = do
let slideOverrides = mapMaybe
(\fp -> pathToOverride $ "ppt/slides/" ++ fp)
relativePaths
+ speakerNotesOverrides <- (mapMaybe pathToOverride) <$> getSpeakerNotesFilePaths
return $ ContentTypes
(defaults ++ mediaDefaults)
- (inheritedOverrides ++ docPropsOverride ++ presOverride ++ slideOverrides)
+ (inheritedOverrides ++ docPropsOverride ++ presOverride ++ slideOverrides ++ speakerNotesOverrides)
presML :: String
presML = "application/vnd.openxmlformats-officedocument.presentationml"
--
cgit v1.2.3