{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-} {- Copyright (C) 2017-2018 Jesse Rosenthal 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-2018 Jesse Rosenthal License : GNU GPL, version 2 or above Maintainer : Jesse Rosenthal 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 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 qualified Text.XML.Light.Cursor as XMLC import Text.Pandoc.Definition import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Error (PandocError(..)) import Text.Pandoc.Slides (getSlideLevel) 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 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, maybeToList) 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 , envSlideLevel = case writerSlideLevel opts of Just n -> n Nothing -> getSlideLevel blks' } 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 , envInNoteSlide :: 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 , envInNoteSlide = 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 , stNoteIds :: M.Map Int [Block] } deriving (Show, Eq) instance Default WriterState where def = WriterState { stCurSlideId = 0 , stSlideIdOffset = 1 , stLinkIds = mempty , stMediaIds = mempty , stMediaGlobalIds = mempty , stNoteIds = 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] } | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem] , twoColumnSlideLeft :: [Shape] , twoColumnSlideRight :: [Shape] } deriving (Show, Eq) data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape deriving (Show, Eq) data Shape = Pic PicProps 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) 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 , rPropForceSize :: Maybe Pixels } 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 , rPropForceSize = Nothing } data PicProps = PicProps { picPropLink :: Maybe (URL, String) } deriving (Show, Eq) instance Default PicProps where def = PicProps { picPropLink = Nothing } -------------------------------------------------- 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 = (envRunProps r){rPropCode = True}}) $ inlineToParElems $ Str str inlineToParElems (Math mathtype str) = return [MathElem mathtype (TeXString str)] inlineToParElems (Note blks) = do notes <- gets stNoteIds let maxNoteId = case M.keys notes of [] -> 0 lst -> maximum lst curNoteId = maxNoteId + 1 modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes } inlineToParElems $ Superscript [Str $ show curNoteId] inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils inlineToParElems (RawInline _ _) = return [] inlineToParElems _ = return [] isListType :: Block -> Bool isListType (OrderedList _ _) = True isListType (BulletList _) = True isListType (DefinitionList _) = True isListType _ = False 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] -- We can't yet do incremental lists, but we should render a -- (BlockQuote List) as a list to maintain compatibility with other -- formats. blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do ps <- blockToParagraphs blk ps' <- blockToParagraphs $ BlockQuote blks return $ ps ++ ps' blockToParagraphs (BlockQuote blks) = local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100} , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$ concatMapM blockToParagraphs blks -- TODO: work out the format blockToParagraphs (RawBlock _ _) = return [] 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 (DefinitionList entries) = do let go :: PandocMonad m => ([Inline], [[Block]]) -> P m [Paragraph] go (ils, blksLst) = do term <-blockToParagraphs $ Para [Strong ils] -- For now, we'll treat each definition term as a -- blockquote. We can extend this further later. definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst return $ term ++ definition concatMapM go entries blockToParagraphs (Div (_, ("notes" : []), _) _) = return [] blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks 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 def url attr <$> (inlinesToParElems ils) blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = Pic def url attr <$> (inlinesToParElems ils) blockToShape (Plain (il:_)) | Link _ (il':_) target <- il , Image attr ils (url, _) <- il' = Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils) blockToShape (Para (il:_)) | Link _ (il':_) target <- il , Image attr ils (url, _) <- il' = Pic def{picPropLink = Just target} 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 isImage :: Inline -> Bool isImage (Image _ _ _) = True isImage (Link _ ((Image _ _ _) : _) _) = True isImage _ = False 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 -- `blockToParagraphs` treats Plain and Para the same, so we can save -- some code duplication by treating them the same here. splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks) splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do slideLevel <- asks envSlideLevel case cur of (Header n _ _) : [] | n == slideLevel -> splitBlocks' [] (acc ++ [cur ++ [Para [il]]]) (if null ils then blks else (Para ils) : blks) _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]]) (if null ils then blks else (Para 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 (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do slideLevel <- asks envSlideLevel case cur of (Header n _ _) : [] | n == slideLevel -> splitBlocks' [] (acc ++ [cur ++ [d]]) blks _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) 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 -- Now get the slide without the header, and then add the header -- in. slide <- blocksToSlide' lvl blks return $ case slide of ContentSlide _ cont -> ContentSlide hdr cont TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR slide' -> slide' blocksToSlide' _ (blk : blks) | Div (_, classes, _) divBlks <- blk , "columns" `elem` classes , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks , "column" `elem` clsL, "column" `elem` clsR = do unless (null blks) (mapM (P.report . BlockNotRendered) blks >> return ()) unless (null remaining) (mapM (P.report . BlockNotRendered) remaining >> return ()) shapesL <- blocksToShapes blksL shapesR <- blocksToShapes blksR return $ TwoColumnSlide { twoColumnSlideHeader = [] , twoColumnSlideLeft = shapesL , twoColumnSlideRight = shapesR } blocksToSlide' _ (blk : blks) = do inNoteSlide <- asks envInNoteSlide shapes <- if inNoteSlide then forceFontSize noteSize $ blocksToShapes (blk : blks) else 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 makeNoteEntry :: Int -> [Block] -> [Block] makeNoteEntry n blks = let enum = Str (show n ++ ".") in case blks of (Para ils : blks') -> (Para $ enum : Space : ils) : blks' _ -> (Para [enum]) : blks forceFontSize :: PandocMonad m => Pixels -> P m a -> P m a forceFontSize px x = do rpr <- asks envRunProps local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x -- Right now, there's no logic for making more than one slide, but I -- want to leave the option open to make multiple slides if we figure -- out how to guess at how much space the text of the notes will take -- up (or if we allow a way for it to be manually controlled). Plus a -- list will make it easier to put together in the final -- `blocksToPresentation` function (since we can just add an empty -- list without checking the state). makeNotesSlides :: PandocMonad m => P m [Slide] makeNotesSlides = local (\env -> env{envInNoteSlide=True}) $ do noteIds <- gets stNoteIds if M.null noteIds then return [] else do let hdr = Header 2 nullAttr [Str "Notes"] blks <- return $ concatMap (\(n, bs) -> makeNoteEntry n bs) $ M.toList noteIds sld <- blocksToSlide $ hdr : blks return [sld] 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 noteSlides <- makeNotesSlides let slides' = slides ++ noteSlides 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" (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.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 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 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 replaceNamedChildren :: NameSpaces -> String -> String -> [Element] -> Element -> Element replaceNamedChildren ns prefix name newKids element = element { elContent = concat $ fun True $ elContent element } where fun :: Bool -> [Content] -> [[Content]] fun _ [] = [] fun switch ((Elem e) : conts) | isElem ns prefix name e = if switch then (map Elem $ newKids) : fun False conts else fun False conts fun switch (cont : conts) = [cont] : fun switch conts ---------------------------------------------------------------- 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 => PicProps -> MediaInfo -> Text.Pandoc.Definition.Attr -> P m Element makePicElement picProps 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 cNvPicPr = mknode "p:cNvPicPr" [] $ mknode "a:picLocks" [("noGrp","1") ,("noChangeAspect","1")] () -- cNvPr will contain the link information so we do that separately, -- and register the link if necessary. let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")] cNvPr <- case picPropLink picProps of Just link -> do idNum <- registerLink link return $ mknode "p:cNvPr" cNvPrAttr $ mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] () Nothing -> return $ mknode "p:cNvPr" cNvPrAttr () let nvPicPr = mknode "p:nvPicPr" [] [ cNvPr , 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 noteSize :: Pixels noteSize = 18 paraElemToElement :: PandocMonad m => ParaElem -> P m Element paraElemToElement Break = return $ mknode "a:br" [] () paraElemToElement (Run rpr s) = do let sizeAttrs = case rPropForceSize rpr of Just n -> [("sz", (show $ n * 100))] Nothing -> [] attrs = sizeAttrs ++ if rPropCode rpr then [] 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 (combineParaElems $ 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 picProps fp attr alt) = do mInfo <- registerMedia fp alt case mInfoExt mInfo of Just _ -> makePicElement picProps 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 let elements' = if null elements then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]] else elements 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 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" [] () 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" [] () setIdx'' :: NameSpaces -> String -> Content -> Content setIdx'' _ idx (Elem element) = let tag = XMLC.getTag element attrs = XMLC.tagAttribs tag idxKey = (QName "idx" Nothing Nothing) attrs' = Attr idxKey idx : (filter (\a -> attrKey a /= idxKey) attrs) tag' = tag {XMLC.tagAttribs = attrs'} in Elem $ XMLC.setTag tag' element setIdx'' _ _ c = c setIdx' :: NameSpaces -> String -> XMLC.Cursor -> XMLC.Cursor setIdx' ns idx cur = let modifiedCur = XMLC.modifyContent (setIdx'' ns idx) cur in case XMLC.nextDF modifiedCur of Just cur' -> setIdx' ns idx cur' Nothing -> XMLC.root modifiedCur setIdx :: NameSpaces -> String -> Element -> Element setIdx ns idx element = let cur = XMLC.fromContent (Elem element) cur' = setIdx' ns idx cur in case XMLC.toTree cur' of Elem element' -> element' _ -> element twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element twoColumnToElement layout hdrShape shapesL shapesR | 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] contentElementsL <- shapesToElements layout shapesL contentElementsR <- shapesToElements layout shapesR let contentElementsL' = map (setIdx ns "1") contentElementsL contentElementsR' = map (setIdx ns "2") contentElementsR return $ replaceNamedChildren ns "p" "sp" (hdrShapeElements ++ contentElementsL' ++ contentElementsR') spTree twoColumnToElement _ _ _ _= 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@(TwoColumnSlide hdrElems shapesL shapesR) = do layout <- getLayout s spTree <- local (\env -> if null hdrElems then env else env{envSlideHasHeader=True}) $ twoColumnToElement layout hdrElems shapesL shapesR 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" (TwoColumnSlide _ _ _) -> "../slideLayouts/slideLayout4.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) 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) 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" : _ : [] <- splitDirectories fp= Just $ presML ++ ".slideLayout+xml" | otherwise = Nothing ------------------------------------------------------- combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem] combineParaElems' mbPElem [] = maybeToList mbPElem combineParaElems' Nothing (pElem : pElems) = combineParaElems' (Just pElem) pElems combineParaElems' (Just pElem') (pElem : pElems) | Run rPr' s' <- pElem' , Run rPr s <- pElem , rPr == rPr' = combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems | otherwise = pElem' : combineParaElems' (Just pElem) pElems combineParaElems :: [ParaElem] -> [ParaElem] combineParaElems = combineParaElems' Nothing