@@ -1,4 +1,4 @@
1−{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-}
1+{-# LANGUAGE PatternGuards #-}
22
33{-
44Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu>
@@ -27,44 +27,29 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2727 Stability : alpha
2828 Portability : portable
2929
30−Conversion of 'Pandoc' documents to powerpoint (pptx).
30+Conversion of 'Pandoc' documents to powerpoint (pptx). -}
31+
32+{-
33+This is a wrapper around two modules:
34+
35+ - Text.Pandoc.Writers.Powerpoint.Presentation (which converts a
36+ pandoc document into a Presentation datatype), and
37+
38+ - Text.Pandoc.Writers.Powerpoint.Output (which converts a
39+ Presentation into a zip archive, which can be output).
3140-}
3241
3342module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where
3443
35−import Control.Monad.Except (throwError, catchError)
36−import Control.Monad.Reader
37−import Control.Monad.State
3844import Codec.Archive.Zip
39−import Data.List (intercalate, stripPrefix, nub, union)
40−import Data.Default
41−import Data.Time.Clock (UTCTime)
42−import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
43−import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)
44−import Text.XML.Light
4545import Text.Pandoc.Definition
46−import qualified Text.Pandoc.UTF8 as UTF8
46+import Text.Pandoc.Walk
4747import Text.Pandoc.Class (PandocMonad)
48−import Text.Pandoc.Error (PandocError(..))
49−import Text.Pandoc.Slides (getSlideLevel)
50−import qualified Text.Pandoc.Class as P
51−import Text.Pandoc.Options
52−import Text.Pandoc.MIME
53−import Text.Pandoc.Logging
48+import Text.Pandoc.Options (WriterOptions)
49+import Text.Pandoc.Writers.Shared (fixDisplayMath)
50+import Text.Pandoc.Writers.Powerpoint.Presentation (documentToPresentation)
51+import Text.Pandoc.Writers.Powerpoint.Output (presentationToArchive)
5452import qualified Data.ByteString.Lazy as BL
55−import Text.Pandoc.Walk
56−import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"
57−import Text.Pandoc.Writers.Shared (fixDisplayMath, metaValueToInlines)
58−import Text.Pandoc.Writers.OOXML
59−import qualified Data.Map as M
60−import Data.Maybe (mapMaybe, listToMaybe, maybeToList, catMaybes)
61−import Text.Pandoc.ImageSize
62−import Control.Applicative ((<|>))
63−import System.FilePath.Glob
64−
65−import Text.TeXMath
66−import Text.Pandoc.Writers.Math (convertMath)
67−
6853
6954writePowerpoint :: (PandocMonad m)
7055 => WriterOptions -- ^ Writer options
@@ -72,1951 +57,6 @@ writePowerpoint :: (PandocMonad m)
7257 -> m BL.ByteString
7358writePowerpoint opts (Pandoc meta blks) = do
7459 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− presSize <- case getPresentationSize refArchive distArchive of
85− Just sz -> return sz
86− Nothing -> throwError $
87− PandocSomeError $
88− "Could not determine presentation size"
89−
90− let env = def { envMetadata = meta
91− , envRefArchive = refArchive
92− , envDistArchive = distArchive
93− , envUTCTime = utctime
94− , envOpts = opts
95− , envSlideLevel = case writerSlideLevel opts of
96− Just n -> n
97− Nothing -> getSlideLevel blks'
98− , envPresentationSize = presSize
99− }
100−
101− let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
102− }
103−
104− runP env st $ do pres <- blocksToPresentation blks'
105− archv <- presentationToArchive pres
106− return $ fromArchive archv
107−
108−concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
109−concatMapM f xs = liftM concat (mapM f xs)
110−
111−data WriterEnv = WriterEnv { envMetadata :: Meta
112− , envRunProps :: RunProps
113− , envParaProps :: ParaProps
114− , envSlideLevel :: Int
115− , envRefArchive :: Archive
116− , envDistArchive :: Archive
117− , envUTCTime :: UTCTime
118− , envOpts :: WriterOptions
119− , envPresentationSize :: (Integer, Integer)
120− , envSlideHasHeader :: Bool
121− , envInList :: Bool
122− , envInNoteSlide :: Bool
123− , envCurSlideId :: Int
124− -- the difference between the number at
125− -- the end of the slide file name and
126− -- the rId number
127− , envSlideIdOffset :: Int
128− , envContentType :: ContentType
129− }
130− deriving (Show)
131−
132−instance Default WriterEnv where
133− def = WriterEnv { envMetadata = mempty
134− , envRunProps = def
135− , envParaProps = def
136− , envSlideLevel = 2
137− , envRefArchive = emptyArchive
138− , envDistArchive = emptyArchive
139− , envUTCTime = posixSecondsToUTCTime 0
140− , envOpts = def
141− , envPresentationSize = (720, 540)
142− , envSlideHasHeader = False
143− , envInList = False
144− , envInNoteSlide = False
145− , envCurSlideId = 1
146− , envSlideIdOffset = 1
147− , envContentType = NormalContent
148− }
149−
150−data ContentType = NormalContent
151− | TwoColumnLeftContent
152− | TwoColumnRightContent
153− deriving (Show, Eq)
154−
155−data MediaInfo = MediaInfo { mInfoFilePath :: FilePath
156− , mInfoLocalId :: Int
157− , mInfoGlobalId :: Int
158− , mInfoMimeType :: Maybe MimeType
159− , mInfoExt :: Maybe String
160− , mInfoCaption :: Bool
161− } deriving (Show, Eq)
162−
163−data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String))
164− -- (FP, Local ID, Global ID, Maybe Mime)
165− , stMediaIds :: M.Map Int [MediaInfo]
166− , stMediaGlobalIds :: M.Map FilePath Int
167− , stNoteIds :: M.Map Int [Block]
168− -- associate anchors with slide id
169− , stAnchorMap :: M.Map String Int
170− -- media inherited from the template.
171− , stTemplateMedia :: [FilePath]
172− } deriving (Show, Eq)
173−
174−instance Default WriterState where
175− def = WriterState { stLinkIds = mempty
176− , stMediaIds = mempty
177− , stMediaGlobalIds = mempty
178− , stNoteIds = mempty
179− , stAnchorMap= mempty
180− , stTemplateMedia = []
181− }
182−
183−-- This populates the global ids map with images already in the
184−-- template, so the ids won't be used by images introduced by the
185−-- user.
186−initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int
187−initialGlobalIds refArchive distArchive =
188− let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
189− mediaPaths = filter (match (compile "ppt/media/image")) archiveFiles
190−
191− go :: FilePath -> Maybe (FilePath, Int)
192− go fp = do
193− s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp
194− (n, _) <- listToMaybe $ reads s
195− return (fp, n)
196− in
197− M.fromList $ mapMaybe go mediaPaths
198−
199−getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer)
200−getPresentationSize refArchive distArchive = do
201− entry <- findEntryByPath "ppt/presentation.xml" refArchive `mplus`
202− findEntryByPath "ppt/presentation.xml" distArchive
203− presElement <- parseXMLDoc $ UTF8.toStringLazy $ fromEntry entry
204− let ns = elemToNameSpaces presElement
205− sldSize <- findChild (elemName ns "p" "sldSz") presElement
206− cxS <- findAttr (QName "cx" Nothing Nothing) sldSize
207− cyS <- findAttr (QName "cy" Nothing Nothing) sldSize
208− (cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String)
209− (cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String)
210− return (cx `div` 12700, cy `div` 12700)
211−
212−type P m = ReaderT WriterEnv (StateT WriterState m)
213−
214−runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
215−runP env st p = evalStateT (runReaderT p env) st
216−
217−type Pixels = Integer
218−
219−data Presentation = Presentation [Slide]
220− deriving (Show)
221−
222−data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]
223− , metadataSlideSubtitle :: [ParaElem]
224− , metadataSlideAuthors :: [[ParaElem]]
225− , metadataSlideDate :: [ParaElem]
226− }
227− | TitleSlide { titleSlideHeader :: [ParaElem]}
228− | ContentSlide { contentSlideHeader :: [ParaElem]
229− , contentSlideContent :: [Shape]
230− }
231− | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem]
232− , twoColumnSlideLeft :: [Shape]
233− , twoColumnSlideRight :: [Shape]
234− }
235− deriving (Show, Eq)
236−
237−data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape
238− deriving (Show, Eq)
239−
240−data Shape = Pic PicProps FilePath Text.Pandoc.Definition.Attr [ParaElem]
241− | GraphicFrame [Graphic] [ParaElem]
242− | TextBox [Paragraph]
243− deriving (Show, Eq)
244−
245−type Cell = [Paragraph]
246−
247−data TableProps = TableProps { tblPrFirstRow :: Bool
248− , tblPrBandRow :: Bool
249− } deriving (Show, Eq)
250−
251−type ColWidth = Integer
252−
253−data Graphic = Tbl TableProps [ColWidth] [Cell] [[Cell]]
254− deriving (Show, Eq)
255−
256−
257−data Paragraph = Paragraph { paraProps :: ParaProps
258− , paraElems :: [ParaElem]
259− } deriving (Show, Eq)
260−
261−autoNumberingToType :: ListAttributes -> String
262−autoNumberingToType (_, numStyle, numDelim) =
263− typeString ++ delimString
264− where
265− typeString = case numStyle of
266− Decimal -> "arabic"
267− UpperAlpha -> "alphaUc"
268− LowerAlpha -> "alphaLc"
269− UpperRoman -> "romanUc"
270− LowerRoman -> "romanLc"
271− _ -> "arabic"
272− delimString = case numDelim of
273− Period -> "Period"
274− OneParen -> "ParenR"
275− TwoParens -> "ParenBoth"
276− _ -> "Period"
277−
278−data BulletType = Bullet
279− | AutoNumbering ListAttributes
280− deriving (Show, Eq)
281−
282−data Algnment = AlgnLeft | AlgnRight | AlgnCenter
283− deriving (Show, Eq)
284−
285−data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels
286− , pPropMarginRight :: Maybe Pixels
287− , pPropLevel :: Int
288− , pPropBullet :: Maybe BulletType
289− , pPropAlign :: Maybe Algnment
290− , pPropSpaceBefore :: Maybe Pixels
291− } deriving (Show, Eq)
292−
293−instance Default ParaProps where
294− def = ParaProps { pPropMarginLeft = Just 0
295− , pPropMarginRight = Just 0
296− , pPropLevel = 0
297− , pPropBullet = Nothing
298− , pPropAlign = Nothing
299− , pPropSpaceBefore = Nothing
300− }
301−
302−newtype TeXString = TeXString {unTeXString :: String}
303− deriving (Eq, Show)
304−
305−data ParaElem = Break
306− | Run RunProps String
307− -- It would be more elegant to have native TeXMath
308− -- Expressions here, but this allows us to use
309− -- `convertmath` from T.P.Writers.Math. Will perhaps
310− -- revisit in the future.
311− | MathElem MathType TeXString
312− deriving (Show, Eq)
313−
314−data Strikethrough = NoStrike | SingleStrike | DoubleStrike
315− deriving (Show, Eq)
316−
317−data Capitals = NoCapitals | SmallCapitals | AllCapitals
318− deriving (Show, Eq)
319−
320−type URL = String
321−
322−data RunProps = RunProps { rPropBold :: Bool
323− , rPropItalics :: Bool
324− , rStrikethrough :: Maybe Strikethrough
325− , rBaseline :: Maybe Int
326− , rCap :: Maybe Capitals
327− , rLink :: Maybe (URL, String)
328− , rPropCode :: Bool
329− , rPropBlockQuote :: Bool
330− , rPropForceSize :: Maybe Pixels
331− } deriving (Show, Eq)
332−
333−instance Default RunProps where
334− def = RunProps { rPropBold = False
335− , rPropItalics = False
336− , rStrikethrough = Nothing
337− , rBaseline = Nothing
338− , rCap = Nothing
339− , rLink = Nothing
340− , rPropCode = False
341− , rPropBlockQuote = False
342− , rPropForceSize = Nothing
343− }
344−
345−data PicProps = PicProps { picPropLink :: Maybe (URL, String)
346− } deriving (Show, Eq)
347−
348−instance Default PicProps where
349− def = PicProps { picPropLink = Nothing
350− }
351−
352−--------------------------------------------------
353−
354−inlinesToParElems :: Monad m => [Inline] -> P m [ParaElem]
355−inlinesToParElems ils = concatMapM inlineToParElems ils
356−
357−inlineToParElems :: Monad m => Inline -> P m [ParaElem]
358−inlineToParElems (Str s) = do
359− pr <- asks envRunProps
360− return [Run pr s]
361−inlineToParElems (Emph ils) =
362− local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $
363− inlinesToParElems ils
364−inlineToParElems (Strong ils) =
365− local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $
366− inlinesToParElems ils
367−inlineToParElems (Strikeout ils) =
368− local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $
369− inlinesToParElems ils
370−inlineToParElems (Superscript ils) =
371− local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $
372− inlinesToParElems ils
373−inlineToParElems (Subscript ils) =
374− local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $
375− inlinesToParElems ils
376−inlineToParElems (SmallCaps ils) =
377− local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $
378− inlinesToParElems ils
379−inlineToParElems Space = inlineToParElems (Str " ")
380−inlineToParElems SoftBreak = inlineToParElems (Str " ")
381−inlineToParElems LineBreak = return [Break]
382−inlineToParElems (Link _ ils (url, title)) = do
383− local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $
384− inlinesToParElems ils
385−inlineToParElems (Code _ str) = do
386− local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $
387− inlineToParElems $ Str str
388−inlineToParElems (Math mathtype str) =
389− return [MathElem mathtype (TeXString str)]
390−inlineToParElems (Note blks) = do
391− notes <- gets stNoteIds
392− let maxNoteId = case M.keys notes of
393− [] -> 0
394− lst -> maximum lst
395− curNoteId = maxNoteId + 1
396− modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes }
397− inlineToParElems $ Superscript [Str $ show curNoteId]
398−inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils
399−inlineToParElems (RawInline _ _) = return []
400−inlineToParElems _ = return []
401−
402−isListType :: Block -> Bool
403−isListType (OrderedList _ _) = True
404−isListType (BulletList _) = True
405−isListType (DefinitionList _) = True
406−isListType _ = False
407−
408−registerAnchorId :: PandocMonad m => String -> P m ()
409−registerAnchorId anchor = do
410− anchorMap <- gets stAnchorMap
411− slideId <- asks envCurSlideId
412− unless (null anchor) $
413− modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}
414−
415−blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph]
416−blockToParagraphs (Plain ils) = do
417− parElems <- inlinesToParElems ils
418− pProps <- asks envParaProps
419− return [Paragraph pProps parElems]
420−blockToParagraphs (Para ils) = do
421− parElems <- inlinesToParElems ils
422− pProps <- asks envParaProps
423− return [Paragraph pProps parElems]
424−blockToParagraphs (LineBlock ilsList) = do
425− parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList
426− pProps <- asks envParaProps
427− return [Paragraph pProps parElems]
428−-- TODO: work out the attributes
429−blockToParagraphs (CodeBlock attr str) =
430− local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $
431− blockToParagraphs $ Para [Code attr str]
432−-- We can't yet do incremental lists, but we should render a
433−-- (BlockQuote List) as a list to maintain compatibility with other
434−-- formats.
435−blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do
436− ps <- blockToParagraphs blk
437− ps' <- blockToParagraphs $ BlockQuote blks
438− return $ ps ++ ps'
439−blockToParagraphs (BlockQuote blks) =
440− local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}
441− , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$
442− concatMapM blockToParagraphs blks
443−-- TODO: work out the format
444−blockToParagraphs (RawBlock _ _) = return []
445−blockToParagraphs (Header _ (ident, _, _) ils) = do
446− -- Note that this function only deals with content blocks, so it
447− -- will only touch headers that are above the current slide level --
448− -- slides at or below the slidelevel will be taken care of by
449− -- `blocksToSlide'`. We have the register anchors in both of them.
450− registerAnchorId ident
451− -- we set the subeader to bold
452− parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $
453− inlinesToParElems ils
454− -- and give it a bit of space before it.
455− return [Paragraph def{pPropSpaceBefore = Just 30} parElems]
456−blockToParagraphs (BulletList blksLst) = do
457− pProps <- asks envParaProps
458− let lvl = pPropLevel pProps
459− local (\env -> env{ envInList = True
460− , envParaProps = pProps{ pPropLevel = lvl + 1
461− , pPropBullet = Just Bullet
462− , pPropMarginLeft = Nothing
463− }}) $
464− concatMapM multiParBullet blksLst
465−blockToParagraphs (OrderedList listAttr blksLst) = do
466− pProps <- asks envParaProps
467− let lvl = pPropLevel pProps
468− local (\env -> env{ envInList = True
469− , envParaProps = pProps{ pPropLevel = lvl + 1
470− , pPropBullet = Just (AutoNumbering listAttr)
471− , pPropMarginLeft = Nothing
472− }}) $
473− concatMapM multiParBullet blksLst
474−blockToParagraphs (DefinitionList entries) = do
475− let go :: PandocMonad m => ([Inline], [[Block]]) -> P m [Paragraph]
476− go (ils, blksLst) = do
477− term <-blockToParagraphs $ Para [Strong ils]
478− -- For now, we'll treat each definition term as a
479− -- blockquote. We can extend this further later.
480− definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst
481− return $ term ++ definition
482− concatMapM go entries
483−blockToParagraphs (Div (_, ("notes" : []), _) _) = return []
484−blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks
485−blockToParagraphs blk = do
486− P.report $ BlockNotRendered blk
487− return []
488−
489−-- Make sure the bullet env gets turned off after the first para.
490−multiParBullet :: PandocMonad m => [Block] -> P m [Paragraph]
491−multiParBullet [] = return []
492−multiParBullet (b:bs) = do
493− pProps <- asks envParaProps
494− p <- blockToParagraphs b
495− ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $
496− concatMapM blockToParagraphs bs
497− return $ p ++ ps
498−
499−cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> P m [Paragraph]
500−cellToParagraphs algn tblCell = do
501− paras <- mapM (blockToParagraphs) tblCell
502− let alignment = case algn of
503− AlignLeft -> Just AlgnLeft
504− AlignRight -> Just AlgnRight
505− AlignCenter -> Just AlgnCenter
506− AlignDefault -> Nothing
507− paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras
508− return $ concat paras'
509−
510−rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> P m [[Paragraph]]
511−rowToParagraphs algns tblCells = do
512− -- We have to make sure we have the right number of alignments
513− let pairs = zip (algns ++ repeat AlignDefault) tblCells
514− mapM (\(a, tc) -> cellToParagraphs a tc) pairs
515−
516−blockToShape :: PandocMonad m => Block -> P m Shape
517−blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il =
518− Pic def url attr <$> (inlinesToParElems ils)
519−blockToShape (Para (il:_)) | Image attr ils (url, _) <- il =
520− Pic def url attr <$> (inlinesToParElems ils)
521−blockToShape (Plain (il:_)) | Link _ (il':_) target <- il
522− , Image attr ils (url, _) <- il' =
523− Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)
524−blockToShape (Para (il:_)) | Link _ (il':_) target <- il
525− , Image attr ils (url, _) <- il' =
526− Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)
527−blockToShape (Table caption algn _ hdrCells rows) = do
528− caption' <- inlinesToParElems caption
529− (pageWidth, _) <- asks envPresentationSize
530− hdrCells' <- rowToParagraphs algn hdrCells
531− rows' <- mapM (rowToParagraphs algn) rows
532− let tblPr = if null hdrCells
533− then TableProps { tblPrFirstRow = False
534− , tblPrBandRow = True
535− }
536− else TableProps { tblPrFirstRow = True
537− , tblPrBandRow = True
538− }
539− colWidths = if null hdrCells
540− then case rows of
541− r : _ | not (null r) -> replicate (length r) $
542− (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length r)
543− -- satisfy the compiler. This is the same as
544− -- saying that rows is empty, but the compiler
545− -- won't understand that `[]` exhausts the
546− -- alternatives.
547− _ -> []
548− else replicate (length hdrCells) $
549− (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells)
550−
551− return $ GraphicFrame [Tbl tblPr colWidths hdrCells' rows'] caption'
552−blockToShape blk = TextBox <$> blockToParagraphs blk
553−
554−blocksToShapes :: PandocMonad m => [Block] -> P m [Shape]
555−blocksToShapes blks = combineShapes <$> mapM blockToShape blks
556−
557−isImage :: Inline -> Bool
558−isImage (Image _ _ _) = True
559−isImage (Link _ ((Image _ _ _) : _) _) = True
560−isImage _ = False
561−
562−splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> P m [[Block]]
563−splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur])
564−splitBlocks' cur acc (HorizontalRule : blks) =
565− splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks
566−splitBlocks' cur acc (h@(Header n _ _) : blks) = do
567− slideLevel <- asks envSlideLevel
568− case compare n slideLevel of
569− LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks
570− EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks
571− GT -> splitBlocks' (cur ++ [h]) acc blks
572−-- `blockToParagraphs` treats Plain and Para the same, so we can save
573−-- some code duplication by treating them the same here.
574−splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks)
575−splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do
576− slideLevel <- asks envSlideLevel
577− case cur of
578− (Header n _ _) : [] | n == slideLevel ->
579− splitBlocks' []
580− (acc ++ [cur ++ [Para [il]]])
581− (if null ils then blks else (Para ils) : blks)
582− _ -> splitBlocks' []
583− (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]])
584− (if null ils then blks else (Para ils) : blks)
585−splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do
586− slideLevel <- asks envSlideLevel
587− case cur of
588− (Header n _ _) : [] | n == slideLevel ->
589− splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks
590− _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks
591−splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do
592− slideLevel <- asks envSlideLevel
593− case cur of
594− (Header n _ _) : [] | n == slideLevel ->
595− splitBlocks' [] (acc ++ [cur ++ [d]]) blks
596− _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks
597−splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks
598−
599−splitBlocks :: Monad m => [Block] -> P m [[Block]]
600−splitBlocks = splitBlocks' [] []
601−
602−blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide
603−blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)
604− | n < lvl = do
605− registerAnchorId ident
606− hdr <- inlinesToParElems ils
607− return $ TitleSlide {titleSlideHeader = hdr}
608− | n == lvl = do
609− registerAnchorId ident
610− hdr <- inlinesToParElems ils
611− -- Now get the slide without the header, and then add the header
612− -- in.
613− slide <- blocksToSlide' lvl blks
614− return $ case slide of
615− ContentSlide _ cont -> ContentSlide hdr cont
616− TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR
617− slide' -> slide'
618−blocksToSlide' _ (blk : blks)
619− | Div (_, classes, _) divBlks <- blk
620− , "columns" `elem` classes
621− , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks
622− , "column" `elem` clsL, "column" `elem` clsR = do
623− unless (null blks)
624− (mapM (P.report . BlockNotRendered) blks >> return ())
625− unless (null remaining)
626− (mapM (P.report . BlockNotRendered) remaining >> return ())
627− mbSplitBlksL <- splitBlocks blksL
628− mbSplitBlksR <- splitBlocks blksR
629− let blksL' = case mbSplitBlksL of
630− bs : _ -> bs
631− [] -> []
632− let blksR' = case mbSplitBlksR of
633− bs : _ -> bs
634− [] -> []
635− shapesL <- blocksToShapes blksL'
636− shapesR <- blocksToShapes blksR'
637− return $ TwoColumnSlide { twoColumnSlideHeader = []
638− , twoColumnSlideLeft = shapesL
639− , twoColumnSlideRight = shapesR
640− }
641−blocksToSlide' _ (blk : blks) = do
642− inNoteSlide <- asks envInNoteSlide
643− shapes <- if inNoteSlide
644− then forceFontSize noteSize $ blocksToShapes (blk : blks)
645− else blocksToShapes (blk : blks)
646− return $ ContentSlide { contentSlideHeader = []
647− , contentSlideContent = shapes
648− }
649−blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []
650− , contentSlideContent = []
651− }
652−
653−blocksToSlide :: PandocMonad m => [Block] -> P m Slide
654−blocksToSlide blks = do
655− slideLevel <- asks envSlideLevel
656− blocksToSlide' slideLevel blks
657−
658−makeNoteEntry :: Int -> [Block] -> [Block]
659−makeNoteEntry n blks =
660− let enum = Str (show n ++ ".")
661− in
662− case blks of
663− (Para ils : blks') -> (Para $ enum : Space : ils) : blks'
664− _ -> (Para [enum]) : blks
665−
666−forceFontSize :: PandocMonad m => Pixels -> P m a -> P m a
667−forceFontSize px x = do
668− rpr <- asks envRunProps
669− local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x
670−
671−-- We leave these as blocks because we will want to include them in
672−-- the TOC.
673−makeNotesSlideBlocks :: PandocMonad m => P m [Block]
674−makeNotesSlideBlocks = do
675− noteIds <- gets stNoteIds
676− slideLevel <- asks envSlideLevel
677− meta <- asks envMetadata
678− -- Get identifiers so we can give the notes section a unique ident.
679− anchorSet <- M.keysSet <$> gets stAnchorMap
680− if M.null noteIds
681− then return []
682− else do let title = case lookupMeta "notes-title" meta of
683− Just val -> metaValueToInlines val
684− Nothing -> [Str "Notes"]
685− ident = Shared.uniqueIdent title anchorSet
686− hdr = Header slideLevel (ident, [], []) title
687− blks <- return $
688− concatMap (\(n, bs) -> makeNoteEntry n bs) $
689− M.toList noteIds
690− return $ hdr : blks
691−
692−getMetaSlide :: PandocMonad m => P m (Maybe Slide)
693−getMetaSlide = do
694− meta <- asks envMetadata
695− title <- inlinesToParElems $ docTitle meta
696− subtitle <- inlinesToParElems $
697− case lookupMeta "subtitle" meta of
698− Just (MetaString s) -> [Str s]
699− Just (MetaInlines ils) -> ils
700− Just (MetaBlocks [Plain ils]) -> ils
701− Just (MetaBlocks [Para ils]) -> ils
702− _ -> []
703− authors <- mapM inlinesToParElems $ docAuthors meta
704− date <- inlinesToParElems $ docDate meta
705− if null title && null subtitle && null authors && null date
706− then return Nothing
707− else return $ Just $ MetadataSlide { metadataSlideTitle = title
708− , metadataSlideSubtitle = subtitle
709− , metadataSlideAuthors = authors
710− , metadataSlideDate = date
711− }
712−
713−-- adapted from the markdown writer
714−elementToListItem :: PandocMonad m => Shared.Element -> P m [Block]
715−elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do
716− opts <- asks envOpts
717− let headerLink = if null ident
718− then walk Shared.deNote headerText
719− else [Link nullAttr (walk Shared.deNote headerText)
720− ('#':ident, "")]
721− listContents <- if null subsecs || lev >= writerTOCDepth opts
722− then return []
723− else mapM elementToListItem subsecs
724− return [Plain headerLink, BulletList listContents]
725−elementToListItem (Shared.Blk _) = return []
726−
727−makeTOCSlide :: PandocMonad m => [Block] -> P m Slide
728−makeTOCSlide blks = do
729− contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks)
730− meta <- asks envMetadata
731− slideLevel <- asks envSlideLevel
732− let tocTitle = case lookupMeta "toc-title" meta of
733− Just val -> metaValueToInlines val
734− Nothing -> [Str "Table of Contents"]
735− hdr = Header slideLevel nullAttr tocTitle
736− sld <- blocksToSlide [hdr, contents]
737− return sld
738−
739−blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation
740−blocksToPresentation blks = do
741− opts <- asks envOpts
742− let metadataStartNum = 1
743− metadataslides <- maybeToList <$> getMetaSlide
744− let tocStartNum = metadataStartNum + length metadataslides
745− -- As far as I can tell, if we want to have a variable-length toc in
746− -- the future, we'll have to make it twice. Once to get the length,
747− -- and a second time to include the notes slide. We can't make the
748− -- notes slide before the body slides because we need to know if
749− -- there are notes, and we can't make either before the toc slide,
750− -- because we need to know its length to get slide numbers right.
751− --
752− -- For now, though, since the TOC slide is only length 1, if it
753− -- exists, we'll just get the length, and then come back to make the
754− -- slide later
755− let tocSlidesLength = if writerTableOfContents opts then 1 else 0
756− let bodyStartNum = tocStartNum + tocSlidesLength
757− blksLst <- splitBlocks blks
758− bodyslides <- mapM
759− (\(bs, n) -> local (\st -> st{envCurSlideId = n}) (blocksToSlide bs))
760− (zip blksLst [bodyStartNum..])
761− let noteStartNum = bodyStartNum + length bodyslides
762− notesSlideBlocks <- makeNotesSlideBlocks
763− -- now we come back and make the real toc...
764− tocSlides <- if writerTableOfContents opts
765− then do toc <- makeTOCSlide $ blks ++ notesSlideBlocks
766− return [toc]
767− else return []
768− -- ... and the notes slide. We test to see if the blocks are empty,
769− -- because we don't want to make an empty slide.
770− notesSlides <- if null notesSlideBlocks
771− then return []
772− else do notesSlide <- local
773− (\env -> env { envCurSlideId = noteStartNum
774− , envInNoteSlide = True
775− })
776− (blocksToSlide $ notesSlideBlocks)
777− return [notesSlide]
778− return $
779− Presentation $
780− metadataslides ++ tocSlides ++ bodyslides ++ notesSlides
781−
782−--------------------------------------------------------------------
783−
784−copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive
785−copyFileToArchive arch fp = do
786− refArchive <- asks envRefArchive
787− distArchive <- asks envDistArchive
788− case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
789− Nothing -> fail $ fp ++ " missing in reference file"
790− Just e -> return $ addEntryToArchive e arch
791−
792−inheritedPatterns :: [Pattern]
793−inheritedPatterns = map compile [ "_rels/.rels"
794− , "docProps/app.xml"
795− , "docProps/core.xml"
796− , "ppt/slideLayouts/slideLayout*.xml"
797− , "ppt/slideLayouts/_rels/slideLayout*.xml.rels"
798− , "ppt/slideMasters/slideMaster1.xml"
799− , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
800− , "ppt/theme/theme1.xml"
801− , "ppt/theme/_rels/theme1.xml.rels"
802− , "ppt/presProps.xml"
803− , "ppt/viewProps.xml"
804− , "ppt/tableStyles.xml"
805− , "ppt/media/image*"
806− ]
807−
808−patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]
809−patternToFilePaths pat = do
810− refArchive <- asks envRefArchive
811− distArchive <- asks envDistArchive
812−
813− let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
814− return $ filter (match pat) archiveFiles
815−
816−patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]
817−patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats
818−
819−-- Here are the files we'll require to make a Powerpoint document. If
820−-- any of these are missing, we should error out of our build.
821−requiredFiles :: [FilePath]
822−requiredFiles = [ "_rels/.rels"
823− , "docProps/app.xml"
824− , "docProps/core.xml"
825− , "ppt/presProps.xml"
826− , "ppt/slideLayouts/slideLayout1.xml"
827− , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
828− , "ppt/slideLayouts/slideLayout2.xml"
829− , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
830− , "ppt/slideLayouts/slideLayout3.xml"
831− , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
832− , "ppt/slideLayouts/slideLayout4.xml"
833− , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
834− , "ppt/slideMasters/slideMaster1.xml"
835− , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
836− , "ppt/theme/theme1.xml"
837− , "ppt/viewProps.xml"
838− , "ppt/tableStyles.xml"
839− ]
840−
841−
842−presentationToArchive :: PandocMonad m => Presentation -> P m Archive
843−presentationToArchive p@(Presentation slides) = do
844− filePaths <- patternsToFilePaths inheritedPatterns
845−
846− -- make sure all required files are available:
847− let missingFiles = filter (\fp -> not (fp `elem` filePaths)) requiredFiles
848− unless (null missingFiles)
849− (throwError $
850− PandocSomeError $
851− "The following required files are missing:\n" ++
852− (unlines $ map (" " ++) missingFiles)
853− )
854−
855− newArch' <- foldM copyFileToArchive emptyArchive filePaths
856− -- presentation entry and rels. We have to do the rels first to make
857− -- sure we know the correct offset for the rIds.
858− presEntry <- presentationToPresEntry p
859− presRelsEntry <- presentationToRelsEntry p
860− slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]
861− slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]
862− -- These have to come after everything, because they need the info
863− -- built up in the state.
864− mediaEntries <- makeMediaEntries
865− contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry
866− -- fold everything into our inherited archive and return it.
867− return $ foldr addEntryToArchive newArch' $
868− slideEntries ++
869− slideRelEntries ++
870− mediaEntries ++
871− [contentTypesEntry, presEntry, presRelsEntry]
872−
873−--------------------------------------------------
874−
875−combineShapes :: [Shape] -> [Shape]
876−combineShapes [] = []
877−combineShapes (s : []) = [s]
878−combineShapes (pic@(Pic _ _ _ _) : ss) = pic : combineShapes ss
879−combineShapes ((TextBox []) : ss) = combineShapes ss
880−combineShapes (s : TextBox [] : ss) = combineShapes (s : ss)
881−combineShapes ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) =
882− combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss
883−combineShapes (s:ss) = s : combineShapes ss
884−
885−--------------------------------------------------
886−
887−getLayout :: PandocMonad m => Slide -> P m Element
888−getLayout slide = do
889− let layoutpath = case slide of
890− (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml"
891− (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml"
892− (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml"
893− (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml"
894− distArchive <- asks envDistArchive
895− root <- case findEntryByPath layoutpath distArchive of
896− Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of
897− Just element -> return $ element
898− Nothing -> throwError $
899− PandocSomeError $
900− layoutpath ++ " corrupt in reference file"
901− Nothing -> throwError $
902− PandocSomeError $
903− layoutpath ++ " missing in reference file"
904− return root
905−
906−shapeHasName :: NameSpaces -> String -> Element -> Bool
907−shapeHasName ns name element
908− | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element
909− , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr
910− , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr =
911− nm == name
912− | otherwise = False
913−
914−shapeHasId :: NameSpaces -> String -> Element -> Bool
915−shapeHasId ns ident element
916− | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element
917− , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr
918− , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr =
919− nm == ident
920− | otherwise = False
921−
922−-- The content shape in slideLayout2 (Title/Content) has id=3 In
923−-- slideLayout4 (two column) the left column is id=3, and the right
924−-- column is id=4.
925−getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element
926−getContentShape ns spTreeElem
927− | isElem ns "p" "spTree" spTreeElem = do
928− contentType <- asks envContentType
929− let ident = case contentType of
930− NormalContent -> "3"
931− TwoColumnLeftContent -> "3"
932− TwoColumnRightContent -> "4"
933− case filterChild
934− (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e))
935− spTreeElem
936− of
937− Just e -> return e
938− Nothing -> throwError $
939− PandocSomeError $
940− "Could not find shape for Powerpoint content"
941−getContentShape _ _ = throwError $
942− PandocSomeError $
943− "Attempted to find content on non shapeTree"
944−
945−getShapeDimensions :: NameSpaces
946− -> Element
947− -> Maybe ((Integer, Integer), (Integer, Integer))
948−getShapeDimensions ns element
949− | isElem ns "p" "sp" element = do
950− spPr <- findChild (elemName ns "p" "spPr") element
951− xfrm <- findChild (elemName ns "a" "xfrm") spPr
952− off <- findChild (elemName ns "a" "off") xfrm
953− xS <- findAttr (QName "x" Nothing Nothing) off
954− yS <- findAttr (QName "y" Nothing Nothing) off
955− ext <- findChild (elemName ns "a" "ext") xfrm
956− cxS <- findAttr (QName "cx" Nothing Nothing) ext
957− cyS <- findAttr (QName "cy" Nothing Nothing) ext
958− (x, _) <- listToMaybe $ reads xS
959− (y, _) <- listToMaybe $ reads yS
960− (cx, _) <- listToMaybe $ reads cxS
961− (cy, _) <- listToMaybe $ reads cyS
962− return $ ((x `div` 12700, y `div` 12700), (cx `div` 12700, cy `div` 12700))
963− | otherwise = Nothing
964−
965−
966−getMasterShapeDimensionsById :: String
967− -> Element
968− -> Maybe ((Integer, Integer), (Integer, Integer))
969−getMasterShapeDimensionsById ident master = do
970− let ns = elemToNameSpaces master
971− cSld <- findChild (elemName ns "p" "cSld") master
972− spTree <- findChild (elemName ns "p" "spTree") cSld
973− sp <- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTree
974− getShapeDimensions ns sp
975−
976−getContentShapeSize :: PandocMonad m
977− => NameSpaces
978− -> Element
979− -> Element
980− -> P m ((Integer, Integer), (Integer, Integer))
981−getContentShapeSize ns layout master
982− | isElem ns "p" "sldLayout" layout
983− , Just cSld <- findChild (elemName ns "p" "cSld") layout
984− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
985− sp <- getContentShape ns spTree
986− case getShapeDimensions ns sp of
987− Just sz -> return sz
988− Nothing -> do let mbSz =
989− findChild (elemName ns "p" "nvSpPr") sp >>=
990− findChild (elemName ns "p" "cNvPr") >>=
991− findAttr (QName "id" Nothing Nothing) >>=
992− flip getMasterShapeDimensionsById master
993− case mbSz of
994− Just sz' -> return sz'
995− Nothing -> throwError $
996− PandocSomeError $
997− "Couldn't find necessary content shape size"
998−getContentShapeSize _ _ _ = throwError $
999− PandocSomeError $
1000− "Attempted to find content shape size in non-layout"
1001−
1002−replaceNamedChildren :: NameSpaces
1003− -> String
1004− -> String
1005− -> [Element]
1006− -> Element
1007− -> Element
1008−replaceNamedChildren ns prefix name newKids element =
1009− element { elContent = concat $ fun True $ elContent element }
1010− where
1011− fun :: Bool -> [Content] -> [[Content]]
1012− fun _ [] = []
1013− fun switch ((Elem e) : conts) | isElem ns prefix name e =
1014− if switch
1015− then (map Elem $ newKids) : fun False conts
1016− else fun False conts
1017− fun switch (cont : conts) = [cont] : fun switch conts
1018−
1019−----------------------------------------------------------------
1020−
1021−registerLink :: PandocMonad m => (URL, String) -> P m Int
1022−registerLink link = do
1023− curSlideId <- asks envCurSlideId
1024− linkReg <- gets stLinkIds
1025− mediaReg <- gets stMediaIds
1026− let maxLinkId = case M.lookup curSlideId linkReg of
1027− Just mp -> case M.keys mp of
1028− [] -> 1
1029− ks -> maximum ks
1030− Nothing -> 1
1031− maxMediaId = case M.lookup curSlideId mediaReg of
1032− Just [] -> 1
1033− Just mInfos -> maximum $ map mInfoLocalId mInfos
1034− Nothing -> 1
1035− maxId = max maxLinkId maxMediaId
1036− slideLinks = case M.lookup curSlideId linkReg of
1037− Just mp -> M.insert (maxId + 1) link mp
1038− Nothing -> M.singleton (maxId + 1) link
1039− modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg}
1040− return $ maxId + 1
1041−
1042−registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo
1043−registerMedia fp caption = do
1044− curSlideId <- asks envCurSlideId
1045− linkReg <- gets stLinkIds
1046− mediaReg <- gets stMediaIds
1047− globalIds <- gets stMediaGlobalIds
1048− let maxLinkId = case M.lookup curSlideId linkReg of
1049− Just mp -> case M.keys mp of
1050− [] -> 1
1051− ks -> maximum ks
1052− Nothing -> 1
1053− maxMediaId = case M.lookup curSlideId mediaReg of
1054− Just [] -> 1
1055− Just mInfos -> maximum $ map mInfoLocalId mInfos
1056− Nothing -> 1
1057− maxLocalId = max maxLinkId maxMediaId
1058−
1059− maxGlobalId = case M.elems globalIds of
1060− [] -> 0
1061− ids -> maximum ids
1062−
1063− (imgBytes, mbMt) <- P.fetchItem fp
1064− let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x))
1065− <|>
1066− case imageType imgBytes of
1067− Just Png -> Just ".png"
1068− Just Jpeg -> Just ".jpeg"
1069− Just Gif -> Just ".gif"
1070− Just Pdf -> Just ".pdf"
1071− Just Eps -> Just ".eps"
1072− Just Svg -> Just ".svg"
1073− Nothing -> Nothing
1074−
1075− let newGlobalId = case M.lookup fp globalIds of
1076− Just ident -> ident
1077− Nothing -> maxGlobalId + 1
1078−
1079− let newGlobalIds = M.insert fp newGlobalId globalIds
1080−
1081− let mediaInfo = MediaInfo { mInfoFilePath = fp
1082− , mInfoLocalId = maxLocalId + 1
1083− , mInfoGlobalId = newGlobalId
1084− , mInfoMimeType = mbMt
1085− , mInfoExt = imgExt
1086− , mInfoCaption = (not . null) caption
1087− }
1088−
1089− let slideMediaInfos = case M.lookup curSlideId mediaReg of
1090− Just minfos -> mediaInfo : minfos
1091− Nothing -> [mediaInfo]
1092−
1093−
1094− modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg
1095− , stMediaGlobalIds = newGlobalIds
1096− }
1097− return mediaInfo
1098−
1099−makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry
1100−makeMediaEntry mInfo = do
1101− epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
1102− (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
1103− let ext = case mInfoExt mInfo of
1104− Just e -> e
1105− Nothing -> ""
1106− let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext
1107− return $ toEntry fp epochtime $ BL.fromStrict imgBytes
1108−
1109−makeMediaEntries :: PandocMonad m => P m [Entry]
1110−makeMediaEntries = do
1111− mediaInfos <- gets stMediaIds
1112− let allInfos = mconcat $ M.elems mediaInfos
1113− mapM makeMediaEntry allInfos
1114−
1115−-- -- | Scales the image to fit the page
1116−-- -- sizes are passed in emu
1117−-- fitToPage' :: (Double, Double) -- image size in emu
1118−-- -> Integer -- pageWidth
1119−-- -> Integer -- pageHeight
1120−-- -> (Integer, Integer) -- imagesize
1121−-- fitToPage' (x, y) pageWidth pageHeight
1122−-- -- Fixes width to the page width and scales the height
1123−-- | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight =
1124−-- (floor x, floor y)
1125−-- | x / fromIntegral pageWidth > y / fromIntegral pageWidth =
1126−-- (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y)
1127−-- | otherwise =
1128−-- (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight)
1129−
1130−-- positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer)
1131−-- positionImage (x, y) pageWidth pageHeight =
1132−-- let (x', y') = fitToPage' (x, y) pageWidth pageHeight
1133−-- in
1134−-- ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2)
1135−
1136−getMaster :: PandocMonad m => P m Element
1137−getMaster = do
1138− refArchive <- asks envRefArchive
1139− distArchive <- asks envDistArchive
1140− parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml"
1141−
1142−-- We want to get the header dimensions, so we can make sure that the
1143−-- image goes underneath it. We only use this in a content slide if it
1144−-- has a header.
1145−
1146−-- getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer))
1147−-- getHeaderSize = do
1148−-- master <- getMaster
1149−-- let ns = elemToNameSpaces master
1150−-- sps = [master] >>=
1151−-- findChildren (elemName ns "p" "cSld") >>=
1152−-- findChildren (elemName ns "p" "spTree") >>=
1153−-- findChildren (elemName ns "p" "sp")
1154−-- mbXfrm =
1155−-- listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>=
1156−-- findChild (elemName ns "p" "spPr") >>=
1157−-- findChild (elemName ns "a" "xfrm")
1158−-- xoff = mbXfrm >>=
1159−-- findChild (elemName ns "a" "off") >>=
1160−-- findAttr (QName "x" Nothing Nothing) >>=
1161−-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))
1162−-- yoff = mbXfrm >>=
1163−-- findChild (elemName ns "a" "off") >>=
1164−-- findAttr (QName "y" Nothing Nothing) >>=
1165−-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))
1166−-- xext = mbXfrm >>=
1167−-- findChild (elemName ns "a" "ext") >>=
1168−-- findAttr (QName "cx" Nothing Nothing) >>=
1169−-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))
1170−-- yext = mbXfrm >>=
1171−-- findChild (elemName ns "a" "ext") >>=
1172−-- findAttr (QName "cy" Nothing Nothing) >>=
1173−-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))
1174−-- off = case xoff of
1175−-- Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff')
1176−-- _ -> (1043490, 1027664)
1177−-- ext = case xext of
1178−-- Just (xext', _) | Just (yext',_) <- yext -> (xext', yext')
1179−-- _ -> (7024744, 1143000)
1180−-- return $ (off, ext)
1181−
1182−-- Hard-coded for now
1183−-- captionPosition :: ((Integer, Integer), (Integer, Integer))
1184−-- captionPosition = ((457200, 6061972), (8229600, 527087))
1185−
1186−captionHeight :: Integer
1187−captionHeight = 40
1188−
1189−createCaption :: PandocMonad m
1190− => ((Integer, Integer), (Integer, Integer))
1191− -> [ParaElem]
1192− -> P m Element
1193−createCaption contentShapeDimensions paraElements = do
1194− let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements
1195− elements <- mapM paragraphToElement [para]
1196− let ((x, y), (cx, cy)) = contentShapeDimensions
1197− let txBody = mknode "p:txBody" [] $
1198− [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
1199− return $
1200− mknode "p:sp" [] [ mknode "p:nvSpPr" []
1201− [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()
1202− , mknode "p:cNvSpPr" [("txBox", "1")] ()
1203− , mknode "p:nvPr" [] ()
1204− ]
1205− , mknode "p:spPr" []
1206− [ mknode "a:xfrm" []
1207− [ mknode "a:off" [("x", show $ 12700 * x),
1208− ("y", show $ 12700 * (y + cy - captionHeight))] ()
1209− , mknode "a:ext" [("cx", show $ 12700 * cx),
1210− ("cy", show $ 12700 * captionHeight)] ()
1211− ]
1212− , mknode "a:prstGeom" [("prst", "rect")]
1213− [ mknode "a:avLst" [] ()
1214− ]
1215− , mknode "a:noFill" [] ()
1216− ]
1217− , txBody
1218− ]
1219−
1220−makePicElements :: PandocMonad m
1221− => Element
1222− -> PicProps
1223− -> MediaInfo
1224− -> Text.Pandoc.Definition.Attr
1225− -> [ParaElem]
1226− -> P m [Element]
1227−makePicElements layout picProps mInfo _ alt = do
1228− opts <- asks envOpts
1229− (pageWidth, pageHeight) <- asks envPresentationSize
1230− -- hasHeader <- asks envSlideHasHeader
1231− let hasCaption = mInfoCaption mInfo
1232− (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)
1233− let (pxX, pxY) = case imageSize opts imgBytes of
1234− Right sz -> sizeInPixels $ sz
1235− Left _ -> sizeInPixels $ def
1236− master <- getMaster
1237− let ns = elemToNameSpaces layout
1238− ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master
1239− `catchError`
1240− (\_ -> return ((0, 0), (pageWidth, pageHeight)))
1241−
1242− let cy = if hasCaption then cytmp - captionHeight else cytmp
1243−
1244− let imgRatio = fromIntegral pxX / fromIntegral pxY :: Double
1245− boxRatio = fromIntegral cx / fromIntegral cy :: Double
1246− (dimX, dimY) = if imgRatio > boxRatio
1247− then (fromIntegral cx, fromIntegral cx / imgRatio)
1248− else (fromIntegral cy * imgRatio, fromIntegral cy)
1249−
1250− (dimX', dimY') = (round dimX * 12700, round dimY * 12700) :: (Integer, Integer)
1251− (xoff, yoff) = (fromIntegral x + (fromIntegral cx - dimX) / 2,
1252− fromIntegral y + (fromIntegral cy - dimY) / 2)
1253− (xoff', yoff') = (round xoff * 12700, round yoff * 12700) :: (Integer, Integer)
1254−
1255− let cNvPicPr = mknode "p:cNvPicPr" [] $
1256− mknode "a:picLocks" [("noGrp","1")
1257− ,("noChangeAspect","1")] ()
1258− -- cNvPr will contain the link information so we do that separately,
1259− -- and register the link if necessary.
1260− let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")]
1261− cNvPr <- case picPropLink picProps of
1262− Just link -> do idNum <- registerLink link
1263− return $ mknode "p:cNvPr" cNvPrAttr $
1264− mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] ()
1265− Nothing -> return $ mknode "p:cNvPr" cNvPrAttr ()
1266− let nvPicPr = mknode "p:nvPicPr" []
1267− [ cNvPr
1268− , cNvPicPr
1269− , mknode "p:nvPr" [] ()]
1270− let blipFill = mknode "p:blipFill" []
1271− [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] ()
1272− , mknode "a:stretch" [] $
1273− mknode "a:fillRect" [] () ]
1274− let xfrm = mknode "a:xfrm" []
1275− [ mknode "a:off" [("x",show xoff'), ("y",show yoff')] ()
1276− , mknode "a:ext" [("cx",show dimX')
1277− ,("cy",show dimY')] () ]
1278− let prstGeom = mknode "a:prstGeom" [("prst","rect")] $
1279− mknode "a:avLst" [] ()
1280− let ln = mknode "a:ln" [("w","9525")]
1281− [ mknode "a:noFill" [] ()
1282− , mknode "a:headEnd" [] ()
1283− , mknode "a:tailEnd" [] () ]
1284− let spPr = mknode "p:spPr" [("bwMode","auto")]
1285− [xfrm, prstGeom, mknode "a:noFill" [] (), ln]
1286−
1287− let picShape = mknode "p:pic" []
1288− [ nvPicPr
1289− , blipFill
1290− , spPr ]
1291−
1292− -- And now, maybe create the caption:
1293− if hasCaption
1294− then do cap <- createCaption ((x, y), (cx, cytmp)) alt
1295− return [picShape, cap]
1296− else return [picShape]
1297−
1298−-- Currently hardcoded, until I figure out how to make it dynamic.
1299−blockQuoteSize :: Pixels
1300−blockQuoteSize = 20
1301−
1302−noteSize :: Pixels
1303−noteSize = 18
1304−
1305−paraElemToElement :: PandocMonad m => ParaElem -> P m Element
1306−paraElemToElement Break = return $ mknode "a:br" [] ()
1307−paraElemToElement (Run rpr s) = do
1308− let sizeAttrs = case rPropForceSize rpr of
1309− Just n -> [("sz", (show $ n * 100))]
1310− Nothing -> []
1311− attrs = sizeAttrs ++
1312− if rPropCode rpr
1313− then []
1314− else (if rPropBold rpr then [("b", "1")] else []) ++
1315− (if rPropItalics rpr then [("i", "1")] else []) ++
1316− (case rStrikethrough rpr of
1317− Just NoStrike -> [("strike", "noStrike")]
1318− Just SingleStrike -> [("strike", "sngStrike")]
1319− Just DoubleStrike -> [("strike", "dblStrike")]
1320− Nothing -> []) ++
1321− (case rBaseline rpr of
1322− Just n -> [("baseline", show n)]
1323− Nothing -> []) ++
1324− (case rCap rpr of
1325− Just NoCapitals -> [("cap", "none")]
1326− Just SmallCapitals -> [("cap", "small")]
1327− Just AllCapitals -> [("cap", "all")]
1328− Nothing -> []) ++
1329− []
1330− linkProps <- case rLink rpr of
1331− Just link -> do
1332− idNum <- registerLink link
1333− -- first we have to make sure that if it's an
1334− -- anchor, it's in the anchor map. If not, there's
1335− -- no link.
1336− anchorMap <- gets stAnchorMap
1337− return $ case link of
1338− -- anchor with nothing in the map
1339− ('#':target, _) | Nothing <- M.lookup target anchorMap ->
1340− []
1341− -- anchor that is in the map
1342− ('#':_, _) ->
1343− let linkAttrs =
1344− [ ("r:id", "rId" ++ show idNum)
1345− , ("action", "ppaction://hlinksldjump")
1346− ]
1347− in [mknode "a:hlinkClick" linkAttrs ()]
1348− -- external
1349− _ ->
1350− let linkAttrs =
1351− [ ("r:id", "rId" ++ show idNum)
1352− ]
1353− in [mknode "a:hlinkClick" linkAttrs ()]
1354− Nothing -> return []
1355− let propContents = if rPropCode rpr
1356− then [mknode "a:latin" [("typeface", "Courier")] ()]
1357− else linkProps
1358− return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents
1359− , mknode "a:t" [] s
1360− ]
1361−paraElemToElement (MathElem mathType texStr) = do
1362− res <- convertMath writeOMML mathType (unTeXString texStr)
1363− case res of
1364− Right r -> return $ mknode "a14:m" [] $ addMathInfo r
1365− Left (Str s) -> paraElemToElement (Run def s)
1366− Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback"
1367−
1368−-- This is a bit of a kludge -- really requires adding an option to
1369−-- TeXMath, but since that's a different package, we'll do this one
1370−-- step at a time.
1371−addMathInfo :: Element -> Element
1372−addMathInfo element =
1373− let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns"))
1374− , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"
1375− }
1376− in add_attr mathspace element
1377−
1378−-- We look through the element to see if it contains an a14:m
1379−-- element. If so, we surround it. This is a bit ugly, but it seems
1380−-- more dependable than looking through shapes for math. Plus this is
1381−-- an xml implementation detail, so it seems to make sense to do it at
1382−-- the xml level.
1383−surroundWithMathAlternate :: Element -> Element
1384−surroundWithMathAlternate element =
1385− case findElement (QName "m" Nothing (Just "a14")) element of
1386− Just _ ->
1387− mknode "mc:AlternateContent"
1388− [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")
1389− ] [ mknode "mc:Choice"
1390− [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")
1391− , ("Requires", "a14")] [ element ]
1392− ]
1393− Nothing -> element
1394−
1395−paragraphToElement :: PandocMonad m => Paragraph -> P m Element
1396−paragraphToElement par = do
1397− let
1398− attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++
1399− (case pPropMarginLeft (paraProps par) of
1400− Just px -> [("marL", show $ 12700 * px), ("indent", "0")]
1401− Nothing -> []
1402− ) ++
1403− (case pPropAlign (paraProps par) of
1404− Just AlgnLeft -> [("algn", "l")]
1405− Just AlgnRight -> [("algn", "r")]
1406− Just AlgnCenter -> [("algn", "ctr")]
1407− Nothing -> []
1408− )
1409− props = [] ++
1410− (case pPropSpaceBefore $ paraProps par of
1411− Just px -> [mknode "a:spcBef" [] [
1412− mknode "a:spcPts" [("val", show $ 100 * px)] ()
1413− ]
1414− ]
1415− Nothing -> []
1416− ) ++
1417− (case pPropBullet $ paraProps par of
1418− Just Bullet -> []
1419− Just (AutoNumbering attrs') ->
1420− [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()]
1421− Nothing -> [mknode "a:buNone" [] ()]
1422− )
1423− paras <- mapM paraElemToElement (combineParaElems $ paraElems par)
1424− return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras
1425−
1426−shapeToElement :: PandocMonad m => Element -> Shape -> P m Element
1427−shapeToElement layout (TextBox paras)
1428− | ns <- elemToNameSpaces layout
1429− , Just cSld <- findChild (elemName ns "p" "cSld") layout
1430− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
1431− sp <- getContentShape ns spTree
1432− elements <- mapM paragraphToElement paras
1433− let txBody = mknode "p:txBody" [] $
1434− [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements
1435− emptySpPr = mknode "p:spPr" [] ()
1436− return $
1437− surroundWithMathAlternate $
1438− replaceNamedChildren ns "p" "txBody" [txBody] $
1439− replaceNamedChildren ns "p" "spPr" [emptySpPr] $
1440− sp
1441−-- GraphicFrame and Pic should never reach this.
1442−shapeToElement _ _ = return $ mknode "p:sp" [] ()
1443−
1444−shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]
1445−shapeToElements layout (Pic picProps fp attr alt) = do
1446− mInfo <- registerMedia fp alt
1447− case mInfoExt mInfo of
1448− Just _ -> do
1449− makePicElements layout picProps mInfo attr alt
1450− Nothing -> shapeToElements layout $ TextBox [Paragraph def alt]
1451−shapeToElements layout (GraphicFrame tbls cptn) =
1452− graphicFrameToElements layout tbls cptn
1453−shapeToElements layout shp = do
1454− element <- shapeToElement layout shp
1455− return [element]
1456−
1457−shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element]
1458−shapesToElements layout shps = do
1459− concat <$> mapM (shapeToElements layout) shps
1460−
1461−hardcodedTableMargin :: Integer
1462−hardcodedTableMargin = 36
1463−
1464−graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element]
1465−graphicFrameToElements layout tbls caption = do
1466− -- get the sizing
1467− master <- getMaster
1468− (pageWidth, pageHeight) <- asks envPresentationSize
1469− let ns = elemToNameSpaces layout
1470− ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master
1471− `catchError`
1472− (\_ -> return ((0, 0), (pageWidth, pageHeight)))
1473−
1474− let cy = if (not $ null caption) then cytmp - captionHeight else cytmp
1475−
1476− elements <- mapM graphicToElement tbls
1477− let graphicFrameElts =
1478− mknode "p:graphicFrame" [] $
1479− [ mknode "p:nvGraphicFramePr" [] $
1480− [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()
1481− , mknode "p:cNvGraphicFramePr" [] $
1482− [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]
1483− , mknode "p:nvPr" [] $
1484− [mknode "p:ph" [("idx", "1")] ()]
1485− ]
1486− , mknode "p:xfrm" [] $
1487− [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] ()
1488− , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] ()
1489− ]
1490− ] ++ elements
1491−
1492− if (not $ null caption)
1493− then do capElt <- createCaption ((x, y), (cx, cytmp)) caption
1494− return [graphicFrameElts, capElt]
1495− else return [graphicFrameElts]
1496−
1497−graphicToElement :: PandocMonad m => Graphic -> P m Element
1498−graphicToElement (Tbl tblPr colWidths hdrCells rows) = do
1499− let cellToOpenXML paras =
1500− do elements <- mapM paragraphToElement paras
1501− let elements' = if null elements
1502− then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]]
1503− else elements
1504− return $
1505− [mknode "a:txBody" [] $
1506− ([ mknode "a:bodyPr" [] ()
1507− , mknode "a:lstStyle" [] ()]
1508− ++ elements')]
1509− headers' <- mapM cellToOpenXML hdrCells
1510− rows' <- mapM (mapM cellToOpenXML) rows
1511− let borderProps = mknode "a:tcPr" [] ()
1512− let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]]
1513− let mkcell border contents = mknode "a:tc" []
1514− $ (if null contents
1515− then emptyCell
1516− else contents) ++ [ borderProps | border ]
1517− let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells
1518−
1519− let mkgridcol w = mknode "a:gridCol"
1520− [("w", show ((12700 * w) :: Integer))] ()
1521− let hasHeader = not (all null hdrCells)
1522− return $ mknode "a:graphic" [] $
1523− [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $
1524− [mknode "a:tbl" [] $
1525− [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0")
1526− , ("bandRow", if tblPrBandRow tblPr then "1" else "0")
1527− ] ()
1528− , mknode "a:tblGrid" [] (if all (==0) colWidths
1529− then []
1530− else map mkgridcol colWidths)
1531− ]
1532− ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows'
1533− ]
1534− ]
1535−
1536−getShapeByName :: NameSpaces -> Element -> String -> Maybe Element
1537−getShapeByName ns spTreeElem name
1538− | isElem ns "p" "spTree" spTreeElem =
1539− filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem
1540− | otherwise = Nothing
1541−
1542−-- getShapeById :: NameSpaces -> Element -> String -> Maybe Element
1543−-- getShapeById ns spTreeElem ident
1544−-- | isElem ns "p" "spTree" spTreeElem =
1545−-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTreeElem
1546−-- | otherwise = Nothing
1547−
1548−nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element
1549−nonBodyTextToElement layout shapeName paraElements
1550− | ns <- elemToNameSpaces layout
1551− , Just cSld <- findChild (elemName ns "p" "cSld") layout
1552− , Just spTree <- findChild (elemName ns "p" "spTree") cSld
1553− , Just sp <- getShapeByName ns spTree shapeName = do
1554− let hdrPara = Paragraph def paraElements
1555− element <- paragraphToElement hdrPara
1556− let txBody = mknode "p:txBody" [] $
1557− [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++
1558− [element]
1559− return $ replaceNamedChildren ns "p" "txBody" [txBody] sp
1560− -- XXX: TODO
1561− | otherwise = return $ mknode "p:sp" [] ()
1562−
1563−contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element
1564−contentToElement layout hdrShape shapes
1565− | ns <- elemToNameSpaces layout
1566− , Just cSld <- findChild (elemName ns "p" "cSld") layout
1567− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
1568− element <- nonBodyTextToElement layout "Title 1" hdrShape
1569− let hdrShapeElements = if null hdrShape
1570− then []
1571− else [element]
1572− contentElements <- local
1573− (\env -> env {envContentType = NormalContent})
1574− (shapesToElements layout shapes)
1575− return $
1576− replaceNamedChildren ns "p" "sp"
1577− (hdrShapeElements ++ contentElements)
1578− spTree
1579−contentToElement _ _ _ = return $ mknode "p:sp" [] ()
1580−
1581−twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element
1582−twoColumnToElement layout hdrShape shapesL shapesR
1583− | ns <- elemToNameSpaces layout
1584− , Just cSld <- findChild (elemName ns "p" "cSld") layout
1585− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
1586− element <- nonBodyTextToElement layout "Title 1" hdrShape
1587− let hdrShapeElements = if null hdrShape
1588− then []
1589− else [element]
1590− contentElementsL <- local
1591− (\env -> env {envContentType =TwoColumnLeftContent})
1592− (shapesToElements layout shapesL)
1593− contentElementsR <- local
1594− (\env -> env {envContentType =TwoColumnRightContent})
1595− (shapesToElements layout shapesR)
1596− -- let contentElementsL' = map (setIdx ns "1") contentElementsL
1597− -- contentElementsR' = map (setIdx ns "2") contentElementsR
1598− return $
1599− replaceNamedChildren ns "p" "sp"
1600− (hdrShapeElements ++ contentElementsL ++ contentElementsR)
1601− spTree
1602−twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] ()
1603−
1604−
1605−titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element
1606−titleToElement layout titleElems
1607− | ns <- elemToNameSpaces layout
1608− , Just cSld <- findChild (elemName ns "p" "cSld") layout
1609− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
1610− element <- nonBodyTextToElement layout "Title 1" titleElems
1611− let titleShapeElements = if null titleElems
1612− then []
1613− else [element]
1614− return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree
1615−titleToElement _ _ = return $ mknode "p:sp" [] ()
1616−
1617−metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element
1618−metadataToElement layout titleElems subtitleElems authorsElems dateElems
1619− | ns <- elemToNameSpaces layout
1620− , Just cSld <- findChild (elemName ns "p" "cSld") layout
1621− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do
1622− titleShapeElements <- if null titleElems
1623− then return []
1624− else sequence [nonBodyTextToElement layout "Title 1" titleElems]
1625− let combinedAuthorElems = intercalate [Break] authorsElems
1626− subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems]
1627− subtitleShapeElements <- if null subtitleAndAuthorElems
1628− then return []
1629− else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems]
1630− dateShapeElements <- if null dateElems
1631− then return []
1632− else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems]
1633− return $ replaceNamedChildren ns "p" "sp"
1634− (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements)
1635− spTree
1636−metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] ()
1637−
1638−slideToElement :: PandocMonad m => Slide -> P m Element
1639−slideToElement s@(ContentSlide hdrElems shapes) = do
1640− layout <- getLayout s
1641− spTree <- local (\env -> if null hdrElems
1642− then env
1643− else env{envSlideHasHeader=True}) $
1644− contentToElement layout hdrElems shapes
1645− return $ mknode "p:sld"
1646− [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
1647− ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
1648− ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
1649− ] [mknode "p:cSld" [] [spTree]]
1650−slideToElement s@(TwoColumnSlide hdrElems shapesL shapesR) = do
1651− layout <- getLayout s
1652− spTree <- local (\env -> if null hdrElems
1653− then env
1654− else env{envSlideHasHeader=True}) $
1655− twoColumnToElement layout hdrElems shapesL shapesR
1656− return $ mknode "p:sld"
1657− [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
1658− ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
1659− ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
1660− ] [mknode "p:cSld" [] [spTree]]
1661−slideToElement s@(TitleSlide hdrElems) = do
1662− layout <- getLayout s
1663− spTree <- titleToElement layout hdrElems
1664− return $ mknode "p:sld"
1665− [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
1666− ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
1667− ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
1668− ] [mknode "p:cSld" [] [spTree]]
1669−slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do
1670− layout <- getLayout s
1671− spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems
1672− return $ mknode "p:sld"
1673− [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),
1674− ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),
1675− ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")
1676− ] [mknode "p:cSld" [] [spTree]]
1677−
1678−-----------------------------------------------------------------------
1679−
1680−slideToFilePath :: Slide -> Int -> FilePath
1681−slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"
1682−
1683−slideToSlideId :: Monad m => Slide -> Int -> P m String
1684−slideToSlideId _ idNum = do
1685− n <- asks envSlideIdOffset
1686− return $ "rId" ++ (show $ idNum + n)
1687−
1688−
1689−data Relationship = Relationship { relId :: Int
1690− , relType :: MimeType
1691− , relTarget :: FilePath
1692− } deriving (Show, Eq)
1693−
1694−elementToRel :: Element -> Maybe Relationship
1695−elementToRel element
1696− | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing =
1697− do rId <- findAttr (QName "Id" Nothing Nothing) element
1698− numStr <- stripPrefix "rId" rId
1699− num <- case reads numStr :: [(Int, String)] of
1700− (n, _) : _ -> Just n
1701− [] -> Nothing
1702− type' <- findAttr (QName "Type" Nothing Nothing) element
1703− target <- findAttr (QName "Target" Nothing Nothing) element
1704− return $ Relationship num type' target
1705− | otherwise = Nothing
1706−
1707−slideToPresRel :: Monad m => Slide -> Int -> P m Relationship
1708−slideToPresRel slide idNum = do
1709− n <- asks envSlideIdOffset
1710− let rId = idNum + n
1711− fp = "slides/" ++ slideToFilePath slide idNum
1712− return $ Relationship { relId = rId
1713− , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"
1714− , relTarget = fp
1715− }
1716−
1717−getRels :: PandocMonad m => P m [Relationship]
1718−getRels = do
1719− refArchive <- asks envRefArchive
1720− distArchive <- asks envDistArchive
1721− relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels"
1722− let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"
1723− let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem
1724− return $ mapMaybe elementToRel relElems
1725−
1726−presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]
1727−presentationToRels (Presentation slides) = do
1728− mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]
1729− rels <- getRels
1730− let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels
1731− -- We want to make room for the slides in the id space. The slides
1732− -- will start at Id2 (since Id1 is for the slide master). There are
1733− -- two slides in the data file, but that might change in the future,
1734− -- so we will do this:
1735− --
1736− -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is.
1737− -- 2. We add the difference between this and the number of slides to
1738− -- all relWithoutSlide rels (unless they're 1)
1739−
1740− let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of
1741− [] -> 0 -- doesn't matter in this case, since
1742− -- there will be nothing to map the
1743− -- function over
1744− l -> minimum l
1745−
1746− modifyRelNum :: Int -> Int
1747− modifyRelNum 1 = 1
1748− modifyRelNum n = n - minRelNotOne + 2 + length slides
1749−
1750− relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides
1751−
1752− return $ mySlideRels ++ relsWithoutSlides'
1753−
1754−relToElement :: Relationship -> Element
1755−relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel))
1756− , ("Type", relType rel)
1757− , ("Target", relTarget rel) ] ()
1758−
1759−relsToElement :: [Relationship] -> Element
1760−relsToElement rels = mknode "Relationships"
1761− [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
1762− (map relToElement rels)
1763−
1764−presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry
1765−presentationToRelsEntry pres = do
1766− rels <- presentationToRels pres
1767− elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels
1768−
1769−elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry
1770−elemToEntry fp element = do
1771− epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime
1772− return $ toEntry fp epochtime $ renderXml element
1773−
1774−slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry
1775−slideToEntry slide idNum = do
1776− local (\env -> env{envCurSlideId = idNum}) $ do
1777− element <- slideToElement slide
1778− elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element
1779−
1780−slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry
1781−slideToSlideRelEntry slide idNum = do
1782− element <- slideToSlideRelElement slide idNum
1783− elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element
1784−
1785−linkRelElement :: PandocMonad m => Int -> (URL, String) -> P m (Maybe Element)
1786−linkRelElement idNum (url, _) = do
1787− anchorMap <- gets stAnchorMap
1788− case url of
1789− -- if it's an anchor in the map, we use the slide number for an
1790− -- internal link.
1791− '#' : anchor | Just num <- M.lookup anchor anchorMap ->
1792− return $ Just $
1793− mknode "Relationship" [ ("Id", "rId" ++ show idNum)
1794− , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")
1795− , ("Target", "slide" ++ show num ++ ".xml")
1796− ] ()
1797− -- if it's an anchor not in the map, we return nothing.
1798− '#' : _ -> return Nothing
1799− -- Anything else we treat as an external link
1800− _ ->
1801− return $ Just $
1802− mknode "Relationship" [ ("Id", "rId" ++ show idNum)
1803− , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")
1804− , ("Target", url)
1805− , ("TargetMode", "External")
1806− ] ()
1807−
1808−linkRelElements :: PandocMonad m => M.Map Int (URL, String) -> P m [Element]
1809−linkRelElements mp = catMaybes <$> mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)
1810−
1811−mediaRelElement :: MediaInfo -> Element
1812−mediaRelElement mInfo =
1813− let ext = case mInfoExt mInfo of
1814− Just e -> e
1815− Nothing -> ""
1816− in
1817− mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo))
1818− , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")
1819− , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)
1820− ] ()
1821−
1822−slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element
1823−slideToSlideRelElement slide idNum = do
1824− let target = case slide of
1825− (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml"
1826− (TitleSlide _) -> "../slideLayouts/slideLayout3.xml"
1827− (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml"
1828− (TwoColumnSlide _ _ _) -> "../slideLayouts/slideLayout4.xml"
1829−
1830− linkIds <- gets stLinkIds
1831− mediaIds <- gets stMediaIds
1832−
1833− linkRels <- case M.lookup idNum linkIds of
1834− Just mp -> linkRelElements mp
1835− Nothing -> return []
1836− let mediaRels = case M.lookup idNum mediaIds of
1837− Just mInfos -> map mediaRelElement mInfos
1838− Nothing -> []
1839−
1840− return $
1841− mknode "Relationships"
1842− [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]
1843− ([mknode "Relationship" [ ("Id", "rId1")
1844− , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")
1845− , ("Target", target)] ()
1846− ] ++ linkRels ++ mediaRels)
1847−
1848−slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element
1849−slideToSldIdElement slide idNum = do
1850− let id' = show $ idNum + 255
1851− rId <- slideToSlideId slide idNum
1852− return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()
1853−
1854−presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element
1855−presentationToSldIdLst (Presentation slides) = do
1856− ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])
1857− return $ mknode "p:sldIdLst" [] ids
1858−
1859−presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element
1860−presentationToPresentationElement pres = do
1861− refArchive <- asks envRefArchive
1862− distArchive <- asks envDistArchive
1863− element <- parseXml refArchive distArchive "ppt/presentation.xml"
1864− sldIdLst <- presentationToSldIdLst pres
1865−
1866− let modifySldIdLst :: Content -> Content
1867− modifySldIdLst (Elem e) = case elName e of
1868− (QName "sldIdLst" _ _) -> Elem sldIdLst
1869− _ -> Elem e
1870− modifySldIdLst ct = ct
1871−
1872− newContent = map modifySldIdLst $ elContent element
1873−
1874− return $ element{elContent = newContent}
1875−
1876−presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry
1877−presentationToPresEntry pres = presentationToPresentationElement pres >>=
1878− elemToEntry "ppt/presentation.xml"
1879−
1880−
1881−
1882−
1883−defaultContentTypeToElem :: DefaultContentType -> Element
1884−defaultContentTypeToElem dct =
1885− mknode "Default"
1886− [("Extension", defContentTypesExt dct),
1887− ("ContentType", defContentTypesType dct)]
1888− ()
1889−
1890−overrideContentTypeToElem :: OverrideContentType -> Element
1891−overrideContentTypeToElem oct =
1892− mknode "Override"
1893− [("PartName", overrideContentTypesPart oct),
1894− ("ContentType", overrideContentTypesType oct)]
1895− ()
1896−
1897−contentTypesToElement :: ContentTypes -> Element
1898−contentTypesToElement ct =
1899− let ns = "http://schemas.openxmlformats.org/package/2006/content-types"
1900− in
1901− mknode "Types" [("xmlns", ns)] $
1902− (map defaultContentTypeToElem $ contentTypesDefaults ct) ++
1903− (map overrideContentTypeToElem $ contentTypesOverrides ct)
1904−
1905−data DefaultContentType = DefaultContentType
1906− { defContentTypesExt :: String
1907− , defContentTypesType:: MimeType
1908− }
1909− deriving (Show, Eq)
1910−
1911−data OverrideContentType = OverrideContentType
1912− { overrideContentTypesPart :: FilePath
1913− , overrideContentTypesType :: MimeType
1914− }
1915− deriving (Show, Eq)
1916−
1917−data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType]
1918− , contentTypesOverrides :: [OverrideContentType]
1919− }
1920− deriving (Show, Eq)
1921−
1922−contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry
1923−contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct
1924−
1925−pathToOverride :: FilePath -> Maybe OverrideContentType
1926−pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)
1927−
1928−mediaFileContentType :: FilePath -> Maybe DefaultContentType
1929−mediaFileContentType fp = case takeExtension fp of
1930− '.' : ext -> Just $
1931− DefaultContentType { defContentTypesExt = ext
1932− , defContentTypesType =
1933− case getMimeType fp of
1934− Just mt -> mt
1935− Nothing -> "application/octet-stream"
1936− }
1937− _ -> Nothing
1938−
1939−mediaContentType :: MediaInfo -> Maybe DefaultContentType
1940−mediaContentType mInfo
1941− | Just ('.' : ext) <- mInfoExt mInfo =
1942− Just $ DefaultContentType { defContentTypesExt = ext
1943− , defContentTypesType =
1944− case mInfoMimeType mInfo of
1945− Just mt -> mt
1946− Nothing -> "application/octet-stream"
1947− }
1948− | otherwise = Nothing
1949−
1950−presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
1951−presentationToContentTypes (Presentation slides) = do
1952− mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
1953− filePaths <- patternsToFilePaths inheritedPatterns
1954− let mediaFps = filter (match (compile "ppt/media/image*")) filePaths
1955− let defaults = [ DefaultContentType "xml" "application/xml"
1956− , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
1957− ]
1958− mediaDefaults = nub $
1959− (mapMaybe mediaContentType $ mediaInfos) ++
1960− (mapMaybe mediaFileContentType $ mediaFps)
1961−
1962− inheritedOverrides = mapMaybe pathToOverride filePaths
1963− presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
1964− slideOverrides =
1965− mapMaybe
1966− (\(s, n) ->
1967− pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)
1968− (zip slides [1..])
1969− -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]
1970− return $ ContentTypes
1971− (defaults ++ mediaDefaults)
1972− (inheritedOverrides ++ presOverride ++ slideOverrides)
1973−
1974−presML :: String
1975−presML = "application/vnd.openxmlformats-officedocument.presentationml"
1976−
1977−noPresML :: String
1978−noPresML = "application/vnd.openxmlformats-officedocument"
1979−
1980−getContentType :: FilePath -> Maybe MimeType
1981−getContentType fp
1982− | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml"
1983− | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml"
1984− | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml"
1985− | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml"
1986− | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml"
1987− | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml"
1988− | "ppt" : "slideMasters" : f : [] <- splitDirectories fp
1989− , (_, ".xml") <- splitExtension f =
1990− Just $ presML ++ ".slideMaster+xml"
1991− | "ppt" : "slides" : f : [] <- splitDirectories fp
1992− , (_, ".xml") <- splitExtension f =
1993− Just $ presML ++ ".slide+xml"
1994− | "ppt" : "notesMasters" : f : [] <- splitDirectories fp
1995− , (_, ".xml") <- splitExtension f =
1996− Just $ presML ++ ".notesMaster+xml"
1997− | "ppt" : "notesSlides" : f : [] <- splitDirectories fp
1998− , (_, ".xml") <- splitExtension f =
1999− Just $ presML ++ ".notesSlide+xml"
2000− | "ppt" : "theme" : f : [] <- splitDirectories fp
2001− , (_, ".xml") <- splitExtension f =
2002− Just $ noPresML ++ ".theme+xml"
2003− | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp=
2004− Just $ presML ++ ".slideLayout+xml"
2005− | otherwise = Nothing
2006−
2007−-------------------------------------------------------
2008−
2009−combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem]
2010−combineParaElems' mbPElem [] = maybeToList mbPElem
2011−combineParaElems' Nothing (pElem : pElems) =
2012− combineParaElems' (Just pElem) pElems
2013−combineParaElems' (Just pElem') (pElem : pElems)
2014− | Run rPr' s' <- pElem'
2015− , Run rPr s <- pElem
2016− , rPr == rPr' =
2017− combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems
2018− | otherwise =
2019− pElem' : combineParaElems' (Just pElem) pElems
2020−
2021−combineParaElems :: [ParaElem] -> [ParaElem]
2022−combineParaElems = combineParaElems' Nothing
60+ pres <- documentToPresentation opts (Pandoc meta blks')
61+ archv <- presentationToArchive opts pres
62+ return $ fromArchive archv