"Fossies" - the Fresh Open Source Software Archive

Member "pandoc-2.7.3/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs" (12 Jun 2019, 39955 Bytes) of package /linux/www/pandoc-2.7.3.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Haskell source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the last Fossies "Diffs" side-by-side code changes report for "Presentation.hs": 2.7.1_vs_2.7.2.

    1 {-# LANGUAGE NoImplicitPrelude          #-}
    2 {-# LANGUAGE PatternGuards              #-}
    3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    4 {- |
    5    Module      : Text.Pandoc.Writers.Powerpoint.Presentation
    6    Copyright   : Copyright (C) 2017-2019 Jesse Rosenthal
    7    License     : GNU GPL, version 2 or above
    8 
    9    Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
   10    Stability   : alpha
   11    Portability : portable
   12 
   13 Definition of Presentation datatype, modeling a MS Powerpoint (pptx)
   14 document, and functions for converting a Pandoc document to
   15 Presentation.
   16 -}
   17 
   18 module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation
   19                                                    , Presentation(..)
   20                                                    , DocProps(..)
   21                                                    , Slide(..)
   22                                                    , Layout(..)
   23                                                    , SpeakerNotes(..)
   24                                                    , SlideId(..)
   25                                                    , Shape(..)
   26                                                    , Graphic(..)
   27                                                    , BulletType(..)
   28                                                    , Algnment(..)
   29                                                    , Paragraph(..)
   30                                                    , ParaElem(..)
   31                                                    , ParaProps(..)
   32                                                    , RunProps(..)
   33                                                    , TableProps(..)
   34                                                    , Strikethrough(..)
   35                                                    , Capitals(..)
   36                                                    , PicProps(..)
   37                                                    , URL
   38                                                    , TeXString(..)
   39                                                    , LinkTarget(..)
   40                                                    ) where
   41 
   42 
   43 import Prelude
   44 import Control.Monad.Reader
   45 import Control.Monad.State
   46 import Data.List (intercalate)
   47 import Data.Default
   48 import Text.Pandoc.Definition
   49 import Text.Pandoc.ImageSize
   50 import Text.Pandoc.Slides (getSlideLevel)
   51 import Text.Pandoc.Options
   52 import Text.Pandoc.Logging
   53 import Text.Pandoc.Walk
   54 import Data.Time (UTCTime)
   55 import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"
   56 import Text.Pandoc.Writers.Shared (lookupMetaInlines, lookupMetaBlocks
   57                                  , lookupMetaString, toTableOfContents)
   58 import qualified Data.Map as M
   59 import qualified Data.Set as S
   60 import Data.Maybe (maybeToList, fromMaybe)
   61 import Text.Pandoc.Highlighting
   62 import qualified Data.Text as T
   63 import Control.Applicative ((<|>))
   64 import Skylighting
   65 
   66 data WriterEnv = WriterEnv { envMetadata :: Meta
   67                            , envRunProps :: RunProps
   68                            , envParaProps :: ParaProps
   69                            , envSlideLevel :: Int
   70                            , envOpts :: WriterOptions
   71                            , envSlideHasHeader :: Bool
   72                            , envInList :: Bool
   73                            , envInNoteSlide :: Bool
   74                            , envCurSlideId :: SlideId
   75                            , envInSpeakerNotes :: Bool
   76                            }
   77                  deriving (Show)
   78 
   79 instance Default WriterEnv where
   80   def = WriterEnv { envMetadata = mempty
   81                   , envRunProps = def
   82                   , envParaProps = def
   83                   , envSlideLevel = 2
   84                   , envOpts = def
   85                   , envSlideHasHeader = False
   86                   , envInList = False
   87                   , envInNoteSlide = False
   88                   , envCurSlideId = SlideId "Default"
   89                   , envInSpeakerNotes = False
   90                   }
   91 
   92 
   93 data WriterState = WriterState { stNoteIds :: M.Map Int [Block]
   94                                -- associate anchors with slide id
   95                                , stAnchorMap :: M.Map String SlideId
   96                                , stSlideIdSet :: S.Set SlideId
   97                                , stLog :: [LogMessage]
   98                                , stSpeakerNotes :: SpeakerNotes
   99                                } deriving (Show, Eq)
  100 
  101 instance Default WriterState where
  102   def = WriterState { stNoteIds = mempty
  103                     , stAnchorMap = mempty
  104                     -- we reserve this s
  105                     , stSlideIdSet = reservedSlideIds
  106                     , stLog = []
  107                     , stSpeakerNotes = mempty
  108                     }
  109 
  110 metadataSlideId :: SlideId
  111 metadataSlideId = SlideId "Metadata"
  112 
  113 tocSlideId :: SlideId
  114 tocSlideId = SlideId "TOC"
  115 
  116 endNotesSlideId :: SlideId
  117 endNotesSlideId = SlideId "EndNotes"
  118 
  119 reservedSlideIds :: S.Set SlideId
  120 reservedSlideIds = S.fromList [ metadataSlideId
  121                               , tocSlideId
  122                               , endNotesSlideId
  123                               ]
  124 
  125 uniqueSlideId' :: Integer -> S.Set SlideId -> String -> SlideId
  126 uniqueSlideId' n idSet s =
  127   let s' = if n == 0 then s else s ++ "-" ++ show n
  128   in if SlideId s' `S.member` idSet
  129      then uniqueSlideId' (n+1) idSet s
  130      else SlideId s'
  131 
  132 uniqueSlideId :: S.Set SlideId -> String -> SlideId
  133 uniqueSlideId = uniqueSlideId' 0
  134 
  135 runUniqueSlideId :: String -> Pres SlideId
  136 runUniqueSlideId s = do
  137   idSet <- gets stSlideIdSet
  138   let sldId = uniqueSlideId idSet s
  139   modify $ \st -> st{stSlideIdSet = S.insert sldId idSet}
  140   return sldId
  141 
  142 addLogMessage :: LogMessage -> Pres ()
  143 addLogMessage msg = modify $ \st -> st{stLog = msg : stLog st}
  144 
  145 type Pres = ReaderT WriterEnv (State WriterState)
  146 
  147 runPres :: WriterEnv -> WriterState -> Pres a -> (a, [LogMessage])
  148 runPres env st p = (pres, reverse $ stLog finalSt)
  149   where (pres, finalSt) = runState (runReaderT p env) st
  150 
  151 -- GHC 7.8 will still complain about concat <$> mapM unless we specify
  152 -- Functor. We can get rid of this when we stop supporting GHC 7.8.
  153 concatMapM        :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
  154 concatMapM f xs   =  liftM concat (mapM f xs)
  155 
  156 type Pixels = Integer
  157 
  158 data Presentation = Presentation DocProps [Slide]
  159   deriving (Show)
  160 
  161 data DocProps = DocProps { dcTitle :: Maybe String
  162                          , dcSubject :: Maybe String
  163                          , dcCreator :: Maybe String
  164                          , dcKeywords :: Maybe [String]
  165                          , dcDescription :: Maybe String
  166                          , cpCategory :: Maybe String
  167                          , dcCreated :: Maybe UTCTime
  168                          , customProperties :: Maybe [(String, String)]
  169                          } deriving (Show, Eq)
  170 
  171 
  172 data Slide = Slide { slideId :: SlideId
  173                    , slideLayout :: Layout
  174                    , slideSpeakerNotes :: SpeakerNotes
  175                    } deriving (Show, Eq)
  176 
  177 newtype SlideId = SlideId String
  178   deriving (Show, Eq, Ord)
  179 
  180 -- In theory you could have anything on a notes slide but it seems
  181 -- designed mainly for one textbox, so we'll just put in the contents
  182 -- of that textbox, to avoid other shapes that won't work as well.
  183 newtype SpeakerNotes = SpeakerNotes {fromSpeakerNotes :: [Paragraph]}
  184   deriving (Show, Eq, Monoid, Semigroup)
  185 
  186 data Layout = MetadataSlide [ParaElem] [ParaElem] [[ParaElem]] [ParaElem]
  187             --              title      subtitle   authors      date
  188             | TitleSlide [ParaElem]
  189             --           heading
  190             | ContentSlide [ParaElem] [Shape]
  191             --             heading    content
  192             | TwoColumnSlide [ParaElem] [Shape] [Shape]
  193             --               heading    left    right
  194             deriving (Show, Eq)
  195 
  196 data Shape = Pic PicProps FilePath [ParaElem]
  197            | GraphicFrame [Graphic] [ParaElem]
  198            | TextBox [Paragraph]
  199            | RawOOXMLShape String
  200   deriving (Show, Eq)
  201 
  202 type Cell = [Paragraph]
  203 
  204 data TableProps = TableProps { tblPrFirstRow :: Bool
  205                              , tblPrBandRow :: Bool
  206                              } deriving (Show, Eq)
  207 
  208 data Graphic = Tbl TableProps [Cell] [[Cell]]
  209   deriving (Show, Eq)
  210 
  211 
  212 data Paragraph = Paragraph { paraProps :: ParaProps
  213                            , paraElems  :: [ParaElem]
  214                            } deriving (Show, Eq)
  215 
  216 data BulletType = Bullet
  217                 | AutoNumbering ListAttributes
  218   deriving (Show, Eq)
  219 
  220 data Algnment = AlgnLeft | AlgnRight | AlgnCenter
  221   deriving (Show, Eq)
  222 
  223 data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels
  224                            , pPropMarginRight :: Maybe Pixels
  225                            , pPropLevel :: Int
  226                            , pPropBullet :: Maybe BulletType
  227                            , pPropAlign :: Maybe Algnment
  228                            , pPropSpaceBefore :: Maybe Pixels
  229                            } deriving (Show, Eq)
  230 
  231 instance Default ParaProps where
  232   def = ParaProps { pPropMarginLeft = Just 0
  233                   , pPropMarginRight = Just 0
  234                   , pPropLevel = 0
  235                   , pPropBullet = Nothing
  236                   , pPropAlign = Nothing
  237                   , pPropSpaceBefore = Nothing
  238                   }
  239 
  240 newtype TeXString = TeXString {unTeXString :: String}
  241   deriving (Eq, Show)
  242 
  243 data ParaElem = Break
  244               | Run RunProps String
  245               -- It would be more elegant to have native TeXMath
  246               -- Expressions here, but this allows us to use
  247               -- `convertmath` from T.P.Writers.Math. Will perhaps
  248               -- revisit in the future.
  249               | MathElem MathType TeXString
  250               | RawOOXMLParaElem String
  251               deriving (Show, Eq)
  252 
  253 data Strikethrough = NoStrike | SingleStrike | DoubleStrike
  254   deriving (Show, Eq)
  255 
  256 data Capitals = NoCapitals | SmallCapitals | AllCapitals
  257   deriving (Show, Eq)
  258 
  259 type URL = String
  260 
  261 data LinkTarget = ExternalTarget (URL, String)
  262                 | InternalTarget SlideId
  263                 deriving (Show, Eq)
  264 
  265 data RunProps = RunProps { rPropBold :: Bool
  266                          , rPropItalics :: Bool
  267                          , rStrikethrough :: Maybe Strikethrough
  268                          , rBaseline :: Maybe Int
  269                          , rCap :: Maybe Capitals
  270                          , rLink :: Maybe LinkTarget
  271                          , rPropCode :: Bool
  272                          , rPropBlockQuote :: Bool
  273                          , rPropForceSize :: Maybe Pixels
  274                          , rSolidFill :: Maybe Color
  275                          -- TODO: Make a full underline data type with
  276                          -- the different options.
  277                          , rPropUnderline :: Bool
  278                          } deriving (Show, Eq)
  279 
  280 instance Default RunProps where
  281   def = RunProps { rPropBold = False
  282                  , rPropItalics = False
  283                  , rStrikethrough = Nothing
  284                  , rBaseline = Nothing
  285                  , rCap = Nothing
  286                  , rLink = Nothing
  287                  , rPropCode = False
  288                  , rPropBlockQuote = False
  289                  , rPropForceSize = Nothing
  290                  , rSolidFill = Nothing
  291                  , rPropUnderline = False
  292                  }
  293 
  294 data PicProps = PicProps { picPropLink :: Maybe LinkTarget
  295                          , picWidth    :: Maybe Dimension
  296                          , picHeight   :: Maybe Dimension
  297                          } deriving (Show, Eq)
  298 
  299 instance Default PicProps where
  300   def = PicProps { picPropLink = Nothing
  301                  , picWidth = Nothing
  302                  , picHeight = Nothing
  303                  }
  304 
  305 --------------------------------------------------
  306 
  307 inlinesToParElems :: [Inline] -> Pres [ParaElem]
  308 inlinesToParElems ils = concatMapM inlineToParElems ils
  309 
  310 inlineToParElems :: Inline -> Pres [ParaElem]
  311 inlineToParElems (Str s) = do
  312   pr <- asks envRunProps
  313   return [Run pr s]
  314 inlineToParElems (Emph ils) =
  315   local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $
  316   inlinesToParElems ils
  317 inlineToParElems (Strong ils) =
  318   local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $
  319   inlinesToParElems ils
  320 inlineToParElems (Strikeout ils) =
  321   local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $
  322   inlinesToParElems ils
  323 inlineToParElems (Superscript ils) =
  324   local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $
  325   inlinesToParElems ils
  326 inlineToParElems (Subscript ils) =
  327   local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $
  328   inlinesToParElems ils
  329 inlineToParElems (SmallCaps ils) =
  330   local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $
  331   inlinesToParElems ils
  332 inlineToParElems Space = inlineToParElems (Str " ")
  333 inlineToParElems SoftBreak = inlineToParElems (Str " ")
  334 inlineToParElems LineBreak = return [Break]
  335 inlineToParElems (Link _ ils (url, title)) =
  336   local (\r ->r{envRunProps = (envRunProps r){rLink = Just $ ExternalTarget (url, title)}}) $
  337   inlinesToParElems ils
  338 inlineToParElems (Code _ str) =
  339   local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $
  340   inlineToParElems $ Str str
  341 inlineToParElems (Math mathtype str) =
  342   return [MathElem mathtype (TeXString str)]
  343 -- We ignore notes if we're in a speaker notes div. Otherwise this
  344 -- would add an entry to the endnotes slide, which would put speaker
  345 -- notes in the public presentation. In the future, we can entertain a
  346 -- way of adding a speakernotes-specific note that would just add
  347 -- paragraphs to the bottom of the notes page.
  348 inlineToParElems (Note blks) = do
  349   inSpNotes <- asks envInSpeakerNotes
  350   if inSpNotes
  351     then return []
  352     else do
  353     notes <- gets stNoteIds
  354     let maxNoteId = case M.keys notes of
  355           [] -> 0
  356           lst -> maximum lst
  357         curNoteId = maxNoteId + 1
  358     modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes }
  359     local (\env -> env{envRunProps = (envRunProps env){rLink = Just $ InternalTarget endNotesSlideId}}) $
  360       inlineToParElems $ Superscript [Str $ show curNoteId]
  361 inlineToParElems (Span (_, ["underline"], _) ils) =
  362   local (\r -> r{envRunProps = (envRunProps r){rPropUnderline=True}}) $
  363   inlinesToParElems ils
  364 inlineToParElems (Span _ ils) = inlinesToParElems ils
  365 inlineToParElems (Quoted quoteType ils) =
  366   inlinesToParElems $ [Str open] ++ ils ++ [Str close]
  367   where (open, close) = case quoteType of
  368                           SingleQuote -> ("\x2018", "\x2019")
  369                           DoubleQuote -> ("\x201C", "\x201D")
  370 inlineToParElems il@(RawInline fmt s) =
  371   case fmt of
  372     Format "openxml" -> return [RawOOXMLParaElem s]
  373     _                -> do addLogMessage $ InlineNotRendered il
  374                            return []
  375 inlineToParElems (Cite _ ils) = inlinesToParElems ils
  376 -- Note: we shouldn't reach this, because images should be handled at
  377 -- the shape level, but should that change in the future, we render
  378 -- the alt text.
  379 inlineToParElems (Image _ alt _) = inlinesToParElems alt
  380 
  381 
  382 
  383 isListType :: Block -> Bool
  384 isListType (OrderedList _ _) = True
  385 isListType (BulletList _) = True
  386 isListType (DefinitionList _) = True
  387 isListType _ = False
  388 
  389 registerAnchorId :: String -> Pres ()
  390 registerAnchorId anchor = do
  391   anchorMap <- gets stAnchorMap
  392   sldId <- asks envCurSlideId
  393   unless (null anchor) $
  394     modify $ \st -> st {stAnchorMap = M.insert anchor sldId anchorMap}
  395 
  396 -- Currently hardcoded, until I figure out how to make it dynamic.
  397 blockQuoteSize :: Pixels
  398 blockQuoteSize = 20
  399 
  400 noteSize :: Pixels
  401 noteSize = 18
  402 
  403 blockToParagraphs :: Block -> Pres [Paragraph]
  404 blockToParagraphs (Plain ils) = blockToParagraphs (Para ils)
  405 blockToParagraphs (Para ils) = do
  406   parElems <- inlinesToParElems ils
  407   pProps <- asks envParaProps
  408   return [Paragraph pProps parElems]
  409 blockToParagraphs (LineBlock ilsList) = do
  410   parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList
  411   pProps <- asks envParaProps
  412   return [Paragraph pProps parElems]
  413 -- TODO: work out the attributes
  414 blockToParagraphs (CodeBlock attr str) =
  415   local (\r -> r{ envParaProps = def{pPropMarginLeft = Just 100}
  416                 , envRunProps = (envRunProps r){rPropCode = True}}) $ do
  417   mbSty <- writerHighlightStyle <$> asks envOpts
  418   synMap <- writerSyntaxMap <$> asks envOpts
  419   case mbSty of
  420     Just sty ->
  421       case highlight synMap (formatSourceLines sty) attr str of
  422         Right pElems -> do pProps <- asks envParaProps
  423                            return [Paragraph pProps pElems]
  424         Left _ -> blockToParagraphs $ Para [Str str]
  425     Nothing -> blockToParagraphs $ Para [Str str]
  426 -- We can't yet do incremental lists, but we should render a
  427 -- (BlockQuote List) as a list to maintain compatibility with other
  428 -- formats.
  429 blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do
  430   ps  <- blockToParagraphs blk
  431   ps' <- blockToParagraphs $ BlockQuote blks
  432   return $ ps ++ ps'
  433 blockToParagraphs (BlockQuote blks) =
  434   local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}
  435                 , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$
  436   concatMapM blockToParagraphs blks
  437 -- TODO: work out the format
  438 blockToParagraphs blk@(RawBlock _ _) = do addLogMessage $ BlockNotRendered blk
  439                                           return []
  440 blockToParagraphs (Header _ (ident, _, _) ils) = do
  441   -- Note that this function only deals with content blocks, so it
  442   -- will only touch headers that are above the current slide level --
  443   -- slides at or below the slidelevel will be taken care of by
  444   -- `blocksToSlide'`. We have the register anchors in both of them.
  445   registerAnchorId ident
  446   -- we set the subeader to bold
  447   parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $
  448               inlinesToParElems ils
  449   -- and give it a bit of space before it.
  450   return [Paragraph def{pPropSpaceBefore = Just 30} parElems]
  451 blockToParagraphs (BulletList blksLst) = do
  452   pProps <- asks envParaProps
  453   let lvl = pPropLevel pProps
  454   local (\env -> env{ envInList = True
  455                     , envParaProps = pProps{ pPropLevel = lvl + 1
  456                                            , pPropBullet = Just Bullet
  457                                            , pPropMarginLeft = Nothing
  458                                            }}) $
  459     concatMapM multiParBullet blksLst
  460 blockToParagraphs (OrderedList listAttr blksLst) = do
  461   pProps <- asks envParaProps
  462   let lvl = pPropLevel pProps
  463   local (\env -> env{ envInList = True
  464                     , envParaProps = pProps{ pPropLevel = lvl + 1
  465                                            , pPropBullet = Just (AutoNumbering listAttr)
  466                                            , pPropMarginLeft = Nothing
  467                                            }}) $
  468     concatMapM multiParBullet blksLst
  469 blockToParagraphs (DefinitionList entries) = do
  470   let go :: ([Inline], [[Block]]) -> Pres [Paragraph]
  471       go (ils, blksLst) = do
  472         term <-blockToParagraphs $ Para [Strong ils]
  473         -- For now, we'll treat each definition term as a
  474         -- blockquote. We can extend this further later.
  475         definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst
  476         return $ term ++ definition
  477   concatMapM go entries
  478 blockToParagraphs (Div _ blks)  = concatMapM blockToParagraphs blks
  479 blockToParagraphs blk = do
  480   addLogMessage $ BlockNotRendered blk
  481   return []
  482 
  483 -- Make sure the bullet env gets turned off after the first para.
  484 multiParBullet :: [Block] -> Pres [Paragraph]
  485 multiParBullet [] = return []
  486 multiParBullet (b:bs) = do
  487   pProps <- asks envParaProps
  488   p <- blockToParagraphs b
  489   ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $
  490     concatMapM blockToParagraphs bs
  491   return $ p ++ ps
  492 
  493 cellToParagraphs :: Alignment -> TableCell -> Pres [Paragraph]
  494 cellToParagraphs algn tblCell = do
  495   paras <- mapM blockToParagraphs tblCell
  496   let alignment = case algn of
  497         AlignLeft -> Just AlgnLeft
  498         AlignRight -> Just AlgnRight
  499         AlignCenter -> Just AlgnCenter
  500         AlignDefault -> Nothing
  501       paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras
  502   return $ concat paras'
  503 
  504 rowToParagraphs :: [Alignment] -> [TableCell] -> Pres [[Paragraph]]
  505 rowToParagraphs algns tblCells = do
  506   -- We have to make sure we have the right number of alignments
  507   let pairs = zip (algns ++ repeat AlignDefault) tblCells
  508   mapM (uncurry cellToParagraphs) pairs
  509 
  510 withAttr :: Attr -> Shape -> Shape
  511 withAttr attr (Pic picPr url caption) =
  512   let picPr' = picPr { picWidth = dimension Width attr
  513                      , picHeight = dimension Height attr
  514                      }
  515   in
  516     Pic picPr' url caption
  517 withAttr _ sp = sp
  518 
  519 blockToShape :: Block -> Pres Shape
  520 blockToShape (Plain ils) = blockToShape (Para ils)
  521 blockToShape (Para (il:_))  | Image attr ils (url, _) <- il =
  522       (withAttr attr . Pic def url) <$> inlinesToParElems ils
  523 blockToShape (Para (il:_))  | Link _ (il':_) target <- il
  524                             , Image attr ils (url, _) <- il' =
  525       (withAttr attr . Pic def{picPropLink = Just $ ExternalTarget target} url) <$>
  526       inlinesToParElems ils
  527 blockToShape (Table caption algn _ hdrCells rows) = do
  528   caption' <- inlinesToParElems caption
  529   hdrCells' <- rowToParagraphs algn hdrCells
  530   rows' <- mapM (rowToParagraphs algn) rows
  531   let tblPr = if null hdrCells
  532               then TableProps { tblPrFirstRow = False
  533                               , tblPrBandRow = True
  534                               }
  535               else TableProps { tblPrFirstRow = True
  536                               , tblPrBandRow = True
  537                               }
  538 
  539   return $ GraphicFrame [Tbl tblPr hdrCells' rows'] caption'
  540 -- If the format isn't openxml, we fall through to blockToPargraphs
  541 blockToShape (RawBlock (Format "openxml") str) = return $ RawOOXMLShape str
  542 blockToShape blk = do paras <- blockToParagraphs blk
  543                       let paras' = map (\par -> par{paraElems = combineParaElems $ paraElems par}) paras
  544                       return $ TextBox paras'
  545 
  546 combineShapes :: [Shape] -> [Shape]
  547 combineShapes [] = []
  548 combineShapes (pic@Pic{} : ss) = pic : combineShapes ss
  549 combineShapes (TextBox [] : ss) = combineShapes ss
  550 combineShapes (s : TextBox [] : ss) = combineShapes (s : ss)
  551 combineShapes (TextBox (p:ps) : TextBox (p':ps') : ss) =
  552   combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss
  553 combineShapes (s:ss) = s : combineShapes ss
  554 
  555 isNotesDiv :: Block -> Bool
  556 isNotesDiv (Div (_, ["notes"], _) _) = True
  557 isNotesDiv _ = False
  558 
  559 blocksToShapes :: [Block] -> Pres [Shape]
  560 blocksToShapes blks = combineShapes <$> mapM blockToShape blks
  561 
  562 isImage :: Inline -> Bool
  563 isImage Image{} = True
  564 isImage (Link _ (Image{} : _) _) = True
  565 isImage _ = False
  566 
  567 splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[Block]]
  568 splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur])
  569 splitBlocks' cur acc (HorizontalRule : blks) =
  570   splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks
  571 splitBlocks' cur acc (h@(Header n _ _) : blks) = do
  572   slideLevel <- asks envSlideLevel
  573   let (nts, blks') = span isNotesDiv blks
  574   case compare n slideLevel of
  575     LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [h : nts]) blks'
  576     EQ -> splitBlocks' (h:nts) (acc ++ (if null cur then [] else [cur])) blks'
  577     GT -> splitBlocks' (cur ++ (h:nts)) acc blks'
  578 -- `blockToParagraphs` treats Plain and Para the same, so we can save
  579 -- some code duplication by treating them the same here.
  580 splitBlocks' cur acc (Plain ils : blks) = splitBlocks' cur acc (Para ils : blks)
  581 splitBlocks' cur acc (Para (il:ils) : blks) | isImage il = do
  582   slideLevel <- asks envSlideLevel
  583   let (nts, blks') = if null ils
  584                      then span isNotesDiv blks
  585                      else ([], blks)
  586   case cur of
  587     [Header n _ _] | n == slideLevel ->
  588                             splitBlocks' []
  589                             (acc ++ [cur ++ [Para [il]] ++ nts])
  590                             (if null ils then blks' else Para ils : blks')
  591     _ -> splitBlocks' []
  592          (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]] ++ nts])
  593          (if null ils then blks' else Para ils : blks')
  594 splitBlocks' cur acc (tbl@Table{} : blks) = do
  595   slideLevel <- asks envSlideLevel
  596   let (nts, blks') = span isNotesDiv blks
  597   case cur of
  598     [Header n _ _] | n == slideLevel ->
  599                             splitBlocks' [] (acc ++ [cur ++ [tbl] ++ nts]) blks'
  600     _ ->  splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl] ++ nts]) blks'
  601 splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes =  do
  602   slideLevel <- asks envSlideLevel
  603   let (nts, blks') = span isNotesDiv blks
  604   case cur of
  605     [Header n _ _] | n == slideLevel ->
  606                             splitBlocks' [] (acc ++ [cur ++ [d] ++ nts]) blks'
  607     _ ->  splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d] ++ nts]) blks'
  608 splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks
  609 
  610 splitBlocks :: [Block] -> Pres [[Block]]
  611 splitBlocks = splitBlocks' [] []
  612 
  613 blocksToSlide' :: Int -> [Block] -> SpeakerNotes -> Pres Slide
  614 blocksToSlide' lvl (Header n (ident, _, _) ils : blks) spkNotes
  615   | n < lvl = do
  616       registerAnchorId ident
  617       sldId <- asks envCurSlideId
  618       hdr <- inlinesToParElems ils
  619       return $ Slide sldId (TitleSlide hdr) spkNotes
  620   | n == lvl = do
  621       registerAnchorId ident
  622       hdr <- inlinesToParElems ils
  623       -- Now get the slide without the header, and then add the header
  624       -- in.
  625       slide <- blocksToSlide' lvl blks spkNotes
  626       let layout = case slideLayout slide of
  627             ContentSlide _ cont          -> ContentSlide hdr cont
  628             TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR
  629             layout'                     -> layout'
  630       return $ slide{slideLayout = layout}
  631 blocksToSlide' _ (blk : blks) spkNotes
  632   | Div (_, classes, _) divBlks <- blk
  633   , "columns" `elem` classes
  634   , Div (_, clsL, _) blksL : Div (_, clsR, _) blksR : remaining <- divBlks
  635   , "column" `elem` clsL, "column" `elem` clsR = do
  636       mapM_ (addLogMessage . BlockNotRendered) (blks ++ remaining)
  637       mbSplitBlksL <- splitBlocks blksL
  638       mbSplitBlksR <- splitBlocks blksR
  639       let blksL' = case mbSplitBlksL of
  640             bs : _ -> bs
  641             []     -> []
  642       let blksR' = case mbSplitBlksR of
  643             bs : _ -> bs
  644             []     -> []
  645       shapesL <- blocksToShapes blksL'
  646       shapesR <- blocksToShapes blksR'
  647       sldId <- asks envCurSlideId
  648       return $ Slide
  649         sldId
  650         (TwoColumnSlide [] shapesL shapesR)
  651         spkNotes
  652 blocksToSlide' _ (blk : blks) spkNotes = do
  653       inNoteSlide <- asks envInNoteSlide
  654       shapes <- if inNoteSlide
  655                 then forceFontSize noteSize $ blocksToShapes (blk : blks)
  656                 else blocksToShapes (blk : blks)
  657       sldId <- asks envCurSlideId
  658       return $
  659         Slide
  660         sldId
  661         (ContentSlide [] shapes)
  662         spkNotes
  663 blocksToSlide' _ [] spkNotes = do
  664   sldId <- asks envCurSlideId
  665   return $
  666     Slide
  667     sldId
  668     (ContentSlide [] [])
  669     spkNotes
  670 
  671 blockToSpeakerNotes :: Block -> Pres SpeakerNotes
  672 blockToSpeakerNotes (Div (_, ["notes"], _) blks) =
  673   local (\env -> env{envInSpeakerNotes=True}) $
  674   SpeakerNotes <$> concatMapM blockToParagraphs blks
  675 blockToSpeakerNotes _ = return mempty
  676 
  677 handleSpeakerNotes :: Block -> Pres ()
  678 handleSpeakerNotes blk = do
  679   spNotes <- blockToSpeakerNotes blk
  680   modify $ \st -> st{stSpeakerNotes = (stSpeakerNotes st) <> spNotes}
  681 
  682 handleAndFilterSpeakerNotes' :: [Block] -> Pres [Block]
  683 handleAndFilterSpeakerNotes' blks = do
  684   mapM_ handleSpeakerNotes blks
  685   return $ filter (not . isNotesDiv) blks
  686 
  687 handleAndFilterSpeakerNotes :: [Block] -> Pres ([Block], SpeakerNotes)
  688 handleAndFilterSpeakerNotes blks = do
  689   modify $ \st -> st{stSpeakerNotes = mempty}
  690   blks' <- walkM handleAndFilterSpeakerNotes' blks
  691   spkNotes <- gets stSpeakerNotes
  692   return (blks', spkNotes)
  693 
  694 blocksToSlide :: [Block] -> Pres Slide
  695 blocksToSlide blks = do
  696   (blks', spkNotes) <- handleAndFilterSpeakerNotes blks
  697   slideLevel <- asks envSlideLevel
  698   blocksToSlide' slideLevel blks' spkNotes
  699 
  700 makeNoteEntry :: Int -> [Block] -> [Block]
  701 makeNoteEntry n blks =
  702   let enum = Str (show n ++ ".")
  703   in
  704     case blks of
  705       (Para ils : blks') -> (Para $ enum : Space : ils) : blks'
  706       _ -> Para [enum] : blks
  707 
  708 forceFontSize :: Pixels -> Pres a -> Pres a
  709 forceFontSize px x = do
  710   rpr <- asks envRunProps
  711   local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x
  712 
  713 -- We leave these as blocks because we will want to include them in
  714 -- the TOC.
  715 makeEndNotesSlideBlocks :: Pres [Block]
  716 makeEndNotesSlideBlocks = do
  717   noteIds <- gets stNoteIds
  718   slideLevel <- asks envSlideLevel
  719   exts <- writerExtensions <$> asks envOpts
  720   meta <- asks envMetadata
  721   -- Get identifiers so we can give the notes section a unique ident.
  722   anchorSet <- M.keysSet <$> gets stAnchorMap
  723   if M.null noteIds
  724     then return []
  725     else let title = case lookupMetaInlines "notes-title" meta of
  726                        [] -> [Str "Notes"]
  727                        ls -> ls
  728              ident = Shared.uniqueIdent exts title anchorSet
  729              hdr = Header slideLevel (ident, [], []) title
  730              blks = concatMap (\(n, bs) -> makeNoteEntry n bs) $
  731                     M.toList noteIds
  732          in return $ hdr : blks
  733 
  734 getMetaSlide :: Pres (Maybe Slide)
  735 getMetaSlide  = do
  736   meta <- asks envMetadata
  737   title <- inlinesToParElems $ docTitle meta
  738   subtitle <- inlinesToParElems $ lookupMetaInlines "subtitle" meta
  739   authors <- mapM inlinesToParElems $ docAuthors meta
  740   date <- inlinesToParElems $ docDate meta
  741   if null title && null subtitle && null authors && null date
  742     then return Nothing
  743     else return $
  744          Just $
  745          Slide
  746          metadataSlideId
  747          (MetadataSlide title subtitle authors date)
  748          mempty
  749 
  750 addSpeakerNotesToMetaSlide :: Slide -> [Block] -> Pres (Slide, [Block])
  751 addSpeakerNotesToMetaSlide (Slide sldId layout@(MetadataSlide _ _ _ _) spkNotes) blks =
  752   do let (ntsBlks, blks') = span isNotesDiv blks
  753      spkNotes' <- mconcat <$> mapM blockToSpeakerNotes ntsBlks
  754      return (Slide sldId layout (spkNotes <> spkNotes'), blks')
  755 addSpeakerNotesToMetaSlide sld blks = return (sld, blks)
  756 
  757 makeTOCSlide :: [Block] -> Pres Slide
  758 makeTOCSlide blks = local (\env -> env{envCurSlideId = tocSlideId}) $ do
  759   opts <- asks envOpts
  760   let contents = toTableOfContents opts blks
  761   meta <- asks envMetadata
  762   slideLevel <- asks envSlideLevel
  763   let tocTitle = case lookupMetaInlines "toc-title" meta of
  764                    [] -> [Str "Table of Contents"]
  765                    ls -> ls
  766       hdr = Header slideLevel nullAttr tocTitle
  767   blocksToSlide [hdr, contents]
  768 
  769 combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem]
  770 combineParaElems' mbPElem [] = maybeToList mbPElem
  771 combineParaElems' Nothing (pElem : pElems) =
  772   combineParaElems' (Just pElem) pElems
  773 combineParaElems' (Just pElem') (pElem : pElems)
  774   | Run rPr' s' <- pElem'
  775   , Run rPr s <- pElem
  776   , rPr == rPr' =
  777     combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems
  778   | otherwise =
  779     pElem' : combineParaElems' (Just pElem) pElems
  780 
  781 combineParaElems :: [ParaElem] -> [ParaElem]
  782 combineParaElems = combineParaElems' Nothing
  783 
  784 applyToParagraph :: Monad m => (ParaElem -> m ParaElem) -> Paragraph -> m Paragraph
  785 applyToParagraph f para = do
  786   paraElems' <- mapM f $ paraElems para
  787   return $ para {paraElems = paraElems'}
  788 
  789 applyToShape :: Monad m => (ParaElem -> m ParaElem) -> Shape -> m Shape
  790 applyToShape f (Pic pPr fp pes) = Pic pPr fp <$> mapM f pes
  791 applyToShape f (GraphicFrame gfx pes) = GraphicFrame gfx <$> mapM f pes
  792 applyToShape f (TextBox paras) = TextBox <$> mapM (applyToParagraph f) paras
  793 applyToShape _ (RawOOXMLShape str) = return $ RawOOXMLShape str
  794 
  795 applyToLayout :: Monad m => (ParaElem -> m ParaElem) -> Layout -> m Layout
  796 applyToLayout f (MetadataSlide title subtitle authors date) = do
  797   title' <- mapM f title
  798   subtitle' <- mapM f subtitle
  799   authors' <- mapM (mapM f) authors
  800   date' <- mapM f date
  801   return $ MetadataSlide title' subtitle' authors' date'
  802 applyToLayout f (TitleSlide title) = TitleSlide <$> mapM f title
  803 applyToLayout f (ContentSlide hdr content) = do
  804   hdr' <- mapM f hdr
  805   content' <- mapM (applyToShape f) content
  806   return $ ContentSlide hdr' content'
  807 applyToLayout f (TwoColumnSlide hdr contentL contentR) = do
  808   hdr' <- mapM f hdr
  809   contentL' <- mapM (applyToShape f) contentL
  810   contentR' <- mapM (applyToShape f) contentR
  811   return $ TwoColumnSlide hdr' contentL' contentR'
  812 
  813 applyToSlide :: Monad m => (ParaElem -> m ParaElem) -> Slide -> m Slide
  814 applyToSlide f slide = do
  815   layout' <- applyToLayout f $ slideLayout slide
  816   let paras = fromSpeakerNotes $ slideSpeakerNotes slide
  817   notes' <- SpeakerNotes <$> mapM (applyToParagraph f) paras
  818   return slide{slideLayout = layout', slideSpeakerNotes = notes'}
  819 
  820 replaceAnchor :: ParaElem -> Pres ParaElem
  821 replaceAnchor (Run rProps s)
  822   | Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do
  823       anchorMap <- gets stAnchorMap
  824       -- If the anchor is not in the anchormap, we just remove the
  825       -- link.
  826       let rProps' = case M.lookup anchor anchorMap of
  827                       Just n  -> rProps{rLink = Just $ InternalTarget n}
  828                       Nothing -> rProps{rLink = Nothing}
  829       return $ Run rProps' s
  830 replaceAnchor pe = return pe
  831 
  832 emptyParaElem :: ParaElem -> Bool
  833 emptyParaElem (Run _ s) =
  834   null $ Shared.trim s
  835 emptyParaElem (MathElem _ ts) =
  836   null $ Shared.trim $ unTeXString ts
  837 emptyParaElem _ = False
  838 
  839 emptyParagraph :: Paragraph -> Bool
  840 emptyParagraph para = all emptyParaElem $ paraElems para
  841 
  842 
  843 emptyShape :: Shape -> Bool
  844 emptyShape (TextBox paras) = all emptyParagraph paras
  845 emptyShape _ = False
  846 
  847 emptyLayout :: Layout -> Bool
  848 emptyLayout layout = case layout of
  849   MetadataSlide title subtitle authors date ->
  850     all emptyParaElem title &&
  851     all emptyParaElem subtitle &&
  852     all (all emptyParaElem) authors &&
  853     all emptyParaElem date
  854   TitleSlide hdr -> all emptyParaElem hdr
  855   ContentSlide hdr shapes ->
  856     all emptyParaElem hdr &&
  857     all emptyShape shapes
  858   TwoColumnSlide hdr shapes1 shapes2 ->
  859     all emptyParaElem hdr &&
  860     all emptyShape shapes1 &&
  861     all emptyShape shapes2
  862 
  863 emptySlide :: Slide -> Bool
  864 emptySlide (Slide _ layout notes) = (notes == mempty) && (emptyLayout layout)
  865 
  866 blocksToPresentationSlides :: [Block] -> Pres [Slide]
  867 blocksToPresentationSlides blks = do
  868   opts <- asks envOpts
  869   mbMetadataSlide <- getMetaSlide
  870   -- if the metadata slide exists, we try to add any speakerNotes
  871   -- which immediately follow it. We also convert from maybe to a
  872   -- list, so that it will be able to add together more easily with
  873   -- the other lists of slides.
  874   (metadataslides, blks') <- case mbMetadataSlide of
  875                                  Just sld ->
  876                                    do (s, bs) <- addSpeakerNotesToMetaSlide sld blks
  877                                       return ([s], bs)
  878                                  Nothing -> return ([], blks)
  879   -- As far as I can tell, if we want to have a variable-length toc in
  880   -- the future, we'll have to make it twice. Once to get the length,
  881   -- and a second time to include the notes slide. We can't make the
  882   -- notes slide before the body slides because we need to know if
  883   -- there are notes, and we can't make either before the toc slide,
  884   -- because we need to know its length to get slide numbers right.
  885   --
  886   -- For now, though, since the TOC slide is only length 1, if it
  887   -- exists, we'll just get the length, and then come back to make the
  888   -- slide later
  889   blksLst <- splitBlocks blks'
  890   bodySlideIds <- mapM
  891                   (\n -> runUniqueSlideId $ "BodySlide" ++ show n)
  892                   (take (length blksLst) [1..] :: [Integer])
  893   bodyslides <- mapM
  894                 (\(bs, ident) ->
  895                     local (\st -> st{envCurSlideId = ident}) (blocksToSlide bs))
  896                 (zip blksLst bodySlideIds)
  897   endNotesSlideBlocks <- makeEndNotesSlideBlocks
  898   -- now we come back and make the real toc...
  899   tocSlides <- if writerTableOfContents opts
  900                then do toc <- makeTOCSlide $ blks' ++ endNotesSlideBlocks
  901                        return [toc]
  902                else return []
  903   -- ... and the notes slide. We test to see if the blocks are empty,
  904   -- because we don't want to make an empty slide.
  905   endNotesSlides <- if null endNotesSlideBlocks
  906                     then return []
  907                     else do endNotesSlide <- local
  908                               (\env -> env { envCurSlideId = endNotesSlideId
  909                                            , envInNoteSlide = True
  910                                            })
  911                               (blocksToSlide endNotesSlideBlocks)
  912                             return [endNotesSlide]
  913 
  914   let slides = metadataslides ++ tocSlides ++ bodyslides ++ endNotesSlides
  915       slides' = filter (not . emptySlide) slides
  916   mapM (applyToSlide replaceAnchor) slides'
  917 
  918 metaToDocProps :: Meta -> DocProps
  919 metaToDocProps meta =
  920   let keywords = case lookupMeta "keywords" meta of
  921                    Just (MetaList xs) -> Just $ map Shared.stringify xs
  922                    _                  -> Nothing
  923 
  924       authors = case map Shared.stringify $ docAuthors meta of
  925                   [] -> Nothing
  926                   ss -> Just $ intercalate "; " ss
  927 
  928       description = case map Shared.stringify $ lookupMetaBlocks "description" meta of
  929                   [] -> Nothing
  930                   ss -> Just $ intercalate "_x000d_\n" ss
  931 
  932       customProperties' = case [(k, lookupMetaString k meta) | k <- M.keys (unMeta meta)
  933                                , k `notElem` (["title", "author", "keywords", "description"
  934                                              , "subject","lang","category"])] of
  935                   [] -> Nothing
  936                   ss -> Just ss
  937   in
  938     DocProps{ dcTitle = Shared.stringify <$> lookupMeta "title" meta
  939             , dcSubject = Shared.stringify <$> lookupMeta "subject" meta
  940             , dcCreator = authors
  941             , dcKeywords = keywords
  942             , dcDescription = description
  943             , cpCategory = Shared.stringify <$> lookupMeta "category" meta
  944             , dcCreated = Nothing
  945             , customProperties = customProperties'
  946             }
  947 
  948 documentToPresentation :: WriterOptions
  949                        -> Pandoc
  950                        -> (Presentation, [LogMessage])
  951 documentToPresentation opts (Pandoc meta blks) =
  952   let env = def { envOpts = opts
  953                 , envMetadata = meta
  954                 , envSlideLevel = fromMaybe (getSlideLevel blks) (writerSlideLevel opts)
  955                 }
  956       (presSlides, msgs) = runPres env def $ blocksToPresentationSlides blks
  957       docProps = metaToDocProps meta
  958   in
  959     (Presentation docProps presSlides, msgs)
  960 
  961 -- --------------------------------------------------------------
  962 
  963 applyTokStyToRunProps :: TokenStyle -> RunProps -> RunProps
  964 applyTokStyToRunProps tokSty rProps =
  965   rProps{ rSolidFill     = tokenColor tokSty <|> rSolidFill rProps
  966         , rPropBold      = tokenBold tokSty || rPropBold rProps
  967         , rPropItalics   = tokenItalic tokSty || rPropItalics rProps
  968         , rPropUnderline = tokenUnderline tokSty || rPropUnderline rProps
  969         }
  970 
  971 formatToken :: Style -> Token -> ParaElem
  972 formatToken sty (tokType, txt) =
  973   let rProps = def{rPropCode = True, rSolidFill = defaultColor sty}
  974       rProps' = case M.lookup tokType (tokenStyles sty) of
  975         Just tokSty -> applyTokStyToRunProps tokSty rProps
  976         Nothing     -> rProps
  977   in
  978     Run rProps' $ T.unpack txt
  979 
  980 formatSourceLine :: Style -> FormatOptions -> SourceLine -> [ParaElem]
  981 formatSourceLine sty _ srcLn = map (formatToken sty) srcLn
  982 
  983 formatSourceLines :: Style -> FormatOptions -> [SourceLine] -> [ParaElem]
  984 formatSourceLines sty opts srcLns = intercalate [Break] $
  985                                     map (formatSourceLine sty opts) srcLns