b010113 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Powerpoint writer: Move Presentation.hs out of PandocMonad

b010113Jesse Rosenthal9 years ago

src/Text/Pandoc/Writers/Powerpoint.hs+3−2

compare with master

unifiedsplit

@@ -44,7 +44,7 @@ module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where

44import Codec.Archive.Zip

45import Text.Pandoc.Definition

46import Text.Pandoc.Walk

47−import Text.Pandoc.Class (PandocMonad)

47+import Text.Pandoc.Class (PandocMonad, report)

48import Text.Pandoc.Options (WriterOptions)

49import Text.Pandoc.Writers.Shared (fixDisplayMath)

50import Text.Pandoc.Writers.Powerpoint.Presentation (documentToPresentation)

@@ -57,6 +57,7 @@ writePowerpoint :: (PandocMonad m)

57 -> m BL.ByteString

58writePowerpoint opts (Pandoc meta blks) = do

59 let blks' = walk fixDisplayMath blks

60− pres <- documentToPresentation opts (Pandoc meta blks')

60+ let (pres, logMsgs) = documentToPresentation opts (Pandoc meta blks')

61+ mapM_ report logMsgs

61 archv <- presentationToArchive opts pres

62 archv <- presentationToArchive opts pres

62 return $ fromArchive archv

63 return $ fromArchive archv

src/Text/Pandoc/Writers/Powerpoint/Presentation.hs+36−33

@@ -58,9 +58,7 @@ import Control.Monad.State

58import Data.List (intercalate)

59import Data.Default

60import Text.Pandoc.Definition

61−import Text.Pandoc.Class (PandocMonad)

62import Text.Pandoc.Slides (getSlideLevel)

61import Text.Pandoc.Slides (getSlideLevel)

63−import qualified Text.Pandoc.Class as P

64import Text.Pandoc.Options

62import Text.Pandoc.Options

65import Text.Pandoc.Logging

63import Text.Pandoc.Logging

66import Text.Pandoc.Walk

64import Text.Pandoc.Walk

@@ -97,17 +95,23 @@ instance Default WriterEnv where

97data WriterState = WriterState { stNoteIds :: M.Map Int [Block]

95data WriterState = WriterState { stNoteIds :: M.Map Int [Block]

98 -- associate anchors with slide id

96 -- associate anchors with slide id

99 , stAnchorMap :: M.Map String Int

97 , stAnchorMap :: M.Map String Int

98+ , stLog :: [LogMessage]

100 } deriving (Show, Eq)

99 } deriving (Show, Eq)

101

100

102instance Default WriterState where

101instance Default WriterState where

103 def = WriterState { stNoteIds = mempty

102 def = WriterState { stNoteIds = mempty

104− , stAnchorMap= mempty

103+ , stAnchorMap = mempty

104+ , stLog = []

105 }

106

107−type Pres m = ReaderT WriterEnv (StateT WriterState m)

107+addLogMessage :: LogMessage -> Pres ()

108+addLogMessage msg = modify $ \st -> st{stLog = msg : (stLog st)}

108

109

110+type Pres = ReaderT WriterEnv (State WriterState)

111+

109−runPres :: Monad m => WriterEnv -> WriterState -> Pres m a -> m a

112+runPres :: WriterEnv -> WriterState -> Pres a -> (a, [LogMessage])

113+runPres env st p = (pres, reverse $ stLog finalSt)

110−runPres env st p = evalStateT (runReaderT p env) st

114+ where (pres, finalSt) = runState (runReaderT p env) st

111

115

112-- GHC 7.8 will still complain about concat <$> mapM unless we specify

116-- GHC 7.8 will still complain about concat <$> mapM unless we specify

113-- Functor. We can get rid of this when we stop supporting GHC 7.8.

117-- Functor. We can get rid of this when we stop supporting GHC 7.8.

@@ -234,10 +238,10 @@ instance Default PicProps where

234

238

235--------------------------------------------------

239--------------------------------------------------

236

240

237−inlinesToParElems :: Monad m => [Inline] -> Pres m [ParaElem]

241+inlinesToParElems :: [Inline] -> Pres [ParaElem]

238inlinesToParElems ils = concatMapM inlineToParElems ils

242inlinesToParElems ils = concatMapM inlineToParElems ils

239

243

240−inlineToParElems :: Monad m => Inline -> Pres m [ParaElem]

244+inlineToParElems :: Inline -> Pres [ParaElem]

241inlineToParElems (Str s) = do

245inlineToParElems (Str s) = do

242 pr <- asks envRunProps

246 pr <- asks envRunProps

243 return [Run pr s]

247 return [Run pr s]

@@ -288,7 +292,7 @@ isListType (BulletList _) = True

288isListType (DefinitionList _) = True

292isListType (DefinitionList _) = True

289isListType _ = False

293isListType _ = False

290

294

291−registerAnchorId :: PandocMonad m => String -> Pres m ()

295+registerAnchorId :: String -> Pres ()

292registerAnchorId anchor = do

296registerAnchorId anchor = do

293 anchorMap <- gets stAnchorMap

297 anchorMap <- gets stAnchorMap

294 slideId <- asks envCurSlideId

298 slideId <- asks envCurSlideId

@@ -302,7 +306,7 @@ blockQuoteSize = 20

302noteSize :: Pixels

306noteSize :: Pixels

303noteSize = 18

307noteSize = 18

304

308

305−blockToParagraphs :: PandocMonad m => Block -> Pres m [Paragraph]

309+blockToParagraphs :: Block -> Pres [Paragraph]

306blockToParagraphs (Plain ils) = do

310blockToParagraphs (Plain ils) = do

307 parElems <- inlinesToParElems ils

311 parElems <- inlinesToParElems ils

308 pProps <- asks envParaProps

312 pProps <- asks envParaProps

@@ -362,7 +366,7 @@ blockToParagraphs (OrderedList listAttr blksLst) = do

362 }}) $

366 }}) $

363 concatMapM multiParBullet blksLst

367 concatMapM multiParBullet blksLst

364blockToParagraphs (DefinitionList entries) = do

368blockToParagraphs (DefinitionList entries) = do

365− let go :: PandocMonad m => ([Inline], [[Block]]) -> Pres m [Paragraph]

369+ let go :: ([Inline], [[Block]]) -> Pres [Paragraph]

366 go (ils, blksLst) = do

370 go (ils, blksLst) = do

367 term <-blockToParagraphs $ Para [Strong ils]

371 term <-blockToParagraphs $ Para [Strong ils]

368 -- For now, we'll treat each definition term as a

372 -- For now, we'll treat each definition term as a

@@ -373,11 +377,11 @@ blockToParagraphs (DefinitionList entries) = do

373blockToParagraphs (Div (_, ("notes" : []), _) _) = return []

377blockToParagraphs (Div (_, ("notes" : []), _) _) = return []

374blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks

378blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks

375blockToParagraphs blk = do

379blockToParagraphs blk = do

376− P.report $ BlockNotRendered blk

380+ addLogMessage $ BlockNotRendered blk

377 return []

381 return []

378

382

379-- Make sure the bullet env gets turned off after the first para.

383-- Make sure the bullet env gets turned off after the first para.

380−multiParBullet :: PandocMonad m => [Block] -> Pres m [Paragraph]

384+multiParBullet :: [Block] -> Pres [Paragraph]

381multiParBullet [] = return []

385multiParBullet [] = return []

382multiParBullet (b:bs) = do

386multiParBullet (b:bs) = do

383 pProps <- asks envParaProps

387 pProps <- asks envParaProps

@@ -386,7 +390,7 @@ multiParBullet (b:bs) = do

386 concatMapM blockToParagraphs bs

390 concatMapM blockToParagraphs bs

387 return $ p ++ ps

391 return $ p ++ ps

388

392

389−cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> Pres m [Paragraph]

393+cellToParagraphs :: Alignment -> TableCell -> Pres [Paragraph]

390cellToParagraphs algn tblCell = do

394cellToParagraphs algn tblCell = do

391 paras <- mapM (blockToParagraphs) tblCell

395 paras <- mapM (blockToParagraphs) tblCell

392 let alignment = case algn of

396 let alignment = case algn of

@@ -397,13 +401,13 @@ cellToParagraphs algn tblCell = do

397 paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras

401 paras' = map (map (\p -> p{paraProps = (paraProps p){pPropAlign = alignment}})) paras

398 return $ concat paras'

402 return $ concat paras'

399

403

400−rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> Pres m [[Paragraph]]

404+rowToParagraphs :: [Alignment] -> [TableCell] -> Pres [[Paragraph]]

401rowToParagraphs algns tblCells = do

405rowToParagraphs algns tblCells = do

402 -- We have to make sure we have the right number of alignments

406 -- We have to make sure we have the right number of alignments

403 let pairs = zip (algns ++ repeat AlignDefault) tblCells

407 let pairs = zip (algns ++ repeat AlignDefault) tblCells

404 mapM (\(a, tc) -> cellToParagraphs a tc) pairs

408 mapM (\(a, tc) -> cellToParagraphs a tc) pairs

405

409

406−blockToShape :: PandocMonad m => Block -> Pres m Shape

410+blockToShape :: Block -> Pres Shape

407blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il =

411blockToShape (Plain (il:_)) | Image attr ils (url, _) <- il =

408 Pic def url attr <$> (inlinesToParElems ils)

412 Pic def url attr <$> (inlinesToParElems ils)

409blockToShape (Para (il:_)) | Image attr ils (url, _) <- il =

413blockToShape (Para (il:_)) | Image attr ils (url, _) <- il =

@@ -441,7 +445,7 @@ combineShapes ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) =

441 combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss

445 combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss

442combineShapes (s:ss) = s : combineShapes ss

446combineShapes (s:ss) = s : combineShapes ss

443

447

444−blocksToShapes :: PandocMonad m => [Block] -> Pres m [Shape]

448+blocksToShapes :: [Block] -> Pres [Shape]

445blocksToShapes blks = combineShapes <$> mapM blockToShape blks

449blocksToShapes blks = combineShapes <$> mapM blockToShape blks

446

450

447isImage :: Inline -> Bool

451isImage :: Inline -> Bool

@@ -449,7 +453,7 @@ isImage (Image _ _ _) = True

449isImage (Link _ ((Image _ _ _) : _) _) = True

453isImage (Link _ ((Image _ _ _) : _) _) = True

450isImage _ = False

454isImage _ = False

451

455

452−splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> Pres m [[Block]]

456+splitBlocks' :: [Block] -> [[Block]] -> [Block] -> Pres [[Block]]

453splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur])

457splitBlocks' cur acc [] = return $ acc ++ (if null cur then [] else [cur])

454splitBlocks' cur acc (HorizontalRule : blks) =

458splitBlocks' cur acc (HorizontalRule : blks) =

455 splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks

459 splitBlocks' [] (acc ++ (if null cur then [] else [cur])) blks

@@ -486,10 +490,10 @@ splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classe

486 _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks

490 _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[d]]) blks

487splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks

491splitBlocks' cur acc (blk : blks) = splitBlocks' (cur ++ [blk]) acc blks

488

492

489−splitBlocks :: Monad m => [Block] -> Pres m [[Block]]

493+splitBlocks :: [Block] -> Pres [[Block]]

490splitBlocks = splitBlocks' [] []

494splitBlocks = splitBlocks' [] []

491

495

492−blocksToSlide' :: PandocMonad m => Int -> [Block] -> Pres m Slide

496+blocksToSlide' :: Int -> [Block] -> Pres Slide

493blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)

497blocksToSlide' lvl ((Header n (ident, _, _) ils) : blks)

494 | n < lvl = do

498 | n < lvl = do

495 registerAnchorId ident

499 registerAnchorId ident

@@ -511,9 +515,9 @@ blocksToSlide' _ (blk : blks)

511 , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks

515 , (Div (_, clsL, _) blksL) : (Div (_, clsR, _) blksR) : remaining <- divBlks

512 , "column" `elem` clsL, "column" `elem` clsR = do

516 , "column" `elem` clsL, "column" `elem` clsR = do

513 unless (null blks)

517 unless (null blks)

514− (mapM (P.report . BlockNotRendered) blks >> return ())

518+ (mapM (addLogMessage . BlockNotRendered) blks >> return ())

515 unless (null remaining)

519 unless (null remaining)

516− (mapM (P.report . BlockNotRendered) remaining >> return ())

520+ (mapM (addLogMessage . BlockNotRendered) remaining >> return ())

517 mbSplitBlksL <- splitBlocks blksL

521 mbSplitBlksL <- splitBlocks blksL

518 mbSplitBlksR <- splitBlocks blksR

522 mbSplitBlksR <- splitBlocks blksR

519 let blksL' = case mbSplitBlksL of

523 let blksL' = case mbSplitBlksL of

@@ -540,7 +544,7 @@ blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []

540 , contentSlideContent = []

544 , contentSlideContent = []

541 }

545 }

542

546

543−blocksToSlide :: PandocMonad m => [Block] -> Pres m Slide

547+blocksToSlide :: [Block] -> Pres Slide

544blocksToSlide blks = do

548blocksToSlide blks = do

545 slideLevel <- asks envSlideLevel

549 slideLevel <- asks envSlideLevel

546 blocksToSlide' slideLevel blks

550 blocksToSlide' slideLevel blks

@@ -553,14 +557,14 @@ makeNoteEntry n blks =

553 (Para ils : blks') -> (Para $ enum : Space : ils) : blks'

557 (Para ils : blks') -> (Para $ enum : Space : ils) : blks'

554 _ -> (Para [enum]) : blks

558 _ -> (Para [enum]) : blks

555

559

556−forceFontSize :: PandocMonad m => Pixels -> Pres m a -> Pres m a

560+forceFontSize :: Pixels -> Pres a -> Pres a

557forceFontSize px x = do

561forceFontSize px x = do

558 rpr <- asks envRunProps

562 rpr <- asks envRunProps

559 local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x

563 local (\r -> r {envRunProps = rpr{rPropForceSize = Just px}}) x

560

564

561-- We leave these as blocks because we will want to include them in

565-- We leave these as blocks because we will want to include them in

562-- the TOC.

566-- the TOC.

563−makeNotesSlideBlocks :: PandocMonad m => Pres m [Block]

567+makeNotesSlideBlocks :: Pres [Block]

564makeNotesSlideBlocks = do

568makeNotesSlideBlocks = do

565 noteIds <- gets stNoteIds

569 noteIds <- gets stNoteIds

566 slideLevel <- asks envSlideLevel

570 slideLevel <- asks envSlideLevel

@@ -579,7 +583,7 @@ makeNotesSlideBlocks = do

579 M.toList noteIds

583 M.toList noteIds

580 return $ hdr : blks

584 return $ hdr : blks

581

585

582−getMetaSlide :: PandocMonad m => Pres m (Maybe Slide)

586+getMetaSlide :: Pres (Maybe Slide)

583getMetaSlide = do

587getMetaSlide = do

584 meta <- asks envMetadata

588 meta <- asks envMetadata

585 title <- inlinesToParElems $ docTitle meta

589 title <- inlinesToParElems $ docTitle meta

@@ -600,7 +604,7 @@ getMetaSlide = do

600 , metadataSlideDate = date

604 , metadataSlideDate = date

601 }

605 }

602-- adapted from the markdown writer

606-- adapted from the markdown writer

603−elementToListItem :: PandocMonad m => Shared.Element -> Pres m [Block]

607+elementToListItem :: Shared.Element -> Pres [Block]

604elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do

608elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do

605 opts <- asks envOpts

609 opts <- asks envOpts

606 let headerLink = if null ident

610 let headerLink = if null ident

@@ -613,7 +617,7 @@ elementToListItem (Shared.Sec lev _nums (ident,_,_) headerText subsecs) = do

613 return [Plain headerLink, BulletList listContents]

617 return [Plain headerLink, BulletList listContents]

614elementToListItem (Shared.Blk _) = return []

618elementToListItem (Shared.Blk _) = return []

615

619

616−makeTOCSlide :: PandocMonad m => [Block] -> Pres m Slide

620+makeTOCSlide :: [Block] -> Pres Slide

617makeTOCSlide blks = do

621makeTOCSlide blks = do

618 contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks)

622 contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks)

619 meta <- asks envMetadata

623 meta <- asks envMetadata

@@ -676,7 +680,7 @@ applyToSlide f (TwoColumnSlide hdr contentL contentR) = do

676 contentR' <- mapM (applyToShape f) contentR

680 contentR' <- mapM (applyToShape f) contentR

677 return $ TwoColumnSlide hdr' contentL' contentR'

681 return $ TwoColumnSlide hdr' contentL' contentR'

678

682

679−replaceAnchor :: PandocMonad m => ParaElem -> Pres m ParaElem

683+replaceAnchor :: ParaElem -> Pres ParaElem

680replaceAnchor (Run rProps s)

684replaceAnchor (Run rProps s)

681 | Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do

685 | Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do

682 anchorMap <- gets stAnchorMap

686 anchorMap <- gets stAnchorMap

@@ -688,7 +692,7 @@ replaceAnchor (Run rProps s)

688 return $ Run rProps' s

692 return $ Run rProps' s

689replaceAnchor pe = return pe

693replaceAnchor pe = return pe

690

694

691−blocksToPresentation :: PandocMonad m => [Block] -> Pres m Presentation

695+blocksToPresentation :: [Block] -> Pres Presentation

692blocksToPresentation blks = do

696blocksToPresentation blks = do

693 opts <- asks envOpts

697 opts <- asks envOpts

694 let metadataStartNum = 1

698 let metadataStartNum = 1

@@ -732,10 +736,9 @@ blocksToPresentation blks = do

732 slides' <- mapM (applyToSlide replaceAnchor) slides

736 slides' <- mapM (applyToSlide replaceAnchor) slides

733 return $ Presentation slides'

737 return $ Presentation slides'

734

738

735−documentToPresentation :: PandocMonad m

739+documentToPresentation :: WriterOptions

736− => WriterOptions

737 -> Pandoc

740 -> Pandoc

738− -> m Presentation

741+ -> (Presentation, [LogMessage])

739documentToPresentation opts (Pandoc meta blks) = do

742documentToPresentation opts (Pandoc meta blks) = do

740 let env = def { envOpts = opts

743 let env = def { envOpts = opts

741 , envMetadata = meta

744 , envMetadata = meta