1{-# LANGUAGE DeriveTraversable #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE PatternGuards #-} 4{- | 5 Module : Text.Pandoc.Writers.Powerpoint.Output 6 Copyright : Copyright (C) 2017-2020 Jesse Rosenthal 7 License : GNU GPL, version 2 or above 8 9 Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> 10 Stability : alpha 11 Portability : portable 12 13Conversion of Presentation datatype (defined in 14Text.Pandoc.Writers.Powerpoint.Presentation) to a zip archive. 15-} 16 17module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive 18 ) where 19 20import Control.Monad.Except (throwError, catchError) 21import Control.Monad.Reader 22import Control.Monad.State 23import Codec.Archive.Zip 24import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf, intersperse) 25import Data.CaseInsensitive (CI) 26import qualified Data.CaseInsensitive as CI 27import Data.Default 28import Data.Foldable (toList) 29import Data.List.NonEmpty (nonEmpty, NonEmpty ((:|))) 30import Data.Text (Text) 31import qualified Data.Text as T 32import Data.Text.Read (decimal) 33import Data.Time (formatTime, defaultTimeLocale) 34import Data.Time.Clock (UTCTime) 35import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) 36import Data.Traversable (for) 37import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension, takeFileName) 38import Text.Pandoc.XML.Light as XML 39import Text.Pandoc.Definition 40import qualified Text.Pandoc.UTF8 as UTF8 41import Text.Pandoc.Class.PandocMonad (PandocMonad) 42import Text.Pandoc.Error (PandocError(..)) 43import qualified Text.Pandoc.Class.PandocMonad as P 44import Text.Pandoc.Options 45import Text.Pandoc.MIME 46import qualified Data.ByteString.Lazy as BL 47import Text.Pandoc.Writers.Shared (metaToContext) 48import Text.Pandoc.Writers.OOXML 49import qualified Data.Map as M 50import Data.Maybe (mapMaybe, listToMaybe, fromMaybe, maybeToList, catMaybes, isJust) 51import Text.Pandoc.ImageSize 52import Control.Applicative ((<|>)) 53import System.FilePath.Glob 54import Text.DocTemplates (FromContext(lookupContext), Context) 55import Text.DocLayout (literal) 56import Text.TeXMath 57import Text.Pandoc.Logging (LogMessage(PowerpointTemplateWarning)) 58import Text.Pandoc.Writers.Math (convertMath) 59import Text.Pandoc.Writers.Powerpoint.Presentation 60import Text.Pandoc.Shared (tshow, stringify) 61import Skylighting (fromColor) 62 63-- |The 'EMU' type is used to specify sizes in English Metric Units. 64type EMU = Integer 65 66-- |The 'pixelsToEmu' function converts a size in pixels to one 67-- in English Metric Units. It assumes a DPI of 72. 68pixelsToEmu :: Pixels -> EMU 69pixelsToEmu = (12700 *) 70 71-- This populates the global ids map with images already in the 72-- template, so the ids won't be used by images introduced by the 73-- user. 74initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int 75initialGlobalIds refArchive distArchive = 76 let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive 77 mediaPaths = filter (isPrefixOf "ppt/media/image") archiveFiles 78 79 go :: FilePath -> Maybe (FilePath, Int) 80 go fp = do 81 s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp 82 (n, _) <- listToMaybe $ reads s 83 return (fp, n) 84 in 85 M.fromList $ mapMaybe go mediaPaths 86 87getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer) 88getPresentationSize refArchive distArchive = do 89 entry <- findEntryByPath "ppt/presentation.xml" refArchive `mplus` 90 findEntryByPath "ppt/presentation.xml" distArchive 91 presElement <- either (const Nothing) return $ 92 parseXMLElement $ UTF8.toTextLazy $ fromEntry entry 93 let ns = elemToNameSpaces presElement 94 sldSize <- findChild (elemName ns "p" "sldSz") presElement 95 cxS <- findAttr (QName "cx" Nothing Nothing) sldSize 96 cyS <- findAttr (QName "cy" Nothing Nothing) sldSize 97 cx <- readTextAsInteger cxS 98 cy <- readTextAsInteger cyS 99 return (cx `div` 12700, cy `div` 12700) 100 101readTextAsInteger :: Text -> Maybe Integer 102readTextAsInteger = either (const Nothing) (Just . fst) . Data.Text.Read.decimal 103 104data WriterEnv = WriterEnv { envRefArchive :: Archive 105 , envDistArchive :: Archive 106 , envUTCTime :: UTCTime 107 , envOpts :: WriterOptions 108 , envContext :: Context Text 109 , envPresentationSize :: (Integer, Integer) 110 , envSlideHasHeader :: Bool 111 , envInList :: Bool 112 , envInNoteSlide :: Bool 113 , envCurSlideId :: Int 114 -- the difference between the number at 115 -- the end of the slide file name and 116 -- the rId number 117 , envSlideIdOffset :: Int 118 , envContentType :: ContentType 119 , envSlideIdMap :: M.Map SlideId Int 120 -- maps the slide number to the 121 -- corresponding notes id number. If there 122 -- are no notes for a slide, there will be 123 -- no entry in the map for it. 124 , envSpeakerNotesIdMap :: M.Map Int Int 125 , envInSpeakerNotes :: Bool 126 , envSlideLayouts :: Maybe SlideLayouts 127 } 128 deriving (Show) 129 130instance Default WriterEnv where 131 def = WriterEnv { envRefArchive = emptyArchive 132 , envDistArchive = emptyArchive 133 , envUTCTime = posixSecondsToUTCTime 0 134 , envOpts = def 135 , envContext = mempty 136 , envPresentationSize = (720, 540) 137 , envSlideHasHeader = False 138 , envInList = False 139 , envInNoteSlide = False 140 , envCurSlideId = 1 141 , envSlideIdOffset = 1 142 , envContentType = NormalContent 143 , envSlideIdMap = mempty 144 , envSpeakerNotesIdMap = mempty 145 , envInSpeakerNotes = False 146 , envSlideLayouts = Nothing 147 } 148 149type SlideLayouts = SlideLayoutsOf SlideLayout 150 151data SlideLayoutsOf a = SlideLayouts 152 { metadata :: a 153 , title :: a 154 , content :: a 155 , twoColumn :: a 156 } deriving (Show, Functor, Foldable, Traversable) 157 158data SlideLayout = SlideLayout 159 { slElement :: Element 160 , slInReferenceDoc :: Bool 161 -- ^ True if the layout is in the provided reference doc, False if it's in 162 -- the default reference doc. 163 , slPath :: FilePath 164 , slEntry :: Entry 165 } deriving (Show) 166 167getSlideLayouts :: PandocMonad m => P m SlideLayouts 168getSlideLayouts = asks envSlideLayouts >>= maybe (throwError e) pure 169 where 170 e = PandocSomeError ("Slide layouts aren't defined, even though they should " 171 <> "always be. This is a bug in pandoc.") 172 173data ContentType = NormalContent 174 | TwoColumnLeftContent 175 | TwoColumnRightContent 176 deriving (Show, Eq) 177 178data MediaInfo = MediaInfo { mInfoFilePath :: FilePath 179 , mInfoLocalId :: Int 180 , mInfoGlobalId :: Int 181 , mInfoMimeType :: Maybe MimeType 182 , mInfoExt :: Maybe T.Text 183 , mInfoCaption :: Bool 184 } deriving (Show, Eq) 185 186data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int LinkTarget) 187 -- (FP, Local ID, Global ID, Maybe Mime) 188 , stMediaIds :: M.Map Int [MediaInfo] 189 , stMediaGlobalIds :: M.Map FilePath Int 190 } deriving (Show, Eq) 191 192instance Default WriterState where 193 def = WriterState { stLinkIds = mempty 194 , stMediaIds = mempty 195 , stMediaGlobalIds = mempty 196 } 197 198type P m = ReaderT WriterEnv (StateT WriterState m) 199 200runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a 201runP env st p = evalStateT (runReaderT p env) st 202 203-------------------------------------------------------------------- 204 205monospaceFont :: Monad m => P m T.Text 206monospaceFont = do 207 vars <- asks envContext 208 case lookupContext "monofont" vars of 209 Just s -> return s 210 Nothing -> return "Courier" 211 212fontSizeAttributes :: Monad m => RunProps -> P m [(Text, Text)] 213fontSizeAttributes RunProps { rPropForceSize = Just sz } = 214 return [("sz", tshow $ sz * 100)] 215fontSizeAttributes _ = return [] 216 217copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive 218copyFileToArchive arch fp = do 219 refArchive <- asks envRefArchive 220 distArchive <- asks envDistArchive 221 case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of 222 Nothing -> throwError $ PandocSomeError 223 $ T.pack 224 $ fp <> " missing in reference file" 225 Just e -> return $ addEntryToArchive e arch 226 227alwaysInheritedPatterns :: [Pattern] 228alwaysInheritedPatterns = 229 map compile [ "docProps/app.xml" 230 , "ppt/slideLayouts/slideLayout*.xml" 231 , "ppt/slideLayouts/_rels/slideLayout*.xml.rels" 232 , "ppt/slideMasters/slideMaster1.xml" 233 , "ppt/slideMasters/_rels/slideMaster1.xml.rels" 234 , "ppt/theme/theme1.xml" 235 , "ppt/theme/_rels/theme1.xml.rels" 236 , "ppt/presProps.xml" 237 , "ppt/tableStyles.xml" 238 , "ppt/media/image*" 239 ] 240 241-- We only look for these under special conditions 242contingentInheritedPatterns :: Presentation -> [Pattern] 243contingentInheritedPatterns pres = [] <> 244 if presHasSpeakerNotes pres 245 then map compile [ "ppt/notesMasters/notesMaster*.xml" 246 , "ppt/notesMasters/_rels/notesMaster*.xml.rels" 247 , "ppt/theme/theme2.xml" 248 , "ppt/theme/_rels/theme2.xml.rels" 249 ] 250 else [] 251 252inheritedPatterns :: Presentation -> [Pattern] 253inheritedPatterns pres = 254 alwaysInheritedPatterns <> contingentInheritedPatterns pres 255 256patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath] 257patternToFilePaths pat = do 258 refArchive <- asks envRefArchive 259 distArchive <- asks envDistArchive 260 261 let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive 262 return $ filter (match pat) archiveFiles 263 264patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath] 265patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats 266 267-- Here are the files we'll require to make a Powerpoint document. If 268-- any of these are missing, we should error out of our build. 269requiredFiles :: [FilePath] 270requiredFiles = [ "docProps/app.xml" 271 , "ppt/presProps.xml" 272 , "ppt/slideLayouts/slideLayout1.xml" 273 , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" 274 , "ppt/slideLayouts/slideLayout2.xml" 275 , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" 276 , "ppt/slideLayouts/slideLayout3.xml" 277 , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" 278 , "ppt/slideLayouts/slideLayout4.xml" 279 , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" 280 , "ppt/slideMasters/slideMaster1.xml" 281 , "ppt/slideMasters/_rels/slideMaster1.xml.rels" 282 , "ppt/theme/theme1.xml" 283 , "ppt/tableStyles.xml" 284 ] 285 286presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive 287presentationToArchiveP p@(Presentation docProps slides) = do 288 filePaths <- patternsToFilePaths $ inheritedPatterns p 289 290 -- make sure all required files are available: 291 let missingFiles = filter (`notElem` filePaths) requiredFiles 292 unless (null missingFiles) 293 (throwError $ 294 PandocSomeError $ 295 "The following required files are missing:\n" <> 296 T.unlines (map (T.pack . (" " <>)) missingFiles) 297 ) 298 299 newArch <- foldM copyFileToArchive emptyArchive filePaths 300 301 -- Add any layouts taken from the default archive, 302 -- overwriting any already added. 303 slideLayouts <- getSlideLayouts 304 let f layout = 305 if not (slInReferenceDoc layout) 306 then addEntryToArchive (slEntry layout) 307 else id 308 let newArch' = foldr f newArch slideLayouts 309 310 -- Update the master to make sure it includes any layouts we've just added 311 master <- getMaster 312 masterRels <- getMasterRels 313 let (updatedMasterElem, updatedMasterRelElem) = updateMasterElems slideLayouts master masterRels 314 updatedMasterEntry <- elemToEntry "ppt/slideMasters/slideMaster1.xml" updatedMasterElem 315 updatedMasterRelEntry <- elemToEntry "ppt/slideMasters/_rels/slideMaster1.xml.rels" updatedMasterRelElem 316 317 -- we make a modified ppt/viewProps.xml out of the presentation viewProps 318 viewPropsEntry <- makeViewPropsEntry 319 -- we make a docProps/core.xml entry out of the presentation docprops 320 docPropsEntry <- docPropsToEntry docProps 321 -- we make a docProps/custom.xml entry out of the custom properties 322 docCustomPropsEntry <- docCustomPropsToEntry docProps 323 -- we make this ourself in case there's something unexpected in the 324 -- one in the reference doc. 325 relsEntry <- topLevelRelsEntry 326 -- presentation entry and rels. We have to do the rels first to make 327 -- sure we know the correct offset for the rIds. 328 presEntry <- presentationToPresEntry p 329 presRelsEntry <- presentationToRelsEntry p 330 slideEntries <- mapM slideToEntry slides 331 slideRelEntries <- mapM slideToSlideRelEntry slides 332 spkNotesEntries <- catMaybes <$> mapM slideToSpeakerNotesEntry slides 333 spkNotesRelEntries <- catMaybes <$> mapM slideToSpeakerNotesRelEntry slides 334 -- These have to come after everything, because they need the info 335 -- built up in the state. 336 mediaEntries <- makeMediaEntries 337 contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry 338 -- fold everything into our inherited archive and return it. 339 return $ foldr addEntryToArchive newArch' $ 340 slideEntries <> 341 slideRelEntries <> 342 spkNotesEntries <> 343 spkNotesRelEntries <> 344 mediaEntries <> 345 [updatedMasterEntry, updatedMasterRelEntry] <> 346 [contentTypesEntry, docPropsEntry, docCustomPropsEntry, relsEntry, 347 presEntry, presRelsEntry, viewPropsEntry] 348 349updateMasterElems :: SlideLayouts -> Element -> Element -> (Element, Element) 350updateMasterElems layouts master masterRels = (updatedMaster, updatedMasterRels) 351 where 352 updatedMaster = master { elContent = updateSldLayoutIdLst <$> elContent master } 353 (updatedRelationshipIds, updatedMasterRels) = addLayoutRels masterRels 354 355 updateSldLayoutIdLst :: Content -> Content 356 updateSldLayoutIdLst (Elem e) = case elName e of 357 (QName "sldLayoutIdLst" _ _) -> let 358 mkChild relationshipId (lastId, children) = let 359 thisId = lastId + 1 360 newChild = Element 361 { elName = QName "sldLayoutId" Nothing (Just "p") 362 , elAttribs = 363 [ Attr (QName "id" Nothing Nothing) (T.pack (show thisId)) 364 , Attr (QName "id" Nothing (Just "r")) relationshipId 365 ] 366 , elContent = [] 367 , elLine = Nothing 368 } 369 in (thisId, Elem newChild : children) 370 newChildren = snd (foldr mkChild (maxIdNumber' e, []) updatedRelationshipIds) 371 in Elem e { elContent = elContent e <> newChildren } 372 _ -> Elem e 373 updateSldLayoutIdLst c = c 374 375 addLayoutRels :: 376 Element -> 377 ([Text], Element) 378 addLayoutRels e = let 379 layoutsToAdd = filter (not . slInReferenceDoc) (toList layouts) 380 newRelationships = snd (foldr mkRelationship (maxIdNumber e, []) layoutsToAdd) 381 newRelationshipIds = mapMaybe getRelationshipId newRelationships 382 mkRelationship layout (lastId, relationships) = let 383 thisId = lastId + 1 384 slideLayoutPath = "../slideLayouts/" <> T.pack (takeFileName (slPath layout)) 385 newRelationship = Element 386 { elName = QName "Relationship" Nothing Nothing 387 , elAttribs = 388 [ Attr (QName "Id" Nothing Nothing) ("rId" <> T.pack (show thisId)) 389 , Attr (QName "Type" Nothing Nothing) "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout" 390 , Attr (QName "Target" Nothing Nothing) slideLayoutPath 391 ] 392 , elContent = [] 393 , elLine = Nothing 394 } 395 in (thisId, Elem newRelationship : relationships) 396 in (newRelationshipIds, e {elContent = elContent e <> newRelationships}) 397 398 getRelationshipId :: Content -> Maybe Text 399 getRelationshipId (Elem e) = findAttr (QName "Id" Nothing Nothing) e 400 getRelationshipId _ = Nothing 401 402 maxIdNumber :: Element -> Integer 403 maxIdNumber relationships = maximum (0 : idNumbers) 404 where 405 idNumbers = fst <$> mapMaybe (hush . decimal . T.drop 3) idAttributes 406 idAttributes = mapMaybe getIdAttribute (elContent relationships) 407 getIdAttribute (Elem e) = findAttr (QName "Id" Nothing Nothing) e 408 getIdAttribute _ = Nothing 409 410 maxIdNumber' :: Element -> Integer 411 maxIdNumber' sldLayouts = maximum (0 : idNumbers) 412 where 413 idNumbers = fst <$> mapMaybe (hush . decimal) idAttributes 414 idAttributes = mapMaybe getIdAttribute (elContent sldLayouts) 415 getIdAttribute (Elem e) = findAttr (QName "id" Nothing Nothing) e 416 getIdAttribute _ = Nothing 417 418 hush :: Either a b -> Maybe b 419 hush = either (const Nothing) Just 420 421makeSlideIdMap :: Presentation -> M.Map SlideId Int 422makeSlideIdMap (Presentation _ slides) = 423 M.fromList $ map slideId slides `zip` [1..] 424 425makeSpeakerNotesMap :: Presentation -> M.Map Int Int 426makeSpeakerNotesMap (Presentation _ slides) = 427 M.fromList $ 428 mapMaybe f (slides `zip` [1..]) `zip` [1..] 429 where f (Slide _ _ notes, n) = if notes == mempty 430 then Nothing 431 else Just n 432 433presentationToArchive :: PandocMonad m 434 => WriterOptions -> Meta -> Presentation -> m Archive 435presentationToArchive opts meta pres = do 436 distArchive <- toArchive . BL.fromStrict <$> 437 P.readDefaultDataFile "reference.pptx" 438 refArchive <- case writerReferenceDoc opts of 439 Just f -> toArchive <$> P.readFileLazy f 440 Nothing -> toArchive . BL.fromStrict <$> 441 P.readDataFile "reference.pptx" 442 443 let (referenceLayouts, defaultReferenceLayouts) = 444 (getLayoutsFromArchive refArchive, getLayoutsFromArchive distArchive) 445 let layoutTitles = SlideLayouts { metadata = "Title Slide" :: Text 446 , title = "Section Header" 447 , content = "Title and Content" 448 , twoColumn = "Two Content" 449 } 450 layouts <- for layoutTitles $ \layoutTitle -> do 451 let layout = M.lookup (CI.mk layoutTitle) referenceLayouts 452 let defaultLayout = M.lookup (CI.mk layoutTitle) defaultReferenceLayouts 453 case (layout, defaultLayout) of 454 (Nothing, Nothing) -> 455 throwError (PandocSomeError ("Couldn't find layout named \"" 456 <> layoutTitle <> "\" in the provided " 457 <> "reference doc or in the default " 458 <> "reference doc included with pandoc.")) 459 (Nothing, Just ((element, path, entry) :| _)) -> do 460 P.report (PowerpointTemplateWarning 461 ("Couldn't find layout named \"" 462 <> layoutTitle <> "\" in provided " 463 <> "reference doc. Falling back to " 464 <> "the default included with pandoc.")) 465 pure SlideLayout { slElement = element 466 , slPath = path 467 , slEntry = entry 468 , slInReferenceDoc = False 469 } 470 (Just ((element, path, entry) :| _), _ ) -> 471 pure SlideLayout { slElement = element 472 , slPath = path 473 , slEntry = entry 474 , slInReferenceDoc = True 475 } 476 477 478 utctime <- P.getTimestamp 479 480 presSize <- case getPresentationSize refArchive distArchive of 481 Just sz -> return sz 482 Nothing -> throwError $ 483 PandocSomeError 484 "Could not determine presentation size" 485 486 -- note, we need writerTemplate to be Just _ or metaToContext does 487 -- nothing 488 context <- metaToContext opts{ writerTemplate = 489 writerTemplate opts <|> Just mempty } 490 (return . literal . stringify) 491 (return . literal . stringify) meta 492 493 let env = def { envRefArchive = refArchive 494 , envDistArchive = distArchive 495 , envUTCTime = utctime 496 , envOpts = opts 497 , envContext = context 498 , envPresentationSize = presSize 499 , envSlideIdMap = makeSlideIdMap pres 500 , envSpeakerNotesIdMap = makeSpeakerNotesMap pres 501 , envSlideLayouts = Just layouts 502 } 503 504 let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive 505 } 506 507 runP env st $ presentationToArchiveP pres 508 509-- | Get all slide layouts from an archive, as a map where the layout's name 510-- gives the map key. 511-- 512-- For each layout, the map contains its XML representation, its path within 513-- the archive, and the archive entry. 514getLayoutsFromArchive :: Archive -> M.Map (CI Text) (NonEmpty (Element, FilePath, Entry)) 515getLayoutsFromArchive archive = 516 M.fromListWith (<>) ((\t@(e, _, _) -> (CI.mk (name e), pure t)) <$> layouts) 517 where 518 layouts :: [(Element, FilePath, Entry)] 519 layouts = mapMaybe findElementByPath paths 520 parseXml' entry = case parseXMLElement (UTF8.toTextLazy (fromEntry entry)) of 521 Left _ -> Nothing 522 Right element -> Just element 523 findElementByPath :: FilePath -> Maybe (Element, FilePath, Entry) 524 findElementByPath path = do 525 entry <- findEntryByPath path archive 526 element <- parseXml' entry 527 pure (element, path, entry) 528 paths = filter (match (compile "ppt/slideLayouts/slideLayout*.xml")) (filesInArchive archive) 529 name element = fromMaybe "Untitled layout" $ do 530 let ns = elemToNameSpaces element 531 cSld <- findChild (elemName ns "p" "cSld") element 532 findAttr (QName "name" Nothing Nothing) cSld 533 534-------------------------------------------------- 535 536-- Check to see if the presentation has speaker notes. This will 537-- influence whether we import the notesMaster template. 538presHasSpeakerNotes :: Presentation -> Bool 539presHasSpeakerNotes (Presentation _ slides) = 540 not $ all ((mempty ==) . slideSpeakerNotes) slides 541 542curSlideHasSpeakerNotes :: PandocMonad m => P m Bool 543curSlideHasSpeakerNotes = 544 M.member <$> asks envCurSlideId <*> asks envSpeakerNotesIdMap 545 546-------------------------------------------------- 547 548getLayout :: PandocMonad m => Layout -> P m Element 549getLayout layout = getElement <$> getSlideLayouts 550 where 551 getElement = 552 slElement . case layout of 553 MetadataSlide{} -> metadata 554 TitleSlide{} -> title 555 ContentSlide{} -> content 556 TwoColumnSlide{} -> twoColumn 557 558shapeHasId :: NameSpaces -> T.Text -> Element -> Bool 559shapeHasId ns ident element 560 | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element 561 , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr 562 , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr = 563 nm == ident 564 | otherwise = False 565 566getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element 567getContentShape ns spTreeElem 568 | isElem ns "p" "spTree" spTreeElem = do 569 contentType <- asks envContentType 570 let contentShapes = getShapesByPlaceHolderType ns spTreeElem ObjType 571 case contentType of 572 NormalContent | (sp : _) <- contentShapes -> return sp 573 TwoColumnLeftContent | (sp : _) <- contentShapes -> return sp 574 TwoColumnRightContent | (_ : sp : _) <- contentShapes -> return sp 575 _ -> throwError $ PandocSomeError 576 "Could not find shape for Powerpoint content" 577getContentShape _ _ = throwError $ PandocSomeError 578 "Attempted to find content on non shapeTree" 579 580getShapeDimensions :: NameSpaces 581 -> Element 582 -> Maybe ((Integer, Integer), (Integer, Integer)) 583getShapeDimensions ns element 584 | isElem ns "p" "sp" element = do 585 spPr <- findChild (elemName ns "p" "spPr") element 586 xfrm <- findChild (elemName ns "a" "xfrm") spPr 587 off <- findChild (elemName ns "a" "off") xfrm 588 xS <- findAttr (QName "x" Nothing Nothing) off 589 yS <- findAttr (QName "y" Nothing Nothing) off 590 ext <- findChild (elemName ns "a" "ext") xfrm 591 cxS <- findAttr (QName "cx" Nothing Nothing) ext 592 cyS <- findAttr (QName "cy" Nothing Nothing) ext 593 x <- readTextAsInteger xS 594 y <- readTextAsInteger yS 595 cx <- readTextAsInteger cxS 596 cy <- readTextAsInteger cyS 597 return ((x `div` 12700, y `div` 12700), 598 (cx `div` 12700, cy `div` 12700)) 599 | otherwise = Nothing 600 601 602getMasterShapeDimensionsById :: T.Text 603 -> Element 604 -> Maybe ((Integer, Integer), (Integer, Integer)) 605getMasterShapeDimensionsById ident master = do 606 let ns = elemToNameSpaces master 607 cSld <- findChild (elemName ns "p" "cSld") master 608 spTree <- findChild (elemName ns "p" "spTree") cSld 609 sp <- filterChild (\e -> isElem ns "p" "sp" e && shapeHasId ns ident e) spTree 610 getShapeDimensions ns sp 611 612getContentShapeSize :: PandocMonad m 613 => NameSpaces 614 -> Element 615 -> Element 616 -> P m ((Integer, Integer), (Integer, Integer)) 617getContentShapeSize ns layout master 618 | isElem ns "p" "sldLayout" layout 619 , Just cSld <- findChild (elemName ns "p" "cSld") layout 620 , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do 621 sp <- getContentShape ns spTree 622 case getShapeDimensions ns sp of 623 Just sz -> return sz 624 Nothing -> do let mbSz = 625 findChild (elemName ns "p" "nvSpPr") sp >>= 626 findChild (elemName ns "p" "cNvPr") >>= 627 findAttr (QName "id" Nothing Nothing) >>= 628 flip getMasterShapeDimensionsById master 629 case mbSz of 630 Just sz' -> return sz' 631 Nothing -> throwError $ PandocSomeError 632 "Couldn't find necessary content shape size" 633getContentShapeSize _ _ _ = throwError $ PandocSomeError 634 "Attempted to find content shape size in non-layout" 635 636buildSpTree :: NameSpaces -> Element -> [Content] -> Element 637buildSpTree ns spTreeElem newShapes = 638 emptySpTreeElem { elContent = newContent } 639 where newContent = elContent emptySpTreeElem <> newShapes 640 emptySpTreeElem = spTreeElem { elContent = filter fn (elContent spTreeElem) } 641 fn :: Content -> Bool 642 fn (Elem e) = isElem ns "p" "nvGrpSpPr" e || 643 isElem ns "p" "grpSpPr" e 644 fn _ = True 645 646replaceNamedChildren :: NameSpaces 647 -> Text 648 -> Text 649 -> [Element] 650 -> Element 651 -> Element 652replaceNamedChildren ns prefix name newKids element = 653 element { elContent = concat $ fun True $ elContent element } 654 where 655 fun :: Bool -> [Content] -> [[Content]] 656 fun _ [] = [] 657 fun switch (Elem e : conts) | isElem ns prefix name e = 658 if switch 659 then map Elem newKids : fun False conts 660 else fun False conts 661 fun switch (cont : conts) = [cont] : fun switch conts 662 663---------------------------------------------------------------- 664 665registerLink :: PandocMonad m => LinkTarget -> P m Int 666registerLink link = do 667 curSlideId <- asks envCurSlideId 668 linkReg <- gets stLinkIds 669 mediaReg <- gets stMediaIds 670 hasSpeakerNotes <- curSlideHasSpeakerNotes 671 let maxLinkId = case M.lookup curSlideId linkReg >>= nonEmpty . M.keys of 672 Just xs -> maximum xs 673 Nothing 674 | hasSpeakerNotes -> 2 675 | otherwise -> 1 676 maxMediaId = case M.lookup curSlideId mediaReg >>= nonEmpty of 677 Just mInfos -> maximum $ fmap mInfoLocalId mInfos 678 Nothing 679 | hasSpeakerNotes -> 2 680 | otherwise -> 1 681 maxId = max maxLinkId maxMediaId 682 slideLinks = case M.lookup curSlideId linkReg of 683 Just mp -> M.insert (maxId + 1) link mp 684 Nothing -> M.singleton (maxId + 1) link 685 modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg} 686 return $ maxId + 1 687 688registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo 689registerMedia fp caption = do 690 curSlideId <- asks envCurSlideId 691 linkReg <- gets stLinkIds 692 mediaReg <- gets stMediaIds 693 globalIds <- gets stMediaGlobalIds 694 hasSpeakerNotes <- curSlideHasSpeakerNotes 695 let maxLinkId = case M.lookup curSlideId linkReg >>= nonEmpty . M.keys of 696 Just ks -> maximum ks 697 Nothing 698 | hasSpeakerNotes -> 2 699 | otherwise -> 1 700 maxMediaId = case M.lookup curSlideId mediaReg >>= nonEmpty of 701 Just mInfos -> maximum $ fmap mInfoLocalId mInfos 702 Nothing 703 | hasSpeakerNotes -> 2 704 | otherwise -> 1 705 maxLocalId = max maxLinkId maxMediaId 706 707 maxGlobalId = maybe 0 maximum $ nonEmpty $ M.elems globalIds 708 709 (imgBytes, mbMt) <- P.fetchItem $ T.pack fp 710 let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ "." <> x)) 711 <|> 712 case imageType imgBytes of 713 Just Png -> Just ".png" 714 Just Jpeg -> Just ".jpeg" 715 Just Gif -> Just ".gif" 716 Just Pdf -> Just ".pdf" 717 Just Eps -> Just ".eps" 718 Just Svg -> Just ".svg" 719 Just Emf -> Just ".emf" 720 Just Tiff -> Just ".tiff" 721 Nothing -> Nothing 722 723 let newGlobalId = fromMaybe (maxGlobalId + 1) (M.lookup fp globalIds) 724 725 let newGlobalIds = M.insert fp newGlobalId globalIds 726 727 let mediaInfo = MediaInfo { mInfoFilePath = fp 728 , mInfoLocalId = maxLocalId + 1 729 , mInfoGlobalId = newGlobalId 730 , mInfoMimeType = mbMt 731 , mInfoExt = imgExt 732 , mInfoCaption = (not . null) caption 733 } 734 735 let slideMediaInfos = case M.lookup curSlideId mediaReg of 736 Just minfos -> mediaInfo : minfos 737 Nothing -> [mediaInfo] 738 739 740 modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg 741 , stMediaGlobalIds = newGlobalIds 742 } 743 return mediaInfo 744 745makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry 746makeMediaEntry mInfo = do 747 epochtime <- floor . utcTimeToPOSIXSeconds <$> asks envUTCTime 748 (imgBytes, _) <- P.fetchItem (T.pack $ mInfoFilePath mInfo) 749 let ext = fromMaybe "" (mInfoExt mInfo) 750 let fp = "ppt/media/image" <> 751 show (mInfoGlobalId mInfo) <> T.unpack ext 752 return $ toEntry fp epochtime $ BL.fromStrict imgBytes 753 754makeMediaEntries :: PandocMonad m => P m [Entry] 755makeMediaEntries = do 756 mediaInfos <- gets stMediaIds 757 let allInfos = mconcat $ M.elems mediaInfos 758 mapM makeMediaEntry allInfos 759 760-- -- | Scales the image to fit the page 761-- -- sizes are passed in emu 762-- fitToPage' :: (Double, Double) -- image size in emu 763-- -> Integer -- pageWidth 764-- -> Integer -- pageHeight 765-- -> (Integer, Integer) -- imagesize 766-- fitToPage' (x, y) pageWidth pageHeight 767-- -- Fixes width to the page width and scales the height 768-- | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight = 769-- (floor x, floor y) 770-- | x / fromIntegral pageWidth > y / fromIntegral pageWidth = 771-- (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) 772-- | otherwise = 773-- (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight) 774 775-- positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer) 776-- positionImage (x, y) pageWidth pageHeight = 777-- let (x', y') = fitToPage' (x, y) pageWidth pageHeight 778-- in 779-- ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2) 780 781getMaster :: PandocMonad m => P m Element 782getMaster = do 783 refArchive <- asks envRefArchive 784 distArchive <- asks envDistArchive 785 parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml" 786 787getMasterRels :: PandocMonad m => P m Element 788getMasterRels = do 789 refArchive <- asks envRefArchive 790 distArchive <- asks envDistArchive 791 parseXml refArchive distArchive "ppt/slideMasters/_rels/slideMaster1.xml.rels" 792 793-- We want to get the header dimensions, so we can make sure that the 794-- image goes underneath it. We only use this in a content slide if it 795-- has a header. 796 797-- getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer)) 798-- getHeaderSize = do 799-- master <- getMaster 800-- let ns = elemToNameSpaces master 801-- sps = [master] >>= 802-- findChildren (elemName ns "p" "cSld") >>= 803-- findChildren (elemName ns "p" "spTree") >>= 804-- findChildren (elemName ns "p" "sp") 805-- mbXfrm = 806-- listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>= 807-- findChild (elemName ns "p" "spPr") >>= 808-- findChild (elemName ns "a" "xfrm") 809-- xoff = mbXfrm >>= 810-- findChild (elemName ns "a" "off") >>= 811-- findAttr (QName "x" Nothing Nothing) >>= 812-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) 813-- yoff = mbXfrm >>= 814-- findChild (elemName ns "a" "off") >>= 815-- findAttr (QName "y" Nothing Nothing) >>= 816-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) 817-- xext = mbXfrm >>= 818-- findChild (elemName ns "a" "ext") >>= 819-- findAttr (QName "cx" Nothing Nothing) >>= 820-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) 821-- yext = mbXfrm >>= 822-- findChild (elemName ns "a" "ext") >>= 823-- findAttr (QName "cy" Nothing Nothing) >>= 824-- (listToMaybe . (\s -> reads s :: [(Integer, String)])) 825-- off = case xoff of 826-- Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff') 827-- _ -> (1043490, 1027664) 828-- ext = case xext of 829-- Just (xext', _) | Just (yext',_) <- yext -> (xext', yext') 830-- _ -> (7024744, 1143000) 831-- return $ (off, ext) 832 833-- Hard-coded for now 834-- captionPosition :: ((Integer, Integer), (Integer, Integer)) 835-- captionPosition = ((457200, 6061972), (8229600, 527087)) 836 837captionHeight :: Integer 838captionHeight = 40 839 840createCaption :: PandocMonad m 841 => ((Integer, Integer), (Integer, Integer)) 842 -> [ParaElem] 843 -> P m Element 844createCaption contentShapeDimensions paraElements = do 845 let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements 846 elements <- mapM paragraphToElement [para] 847 let ((x, y), (cx, cy)) = contentShapeDimensions 848 let txBody = mknode "p:txBody" [] $ 849 [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> elements 850 return $ 851 mknode "p:sp" [] [ mknode "p:nvSpPr" [] 852 [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] () 853 , mknode "p:cNvSpPr" [("txBox", "1")] () 854 , mknode "p:nvPr" [] () 855 ] 856 , mknode "p:spPr" [] 857 [ mknode "a:xfrm" [] 858 [ mknode "a:off" [("x", tshow $ 12700 * x), 859 ("y", tshow $ 12700 * (y + cy - captionHeight))] () 860 , mknode "a:ext" [("cx", tshow $ 12700 * cx), 861 ("cy", tshow $ 12700 * captionHeight)] () 862 ] 863 , mknode "a:prstGeom" [("prst", "rect")] 864 [ mknode "a:avLst" [] () 865 ] 866 , mknode "a:noFill" [] () 867 ] 868 , txBody 869 ] 870 871makePicElements :: PandocMonad m 872 => Element 873 -> PicProps 874 -> MediaInfo 875 -> Text 876 -> [ParaElem] 877 -> P m [Element] 878makePicElements layout picProps mInfo titleText alt = do 879 opts <- asks envOpts 880 (pageWidth, pageHeight) <- asks envPresentationSize 881 -- hasHeader <- asks envSlideHasHeader 882 let hasCaption = mInfoCaption mInfo 883 (imgBytes, _) <- P.fetchItem (T.pack $ mInfoFilePath mInfo) 884 let (pxX, pxY) = case imageSize opts imgBytes of 885 Right sz -> sizeInPixels sz 886 Left _ -> sizeInPixels def 887 master <- getMaster 888 let ns = elemToNameSpaces layout 889 ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master 890 `catchError` 891 (\_ -> return ((0, 0), (pageWidth, pageHeight))) 892 893 let cy = if hasCaption then cytmp - captionHeight else cytmp 894 895 let imgRatio = fromIntegral pxX / fromIntegral pxY :: Double 896 boxRatio = fromIntegral cx / fromIntegral cy :: Double 897 (dimX, dimY) = if imgRatio > boxRatio 898 then (fromIntegral cx, fromIntegral cx / imgRatio) 899 else (fromIntegral cy * imgRatio, fromIntegral cy) 900 901 (dimX', dimY') = (round dimX * 12700, round dimY * 12700) :: (Integer, Integer) 902 (xoff, yoff) = (fromIntegral x + (fromIntegral cx - dimX) / 2, 903 fromIntegral y + (fromIntegral cy - dimY) / 2) 904 (xoff', yoff') = (round xoff * 12700, round yoff * 12700) :: (Integer, Integer) 905 906 let cNvPicPr = mknode "p:cNvPicPr" [] $ 907 mknode "a:picLocks" [("noGrp","1") 908 ,("noChangeAspect","1")] () 909 -- cNvPr will contain the link information so we do that separately, 910 -- and register the link if necessary. 911 let description = (if T.null titleText 912 then "" 913 else titleText <> "\n\n") 914 <> T.pack (mInfoFilePath mInfo) 915 let cNvPrAttr = [("descr", description), 916 ("id","0"), 917 ("name","Picture 1")] 918 cNvPr <- case picPropLink picProps of 919 Just link -> do idNum <- registerLink link 920 return $ mknode "p:cNvPr" cNvPrAttr $ 921 mknode "a:hlinkClick" [("r:id", "rId" <> tshow idNum)] () 922 Nothing -> return $ mknode "p:cNvPr" cNvPrAttr () 923 let nvPicPr = mknode "p:nvPicPr" [] 924 [ cNvPr 925 , cNvPicPr 926 , mknode "p:nvPr" [] ()] 927 let blipFill = mknode "p:blipFill" [] 928 [ mknode "a:blip" [("r:embed", "rId" <> 929 tshow (mInfoLocalId mInfo))] () 930 , mknode "a:stretch" [] $ 931 mknode "a:fillRect" [] () ] 932 let xfrm = mknode "a:xfrm" [] 933 [ mknode "a:off" [("x", tshow xoff'), ("y", tshow yoff')] () 934 , mknode "a:ext" [("cx", tshow dimX') 935 ,("cy", tshow dimY')] () ] 936 let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ 937 mknode "a:avLst" [] () 938 let ln = mknode "a:ln" [("w","9525")] 939 [ mknode "a:noFill" [] () 940 , mknode "a:headEnd" [] () 941 , mknode "a:tailEnd" [] () ] 942 let spPr = mknode "p:spPr" [("bwMode","auto")] 943 [xfrm, prstGeom, mknode "a:noFill" [] (), ln] 944 945 let picShape = mknode "p:pic" [] 946 [ nvPicPr 947 , blipFill 948 , spPr ] 949 950 -- And now, maybe create the caption: 951 if hasCaption 952 then do cap <- createCaption ((x, y), (cx, cytmp)) alt 953 return [picShape, cap] 954 else return [picShape] 955 956 957paraElemToElements :: PandocMonad m => ParaElem -> P m [Content] 958paraElemToElements Break = return [Elem $ mknode "a:br" [] ()] 959paraElemToElements (Run rpr s) = do 960 sizeAttrs <- fontSizeAttributes rpr 961 let attrs = sizeAttrs <> 962 ( 963 [("b", "1") | rPropBold rpr]) <> 964 ( 965 [("i", "1") | rPropItalics rpr]) <> 966 ( 967 [("u", "sng") | rPropUnderline rpr]) <> 968 (case rStrikethrough rpr of 969 Just NoStrike -> [("strike", "noStrike")] 970 Just SingleStrike -> [("strike", "sngStrike")] 971 Just DoubleStrike -> [("strike", "dblStrike")] 972 Nothing -> []) <> 973 (case rBaseline rpr of 974 Just n -> [("baseline", tshow n)] 975 Nothing -> []) <> 976 (case rCap rpr of 977 Just NoCapitals -> [("cap", "none")] 978 Just SmallCapitals -> [("cap", "small")] 979 Just AllCapitals -> [("cap", "all")] 980 Nothing -> []) <> 981 [] 982 linkProps <- case rLink rpr of 983 Just link -> do 984 idNum <- registerLink link 985 -- first we have to make sure that if it's an 986 -- anchor, it's in the anchor map. If not, there's 987 -- no link. 988 return $ case link of 989 InternalTarget _ -> 990 let linkAttrs = 991 [ ("r:id", "rId" <> tshow idNum) 992 , ("action", "ppaction://hlinksldjump") 993 ] 994 in [mknode "a:hlinkClick" linkAttrs ()] 995 -- external 996 ExternalTarget _ -> 997 let linkAttrs = 998 [ ("r:id", "rId" <> tshow idNum) 999 ] 1000 in [mknode "a:hlinkClick" linkAttrs ()] 1001 Nothing -> return [] 1002 let colorContents = case rSolidFill rpr of 1003 Just color -> 1004 case fromColor color of 1005 '#':hx -> 1006 [mknode "a:solidFill" [] 1007 [mknode "a:srgbClr" 1008 [("val", T.toUpper $ T.pack hx)] ()]] 1009 _ -> [] 1010 Nothing -> [] 1011 codeFont <- monospaceFont 1012 let codeContents = 1013 [mknode "a:latin" [("typeface", codeFont)] () | rPropCode rpr] 1014 let propContents = linkProps <> colorContents <> codeContents 1015 return [Elem $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents 1016 , mknode "a:t" [] s 1017 ]] 1018paraElemToElements (MathElem mathType texStr) = do 1019 isInSpkrNotes <- asks envInSpeakerNotes 1020 if isInSpkrNotes 1021 then paraElemToElements $ Run def $ unTeXString texStr 1022 else do res <- convertMath writeOMML mathType (unTeXString texStr) 1023 case fromXLElement <$> res of 1024 Right r -> return [Elem $ mknode "a14:m" [] $ addMathInfo r] 1025 Left (Str s) -> paraElemToElements (Run def s) 1026 Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback" 1027paraElemToElements (RawOOXMLParaElem str) = return 1028 [Text (CData CDataRaw str Nothing)] 1029 1030 1031-- This is a bit of a kludge -- really requires adding an option to 1032-- TeXMath, but since that's a different package, we'll do this one 1033-- step at a time. 1034addMathInfo :: Element -> Element 1035addMathInfo element = 1036 let mathspace = 1037 Attr { attrKey = QName "m" Nothing (Just "xmlns") 1038 , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" 1039 } 1040 in add_attr mathspace element 1041 1042-- We look through the element to see if it contains an a14:m 1043-- element. If so, we surround it. This is a bit ugly, but it seems 1044-- more dependable than looking through shapes for math. Plus this is 1045-- an xml implementation detail, so it seems to make sense to do it at 1046-- the xml level. 1047surroundWithMathAlternate :: Element -> Element 1048surroundWithMathAlternate element = 1049 case findElement (QName "m" Nothing (Just "a14")) element of 1050 Just _ -> 1051 mknode "mc:AlternateContent" 1052 [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006") 1053 ] [ mknode "mc:Choice" 1054 [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main") 1055 , ("Requires", "a14")] [ element ] 1056 ] 1057 Nothing -> element 1058 1059paragraphToElement :: PandocMonad m => Paragraph -> P m Element 1060paragraphToElement par = do 1061 let 1062 attrs = [("lvl", tshow $ pPropLevel $ paraProps par)] <> 1063 (case pPropMarginLeft (paraProps par) of 1064 Just px -> [("marL", tshow $ pixelsToEmu px)] 1065 Nothing -> [] 1066 ) <> 1067 (case pPropIndent (paraProps par) of 1068 Just px -> [("indent", tshow $ pixelsToEmu px)] 1069 Nothing -> [] 1070 ) <> 1071 (case pPropAlign (paraProps par) of 1072 Just AlgnLeft -> [("algn", "l")] 1073 Just AlgnRight -> [("algn", "r")] 1074 Just AlgnCenter -> [("algn", "ctr")] 1075 Nothing -> [] 1076 ) 1077 props = [] <> 1078 (case pPropSpaceBefore $ paraProps par of 1079 Just px -> [mknode "a:spcBef" [] [ 1080 mknode "a:spcPts" [("val", tshow $ 100 * px)] () 1081 ] 1082 ] 1083 Nothing -> [] 1084 ) <> 1085 (case pPropBullet $ paraProps par of 1086 Just Bullet -> [] 1087 Just (AutoNumbering attrs') -> 1088 [mknode "a:buAutoNum" (autoNumAttrs attrs') ()] 1089 Nothing -> [mknode "a:buNone" [] ()] 1090 ) 1091 paras <- mapM paraElemToElements (paraElems par) 1092 return $ mknode "a:p" [] $ 1093 [Elem $ mknode "a:pPr" attrs props] <> concat paras 1094 1095shapeToElement :: PandocMonad m => Element -> Shape -> P m Element 1096shapeToElement layout (TextBox paras) 1097 | ns <- elemToNameSpaces layout 1098 , Just cSld <- findChild (elemName ns "p" "cSld") layout 1099 , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do 1100 sp <- getContentShape ns spTree 1101 elements <- mapM paragraphToElement paras 1102 let txBody = mknode "p:txBody" [] $ 1103 [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> elements 1104 emptySpPr = mknode "p:spPr" [] () 1105 return 1106 . surroundWithMathAlternate 1107 . replaceNamedChildren ns "p" "txBody" [txBody] 1108 . replaceNamedChildren ns "p" "spPr" [emptySpPr] 1109 $ sp 1110-- GraphicFrame and Pic should never reach this. 1111shapeToElement _ _ = return $ mknode "p:sp" [] () 1112 1113shapeToElements :: PandocMonad m => Element -> Shape -> P m [Content] 1114shapeToElements layout (Pic picProps fp titleText alt) = do 1115 mInfo <- registerMedia fp alt 1116 case mInfoExt mInfo of 1117 Just _ -> map Elem <$> 1118 makePicElements layout picProps mInfo titleText alt 1119 Nothing -> shapeToElements layout $ TextBox [Paragraph def alt] 1120shapeToElements layout (GraphicFrame tbls cptn) = map Elem <$> 1121 graphicFrameToElements layout tbls cptn 1122shapeToElements _ (RawOOXMLShape str) = return 1123 [Text (CData CDataRaw str Nothing)] 1124shapeToElements layout shp = do 1125 element <- shapeToElement layout shp 1126 return [Elem element] 1127 1128shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Content] 1129shapesToElements layout shps = 1130 concat <$> mapM (shapeToElements layout) shps 1131 1132graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element] 1133graphicFrameToElements layout tbls caption = do 1134 -- get the sizing 1135 master <- getMaster 1136 (pageWidth, pageHeight) <- asks envPresentationSize 1137 let ns = elemToNameSpaces layout 1138 ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master 1139 `catchError` 1140 (\_ -> return ((0, 0), (pageWidth, pageHeight))) 1141 1142 let cy = if not $ null caption then cytmp - captionHeight else cytmp 1143 1144 elements <- mapM (graphicToElement cx) tbls 1145 let graphicFrameElts = 1146 mknode "p:graphicFrame" [] $ 1147 [ mknode "p:nvGraphicFramePr" [] 1148 [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] () 1149 , mknode "p:cNvGraphicFramePr" [] 1150 [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()] 1151 , mknode "p:nvPr" [] 1152 [mknode "p:ph" [("idx", "1")] ()] 1153 ] 1154 , mknode "p:xfrm" [] 1155 [ mknode "a:off" [("x", tshow $ 12700 * x), 1156 ("y", tshow $ 12700 * y)] () 1157 , mknode "a:ext" [("cx", tshow $ 12700 * cx), 1158 ("cy", tshow $ 12700 * cy)] () 1159 ] 1160 ] <> elements 1161 1162 if not $ null caption 1163 then do capElt <- createCaption ((x, y), (cx, cytmp)) caption 1164 return [graphicFrameElts, capElt] 1165 else return [graphicFrameElts] 1166 1167getDefaultTableStyle :: PandocMonad m => P m (Maybe T.Text) 1168getDefaultTableStyle = do 1169 refArchive <- asks envRefArchive 1170 distArchive <- asks envDistArchive 1171 tblStyleLst <- parseXml refArchive distArchive "ppt/tableStyles.xml" 1172 return $ findAttr (QName "def" Nothing Nothing) tblStyleLst 1173 1174graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element 1175graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do 1176 let colWidths = if null hdrCells 1177 then case rows of 1178 r : _ | not (null r) -> replicate (length r) $ 1179 tableWidth `div` toInteger (length r) 1180 -- satisfy the compiler. This is the same as 1181 -- saying that rows is empty, but the compiler 1182 -- won't understand that `[]` exhausts the 1183 -- alternatives. 1184 _ -> [] 1185 else replicate (length hdrCells) $ 1186 tableWidth `div` toInteger (length hdrCells) 1187 1188 let cellToOpenXML paras = 1189 do elements <- mapM paragraphToElement paras 1190 let elements' = if null elements 1191 then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]] 1192 else elements 1193 1194 return 1195 [mknode "a:txBody" [] $ 1196 [ mknode "a:bodyPr" [] () 1197 , mknode "a:lstStyle" [] ()] 1198 <> elements'] 1199 headers' <- mapM cellToOpenXML hdrCells 1200 rows' <- mapM (mapM cellToOpenXML) rows 1201 let borderProps = mknode "a:tcPr" [] () 1202 let emptyCell' = [mknode "a:p" [] [mknode "a:pPr" [] ()]] 1203 let mkcell border contents = mknode "a:tc" [] 1204 $ (if null contents 1205 then emptyCell' 1206 else contents) <> [ borderProps | border ] 1207 let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells 1208 1209 let mkgridcol w = mknode "a:gridCol" 1210 [("w", tshow ((12700 * w) :: Integer))] () 1211 let hasHeader = not (all null hdrCells) 1212 1213 mbDefTblStyle <- getDefaultTableStyle 1214 let tblPrElt = mknode "a:tblPr" 1215 [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") 1216 , ("bandRow", if tblPrBandRow tblPr then "1" else "0") 1217 ] (case mbDefTblStyle of 1218 Nothing -> [] 1219 Just sty -> [mknode "a:tableStyleId" [] sty]) 1220 1221 return $ mknode "a:graphic" [] 1222 [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] 1223 [mknode "a:tbl" [] $ 1224 [ tblPrElt 1225 , mknode "a:tblGrid" [] (if all (==0) colWidths 1226 then [] 1227 else map mkgridcol colWidths) 1228 ] 1229 <> [ mkrow True headers' | hasHeader ] <> map (mkrow False) rows' 1230 ] 1231 ] 1232 1233 1234-- We get the shape by placeholder type. If there is NO type, it 1235-- defaults to a content placeholder. 1236 1237data PHType = PHType T.Text | ObjType 1238 deriving (Show, Eq) 1239 1240findPHType :: NameSpaces -> Element -> PHType -> Bool 1241findPHType ns spElem phType 1242 | isElem ns "p" "sp" spElem = 1243 let mbPHElem = (Just spElem >>= 1244 findChild (elemName ns "p" "nvSpPr") >>= 1245 findChild (elemName ns "p" "nvPr") >>= 1246 findChild (elemName ns "p" "ph")) 1247 in 1248 case mbPHElem of 1249 -- if it's a named PHType, we want to check that the attribute 1250 -- value matches. 1251 Just phElem | (PHType tp) <- phType -> 1252 case findAttr (QName "type" Nothing Nothing) phElem of 1253 Just tp' -> tp == tp' 1254 Nothing -> False 1255 -- if it's an ObjType, we want to check that there is NO 1256 -- "type" attribute. In other words, a lookup should return nothing. 1257 Just phElem | ObjType <- phType -> 1258 case findAttr (QName "type" Nothing Nothing) phElem of 1259 Just _ -> False 1260 Nothing -> True 1261 Nothing -> False 1262findPHType _ _ _ = False 1263 1264getShapesByPlaceHolderType :: NameSpaces -> Element -> PHType -> [Element] 1265getShapesByPlaceHolderType ns spTreeElem phType 1266 | isElem ns "p" "spTree" spTreeElem = 1267 filterChildren (\e -> findPHType ns e phType) spTreeElem 1268 | otherwise = [] 1269 1270getShapeByPlaceHolderType :: NameSpaces -> Element -> PHType -> Maybe Element 1271getShapeByPlaceHolderType ns spTreeElem phType = 1272 listToMaybe $ getShapesByPlaceHolderType ns spTreeElem phType 1273 1274-- Like the above, but it tries a number of different placeholder types 1275getShapeByPlaceHolderTypes :: NameSpaces -> Element -> [PHType] -> Maybe Element 1276getShapeByPlaceHolderTypes _ _ [] = Nothing 1277getShapeByPlaceHolderTypes ns spTreeElem (s:ss) = 1278 case getShapeByPlaceHolderType ns spTreeElem s of 1279 Just element -> Just element 1280 Nothing -> getShapeByPlaceHolderTypes ns spTreeElem ss 1281 1282nonBodyTextToElement :: PandocMonad m => Element -> [PHType] -> [ParaElem] -> P m Element 1283nonBodyTextToElement layout phTypes paraElements 1284 | ns <- elemToNameSpaces layout 1285 , Just cSld <- findChild (elemName ns "p" "cSld") layout 1286 , Just spTree <- findChild (elemName ns "p" "spTree") cSld 1287 , Just sp <- getShapeByPlaceHolderTypes ns spTree phTypes = do 1288 let hdrPara = Paragraph def paraElements 1289 element <- paragraphToElement hdrPara 1290 let txBody = mknode "p:txBody" [] $ 1291 [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> 1292 [element] 1293 return $ replaceNamedChildren ns "p" "txBody" [txBody] sp 1294 -- XXX: TODO 1295 | otherwise = return $ mknode "p:sp" [] () 1296 1297contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element 1298contentToElement layout hdrShape shapes 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 [PHType "title"] hdrShape 1303 let hdrShapeElements = [Elem element | not (null hdrShape)] 1304 contentElements <- local 1305 (\env -> env {envContentType = NormalContent}) 1306 (shapesToElements layout shapes) 1307 return $ buildSpTree ns spTree (hdrShapeElements <> contentElements) 1308contentToElement _ _ _ = return $ mknode "p:sp" [] () 1309 1310twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element 1311twoColumnToElement layout hdrShape shapesL shapesR 1312 | ns <- elemToNameSpaces layout 1313 , Just cSld <- findChild (elemName ns "p" "cSld") layout 1314 , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do 1315 element <- nonBodyTextToElement layout [PHType "title"] hdrShape 1316 let hdrShapeElements = [Elem element | not (null hdrShape)] 1317 contentElementsL <- local 1318 (\env -> env {envContentType =TwoColumnLeftContent}) 1319 (shapesToElements layout shapesL) 1320 contentElementsR <- local 1321 (\env -> env {envContentType =TwoColumnRightContent}) 1322 (shapesToElements layout shapesR) 1323 -- let contentElementsL' = map (setIdx ns "1") contentElementsL 1324 -- contentElementsR' = map (setIdx ns "2") contentElementsR 1325 return $ buildSpTree ns spTree $ 1326 hdrShapeElements <> contentElementsL <> contentElementsR 1327twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] () 1328 1329 1330titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element 1331titleToElement layout titleElems 1332 | ns <- elemToNameSpaces layout 1333 , Just cSld <- findChild (elemName ns "p" "cSld") layout 1334 , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do 1335 element <- nonBodyTextToElement layout [PHType "title", PHType "ctrTitle"] titleElems 1336 let titleShapeElements = [Elem element | not (null titleElems)] 1337 return $ buildSpTree ns spTree titleShapeElements 1338titleToElement _ _ = return $ mknode "p:sp" [] () 1339 1340metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element 1341metadataToElement layout titleElems subtitleElems authorsElems dateElems 1342 | ns <- elemToNameSpaces layout 1343 , Just cSld <- findChild (elemName ns "p" "cSld") layout 1344 , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do 1345 titleShapeElements <- if null titleElems 1346 then return [] 1347 else sequence [nonBodyTextToElement layout [PHType "ctrTitle"] titleElems] 1348 let combinedAuthorElems = intercalate [Break] authorsElems 1349 subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] 1350 subtitleShapeElements <- if null subtitleAndAuthorElems 1351 then return [] 1352 else sequence [nonBodyTextToElement layout [PHType "subTitle"] subtitleAndAuthorElems] 1353 dateShapeElements <- if null dateElems 1354 then return [] 1355 else sequence [nonBodyTextToElement layout [PHType "dt"] dateElems] 1356 return . buildSpTree ns spTree . map Elem $ 1357 (titleShapeElements <> subtitleShapeElements <> dateShapeElements) 1358metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () 1359 1360slideToElement :: PandocMonad m => Slide -> P m Element 1361slideToElement (Slide _ l@(ContentSlide hdrElems shapes) _ )= do 1362 layout <- getLayout l 1363 spTree <- local (\env -> if null hdrElems 1364 then env 1365 else env{envSlideHasHeader=True}) $ 1366 contentToElement layout hdrElems shapes 1367 return $ mknode "p:sld" 1368 [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), 1369 ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), 1370 ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") 1371 ] [mknode "p:cSld" [] [spTree]] 1372slideToElement (Slide _ l@(TwoColumnSlide hdrElems shapesL shapesR) _) = do 1373 layout <- getLayout l 1374 spTree <- local (\env -> if null hdrElems 1375 then env 1376 else env{envSlideHasHeader=True}) $ 1377 twoColumnToElement layout hdrElems shapesL shapesR 1378 return $ mknode "p:sld" 1379 [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), 1380 ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), 1381 ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") 1382 ] [mknode "p:cSld" [] [spTree]] 1383slideToElement (Slide _ l@(TitleSlide hdrElems) _) = do 1384 layout <- getLayout l 1385 spTree <- titleToElement layout hdrElems 1386 return $ mknode "p:sld" 1387 [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), 1388 ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), 1389 ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") 1390 ] [mknode "p:cSld" [] [spTree]] 1391slideToElement (Slide _ l@(MetadataSlide titleElems subtitleElems authorElems dateElems) _) = do 1392 layout <- getLayout l 1393 spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems 1394 return $ mknode "p:sld" 1395 [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), 1396 ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), 1397 ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") 1398 ] [mknode "p:cSld" [] [spTree]] 1399 1400 1401-------------------------------------------------------------------- 1402-- Notes: 1403 1404getNotesMaster :: PandocMonad m => P m Element 1405getNotesMaster = do 1406 refArchive <- asks envRefArchive 1407 distArchive <- asks envDistArchive 1408 parseXml refArchive distArchive "ppt/notesMasters/notesMaster1.xml" 1409 1410getSlideNumberFieldId :: PandocMonad m => Element -> P m T.Text 1411getSlideNumberFieldId notesMaster 1412 | ns <- elemToNameSpaces notesMaster 1413 , Just cSld <- findChild (elemName ns "p" "cSld") notesMaster 1414 , Just spTree <- findChild (elemName ns "p" "spTree") cSld 1415 , Just sp <- getShapeByPlaceHolderType ns spTree (PHType "sldNum") 1416 , Just txBody <- findChild (elemName ns "p" "txBody") sp 1417 , Just p <- findChild (elemName ns "a" "p") txBody 1418 , Just fld <- findChild (elemName ns "a" "fld") p 1419 , Just fldId <- findAttr (QName "id" Nothing Nothing) fld = 1420 return fldId 1421 | otherwise = throwError $ 1422 PandocSomeError 1423 "No field id for slide numbers in notesMaster.xml" 1424 1425speakerNotesSlideImage :: Element 1426speakerNotesSlideImage = 1427 mknode "p:sp" [] 1428 [ mknode "p:nvSpPr" [] 1429 [ mknode "p:cNvPr" [ ("id", "2") 1430 , ("name", "Slide Image Placeholder 1") 1431 ] () 1432 , mknode "p:cNvSpPr" [] 1433 [ mknode "a:spLocks" [ ("noGrp", "1") 1434 , ("noRot", "1") 1435 , ("noChangeAspect", "1") 1436 ] () 1437 ] 1438 , mknode "p:nvPr" [] 1439 [ mknode "p:ph" [("type", "sldImg")] ()] 1440 ] 1441 , mknode "p:spPr" [] () 1442 ] 1443 1444-- we want to wipe links from the speaker notes in the 1445-- paragraphs. Powerpoint doesn't allow you to input them, and it 1446-- would provide extra complications. 1447removeParaLinks :: Paragraph -> Paragraph 1448removeParaLinks paragraph = paragraph{paraElems = map f (paraElems paragraph)} 1449 where f (Run rProps s) = Run rProps{rLink=Nothing} s 1450 f pe = pe 1451 1452-- put an empty paragraph between paragraphs for more expected spacing. 1453spaceParas :: [Paragraph] -> [Paragraph] 1454spaceParas = intersperse (Paragraph def []) 1455 1456speakerNotesBody :: PandocMonad m => [Paragraph] -> P m Element 1457speakerNotesBody paras = do 1458 elements <- local (\env -> env{envInSpeakerNotes = True}) $ 1459 mapM paragraphToElement $ spaceParas $ map removeParaLinks paras 1460 let txBody = mknode "p:txBody" [] $ 1461 [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> elements 1462 return $ 1463 mknode "p:sp" [] 1464 [ mknode "p:nvSpPr" [] 1465 [ mknode "p:cNvPr" [ ("id", "3") 1466 , ("name", "Notes Placeholder 2") 1467 ] () 1468 , mknode "p:cNvSpPr" [] 1469 [ mknode "a:spLocks" [("noGrp", "1")] ()] 1470 , mknode "p:nvPr" [] 1471 [ mknode "p:ph" [("type", "body"), ("idx", "1")] ()] 1472 ] 1473 , mknode "p:spPr" [] () 1474 , txBody 1475 ] 1476 1477speakerNotesSlideNumber :: Int -> T.Text -> Element 1478speakerNotesSlideNumber pgNum fieldId = 1479 mknode "p:sp" [] 1480 [ mknode "p:nvSpPr" [] 1481 [ mknode "p:cNvPr" [ ("id", "4") 1482 , ("name", "Slide Number Placeholder 3") 1483 ] () 1484 , mknode "p:cNvSpPr" [] 1485 [ mknode "a:spLocks" [("noGrp", "1")] ()] 1486 , mknode "p:nvPr" [] 1487 [ mknode "p:ph" [ ("type", "sldNum") 1488 , ("sz", "quarter") 1489 , ("idx", "10") 1490 ] () 1491 ] 1492 ] 1493 , mknode "p:spPr" [] () 1494 , mknode "p:txBody" [] 1495 [ mknode "a:bodyPr" [] () 1496 , mknode "a:lstStyle" [] () 1497 , mknode "a:p" [] 1498 [ mknode "a:fld" [ ("id", fieldId) 1499 , ("type", "slidenum") 1500 ] 1501 [ mknode "a:rPr" [("lang", "en-US")] () 1502 , mknode "a:t" [] (tshow pgNum) 1503 ] 1504 , mknode "a:endParaRPr" [("lang", "en-US")] () 1505 ] 1506 ] 1507 ] 1508 1509slideToSpeakerNotesElement :: PandocMonad m => Slide -> P m (Maybe Element) 1510slideToSpeakerNotesElement (Slide _ _ (SpeakerNotes [])) = return Nothing 1511slideToSpeakerNotesElement slide@(Slide _ _ (SpeakerNotes paras)) = do 1512 master <- getNotesMaster 1513 fieldId <- getSlideNumberFieldId master 1514 num <- slideNum slide 1515 let imgShape = speakerNotesSlideImage 1516 sldNumShape = speakerNotesSlideNumber num fieldId 1517 bodyShape <- speakerNotesBody paras 1518 return $ Just $ 1519 mknode "p:notes" 1520 [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main") 1521 , ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") 1522 , ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") 1523 ] [ mknode "p:cSld" [] 1524 [ mknode "p:spTree" [] 1525 [ mknode "p:nvGrpSpPr" [] 1526 [ mknode "p:cNvPr" [("id", "1"), ("name", "")] () 1527 , mknode "p:cNvGrpSpPr" [] () 1528 , mknode "p:nvPr" [] () 1529 ] 1530 , mknode "p:grpSpPr" [] 1531 [ mknode "a:xfrm" [] 1532 [ mknode "a:off" [("x", "0"), ("y", "0")] () 1533 , mknode "a:ext" [("cx", "0"), ("cy", "0")] () 1534 , mknode "a:chOff" [("x", "0"), ("y", "0")] () 1535 , mknode "a:chExt" [("cx", "0"), ("cy", "0")] () 1536 ] 1537 ] 1538 , imgShape 1539 , bodyShape 1540 , sldNumShape 1541 ] 1542 ] 1543 ] 1544 1545----------------------------------------------------------------------- 1546 1547getSlideIdNum :: PandocMonad m => SlideId -> P m Int 1548getSlideIdNum sldId = do 1549 slideIdMap <- asks envSlideIdMap 1550 case M.lookup sldId slideIdMap of 1551 Just n -> return n 1552 Nothing -> throwError $ 1553 PandocShouldNeverHappenError $ 1554 "Slide Id " <> tshow sldId <> " not found." 1555 1556slideNum :: PandocMonad m => Slide -> P m Int 1557slideNum slide = getSlideIdNum $ slideId slide 1558 1559idNumToFilePath :: Int -> FilePath 1560idNumToFilePath idNum = "slide" <> show idNum <> ".xml" 1561 1562slideToFilePath :: PandocMonad m => Slide -> P m FilePath 1563slideToFilePath slide = do 1564 idNum <- slideNum slide 1565 return $ "slide" <> show idNum <> ".xml" 1566 1567slideToRelId :: PandocMonad m => Slide -> P m T.Text 1568slideToRelId slide = do 1569 n <- slideNum slide 1570 offset <- asks envSlideIdOffset 1571 return $ "rId" <> tshow (n + offset) 1572 1573 1574data Relationship = Relationship { relId :: Int 1575 , relType :: MimeType 1576 , relTarget :: FilePath 1577 } deriving (Show, Eq) 1578 1579elementToRel :: Element -> Maybe Relationship 1580elementToRel element 1581 | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing = 1582 do rId <- findAttr (QName "Id" Nothing Nothing) element 1583 numStr <- T.stripPrefix "rId" rId 1584 num <- fromIntegral <$> readTextAsInteger numStr 1585 type' <- findAttr (QName "Type" Nothing Nothing) element 1586 target <- findAttr (QName "Target" Nothing Nothing) element 1587 return $ Relationship num type' (T.unpack target) 1588 | otherwise = Nothing 1589 1590slideToPresRel :: PandocMonad m => Slide -> P m Relationship 1591slideToPresRel slide = do 1592 idNum <- slideNum slide 1593 n <- asks envSlideIdOffset 1594 let rId = idNum + n 1595 fp = "slides/" <> idNumToFilePath idNum 1596 return $ Relationship { relId = rId 1597 , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" 1598 , relTarget = fp 1599 } 1600 1601getRels :: PandocMonad m => P m [Relationship] 1602getRels = do 1603 refArchive <- asks envRefArchive 1604 distArchive <- asks envDistArchive 1605 relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels" 1606 let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships" 1607 let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem 1608 return $ mapMaybe elementToRel relElems 1609 1610presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] 1611presentationToRels pres@(Presentation _ slides) = do 1612 mySlideRels <- mapM slideToPresRel slides 1613 let notesMasterRels = 1614 [Relationship { relId = length mySlideRels + 2 1615 , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster" 1616 , relTarget = "notesMasters/notesMaster1.xml" 1617 } | presHasSpeakerNotes pres] 1618 insertedRels = mySlideRels <> notesMasterRels 1619 rels <- getRels 1620 -- we remove the slide rels and the notesmaster (if it's 1621 -- there). We'll put these back in ourselves, if necessary. 1622 let relsWeKeep = filter 1623 (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" && 1624 relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") 1625 rels 1626 -- We want to make room for the slides in the id space. The slides 1627 -- will start at Id2 (since Id1 is for the slide master). There are 1628 -- two slides in the data file, but that might change in the future, 1629 -- so we will do this: 1630 -- 1631 -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is. 1632 -- 2. We add the difference between this and the number of slides to 1633 -- all relWithoutSlide rels (unless they're 1) 1634 -- 3. If we have a notesmaster slide, we make space for that as well. 1635 1636 let minRelNotOne = maybe 0 minimum $ nonEmpty 1637 $ filter (1 <) $ map relId relsWeKeep 1638 1639 modifyRelNum :: Int -> Int 1640 modifyRelNum 1 = 1 1641 modifyRelNum n = n - minRelNotOne + 2 + length insertedRels 1642 1643 relsWeKeep' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWeKeep 1644 1645 return $ insertedRels <> relsWeKeep' 1646 1647-- We make this ourselves, in case there's a thumbnail in the one from 1648-- the template. 1649topLevelRels :: [Relationship] 1650topLevelRels = 1651 [ Relationship { relId = 1 1652 , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" 1653 , relTarget = "ppt/presentation.xml" 1654 } 1655 , Relationship { relId = 2 1656 , relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" 1657 , relTarget = "docProps/core.xml" 1658 } 1659 , Relationship { relId = 3 1660 , relType = "http://schemas.openxmlformats.org/package/2006/relationships/metadata/extended-properties" 1661 , relTarget = "docProps/app.xml" 1662 } 1663 , Relationship { relId = 4 1664 , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/custom-properties" 1665 , relTarget = "docProps/custom.xml" 1666 } 1667 ] 1668 1669topLevelRelsEntry :: PandocMonad m => P m Entry 1670topLevelRelsEntry = elemToEntry "_rels/.rels" $ relsToElement topLevelRels 1671 1672relToElement :: Relationship -> Element 1673relToElement rel = mknode "Relationship" [ ("Id", "rId" <> tshow (relId rel)) 1674 , ("Type", relType rel) 1675 , ("Target", T.pack $ relTarget rel) ] () 1676 1677relsToElement :: [Relationship] -> Element 1678relsToElement rels = mknode "Relationships" 1679 [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] 1680 (map relToElement rels) 1681 1682presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry 1683presentationToRelsEntry pres = do 1684 rels <- presentationToRels pres 1685 elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels 1686 1687elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry 1688elemToEntry fp element = do 1689 epochtime <- floor . utcTimeToPOSIXSeconds <$> asks envUTCTime 1690 return $ toEntry fp epochtime $ renderXml element 1691 1692slideToEntry :: PandocMonad m => Slide -> P m Entry 1693slideToEntry slide = do 1694 idNum <- slideNum slide 1695 local (\env -> env{envCurSlideId = idNum}) $ do 1696 element <- slideToElement slide 1697 elemToEntry ("ppt/slides/" <> idNumToFilePath idNum) element 1698 1699slideToSpeakerNotesEntry :: PandocMonad m => Slide -> P m (Maybe Entry) 1700slideToSpeakerNotesEntry slide = do 1701 idNum <- slideNum slide 1702 local (\env -> env{envCurSlideId = idNum}) $ do 1703 mbElement <- slideToSpeakerNotesElement slide 1704 mbNotesIdNum <- do mp <- asks envSpeakerNotesIdMap 1705 return $ M.lookup idNum mp 1706 case mbElement of 1707 Just element | Just notesIdNum <- mbNotesIdNum -> 1708 Just <$> 1709 elemToEntry 1710 ("ppt/notesSlides/notesSlide" <> show notesIdNum <> 1711 ".xml") 1712 element 1713 _ -> return Nothing 1714 1715slideToSpeakerNotesRelElement :: PandocMonad m => Slide -> P m (Maybe Element) 1716slideToSpeakerNotesRelElement (Slide _ _ (SpeakerNotes [])) = return Nothing 1717slideToSpeakerNotesRelElement slide@Slide{} = do 1718 idNum <- slideNum slide 1719 return $ Just $ 1720 mknode "Relationships" 1721 [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] 1722 [ mknode "Relationship" [ ("Id", "rId2") 1723 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") 1724 , ("Target", "../slides/slide" <> tshow idNum <> ".xml") 1725 ] () 1726 , mknode "Relationship" [ ("Id", "rId1") 1727 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") 1728 , ("Target", "../notesMasters/notesMaster1.xml") 1729 ] () 1730 ] 1731 1732 1733slideToSpeakerNotesRelEntry :: PandocMonad m => Slide -> P m (Maybe Entry) 1734slideToSpeakerNotesRelEntry slide = do 1735 idNum <- slideNum slide 1736 mbElement <- slideToSpeakerNotesRelElement slide 1737 mp <- asks envSpeakerNotesIdMap 1738 let mbNotesIdNum = M.lookup idNum mp 1739 case mbElement of 1740 Just element | Just notesIdNum <- mbNotesIdNum -> 1741 Just <$> 1742 elemToEntry 1743 ("ppt/notesSlides/_rels/notesSlide" <> show notesIdNum <> ".xml.rels") 1744 element 1745 _ -> return Nothing 1746 1747slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry 1748slideToSlideRelEntry slide = do 1749 idNum <- slideNum slide 1750 element <- slideToSlideRelElement slide 1751 elemToEntry ("ppt/slides/_rels/" <> idNumToFilePath idNum <> ".rels") element 1752 1753linkRelElement :: PandocMonad m => (Int, LinkTarget) -> P m Element 1754linkRelElement (rIdNum, InternalTarget targetId) = do 1755 targetIdNum <- getSlideIdNum targetId 1756 return $ 1757 mknode "Relationship" [ ("Id", "rId" <> tshow rIdNum) 1758 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") 1759 , ("Target", "slide" <> tshow targetIdNum <> ".xml") 1760 ] () 1761linkRelElement (rIdNum, ExternalTarget (url, _)) = 1762 return $ 1763 mknode "Relationship" [ ("Id", "rId" <> tshow rIdNum) 1764 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") 1765 , ("Target", url) 1766 , ("TargetMode", "External") 1767 ] () 1768 1769linkRelElements :: PandocMonad m => M.Map Int LinkTarget -> P m [Element] 1770linkRelElements mp = mapM linkRelElement (M.toList mp) 1771 1772mediaRelElement :: MediaInfo -> Element 1773mediaRelElement mInfo = 1774 let ext = fromMaybe "" (mInfoExt mInfo) 1775 in 1776 mknode "Relationship" [ ("Id", "rId" <> 1777 tshow (mInfoLocalId mInfo)) 1778 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") 1779 , ("Target", "../media/image" <> 1780 tshow (mInfoGlobalId mInfo) <> ext) 1781 ] () 1782 1783speakerNotesSlideRelElement :: PandocMonad m => Slide -> P m (Maybe Element) 1784speakerNotesSlideRelElement slide = do 1785 idNum <- slideNum slide 1786 mp <- asks envSpeakerNotesIdMap 1787 return $ case M.lookup idNum mp of 1788 Nothing -> Nothing 1789 Just n -> 1790 let target = "../notesSlides/notesSlide" <> tshow n <> ".xml" 1791 in Just $ 1792 mknode "Relationship" [ ("Id", "rId2") 1793 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesSlide") 1794 , ("Target", target) 1795 ] () 1796 1797slideToSlideRelElement :: PandocMonad m => Slide -> P m Element 1798slideToSlideRelElement slide = do 1799 idNum <- slideNum slide 1800 target <- flip fmap getSlideLayouts $ 1801 T.pack . ("../slideLayouts/" <>) . takeFileName . 1802 slPath . case slide of 1803 (Slide _ MetadataSlide{} _) -> metadata 1804 (Slide _ TitleSlide{} _) -> title 1805 (Slide _ ContentSlide{} _) -> content 1806 (Slide _ TwoColumnSlide{} _) -> twoColumn 1807 1808 speakerNotesRels <- maybeToList <$> speakerNotesSlideRelElement slide 1809 1810 linkIds <- gets stLinkIds 1811 mediaIds <- gets stMediaIds 1812 1813 linkRels <- case M.lookup idNum linkIds of 1814 Just mp -> linkRelElements mp 1815 Nothing -> return [] 1816 let mediaRels = case M.lookup idNum mediaIds of 1817 Just mInfos -> map mediaRelElement mInfos 1818 Nothing -> [] 1819 1820 return $ 1821 mknode "Relationships" 1822 [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] 1823 ([mknode "Relationship" [ ("Id", "rId1") 1824 , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout") 1825 , ("Target", target)] () 1826 ] <> speakerNotesRels <> linkRels <> mediaRels) 1827 1828slideToSldIdElement :: PandocMonad m => Slide -> P m Element 1829slideToSldIdElement slide = do 1830 n <- slideNum slide 1831 let id' = tshow $ n + 255 1832 rId <- slideToRelId slide 1833 return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () 1834 1835presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element 1836presentationToSldIdLst (Presentation _ slides) = do 1837 ids <- mapM slideToSldIdElement slides 1838 return $ mknode "p:sldIdLst" [] ids 1839 1840presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element 1841presentationToPresentationElement pres@(Presentation _ slds) = do 1842 refArchive <- asks envRefArchive 1843 distArchive <- asks envDistArchive 1844 element <- parseXml refArchive distArchive "ppt/presentation.xml" 1845 sldIdLst <- presentationToSldIdLst pres 1846 1847 let modifySldIdLst :: Content -> Content 1848 modifySldIdLst (Elem e) = case elName e of 1849 (QName "sldIdLst" _ _) -> Elem sldIdLst 1850 _ -> Elem e 1851 modifySldIdLst ct = ct 1852 1853 notesMasterRId = length slds + 2 1854 1855 notesMasterElem = mknode "p:notesMasterIdLst" [] 1856 [ mknode 1857 "p:NotesMasterId" 1858 [("r:id", "rId" <> tshow notesMasterRId)] 1859 () 1860 ] 1861 1862 -- if there's a notesMasterIdLst in the presentation.xml file, 1863 -- we want to remove it. We then want to put our own, if 1864 -- necessary, after the slideMasterIdLst element. We also remove 1865 -- handouts master, since we don't want it. 1866 1867 removeUnwantedMaster' :: Content -> [Content] 1868 removeUnwantedMaster' (Elem e) = case elName e of 1869 (QName "notesMasterIdLst" _ _) -> [] 1870 (QName "handoutMasterIdLst" _ _) -> [] 1871 _ -> [Elem e] 1872 removeUnwantedMaster' ct = [ct] 1873 1874 removeUnwantedMaster :: [Content] -> [Content] 1875 removeUnwantedMaster = concatMap removeUnwantedMaster' 1876 1877 insertNotesMaster' :: Content -> [Content] 1878 insertNotesMaster' (Elem e) = case elName e of 1879 (QName "sldMasterIdLst" _ _) -> [Elem e, Elem notesMasterElem] 1880 _ -> [Elem e] 1881 insertNotesMaster' ct = [ct] 1882 1883 insertNotesMaster :: [Content] -> [Content] 1884 insertNotesMaster = if presHasSpeakerNotes pres 1885 then concatMap insertNotesMaster' 1886 else id 1887 1888 newContent = insertNotesMaster $ 1889 removeUnwantedMaster $ 1890 map modifySldIdLst $ 1891 elContent element 1892 1893 return $ element{elContent = newContent} 1894 1895presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry 1896presentationToPresEntry pres = presentationToPresentationElement pres >>= 1897 elemToEntry "ppt/presentation.xml" 1898 1899-- adapted from the Docx writer 1900docPropsElement :: PandocMonad m => DocProps -> P m Element 1901docPropsElement docProps = do 1902 utctime <- asks envUTCTime 1903 let keywords = case dcKeywords docProps of 1904 Just xs -> T.intercalate ", " xs 1905 Nothing -> "" 1906 return $ 1907 mknode "cp:coreProperties" 1908 [("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties") 1909 ,("xmlns:dc","http://purl.org/dc/elements/1.1/") 1910 ,("xmlns:dcterms","http://purl.org/dc/terms/") 1911 ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/") 1912 ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] 1913 $ 1914 mknode "dc:title" [] (fromMaybe "" $ dcTitle docProps) 1915 : 1916 mknode "dc:creator" [] (fromMaybe "" $ dcCreator docProps) 1917 : 1918 mknode "cp:keywords" [] keywords 1919 : ( [mknode "dc:subject" [] $ fromMaybe "" $ dcSubject docProps | isJust (dcSubject docProps)]) 1920 <> ( [mknode "dc:description" [] $ fromMaybe "" $ dcDescription docProps | isJust (dcDescription docProps)]) 1921 <> ( [mknode "cp:category" [] $ fromMaybe "" $ cpCategory docProps | isJust (cpCategory docProps)]) 1922 <> (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x 1923 , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x 1924 ]) (T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime) 1925 1926docPropsToEntry :: PandocMonad m => DocProps -> P m Entry 1927docPropsToEntry docProps = docPropsElement docProps >>= 1928 elemToEntry "docProps/core.xml" 1929 1930-- adapted from the Docx writer 1931docCustomPropsElement :: PandocMonad m => DocProps -> P m Element 1932docCustomPropsElement docProps = do 1933 let mkCustomProp (k, v) pid = mknode "property" 1934 [("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 1935 ,("pid", tshow pid) 1936 ,("name", k)] $ mknode "vt:lpwstr" [] v 1937 return $ mknode "Properties" 1938 [("xmlns","http://schemas.openxmlformats.org/officeDocument/2006/custom-properties") 1939 ,("xmlns:vt","http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes") 1940 ] $ zipWith mkCustomProp (fromMaybe [] $ customProperties docProps) [(2 :: Int)..] 1941 1942docCustomPropsToEntry :: PandocMonad m => DocProps -> P m Entry 1943docCustomPropsToEntry docProps = docCustomPropsElement docProps >>= 1944 elemToEntry "docProps/custom.xml" 1945 1946-- We read from the template, but we remove the lastView, so it always 1947-- opens on slide view. Templates will sometimes be open in master 1948-- view for editing. 1949viewPropsElement :: PandocMonad m => P m Element 1950viewPropsElement = do 1951 refArchive <- asks envRefArchive 1952 distArchive <- asks envDistArchive 1953 viewPrElement <- parseXml refArchive distArchive "ppt/viewProps.xml" 1954 -- remove "lastView" if it exists: 1955 let notLastView :: XML.Attr -> Bool 1956 notLastView attr = 1957 qName (attrKey attr) /= "lastView" 1958 return $ 1959 viewPrElement {elAttribs = filter notLastView (elAttribs viewPrElement)} 1960 1961makeViewPropsEntry :: PandocMonad m => P m Entry 1962makeViewPropsEntry = viewPropsElement >>= elemToEntry "ppt/viewProps.xml" 1963 1964defaultContentTypeToElem :: DefaultContentType -> Element 1965defaultContentTypeToElem dct = 1966 mknode "Default" 1967 [("Extension", defContentTypesExt dct), 1968 ("ContentType", defContentTypesType dct)] 1969 () 1970 1971overrideContentTypeToElem :: OverrideContentType -> Element 1972overrideContentTypeToElem oct = 1973 mknode "Override" 1974 [("PartName", T.pack $ overrideContentTypesPart oct), 1975 ("ContentType", overrideContentTypesType oct)] 1976 () 1977 1978contentTypesToElement :: ContentTypes -> Element 1979contentTypesToElement ct = 1980 let ns = "http://schemas.openxmlformats.org/package/2006/content-types" 1981 in 1982 mknode "Types" [("xmlns", ns)] $ 1983 1984 map defaultContentTypeToElem (contentTypesDefaults ct) <> 1985 map overrideContentTypeToElem (contentTypesOverrides ct) 1986 1987data DefaultContentType = DefaultContentType 1988 { defContentTypesExt :: T.Text 1989 , defContentTypesType:: MimeType 1990 } 1991 deriving (Show, Eq) 1992 1993data OverrideContentType = OverrideContentType 1994 { overrideContentTypesPart :: FilePath 1995 , overrideContentTypesType :: MimeType 1996 } 1997 deriving (Show, Eq) 1998 1999data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType] 2000 , contentTypesOverrides :: [OverrideContentType] 2001 } 2002 deriving (Show, Eq) 2003 2004contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry 2005contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct 2006 2007pathToOverride :: FilePath -> Maybe OverrideContentType 2008pathToOverride fp = OverrideContentType ("/" <> fp) <$> getContentType fp 2009 2010mediaFileContentType :: FilePath -> Maybe DefaultContentType 2011mediaFileContentType fp = case takeExtension fp of 2012 '.' : ext -> Just $ 2013 DefaultContentType { defContentTypesExt = T.pack ext 2014 , defContentTypesType = 2015 fromMaybe "application/octet-stream" (getMimeType fp) 2016 } 2017 _ -> Nothing 2018 2019mediaContentType :: MediaInfo -> Maybe DefaultContentType 2020mediaContentType mInfo 2021 | Just t <- mInfoExt mInfo 2022 , Just ('.', ext) <- T.uncons t = 2023 Just $ DefaultContentType { defContentTypesExt = ext 2024 , defContentTypesType = 2025 fromMaybe "application/octet-stream" (mInfoMimeType mInfo) 2026 } 2027 | otherwise = Nothing 2028 2029getSpeakerNotesFilePaths :: PandocMonad m => P m [FilePath] 2030getSpeakerNotesFilePaths = do 2031 mp <- asks envSpeakerNotesIdMap 2032 let notesIdNums = M.elems mp 2033 return $ map (\n -> "ppt/notesSlides/notesSlide" <> show n <> ".xml") 2034 notesIdNums 2035 2036presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes 2037presentationToContentTypes p@(Presentation _ slides) = do 2038 mediaInfos <- mconcat . M.elems <$> gets stMediaIds 2039 filePaths <- patternsToFilePaths $ inheritedPatterns p 2040 let mediaFps = filter (match (compile "ppt/media/image*")) filePaths 2041 let defaults = [ DefaultContentType "xml" "application/xml" 2042 , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" 2043 ] 2044 mediaDefaults = nub $ 2045 mapMaybe mediaContentType mediaInfos <> 2046 mapMaybe mediaFileContentType mediaFps 2047 2048 inheritedOverrides = mapMaybe pathToOverride filePaths 2049 createdOverrides = mapMaybe pathToOverride [ "docProps/core.xml" 2050 , "docProps/custom.xml" 2051 , "ppt/presentation.xml" 2052 , "ppt/viewProps.xml" 2053 ] 2054 relativePaths <- mapM slideToFilePath slides 2055 let slideOverrides = mapMaybe 2056 (\fp -> pathToOverride $ "ppt/slides/" <> fp) 2057 relativePaths 2058 speakerNotesOverrides <- mapMaybe pathToOverride <$> getSpeakerNotesFilePaths 2059 return $ ContentTypes 2060 (defaults <> mediaDefaults) 2061 (inheritedOverrides <> createdOverrides <> slideOverrides <> speakerNotesOverrides) 2062 2063presML :: T.Text 2064presML = "application/vnd.openxmlformats-officedocument.presentationml" 2065 2066noPresML :: T.Text 2067noPresML = "application/vnd.openxmlformats-officedocument" 2068 2069getContentType :: FilePath -> Maybe MimeType 2070getContentType fp 2071 | fp == "ppt/presentation.xml" = Just $ presML <> ".presentation.main+xml" 2072 | fp == "ppt/presProps.xml" = Just $ presML <> ".presProps+xml" 2073 | fp == "ppt/viewProps.xml" = Just $ presML <> ".viewProps+xml" 2074 | fp == "ppt/tableStyles.xml" = Just $ presML <> ".tableStyles+xml" 2075 | fp == "docProps/core.xml" = Just "application/vnd.openxmlformats-package.core-properties+xml" 2076 | fp == "docProps/custom.xml" = Just "application/vnd.openxmlformats-officedocument.custom-properties+xml" 2077 | fp == "docProps/app.xml" = Just $ noPresML <> ".extended-properties+xml" 2078 | ["ppt", "slideMasters", f] <- splitDirectories fp 2079 , (_, ".xml") <- splitExtension f = 2080 Just $ presML <> ".slideMaster+xml" 2081 | ["ppt", "slides", f] <- splitDirectories fp 2082 , (_, ".xml") <- splitExtension f = 2083 Just $ presML <> ".slide+xml" 2084 | ["ppt", "notesMasters", f] <- splitDirectories fp 2085 , (_, ".xml") <- splitExtension f = 2086 Just $ presML <> ".notesMaster+xml" 2087 | ["ppt", "notesSlides", f] <- splitDirectories fp 2088 , (_, ".xml") <- splitExtension f = 2089 Just $ presML <> ".notesSlide+xml" 2090 | ["ppt", "theme", f] <- splitDirectories fp 2091 , (_, ".xml") <- splitExtension f = 2092 Just $ noPresML <> ".theme+xml" 2093 | ["ppt", "slideLayouts", _] <- splitDirectories fp= 2094 Just $ presML <> ".slideLayout+xml" 2095 | otherwise = Nothing 2096 2097-- Kept as String for XML.Light 2098autoNumAttrs :: ListAttributes -> [(Text, Text)] 2099autoNumAttrs (startNum, numStyle, numDelim) = 2100 numAttr <> typeAttr 2101 where 2102 numAttr = [("startAt", tshow startNum) | startNum /= 1] 2103 typeAttr = [("type", typeString <> delimString)] 2104 typeString = case numStyle of 2105 Decimal -> "arabic" 2106 UpperAlpha -> "alphaUc" 2107 LowerAlpha -> "alphaLc" 2108 UpperRoman -> "romanUc" 2109 LowerRoman -> "romanLc" 2110 _ -> "arabic" 2111 delimString = case numDelim of 2112 Period -> "Period" 2113 OneParen -> "ParenR" 2114 TwoParens -> "ParenBoth" 2115 _ -> "Period" 2116