Powerpoint writer: Add anchor links

For anchor-type links (`[foo](#bar)`) we produce an anchor link. In
powerpoint these are links to slides, so we keep track of a map
relating anchors to the slides they occur on.

1 files changed, 47 insertions, 20 deletions

diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs
index 1509f967f..990d90433 100644
--- a/src/Text/Pandoc/Writers/Powerpoint.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint.hs
@@ -146,8 +146,8 @@ data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String)
                                , stMediaIds :: M.Map Int [MediaInfo]
                                , stMediaGlobalIds :: M.Map FilePath Int
                                , stNoteIds :: M.Map Int [Block]
-                               -- anchors in the current slide
-                               , stCurSlideAnchors :: M.Map String Int
+                               -- associate anchors with slide id
+                               , stAnchorMap :: M.Map String Int
                                } deriving (Show, Eq)
 
 instance Default WriterState where
@@ -155,7 +155,7 @@ instance Default WriterState where
                     , stMediaIds = mempty
                     , stMediaGlobalIds = mempty
                     , stNoteIds = mempty
-                    , stCurSlideAnchors = mempty
+                    , stAnchorMap= mempty
                     }
 
 type P m = ReaderT WriterEnv (StateT WriterState m)
@@ -377,6 +377,13 @@ isListType (BulletList _) = True
 isListType (DefinitionList _) = True
 isListType _ = False
 
+registerAnchorId :: PandocMonad m => String -> P m ()
+registerAnchorId anchor = do
+  anchorMap <- gets stAnchorMap
+  slideId <- asks envCurSlideId
+  unless (null anchor) $
+    modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}
+
 blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph]
 blockToParagraphs (Plain ils) = do
   parElems <- inlinesToParElems ils
@@ -407,7 +414,11 @@ blockToParagraphs (BlockQuote blks) =
   concatMapM blockToParagraphs blks
 -- TODO: work out the format
 blockToParagraphs (RawBlock _ _) = return []
-blockToParagraphs (Header n _ ils) = do
+blockToParagraphs (Header n (ident, _, _) ils) = do
+  -- Note that this function will only touch headers that are not at
+  -- the beginning of slides -- all the rest will be taken care of by
+  -- `blocksToSlide'`. We have the register anchors in both of them.
+  registerAnchorId ident
   slideLevel <- asks envSlideLevel
   parElems <- inlinesToParElems ils
   -- For the time being we're not doing headers inside of bullets, but
@@ -564,11 +575,13 @@ splitBlocks :: Monad m => [Block] -> P m [[Block]]
 splitBlocks = splitBlocks' [] []
 
 blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide
-blocksToSlide' lvl ((Header n _ ils) : blks)
+blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)
   | n < lvl = do
+      registerAnchorId ident
       hdr <- inlinesToParElems ils
       return $ TitleSlide {titleSlideHeader = hdr}
   | n == lvl = do
+      registerAnchorId ident
       hdr <- inlinesToParElems ils
       -- Now get the slide without the header, and then add the header
       -- in.
@@ -1141,11 +1154,15 @@ paraElemToElement (Run rpr s) = do
                 Nothing -> []) ++
              []
   linkProps <- case rLink rpr of
-                 Just link -> do idNum <- registerLink link
-                                 return [mknode "a:hlinkClick"
-                                          [("r:id", "rId" ++ show idNum)]
-                                          ()
-                                        ]
+                 Just link -> do
+                   idNum <- registerLink link
+                   let (url, _) = link
+                       linkAttrs = [("r:id", "rId" ++ show idNum)]
+                       -- we have to add an extra action if it's an anchor.
+                       linkAttrs' = linkAttrs ++ case url of
+                         '#' : _ -> [("action", "ppaction://hlinksldjump")]
+                         _       -> []
+                   return [mknode "a:hlinkClick" linkAttrs' ()]
                  Nothing -> return []
   let propContents = if rPropCode rpr
                      then [mknode "a:latin" [("typeface", "Courier")] ()]
@@ -1576,16 +1593,26 @@ slideToSlideRelEntry slide idNum = do
   element <- slideToSlideRelElement slide idNum
   elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element
 
-linkRelElement :: Int -> (URL, String) -> Element
-linkRelElement idNum (url, _) =
-  mknode "Relationship" [ ("Id", "rId" ++ show idNum)
-                        , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
+linkRelElement :: PandocMonad m => Int -> (URL, String) -> P m Element
+linkRelElement idNum (url, _) = do
+  anchorMap <- gets stAnchorMap
+  case url of
+    '#' : anchor | Just num <- M.lookup anchor anchorMap ->
+      return $
+      mknode "Relationship" [ ("Id", "rId" ++ show idNum)
+                            , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
+                            , ("Target", "slide" ++ show num ++ ".xml")
+                            ] ()
+    _ ->
+      return $
+      mknode "Relationship" [ ("Id", "rId" ++ show idNum)
+                            , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
                         , ("Target", url)
                         , ("TargetMode", "External")
                         ] ()
 
-linkRelElements :: M.Map Int (URL, String) -> [Element]
-linkRelElements mp = map (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)
+linkRelElements :: PandocMonad m => M.Map Int (URL, String) -> P m [Element]
+linkRelElements mp = mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)
 
 mediaRelElement :: MediaInfo -> Element
 mediaRelElement mInfo =
@@ -1609,10 +1636,10 @@ slideToSlideRelElement slide idNum = do
   linkIds <- gets stLinkIds
   mediaIds <- gets stMediaIds
 
-  let linkRels = case M.lookup idNum linkIds of
-                   Just mp -> linkRelElements mp
-                   Nothing -> []
-      mediaRels = case M.lookup idNum mediaIds of
+  linkRels <- case M.lookup idNum linkIds of
+                Just mp -> linkRelElements mp
+                Nothing -> return []
+  let mediaRels = case M.lookup idNum mediaIds of
                    Just mInfos -> map mediaRelElement mInfos
                    Nothing -> []