Powerpoint writer: Use slideids to simplify code.

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)