summaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Writers/Powerpoint/Presentation.hs')
-rw-r--r--src/Text/Pandoc/Writers/Powerpoint/Presentation.hs701
1 files changed, 701 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
new file mode 100644
index 000000000..68b2aeeb2
--- /dev/null
+++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
@@ -0,0 +1,701 @@
+{-# LANGUAGE PatternGuards #-}
+
+{-
+Copyright (C) 2017-2018 Jesse Rosenthal <jrosenthal@jhu.edu>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+-}
+
+{- |
+ Module : Text.Pandoc.Writers.Powerpoint.Presentation
+ Copyright : Copyright (C) 2017-2018 Jesse Rosenthal
+ License : GNU GPL, version 2 or above
+
+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
+ Stability : alpha
+ Portability : portable
+
+Definition of Presentation datatype, modeling a MS Powerpoint (pptx)
+document, and functions for converting a Pandoc document to
+Presentation.
+-}
+
+module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation
+ , Presentation(..)
+ , Slide(..)
+ , SlideElement(..)
+ , Shape(..)
+ , Graphic(..)
+ , BulletType(..)
+ , Algnment(..)
+ , Paragraph(..)
+ , ParaElem(..)
+ , ParaProps(..)
+ , RunProps(..)
+ , TableProps(..)
+ , Strikethrough(..)
+ , Capitals(..)
+ , PicProps(..)
+ , URL
+ , TeXString(..)
+ ) where
+
+
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.List (intercalate)
+import Data.Default
+import Text.Pandoc.Definition
+import Text.Pandoc.Class (PandocMonad)
+import Text.Pandoc.Slides (getSlideLevel)
+import qualified Text.Pandoc.Class as P
+import Text.Pandoc.Options
+import Text.Pandoc.Logging
+import Text.Pandoc.Walk
+import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"
+import Text.Pandoc.Writers.Shared (metaValueToInlines)
+import qualified Data.Map as M
+import Data.Maybe (maybeToList)
+
+data WriterEnv = WriterEnv { envMetadata :: Meta
+ , envRunProps :: RunProps
+ , envParaProps :: ParaProps
+ , envSlideLevel :: Int
+ , envOpts :: WriterOptions
+ , 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
+ , envOpts = def
+ , envSlideHasHeader = False
+ , envInList = False
+ , envInNoteSlide = False
+ , envCurSlideId = 1
+ , envSlideIdOffset = 1
+ }
+
+
+data WriterState = WriterState { stNoteIds :: M.Map Int [Block]
+ -- associate anchors with slide id
+ , stAnchorMap :: M.Map String Int
+ } deriving (Show, Eq)
+
+instance Default WriterState where
+ def = WriterState { stNoteIds = mempty
+ , stAnchorMap= mempty
+ }
+
+type Pres m = ReaderT WriterEnv (StateT WriterState m)
+
+runPres :: Monad m => WriterEnv -> WriterState -> Pres m a -> m a
+runPres env st p = evalStateT (runReaderT p env) st
+
+-- GHC 7.8 will still complain about concat <$> mapM unless we specify
+-- Functor. We can get rid of this when we stop supporting GHC 7.8.
+concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
+concatMapM f xs = liftM concat (mapM f xs)
+
+type Pixels = Integer
+
+data Presentation = Presentation [Slide]
+ deriving (Show)
+
+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)
+
+data Graphic = Tbl TableProps [Cell] [[Cell]]
+ deriving (Show, Eq)
+
+
+data Paragraph = Paragraph { paraProps :: ParaProps
+ , paraElems :: [ParaElem]
+ } deriving (Show, Eq)
+
+
+data BulletType = Bullet
+ | AutoNumbering ListAttributes
+ deriving (Show, Eq)
+
+data Algnment = AlgnLeft | AlgnRight | AlgnCenter
+ deriving (Show, Eq)
+
+data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels
+ , pPropMarginRight :: Maybe Pixels
+ , pPropLevel :: Int
+ , pPropBullet :: Maybe BulletType
+ , pPropAlign :: Maybe Algnment
+ , pPropSpaceBefore :: Maybe Pixels
+ } deriving (Show, Eq)
+
+instance Default ParaProps where
+ def = ParaProps { pPropMarginLeft = Just 0
+ , pPropMarginRight = Just 0
+ , pPropLevel = 0
+ , pPropBullet = Nothing
+ , pPropAlign = Nothing
+ , pPropSpaceBefore = 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] -> Pres m [ParaElem]
+inlinesToParElems ils = concatMapM inlineToParElems ils
+
+inlineToParElems :: Monad m => Inline -> Pres 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 -> Pres m ()
+registerAnchorId anchor = do
+ anchorMap <- gets stAnchorMap
+ slideId <- asks envCurSlideId
+ unless (null anchor) $
+ modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}
+
+-- Currently hardcoded, until I figure out how to make it dynamic.
+blockQuoteSize :: Pixels
+blockQuoteSize = 20
+
+noteSize :: Pixels
+noteSize = 18
+
+blockToParagraphs :: PandocMonad m => Block -> Pres 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 _ (ident, _, _) ils) = do
+ -- Note that this function only deals with content blocks, so it
+ -- will only touch headers that are above the current slide level --
+ -- slides at or below the slidelevel will be taken care of by
+ -- `blocksToSlide'`. We have the register anchors in both of them.
+ registerAnchorId ident
+ -- we set the subeader to bold
+ parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $
+ inlinesToParElems ils
+ -- and give it a bit of space before it.
+ return [Paragraph def{pPropSpaceBefore = Just 30} 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]]) -> Pres 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] -> Pres 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 -> Pres 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] -> Pres 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 -> Pres 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
+ 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
+ }
+
+ return $ GraphicFrame [Tbl tblPr hdrCells' rows'] caption'
+blockToShape blk = do paras <- blockToParagraphs blk
+ let paras' = map (\par -> par{paraElems = combineParaElems $ paraElems par}) paras
+ return $ TextBox paras'
+
+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 ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) =
+ combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss
+combineShapes (s:ss) = s : combineShapes ss
+
+blocksToShapes :: PandocMonad m => [Block] -> Pres 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] -> Pres 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] -> Pres m [[Block]]
+splitBlocks = splitBlocks' [] []
+
+blocksToSlide' :: PandocMonad m => Int -> [Block] -> Pres 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 ())
+ mbSplitBlksL <- splitBlocks blksL
+ mbSplitBlksR <- splitBlocks blksR
+ let blksL' = case mbSplitBlksL of
+ bs : _ -> bs
+ [] -> []
+ let blksR' = case mbSplitBlksR of
+ bs : _ -> bs
+ [] -> []
+ 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] -> Pres 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 -> Pres m a -> Pres 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 => Pres 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 => Pres 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 -> Pres 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] -> Pres 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
+
+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
+
+blocksToPresentation :: PandocMonad m => [Block] -> Pres 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]
+ return $
+ Presentation $
+ metadataslides ++ tocSlides ++ bodyslides ++ notesSlides
+
+documentToPresentation :: PandocMonad m
+ => WriterOptions
+ -> Pandoc
+ -> m Presentation
+documentToPresentation opts (Pandoc meta blks) = do
+ let env = def { envOpts = opts
+ , envMetadata = meta
+ , envSlideLevel = case writerSlideLevel opts of
+ Just lvl -> lvl
+ Nothing -> getSlideLevel blks
+ }
+ runPres env def $ blocksToPresentation blks
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-06 12:15:17 +0000