diff options
Diffstat (limited to 'src/Text/Pandoc')
| -rw-r--r-- | src/Text/Pandoc/Writers/Powerpoint.hs | 1665 |
1 files changed, 1665 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs new file mode 100644 index 000000000..f7d5bbc5f --- /dev/null +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -0,0 +1,1665 @@ +{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-} + +{- +Copyright (C) 2017 Jesse Rosenthal <jrosenthal@jhu.edu> + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Writers.Powerpoint + Copyright : Copyright (C) 2017 Jesse Rosenthal + License : GNU GPL, version 2 or above + + Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu> + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to powerpoint (pptx). +-} + +module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where + +import Control.Monad.Except (throwError) +import Control.Monad.Reader +import Control.Monad.State +import Codec.Archive.Zip +import Data.List (intercalate, stripPrefix, isPrefixOf, nub) +-- import Control.Monad (mplus) +import Data.Default +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) +import System.FilePath.Posix (splitDirectories, splitExtension) +import Text.XML.Light +import Text.Pandoc.Definition +import qualified Text.Pandoc.UTF8 as UTF8 +import Text.Pandoc.Class (PandocMonad) +import Text.Pandoc.Error (PandocError(..)) +import qualified Text.Pandoc.Class as P +import Text.Pandoc.Options +import Text.Pandoc.MIME +import Text.Pandoc.Logging +import qualified Data.ByteString.Lazy as BL +-- import qualified Data.ByteString.Lazy.Char8 as BL8 +-- import qualified Text.Pandoc.UTF8 as UTF8 +import Text.Pandoc.Walk +import Text.Pandoc.Writers.Shared (fixDisplayMath) +import Text.Pandoc.Writers.OOXML +import qualified Data.Map as M +import Data.Maybe (mapMaybe, listToMaybe) +import Text.Pandoc.ImageSize +import Control.Applicative ((<|>)) + +import Text.TeXMath +import Text.Pandoc.Writers.Math (convertMath) + + +writePowerpoint :: (PandocMonad m) + => WriterOptions -- ^ Writer options + -> Pandoc -- ^ Document to convert + -> m BL.ByteString +writePowerpoint opts (Pandoc meta blks) = do + let blks' = walk fixDisplayMath blks + distArchive <- (toArchive . BL.fromStrict) <$> + P.readDefaultDataFile "reference.pptx" + refArchive <- case writerReferenceDoc opts of + Just f -> toArchive <$> P.readFileLazy f + Nothing -> (toArchive . BL.fromStrict) <$> + P.readDataFile "reference.pptx" + + utctime <- P.getCurrentTime + + let env = def { envMetadata = meta + , envRefArchive = refArchive + , envDistArchive = distArchive + , envUTCTime = utctime + , envOpts = opts + } + runP env def $ do pres <- blocksToPresentation blks' + archv <- presentationToArchive pres + return $ fromArchive archv + +concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +data WriterEnv = WriterEnv { envMetadata :: Meta + , envRunProps :: RunProps + , envParaProps :: ParaProps + , envSlideLevel :: Int + , envRefArchive :: Archive + , envDistArchive :: Archive + , envUTCTime :: UTCTime + , envOpts :: WriterOptions + , envPresentationSize :: PresentationSize + , envSlideHasHeader :: Bool + , envInList :: Bool + } + deriving (Show) + +instance Default WriterEnv where + def = WriterEnv { envMetadata = mempty + , envRunProps = def + , envParaProps = def + , envSlideLevel = 2 + , envRefArchive = emptyArchive + , envDistArchive = emptyArchive + , envUTCTime = posixSecondsToUTCTime 0 + , envOpts = def + , envPresentationSize = def + , envSlideHasHeader = False + , envInList = False + } + +data MediaInfo = MediaInfo { mInfoFilePath :: FilePath + , mInfoLocalId :: Int + , mInfoGlobalId :: Int + , mInfoMimeType :: Maybe MimeType + , mInfoExt :: Maybe String + , mInfoCaption :: Bool + } deriving (Show, Eq) + +data WriterState = WriterState { stCurSlideId :: Int + -- the difference between the number at + -- the end of the slide file name and + -- the rId number + , stSlideIdOffset :: Int + , stLinkIds :: M.Map Int (M.Map Int (URL, String)) + -- (FP, Local ID, Global ID, Maybe Mime) + , stMediaIds :: M.Map Int [MediaInfo] + , stMediaGlobalIds :: M.Map FilePath Int + } deriving (Show, Eq) + +instance Default WriterState where + def = WriterState { stCurSlideId = 0 + , stSlideIdOffset = 1 + , stLinkIds = mempty + , stMediaIds = mempty + , stMediaGlobalIds = mempty + } + +type P m = ReaderT WriterEnv (StateT WriterState m) + +runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a +runP env st p = evalStateT (runReaderT p env) st + +type Pixels = Integer + +data Presentation = Presentation PresentationSize [Slide] + deriving (Show) + +data PresentationSize = PresentationSize { presSizeWidth :: Pixels + , presSizeRatio :: PresentationRatio + } + deriving (Show, Eq) + +data PresentationRatio = Ratio4x3 + | Ratio16x9 + | Ratio16x10 + deriving (Show, Eq) + +-- Note that right now we're only using Ratio4x3. +getPageHeight :: PresentationSize -> Pixels +getPageHeight sz = case presSizeRatio sz of + Ratio4x3 -> floor (((fromInteger (presSizeWidth sz)) / 4) * 3 :: Double) + Ratio16x9 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 9 :: Double) + Ratio16x10 -> floor (((fromInteger (presSizeWidth sz)) / 16) * 10 :: Double) + +instance Default PresentationSize where + def = PresentationSize 720 Ratio4x3 + +data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem] + , metadataSlideSubtitle :: [ParaElem] + , metadataSlideAuthors :: [[ParaElem]] + , metadataSlideDate :: [ParaElem] + } + | TitleSlide { titleSlideHeader :: [ParaElem]} + | ContentSlide { contentSlideHeader :: [ParaElem] + , contentSlideContent :: [Shape] + } + deriving (Show, Eq) + +data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape + deriving (Show, Eq) + +data Shape = Pic FilePath Text.Pandoc.Definition.Attr [ParaElem] + | GraphicFrame [Graphic] [ParaElem] + | TextBox [Paragraph] + deriving (Show, Eq) + +type Cell = [Paragraph] + +data TableProps = TableProps { tblPrFirstRow :: Bool + , tblPrBandRow :: Bool + } deriving (Show, Eq) + +type ColWidth = Integer + +data Graphic = Tbl TableProps [ColWidth] [Cell] [[Cell]] + deriving (Show, Eq) + + +data Paragraph = Paragraph { paraProps :: ParaProps + , paraElems :: [ParaElem] + } deriving (Show, Eq) + +data HeaderType = TitleHeader | SlideHeader | InternalHeader Int + deriving (Show, Eq) + +-- type StartingAt = Int + +-- data AutoNumType = ArabicNum +-- | AlphaUpperNum +-- | AlphaLowerNum +-- | RomanUpperNum +-- | RomanLowerNum +-- deriving (Show, Eq) + +-- data AutoNumDelim = PeriodDelim +-- | OneParenDelim +-- | TwoParensDelim +-- deriving (Show, Eq) + +autoNumberingToType :: ListAttributes -> String +autoNumberingToType (_, numStyle, numDelim) = + typeString ++ delimString + where + typeString = case numStyle of + Decimal -> "arabic" + UpperAlpha -> "alphaUc" + LowerAlpha -> "alphaLc" + UpperRoman -> "romanUc" + LowerRoman -> "romanLc" + _ -> "arabic" + delimString = case numDelim of + Period -> "Period" + OneParen -> "ParenR" + TwoParens -> "ParenBoth" + _ -> "Period" + +data BulletType = Bullet + | AutoNumbering ListAttributes + deriving (Show, Eq) + +data Algnment = AlgnLeft | AlgnRight | AlgnCenter + deriving (Show, Eq) + +data ParaProps = ParaProps { pPropHeaderType :: Maybe HeaderType + , pPropMarginLeft :: Maybe Pixels + , pPropMarginRight :: Maybe Pixels + , pPropLevel :: Int + , pPropBullet :: Maybe BulletType + , pPropAlign :: Maybe Algnment + } deriving (Show, Eq) + +instance Default ParaProps where + def = ParaProps { pPropHeaderType = Nothing + , pPropMarginLeft = Just 0 + , pPropMarginRight = Just 0 + , pPropLevel = 0 + , pPropBullet = Nothing + , pPropAlign = Nothing + } + +newtype TeXString = TeXString {unTeXString :: String} + deriving (Eq, Show) + +data ParaElem = Break + | Run RunProps String + -- It would be more elegant to have native TeXMath + -- Expressions here, but this allows us to use + -- `convertmath` from T.P.Writers.Math. Will perhaps + -- revisit in the future. + | MathElem MathType TeXString + deriving (Show, Eq) + +data Strikethrough = NoStrike | SingleStrike | DoubleStrike + deriving (Show, Eq) + +data Capitals = NoCapitals | SmallCapitals | AllCapitals + deriving (Show, Eq) + +type URL = String + +data RunProps = RunProps { rPropBold :: Bool + , rPropItalics :: Bool + , rStrikethrough :: Maybe Strikethrough + , rBaseline :: Maybe Int + , rCap :: Maybe Capitals + , rLink :: Maybe (URL, String) + , rPropCode :: Bool + , rPropBlockQuote :: Bool + } deriving (Show, Eq) + +instance Default RunProps where + def = RunProps { rPropBold = False + , rPropItalics = False + , rStrikethrough = Nothing + , rBaseline = Nothing + , rCap = Nothing + , rLink = Nothing + , rPropCode = False + , rPropBlockQuote = False + } + +-------------------------------------------------- + +inlinesToParElems :: Monad m => [Inline] -> P m [ParaElem] +inlinesToParElems ils = concatMapM inlineToParElems ils + +inlineToParElems :: Monad m => Inline -> P m [ParaElem] +inlineToParElems (Str s) = do + pr <- asks envRunProps + return [Run pr s] +inlineToParElems (Emph ils) = + local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $ + inlinesToParElems ils +inlineToParElems (Strong ils) = + local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $ + inlinesToParElems ils +inlineToParElems (Strikeout ils) = + local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $ + inlinesToParElems ils +inlineToParElems (Superscript ils) = + local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $ + inlinesToParElems ils +inlineToParElems (Subscript ils) = + local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $ + inlinesToParElems ils +inlineToParElems (SmallCaps ils) = + local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $ + inlinesToParElems ils +inlineToParElems Space = inlineToParElems (Str " ") +inlineToParElems SoftBreak = inlineToParElems (Str " ") +inlineToParElems LineBreak = return [Break] +inlineToParElems (Link _ ils (url, title)) = do + local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $ + inlinesToParElems ils +inlineToParElems (Code _ str) = do + local (\r ->r{envRunProps = def{rPropCode = True}}) $ + inlineToParElems $ Str str +inlineToParElems (Math mathtype str) = + return [MathElem mathtype (TeXString str)] +inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils +inlineToParElems (RawInline _ _) = return [] +inlineToParElems _ = return [] + +blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph] +blockToParagraphs (Plain ils) = do + parElems <- inlinesToParElems ils + pProps <- asks envParaProps + return [Paragraph pProps parElems] +blockToParagraphs (Para ils) = do + parElems <- inlinesToParElems ils + pProps <- asks envParaProps + return [Paragraph pProps parElems] +blockToParagraphs (LineBlock ilsList) = do + parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList + pProps <- asks envParaProps + return [Paragraph pProps parElems] +-- TODO: work out the attributes +blockToParagraphs (CodeBlock attr str) = + local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $ + blockToParagraphs $ Para [Code attr str] +-- TODO: work out the format +blockToParagraphs (BlockQuote blks) = + local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100} + , envRunProps = (envRunProps r){rPropBlockQuote = True}})$ + concatMapM blockToParagraphs blks +-- TODO: work out the format +blockToParagraphs (RawBlock _ _) = return [] + -- parElems <- inlinesToParElems [Str str] + -- paraProps <- asks envParaProps + -- return [Paragraph paraProps parElems] +-- TODO: work out the format +blockToParagraphs (Header n _ ils) = do + slideLevel <- asks envSlideLevel + parElems <- inlinesToParElems ils + -- For the time being we're not doing headers inside of bullets, but + -- we might change that. + let headerType = case n `compare` slideLevel of + LT -> TitleHeader + EQ -> SlideHeader + GT -> InternalHeader (n - slideLevel) + return [Paragraph def{pPropHeaderType = Just headerType} parElems] +blockToParagraphs (BulletList blksLst) = do + pProps <- asks envParaProps + let lvl = pPropLevel pProps + local (\env -> env{ envInList = True + , envParaProps = pProps{ pPropLevel = lvl + 1 + , pPropBullet = Just Bullet + , pPropMarginLeft = Nothing + }}) $ + concatMapM multiParBullet blksLst +blockToParagraphs (OrderedList listAttr blksLst) = do + pProps <- asks envParaProps + let lvl = pPropLevel pProps + local (\env -> env{ envInList = True + , envParaProps = pProps{ pPropLevel = lvl + 1 + , pPropBullet = Just (AutoNumbering listAttr) + , pPropMarginLeft = Nothing + }}) $ + concatMapM multiParBullet blksLst +blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks +-- TODO +blockToParagraphs blk = do + P.report $ BlockNotRendered blk + return [] + +-- Make sure the bullet env gets turned off after the first para. +multiParBullet :: PandocMonad m => [Block] -> P m [Paragraph] +multiParBullet [] = return [] +multiParBullet (b:bs) = do + pProps <- asks envParaProps + p <- blockToParagraphs b + ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $ + concatMapM blockToParagraphs bs + return $ p ++ ps + +cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> P m [Paragraph] +cellToParagraphs algn tblCell = do + paras <- mapM (blockToParagraphs) tblCell + let alignment = case algn of + AlignLeft -> Just AlgnLeft + AlignRight -> Just AlgnRight + AlignCenter -> Just AlgnCenter + AlignDefault -> Nothing + paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras + return $ concat paras' + +rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> P m [[Paragraph]] +rowToParagraphs algns tblCells = do + -- We have to make sure we have the right number of alignments + let pairs = zip (algns ++ repeat AlignDefault) tblCells + mapM (\(a, tc) -> cellToParagraphs a tc) pairs + +blockToShape :: PandocMonad m => Block -> P m Shape +blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il = + Pic url attr <$> (inlinesToParElems ils) +blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = + Pic url attr <$> (inlinesToParElems ils) +blockToShape (Table caption algn _ hdrCells rows) = do + caption' <- inlinesToParElems caption + pageWidth <- presSizeWidth <$> asks envPresentationSize + hdrCells' <- rowToParagraphs algn hdrCells + rows' <- mapM (rowToParagraphs algn) rows + let tblPr = if null hdrCells + then TableProps { tblPrFirstRow = False + , tblPrBandRow = True + } + else TableProps { tblPrFirstRow = True + , tblPrBandRow = True + } + colWidths = if null hdrCells + then case rows of + r : _ | not (null r) -> replicate (length r) $ + (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length r) + -- satisfy the compiler. This is the same as + -- saying that rows is empty, but the compiler + -- won't understand that `[]` exhausts the + -- alternatives. + _ -> [] + else replicate (length hdrCells) $ + (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells) + + return $ GraphicFrame [Tbl tblPr colWidths hdrCells' rows'] caption' +blockToShape blk = TextBox <$> blockToParagraphs blk + +blocksToShapes :: PandocMonad m => [Block] -> P m [Shape] +blocksToShapes blks = combineShapes <$> mapM blockToShape blks + +splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> P m [[Block]] +splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur]) +splitBlocks' cur acc (HorizontalRule : blks) = + splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks +splitBlocks' cur acc (h@(Header n _ _) : blks) = do + slideLevel <- asks envSlideLevel + case compare n slideLevel of + LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks + EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks + GT -> splitBlocks' (cur ++ [h]) acc blks +splitBlocks' cur acc ((Para (img@(Image _ _ _):ils)) : blks) = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] + (acc ++ [cur ++ [Para [img]]]) + (if null ils then blks else (Para ils) : blks) + _ -> splitBlocks' [] + (acc ++ (if null cur then [] else [cur]) ++ [[Para [img]]]) + (if null ils then blks else (Para ils) : blks) +splitBlocks' cur acc ((Plain (img@(Image _ _ _):ils)) : blks) = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] + (acc ++ [cur ++ [Para [img]]]) + (if null ils then blks else (Plain ils) : blks) + _ -> splitBlocks' [] + (acc ++ (if null cur then [] else [cur]) ++ [[Para [img]]]) + (if null ils then blks else (Plain ils) : blks) +splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do + slideLevel <- asks envSlideLevel + case cur of + (Header n _ _) : [] | n == slideLevel -> + splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks + _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks +splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks + +splitBlocks :: Monad m => [Block] -> P m [[Block]] +splitBlocks = splitBlocks' [] [] + +blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide +blocksToSlide' lvl ((Header n _ ils) : blks) + | n < lvl = do + hdr <- inlinesToParElems ils + return $ TitleSlide {titleSlideHeader = hdr} + | n == lvl = do + hdr <- inlinesToParElems ils + shapes <- blocksToShapes blks + return $ ContentSlide { contentSlideHeader = hdr + , contentSlideContent = shapes + } +blocksToSlide' _ (blk : blks) = do + shapes <- blocksToShapes (blk : blks) + return $ ContentSlide { contentSlideHeader = [] + , contentSlideContent = shapes + } +blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = [] + , contentSlideContent = [] + } + +blocksToSlide :: PandocMonad m => [Block] -> P m Slide +blocksToSlide blks = do + slideLevel <- asks envSlideLevel + blocksToSlide' slideLevel blks + +getMetaSlide :: PandocMonad m => P m (Maybe Slide) +getMetaSlide = do + meta <- asks envMetadata + title <- inlinesToParElems $ docTitle meta + subtitle <- inlinesToParElems $ + case lookupMeta "subtitle" meta of + Just (MetaString s) -> [Str s] + Just (MetaInlines ils) -> ils + Just (MetaBlocks [Plain ils]) -> ils + Just (MetaBlocks [Para ils]) -> ils + _ -> [] + authors <- mapM inlinesToParElems $ docAuthors meta + date <- inlinesToParElems $ docDate meta + if null title && null subtitle && null authors && null date + then return Nothing + else return $ Just $ MetadataSlide { metadataSlideTitle = title + , metadataSlideSubtitle = subtitle + , metadataSlideAuthors = authors + , metadataSlideDate = date + } + +blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation +blocksToPresentation blks = do + blksLst <- splitBlocks blks + slides <- mapM blocksToSlide blksLst + metadataslide <- getMetaSlide + presSize <- asks envPresentationSize + return $ case metadataslide of + Just metadataslide' -> Presentation presSize $ metadataslide' : slides + Nothing -> Presentation presSize slides + +-------------------------------------------------------------------- + +copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive +copyFileToArchive arch fp = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of + Nothing -> fail $ fp ++ " missing in reference file" + Just e -> return $ addEntryToArchive e arch + +getMediaFiles :: PandocMonad m => P m [FilePath] +getMediaFiles = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive + return $ filter (isPrefixOf "ppt/media") allEntries + + +copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive +copyFileToArchiveIfExists arch fp = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of + Nothing -> return $ arch + Just e -> return $ addEntryToArchive e arch + +inheritedFiles :: [FilePath] +inheritedFiles = [ "_rels/.rels" + , "docProps/app.xml" + , "docProps/core.xml" + , "ppt/slideLayouts/slideLayout4.xml" + , "ppt/slideLayouts/_rels/slideLayout9.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout2.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout10.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout3.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout5.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout7.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout8.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout11.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout4.xml.rels" + , "ppt/slideLayouts/_rels/slideLayout6.xml.rels" + , "ppt/slideLayouts/slideLayout2.xml" + , "ppt/slideLayouts/slideLayout8.xml" + , "ppt/slideLayouts/slideLayout11.xml" + , "ppt/slideLayouts/slideLayout3.xml" + , "ppt/slideLayouts/slideLayout6.xml" + , "ppt/slideLayouts/slideLayout9.xml" + , "ppt/slideLayouts/slideLayout5.xml" + , "ppt/slideLayouts/slideLayout7.xml" + , "ppt/slideLayouts/slideLayout1.xml" + , "ppt/slideLayouts/slideLayout10.xml" + -- , "ppt/_rels/presentation.xml.rels" + , "ppt/theme/theme1.xml" + , "ppt/presProps.xml" + -- , "ppt/slides/_rels/slide1.xml.rels" + -- , "ppt/slides/_rels/slide2.xml.rels" + -- This is the one we're + -- going to build + -- , "ppt/slides/slide2.xml" + -- , "ppt/slides/slide1.xml" + , "ppt/viewProps.xml" + , "ppt/tableStyles.xml" + , "ppt/slideMasters/_rels/slideMaster1.xml.rels" + , "ppt/slideMasters/slideMaster1.xml" + -- , "ppt/presentation.xml" + -- , "[Content_Types].xml" + ] + +-- Here are some that might not be there. We won't fail if they're not +possibleInheritedFiles :: [FilePath] +possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ] + +presentationToArchive :: PandocMonad m => Presentation -> P m Archive +presentationToArchive p@(Presentation _ slides) = do + newArch <- foldM copyFileToArchive emptyArchive inheritedFiles + mediaDir <- getMediaFiles + newArch' <- foldM copyFileToArchiveIfExists newArch $ + possibleInheritedFiles ++ mediaDir + -- presentation entry and rels. We have to do the rels first to make + -- sure we know the correct offset for the rIds. + presEntry <- presentationToPresEntry p + presRelsEntry <- presentationToRelsEntry p + slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..] + slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..] + -- These have to come after everything, because they need the info + -- built up in the state. + mediaEntries <- makeMediaEntries + contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry + -- fold everything into our inherited archive and return it. + return $ foldr addEntryToArchive newArch' $ + slideEntries ++ + slideRelEntries ++ + mediaEntries ++ + [contentTypesEntry, presEntry, presRelsEntry] + +-------------------------------------------------- + +combineShapes :: [Shape] -> [Shape] +combineShapes [] = [] +combineShapes (s : []) = [s] +combineShapes (pic@(Pic _ _ _) : ss) = pic : combineShapes ss +combineShapes ((TextBox []) : ss) = combineShapes ss +combineShapes (s : TextBox [] : ss) = combineShapes (s : ss) +combineShapes (s@(TextBox (p:ps)) : s'@(TextBox (p':ps')) : ss) + | pPropHeaderType (paraProps p) == Just TitleHeader || + pPropHeaderType (paraProps p) == Just SlideHeader = + TextBox [p] : (combineShapes $ TextBox ps : s' : ss) + | pPropHeaderType (paraProps p') == Just TitleHeader || + pPropHeaderType (paraProps p') == Just SlideHeader = + s : TextBox [p'] : (combineShapes $ TextBox ps' : ss) + | otherwise = combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss +combineShapes (s:ss) = s : combineShapes ss + +-------------------------------------------------- + +getLayout :: PandocMonad m => Slide -> P m Element +getLayout slide = do + let layoutpath = case slide of + (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml" + (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml" + (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml" + distArchive <- asks envDistArchive + root <- case findEntryByPath layoutpath distArchive of + Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of + Just element -> return $ element + Nothing -> throwError $ + PandocSomeError $ + layoutpath ++ " corrupt in reference file" + Nothing -> throwError $ + PandocSomeError $ + layoutpath ++ " missing in reference file" + return root + -- let ns = elemToNameSpaces root + -- case findChild (elemName ns "p" "cSld") root of + -- Just element' -> return element' + -- Nothing -> throwError $ + -- PandocSomeError $ + -- layoutpath ++ " not correctly formed layout file" + +shapeHasName :: NameSpaces -> String -> Element -> Bool +shapeHasName ns name element + | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element + , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr + , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr = + nm == name + | otherwise = False + +-- getContentTitleShape :: NameSpaces -> Element -> Maybe Element +-- getContentTitleShape ns spTreeElem +-- | isElem ns "p" "spTree" spTreeElem = +-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Title 1" e)) spTreeElem +-- | otherwise = Nothing + +-- getSubtitleShape :: NameSpaces -> Element -> Maybe Element +-- getSubtitleShape ns spTreeElem +-- | isElem ns "p" "spTree" spTreeElem = +-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Subtitle 2" e)) spTreeElem +-- | otherwise = Nothing + +-- getDateShape :: NameSpaces -> Element -> Maybe Element +-- getDateShape ns spTreeElem +-- | isElem ns "p" "spTree" spTreeElem = +-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Date Placeholder 3" e)) spTreeElem +-- | otherwise = Nothing + +getContentShape :: NameSpaces -> Element -> Maybe Element +getContentShape ns spTreeElem + | isElem ns "p" "spTree" spTreeElem = + filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns "Content Placeholder 2" e)) spTreeElem + | otherwise = Nothing + + +-- cursorHasName :: QName -> XMLC.Cursor -> Bool +-- cursorHasName nm cur = case XMLC.current cur of +-- Elem element -> case XMLC.tagName $ XMLC.getTag element of +-- nm -> True +-- _ -> False +-- _ -> False + +-- fillInTxBody :: NameSpaces -> [Paragraph] -> Element -> Element +-- fillInTxBody ns paras txBodyElem +-- | isElem ns "p" "txBody" txBodyElem = +-- replaceNamedChildren ns "a" "p" (map paragraphToElement paras) txBodyElem +-- | otherwise = txBodyElem + +-- fillInShape :: NameSpaces -> Shape -> Element -> Element +-- fillInShape ns shape spElem +-- | TextBox paras <- shape +-- , isElemn ns "p" "sp" spElem = +-- replaceNamedChildren ns "p" "txBody" (fillInTxBody ns paras sp + + +-- fillInShape :: NameSpaces -> Element -> Shape -> Element +-- fillInShape ns spElem (TextBox paras) = fillInParagraphs ns spElem paras +-- fillInShape _ spElem pic = spElem + +contentIsElem :: NameSpaces -> String -> String -> Content -> Bool +contentIsElem ns prefix name (Elem element) = isElem ns prefix name element +contentIsElem _ _ _ _ = False + +replaceNamedChildren :: NameSpaces -> String -> String -> [Element] -> Element -> Element +replaceNamedChildren ns prefix name newKids element = + let content = elContent element + content' = filter (\c -> not (contentIsElem ns prefix name c)) content + in + element{elContent = content' ++ map Elem newKids} + + +---------------------------------------------------------------- + +registerLink :: PandocMonad m => (URL, String) -> P m Int +registerLink link = do + curSlideId <- gets stCurSlideId + linkReg <- gets stLinkIds + mediaReg <- gets stMediaIds + let maxLinkId = case M.lookup curSlideId linkReg of + Just mp -> case M.keys mp of + [] -> 1 + ks -> maximum ks + Nothing -> 1 + maxMediaId = case M.lookup curSlideId mediaReg of + Just [] -> 1 + Just mInfos -> maximum $ map mInfoLocalId mInfos + Nothing -> 1 + maxId = max maxLinkId maxMediaId + slideLinks = case M.lookup curSlideId linkReg of + Just mp -> M.insert (maxId + 1) link mp + Nothing -> M.singleton (maxId + 1) link + modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg} + return $ maxId + 1 + +registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo +registerMedia fp caption = do + curSlideId <- gets stCurSlideId + linkReg <- gets stLinkIds + mediaReg <- gets stMediaIds + globalIds <- gets stMediaGlobalIds + let maxLinkId = case M.lookup curSlideId linkReg of + Just mp -> case M.keys mp of + [] -> 1 + ks -> maximum ks + Nothing -> 1 + maxMediaId = case M.lookup curSlideId mediaReg of + Just [] -> 1 + Just mInfos -> maximum $ map mInfoLocalId mInfos + Nothing -> 1 + maxLocalId = max maxLinkId maxMediaId + + maxGlobalId = case M.elems globalIds of + [] -> 0 + ids -> maximum ids + + (imgBytes, mbMt) <- P.fetchItem fp + let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x)) + <|> + case imageType imgBytes of + Just Png -> Just ".png" + Just Jpeg -> Just ".jpeg" + Just Gif -> Just ".gif" + Just Pdf -> Just ".pdf" + Just Eps -> Just ".eps" + Just Svg -> Just ".svg" + Nothing -> Nothing + + let newGlobalId = case M.lookup fp globalIds of + Just ident -> ident + Nothing -> maxGlobalId + 1 + + let newGlobalIds = M.insert fp newGlobalId globalIds + + let mediaInfo = MediaInfo { mInfoFilePath = fp + , mInfoLocalId = maxLocalId + 1 + , mInfoGlobalId = newGlobalId + , mInfoMimeType = mbMt + , mInfoExt = imgExt + , mInfoCaption = (not . null) caption + } + + let slideMediaInfos = case M.lookup curSlideId mediaReg of + Just minfos -> mediaInfo : minfos + Nothing -> [mediaInfo] + + + modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg + , stMediaGlobalIds = newGlobalIds + } + return mediaInfo + +makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry +makeMediaEntry mInfo = do + epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime + (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) + let ext = case mInfoExt mInfo of + Just e -> e + Nothing -> "" + let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext + return $ toEntry fp epochtime $ BL.fromStrict imgBytes + +makeMediaEntries :: PandocMonad m => P m [Entry] +makeMediaEntries = do + mediaInfos <- gets stMediaIds + let allInfos = mconcat $ M.elems mediaInfos + mapM makeMediaEntry allInfos + +-- | Scales the image to fit the page +-- sizes are passed in emu +fitToPage' :: (Double, Double) -- image size in emu + -> Integer -- pageWidth + -> Integer -- pageHeight + -> (Integer, Integer) -- imagesize +fitToPage' (x, y) pageWidth pageHeight + -- Fixes width to the page width and scales the height + | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight = + (floor x, floor y) + | x / fromIntegral pageWidth > y / fromIntegral pageWidth = + (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y) + | otherwise = + (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight) + +positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer) +positionImage (x, y) pageWidth pageHeight = + let (x', y') = fitToPage' (x, y) pageWidth pageHeight + in + ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2) + +getMaster :: PandocMonad m => P m Element +getMaster = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml" + +-- We want to get the header dimensions, so we can make sure that the +-- image goes underneath it. We only use this in a content slide if it +-- has a header. + +getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer)) +getHeaderSize = do + master <- getMaster + let ns = elemToNameSpaces master + sps = [master] >>= + findChildren (elemName ns "p" "cSld") >>= + findChildren (elemName ns "p" "spTree") >>= + findChildren (elemName ns "p" "sp") + mbXfrm = + listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>= + findChild (elemName ns "p" "spPr") >>= + findChild (elemName ns "a" "xfrm") + xoff = mbXfrm >>= + findChild (elemName ns "a" "off") >>= + findAttr (QName "x" Nothing Nothing) >>= + (listToMaybe . (\s -> reads s :: [(Integer, String)])) + yoff = mbXfrm >>= + findChild (elemName ns "a" "off") >>= + findAttr (QName "y" Nothing Nothing) >>= + (listToMaybe . (\s -> reads s :: [(Integer, String)])) + xext = mbXfrm >>= + findChild (elemName ns "a" "ext") >>= + findAttr (QName "cx" Nothing Nothing) >>= + (listToMaybe . (\s -> reads s :: [(Integer, String)])) + yext = mbXfrm >>= + findChild (elemName ns "a" "ext") >>= + findAttr (QName "cy" Nothing Nothing) >>= + (listToMaybe . (\s -> reads s :: [(Integer, String)])) + off = case xoff of + Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff') + _ -> (1043490, 1027664) + ext = case xext of + Just (xext', _) | Just (yext',_) <- yext -> (xext', yext') + _ -> (7024744, 1143000) + return $ (off, ext) + + +-- Hard-coded for now +captionPosition :: ((Integer, Integer), (Integer, Integer)) +captionPosition = ((457200, 6061972), (8229600, 527087)) + +createCaption :: PandocMonad m => [ParaElem] -> P m Element +createCaption paraElements = do + let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements + elements <- mapM paragraphToElement [para] + let ((x, y), (cx, cy)) = captionPosition + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + return $ + mknode "p:sp" [] [ mknode "p:nvSpPr" [] + [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] () + , mknode "p:cNvSpPr" [("txBox", "1")] () + , mknode "p:nvPr" [] () + ] + , mknode "p:spPr" [] + [ mknode "a:xfrm" [] + [ mknode "a:off" [("x", show x), ("y", show y)] () + , mknode "a:ext" [("cx", show cx), ("cy", show cy)] () + ] + , mknode "a:prstGeom" [("prst", "rect")] + [ mknode "a:avLst" [] () + ] + , mknode "a:noFill" [] () + ] + , txBody + ] + +-- Largely lifted from inlineToOpenXML' in T.P.W.Docx. Can't be easily +-- abstracted because of some different namespaces and monads. TODO. +makePicElement :: PandocMonad m + => MediaInfo + -> Text.Pandoc.Definition.Attr + -> P m Element +makePicElement mInfo attr = do + opts <- asks envOpts + pageWidth <- presSizeWidth <$> asks envPresentationSize + pageHeight <- getPageHeight <$> asks envPresentationSize + hasHeader <- asks envSlideHasHeader + let hasCaption = mInfoCaption mInfo + (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) + -- We're not using x exts + ((hXoff, hYoff), (_, hYext)) <- if hasHeader + then getHeaderSize + else return ((0, 0), (0, 0)) + + let ((capX, capY), (_, _)) = if hasCaption + then captionPosition + else ((0,0), (0,0)) + let (xpt,ypt) = desiredSizeInPoints opts attr + (either (const def) id (imageSize opts imgBytes)) + -- 12700 emu = 1 pt + let (xemu,yemu) = fitToPage' (xpt * 12700, ypt * 12700) + ((pageWidth * 12700) - (2 * hXoff) - (2 * capX)) + ((if hasCaption then capY else (pageHeight * 12700)) - (hYoff + hYext)) + (xoff, yoff) = positionImage (xpt * 12700, ypt * 12700) (pageWidth * 12700) (pageHeight * 12700) + xoff' = if hasHeader then xoff + hXoff else xoff + xoff'' = if hasCaption then xoff' + capX else xoff' + yoff' = if hasHeader then hYoff + hYext else yoff + -- let (xemu,yemu)=((floor $ xpt * 12700), (floor $ ypt * 12700)) + let cNvPicPr = mknode "p:cNvPicPr" [] $ + mknode "a:picLocks" [("noGrp","1") + ,("noChangeAspect","1")] () + let nvPicPr = mknode "p:nvPicPr" [] + [ mknode "p:cNvPr" + [("descr", mInfoFilePath mInfo),("id","0"),("name","Picture 1")] () + , cNvPicPr + , mknode "p:nvPr" [] ()] + let blipFill = mknode "p:blipFill" [] + [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] () + , mknode "a:stretch" [] $ + mknode "a:fillRect" [] () ] + let xfrm = mknode "a:xfrm" [] + [ mknode "a:off" [("x",show xoff''), ("y",show yoff')] () + , mknode "a:ext" [("cx",show xemu) + ,("cy",show yemu)] () ] + let prstGeom = mknode "a:prstGeom" [("prst","rect")] $ + mknode "a:avLst" [] () + let ln = mknode "a:ln" [("w","9525")] + [ mknode "a:noFill" [] () + , mknode "a:headEnd" [] () + , mknode "a:tailEnd" [] () ] + let spPr = mknode "p:spPr" [("bwMode","auto")] + [xfrm, prstGeom, mknode "a:noFill" [] (), ln] + return $ + mknode "p:pic" [] + [ nvPicPr + , blipFill + , spPr ] + +-- Currently hardcoded, until I figure out how to make it dynamic. +blockQuoteSize :: Pixels +blockQuoteSize = 20 + +paraElemToElement :: PandocMonad m => ParaElem -> P m Element +paraElemToElement Break = return $ mknode "a:br" [] () +paraElemToElement (Run rpr s) = do + let attrs = + if rPropCode rpr + then [] + else (if rPropBlockQuote rpr then [("sz", (show $ blockQuoteSize * 100))] else []) ++ + (if rPropBold rpr then [("b", "1")] else []) ++ + (if rPropItalics rpr then [("i", "1")] else []) ++ + (case rStrikethrough rpr of + Just NoStrike -> [("strike", "noStrike")] + Just SingleStrike -> [("strike", "sngStrike")] + Just DoubleStrike -> [("strike", "dblStrike")] + Nothing -> []) ++ + (case rBaseline rpr of + Just n -> [("baseline", show n)] + Nothing -> []) ++ + (case rCap rpr of + Just NoCapitals -> [("cap", "none")] + Just SmallCapitals -> [("cap", "small")] + Just AllCapitals -> [("cap", "all")] + Nothing -> []) ++ + [] + linkProps <- case rLink rpr of + Just link -> do idNum <- registerLink link + return [mknode "a:hlinkClick" + [("r:id", "rId" ++ show idNum)] + () + ] + Nothing -> return [] + let propContents = if rPropCode rpr + then [mknode "a:latin" [("typeface", "Courier")] ()] + else linkProps + return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents + , mknode "a:t" [] s + ] +paraElemToElement (MathElem mathType texStr) = do + res <- convertMath writeOMML mathType (unTeXString texStr) + case res of + Right r -> return $ mknode "a14:m" [] $ addMathInfo r + Left (Str s) -> paraElemToElement (Run def s) + Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback" + +-- This is a bit of a kludge -- really requires adding an option to +-- TeXMath, but since that's a different package, we'll do this one +-- step at a time. +addMathInfo :: Element -> Element +addMathInfo element = + let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns")) + , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math" + } + in add_attr mathspace element + +-- We look through the element to see if it contains an a14:m +-- element. If so, we surround it. This is a bit ugly, but it seems +-- more dependable than looking through shapes for math. Plus this is +-- an xml implementation detail, so it seems to make sense to do it at +-- the xml level. +surroundWithMathAlternate :: Element -> Element +surroundWithMathAlternate element = + case findElement (QName "m" Nothing (Just "a14")) element of + Just _ -> + mknode "mc:AlternateContent" + [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006") + ] [ mknode "mc:Choice" + [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main") + , ("Requires", "a14")] [ element ] + ] + Nothing -> element + +paragraphToElement :: PandocMonad m => Paragraph -> P m Element +paragraphToElement par = do + let + attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++ + (case pPropMarginLeft (paraProps par) of + Just px -> [("marL", show $ 12700 * px), ("indent", "0")] + Nothing -> [] + ) ++ + (case pPropAlign (paraProps par) of + Just AlgnLeft -> [("algn", "l")] + Just AlgnRight -> [("algn", "r")] + Just AlgnCenter -> [("algn", "ctr")] + Nothing -> [] + ) + props = [] ++ + (case pPropBullet $ paraProps par of + Just Bullet -> [] + Just (AutoNumbering attrs') -> + [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()] + Nothing -> [mknode "a:buNone" [] ()] + ) + paras <- mapM paraElemToElement (paraElems par) + return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras + +shapeToElement :: PandocMonad m => Element -> Shape -> P m Element +shapeToElement layout (TextBox paras) + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld + , Just sp <- getContentShape ns spTree = do + elements <- mapM paragraphToElement paras + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + emptySpPr = mknode "p:spPr" [] () + return $ + surroundWithMathAlternate $ + replaceNamedChildren ns "p" "txBody" [txBody] $ + replaceNamedChildren ns "p" "spPr" [emptySpPr] $ + sp + -- XXX: TODO + | otherwise = return $ mknode "p:sp" [] () +-- XXX: TODO +shapeToElement layout (Pic fp attr alt) = do + mInfo <- registerMedia fp alt + case mInfoExt mInfo of + Just _ -> makePicElement mInfo attr + Nothing -> shapeToElement layout $ TextBox [Paragraph def alt] +shapeToElement _ (GraphicFrame tbls _) = do + elements <- mapM graphicToElement tbls + return $ mknode "p:graphicFrame" [] $ + [ mknode "p:nvGraphicFramePr" [] $ + [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] () + , mknode "p:cNvGraphicFramePr" [] $ + [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()] + , mknode "p:nvPr" [] $ + [mknode "p:ph" [("idx", "1")] ()] + ] + , mknode "p:xfrm" [] $ + [ mknode "a:off" [("x", "457200"), ("y", "1600200")] () + , mknode "a:ext" [("cx", "8029388"), ("cy", "3644152")] () + ] + ] ++ elements + +shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element] +shapeToElements layout shp = do + case shp of + (Pic _ _ alt) | (not . null) alt -> do + element <- shapeToElement layout shp + caption <- createCaption alt + return [element, caption] + (GraphicFrame _ cptn) | (not . null) cptn -> do + element <- shapeToElement layout shp + caption <- createCaption cptn + return [element, caption] + _ -> do + element <- shapeToElement layout shp + return [element] + +shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element] +shapesToElements layout shps = do + concat <$> mapM (shapeToElements layout) shps + +hardcodedTableMargin :: Integer +hardcodedTableMargin = 36 + + +graphicToElement :: PandocMonad m => Graphic -> P m Element +graphicToElement (Tbl tblPr colWidths hdrCells rows) = do + let cellToOpenXML paras = do elements <- mapM paragraphToElement paras + return $ + [mknode "a:txBody" [] $ + ([ mknode "a:bodyPr" [] () + , mknode "a:lstStyle" [] ()] + ++ elements)] + headers' <- mapM cellToOpenXML hdrCells + rows' <- mapM (mapM cellToOpenXML) rows + let borderProps = mknode "a:tcPr" [] () + let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]] + let mkcell border contents = mknode "a:tc" [] + $ (if null contents + then emptyCell + else contents) ++ [ borderProps | border ] + let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells + -- let textwidth = 14400 -- 5.5 in in twips, 1/20 pt + -- let fullrow = 14400 -- 100% specified in pct + -- let rowwidth = fullrow * sum colWidths + + let mkgridcol w = mknode "a:gridCol" + [("w", show ((12700 * w) :: Integer))] () + let hasHeader = not (all null hdrCells) + return $ mknode "a:graphic" [] $ + [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ + [mknode "a:tbl" [] $ + [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0") + , ("bandRow", if tblPrBandRow tblPr then "1" else "0") + ] () + , mknode "a:tblGrid" [] (if all (==0) colWidths + then [] + else map mkgridcol colWidths) + ] + ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows' + ] + ] + +getShapeByName :: NameSpaces -> Element -> String -> Maybe Element +getShapeByName ns spTreeElem name + | isElem ns "p" "spTree" spTreeElem = + filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem + | otherwise = Nothing + +nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element +nonBodyTextToElement layout shapeName paraElements + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld + , Just sp <- getShapeByName ns spTree shapeName = do + let hdrPara = Paragraph def paraElements + element <- paragraphToElement hdrPara + let txBody = mknode "p:txBody" [] $ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ + [element] + return $ replaceNamedChildren ns "p" "txBody" [txBody] sp + -- XXX: TODO + | otherwise = return $ mknode "p:sp" [] () + + +-- hdrToElement :: Element -> [ParaElem] -> Element +-- hdrToElement layout paraElems +-- | ns <- elemToNameSpaces layout +-- , Just cSld <- findChild (elemName ns "p" "cSld") layout +-- , Just spTree <- findChild (elemName ns "p" "spTree") cSld +-- , Just sp <- getContentTitleShape ns spTree = +-- let hdrPara = Paragraph def paraElems +-- txBody = mknode "p:txBody" [] $ +-- [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ +-- [paragraphToElement hdrPara] +-- in +-- replaceNamedChildren ns "p" "txBody" [txBody] sp +-- -- XXX: TODO +-- | otherwise = mknode "p:sp" [] () +-- -- XXX: TODO +-- hdrToElement _ _ = mknode "p:sp" [] () + +contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element +contentToElement layout hdrShape shapes + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" hdrShape + let hdrShapeElements = if null hdrShape + then [] + else [element] + contentElements <- shapesToElements layout shapes + return $ + replaceNamedChildren ns "p" "sp" + (hdrShapeElements ++ contentElements) + spTree +contentToElement _ _ _ = return $ mknode "p:sp" [] () + +titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element +titleToElement layout titleElems + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + element <- nonBodyTextToElement layout "Title 1" titleElems + let titleShapeElements = if null titleElems + then [] + else [element] + return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree +titleToElement _ _ = return $ mknode "p:sp" [] () + +metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element +metadataToElement layout titleElems subtitleElems authorsElems dateElems + | ns <- elemToNameSpaces layout + , Just cSld <- findChild (elemName ns "p" "cSld") layout + , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do + titleShapeElements <- if null titleElems + then return [] + else sequence [nonBodyTextToElement layout "Title 1" titleElems] + let combinedAuthorElems = intercalate [Break] authorsElems + subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems] + subtitleShapeElements <- if null subtitleAndAuthorElems + then return [] + else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems] + dateShapeElements <- if null dateElems + then return [] + else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems] + return $ replaceNamedChildren ns "p" "sp" + (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) + spTree +metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () + +slideToElement :: PandocMonad m => Slide -> P m Element +slideToElement s@(ContentSlide hdrElems shapes) = do + layout <- getLayout s + spTree <- local (\env -> if null hdrElems + then env + else env{envSlideHasHeader=True}) $ + contentToElement layout hdrElems shapes + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] +slideToElement s@(TitleSlide hdrElems) = do + layout <- getLayout s + spTree <- titleToElement layout hdrElems + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] +slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do + layout <- getLayout s + spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems + return $ mknode "p:sld" + [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"), + ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"), + ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main") + ] [mknode "p:cSld" [] [spTree]] + +----------------------------------------------------------------------- + +slideToFilePath :: Slide -> Int -> FilePath +slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml" + +slideToSlideId :: Monad m => Slide -> Int -> P m String +slideToSlideId _ idNum = do + n <- gets stSlideIdOffset + return $ "rId" ++ (show $ idNum + n) + + +data Relationship = Relationship { relId :: Int + , relType :: MimeType + , relTarget :: FilePath + } deriving (Show, Eq) + +elementToRel :: Element -> Maybe Relationship +elementToRel element + | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing = + do rId <- findAttr (QName "Id" Nothing Nothing) element + numStr <- stripPrefix "rId" rId + num <- case reads numStr :: [(Int, String)] of + (n, _) : _ -> Just n + [] -> Nothing + type' <- findAttr (QName "Type" Nothing Nothing) element + target <- findAttr (QName "Target" Nothing Nothing) element + return $ Relationship num type' target + | otherwise = Nothing + +slideToPresRel :: Monad m => Slide -> Int -> P m Relationship +slideToPresRel slide idNum = do + n <- gets stSlideIdOffset + let rId = idNum + n + fp = "slides/" ++ slideToFilePath slide idNum + return $ Relationship { relId = rId + , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" + , relTarget = fp + } + +getRels :: PandocMonad m => P m [Relationship] +getRels = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels" + let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships" + let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem + return $ mapMaybe elementToRel relElems + +presentationToRels :: PandocMonad m => Presentation -> P m [Relationship] +presentationToRels (Presentation _ slides) = do + mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..] + rels <- getRels + let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels + -- We want to make room for the slides in the id space. The slides + -- will start at Id2 (since Id1 is for the slide master). There are + -- two slides in the data file, but that might change in the future, + -- so we will do this: + -- + -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is. + -- 2. We add the difference between this and the number of slides to + -- all relWithoutSlide rels (unless they're 1) + + let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of + [] -> 0 -- doesn't matter in this case, since + -- there will be nothing to map the + -- function over + l -> minimum l + + modifyRelNum :: Int -> Int + modifyRelNum 1 = 1 + modifyRelNum n = n - minRelNotOne + 2 + length slides + + relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides + + return $ mySlideRels ++ relsWithoutSlides' + +relToElement :: Relationship -> Element +relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel)) + , ("Type", relType rel) + , ("Target", relTarget rel) ] () + +relsToElement :: [Relationship] -> Element +relsToElement rels = mknode "Relationships" + [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] + (map relToElement rels) + +presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry +presentationToRelsEntry pres = do + rels <- presentationToRels pres + elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels + +elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry +elemToEntry fp element = do + epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime + return $ toEntry fp epochtime $ renderXml element + +slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry +slideToEntry slide idNum = do + modify $ \st -> st{stCurSlideId = idNum} + element <- slideToElement slide + elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element + +slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry +slideToSlideRelEntry slide idNum = do + element <- slideToSlideRelElement slide idNum + elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element + +linkRelElement :: Int -> (URL, String) -> Element +linkRelElement idNum (url, _) = + mknode "Relationship" [ ("Id", "rId" ++ show idNum) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") + , ("Target", url) + , ("TargetMode", "External") + ] () + +linkRelElements :: M.Map Int (URL, String) -> [Element] +linkRelElements mp = map (\(n, lnk) -> linkRelElement n lnk) (M.toList mp) + +mediaRelElement :: MediaInfo -> Element +mediaRelElement mInfo = + let ext = case mInfoExt mInfo of + Just e -> e + Nothing -> "" + in + mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo)) + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") + , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext) + ] () + +slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element +slideToSlideRelElement slide idNum = do + let target = case slide of + (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml" + (TitleSlide _) -> "../slideLayouts/slideLayout3.xml" + (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml" + + linkIds <- gets stLinkIds + mediaIds <- gets stMediaIds + + let linkRels = case M.lookup idNum linkIds of + Just mp -> linkRelElements mp + Nothing -> [] + mediaRels = case M.lookup idNum mediaIds of + Just mInfos -> map mediaRelElement mInfos + Nothing -> [] + + return $ + mknode "Relationships" + [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] + ([mknode "Relationship" [ ("Id", "rId1") + , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout") + , ("Target", target)] () + ] ++ linkRels ++ mediaRels) + +-- slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry +-- slideToSlideRelEntry slide idNum = do +-- let fp = "ppt/slides/_rels/slide" ++ (show idNum) ++ ".xml.rels" +-- elemToEntry fp $ slideToSlideRelElement slide + +slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element +slideToSldIdElement slide idNum = do + let id' = show $ idNum + 255 + rId <- slideToSlideId slide idNum + return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () + +presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element +presentationToSldIdLst (Presentation _ slides) = do + ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..]) + return $ mknode "p:sldIdLst" [] ids + +presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element +presentationToPresentationElement pres = do + refArchive <- asks envRefArchive + distArchive <- asks envDistArchive + element <- parseXml refArchive distArchive "ppt/presentation.xml" + sldIdLst <- presentationToSldIdLst pres + + let modifySldIdLst :: Content -> Content + modifySldIdLst (Elem e) = case elName e of + (QName "sldIdLst" _ _) -> Elem sldIdLst + _ -> Elem e + modifySldIdLst ct = ct + + newContent = map modifySldIdLst $ elContent element + + return $ element{elContent = newContent} + +presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry +presentationToPresEntry pres = presentationToPresentationElement pres >>= + elemToEntry "ppt/presentation.xml" + + + + +defaultContentTypeToElem :: DefaultContentType -> Element +defaultContentTypeToElem dct = + mknode "Default" + [("Extension", defContentTypesExt dct), + ("ContentType", defContentTypesType dct)] + () + +overrideContentTypeToElem :: OverrideContentType -> Element +overrideContentTypeToElem oct = + mknode "Override" + [("PartName", overrideContentTypesPart oct), + ("ContentType", overrideContentTypesType oct)] + () + +contentTypesToElement :: ContentTypes -> Element +contentTypesToElement ct = + let ns = "http://schemas.openxmlformats.org/package/2006/content-types" + in + mknode "Types" [("xmlns", ns)] $ + (map defaultContentTypeToElem $ contentTypesDefaults ct) ++ + (map overrideContentTypeToElem $ contentTypesOverrides ct) + +data DefaultContentType = DefaultContentType + { defContentTypesExt :: String + , defContentTypesType:: MimeType + } + deriving (Show, Eq) + +data OverrideContentType = OverrideContentType + { overrideContentTypesPart :: FilePath + , overrideContentTypesType :: MimeType + } + deriving (Show, Eq) + +data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType] + , contentTypesOverrides :: [OverrideContentType] + } + deriving (Show, Eq) + +contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry +contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct + +pathToOverride :: FilePath -> Maybe OverrideContentType +pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp) + +mediaContentType :: MediaInfo -> Maybe DefaultContentType +mediaContentType mInfo + | Just ('.' : ext) <- mInfoExt mInfo = + Just $ DefaultContentType { defContentTypesExt = ext + , defContentTypesType = + case mInfoMimeType mInfo of + Just mt -> mt + Nothing -> "application/octet-stream" + } + | otherwise = Nothing + +presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes +presentationToContentTypes (Presentation _ slides) = do + mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds + let defaults = [ DefaultContentType "xml" "application/xml" + , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" + ] + mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos + inheritedOverrides = mapMaybe pathToOverride inheritedFiles + presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] + slideOverrides = + mapMaybe + (\(s, n) -> + pathToOverride $ "ppt/slides/" ++ slideToFilePath s n) + (zip slides [1..]) + -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"] + return $ ContentTypes + (defaults ++ mediaDefaults) + (inheritedOverrides ++ presOverride ++ slideOverrides) + +-- slideToElement :: Element -> Slide -> Element +-- slideToElement layout (ContentSlide _ shapes) = +-- let sps = map (shapeToElement layout) shapes + +presML :: String +presML = "application/vnd.openxmlformats-officedocument.presentationml" + +noPresML :: String +noPresML = "application/vnd.openxmlformats-officedocument" + +getContentType :: FilePath -> Maybe MimeType +getContentType fp + | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml" + | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml" + | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml" + | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml" + | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml" + | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml" + | "ppt" : "slideMasters" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".slideMaster+xml" + | "ppt" : "slides" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".slide+xml" + | "ppt" : "notesMasters" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".notesMaster+xml" + | "ppt" : "notesSlides" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ presML ++ ".notesSlide+xml" + | "ppt" : "theme" : f : [] <- splitDirectories fp + , (_, ".xml") <- splitExtension f = + Just $ noPresML ++ ".theme+xml" + -- | "ppt" : "slideLayouts" : f : [] <- splitDirectories fp + -- , (_, ".xml") <- splitExtension f = + | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp= + Just $ presML ++ ".slideLayout+xml" + | otherwise = Nothing |