From 3156722ac413ddbc200dfcfdabcf08e7c2e1875d Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Sun, 14 Jan 2018 21:56:00 -0500 Subject: Powerpoint writer: Fix anchor links. They were broken when I refactored (the Output module wanted to use state left over from the construction of the Presentation type). This change introduces a new type `LinkTarget = InternalTarget | ExternalTarget`. Internal target points to a slide number, and these will all be resolved before the Presentation is passed along to the Output module. --- src/Text/Pandoc/Writers/Powerpoint/Output.hs | 65 +++++++----------- src/Text/Pandoc/Writers/Powerpoint/Presentation.hs | 76 +++++++++++++++++----- 2 files changed, 81 insertions(+), 60 deletions(-) (limited to 'src/Text/Pandoc') diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index f3df62690..c45479579 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -54,7 +54,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, catMaybes) +import Data.Maybe (mapMaybe, listToMaybe) import Text.Pandoc.ImageSize import Control.Applicative ((<|>)) import System.FilePath.Glob @@ -135,24 +135,16 @@ data MediaInfo = MediaInfo { mInfoFilePath :: FilePath , mInfoCaption :: Bool } deriving (Show, Eq) -data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String)) +data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int LinkTarget) -- (FP, Local ID, Global ID, Maybe Mime) , stMediaIds :: M.Map Int [MediaInfo] , stMediaGlobalIds :: M.Map FilePath Int - , stNoteIds :: M.Map Int [Block] - -- associate anchors with slide id - , stAnchorMap :: M.Map String Int - -- media inherited from the template. - , stTemplateMedia :: [FilePath] } deriving (Show, Eq) instance Default WriterState where def = WriterState { stLinkIds = mempty , stMediaIds = mempty , stMediaGlobalIds = mempty - , stNoteIds = mempty - , stAnchorMap= mempty - , stTemplateMedia = [] } type P m = ReaderT WriterEnv (StateT WriterState m) @@ -420,7 +412,7 @@ replaceNamedChildren ns prefix name newKids element = ---------------------------------------------------------------- -registerLink :: PandocMonad m => (URL, String) -> P m Int +registerLink :: PandocMonad m => LinkTarget -> P m Int registerLink link = do curSlideId <- asks envCurSlideId linkReg <- gets stLinkIds @@ -729,20 +721,15 @@ paraElemToElement (Run rpr s) = do -- first we have to make sure that if it's an -- anchor, it's in the anchor map. If not, there's -- no link. - anchorMap <- gets stAnchorMap return $ case link of - -- anchor with nothing in the map - ('#':target, _) | Nothing <- M.lookup target anchorMap -> - [] - -- anchor that is in the map - ('#':_, _) -> + InternalTarget _ -> let linkAttrs = [ ("r:id", "rId" ++ show idNum) , ("action", "ppaction://hlinksldjump") ] in [mknode "a:hlinkClick" linkAttrs ()] -- external - _ -> + ExternalTarget _ -> let linkAttrs = [ ("r:id", "rId" ++ show idNum) ] @@ -1191,31 +1178,23 @@ slideToSlideRelEntry slide idNum = do element <- slideToSlideRelElement slide idNum elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element -linkRelElement :: PandocMonad m => Int -> (URL, String) -> P m (Maybe Element) -linkRelElement idNum (url, _) = do - anchorMap <- gets stAnchorMap - case url of - -- if it's an anchor in the map, we use the slide number for an - -- internal link. - '#' : anchor | Just num <- M.lookup anchor anchorMap -> - return $ Just $ - mknode "Relationship" [ ("Id", "rId" ++ show idNum) - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") - , ("Target", "slide" ++ show num ++ ".xml") - ] () - -- if it's an anchor not in the map, we return nothing. - '#' : _ -> return Nothing - -- Anything else we treat as an external link - _ -> - return $ Just $ - mknode "Relationship" [ ("Id", "rId" ++ show idNum) - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") - , ("Target", url) - , ("TargetMode", "External") - ] () - -linkRelElements :: PandocMonad m => M.Map Int (URL, String) -> P m [Element] -linkRelElements mp = catMaybes <$> mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp) +linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element +linkRelElement idNum (InternalTarget num) = do + return $ + mknode "Relationship" [ ("Id", "rId" ++ show idNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") + , ("Target", "slide" ++ show num ++ ".xml") + ] () +linkRelElement idNum (ExternalTarget (url, _)) = do + return $ + mknode "Relationship" [ ("Id", "rId" ++ show idNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") + , ("Target", url) + , ("TargetMode", "External") + ] () + +linkRelElements :: PandocMonad m => M.Map Int LinkTarget -> P m [Element] +linkRelElements mp = mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp) mediaRelElement :: MediaInfo -> Element mediaRelElement mInfo = diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index 68b2aeeb2..e68f5eb57 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -35,7 +35,6 @@ Presentation. module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation , Presentation(..) , Slide(..) - , SlideElement(..) , Shape(..) , Graphic(..) , BulletType(..) @@ -50,6 +49,7 @@ module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation , PicProps(..) , URL , TeXString(..) + , LinkTarget(..) ) where @@ -78,10 +78,6 @@ data WriterEnv = WriterEnv { envMetadata :: Meta , envInList :: Bool , envInNoteSlide :: Bool , envCurSlideId :: Int - -- the difference between the number at - -- the end of the slide file name and - -- the rId number - , envSlideIdOffset :: Int } deriving (Show) @@ -95,7 +91,6 @@ instance Default WriterEnv where , envInList = False , envInNoteSlide = False , envCurSlideId = 1 - , envSlideIdOffset = 1 } @@ -139,9 +134,6 @@ data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem] } deriving (Show, Eq) -data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape - deriving (Show, Eq) - data Shape = Pic PicProps FilePath Text.Pandoc.Definition.Attr [ParaElem] | GraphicFrame [Graphic] [ParaElem] | TextBox [Paragraph] @@ -206,12 +198,16 @@ data Capitals = NoCapitals | SmallCapitals | AllCapitals type URL = String +data LinkTarget = ExternalTarget (URL, String) + | InternalTarget Int -- slideId + deriving (Show, Eq) + data RunProps = RunProps { rPropBold :: Bool , rPropItalics :: Bool , rStrikethrough :: Maybe Strikethrough , rBaseline :: Maybe Int , rCap :: Maybe Capitals - , rLink :: Maybe (URL, String) + , rLink :: Maybe LinkTarget , rPropCode :: Bool , rPropBlockQuote :: Bool , rPropForceSize :: Maybe Pixels @@ -229,7 +225,7 @@ instance Default RunProps where , rPropForceSize = Nothing } -data PicProps = PicProps { picPropLink :: Maybe (URL, String) +data PicProps = PicProps { picPropLink :: Maybe LinkTarget } deriving (Show, Eq) instance Default PicProps where @@ -267,7 +263,7 @@ inlineToParElems Space = inlineToParElems (Str " ") inlineToParElems SoftBreak = inlineToParElems (Str " ") inlineToParElems LineBreak = return [Break] inlineToParElems (Link _ ils (url, title)) = do - local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $ + local (\r ->r{envRunProps = (envRunProps r){rLink = Just $ ExternalTarget (url, title)}}) $ inlinesToParElems ils inlineToParElems (Code _ str) = do local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $ @@ -414,10 +410,10 @@ blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = Pic def url attr <$> (inlinesToParElems ils) blockToShape (Plain (il:_)) | Link _ (il':_) target <- il , Image attr ils (url, _) <- il' = - Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils) + Pic def{picPropLink = Just $ ExternalTarget target} url attr <$> (inlinesToParElems ils) blockToShape (Para (il:_)) | Link _ (il':_) target <- il , Image attr ils (url, _) <- il' = - Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils) + Pic def{picPropLink = Just $ ExternalTarget target} url attr <$> (inlinesToParElems ils) blockToShape (Table caption algn _ hdrCells rows) = do caption' <- inlinesToParElems caption hdrCells' <- rowToParagraphs algn hdrCells @@ -644,6 +640,51 @@ combineParaElems' (Just pElem') (pElem : pElems) combineParaElems :: [ParaElem] -> [ParaElem] combineParaElems = combineParaElems' Nothing +applyToParagraph :: Monad m => (ParaElem -> m ParaElem) -> Paragraph -> m Paragraph +applyToParagraph f para = do + paraElems' <- mapM f $ paraElems para + return $ para {paraElems = paraElems'} + +applyToShape :: Monad m => (ParaElem -> m ParaElem) -> Shape -> m Shape +applyToShape f (Pic pPr fp attr pes) = do + pes' <- mapM f pes + return $ Pic pPr fp attr pes' +applyToShape f (GraphicFrame gfx pes) = do + pes' <- mapM f pes + return $ GraphicFrame gfx pes' +applyToShape f (TextBox paras) = do + paras' <- mapM (applyToParagraph f) paras + return $ TextBox paras' + +applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide +applyToSlide f (MetadataSlide title subtitle authors date) = do + title' <- mapM f title + subtitle' <- mapM f subtitle + authors' <- mapM (mapM f) authors + date' <- mapM f date + return $ MetadataSlide title' subtitle' authors' date' +applyToSlide f (TitleSlide title) = do + title' <- mapM f title + return $ TitleSlide title' +applyToSlide f (ContentSlide hdr content) = do + hdr' <- mapM f hdr + content' <- mapM (applyToShape f) content + return $ ContentSlide hdr' content' +applyToSlide f (TwoColumnSlide hdr contentL contentR) = do + hdr' <- mapM f hdr + contentL' <- mapM (applyToShape f) contentL + contentR' <- mapM (applyToShape f) contentR + return $ TwoColumnSlide hdr' contentL' contentR' + +replaceAnchor :: PandocMonad m => ParaElem -> Pres m ParaElem +replaceAnchor (Run rProps s) + | Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do + anchorMap <- gets stAnchorMap + return $ case M.lookup anchor anchorMap of + Just n -> Run (rProps{rLink = Just $ InternalTarget n}) s + Nothing -> Run rProps s +replaceAnchor pe = return pe + blocksToPresentation :: PandocMonad m => [Block] -> Pres m Presentation blocksToPresentation blks = do opts <- asks envOpts @@ -683,9 +724,10 @@ blocksToPresentation blks = do }) (blocksToSlide $ notesSlideBlocks) return [notesSlide] - return $ - Presentation $ - metadataslides ++ tocSlides ++ bodyslides ++ notesSlides + + let slides = metadataslides ++ tocSlides ++ bodyslides ++ notesSlides + slides' <- mapM (applyToSlide replaceAnchor) slides + return $ Presentation slides' documentToPresentation :: PandocMonad m => WriterOptions -- cgit v1.2.3