aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Writers/Powerpoint
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Writers/Powerpoint')
-rw-r--r--src/Text/Pandoc/Writers/Powerpoint/Output.hs117
-rw-r--r--src/Text/Pandoc/Writers/Powerpoint/Presentation.hs29
2 files changed, 110 insertions, 36 deletions
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
index 5eadf1312..1431469d3 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
@@ -31,6 +31,7 @@ import qualified Data.CaseInsensitive as CI
import Data.Default
import Data.Foldable (toList)
import Data.List.NonEmpty (nonEmpty, NonEmpty ((:|)))
+import Data.Ratio ((%), Ratio)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Read (decimal)
@@ -439,9 +440,9 @@ makeSpeakerNotesMap :: Presentation -> M.Map Int Int
makeSpeakerNotesMap (Presentation _ slides) =
M.fromList $
mapMaybe f (slides `zip` [1..]) `zip` [1..]
- where f (Slide _ _ notes, n) = if notes == mempty
- then Nothing
- else Just n
+ where f (Slide _ _ notes _, n) = if notes == mempty
+ then Nothing
+ else Just n
presentationToArchive :: PandocMonad m
=> WriterOptions -> Meta -> Presentation -> m Archive
@@ -1570,8 +1571,9 @@ metadataToElement layout titleElems subtitleElems authorsElems dateElems
metadataToElement _ _ _ _ _ = return (Nothing, mknode "p:sp" [] ())
slideToElement :: PandocMonad m => Slide -> P m Element
-slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ )= do
+slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ backgroundImage) = do
layout <- getLayout l
+ backgroundImageElement <- traverse backgroundImageToElement backgroundImage
(shapeIds, spTree)
<- local (\env -> if null hdrElems
then env
@@ -1585,9 +1587,10 @@ slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ )= do
[ ("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" [] [spTree] : animations)
-slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do
+ ] (mknode "p:cSld" [] (toList backgroundImageElement <> [spTree]) : animations)
+slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _ backgroundImage) = do
layout <- getLayout l
+ backgroundImageElement <- traverse backgroundImageToElement backgroundImage
(shapeIds, spTree) <- local (\env -> if null hdrElems
then env
else env{envSlideHasHeader=True}) $
@@ -1601,9 +1604,10 @@ slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do
[ ("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" [] [spTree] : animations)
-slideToElement (Slide _ l@(ComparisonSlide hdrElems shapesL shapesR) _) = do
+ ] (mknode "p:cSld" [] (toList backgroundImageElement <> [spTree]) : animations)
+slideToElement (Slide _ l@(ComparisonSlide hdrElems shapesL shapesR) _ backgroundImage) = do
layout <- getLayout l
+ backgroundImageElement <- traverse backgroundImageToElement backgroundImage
(shapeIds, spTree) <- local (\env -> if null hdrElems
then env
else env{envSlideHasHeader=True}) $
@@ -1620,25 +1624,36 @@ slideToElement (Slide _ l@(ComparisonSlide hdrElems shapesL shapesR) _) = do
[ ("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" [] [spTree] : animations)
-slideToElement (Slide _ l@(TitleSlide hdrElems) _) = do
+ ] (mknode "p:cSld" [] (toList backgroundImageElement <> [spTree]) : animations)
+slideToElement (Slide _ l@(TitleSlide hdrElems) _ backgroundImage) = do
layout <- getLayout l
+ backgroundImageElement <- traverse backgroundImageToElement backgroundImage
(_, spTree) <- titleToElement layout hdrElems
return $ mknode "p:sld"
[ ("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" [] [spTree]]
-slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems dateElems) _) = do
+ ] [mknode "p:cSld" [] (toList backgroundImageElement <> [spTree])]
+slideToElement (Slide
+ _
+ l@(MetadataSlide titleElems subtitleElems authorElems dateElems)
+ _
+ backgroundImage) = do
layout <- getLayout l
+ backgroundImageElement <- traverse backgroundImageToElement backgroundImage
(_, spTree) <- metadataToElement layout titleElems subtitleElems authorElems dateElems
return $ mknode "p:sld"
[ ("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" [] [spTree]]
-slideToElement (Slide _ l@(ContentWithCaptionSlide hdrElems captionShapes contentShapes) _) = do
+ ] [mknode "p:cSld" [] (toList backgroundImageElement <> [spTree])]
+slideToElement (Slide
+ _
+ l@(ContentWithCaptionSlide hdrElems captionShapes contentShapes)
+ _
+ backgroundImage) = do
layout <- getLayout l
+ backgroundImageElement <- traverse backgroundImageToElement backgroundImage
(shapeIds, spTree) <- contentWithCaptionToElement layout hdrElems captionShapes contentShapes
let animations = case shapeIds of
Nothing -> []
@@ -1650,15 +1665,63 @@ slideToElement (Slide _ l@(ContentWithCaptionSlide hdrElems captionShapes conten
[ ("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" [] [spTree] : animations)
-slideToElement (Slide _ BlankSlide _) = do
+ ] (mknode "p:cSld" [] (toList backgroundImageElement <> [spTree]) : animations)
+slideToElement (Slide _ BlankSlide _ backgroundImage) = do
layout <- getLayout BlankSlide
+ backgroundImageElement <- traverse backgroundImageToElement backgroundImage
spTree <- blankToElement layout
return $ mknode "p:sld"
[ ("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" [] [spTree]]
+ ] [mknode "p:cSld" [] (toList backgroundImageElement <> [spTree])]
+
+backgroundImageToElement :: PandocMonad m => FilePath -> P m Element
+backgroundImageToElement path = do
+ MediaInfo{mInfoLocalId, mInfoFilePath} <- registerMedia path []
+ (imgBytes, _) <- P.fetchItem (T.pack mInfoFilePath)
+ opts <- asks envOpts
+ let imageDimensions = either (const Nothing)
+ (Just . sizeInPixels)
+ (imageSize opts imgBytes)
+ pageSize <- asks envPresentationSize
+ let fillRectAttributes = maybe [] (offsetAttributes pageSize) imageDimensions
+ let rId = "rId" <> T.pack (show mInfoLocalId)
+ return
+ $ mknode "p:bg" []
+ $ mknode "p:bgPr" []
+ [ mknode "a:blipFill" [("dpi", "0"), ("rotWithShape", "1")]
+ [ mknode "a:blip" [("r:embed", rId)]
+ $ mknode "a:lum" [] ()
+ , mknode "a:srcRect" [] ()
+ , mknode "a:stretch" []
+ $ mknode "a:fillRect" fillRectAttributes ()
+ ]
+ , mknode "a:effectsLst" [] ()
+ ]
+ where
+ offsetAttributes :: (Integer, Integer) -> (Integer, Integer) -> [(Text, Text)]
+ offsetAttributes (pageWidth, pageHeight) (pictureWidth, pictureHeight) = let
+ widthRatio = pictureWidth % pageWidth
+ heightRatio = pictureHeight % pageHeight
+ getOffset :: Ratio Integer -> Text
+ getOffset proportion = let
+ percentageOffset = (proportion - 1) * (-100 % 2)
+ integerOffset = round percentageOffset * 1000 :: Integer
+ in T.pack (show integerOffset)
+ in case compare widthRatio heightRatio of
+ EQ -> []
+ LT -> let
+ offset = getOffset ((pictureHeight % pageHeight) / widthRatio)
+ in [ ("t", offset)
+ , ("b", offset)
+ ]
+ GT -> let
+ offset = getOffset ((pictureWidth % pageWidth) / heightRatio)
+ in [ ("l", offset)
+ , ("r", offset)
+ ]
+
slideToIncrementalAnimations ::
[(ShapeId, Shape)] ->
@@ -1790,8 +1853,8 @@ speakerNotesSlideNumber pgNum fieldId =
]
slideToSpeakerNotesElement :: PandocMonad m => Slide -> P m (Maybe Element)
-slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes [])) = return Nothing
-slideToSpeakerNotesElement slide@(Slide _ _ (SpeakerNotes paras)) = do
+slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes []) _) = return Nothing
+slideToSpeakerNotesElement slide@(Slide _ _ (SpeakerNotes paras) _) = do
master <- getNotesMaster
fieldId <- getSlideNumberFieldId master
num <- slideNum slide
@@ -2037,7 +2100,7 @@ slideToSpeakerNotesEntry slide = do
_ -> return Nothing
slideToSpeakerNotesRelElement :: PandocMonad m => Slide -> P m (Maybe Element)
-slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes [])) = return Nothing
+slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes []) _) = return Nothing
slideToSpeakerNotesRelElement slide@Slide{} = do
idNum <- slideNum slide
return $ Just $
@@ -2124,13 +2187,13 @@ slideToSlideRelElement slide = do
target <- flip fmap getSlideLayouts $
T.pack . ("../slideLayouts/" <>) . takeFileName .
slPath . case slide of
- (Slide _ MetadataSlide{} _) -> metadata
- (Slide _ TitleSlide{} _) -> title
- (Slide _ ContentSlide{} _) -> content
- (Slide _ TwoColumnSlide{} _) -> twoColumn
- (Slide _ ComparisonSlide{} _) -> comparison
- (Slide _ ContentWithCaptionSlide{} _) -> contentWithCaption
- (Slide _ BlankSlide _) -> blank
+ (Slide _ MetadataSlide{} _ _) -> metadata
+ (Slide _ TitleSlide{} _ _) -> title
+ (Slide _ ContentSlide{} _ _) -> content
+ (Slide _ TwoColumnSlide{} _ _) -> twoColumn
+ (Slide _ ComparisonSlide{} _ _) -> comparison
+ (Slide _ ContentWithCaptionSlide{} _ _) -> contentWithCaption
+ (Slide _ BlankSlide _ _) -> blank
speakerNotesRels <- maybeToList <$> speakerNotesSlideRelElement slide
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
index a7660fc5e..fb4518bd7 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
@@ -63,7 +63,7 @@ import Text.Pandoc.Writers.Shared (lookupMetaInlines, lookupMetaBlocks
, toLegacyTable)
import qualified Data.Map as M
import qualified Data.Set as S
-import Data.Maybe (maybeToList, fromMaybe, listToMaybe)
+import Data.Maybe (maybeToList, fromMaybe, listToMaybe, isNothing)
import Text.Pandoc.Highlighting
import qualified Data.Text as T
import Control.Applicative ((<|>))
@@ -201,6 +201,7 @@ data DocProps = DocProps { dcTitle :: Maybe T.Text
data Slide = Slide { slideId :: SlideId
, slideLayout :: Layout
, slideSpeakerNotes :: SpeakerNotes
+ , slideBackgroundImage :: Maybe FilePath
} deriving (Show, Eq)
newtype SlideId = SlideId T.Text
@@ -223,7 +224,7 @@ data Layout = MetadataSlide [ParaElem] [ParaElem] [[ParaElem]] [ParaElem]
| ComparisonSlide [ParaElem] ([Shape], [Shape]) ([Shape], [Shape])
-- heading left@(text, content) right@(text, content)
| ContentWithCaptionSlide [ParaElem] [Shape] [Shape]
- -- heading text content
+ -- heading text content
| BlankSlide
deriving (Show, Eq)
@@ -725,6 +726,7 @@ bodyBlocksToSlide _ (blk : blks) spkNotes
sldId
(TwoColumnSlide [] shapesL shapesR)
spkNotes
+ Nothing
let mkComparison blksL1 blksL2 blksR1 blksR2 = do
shapesL1 <- blocksToShapes blksL1
shapesL2 <- blocksToShapes blksL2
@@ -735,6 +737,7 @@ bodyBlocksToSlide _ (blk : blks) spkNotes
sldId
(ComparisonSlide [] (shapesL1, shapesL2) (shapesR1, shapesR2))
spkNotes
+ Nothing
let (blksL1, blksL2) = break notText blksL
(blksR1, blksR2) = break notText blksR
if (any null [blksL1, blksL2]) && (any null [blksR1, blksR2])
@@ -744,7 +747,7 @@ bodyBlocksToSlide _ (blk : blks) spkNotes = do
sldId <- asks envCurSlideId
inNoteSlide <- asks envInNoteSlide
let mkSlide s =
- Slide sldId s spkNotes
+ Slide sldId s spkNotes Nothing
if inNoteSlide
then mkSlide . ContentSlide [] <$>
forceFontSize noteSize (blocksToShapes (blk : blks))
@@ -767,14 +770,15 @@ bodyBlocksToSlide _ [] spkNotes = do
sldId
BlankSlide
spkNotes
+ Nothing
blocksToSlide' :: Int -> [Block] -> SpeakerNotes -> Pres Slide
-blocksToSlide' lvl (Header n (ident, _, _) ils : blks) spkNotes
+blocksToSlide' lvl (Header n (ident, _, attributes) ils : blks) spkNotes
| n < lvl = do
registerAnchorId ident
sldId <- asks envCurSlideId
hdr <- inlinesToParElems ils
- return $ Slide sldId (TitleSlide hdr) spkNotes
+ return $ Slide sldId (TitleSlide hdr) spkNotes backgroundImage
| n == lvl || lvl == 0 = do
registerAnchorId ident
hdr <- inlinesToParElems ils
@@ -788,7 +792,10 @@ blocksToSlide' lvl (Header n (ident, _, _) ils : blks) spkNotes
ContentWithCaptionSlide _ text content -> ContentWithCaptionSlide hdr text content
BlankSlide -> if all inlineIsBlank ils then BlankSlide else ContentSlide hdr []
layout' -> layout'
- return $ slide{slideLayout = layout}
+ return $ slide{slideLayout = layout, slideBackgroundImage = backgroundImage}
+ where
+ backgroundImage = T.unpack <$> (lookup "background-image" attributes
+ <|> lookup "data-background-image" attributes)
blocksToSlide' lvl blks spkNotes = bodyBlocksToSlide lvl blks spkNotes
blockToSpeakerNotes :: Block -> Pres SpeakerNotes
@@ -869,12 +876,13 @@ getMetaSlide = do
metadataSlideId
(MetadataSlide title subtitle authors date)
mempty
+ Nothing
addSpeakerNotesToMetaSlide :: Slide -> [Block] -> Pres (Slide, [Block])
-addSpeakerNotesToMetaSlide (Slide sldId layout@MetadataSlide{} spkNotes) blks =
+addSpeakerNotesToMetaSlide (Slide sldId layout@MetadataSlide{} spkNotes backgroundImage) blks =
do let (ntsBlks, blks') = span isNotesDiv blks
spkNotes' <- mconcat <$> mapM blockToSpeakerNotes ntsBlks
- return (Slide sldId layout (spkNotes <> spkNotes'), blks')
+ return (Slide sldId layout (spkNotes <> spkNotes') backgroundImage, blks')
addSpeakerNotesToMetaSlide sld blks = return (sld, blks)
makeTOCSlide :: [Block] -> Pres Slide
@@ -1010,7 +1018,10 @@ emptyLayout layout = case layout of
emptySlide :: Slide -> Bool
-emptySlide (Slide _ layout notes) = (notes == mempty) && emptyLayout layout
+emptySlide (Slide _ layout notes backgroundImage)
+ = (notes == mempty)
+ && emptyLayout layout
+ && isNothing backgroundImage
makesBlankSlide :: [Block] -> Bool
makesBlankSlide = all blockIsBlank
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-02 09:29:30 +0000