diff options
Diffstat (limited to 'src/Text/Pandoc/Writers/Powerpoint.hs')
| -rw-r--r-- | src/Text/Pandoc/Writers/Powerpoint.hs | 1868 |
1 files changed, 21 insertions, 1847 deletions
diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs index af19ec93b..acb33f582 100644 --- a/src/Text/Pandoc/Writers/Powerpoint.hs +++ b/src/Text/Pandoc/Writers/Powerpoint.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {- Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu> @@ -27,44 +27,29 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Stability : alpha Portability : portable -Conversion of 'Pandoc' documents to powerpoint (pptx). +Conversion of 'Pandoc' documents to powerpoint (pptx). -} + +{- +This is a wrapper around two modules: + + - Text.Pandoc.Writers.Powerpoint.Presentation (which converts a + pandoc document into a Presentation datatype), and + + - Text.Pandoc.Writers.Powerpoint.Output (which converts a + Presentation into a zip archive, which can be output). -} 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 qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element" -import Text.Pandoc.Writers.Shared (fixDisplayMath, metaValueToInlines) -import Text.Pandoc.Writers.OOXML -import qualified Data.Map as M -import Data.Maybe (mapMaybe, listToMaybe, maybeToList, catMaybes) -import Text.Pandoc.ImageSize -import Control.Applicative ((<|>)) - -import Text.TeXMath -import Text.Pandoc.Writers.Math (convertMath) - +import Text.Pandoc.Class (PandocMonad, report) +import Text.Pandoc.Options (WriterOptions) +import Text.Pandoc.Writers.Shared (fixDisplayMath) +import Text.Pandoc.Writers.Powerpoint.Presentation (documentToPresentation) +import Text.Pandoc.Writers.Powerpoint.Output (presentationToArchive) +import qualified Data.ByteString.Lazy as BL writePowerpoint :: (PandocMonad m) => WriterOptions -- ^ Writer options @@ -72,1818 +57,7 @@ writePowerpoint :: (PandocMonad m) -> 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 - , envCurSlideId :: Int - -- the difference between the number at - -- the end of the slide file name and - -- the rId number - , envSlideIdOffset :: Int - } - 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 - , envCurSlideId = 1 - , envSlideIdOffset = 1 - } - -data MediaInfo = MediaInfo { mInfoFilePath :: FilePath - , mInfoLocalId :: Int - , mInfoGlobalId :: Int - , mInfoMimeType :: Maybe MimeType - , mInfoExt :: Maybe String - , mInfoCaption :: Bool - } deriving (Show, Eq) - -data WriterState = WriterState { 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] - -- associate anchors with slide id - , stAnchorMap :: M.Map String Int - } deriving (Show, Eq) - -instance Default WriterState where - def = WriterState { stLinkIds = mempty - , stMediaIds = mempty - , stMediaGlobalIds = mempty - , stNoteIds = mempty - , stAnchorMap= 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 - -registerAnchorId :: PandocMonad m => String -> P m () -registerAnchorId anchor = do - anchorMap <- gets stAnchorMap - slideId <- asks envCurSlideId - unless (null anchor) $ - modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap} - -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 (ident, _, _) ils) = do - -- Note that this function will only touch headers that are not at - -- the beginning of slides -- all the rest will be taken care of by - -- `blocksToSlide'`. We have the register anchors in both of them. - registerAnchorId ident - 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 (ident, _, _) ils) : blks) - | n < lvl = do - registerAnchorId ident - hdr <- inlinesToParElems ils - return $ TitleSlide {titleSlideHeader = hdr} - | n == lvl = do - registerAnchorId ident - 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 - --- We leave these as blocks because we will want to include them in --- the TOC. -makeNotesSlideBlocks :: PandocMonad m => P m [Block] -makeNotesSlideBlocks = do - noteIds <- gets stNoteIds - slideLevel <- asks envSlideLevel - meta <- asks envMetadata - -- Get identifiers so we can give the notes section a unique ident. - anchorSet <- M.keysSet <$> gets stAnchorMap - if M.null noteIds - then return [] - else do let title = case lookupMeta "notes-title" meta of - Just val -> metaValueToInlines val - Nothing -> [Str "Notes"] - ident = Shared.uniqueIdent title anchorSet - hdr = Header slideLevel (ident, [], []) title - blks <- return $ - concatMap (\(n, bs) -> makeNoteEntry n bs) $ - M.toList noteIds - return $ hdr : 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 - } - --- adapted from the markdown writer -elementToListItem :: PandocMonad m => Shared.Element -> P m [Block] -elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do - opts <- asks envOpts - let headerLink = if null ident - then walk Shared.deNote headerText - else [Link nullAttr (walk Shared.deNote headerText) - ('#':ident, "")] - listContents <- if null subsecs || lev >= writerTOCDepth opts - then return [] - else mapM elementToListItem subsecs - return [Plain headerLink, BulletList listContents] -elementToListItem (Shared.Blk _) = return [] - -makeTOCSlide :: PandocMonad m => [Block] -> P m Slide -makeTOCSlide blks = do - contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks) - meta <- asks envMetadata - slideLevel <- asks envSlideLevel - let tocTitle = case lookupMeta "toc-title" meta of - Just val -> metaValueToInlines val - Nothing -> [Str "Table of Contents"] - hdr = Header slideLevel nullAttr tocTitle - sld <- blocksToSlide [hdr, contents] - return sld - -blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation -blocksToPresentation blks = do - opts <- asks envOpts - let metadataStartNum = 1 - metadataslides <- maybeToList <$> getMetaSlide - let tocStartNum = metadataStartNum + length metadataslides - -- As far as I can tell, if we want to have a variable-length toc in - -- the future, we'll have to make it twice. Once to get the length, - -- and a second time to include the notes slide. We can't make the - -- notes slide before the body slides because we need to know if - -- there are notes, and we can't make either before the toc slide, - -- because we need to know its length to get slide numbers right. - -- - -- For now, though, since the TOC slide is only length 1, if it - -- exists, we'll just get the length, and then come back to make the - -- slide later - let tocSlidesLength = if writerTableOfContents opts then 1 else 0 - let bodyStartNum = tocStartNum + tocSlidesLength - blksLst <- splitBlocks blks - bodyslides <- mapM - (\(bs, n) -> local (\st -> st{envCurSlideId = n}) (blocksToSlide bs)) - (zip blksLst [bodyStartNum..]) - let noteStartNum = bodyStartNum + length bodyslides - notesSlideBlocks <- makeNotesSlideBlocks - -- now we come back and make the real toc... - tocSlides <- if writerTableOfContents opts - then do toc <- makeTOCSlide $ blks ++ notesSlideBlocks - return [toc] - else return [] - -- ... and the notes slide. We test to see if the blocks are empty, - -- because we don't want to make an empty slide. - notesSlides <- if null notesSlideBlocks - then return [] - else do notesSlide <- local - (\env -> env { envCurSlideId = noteStartNum - , envInNoteSlide = True - }) - (blocksToSlide $ notesSlideBlocks) - return [notesSlide] - presSize <- asks envPresentationSize - return $ - Presentation presSize $ - metadataslides ++ tocSlides ++ bodyslides ++ notesSlides - --------------------------------------------------------------------- - -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 <- asks envCurSlideId - 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 <- asks envCurSlideId - 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 - -- first we have to make sure that if it's an - -- anchor, it's in the anchor map. If not, there's - -- no link. - anchorMap <- gets stAnchorMap - return $ case link of - -- anchor with nothing in the map - ('#':target, _) | Nothing <- M.lookup target anchorMap -> - [] - -- anchor that is in the map - ('#':_, _) -> - let linkAttrs = - [ ("r:id", "rId" ++ show idNum) - , ("action", "ppaction://hlinksldjump") - ] - in [mknode "a:hlinkClick" linkAttrs ()] - -- external - _ -> - let linkAttrs = - [ ("r:id", "rId" ++ show idNum) - ] - in [mknode "a:hlinkClick" linkAttrs ()] - 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 <- asks envSlideIdOffset - 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 <- asks envSlideIdOffset - 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 - local (\env -> env{envCurSlideId = idNum}) $ do - 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 :: PandocMonad m => Int -> (URL, String) -> P m (Maybe Element) -linkRelElement idNum (url, _) = do - anchorMap <- gets stAnchorMap - case url of - -- if it's an anchor in the map, we use the slide number for an - -- internal link. - '#' : anchor | Just num <- M.lookup anchor anchorMap -> - return $ Just $ - mknode "Relationship" [ ("Id", "rId" ++ show idNum) - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") - , ("Target", "slide" ++ show num ++ ".xml") - ] () - -- if it's an anchor not in the map, we return nothing. - '#' : _ -> return Nothing - -- Anything else we treat as an external link - _ -> - return $ Just $ - mknode "Relationship" [ ("Id", "rId" ++ show idNum) - , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") - , ("Target", url) - , ("TargetMode", "External") - ] () - -linkRelElements :: PandocMonad m => M.Map Int (URL, String) -> P m [Element] -linkRelElements mp = catMaybes <$> mapM (\(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 - - linkRels <- case M.lookup idNum linkIds of - Just mp -> linkRelElements mp - Nothing -> return [] - let 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 + let (pres, logMsgs) = documentToPresentation opts (Pandoc meta blks') + mapM_ report logMsgs + archv <- presentationToArchive opts pres + return $ fromArchive archv |