@@ -0,0 +1,1665 @@
1+{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-}
2+
3+{-
4+Copyright (C) 2017 Jesse Rosenthal <jrosenthal@jhu.edu>
5+
6+This program is free software; you can redistribute it and/or modify
7+it under the terms of the GNU General Public License as published by
8+the Free Software Foundation; either version 2 of the License, or
9+(at your option) any later version.
10+
11+This program is distributed in the hope that it will be useful,
12+but WITHOUT ANY WARRANTY; without even the implied warranty of
13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14+GNU General Public License for more details.
15+
16+You should have received a copy of the GNU General Public License
17+along with this program; if not, write to the Free Software
18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19+-}
20+
21+{- |
22+ Module : Text.Pandoc.Writers.Powerpoint
23+ Copyright : Copyright (C) 2017 Jesse Rosenthal
24+ License : GNU GPL, version 2 or above
25+
26+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
27+ Stability : alpha
28+ Portability : portable
29+
30+Conversion of 'Pandoc' documents to powerpoint (pptx).
31+-}
32+
33+module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where
34+
35+import Control.Monad.Except (throwError)
36+import Control.Monad.Reader
37+import Control.Monad.State
38+import Codec.Archive.Zip
39+import Data.List (intercalate, stripPrefix, isPrefixOf, nub)
40+-- import Control.Monad (mplus)
41+import Data.Default
42+import Data.Time.Clock (UTCTime)
43+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
44+import System.FilePath.Posix (splitDirectories, splitExtension)
45+import Text.XML.Light
46+import Text.Pandoc.Definition
47+import qualified Text.Pandoc.UTF8 as UTF8
48+import Text.Pandoc.Class (PandocMonad)
49+import Text.Pandoc.Error (PandocError(..))
50+import qualified Text.Pandoc.Class as P
51+import Text.Pandoc.Options
52+import Text.Pandoc.MIME
53+import Text.Pandoc.Logging
54+import qualified Data.ByteString.Lazy as BL
55+-- import qualified Data.ByteString.Lazy.Char8 as BL8
56+-- import qualified Text.Pandoc.UTF8 as UTF8
57+import Text.Pandoc.Walk
58+import Text.Pandoc.Writers.Shared (fixDisplayMath)
59+import Text.Pandoc.Writers.OOXML
60+import qualified Data.Map as M
61+import Data.Maybe (mapMaybe, listToMaybe)
62+import Text.Pandoc.ImageSize
63+import Control.Applicative ((<|>))
64+
65+import Text.TeXMath
66+import Text.Pandoc.Writers.Math (convertMath)
67+
68+
69+writePowerpoint :: (PandocMonad m)
70+ => WriterOptions -- ^ Writer options
71+ -> Pandoc -- ^ Document to convert
72+ -> m BL.ByteString
73+writePowerpoint opts (Pandoc meta blks) = do
74+ let blks' = walk fixDisplayMath blks
75+ distArchive <- (toArchive . BL.fromStrict) <$>
76+ P.readDefaultDataFile "reference.pptx"
77+ refArchive <- case writerReferenceDoc opts of
78+ Just f -> toArchive <$> P.readFileLazy f
79+ Nothing -> (toArchive . BL.fromStrict) <$>
80+ P.readDataFile "reference.pptx"
81+
82+ utctime <- P.getCurrentTime
83+
84+ let env = def { envMetadata = meta
85+ , envRefArchive = refArchive
86+ , envDistArchive = distArchive
87+ , envUTCTime = utctime
88+ , envOpts = opts
89+ }
90+ runP env def $ do pres <- blocksToPresentation blks'
91+ archv <- presentationToArchive pres
92+ return $ fromArchive archv
93+
94+concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
95+concatMapM f xs = liftM concat (mapM f xs)
96+
97+data WriterEnv = WriterEnv { envMetadata :: Meta
98+ , envRunProps :: RunProps
99+ , envParaProps :: ParaProps
100+ , envSlideLevel :: Int
101+ , envRefArchive :: Archive
102+ , envDistArchive :: Archive
103+ , envUTCTime :: UTCTime
104+ , envOpts :: WriterOptions
105+ , envPresentationSize :: PresentationSize
106+ , envSlideHasHeader :: Bool
107+ , envInList :: Bool
108+ }
109+ deriving (Show)
110+
111+instance Default WriterEnv where
112+ def = WriterEnv { envMetadata = mempty
113+ , envRunProps = def
114+ , envParaProps = def
115+ , envSlideLevel = 2
116+ , envRefArchive = emptyArchive
117+ , envDistArchive = emptyArchive
118+ , envUTCTime = posixSecondsToUTCTime 0
119+ , envOpts = def
120+ , envPresentationSize = def
121+ , envSlideHasHeader = False
122+ , envInList = False
123+ }
124+
125+data MediaInfo = MediaInfo { mInfoFilePath :: FilePath
126+ , mInfoLocalId :: Int
127+ , mInfoGlobalId :: Int
128+ , mInfoMimeType :: Maybe MimeType
129+ , mInfoExt :: Maybe String
130+ , mInfoCaption :: Bool
131+ } deriving (Show, Eq)
132+
133+data WriterState = WriterState { stCurSlideId :: Int
134+ -- the difference between the number at
135+ -- the end of the slide file name and
136+ -- the rId number
137+ , stSlideIdOffset :: Int
138+ , stLinkIds :: M.Map Int (M.Map Int (URL, String))
139+ -- (FP, Local ID, Global ID, Maybe Mime)
140+ , stMediaIds :: M.Map Int [MediaInfo]
141+ , stMediaGlobalIds :: M.Map FilePath Int
142+ } deriving (Show, Eq)
143+
144+instance Default WriterState where
145+ def = WriterState { stCurSlideId = 0
146+ , stSlideIdOffset = 1
147+ , stLinkIds = mempty
148+ , stMediaIds = mempty
149+ , stMediaGlobalIds = mempty
150+ }
151+
152+type P m = ReaderT WriterEnv (StateT WriterState m)
153+
154+runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
155+runP env st p = evalStateT (runReaderT p env) st
156+
157+type Pixels = Integer
158+
159+data Presentation = Presentation PresentationSize [Slide]
160+ deriving (Show)
161+
162+data PresentationSize = PresentationSize { presSizeWidth :: Pixels
163+ , presSizeRatio :: PresentationRatio
164+ }
165+ deriving (Show, Eq)
166+
167+data PresentationRatio = Ratio4x3
168+ | Ratio16x9
169+ | Ratio16x10
170+ deriving (Show, Eq)
171+
172+-- Note that right now we're only using Ratio4x3.
173+getPageHeight :: PresentationSize -> Pixels
174+getPageHeight sz = case presSizeRatio sz of
175+ Ratio4x3 -> floor (((fromInteger (presSizeWidth sz)) / 4) * 3 :: Double)
176+ Ratio16x9 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 9 :: Double)
177+ Ratio16x10 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 10 :: Double)
178+
179+instance Default PresentationSize where
180+ def = PresentationSize 720 Ratio4x3
181+
182+data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]
183+ , metadataSlideSubtitle :: [ParaElem]
184+ , metadataSlideAuthors :: [[ParaElem]]
185+ , metadataSlideDate :: [ParaElem]
186+ }
187+ | TitleSlide { titleSlideHeader :: [ParaElem]}
188+ | ContentSlide { contentSlideHeader :: [ParaElem]
189+ , contentSlideContent :: [Shape]
190+ }
191+ deriving (Show, Eq)
192+
193+data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape
194+ deriving (Show, Eq)
195+
196+data Shape = Pic FilePath Text.Pandoc.Definition.Attr [ParaElem]
197+ | GraphicFrame [Graphic] [ParaElem]
198+ | TextBox [Paragraph]
199+ deriving (Show, Eq)
200+
201+type Cell = [Paragraph]
202+
203+data TableProps = TableProps { tblPrFirstRow :: Bool
204+ , tblPrBandRow :: Bool
205+ } deriving (Show, Eq)
206+
207+type ColWidth = Integer
208+
209+data Graphic = Tbl TableProps [ColWidth] [Cell] [[Cell]]
210+ deriving (Show, Eq)
211+
212+
213+data Paragraph = Paragraph { paraProps :: ParaProps
214+ , paraElems :: [ParaElem]
215+ } deriving (Show, Eq)
216+
217+data HeaderType = TitleHeader | SlideHeader | InternalHeader Int
218+ deriving (Show, Eq)
219+
220+-- type StartingAt = Int
221+
222+-- data AutoNumType = ArabicNum
223+-- | AlphaUpperNum
224+-- | AlphaLowerNum
225+-- | RomanUpperNum
226+-- | RomanLowerNum
227+-- deriving (Show, Eq)
228+
229+-- data AutoNumDelim = PeriodDelim
230+-- | OneParenDelim
231+-- | TwoParensDelim
232+-- deriving (Show, Eq)
233+
234+autoNumberingToType :: ListAttributes -> String
235+autoNumberingToType (_, numStyle, numDelim) =
236+ typeString ++ delimString
237+ where
238+ typeString = case numStyle of
239+ Decimal -> "arabic"
240+ UpperAlpha -> "alphaUc"
241+ LowerAlpha -> "alphaLc"
242+ UpperRoman -> "romanUc"
243+ LowerRoman -> "romanLc"
244+ _ -> "arabic"
245+ delimString = case numDelim of
246+ Period -> "Period"
247+ OneParen -> "ParenR"
248+ TwoParens -> "ParenBoth"
249+ _ -> "Period"
250+
251+data BulletType = Bullet
252+ | AutoNumbering ListAttributes
253+ deriving (Show, Eq)
254+
255+data Algnment = AlgnLeft | AlgnRight | AlgnCenter
256+ deriving (Show, Eq)
257+
258+data ParaProps = ParaProps { pPropHeaderType :: Maybe HeaderType
259+ , pPropMarginLeft :: Maybe Pixels
260+ , pPropMarginRight :: Maybe Pixels
261+ , pPropLevel :: Int
262+ , pPropBullet :: Maybe BulletType
263+ , pPropAlign :: Maybe Algnment
264+ } deriving (Show, Eq)
265+
266+instance Default ParaProps where
267+ def = ParaProps { pPropHeaderType = Nothing
268+ , pPropMarginLeft = Just 0
269+ , pPropMarginRight = Just 0
270+ , pPropLevel = 0
271+ , pPropBullet = Nothing
272+ , pPropAlign = Nothing
273+ }
274+
275+newtype TeXString = TeXString {unTeXString :: String}
276+ deriving (Eq, Show)
277+
278+data ParaElem = Break
279+ | Run RunProps String
280+ -- It would be more elegant to have native TeXMath
281+ -- Expressions here, but this allows us to use
282+ -- `convertmath` from T.P.Writers.Math. Will perhaps
283+ -- revisit in the future.
284+ | MathElem MathType TeXString
285+ deriving (Show, Eq)
286+
287+data Strikethrough = NoStrike | SingleStrike | DoubleStrike
288+ deriving (Show, Eq)
289+
290+data Capitals = NoCapitals | SmallCapitals | AllCapitals
291+ deriving (Show, Eq)
292+
293+type URL = String
294+
295+data RunProps = RunProps { rPropBold :: Bool
296+ , rPropItalics :: Bool
297+ , rStrikethrough :: Maybe Strikethrough
298+ , rBaseline :: Maybe Int
299+ , rCap :: Maybe Capitals
300+ , rLink :: Maybe (URL, String)
301+ , rPropCode :: Bool
302+ , rPropBlockQuote :: Bool
303+ } deriving (Show, Eq)
304+
305+instance Default RunProps where
306+ def = RunProps { rPropBold = False
307+ , rPropItalics = False
308+ , rStrikethrough = Nothing
309+ , rBaseline = Nothing
310+ , rCap = Nothing
311+ , rLink = Nothing
312+ , rPropCode = False
313+ , rPropBlockQuote = False
314+ }
315+
316+--------------------------------------------------
317+
318+inlinesToParElems :: Monad m => [Inline] -> P m [ParaElem]
319+inlinesToParElems ils = concatMapM inlineToParElems ils
320+
321+inlineToParElems :: Monad m => Inline -> P m [ParaElem]
322+inlineToParElems (Str s) = do
323+ pr <- asks envRunProps
324+ return [Run pr s]
325+inlineToParElems (Emph ils) =
326+ local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $
327+ inlinesToParElems ils
328+inlineToParElems (Strong ils) =
329+ local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $
330+ inlinesToParElems ils
331+inlineToParElems (Strikeout ils) =
332+ local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $
333+ inlinesToParElems ils
334+inlineToParElems (Superscript ils) =
335+ local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $
336+ inlinesToParElems ils
337+inlineToParElems (Subscript ils) =
338+ local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $
339+ inlinesToParElems ils
340+inlineToParElems (SmallCaps ils) =
341+ local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $
342+ inlinesToParElems ils
343+inlineToParElems Space = inlineToParElems (Str " ")
344+inlineToParElems SoftBreak = inlineToParElems (Str " ")
345+inlineToParElems LineBreak = return [Break]
346+inlineToParElems (Link _ ils (url, title)) = do
347+ local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $
348+ inlinesToParElems ils
349+inlineToParElems (Code _ str) = do
350+ local (\r ->r{envRunProps = def{rPropCode = True}}) $
351+ inlineToParElems $ Str str
352+inlineToParElems (Math mathtype str) =
353+ return [MathElem mathtype (TeXString str)]
354+inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils
355+inlineToParElems (RawInline _ _) = return []
356+inlineToParElems _ = return []
357+
358+blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph]
359+blockToParagraphs (Plain ils) = do
360+ parElems <- inlinesToParElems ils
361+ pProps <- asks envParaProps
362+ return [Paragraph pProps parElems]
363+blockToParagraphs (Para ils) = do
364+ parElems <- inlinesToParElems ils
365+ pProps <- asks envParaProps
366+ return [Paragraph pProps parElems]
367+blockToParagraphs (LineBlock ilsList) = do
368+ parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList
369+ pProps <- asks envParaProps
370+ return [Paragraph pProps parElems]
371+-- TODO: work out the attributes
372+blockToParagraphs (CodeBlock attr str) =
373+ local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $
374+ blockToParagraphs $ Para [Code attr str]
375+-- TODO: work out the format
376+blockToParagraphs (BlockQuote blks) =
377+ local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}
378+ , envRunProps = (envRunProps r){rPropBlockQuote = True}})$
379+ concatMapM blockToParagraphs blks
380+-- TODO: work out the format
381+blockToParagraphs (RawBlock _ _) = return []
382+ -- parElems <- inlinesToParElems [Str str]
383+ -- paraProps <- asks envParaProps
384+ -- return [Paragraph paraProps parElems]
385+-- TODO: work out the format
386+blockToParagraphs (Header n _ ils) = do
387+ slideLevel <- asks envSlideLevel
388+ parElems <- inlinesToParElems ils
389+ -- For the time being we're not doing headers inside of bullets, but
390+ -- we might change that.
391+ let headerType = case n `compare` slideLevel of
392+ LT -> TitleHeader
393+ EQ -> SlideHeader
394+ GT -> InternalHeader (n - slideLevel)
395+ return [Paragraph def{pPropHeaderType = Just headerType} parElems]
396+blockToParagraphs (BulletList blksLst) = do
397+ pProps <- asks envParaProps
398+ let lvl = pPropLevel pProps
399+ local (\env -> env{ envInList = True
400+ , envParaProps = pProps{ pPropLevel = lvl + 1
401+ , pPropBullet = Just Bullet
402+ , pPropMarginLeft = Nothing
403+ }}) $
404+ concatMapM multiParBullet blksLst
405+blockToParagraphs (OrderedList listAttr blksLst) = do
406+ pProps <- asks envParaProps
407+ let lvl = pPropLevel pProps
408+ local (\env -> env{ envInList = True
409+ , envParaProps = pProps{ pPropLevel = lvl + 1
410+ , pPropBullet = Just (AutoNumbering listAttr)
411+ , pPropMarginLeft = Nothing
412+ }}) $
413+ concatMapM multiParBullet blksLst
414+blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks
415+-- TODO
416+blockToParagraphs blk = do
417+ P.report $ BlockNotRendered blk
418+ return []
419+
420+-- Make sure the bullet env gets turned off after the first para.
421+multiParBullet :: PandocMonad m => [Block] -> P m [Paragraph]
422+multiParBullet [] = return []
423+multiParBullet (b:bs) = do
424+ pProps <- asks envParaProps
425+ p <- blockToParagraphs b
426+ ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $
427+ concatMapM blockToParagraphs bs
428+ return $ p ++ ps
429+
430+cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> P m [Paragraph]
431+cellToParagraphs algn tblCell = do
432+ paras <- mapM (blockToParagraphs) tblCell
433+ let alignment = case algn of
434+ AlignLeft -> Just AlgnLeft
435+ AlignRight -> Just AlgnRight
436+ AlignCenter -> Just AlgnCenter
437+ AlignDefault -> Nothing
438+ paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras
439+ return $ concat paras'
440+
441+rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> P m [[Paragraph]]
442+rowToParagraphs algns tblCells = do
443+ -- We have to make sure we have the right number of alignments
444+ let pairs = zip (algns ++ repeat AlignDefault) tblCells
445+ mapM (\(a, tc) -> cellToParagraphs a tc) pairs
446+
447+blockToShape :: PandocMonad m => Block -> P m Shape
448+blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il =
449+ Pic url attr <$> (inlinesToParElems ils)
450+blockToShape (Para (il:_)) | Image attr ils (url, _) <- il =
451+ Pic url attr <$> (inlinesToParElems ils)
452+blockToShape (Table caption algn _ hdrCells rows) = do
453+ caption' <- inlinesToParElems caption
454+ pageWidth <- presSizeWidth <$> asks envPresentationSize
455+ hdrCells' <- rowToParagraphs algn hdrCells
456+ rows' <- mapM (rowToParagraphs algn) rows
457+ let tblPr = if null hdrCells
458+ then TableProps { tblPrFirstRow = False
459+ , tblPrBandRow = True
460+ }
461+ else TableProps { tblPrFirstRow = True
462+ , tblPrBandRow = True
463+ }
464+ colWidths = if null hdrCells
465+ then case rows of
466+ r : _ | not (null r) -> replicate (length r) $
467+ (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length r)
468+ -- satisfy the compiler. This is the same as
469+ -- saying that rows is empty, but the compiler
470+ -- won't understand that `[]` exhausts the
471+ -- alternatives.
472+ _ -> []
473+ else replicate (length hdrCells) $
474+ (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells)
475+
476+ return $ GraphicFrame [Tbl tblPr colWidths hdrCells' rows'] caption'
477+blockToShape blk = TextBox <$> blockToParagraphs blk
478+
479+blocksToShapes :: PandocMonad m => [Block] -> P m [Shape]
480+blocksToShapes blks = combineShapes <$> mapM blockToShape blks
481+
482+splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> P m [[Block]]
483+splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur])
484+splitBlocks' cur acc (HorizontalRule : blks) =
485+ splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks
486+splitBlocks' cur acc (h@(Header n _ _) : blks) = do
487+ slideLevel <- asks envSlideLevel
488+ case compare n slideLevel of
489+ LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks
490+ EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks
491+ GT -> splitBlocks' (cur ++ [h]) acc blks
492+splitBlocks' cur acc ((Para (img@(Image _ _ _):ils)) : blks) = do
493+ slideLevel <- asks envSlideLevel
494+ case cur of
495+ (Header n _ _) : [] | n == slideLevel ->
496+ splitBlocks' []
497+ (acc ++ [cur ++ [Para [img]]])
498+ (if null ils then blks else (Para ils) : blks)
499+ _ -> splitBlocks' []
500+ (acc ++ (if null cur then [] else [cur]) ++ [[Para [img]]])
501+ (if null ils then blks else (Para ils) : blks)
502+splitBlocks' cur acc ((Plain (img@(Image _ _ _):ils)) : blks) = do
503+ slideLevel <- asks envSlideLevel
504+ case cur of
505+ (Header n _ _) : [] | n == slideLevel ->
506+ splitBlocks' []
507+ (acc ++ [cur ++ [Para [img]]])
508+ (if null ils then blks else (Plain ils) : blks)
509+ _ -> splitBlocks' []
510+ (acc ++ (if null cur then [] else [cur]) ++ [[Para [img]]])
511+ (if null ils then blks else (Plain ils) : blks)
512+splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do
513+ slideLevel <- asks envSlideLevel
514+ case cur of
515+ (Header n _ _) : [] | n == slideLevel ->
516+ splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks
517+ _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks
518+splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks
519+
520+splitBlocks :: Monad m => [Block] -> P m [[Block]]
521+splitBlocks = splitBlocks' [] []
522+
523+blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide
524+blocksToSlide' lvl ((Header n _ ils) : blks)
525+ | n < lvl = do
526+ hdr <- inlinesToParElems ils
527+ return $ TitleSlide {titleSlideHeader = hdr}
528+ | n == lvl = do
529+ hdr <- inlinesToParElems ils
530+ shapes <- blocksToShapes blks
531+ return $ ContentSlide { contentSlideHeader = hdr
532+ , contentSlideContent = shapes
533+ }
534+blocksToSlide' _ (blk : blks) = do
535+ shapes <- blocksToShapes (blk : blks)
536+ return $ ContentSlide { contentSlideHeader = []
537+ , contentSlideContent = shapes
538+ }
539+blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []
540+ , contentSlideContent = []
541+ }
542+
543+blocksToSlide :: PandocMonad m => [Block] -> P m Slide
544+blocksToSlide blks = do
545+ slideLevel <- asks envSlideLevel
546+ blocksToSlide' slideLevel blks
547+
548+getMetaSlide :: PandocMonad m => P m (Maybe Slide)
549+getMetaSlide = do
550+ meta <- asks envMetadata
551+ title <- inlinesToParElems $ docTitle meta
552+ subtitle <- inlinesToParElems $
553+ case lookupMeta "subtitle" meta of
554+ Just (MetaString s) -> [Str s]
555+ Just (MetaInlines ils) -> ils
556+ Just (MetaBlocks [Plain ils]) -> ils
557+ Just (MetaBlocks [Para ils]) -> ils
558+ _ -> []
559+ authors <- mapM inlinesToParElems $ docAuthors meta
560+ date <- inlinesToParElems $ docDate meta
561+ if null title && null subtitle && null authors && null date
562+ then return Nothing
563+ else return $ Just $ MetadataSlide { metadataSlideTitle = title
564+ , metadataSlideSubtitle = subtitle
565+ , metadataSlideAuthors = authors
566+ , metadataSlideDate = date
567+ }
568+
569+blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation
570+blocksToPresentation blks = do
571+ blksLst <- splitBlocks blks
572+ slides <- mapM blocksToSlide blksLst
573+ metadataslide <- getMetaSlide
574+ presSize <- asks envPresentationSize
575+ return $ case metadataslide of
576+ Just metadataslide' -> Presentation presSize $ metadataslide' : slides
577+ Nothing -> Presentation presSize slides
578+
579+--------------------------------------------------------------------
580+
581+copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive
582+copyFileToArchive arch fp = do
583+ refArchive <- asks envRefArchive
584+ distArchive <- asks envDistArchive
585+ case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
586+ Nothing -> fail $ fp ++ " missing in reference file"
587+ Just e -> return $ addEntryToArchive e arch
588+
589+getMediaFiles :: PandocMonad m => P m [FilePath]
590+getMediaFiles = do
591+ refArchive <- asks envRefArchive
592+ distArchive <- asks envDistArchive
593+ let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive
594+ return $ filter (isPrefixOf "ppt/media") allEntries
595+
596+
597+copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive
598+copyFileToArchiveIfExists arch fp = do
599+ refArchive <- asks envRefArchive
600+ distArchive <- asks envDistArchive
601+ case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
602+ Nothing -> return $ arch
603+ Just e -> return $ addEntryToArchive e arch
604+
605+inheritedFiles :: [FilePath]
606+inheritedFiles = [ "_rels/.rels"
607+ , "docProps/app.xml"
608+ , "docProps/core.xml"
609+ , "ppt/slideLayouts/slideLayout4.xml"
610+ , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"
611+ , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
612+ , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"
613+ , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
614+ , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
615+ , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"
616+ , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"
617+ , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"
618+ , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"
619+ , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
620+ , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"
621+ , "ppt/slideLayouts/slideLayout2.xml"
622+ , "ppt/slideLayouts/slideLayout8.xml"
623+ , "ppt/slideLayouts/slideLayout11.xml"
624+ , "ppt/slideLayouts/slideLayout3.xml"
625+ , "ppt/slideLayouts/slideLayout6.xml"
626+ , "ppt/slideLayouts/slideLayout9.xml"
627+ , "ppt/slideLayouts/slideLayout5.xml"
628+ , "ppt/slideLayouts/slideLayout7.xml"
629+ , "ppt/slideLayouts/slideLayout1.xml"
630+ , "ppt/slideLayouts/slideLayout10.xml"
631+ -- , "ppt/_rels/presentation.xml.rels"
632+ , "ppt/theme/theme1.xml"
633+ , "ppt/presProps.xml"
634+ -- , "ppt/slides/_rels/slide1.xml.rels"
635+ -- , "ppt/slides/_rels/slide2.xml.rels"
636+ -- This is the one we're
637+ -- going to build
638+ -- , "ppt/slides/slide2.xml"
639+ -- , "ppt/slides/slide1.xml"
640+ , "ppt/viewProps.xml"
641+ , "ppt/tableStyles.xml"
642+ , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
643+ , "ppt/slideMasters/slideMaster1.xml"
644+ -- , "ppt/presentation.xml"
645+ -- , "[Content_Types].xml"
646+ ]
647+
648+-- Here are some that might not be there. We won't fail if they're not
649+possibleInheritedFiles :: [FilePath]
650+possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ]
651+
652+presentationToArchive :: PandocMonad m => Presentation -> P m Archive
653+presentationToArchive p@(Presentation _ slides) = do
654+ newArch <- foldM copyFileToArchive emptyArchive inheritedFiles
655+ mediaDir <- getMediaFiles
656+ newArch' <- foldM copyFileToArchiveIfExists newArch $
657+ possibleInheritedFiles ++ mediaDir
658+ -- presentation entry and rels. We have to do the rels first to make
659+ -- sure we know the correct offset for the rIds.
660+ presEntry <- presentationToPresEntry p
661+ presRelsEntry <- presentationToRelsEntry p
662+ slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]
663+ slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]
664+ -- These have to come after everything, because they need the info
665+ -- built up in the state.
666+ mediaEntries <- makeMediaEntries
667+ contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry
668+ -- fold everything into our inherited archive and return it.
669+ return $ foldr addEntryToArchive newArch' $
670+ slideEntries ++
671+ slideRelEntries ++
672+ mediaEntries ++
673+ [contentTypesEntry, presEntry, presRelsEntry]
674+
675+--------------------------------------------------
676+
677+combineShapes :: [Shape] -> [Shape]
678+combineShapes [] = []
679+combineShapes (s : []) = [s]
680+combineShapes (pic@(Pic _ _ _) : ss) = pic : combineShapes ss
681+combineShapes ((TextBox []) : ss) = combineShapes ss
682+combineShapes (s : TextBox [] : ss) = combineShapes (s : ss)
683+combineShapes (s@(TextBox (p:ps)) : s'@(TextBox (p':ps')) : ss)
684+ | pPropHeaderType (paraProps p) == Just TitleHeader ||
685+ pPropHeaderType (paraProps p) == Just SlideHeader =
686+ TextBox [p] : (combineShapes $ TextBox ps : s' : ss)
687+ | pPropHeaderType (paraProps p') == Just TitleHeader ||
688+ pPropHeaderType (paraProps p') == Just SlideHeader =
689+ s : TextBox [p'] : (combineShapes $ TextBox ps' : ss)
690+ | otherwise = combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss
691+combineShapes (s:ss) = s : combineShapes ss
692+
693+--------------------------------------------------
694+
695+getLayout :: PandocMonad m => Slide -> P m Element
696+getLayout slide = do
697+ let layoutpath = case slide of
698+ (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml"
699+ (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml"
700+ (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml"
701+ distArchive <- asks envDistArchive
702+ root <- case findEntryByPath layoutpath distArchive of
703+ Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of
704+ Just element -> return $ element
705+ Nothing -> throwError $
706+ PandocSomeError $
707+ layoutpath ++ " corrupt in reference file"
708+ Nothing -> throwError $
709+ PandocSomeError $
710+ layoutpath ++ " missing in reference file"
711+ return root
712+ -- let ns = elemToNameSpaces root
713+ -- case findChild (elemName ns "p" "cSld") root of
714+ -- Just element' -> return element'
715+ -- Nothing -> throwError $
716+ -- PandocSomeError $
717+ -- layoutpath ++ " not correctly formed layout file"
718+
719+shapeHasName :: NameSpaces -> String -> Element -> Bool
720+shapeHasName ns name element
721+ | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element
722+ , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr
723+ , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr =
724+ nm == name
725+ | otherwise = False
726+
727+-- getContentTitleShape :: NameSpaces -> Element -> Maybe Element
728+-- getContentTitleShape ns spTreeElem
729+-- | isElem ns "p" "spTree" spTreeElem =
730+-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Title 1" e)) spTreeElem
731+-- | otherwise = Nothing
732+
733+-- getSubtitleShape :: NameSpaces -> Element -> Maybe Element
734+-- getSubtitleShape ns spTreeElem
735+-- | isElem ns "p" "spTree" spTreeElem =
736+-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Subtitle 2" e)) spTreeElem
737+-- | otherwise = Nothing
738+
739+-- getDateShape :: NameSpaces -> Element -> Maybe Element
740+-- getDateShape ns spTreeElem
741+-- | isElem ns "p" "spTree" spTreeElem =
742+-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Date Placeholder 3" e)) spTreeElem
743+-- | otherwise = Nothing
744+
745+getContentShape :: NameSpaces -> Element -> Maybe Element
746+getContentShape ns spTreeElem
747+ | isElem ns "p" "spTree" spTreeElem =
748+ filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Content Placeholder 2" e)) spTreeElem
749+ | otherwise = Nothing
750+
751+
752+-- cursorHasName :: QName -> XMLC.Cursor -> Bool
753+-- cursorHasName nm cur = case XMLC.current cur of
754+-- Elem element -> case XMLC.tagName $ XMLC.getTag element of
755+-- nm -> True
756+-- _ -> False
757+-- _ -> False
758+
759+-- fillInTxBody :: NameSpaces -> [Paragraph] -> Element -> Element
760+-- fillInTxBody ns paras txBodyElem
761+-- | isElem ns "p" "txBody" txBodyElem =
762+-- replaceNamedChildren ns "a" "p" (map paragraphToElement paras) txBodyElem
763+-- | otherwise = txBodyElem
764+
765+-- fillInShape :: NameSpaces -> Shape -> Element -> Element
766+-- fillInShape ns shape spElem
767+-- | TextBox paras <- shape
768+-- , isElemn ns "p" "sp" spElem =
769+-- replaceNamedChildren ns "p" "txBody" (fillInTxBody ns paras sp
770+
771+
772+-- fillInShape :: NameSpaces -> Element -> Shape -> Element
773+-- fillInShape ns spElem (TextBox paras) = fillInParagraphs ns spElem paras
774+-- fillInShape _ spElem pic = spElem
775+
776+contentIsElem :: NameSpaces -> String -> String -> Content -> Bool
777+contentIsElem ns prefix name (Elem element) = isElem ns prefix name element
778+contentIsElem _ _ _ _ = False
779+
780+replaceNamedChildren :: NameSpaces -> String -> String -> [Element] -> Element -> Element
781+replaceNamedChildren ns prefix name newKids element =
782+ let content = elContent element
783+ content' = filter (\c -> not (contentIsElem ns prefix name c)) content
784+ in
785+ element{elContent = content' ++ map Elem newKids}
786+
787+
788+----------------------------------------------------------------
789+
790+registerLink :: PandocMonad m => (URL, String) -> P m Int
791+registerLink link = do
792+ curSlideId <- gets stCurSlideId
793+ linkReg <- gets stLinkIds
794+ mediaReg <- gets stMediaIds
795+ let maxLinkId = case M.lookup curSlideId linkReg of
796+ Just mp -> case M.keys mp of
797+ [] -> 1
798+ ks -> maximum ks
799+ Nothing -> 1
800+ maxMediaId = case M.lookup curSlideId mediaReg of
801+ Just [] -> 1
802+ Just mInfos -> maximum $ map mInfoLocalId mInfos
803+ Nothing -> 1
804+ maxId = max maxLinkId maxMediaId
805+ slideLinks = case M.lookup curSlideId linkReg of
806+ Just mp -> M.insert (maxId + 1) link mp
807+ Nothing -> M.singleton (maxId + 1) link
808+ modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg}
809+ return $ maxId + 1
810+
811+registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo
812+registerMedia fp caption = do
813+ curSlideId <- gets stCurSlideId
814+ linkReg <- gets stLinkIds
815+ mediaReg <- gets stMediaIds
816+ globalIds <- gets stMediaGlobalIds
817+ let maxLinkId = case M.lookup curSlideId linkReg of
818+ Just mp -> case M.keys mp of
819+ [] -> 1
820+ ks -> maximum ks
821+ Nothing -> 1
822+ maxMediaId = case M.lookup curSlideId mediaReg of
823+ Just [] -> 1
824+ Just mInfos -> maximum $ map mInfoLocalId mInfos
825+ Nothing -> 1
826+ maxLocalId = max maxLinkId maxMediaId
827+
828+ maxGlobalId = case M.elems globalIds of
829+ [] -> 0
830+ ids -> maximum ids
831+
832+ (imgBytes, mbMt) <- P.fetchItem fp
833+ let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x))
834+ <|>
835+ case imageType imgBytes of
836+ Just Png -> Just ".png"
837+ Just Jpeg -> Just ".jpeg"
838+ Just Gif -> Just ".gif"
839+ Just Pdf -> Just ".pdf"
840+ Just Eps -> Just ".eps"
841+ Just Svg -> Just ".svg"
842+ Nothing -> Nothing
843+
844+ let newGlobalId = case M.lookup fp globalIds of
845+ Just ident -> ident
846+ Nothing -> maxGlobalId + 1
847+
848+ let newGlobalIds = M.insert fp newGlobalId globalIds
849+
850+ let mediaInfo = MediaInfo { mInfoFilePath = fp
851+ , mInfoLocalId = maxLocalId + 1
852+ , mInfoGlobalId = newGlobalId
853+ , mInfoMimeType = mbMt
854+ , mInfoExt = imgExt
855+ , mInfoCaption = (not . null) caption
856+ }
857+
858+ let slideMediaInfos = case M.lookup curSlideId mediaReg of
859+ Just minfos -> mediaInfo : minfos
860+ Nothing -> [mediaInfo]
861+
862+
863+ modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg
864+ , stMediaGlobalIds = newGlobalIds
865+ }
866+ return mediaInfo
867+
868+makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry
869+makeMediaEntry mInfo = do
870+ epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
871+ (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
872+ let ext = case mInfoExt mInfo of
873+ Just e -> e
874+ Nothing -> ""
875+ let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext
876+ return $ toEntry fp epochtime $ BL.fromStrict imgBytes
877+
878+makeMediaEntries :: PandocMonad m => P m [Entry]
879+makeMediaEntries = do
880+ mediaInfos <- gets stMediaIds
881+ let allInfos = mconcat $ M.elems mediaInfos
882+ mapM makeMediaEntry allInfos
883+
884+-- | Scales the image to fit the page
885+-- sizes are passed in emu
886+fitToPage' :: (Double, Double) -- image size in emu
887+ -> Integer -- pageWidth
888+ -> Integer -- pageHeight
889+ -> (Integer, Integer) -- imagesize
890+fitToPage' (x, y) pageWidth pageHeight
891+ -- Fixes width to the page width and scales the height
892+ | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight =
893+ (floor x, floor y)
894+ | x / fromIntegral pageWidth > y / fromIntegral pageWidth =
895+ (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y)
896+ | otherwise =
897+ (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight)
898+
899+positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer)
900+positionImage (x, y) pageWidth pageHeight =
901+ let (x', y') = fitToPage' (x, y) pageWidth pageHeight
902+ in
903+ ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2)
904+
905+getMaster :: PandocMonad m => P m Element
906+getMaster = do
907+ refArchive <- asks envRefArchive
908+ distArchive <- asks envDistArchive
909+ parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml"
910+
911+-- We want to get the header dimensions, so we can make sure that the
912+-- image goes underneath it. We only use this in a content slide if it
913+-- has a header.
914+
915+getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer))
916+getHeaderSize = do
917+ master <- getMaster
918+ let ns = elemToNameSpaces master
919+ sps = [master] >>=
920+ findChildren (elemName ns "p" "cSld") >>=
921+ findChildren (elemName ns "p" "spTree") >>=
922+ findChildren (elemName ns "p" "sp")
923+ mbXfrm =
924+ listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>=
925+ findChild (elemName ns "p" "spPr") >>=
926+ findChild (elemName ns "a" "xfrm")
927+ xoff = mbXfrm >>=
928+ findChild (elemName ns "a" "off") >>=
929+ findAttr (QName "x" Nothing Nothing) >>=
930+ (listToMaybe . (\s -> reads s :: [(Integer, String)]))
931+ yoff = mbXfrm >>=
932+ findChild (elemName ns "a" "off") >>=
933+ findAttr (QName "y" Nothing Nothing) >>=
934+ (listToMaybe . (\s -> reads s :: [(Integer, String)]))
935+ xext = mbXfrm >>=
936+ findChild (elemName ns "a" "ext") >>=
937+ findAttr (QName "cx" Nothing Nothing) >>=
938+ (listToMaybe . (\s -> reads s :: [(Integer, String)]))
939+ yext = mbXfrm >>=
940+ findChild (elemName ns "a" "ext") >>=
941+ findAttr (QName "cy" Nothing Nothing) >>=
942+ (listToMaybe . (\s -> reads s :: [(Integer, String)]))
943+ off = case xoff of
944+ Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff')
945+ _ -> (1043490, 1027664)
946+ ext = case xext of
947+ Just (xext', _) | Just (yext',_) <- yext -> (xext', yext')
948+ _ -> (7024744, 1143000)
949+ return $ (off, ext)
950+
951+
952+-- Hard-coded for now
953+captionPosition :: ((Integer, Integer), (Integer, Integer))
954+captionPosition = ((457200, 6061972), (8229600, 527087))
955+
956+createCaption :: PandocMonad m => [ParaElem] -> P m Element
957+createCaption paraElements = do
958+ let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements
959+ elements <- mapM paragraphToElement [para]
960+ let ((x, y), (cx, cy)) = captionPosition
961+ let txBody = mknode "p:txBody" [] $
962+ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
963+ return $
964+ mknode "p:sp" [] [ mknode "p:nvSpPr" []
965+ [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()
966+ , mknode "p:cNvSpPr" [("txBox", "1")] ()
967+ , mknode "p:nvPr" [] ()
968+ ]
969+ , mknode "p:spPr" []
970+ [ mknode "a:xfrm" []
971+ [ mknode "a:off" [("x", show x), ("y", show y)] ()
972+ , mknode "a:ext" [("cx", show cx), ("cy", show cy)] ()
973+ ]
974+ , mknode "a:prstGeom" [("prst", "rect")]
975+ [ mknode "a:avLst" [] ()
976+ ]
977+ , mknode "a:noFill" [] ()
978+ ]
979+ , txBody
980+ ]
981+
982+-- Largely lifted from inlineToOpenXML' in T.P.W.Docx. Can't be easily
983+-- abstracted because of some different namespaces and monads. TODO.
984+makePicElement :: PandocMonad m
985+ => MediaInfo
986+ -> Text.Pandoc.Definition.Attr
987+ -> P m Element
988+makePicElement mInfo attr = do
989+ opts <- asks envOpts
990+ pageWidth <- presSizeWidth <$> asks envPresentationSize
991+ pageHeight <- getPageHeight <$> asks envPresentationSize
992+ hasHeader <- asks envSlideHasHeader
993+ let hasCaption = mInfoCaption mInfo
994+ (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
995+ -- We're not using x exts
996+ ((hXoff, hYoff), (_, hYext)) <- if hasHeader
997+ then getHeaderSize
998+ else return ((0, 0), (0, 0))
999+
1000+ let ((capX, capY), (_, _)) = if hasCaption
1001+ then captionPosition
1002+ else ((0,0), (0,0))
1003+ let (xpt,ypt) = desiredSizeInPoints opts attr
1004+ (either (const def) id (imageSize opts imgBytes))
1005+ -- 12700 emu = 1 pt
1006+ let (xemu,yemu) = fitToPage' (xpt * 12700, ypt * 12700)
1007+ ((pageWidth * 12700) - (2 * hXoff) - (2 * capX))
1008+ ((if hasCaption then capY else (pageHeight * 12700)) - (hYoff + hYext))
1009+ (xoff, yoff) = positionImage (xpt * 12700, ypt * 12700) (pageWidth * 12700) (pageHeight * 12700)
1010+ xoff' = if hasHeader then xoff + hXoff else xoff
1011+ xoff'' = if hasCaption then xoff' + capX else xoff'
1012+ yoff' = if hasHeader then hYoff + hYext else yoff
1013+ -- let (xemu,yemu)=((floor $ xpt * 12700), (floor $ ypt * 12700))
1014+ let cNvPicPr = mknode "p:cNvPicPr" [] $
1015+ mknode "a:picLocks" [("noGrp","1")
1016+ ,("noChangeAspect","1")] ()
1017+ let nvPicPr = mknode "p:nvPicPr" []
1018+ [ mknode "p:cNvPr"
1019+ [("descr", mInfoFilePath mInfo),("id","0"),("name","Picture 1")] ()
1020+ , cNvPicPr
1021+ , mknode "p:nvPr" [] ()]
1022+ let blipFill = mknode "p:blipFill" []
1023+ [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] ()
1024+ , mknode "a:stretch" [] $
1025+ mknode "a:fillRect" [] () ]
1026+ let xfrm = mknode "a:xfrm" []
1027+ [ mknode "a:off" [("x",show xoff''), ("y",show yoff')] ()
1028+ , mknode "a:ext" [("cx",show xemu)
1029+ ,("cy",show yemu)] () ]
1030+ let prstGeom = mknode "a:prstGeom" [("prst","rect")] $
1031+ mknode "a:avLst" [] ()
1032+ let ln = mknode "a:ln" [("w","9525")]
1033+ [ mknode "a:noFill" [] ()
1034+ , mknode "a:headEnd" [] ()
1035+ , mknode "a:tailEnd" [] () ]
1036+ let spPr = mknode "p:spPr" [("bwMode","auto")]
1037+ [xfrm, prstGeom, mknode "a:noFill" [] (), ln]
1038+ return $
1039+ mknode "p:pic" []
1040+ [ nvPicPr
1041+ , blipFill
1042+ , spPr ]
1043+
1044+-- Currently hardcoded, until I figure out how to make it dynamic.
1045+blockQuoteSize :: Pixels
1046+blockQuoteSize = 20
1047+
1048+paraElemToElement :: PandocMonad m => ParaElem -> P m Element
1049+paraElemToElement Break = return $ mknode "a:br" [] ()
1050+paraElemToElement (Run rpr s) = do
1051+ let attrs =
1052+ if rPropCode rpr
1053+ then []
1054+ else (if rPropBlockQuote rpr then [("sz", (show $ blockQuoteSize * 100))] else []) ++
1055+ (if rPropBold rpr then [("b", "1")] else []) ++
1056+ (if rPropItalics rpr then [("i", "1")] else []) ++
1057+ (case rStrikethrough rpr of
1058+ Just NoStrike -> [("strike", "noStrike")]
1059+ Just SingleStrike -> [("strike", "sngStrike")]
1060+ Just DoubleStrike -> [("strike", "dblStrike")]
1061+ Nothing -> []) ++
1062+ (case rBaseline rpr of
1063+ Just n -> [("baseline", show n)]
1064+ Nothing -> []) ++
1065+ (case rCap rpr of
1066+ Just NoCapitals -> [("cap", "none")]
1067+ Just SmallCapitals -> [("cap", "small")]
1068+ Just AllCapitals -> [("cap", "all")]
1069+ Nothing -> []) ++
1070+ []
1071+ linkProps <- case rLink rpr of
1072+ Just link -> do idNum <- registerLink link
1073+ return [mknode "a:hlinkClick"
1074+ [("r:id", "rId" ++ show idNum)]
1075+ ()
1076+ ]
1077+ Nothing -> return []
1078+ let propContents = if rPropCode rpr
1079+ then [mknode "a:latin" [("typeface", "Courier")] ()]
1080+ else linkProps
1081+ return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents
1082+ , mknode "a:t" [] s
1083+ ]
1084+paraElemToElement (MathElem mathType texStr) = do
1085+ res <- convertMath writeOMML mathType (unTeXString texStr)
1086+ case res of
1087+ Right r -> return $ mknode "a14:m" [] $ addMathInfo r
1088+ Left (Str s) -> paraElemToElement (Run def s)
1089+ Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback"
1090+
1091+-- This is a bit of a kludge -- really requires adding an option to
1092+-- TeXMath, but since that's a different package, we'll do this one
1093+-- step at a time.
1094+addMathInfo :: Element -> Element
1095+addMathInfo element =
1096+ let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns"))
1097+ , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"
1098+ }
1099+ in add_attr mathspace element
1100+
1101+-- We look through the element to see if it contains an a14:m
1102+-- element. If so, we surround it. This is a bit ugly, but it seems
1103+-- more dependable than looking through shapes for math. Plus this is
1104+-- an xml implementation detail, so it seems to make sense to do it at
1105+-- the xml level.
1106+surroundWithMathAlternate :: Element -> Element
1107+surroundWithMathAlternate element =
1108+ case findElement (QName "m" Nothing (Just "a14")) element of
1109+ Just _ ->
1110+ mknode "mc:AlternateContent"
1111+ [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")
1112+ ] [ mknode "mc:Choice"
1113+ [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")
1114+ , ("Requires", "a14")] [ element ]
1115+ ]
1116+ Nothing -> element
1117+
1118+paragraphToElement :: PandocMonad m => Paragraph -> P m Element
1119+paragraphToElement par = do
1120+ let
1121+ attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++
1122+ (case pPropMarginLeft (paraProps par) of
1123+ Just px -> [("marL", show $ 12700 * px), ("indent", "0")]
1124+ Nothing -> []
1125+ ) ++
1126+ (case pPropAlign (paraProps par) of
1127+ Just AlgnLeft -> [("algn", "l")]
1128+ Just AlgnRight -> [("algn", "r")]
1129+ Just AlgnCenter -> [("algn", "ctr")]
1130+ Nothing -> []
1131+ )
1132+ props = [] ++
1133+ (case pPropBullet $ paraProps par of
1134+ Just Bullet -> []
1135+ Just (AutoNumbering attrs') ->
1136+ [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()]
1137+ Nothing -> [mknode "a:buNone" [] ()]
1138+ )
1139+ paras <- mapM paraElemToElement (paraElems par)
1140+ return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras
1141+
1142+shapeToElement :: PandocMonad m => Element -> Shape -> P m Element
1143+shapeToElement layout (TextBox paras)
1144+ | ns <- elemToNameSpaces layout
1145+ , Just cSld <- findChild (elemName ns "p" "cSld") layout
1146+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld
1147+ , Just sp <- getContentShape ns spTree = do
1148+ elements <- mapM paragraphToElement paras
1149+ let txBody = mknode "p:txBody" [] $
1150+ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
1151+ emptySpPr = mknode "p:spPr" [] ()
1152+ return $
1153+ surroundWithMathAlternate $
1154+ replaceNamedChildren ns "p" "txBody" [txBody] $
1155+ replaceNamedChildren ns "p" "spPr" [emptySpPr] $
1156+ sp
1157+ -- XXX: TODO
1158+ | otherwise = return $ mknode "p:sp" [] ()
1159+-- XXX: TODO
1160+shapeToElement layout (Pic fp attr alt) = do
1161+ mInfo <- registerMedia fp alt
1162+ case mInfoExt mInfo of
1163+ Just _ -> makePicElement mInfo attr
1164+ Nothing -> shapeToElement layout $ TextBox [Paragraph def alt]
1165+shapeToElement _ (GraphicFrame tbls _) = do
1166+ elements <- mapM graphicToElement tbls
1167+ return $ mknode "p:graphicFrame" [] $
1168+ [ mknode "p:nvGraphicFramePr" [] $
1169+ [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()
1170+ , mknode "p:cNvGraphicFramePr" [] $
1171+ [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]
1172+ , mknode "p:nvPr" [] $
1173+ [mknode "p:ph" [("idx", "1")] ()]
1174+ ]
1175+ , mknode "p:xfrm" [] $
1176+ [ mknode "a:off" [("x", "457200"), ("y", "1600200")] ()
1177+ , mknode "a:ext" [("cx", "8029388"), ("cy", "3644152")] ()
1178+ ]
1179+ ] ++ elements
1180+
1181+shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]
1182+shapeToElements layout shp = do
1183+ case shp of
1184+ (Pic _ _ alt) | (not . null) alt -> do
1185+ element <- shapeToElement layout shp
1186+ caption <- createCaption alt
1187+ return [element, caption]
1188+ (GraphicFrame _ cptn) | (not . null) cptn -> do
1189+ element <- shapeToElement layout shp
1190+ caption <- createCaption cptn
1191+ return [element, caption]
1192+ _ -> do
1193+ element <- shapeToElement layout shp
1194+ return [element]
1195+
1196+shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element]
1197+shapesToElements layout shps = do
1198+ concat <$> mapM (shapeToElements layout) shps
1199+
1200+hardcodedTableMargin :: Integer
1201+hardcodedTableMargin = 36
1202+
1203+
1204+graphicToElement :: PandocMonad m => Graphic -> P m Element
1205+graphicToElement (Tbl tblPr colWidths hdrCells rows) = do
1206+ let cellToOpenXML paras = do elements <- mapM paragraphToElement paras
1207+ return $
1208+ [mknode "a:txBody" [] $
1209+ ([ mknode "a:bodyPr" [] ()
1210+ , mknode "a:lstStyle" [] ()]
1211+ ++ elements)]
1212+ headers' <- mapM cellToOpenXML hdrCells
1213+ rows' <- mapM (mapM cellToOpenXML) rows
1214+ let borderProps = mknode "a:tcPr" [] ()
1215+ let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]]
1216+ let mkcell border contents = mknode "a:tc" []
1217+ $ (if null contents
1218+ then emptyCell
1219+ else contents) ++ [ borderProps | border ]
1220+ let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells
1221+ -- let textwidth = 14400 -- 5.5 in in twips, 1/20 pt
1222+ -- let fullrow = 14400 -- 100% specified in pct
1223+ -- let rowwidth = fullrow * sum colWidths
1224+
1225+ let mkgridcol w = mknode "a:gridCol"
1226+ [("w", show ((12700 * w) :: Integer))] ()
1227+ let hasHeader = not (all null hdrCells)
1228+ return $ mknode "a:graphic" [] $
1229+ [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $
1230+ [mknode "a:tbl" [] $
1231+ [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0")
1232+ , ("bandRow", if tblPrBandRow tblPr then "1" else "0")
1233+ ] ()
1234+ , mknode "a:tblGrid" [] (if all (==0) colWidths
1235+ then []
1236+ else map mkgridcol colWidths)
1237+ ]
1238+ ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows'
1239+ ]
1240+ ]
1241+
1242+getShapeByName :: NameSpaces -> Element -> String -> Maybe Element
1243+getShapeByName ns spTreeElem name
1244+ | isElem ns "p" "spTree" spTreeElem =
1245+ filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem
1246+ | otherwise = Nothing
1247+
1248+nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element
1249+nonBodyTextToElement layout shapeName paraElements
1250+ | ns <- elemToNameSpaces layout
1251+ , Just cSld <- findChild (elemName ns "p" "cSld") layout
1252+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld
1253+ , Just sp <- getShapeByName ns spTree shapeName = do
1254+ let hdrPara = Paragraph def paraElements
1255+ element <- paragraphToElement hdrPara
1256+ let txBody = mknode "p:txBody" [] $
1257+ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++
1258+ [element]
1259+ return $ replaceNamedChildren ns "p" "txBody" [txBody] sp
1260+ -- XXX: TODO
1261+ | otherwise = return $ mknode "p:sp" [] ()
1262+
1263+
1264+-- hdrToElement :: Element -> [ParaElem] -> Element
1265+-- hdrToElement layout paraElems
1266+-- | ns <- elemToNameSpaces layout
1267+-- , Just cSld <- findChild (elemName ns "p" "cSld") layout
1268+-- , Just spTree <- findChild (elemName ns "p" "spTree") cSld
1269+-- , Just sp <- getContentTitleShape ns spTree =
1270+-- let hdrPara = Paragraph def paraElems
1271+-- txBody = mknode "p:txBody" [] $
1272+-- [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++
1273+-- [paragraphToElement hdrPara]
1274+-- in
1275+-- replaceNamedChildren ns "p" "txBody" [txBody] sp
1276+-- -- XXX: TODO
1277+-- | otherwise = mknode "p:sp" [] ()
1278+-- -- XXX: TODO
1279+-- hdrToElement _ _ = mknode "p:sp" [] ()
1280+
1281+contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element
1282+contentToElement layout hdrShape shapes
1283+ | ns <- elemToNameSpaces layout
1284+ , Just cSld <- findChild (elemName ns "p" "cSld") layout
1285+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
1286+ element <- nonBodyTextToElement layout "Title 1" hdrShape
1287+ let hdrShapeElements = if null hdrShape
1288+ then []
1289+ else [element]
1290+ contentElements <- shapesToElements layout shapes
1291+ return $
1292+ replaceNamedChildren ns "p" "sp"
1293+ (hdrShapeElements ++ contentElements)
1294+ spTree
1295+contentToElement _ _ _ = return $ mknode "p:sp" [] ()
1296+
1297+titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element
1298+titleToElement layout titleElems
1299+ | ns <- elemToNameSpaces layout
1300+ , Just cSld <- findChild (elemName ns "p" "cSld") layout
1301+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
1302+ element <- nonBodyTextToElement layout "Title 1" titleElems
1303+ let titleShapeElements = if null titleElems
1304+ then []
1305+ else [element]
1306+ return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree
1307+titleToElement _ _ = return $ mknode "p:sp" [] ()
1308+
1309+metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element
1310+metadataToElement layout titleElems subtitleElems authorsElems dateElems
1311+ | ns <- elemToNameSpaces layout
1312+ , Just cSld <- findChild (elemName ns "p" "cSld") layout
1313+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
1314+ titleShapeElements <- if null titleElems
1315+ then return []
1316+ else sequence [nonBodyTextToElement layout "Title 1" titleElems]
1317+ let combinedAuthorElems = intercalate [Break] authorsElems
1318+ subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems]
1319+ subtitleShapeElements <- if null subtitleAndAuthorElems
1320+ then return []
1321+ else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems]
1322+ dateShapeElements <- if null dateElems
1323+ then return []
1324+ else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems]
1325+ return $ replaceNamedChildren ns "p" "sp"
1326+ (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements)
1327+ spTree
1328+metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] ()
1329+
1330+slideToElement :: PandocMonad m => Slide -> P m Element
1331+slideToElement s@(ContentSlide hdrElems shapes) = do
1332+ layout <- getLayout s
1333+ spTree <- local (\env -> if null hdrElems
1334+ then env
1335+ else env{envSlideHasHeader=True}) $
1336+ contentToElement layout hdrElems shapes
1337+ return $ mknode "p:sld"
1338+ [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
1339+ ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
1340+ ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
1341+ ] [mknode "p:cSld" [] [spTree]]
1342+slideToElement s@(TitleSlide hdrElems) = do
1343+ layout <- getLayout s
1344+ spTree <- titleToElement layout hdrElems
1345+ return $ mknode "p:sld"
1346+ [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
1347+ ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
1348+ ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
1349+ ] [mknode "p:cSld" [] [spTree]]
1350+slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do
1351+ layout <- getLayout s
1352+ spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems
1353+ return $ mknode "p:sld"
1354+ [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
1355+ ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
1356+ ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
1357+ ] [mknode "p:cSld" [] [spTree]]
1358+
1359+-----------------------------------------------------------------------
1360+
1361+slideToFilePath :: Slide -> Int -> FilePath
1362+slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"
1363+
1364+slideToSlideId :: Monad m => Slide -> Int -> P m String
1365+slideToSlideId _ idNum = do
1366+ n <- gets stSlideIdOffset
1367+ return $ "rId" ++ (show $ idNum + n)
1368+
1369+
1370+data Relationship = Relationship { relId :: Int
1371+ , relType :: MimeType
1372+ , relTarget :: FilePath
1373+ } deriving (Show, Eq)
1374+
1375+elementToRel :: Element -> Maybe Relationship
1376+elementToRel element
1377+ | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing =
1378+ do rId <- findAttr (QName "Id" Nothing Nothing) element
1379+ numStr <- stripPrefix "rId" rId
1380+ num <- case reads numStr :: [(Int, String)] of
1381+ (n, _) : _ -> Just n
1382+ [] -> Nothing
1383+ type' <- findAttr (QName "Type" Nothing Nothing) element
1384+ target <- findAttr (QName "Target" Nothing Nothing) element
1385+ return $ Relationship num type' target
1386+ | otherwise = Nothing
1387+
1388+slideToPresRel :: Monad m => Slide -> Int -> P m Relationship
1389+slideToPresRel slide idNum = do
1390+ n <- gets stSlideIdOffset
1391+ let rId = idNum + n
1392+ fp = "slides/" ++ slideToFilePath slide idNum
1393+ return $ Relationship { relId = rId
1394+ , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
1395+ , relTarget = fp
1396+ }
1397+
1398+getRels :: PandocMonad m => P m [Relationship]
1399+getRels = do
1400+ refArchive <- asks envRefArchive
1401+ distArchive <- asks envDistArchive
1402+ relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels"
1403+ let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"
1404+ let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem
1405+ return $ mapMaybe elementToRel relElems
1406+
1407+presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]
1408+presentationToRels (Presentation _ slides) = do
1409+ mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]
1410+ rels <- getRels
1411+ let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels
1412+ -- We want to make room for the slides in the id space. The slides
1413+ -- will start at Id2 (since Id1 is for the slide master). There are
1414+ -- two slides in the data file, but that might change in the future,
1415+ -- so we will do this:
1416+ --
1417+ -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is.
1418+ -- 2. We add the difference between this and the number of slides to
1419+ -- all relWithoutSlide rels (unless they're 1)
1420+
1421+ let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of
1422+ [] -> 0 -- doesn't matter in this case, since
1423+ -- there will be nothing to map the
1424+ -- function over
1425+ l -> minimum l
1426+
1427+ modifyRelNum :: Int -> Int
1428+ modifyRelNum 1 = 1
1429+ modifyRelNum n = n - minRelNotOne + 2 + length slides
1430+
1431+ relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides
1432+
1433+ return $ mySlideRels ++ relsWithoutSlides'
1434+
1435+relToElement :: Relationship -> Element
1436+relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel))
1437+ , ("Type", relType rel)
1438+ , ("Target", relTarget rel) ] ()
1439+
1440+relsToElement :: [Relationship] -> Element
1441+relsToElement rels = mknode "Relationships"
1442+ [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
1443+ (map relToElement rels)
1444+
1445+presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry
1446+presentationToRelsEntry pres = do
1447+ rels <- presentationToRels pres
1448+ elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels
1449+
1450+elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry
1451+elemToEntry fp element = do
1452+ epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
1453+ return $ toEntry fp epochtime $ renderXml element
1454+
1455+slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry
1456+slideToEntry slide idNum = do
1457+ modify $ \st -> st{stCurSlideId = idNum}
1458+ element <- slideToElement slide
1459+ elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element
1460+
1461+slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry
1462+slideToSlideRelEntry slide idNum = do
1463+ element <- slideToSlideRelElement slide idNum
1464+ elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element
1465+
1466+linkRelElement :: Int -> (URL, String) -> Element
1467+linkRelElement idNum (url, _) =
1468+ mknode "Relationship" [ ("Id", "rId" ++ show idNum)
1469+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
1470+ , ("Target", url)
1471+ , ("TargetMode", "External")
1472+ ] ()
1473+
1474+linkRelElements :: M.Map Int (URL, String) -> [Element]
1475+linkRelElements mp = map (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)
1476+
1477+mediaRelElement :: MediaInfo -> Element
1478+mediaRelElement mInfo =
1479+ let ext = case mInfoExt mInfo of
1480+ Just e -> e
1481+ Nothing -> ""
1482+ in
1483+ mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo))
1484+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
1485+ , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)
1486+ ] ()
1487+
1488+slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element
1489+slideToSlideRelElement slide idNum = do
1490+ let target = case slide of
1491+ (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml"
1492+ (TitleSlide _) -> "../slideLayouts/slideLayout3.xml"
1493+ (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml"
1494+
1495+ linkIds <- gets stLinkIds
1496+ mediaIds <- gets stMediaIds
1497+
1498+ let linkRels = case M.lookup idNum linkIds of
1499+ Just mp -> linkRelElements mp
1500+ Nothing -> []
1501+ mediaRels = case M.lookup idNum mediaIds of
1502+ Just mInfos -> map mediaRelElement mInfos
1503+ Nothing -> []
1504+
1505+ return $
1506+ mknode "Relationships"
1507+ [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
1508+ ([mknode "Relationship" [ ("Id", "rId1")
1509+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")
1510+ , ("Target", target)] ()
1511+ ] ++ linkRels ++ mediaRels)
1512+
1513+-- slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry
1514+-- slideToSlideRelEntry slide idNum = do
1515+-- let fp = "ppt/slides/_rels/slide" ++ (show idNum) ++ ".xml.rels"
1516+-- elemToEntry fp $ slideToSlideRelElement slide
1517+
1518+slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element
1519+slideToSldIdElement slide idNum = do
1520+ let id' = show $ idNum + 255
1521+ rId <- slideToSlideId slide idNum
1522+ return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()
1523+
1524+presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
1525+presentationToSldIdLst (Presentation _ slides) = do
1526+ ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])
1527+ return $ mknode "p:sldIdLst" [] ids
1528+
1529+presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element
1530+presentationToPresentationElement pres = do
1531+ refArchive <- asks envRefArchive
1532+ distArchive <- asks envDistArchive
1533+ element <- parseXml refArchive distArchive "ppt/presentation.xml"
1534+ sldIdLst <- presentationToSldIdLst pres
1535+
1536+ let modifySldIdLst :: Content -> Content
1537+ modifySldIdLst (Elem e) = case elName e of
1538+ (QName "sldIdLst" _ _) -> Elem sldIdLst
1539+ _ -> Elem e
1540+ modifySldIdLst ct = ct
1541+
1542+ newContent = map modifySldIdLst $ elContent element
1543+
1544+ return $ element{elContent = newContent}
1545+
1546+presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry
1547+presentationToPresEntry pres = presentationToPresentationElement pres >>=
1548+ elemToEntry "ppt/presentation.xml"
1549+
1550+
1551+
1552+
1553+defaultContentTypeToElem :: DefaultContentType -> Element
1554+defaultContentTypeToElem dct =
1555+ mknode "Default"
1556+ [("Extension", defContentTypesExt dct),
1557+ ("ContentType", defContentTypesType dct)]
1558+ ()
1559+
1560+overrideContentTypeToElem :: OverrideContentType -> Element
1561+overrideContentTypeToElem oct =
1562+ mknode "Override"
1563+ [("PartName", overrideContentTypesPart oct),
1564+ ("ContentType", overrideContentTypesType oct)]
1565+ ()
1566+
1567+contentTypesToElement :: ContentTypes -> Element
1568+contentTypesToElement ct =
1569+ let ns = "http://schemas.openxmlformats.org/package/2006/content-types"
1570+ in
1571+ mknode "Types" [("xmlns", ns)] $
1572+ (map defaultContentTypeToElem $ contentTypesDefaults ct) ++
1573+ (map overrideContentTypeToElem $ contentTypesOverrides ct)
1574+
1575+data DefaultContentType = DefaultContentType
1576+ { defContentTypesExt :: String
1577+ , defContentTypesType:: MimeType
1578+ }
1579+ deriving (Show, Eq)
1580+
1581+data OverrideContentType = OverrideContentType
1582+ { overrideContentTypesPart :: FilePath
1583+ , overrideContentTypesType :: MimeType
1584+ }
1585+ deriving (Show, Eq)
1586+
1587+data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType]
1588+ , contentTypesOverrides :: [OverrideContentType]
1589+ }
1590+ deriving (Show, Eq)
1591+
1592+contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry
1593+contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct
1594+
1595+pathToOverride :: FilePath -> Maybe OverrideContentType
1596+pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)
1597+
1598+mediaContentType :: MediaInfo -> Maybe DefaultContentType
1599+mediaContentType mInfo
1600+ | Just ('.' : ext) <- mInfoExt mInfo =
1601+ Just $ DefaultContentType { defContentTypesExt = ext
1602+ , defContentTypesType =
1603+ case mInfoMimeType mInfo of
1604+ Just mt -> mt
1605+ Nothing -> "application/octet-stream"
1606+ }
1607+ | otherwise = Nothing
1608+
1609+presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
1610+presentationToContentTypes (Presentation _ slides) = do
1611+ mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
1612+ let defaults = [ DefaultContentType "xml" "application/xml"
1613+ , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
1614+ ]
1615+ mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos
1616+ inheritedOverrides = mapMaybe pathToOverride inheritedFiles
1617+ presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
1618+ slideOverrides =
1619+ mapMaybe
1620+ (\(s, n) ->
1621+ pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)
1622+ (zip slides [1..])
1623+ -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]
1624+ return $ ContentTypes
1625+ (defaults ++ mediaDefaults)
1626+ (inheritedOverrides ++ presOverride ++ slideOverrides)
1627+
1628+-- slideToElement :: Element -> Slide -> Element
1629+-- slideToElement layout (ContentSlide _ shapes) =
1630+-- let sps = map (shapeToElement layout) shapes
1631+
1632+presML :: String
1633+presML = "application/vnd.openxmlformats-officedocument.presentationml"
1634+
1635+noPresML :: String
1636+noPresML = "application/vnd.openxmlformats-officedocument"
1637+
1638+getContentType :: FilePath -> Maybe MimeType
1639+getContentType fp
1640+ | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml"
1641+ | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml"
1642+ | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml"
1643+ | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml"
1644+ | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml"
1645+ | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml"
1646+ | "ppt" : "slideMasters" : f : [] <- splitDirectories fp
1647+ , (_, ".xml") <- splitExtension f =
1648+ Just $ presML ++ ".slideMaster+xml"
1649+ | "ppt" : "slides" : f : [] <- splitDirectories fp
1650+ , (_, ".xml") <- splitExtension f =
1651+ Just $ presML ++ ".slide+xml"
1652+ | "ppt" : "notesMasters" : f : [] <- splitDirectories fp
1653+ , (_, ".xml") <- splitExtension f =
1654+ Just $ presML ++ ".notesMaster+xml"
1655+ | "ppt" : "notesSlides" : f : [] <- splitDirectories fp
1656+ , (_, ".xml") <- splitExtension f =
1657+ Just $ presML ++ ".notesSlide+xml"
1658+ | "ppt" : "theme" : f : [] <- splitDirectories fp
1659+ , (_, ".xml") <- splitExtension f =
1660+ Just $ noPresML ++ ".theme+xml"
1661+ -- | "ppt" : "slideLayouts" : f : [] <- splitDirectories fp
1662+ -- , (_, ".xml") <- splitExtension f =
1663+ | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp=
1664+ Just $ presML ++ ".slideLayout+xml"
1665+ | otherwise = Nothing