From b010113f3f63f5ca936942ba48a4ea823470ba8b Mon Sep 17 00:00:00 2001
From: Jesse Rosenthal <jrosenthal@jhu.edu>
Date: Mon, 15 Jan 2018 10:01:59 -0500
Subject: [PATCH] Powerpoint writer: Move Presentation.hs out of PandocMonad
We don't need it for anything but the log messages, and we can just
keep track of that in state and pass it along to the `writePowerpoint`
function. This will simplify the code.
---
src/Text/Pandoc/Writers/Powerpoint.hs | 5 +-
.../Pandoc/Writers/Powerpoint/Presentation.hs | 69 ++++++++++---------
2 files changed, 39 insertions(+), 35 deletions(-)
diff --git a/src/Text/Pandoc/Writers/Powerpoint.hs b/src/Text/Pandoc/Writers/Powerpoint.hs
index 3d6b736f2..acb33f582 100644
--- a/src/Text/Pandoc/Writers/Powerpoint.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint.hs
@@ -44,7 +44,7 @@ module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where
import Codec.Archive.Zip
import Text.Pandoc.Definition
import Text.Pandoc.Walk
-import Text.Pandoc.Class (PandocMonad)
+import Text.Pandoc.Class (PandocMonad, report)
import Text.Pandoc.Options (WriterOptions)
import Text.Pandoc.Writers.Shared (fixDisplayMath)
import Text.Pandoc.Writers.Powerpoint.Presentation (documentToPresentation)
@@ -57,6 +57,7 @@ writePowerpoint :: (PandocMonad m)
-> m BL.ByteString
writePowerpoint opts (Pandoc meta blks) = do
let blks' = walk fixDisplayMath blks
- pres <- documentToPresentation opts (Pandoc meta blks')
+ let (pres, logMsgs) = documentToPresentation opts (Pandoc meta blks')
+ mapM_ report logMsgs
archv <- presentationToArchive opts pres
return $ fromArchive archv
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
index 5ced4e8a8..3c5dd617d 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
@@ -58,9 +58,7 @@ 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
@@ -97,17 +95,23 @@ instance Default WriterEnv where
data WriterState = WriterState { stNoteIds :: M.Map Int [Block]
-- associate anchors with slide id
, stAnchorMap :: M.Map String Int
+ , stLog :: [LogMessage]
} deriving (Show, Eq)
instance Default WriterState where
def = WriterState { stNoteIds = mempty
- , stAnchorMap= mempty
+ , stAnchorMap = mempty
+ , stLog = []
}
-type Pres m = ReaderT WriterEnv (StateT WriterState m)
+addLogMessage :: LogMessage -> Pres ()
+addLogMessage msg = modify $ \st -> st{stLog = msg : (stLog st)}
-runPres :: Monad m => WriterEnv -> WriterState -> Pres m a -> m a
-runPres env st p = evalStateT (runReaderT p env) st
+type Pres = ReaderT WriterEnv (State WriterState)
+
+runPres :: WriterEnv -> WriterState -> Pres a -> (a, [LogMessage])
+runPres env st p = (pres, reverse $ stLog finalSt)
+ where (pres, finalSt) = runState (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.
@@ -234,10 +238,10 @@ instance Default PicProps where
--------------------------------------------------
-inlinesToParElems :: Monad m => [Inline] -> Pres m [ParaElem]
+inlinesToParElems :: [Inline] -> Pres [ParaElem]
inlinesToParElems ils = concatMapM inlineToParElems ils
-inlineToParElems :: Monad m => Inline -> Pres m [ParaElem]
+inlineToParElems :: Inline -> Pres [ParaElem]
inlineToParElems (Str s) = do
pr <- asks envRunProps
return [Run pr s]
@@ -288,7 +292,7 @@ isListType (BulletList _) = True
isListType (DefinitionList _) = True
isListType _ = False
-registerAnchorId :: PandocMonad m => String -> Pres m ()
+registerAnchorId :: String -> Pres ()
registerAnchorId anchor = do
anchorMap <- gets stAnchorMap
slideId <- asks envCurSlideId
@@ -302,7 +306,7 @@ blockQuoteSize = 20
noteSize :: Pixels
noteSize = 18
-blockToParagraphs :: PandocMonad m => Block -> Pres m [Paragraph]
+blockToParagraphs :: Block -> Pres [Paragraph]
blockToParagraphs (Plain ils) = do
parElems <- inlinesToParElems ils
pProps <- asks envParaProps
@@ -362,7 +366,7 @@ blockToParagraphs (OrderedList listAttr blksLst) = do
}}) $
concatMapM multiParBullet blksLst
blockToParagraphs (DefinitionList entries) = do
- let go :: PandocMonad m => ([Inline], [[Block]]) -> Pres m [Paragraph]
+ let go :: ([Inline], [[Block]]) -> Pres [Paragraph]
go (ils, blksLst) = do
term <-blockToParagraphs $ Para [Strong ils]
-- For now, we'll treat each definition term as a
@@ -373,11 +377,11 @@ blockToParagraphs (DefinitionList entries) = do
blockToParagraphs (Div (_, ("notes" : []), _) _) = return []
blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks
blockToParagraphs blk = do
- P.report $ BlockNotRendered blk
+ addLogMessage $ BlockNotRendered blk
return []
-- Make sure the bullet env gets turned off after the first para.
-multiParBullet :: PandocMonad m => [Block] -> Pres m [Paragraph]
+multiParBullet :: [Block] -> Pres [Paragraph]
multiParBullet [] = return []
multiParBullet (b:bs) = do
pProps <- asks envParaProps
@@ -386,7 +390,7 @@ multiParBullet (b:bs) = do
concatMapM blockToParagraphs bs
return $ p ++ ps
-cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> Pres m [Paragraph]
+cellToParagraphs :: Alignment -> TableCell -> Pres [Paragraph]
cellToParagraphs algn tblCell = do
paras <- mapM (blockToParagraphs) tblCell
let alignment = case algn of
@@ -397,13 +401,13 @@ cellToParagraphs algn tblCell = do
paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras
return $ concat paras'
-rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> Pres m [[Paragraph]]
+rowToParagraphs :: [Alignment] -> [TableCell] -> Pres [[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 :: Block -> Pres Shape
blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il =
Pic def url attr <$> (inlinesToParElems ils)
blockToShape (Para (il:_)) | Image attr ils (url, _) <- il =
@@ -441,7 +445,7 @@ 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 :: [Block] -> Pres [Shape]
blocksToShapes blks = combineShapes <$> mapM blockToShape blks
isImage :: Inline -> Bool
@@ -449,7 +453,7 @@ isImage (Image _ _ _) = True
isImage (Link _ ((Image _ _ _) : _) _) = True
isImage _ = False
-splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> Pres m [[Block]]
+splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[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
@@ -486,10 +490,10 @@ splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classe
_ -> 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 :: [Block] -> Pres [[Block]]
splitBlocks = splitBlocks' [] []
-blocksToSlide' :: PandocMonad m => Int -> [Block] -> Pres m Slide
+blocksToSlide' :: Int -> [Block] -> Pres Slide
blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)
| n < lvl = do
registerAnchorId ident
@@ -511,9 +515,9 @@ blocksToSlide' _ (blk : blks)
, (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks
, "column" `elem` clsL, "column" `elem` clsR = do
unless (null blks)
- (mapM (P.report . BlockNotRendered) blks >> return ())
+ (mapM (addLogMessage . BlockNotRendered) blks >> return ())
unless (null remaining)
- (mapM (P.report . BlockNotRendered) remaining >> return ())
+ (mapM (addLogMessage . BlockNotRendered) remaining >> return ())
mbSplitBlksL <- splitBlocks blksL
mbSplitBlksR <- splitBlocks blksR
let blksL' = case mbSplitBlksL of
@@ -540,7 +544,7 @@ blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []
, contentSlideContent = []
}
-blocksToSlide :: PandocMonad m => [Block] -> Pres m Slide
+blocksToSlide :: [Block] -> Pres Slide
blocksToSlide blks = do
slideLevel <- asks envSlideLevel
blocksToSlide' slideLevel blks
@@ -553,14 +557,14 @@ makeNoteEntry n blks =
(Para ils : blks') -> (Para $ enum : Space : ils) : blks'
_ -> (Para [enum]) : blks
-forceFontSize :: PandocMonad m => Pixels -> Pres m a -> Pres m a
+forceFontSize :: Pixels -> Pres a -> Pres 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 :: Pres [Block]
makeNotesSlideBlocks = do
noteIds <- gets stNoteIds
slideLevel <- asks envSlideLevel
@@ -579,7 +583,7 @@ makeNotesSlideBlocks = do
M.toList noteIds
return $ hdr : blks
-getMetaSlide :: PandocMonad m => Pres m (Maybe Slide)
+getMetaSlide :: Pres (Maybe Slide)
getMetaSlide = do
meta <- asks envMetadata
title <- inlinesToParElems $ docTitle meta
@@ -600,7 +604,7 @@ getMetaSlide = do
, metadataSlideDate = date
}
-- adapted from the markdown writer
-elementToListItem :: PandocMonad m => Shared.Element -> Pres m [Block]
+elementToListItem :: Shared.Element -> Pres [Block]
elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do
opts <- asks envOpts
let headerLink = if null ident
@@ -613,7 +617,7 @@ elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do
return [Plain headerLink, BulletList listContents]
elementToListItem (Shared.Blk _) = return []
-makeTOCSlide :: PandocMonad m => [Block] -> Pres m Slide
+makeTOCSlide :: [Block] -> Pres Slide
makeTOCSlide blks = do
contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks)
meta <- asks envMetadata
@@ -676,7 +680,7 @@ applyToSlide f (TwoColumnSlide hdr contentL contentR) = do
contentR' <- mapM (applyToShape f) contentR
return $ TwoColumnSlide hdr' contentL' contentR'
-replaceAnchor :: PandocMonad m => ParaElem -> Pres m ParaElem
+replaceAnchor :: ParaElem -> Pres ParaElem
replaceAnchor (Run rProps s)
| Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do
anchorMap <- gets stAnchorMap
@@ -688,7 +692,7 @@ replaceAnchor (Run rProps s)
return $ Run rProps' s
replaceAnchor pe = return pe
-blocksToPresentation :: PandocMonad m => [Block] -> Pres m Presentation
+blocksToPresentation :: [Block] -> Pres Presentation
blocksToPresentation blks = do
opts <- asks envOpts
let metadataStartNum = 1
@@ -732,10 +736,9 @@ blocksToPresentation blks = do
slides' <- mapM (applyToSlide replaceAnchor) slides
return $ Presentation slides'
-documentToPresentation :: PandocMonad m
- => WriterOptions
+documentToPresentation :: WriterOptions
-> Pandoc
- -> m Presentation
+ -> (Presentation, [LogMessage])
documentToPresentation opts (Pandoc meta blks) = do
let env = def { envOpts = opts
, envMetadata = meta