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.
This commit is contained in:
Jesse Rosenthal
parent
2c00540485
commit
3156722ac4
2 changed files with 80 additions and 59 deletions
|
|
@ -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")
|
||||
] ()
|
||||
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 (URL, String) -> P m [Element]
|
||||
linkRelElements mp = catMaybes <$> mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)
|
||||
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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue