431f616 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Powerpoint writer: Refactor into separate modules.

431f616Jesse Rosenthal9 years ago

pandoc.cabal+2

compare with master

unifiedsplit

@@ -527,6 +527,8 @@ library

527 Text.Pandoc.Readers.Org.ParserState,

528 Text.Pandoc.Readers.Org.Parsing,

529 Text.Pandoc.Readers.Org.Shared,

530+ Text.Pandoc.Writers.Powerpoint.Presentation,

531+ Text.Pandoc.Writers.Powerpoint.Output,

530 Text.Pandoc.Lua.Filter,

532 Text.Pandoc.Lua.Filter,

531 Text.Pandoc.Lua.Init,

533 Text.Pandoc.Lua.Init,

532 Text.Pandoc.Lua.Module.MediaBag,

534 Text.Pandoc.Lua.Module.MediaBag,

src/Text/Pandoc/Writers/Powerpoint.hs+19−1979

@@ -1,4 +1,4 @@

1−{-# LANGUAGE PatternGuards, MultiWayIf, OverloadedStrings #-}

1+{-# LANGUAGE PatternGuards #-}

3{-

@@ -27,44 +27,29 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

27 Stability : alpha

28 Portability : portable

30−Conversion of 'Pandoc' documents to powerpoint (pptx).

30+Conversion of 'Pandoc' documents to powerpoint (pptx). -}

31+

32+{-

33+This is a wrapper around two modules:

34+

35+ - Text.Pandoc.Writers.Powerpoint.Presentation (which converts a

36+ pandoc document into a Presentation datatype), and

37+

38+ - Text.Pandoc.Writers.Powerpoint.Output (which converts a

39+ Presentation into a zip archive, which can be output).

31-}

40-}

33module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where

42module Text.Pandoc.Writers.Powerpoint (writePowerpoint) where

35−import Control.Monad.Except (throwError, catchError)

36−import Control.Monad.Reader

37−import Control.Monad.State

38import Codec.Archive.Zip

44import Codec.Archive.Zip

39−import Data.List (intercalate, stripPrefix, nub, union)

40−import Data.Default

41−import Data.Time.Clock (UTCTime)

42−import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)

43−import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)

44−import Text.XML.Light

45import Text.Pandoc.Definition

46−import qualified Text.Pandoc.UTF8 as UTF8

46+import Text.Pandoc.Walk

47import Text.Pandoc.Class (PandocMonad)

48−import Text.Pandoc.Error (PandocError(..))

48+import Text.Pandoc.Options (WriterOptions)

49−import Text.Pandoc.Slides (getSlideLevel)

50−import qualified Text.Pandoc.Class as P

51−import Text.Pandoc.Options

52−import Text.Pandoc.MIME

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

53−import Text.Pandoc.Logging

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

51+import Text.Pandoc.Writers.Powerpoint.Output (presentationToArchive)

54import qualified Data.ByteString.Lazy as BL

52import qualified Data.ByteString.Lazy as BL

55−import Text.Pandoc.Walk

56−import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"

57−import Text.Pandoc.Writers.Shared (fixDisplayMath, metaValueToInlines)

58−import Text.Pandoc.Writers.OOXML

59−import qualified Data.Map as M

60−import Data.Maybe (mapMaybe, listToMaybe, maybeToList, catMaybes)

61−import Text.Pandoc.ImageSize

62−import Control.Applicative ((<|>))

63−import System.FilePath.Glob

64−

65−import Text.TeXMath

66−import Text.Pandoc.Writers.Math (convertMath)

67−

69writePowerpoint :: (PandocMonad m)

54writePowerpoint :: (PandocMonad m)

70 => WriterOptions -- ^ Writer options

55 => WriterOptions -- ^ Writer options

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

72 -> m BL.ByteString

57 -> m BL.ByteString

73writePowerpoint opts (Pandoc meta blks) = do

58writePowerpoint opts (Pandoc meta blks) = do

74 let blks' = walk fixDisplayMath blks

59 let blks' = walk fixDisplayMath blks

75− distArchive <- (toArchive . BL.fromStrict) <$>

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

76− P.readDefaultDataFile "reference.pptx"

61+ archv <- presentationToArchive opts pres

77− refArchive <- case writerReferenceDoc opts of

62+ return $ fromArchive archv

78− Just f -> toArchive <$> P.readFileLazy f

79− Nothing -> (toArchive . BL.fromStrict) <$>

80− P.readDataFile "reference.pptx"

81−

82− utctime <- P.getCurrentTime

83−

84− presSize <- case getPresentationSize refArchive distArchive of

85− Just sz -> return sz

86− Nothing -> throwError $

87− PandocSomeError $

88− "Could not determine presentation size"

89−

90− let env = def { envMetadata = meta

91− , envRefArchive = refArchive

92− , envDistArchive = distArchive

93− , envUTCTime = utctime

94− , envOpts = opts

95− , envSlideLevel = case writerSlideLevel opts of

96− Just n -> n

97− Nothing -> getSlideLevel blks'

98− , envPresentationSize = presSize

99− }

100−

101− let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive

102− }

103−

104− runP env st $ do pres <- blocksToPresentation blks'

105− archv <- presentationToArchive pres

106− return $ fromArchive archv

107−

108−concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]

109−concatMapM f xs = liftM concat (mapM f xs)

110−

111−data WriterEnv = WriterEnv { envMetadata :: Meta

112− , envRunProps :: RunProps

113− , envParaProps :: ParaProps

114− , envSlideLevel :: Int

115− , envRefArchive :: Archive

116− , envDistArchive :: Archive

117− , envUTCTime :: UTCTime

118− , envOpts :: WriterOptions

119− , envPresentationSize :: (Integer, Integer)

120− , envSlideHasHeader :: Bool

121− , envInList :: Bool

122− , envInNoteSlide :: Bool

123− , envCurSlideId :: Int

124− -- the difference between the number at

125− -- the end of the slide file name and

126− -- the rId number

127− , envSlideIdOffset :: Int

128− , envContentType :: ContentType

129− }

130− deriving (Show)

131−

132−instance Default WriterEnv where

133− def = WriterEnv { envMetadata = mempty

134− , envRunProps = def

135− , envParaProps = def

136− , envSlideLevel = 2

137− , envRefArchive = emptyArchive

138− , envDistArchive = emptyArchive

139− , envUTCTime = posixSecondsToUTCTime 0

140− , envOpts = def

141− , envPresentationSize = (720, 540)

142− , envSlideHasHeader = False

143− , envInList = False

144− , envInNoteSlide = False

145− , envCurSlideId = 1

146− , envSlideIdOffset = 1

147− , envContentType = NormalContent

148− }

149−

150−data ContentType = NormalContent

151− | TwoColumnLeftContent

152− | TwoColumnRightContent

153− deriving (Show, Eq)

154−

155−data MediaInfo = MediaInfo { mInfoFilePath :: FilePath

156− , mInfoLocalId :: Int

157− , mInfoGlobalId :: Int

158− , mInfoMimeType :: Maybe MimeType

159− , mInfoExt :: Maybe String

160− , mInfoCaption :: Bool

161− } deriving (Show, Eq)

162−

163−data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String))

164− -- (FP, Local ID, Global ID, Maybe Mime)

165− , stMediaIds :: M.Map Int [MediaInfo]

166− , stMediaGlobalIds :: M.Map FilePath Int

167− , stNoteIds :: M.Map Int [Block]

168− -- associate anchors with slide id

169− , stAnchorMap :: M.Map String Int

170− -- media inherited from the template.

171− , stTemplateMedia :: [FilePath]

172− } deriving (Show, Eq)

173−

174−instance Default WriterState where

175− def = WriterState { stLinkIds = mempty

176− , stMediaIds = mempty

177− , stMediaGlobalIds = mempty

178− , stNoteIds = mempty

179− , stAnchorMap= mempty

180− , stTemplateMedia = []

181− }

182−

183−-- This populates the global ids map with images already in the

184−-- template, so the ids won't be used by images introduced by the

185−-- user.

186−initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int

187−initialGlobalIds refArchive distArchive =

188− let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive

189− mediaPaths = filter (match (compile "ppt/media/image")) archiveFiles

190−

191− go :: FilePath -> Maybe (FilePath, Int)

192− go fp = do

193− s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp

194− (n, _) <- listToMaybe $ reads s

195− return (fp, n)

196− in

197− M.fromList $ mapMaybe go mediaPaths

198−

199−getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer)

200−getPresentationSize refArchive distArchive = do

201− entry <- findEntryByPath "ppt/presentation.xml" refArchive `mplus`

202− findEntryByPath "ppt/presentation.xml" distArchive

203− presElement <- parseXMLDoc $ UTF8.toStringLazy $ fromEntry entry

204− let ns = elemToNameSpaces presElement

205− sldSize <- findChild (elemName ns "p" "sldSz") presElement

206− cxS <- findAttr (QName "cx" Nothing Nothing) sldSize

207− cyS <- findAttr (QName "cy" Nothing Nothing) sldSize

208− (cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String)

209− (cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String)

210− return (cx `div` 12700, cy `div` 12700)

211−

212−type P m = ReaderT WriterEnv (StateT WriterState m)

213−

214−runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a

215−runP env st p = evalStateT (runReaderT p env) st

216−

217−type Pixels = Integer

218−

219−data Presentation = Presentation [Slide]

220− deriving (Show)

221−

222−data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]

223− , metadataSlideSubtitle :: [ParaElem]

224− , metadataSlideAuthors :: [[ParaElem]]

225− , metadataSlideDate :: [ParaElem]

226− }

227− | TitleSlide { titleSlideHeader :: [ParaElem]}

228− | ContentSlide { contentSlideHeader :: [ParaElem]

229− , contentSlideContent :: [Shape]

230− }

231− | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem]

232− , twoColumnSlideLeft :: [Shape]

233− , twoColumnSlideRight :: [Shape]

234− }

235− deriving (Show, Eq)

236−

237−data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape

238− deriving (Show, Eq)

239−

240−data Shape = Pic PicProps FilePath Text.Pandoc.Definition.Attr [ParaElem]

241− | GraphicFrame [Graphic] [ParaElem]

242− | TextBox [Paragraph]

243− deriving (Show, Eq)

244−

245−type Cell = [Paragraph]

246−

247−data TableProps = TableProps { tblPrFirstRow :: Bool

248− , tblPrBandRow :: Bool

249− } deriving (Show, Eq)

250−

251−type ColWidth = Integer

252−

253−data Graphic = Tbl TableProps [ColWidth] [Cell] [[Cell]]

254− deriving (Show, Eq)

255−

256−

257−data Paragraph = Paragraph { paraProps :: ParaProps

258− , paraElems :: [ParaElem]

259− } deriving (Show, Eq)

260−

261−autoNumberingToType :: ListAttributes -> String

262−autoNumberingToType (_, numStyle, numDelim) =

263− typeString ++ delimString

264− where

265− typeString = case numStyle of

266− Decimal -> "arabic"

267− UpperAlpha -> "alphaUc"

268− LowerAlpha -> "alphaLc"

269− UpperRoman -> "romanUc"

270− LowerRoman -> "romanLc"

271− _ -> "arabic"

272− delimString = case numDelim of

273− Period -> "Period"

274− OneParen -> "ParenR"

275− TwoParens -> "ParenBoth"

276− _ -> "Period"

277−

278−data BulletType = Bullet

279− | AutoNumbering ListAttributes

280− deriving (Show, Eq)

281−

282−data Algnment = AlgnLeft | AlgnRight | AlgnCenter

283− deriving (Show, Eq)

284−

285−data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels

286− , pPropMarginRight :: Maybe Pixels

287− , pPropLevel :: Int

288− , pPropBullet :: Maybe BulletType

289− , pPropAlign :: Maybe Algnment

290− , pPropSpaceBefore :: Maybe Pixels

291− } deriving (Show, Eq)

292−

293−instance Default ParaProps where

294− def = ParaProps { pPropMarginLeft = Just 0

295− , pPropMarginRight = Just 0

296− , pPropLevel = 0

297− , pPropBullet = Nothing

298− , pPropAlign = Nothing

299− , pPropSpaceBefore = Nothing

300− }

301−

302−newtype TeXString = TeXString {unTeXString :: String}

303− deriving (Eq, Show)

304−

305−data ParaElem = Break

306− | Run RunProps String

307− -- It would be more elegant to have native TeXMath

308− -- Expressions here, but this allows us to use

309− -- `convertmath` from T.P.Writers.Math. Will perhaps

310− -- revisit in the future.

311− | MathElem MathType TeXString

312− deriving (Show, Eq)

313−

314−data Strikethrough = NoStrike | SingleStrike | DoubleStrike

315− deriving (Show, Eq)

316−

317−data Capitals = NoCapitals | SmallCapitals | AllCapitals

318− deriving (Show, Eq)

319−

320−type URL = String

321−

322−data RunProps = RunProps { rPropBold :: Bool

323− , rPropItalics :: Bool

324− , rStrikethrough :: Maybe Strikethrough

325− , rBaseline :: Maybe Int

326− , rCap :: Maybe Capitals

327− , rLink :: Maybe (URL, String)

328− , rPropCode :: Bool

329− , rPropBlockQuote :: Bool

330− , rPropForceSize :: Maybe Pixels

331− } deriving (Show, Eq)

332−

333−instance Default RunProps where

334− def = RunProps { rPropBold = False

335− , rPropItalics = False

336− , rStrikethrough = Nothing

337− , rBaseline = Nothing

338− , rCap = Nothing

339− , rLink = Nothing

340− , rPropCode = False

341− , rPropBlockQuote = False

342− , rPropForceSize = Nothing

343− }

344−

345−data PicProps = PicProps { picPropLink :: Maybe (URL, String)

346− } deriving (Show, Eq)

347−

348−instance Default PicProps where

349− def = PicProps { picPropLink = Nothing

350− }

351−

352−--------------------------------------------------

353−

354−inlinesToParElems :: Monad m => [Inline] -> P m [ParaElem]

355−inlinesToParElems ils = concatMapM inlineToParElems ils

356−

357−inlineToParElems :: Monad m => Inline -> P m [ParaElem]

358−inlineToParElems (Str s) = do

359− pr <- asks envRunProps

360− return [Run pr s]

361−inlineToParElems (Emph ils) =

362− local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $

363− inlinesToParElems ils

364−inlineToParElems (Strong ils) =

365− local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $

366− inlinesToParElems ils

367−inlineToParElems (Strikeout ils) =

368− local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $

369− inlinesToParElems ils

370−inlineToParElems (Superscript ils) =

371− local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $

372− inlinesToParElems ils

373−inlineToParElems (Subscript ils) =

374− local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $

375− inlinesToParElems ils

376−inlineToParElems (SmallCaps ils) =

377− local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $

378− inlinesToParElems ils

379−inlineToParElems Space = inlineToParElems (Str " ")

380−inlineToParElems SoftBreak = inlineToParElems (Str " ")

381−inlineToParElems LineBreak = return [Break]

382−inlineToParElems (Link _ ils (url, title)) = do

383− local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $

384− inlinesToParElems ils

385−inlineToParElems (Code _ str) = do

386− local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $

387− inlineToParElems $ Str str

388−inlineToParElems (Math mathtype str) =

389− return [MathElem mathtype (TeXString str)]

390−inlineToParElems (Note blks) = do

391− notes <- gets stNoteIds

392− let maxNoteId = case M.keys notes of

393− [] -> 0

394− lst -> maximum lst

395− curNoteId = maxNoteId + 1

396− modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes }

397− inlineToParElems $ Superscript [Str $ show curNoteId]

398−inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils

399−inlineToParElems (RawInline _ _) = return []

400−inlineToParElems _ = return []

401−

402−isListType :: Block -> Bool

403−isListType (OrderedList _ _) = True

404−isListType (BulletList _) = True

405−isListType (DefinitionList _) = True

406−isListType _ = False

407−

408−registerAnchorId :: PandocMonad m => String -> P m ()

409−registerAnchorId anchor = do

410− anchorMap <- gets stAnchorMap

411− slideId <- asks envCurSlideId

412− unless (null anchor) $

413− modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}

414−

415−blockToParagraphs :: PandocMonad m => Block -> P m [Paragraph]

416−blockToParagraphs (Plain ils) = do

417− parElems <- inlinesToParElems ils

418− pProps <- asks envParaProps

419− return [Paragraph pProps parElems]

420−blockToParagraphs (Para ils) = do

421− parElems <- inlinesToParElems ils

422− pProps <- asks envParaProps

423− return [Paragraph pProps parElems]

424−blockToParagraphs (LineBlock ilsList) = do

425− parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList

426− pProps <- asks envParaProps

427− return [Paragraph pProps parElems]

428−-- TODO: work out the attributes

429−blockToParagraphs (CodeBlock attr str) =

430− local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $

431− blockToParagraphs $ Para [Code attr str]

432−-- We can't yet do incremental lists, but we should render a

433−-- (BlockQuote List) as a list to maintain compatibility with other

434−-- formats.

435−blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do

436− ps <- blockToParagraphs blk

437− ps' <- blockToParagraphs $ BlockQuote blks

438− return $ ps ++ ps'

439−blockToParagraphs (BlockQuote blks) =

440− local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}

441− , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$

442− concatMapM blockToParagraphs blks

443−-- TODO: work out the format

444−blockToParagraphs (RawBlock _ _) = return []

445−blockToParagraphs (Header _ (ident, _, _) ils) = do

446− -- Note that this function only deals with content blocks, so it

447− -- will only touch headers that are above the current slide level --

448− -- slides at or below the slidelevel will be taken care of by

449− -- `blocksToSlide'`. We have the register anchors in both of them.

450− registerAnchorId ident

451− -- we set the subeader to bold

452− parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $

453− inlinesToParElems ils

454− -- and give it a bit of space before it.

455− return [Paragraph def{pPropSpaceBefore = Just 30} parElems]

456−blockToParagraphs (BulletList blksLst) = do

457− pProps <- asks envParaProps

458− let lvl = pPropLevel pProps

459− local (\env -> env{ envInList = True

460− , envParaProps = pProps{ pPropLevel = lvl + 1

461− , pPropBullet = Just Bullet

462− , pPropMarginLeft = Nothing

463− }}) $

464− concatMapM multiParBullet blksLst

465−blockToParagraphs (OrderedList listAttr blksLst) = do

466− pProps <- asks envParaProps

467− let lvl = pPropLevel pProps

468− local (\env -> env{ envInList = True

469− , envParaProps = pProps{ pPropLevel = lvl + 1

470− , pPropBullet = Just (AutoNumbering listAttr)

471− , pPropMarginLeft = Nothing

472− }}) $

473− concatMapM multiParBullet blksLst

474−blockToParagraphs (DefinitionList entries) = do

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

476− go (ils, blksLst) = do

477− term <-blockToParagraphs $ Para [Strong ils]

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

479− -- blockquote. We can extend this further later.

480− definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst

481− return $ term ++ definition

482− concatMapM go entries

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

484−blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks

485−blockToParagraphs blk = do

486− P.report $ BlockNotRendered blk

487− return []

488−

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

490−multiParBullet :: PandocMonad m => [Block] -> P m [Paragraph]

491−multiParBullet [] = return []

492−multiParBullet (b:bs) = do

493− pProps <- asks envParaProps

494− p <- blockToParagraphs b

495− ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $

496− concatMapM blockToParagraphs bs

497− return $ p ++ ps

498−

499−cellToParagraphs :: PandocMonad m => Alignment -> TableCell -> P m [Paragraph]

500−cellToParagraphs algn tblCell = do

501− paras <- mapM (blockToParagraphs) tblCell

502− let alignment = case algn of

503− AlignLeft -> Just AlgnLeft

504− AlignRight -> Just AlgnRight

505− AlignCenter -> Just AlgnCenter

506− AlignDefault -> Nothing

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

508− return $ concat paras'

509−

510−rowToParagraphs :: PandocMonad m => [Alignment] -> [TableCell] -> P m [[Paragraph]]

511−rowToParagraphs algns tblCells = do

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

513− let pairs = zip (algns ++ repeat AlignDefault) tblCells

514− mapM (\(a, tc) -> cellToParagraphs a tc) pairs

515−

516−blockToShape :: PandocMonad m => Block -> P m Shape

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

518− Pic def url attr <$> (inlinesToParElems ils)

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

520− Pic def url attr <$> (inlinesToParElems ils)

521−blockToShape (Plain (il:_)) | Link _ (il':_) target <- il

522− , Image attr ils (url, _) <- il' =

523− Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)

524−blockToShape (Para (il:_)) | Link _ (il':_) target <- il

525− , Image attr ils (url, _) <- il' =

526− Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)

527−blockToShape (Table caption algn _ hdrCells rows) = do

528− caption' <- inlinesToParElems caption

529− (pageWidth, _) <- asks envPresentationSize

530− hdrCells' <- rowToParagraphs algn hdrCells

531− rows' <- mapM (rowToParagraphs algn) rows

532− let tblPr = if null hdrCells

533− then TableProps { tblPrFirstRow = False

534− , tblPrBandRow = True

535− }

536− else TableProps { tblPrFirstRow = True

537− , tblPrBandRow = True

538− }

539− colWidths = if null hdrCells

540− then case rows of

541− r : _ | not (null r) -> replicate (length r) $

542− (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length r)

543− -- satisfy the compiler. This is the same as

544− -- saying that rows is empty, but the compiler

545− -- won't understand that `[]` exhausts the

546− -- alternatives.

547− _ -> []

548− else replicate (length hdrCells) $

549− (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells)

550−

551− return $ GraphicFrame [Tbl tblPr colWidths hdrCells' rows'] caption'

552−blockToShape blk = TextBox <$> blockToParagraphs blk

553−

554−blocksToShapes :: PandocMonad m => [Block] -> P m [Shape]

555−blocksToShapes blks = combineShapes <$> mapM blockToShape blks

556−

557−isImage :: Inline -> Bool

558−isImage (Image _ _ _) = True

559−isImage (Link _ ((Image _ _ _) : _) _) = True

560−isImage _ = False

561−

562−splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> P m [[Block]]

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

564−splitBlocks' cur acc (HorizontalRule : blks) =

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

566−splitBlocks' cur acc (h@(Header n _ _) : blks) = do

567− slideLevel <- asks envSlideLevel

568− case compare n slideLevel of

569− LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks

570− EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks

571− GT -> splitBlocks' (cur ++ [h]) acc blks

572−-- `blockToParagraphs` treats Plain and Para the same, so we can save

573−-- some code duplication by treating them the same here.

574−splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks)

575−splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do

576− slideLevel <- asks envSlideLevel

577− case cur of

578− (Header n _ _) : [] | n == slideLevel ->

579− splitBlocks' []

580− (acc ++ [cur ++ [Para [il]]])

581− (if null ils then blks else (Para ils) : blks)

582− _ -> splitBlocks' []

583− (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]])

584− (if null ils then blks else (Para ils) : blks)

585−splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do

586− slideLevel <- asks envSlideLevel

587− case cur of

588− (Header n _ _) : [] | n == slideLevel ->

589− splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks

590− _ -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[tbl]]) blks

591−splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do

592− slideLevel <- asks envSlideLevel

593− case cur of

594− (Header n _ _) : [] | n == slideLevel ->

595− splitBlocks' [] (acc ++ [cur ++ [d]]) blks

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

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

598−

599−splitBlocks :: Monad m => [Block] -> P m [[Block]]

600−splitBlocks = splitBlocks' [] []

601−

602−blocksToSlide' :: PandocMonad m => Int -> [Block] -> P m Slide

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

604− | n < lvl = do

605− registerAnchorId ident

606− hdr <- inlinesToParElems ils

607− return $ TitleSlide {titleSlideHeader = hdr}

608− | n == lvl = do

609− registerAnchorId ident

610− hdr <- inlinesToParElems ils

611− -- Now get the slide without the header, and then add the header

612− -- in.

613− slide <- blocksToSlide' lvl blks

614− return $ case slide of

615− ContentSlide _ cont -> ContentSlide hdr cont

616− TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR

617− slide' -> slide'

618−blocksToSlide' _ (blk : blks)

619− | Div (_, classes, _) divBlks <- blk

620− , "columns" `elem` classes

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

622− , "column" `elem` clsL, "column" `elem` clsR = do

623− unless (null blks)

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

625− unless (null remaining)

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

627− mbSplitBlksL <- splitBlocks blksL

628− mbSplitBlksR <- splitBlocks blksR

629− let blksL' = case mbSplitBlksL of

630− bs : _ -> bs

631− [] -> []

632− let blksR' = case mbSplitBlksR of

633− bs : _ -> bs

634− [] -> []

635− shapesL <- blocksToShapes blksL'

636− shapesR <- blocksToShapes blksR'

637− return $ TwoColumnSlide { twoColumnSlideHeader = []

638− , twoColumnSlideLeft = shapesL

639− , twoColumnSlideRight = shapesR

640− }

641−blocksToSlide' _ (blk : blks) = do

642− inNoteSlide <- asks envInNoteSlide

643− shapes <- if inNoteSlide

644− then forceFontSize noteSize $ blocksToShapes (blk : blks)

645− else blocksToShapes (blk : blks)

646− return $ ContentSlide { contentSlideHeader = []

647− , contentSlideContent = shapes

648− }

649−blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []

650− , contentSlideContent = []

651− }

652−

653−blocksToSlide :: PandocMonad m => [Block] -> P m Slide

654−blocksToSlide blks = do

655− slideLevel <- asks envSlideLevel

656− blocksToSlide' slideLevel blks

657−

658−makeNoteEntry :: Int -> [Block] -> [Block]

659−makeNoteEntry n blks =

660− let enum = Str (show n ++ ".")

661− in

662− case blks of

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

664− _ -> (Para [enum]) : blks

665−

666−forceFontSize :: PandocMonad m => Pixels -> P m a -> P m a

667−forceFontSize px x = do

668− rpr <- asks envRunProps

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

670−

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

672−-- the TOC.

673−makeNotesSlideBlocks :: PandocMonad m => P m [Block]

674−makeNotesSlideBlocks = do

675− noteIds <- gets stNoteIds

676− slideLevel <- asks envSlideLevel

677− meta <- asks envMetadata

678− -- Get identifiers so we can give the notes section a unique ident.

679− anchorSet <- M.keysSet <$> gets stAnchorMap

680− if M.null noteIds

681− then return []

682− else do let title = case lookupMeta "notes-title" meta of

683− Just val -> metaValueToInlines val

684− Nothing -> [Str "Notes"]

685− ident = Shared.uniqueIdent title anchorSet

686− hdr = Header slideLevel (ident, [], []) title

687− blks <- return $

688− concatMap (\(n, bs) -> makeNoteEntry n bs) $

689− M.toList noteIds

690− return $ hdr : blks

691−

692−getMetaSlide :: PandocMonad m => P m (Maybe Slide)

693−getMetaSlide = do

694− meta <- asks envMetadata

695− title <- inlinesToParElems $ docTitle meta

696− subtitle <- inlinesToParElems $

697− case lookupMeta "subtitle" meta of

698− Just (MetaString s) -> [Str s]

699− Just (MetaInlines ils) -> ils

700− Just (MetaBlocks [Plain ils]) -> ils

701− Just (MetaBlocks [Para ils]) -> ils

702− _ -> []

703− authors <- mapM inlinesToParElems $ docAuthors meta

704− date <- inlinesToParElems $ docDate meta

705− if null title && null subtitle && null authors && null date

706− then return Nothing

707− else return $ Just $ MetadataSlide { metadataSlideTitle = title

708− , metadataSlideSubtitle = subtitle

709− , metadataSlideAuthors = authors

710− , metadataSlideDate = date

711− }

712−

713−-- adapted from the markdown writer

714−elementToListItem :: PandocMonad m => Shared.Element -> P m [Block]

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

716− opts <- asks envOpts

717− let headerLink = if null ident

718− then walk Shared.deNote headerText

719− else [Link nullAttr (walk Shared.deNote headerText)

720− ('#':ident, "")]

721− listContents <- if null subsecs || lev >= writerTOCDepth opts

722− then return []

723− else mapM elementToListItem subsecs

724− return [Plain headerLink, BulletList listContents]

725−elementToListItem (Shared.Blk _) = return []

726−

727−makeTOCSlide :: PandocMonad m => [Block] -> P m Slide

728−makeTOCSlide blks = do

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

730− meta <- asks envMetadata

731− slideLevel <- asks envSlideLevel

732− let tocTitle = case lookupMeta "toc-title" meta of

733− Just val -> metaValueToInlines val

734− Nothing -> [Str "Table of Contents"]

735− hdr = Header slideLevel nullAttr tocTitle

736− sld <- blocksToSlide [hdr, contents]

737− return sld

738−

739−blocksToPresentation :: PandocMonad m => [Block] -> P m Presentation

740−blocksToPresentation blks = do

741− opts <- asks envOpts

742− let metadataStartNum = 1

743− metadataslides <- maybeToList <$> getMetaSlide

744− let tocStartNum = metadataStartNum + length metadataslides

745− -- As far as I can tell, if we want to have a variable-length toc in

746− -- the future, we'll have to make it twice. Once to get the length,

747− -- and a second time to include the notes slide. We can't make the

748− -- notes slide before the body slides because we need to know if

749− -- there are notes, and we can't make either before the toc slide,

750− -- because we need to know its length to get slide numbers right.

751− --

752− -- For now, though, since the TOC slide is only length 1, if it

753− -- exists, we'll just get the length, and then come back to make the

754− -- slide later

755− let tocSlidesLength = if writerTableOfContents opts then 1 else 0

756− let bodyStartNum = tocStartNum + tocSlidesLength

757− blksLst <- splitBlocks blks

758− bodyslides <- mapM

759− (\(bs, n) -> local (\st -> st{envCurSlideId = n}) (blocksToSlide bs))

760− (zip blksLst [bodyStartNum..])

761− let noteStartNum = bodyStartNum + length bodyslides

762− notesSlideBlocks <- makeNotesSlideBlocks

763− -- now we come back and make the real toc...

764− tocSlides <- if writerTableOfContents opts

765− then do toc <- makeTOCSlide $ blks ++ notesSlideBlocks

766− return [toc]

767− else return []

768− -- ... and the notes slide. We test to see if the blocks are empty,

769− -- because we don't want to make an empty slide.

770− notesSlides <- if null notesSlideBlocks

771− then return []

772− else do notesSlide <- local

773− (\env -> env { envCurSlideId = noteStartNum

774− , envInNoteSlide = True

775− })

776− (blocksToSlide $ notesSlideBlocks)

777− return [notesSlide]

778− return $

779− Presentation $

780− metadataslides ++ tocSlides ++ bodyslides ++ notesSlides

781−

782−--------------------------------------------------------------------

783−

784−copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive

785−copyFileToArchive arch fp = do

786− refArchive <- asks envRefArchive

787− distArchive <- asks envDistArchive

788− case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of

789− Nothing -> fail $ fp ++ " missing in reference file"

790− Just e -> return $ addEntryToArchive e arch

791−

792−inheritedPatterns :: [Pattern]

793−inheritedPatterns = map compile [ "_rels/.rels"

794− , "docProps/app.xml"

795− , "docProps/core.xml"

796− , "ppt/slideLayouts/slideLayout*.xml"

797− , "ppt/slideLayouts/_rels/slideLayout*.xml.rels"

798− , "ppt/slideMasters/slideMaster1.xml"

799− , "ppt/slideMasters/_rels/slideMaster1.xml.rels"

800− , "ppt/theme/theme1.xml"

801− , "ppt/theme/_rels/theme1.xml.rels"

802− , "ppt/presProps.xml"

803− , "ppt/viewProps.xml"

804− , "ppt/tableStyles.xml"

805− , "ppt/media/image*"

806− ]

807−

808−patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]

809−patternToFilePaths pat = do

810− refArchive <- asks envRefArchive

811− distArchive <- asks envDistArchive

812−

813− let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive

814− return $ filter (match pat) archiveFiles

815−

816−patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]

817−patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats

818−

819−-- Here are the files we'll require to make a Powerpoint document. If

820−-- any of these are missing, we should error out of our build.

821−requiredFiles :: [FilePath]

822−requiredFiles = [ "_rels/.rels"

823− , "docProps/app.xml"

824− , "docProps/core.xml"

825− , "ppt/presProps.xml"

826− , "ppt/slideLayouts/slideLayout1.xml"

827− , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"

828− , "ppt/slideLayouts/slideLayout2.xml"

829− , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"

830− , "ppt/slideLayouts/slideLayout3.xml"

831− , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"

832− , "ppt/slideLayouts/slideLayout4.xml"

833− , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"

834− , "ppt/slideMasters/slideMaster1.xml"

835− , "ppt/slideMasters/_rels/slideMaster1.xml.rels"

836− , "ppt/theme/theme1.xml"

837− , "ppt/viewProps.xml"

838− , "ppt/tableStyles.xml"

839− ]

840−

841−

842−presentationToArchive :: PandocMonad m => Presentation -> P m Archive

843−presentationToArchive p@(Presentation slides) = do

844− filePaths <- patternsToFilePaths inheritedPatterns

845−

846− -- make sure all required files are available:

847− let missingFiles = filter (\fp -> not (fp `elem` filePaths)) requiredFiles

848− unless (null missingFiles)

849− (throwError $

850− PandocSomeError $

851− "The following required files are missing:\n" ++

852− (unlines $ map (" " ++) missingFiles)

853− )

854−

855− newArch' <- foldM copyFileToArchive emptyArchive filePaths

856− -- presentation entry and rels. We have to do the rels first to make

857− -- sure we know the correct offset for the rIds.

858− presEntry <- presentationToPresEntry p

859− presRelsEntry <- presentationToRelsEntry p

860− slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]

861− slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]

862− -- These have to come after everything, because they need the info

863− -- built up in the state.

864− mediaEntries <- makeMediaEntries

865− contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry

866− -- fold everything into our inherited archive and return it.

867− return $ foldr addEntryToArchive newArch' $

868− slideEntries ++

869− slideRelEntries ++

870− mediaEntries ++

871− [contentTypesEntry, presEntry, presRelsEntry]

872−

873−--------------------------------------------------

874−

875−combineShapes :: [Shape] -> [Shape]

876−combineShapes [] = []

877−combineShapes (s : []) = [s]

878−combineShapes (pic@(Pic _ _ _ _) : ss) = pic : combineShapes ss

879−combineShapes ((TextBox []) : ss) = combineShapes ss

880−combineShapes (s : TextBox [] : ss) = combineShapes (s : ss)

881−combineShapes ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) =

882− combineShapes $ TextBox ((p:ps) ++ (p':ps')) : ss

883−combineShapes (s:ss) = s : combineShapes ss

884−

885−--------------------------------------------------

886−

887−getLayout :: PandocMonad m => Slide -> P m Element

888−getLayout slide = do

889− let layoutpath = case slide of

890− (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml"

891− (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml"

892− (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml"

893− (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml"

894− distArchive <- asks envDistArchive

895− root <- case findEntryByPath layoutpath distArchive of

896− Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of

897− Just element -> return $ element

898− Nothing -> throwError $

899− PandocSomeError $

900− layoutpath ++ " corrupt in reference file"

901− Nothing -> throwError $

902− PandocSomeError $

903− layoutpath ++ " missing in reference file"

904− return root

905−

906−shapeHasName :: NameSpaces -> String -> Element -> Bool

907−shapeHasName ns name element

908− | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element

909− , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr

910− , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr =

911− nm == name

912− | otherwise = False

913−

914−shapeHasId :: NameSpaces -> String -> Element -> Bool

915−shapeHasId ns ident element

916− | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element

917− , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr

918− , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr =

919− nm == ident

920− | otherwise = False

921−

922−-- The content shape in slideLayout2 (Title/Content) has id=3 In

923−-- slideLayout4 (two column) the left column is id=3, and the right

924−-- column is id=4.

925−getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element

926−getContentShape ns spTreeElem

927− | isElem ns "p" "spTree" spTreeElem = do

928− contentType <- asks envContentType

929− let ident = case contentType of

930− NormalContent -> "3"

931− TwoColumnLeftContent -> "3"

932− TwoColumnRightContent -> "4"

933− case filterChild

934− (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e))

935− spTreeElem

936− of

937− Just e -> return e

938− Nothing -> throwError $

939− PandocSomeError $

940− "Could not find shape for Powerpoint content"

941−getContentShape _ _ = throwError $

942− PandocSomeError $

943− "Attempted to find content on non shapeTree"

944−

945−getShapeDimensions :: NameSpaces

946− -> Element

947− -> Maybe ((Integer, Integer), (Integer, Integer))

948−getShapeDimensions ns element

949− | isElem ns "p" "sp" element = do

950− spPr <- findChild (elemName ns "p" "spPr") element

951− xfrm <- findChild (elemName ns "a" "xfrm") spPr

952− off <- findChild (elemName ns "a" "off") xfrm

953− xS <- findAttr (QName "x" Nothing Nothing) off

954− yS <- findAttr (QName "y" Nothing Nothing) off

955− ext <- findChild (elemName ns "a" "ext") xfrm

956− cxS <- findAttr (QName "cx" Nothing Nothing) ext

957− cyS <- findAttr (QName "cy" Nothing Nothing) ext

958− (x, _) <- listToMaybe $ reads xS

959− (y, _) <- listToMaybe $ reads yS

960− (cx, _) <- listToMaybe $ reads cxS

961− (cy, _) <- listToMaybe $ reads cyS

962− return $ ((x `div` 12700, y `div` 12700), (cx `div` 12700, cy `div` 12700))

963− | otherwise = Nothing

964−

965−

966−getMasterShapeDimensionsById :: String

967− -> Element

968− -> Maybe ((Integer, Integer), (Integer, Integer))

969−getMasterShapeDimensionsById ident master = do

970− let ns = elemToNameSpaces master

971− cSld <- findChild (elemName ns "p" "cSld") master

972− spTree <- findChild (elemName ns "p" "spTree") cSld

973− sp <- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTree

974− getShapeDimensions ns sp

975−

976−getContentShapeSize :: PandocMonad m

977− => NameSpaces

978− -> Element

979− -> Element

980− -> P m ((Integer, Integer), (Integer, Integer))

981−getContentShapeSize ns layout master

982− | isElem ns "p" "sldLayout" layout

983− , Just cSld <- findChild (elemName ns "p" "cSld") layout

984− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

985− sp <- getContentShape ns spTree

986− case getShapeDimensions ns sp of

987− Just sz -> return sz

988− Nothing -> do let mbSz =

989− findChild (elemName ns "p" "nvSpPr") sp >>=

990− findChild (elemName ns "p" "cNvPr") >>=

991− findAttr (QName "id" Nothing Nothing) >>=

992− flip getMasterShapeDimensionsById master

993− case mbSz of

994− Just sz' -> return sz'

995− Nothing -> throwError $

996− PandocSomeError $

997− "Couldn't find necessary content shape size"

998−getContentShapeSize _ _ _ = throwError $

999− PandocSomeError $

1000− "Attempted to find content shape size in non-layout"

1001−

1002−replaceNamedChildren :: NameSpaces

1003− -> String

1004− -> String

1005− -> [Element]

1006− -> Element

1007− -> Element

1008−replaceNamedChildren ns prefix name newKids element =

1009− element { elContent = concat $ fun True $ elContent element }

1010− where

1011− fun :: Bool -> [Content] -> [[Content]]

1012− fun _ [] = []

1013− fun switch ((Elem e) : conts) | isElem ns prefix name e =

1014− if switch

1015− then (map Elem $ newKids) : fun False conts

1016− else fun False conts

1017− fun switch (cont : conts) = [cont] : fun switch conts

1018−

1019−----------------------------------------------------------------

1020−

1021−registerLink :: PandocMonad m => (URL, String) -> P m Int

1022−registerLink link = do

1023− curSlideId <- asks envCurSlideId

1024− linkReg <- gets stLinkIds

1025− mediaReg <- gets stMediaIds

1026− let maxLinkId = case M.lookup curSlideId linkReg of

1027− Just mp -> case M.keys mp of

1028− [] -> 1

1029− ks -> maximum ks

1030− Nothing -> 1

1031− maxMediaId = case M.lookup curSlideId mediaReg of

1032− Just [] -> 1

1033− Just mInfos -> maximum $ map mInfoLocalId mInfos

1034− Nothing -> 1

1035− maxId = max maxLinkId maxMediaId

1036− slideLinks = case M.lookup curSlideId linkReg of

1037− Just mp -> M.insert (maxId + 1) link mp

1038− Nothing -> M.singleton (maxId + 1) link

1039− modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg}

1040− return $ maxId + 1

1041−

1042−registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo

1043−registerMedia fp caption = do

1044− curSlideId <- asks envCurSlideId

1045− linkReg <- gets stLinkIds

1046− mediaReg <- gets stMediaIds

1047− globalIds <- gets stMediaGlobalIds

1048− let maxLinkId = case M.lookup curSlideId linkReg of

1049− Just mp -> case M.keys mp of

1050− [] -> 1

1051− ks -> maximum ks

1052− Nothing -> 1

1053− maxMediaId = case M.lookup curSlideId mediaReg of

1054− Just [] -> 1

1055− Just mInfos -> maximum $ map mInfoLocalId mInfos

1056− Nothing -> 1

1057− maxLocalId = max maxLinkId maxMediaId

1058−

1059− maxGlobalId = case M.elems globalIds of

1060− [] -> 0

1061− ids -> maximum ids

1062−

1063− (imgBytes, mbMt) <- P.fetchItem fp

1064− let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x))

1065− <|>

1066− case imageType imgBytes of

1067− Just Png -> Just ".png"

1068− Just Jpeg -> Just ".jpeg"

1069− Just Gif -> Just ".gif"

1070− Just Pdf -> Just ".pdf"

1071− Just Eps -> Just ".eps"

1072− Just Svg -> Just ".svg"

1073− Nothing -> Nothing

1074−

1075− let newGlobalId = case M.lookup fp globalIds of

1076− Just ident -> ident

1077− Nothing -> maxGlobalId + 1

1078−

1079− let newGlobalIds = M.insert fp newGlobalId globalIds

1080−

1081− let mediaInfo = MediaInfo { mInfoFilePath = fp

1082− , mInfoLocalId = maxLocalId + 1

1083− , mInfoGlobalId = newGlobalId

1084− , mInfoMimeType = mbMt

1085− , mInfoExt = imgExt

1086− , mInfoCaption = (not . null) caption

1087− }

1088−

1089− let slideMediaInfos = case M.lookup curSlideId mediaReg of

1090− Just minfos -> mediaInfo : minfos

1091− Nothing -> [mediaInfo]

1092−

1093−

1094− modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg

1095− , stMediaGlobalIds = newGlobalIds

1096− }

1097− return mediaInfo

1098−

1099−makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry

1100−makeMediaEntry mInfo = do

1101− epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime

1102− (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)

1103− let ext = case mInfoExt mInfo of

1104− Just e -> e

1105− Nothing -> ""

1106− let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext

1107− return $ toEntry fp epochtime $ BL.fromStrict imgBytes

1108−

1109−makeMediaEntries :: PandocMonad m => P m [Entry]

1110−makeMediaEntries = do

1111− mediaInfos <- gets stMediaIds

1112− let allInfos = mconcat $ M.elems mediaInfos

1113− mapM makeMediaEntry allInfos

1114−

1115−-- -- | Scales the image to fit the page

1116−-- -- sizes are passed in emu

1117−-- fitToPage' :: (Double, Double) -- image size in emu

1118−-- -> Integer -- pageWidth

1119−-- -> Integer -- pageHeight

1120−-- -> (Integer, Integer) -- imagesize

1121−-- fitToPage' (x, y) pageWidth pageHeight

1122−-- -- Fixes width to the page width and scales the height

1123−-- | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight =

1124−-- (floor x, floor y)

1125−-- | x / fromIntegral pageWidth > y / fromIntegral pageWidth =

1126−-- (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y)

1127−-- | otherwise =

1128−-- (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight)

1129−

1130−-- positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer)

1131−-- positionImage (x, y) pageWidth pageHeight =

1132−-- let (x', y') = fitToPage' (x, y) pageWidth pageHeight

1133−-- in

1134−-- ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2)

1135−

1136−getMaster :: PandocMonad m => P m Element

1137−getMaster = do

1138− refArchive <- asks envRefArchive

1139− distArchive <- asks envDistArchive

1140− parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml"

1141−

1142−-- We want to get the header dimensions, so we can make sure that the

1143−-- image goes underneath it. We only use this in a content slide if it

1144−-- has a header.

1145−

1146−-- getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer))

1147−-- getHeaderSize = do

1148−-- master <- getMaster

1149−-- let ns = elemToNameSpaces master

1150−-- sps = [master] >>=

1151−-- findChildren (elemName ns "p" "cSld") >>=

1152−-- findChildren (elemName ns "p" "spTree") >>=

1153−-- findChildren (elemName ns "p" "sp")

1154−-- mbXfrm =

1155−-- listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>=

1156−-- findChild (elemName ns "p" "spPr") >>=

1157−-- findChild (elemName ns "a" "xfrm")

1158−-- xoff = mbXfrm >>=

1159−-- findChild (elemName ns "a" "off") >>=

1160−-- findAttr (QName "x" Nothing Nothing) >>=

1161−-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

1162−-- yoff = mbXfrm >>=

1163−-- findChild (elemName ns "a" "off") >>=

1164−-- findAttr (QName "y" Nothing Nothing) >>=

1165−-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

1166−-- xext = mbXfrm >>=

1167−-- findChild (elemName ns "a" "ext") >>=

1168−-- findAttr (QName "cx" Nothing Nothing) >>=

1169−-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

1170−-- yext = mbXfrm >>=

1171−-- findChild (elemName ns "a" "ext") >>=

1172−-- findAttr (QName "cy" Nothing Nothing) >>=

1173−-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

1174−-- off = case xoff of

1175−-- Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff')

1176−-- _ -> (1043490, 1027664)

1177−-- ext = case xext of

1178−-- Just (xext', _) | Just (yext',_) <- yext -> (xext', yext')

1179−-- _ -> (7024744, 1143000)

1180−-- return $ (off, ext)

1181−

1182−-- Hard-coded for now

1183−-- captionPosition :: ((Integer, Integer), (Integer, Integer))

1184−-- captionPosition = ((457200, 6061972), (8229600, 527087))

1185−

1186−captionHeight :: Integer

1187−captionHeight = 40

1188−

1189−createCaption :: PandocMonad m

1190− => ((Integer, Integer), (Integer, Integer))

1191− -> [ParaElem]

1192− -> P m Element

1193−createCaption contentShapeDimensions paraElements = do

1194− let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements

1195− elements <- mapM paragraphToElement [para]

1196− let ((x, y), (cx, cy)) = contentShapeDimensions

1197− let txBody = mknode "p:txBody" [] $

1198− [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements

1199− return $

1200− mknode "p:sp" [] [ mknode "p:nvSpPr" []

1201− [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()

1202− , mknode "p:cNvSpPr" [("txBox", "1")] ()

1203− , mknode "p:nvPr" [] ()

1204− ]

1205− , mknode "p:spPr" []

1206− [ mknode "a:xfrm" []

1207− [ mknode "a:off" [("x", show $ 12700 * x),

1208− ("y", show $ 12700 * (y + cy - captionHeight))] ()

1209− , mknode "a:ext" [("cx", show $ 12700 * cx),

1210− ("cy", show $ 12700 * captionHeight)] ()

1211− ]

1212− , mknode "a:prstGeom" [("prst", "rect")]

1213− [ mknode "a:avLst" [] ()

1214− ]

1215− , mknode "a:noFill" [] ()

1216− ]

1217− , txBody

1218− ]

1219−

1220−makePicElements :: PandocMonad m

1221− => Element

1222− -> PicProps

1223− -> MediaInfo

1224− -> Text.Pandoc.Definition.Attr

1225− -> [ParaElem]

1226− -> P m [Element]

1227−makePicElements layout picProps mInfo _ alt = do

1228− opts <- asks envOpts

1229− (pageWidth, pageHeight) <- asks envPresentationSize

1230− -- hasHeader <- asks envSlideHasHeader

1231− let hasCaption = mInfoCaption mInfo

1232− (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)

1233− let (pxX, pxY) = case imageSize opts imgBytes of

1234− Right sz -> sizeInPixels $ sz

1235− Left _ -> sizeInPixels $ def

1236− master <- getMaster

1237− let ns = elemToNameSpaces layout

1238− ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master

1239− `catchError`

1240− (\_ -> return ((0, 0), (pageWidth, pageHeight)))

1241−

1242− let cy = if hasCaption then cytmp - captionHeight else cytmp

1243−

1244− let imgRatio = fromIntegral pxX / fromIntegral pxY :: Double

1245− boxRatio = fromIntegral cx / fromIntegral cy :: Double

1246− (dimX, dimY) = if imgRatio > boxRatio

1247− then (fromIntegral cx, fromIntegral cx / imgRatio)

1248− else (fromIntegral cy * imgRatio, fromIntegral cy)

1249−

1250− (dimX', dimY') = (round dimX * 12700, round dimY * 12700) :: (Integer, Integer)

1251− (xoff, yoff) = (fromIntegral x + (fromIntegral cx - dimX) / 2,

1252− fromIntegral y + (fromIntegral cy - dimY) / 2)

1253− (xoff', yoff') = (round xoff * 12700, round yoff * 12700) :: (Integer, Integer)

1254−

1255− let cNvPicPr = mknode "p:cNvPicPr" [] $

1256− mknode "a:picLocks" [("noGrp","1")

1257− ,("noChangeAspect","1")] ()

1258− -- cNvPr will contain the link information so we do that separately,

1259− -- and register the link if necessary.

1260− let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")]

1261− cNvPr <- case picPropLink picProps of

1262− Just link -> do idNum <- registerLink link

1263− return $ mknode "p:cNvPr" cNvPrAttr $

1264− mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] ()

1265− Nothing -> return $ mknode "p:cNvPr" cNvPrAttr ()

1266− let nvPicPr = mknode "p:nvPicPr" []

1267− [ cNvPr

1268− , cNvPicPr

1269− , mknode "p:nvPr" [] ()]

1270− let blipFill = mknode "p:blipFill" []

1271− [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] ()

1272− , mknode "a:stretch" [] $

1273− mknode "a:fillRect" [] () ]

1274− let xfrm = mknode "a:xfrm" []

1275− [ mknode "a:off" [("x",show xoff'), ("y",show yoff')] ()

1276− , mknode "a:ext" [("cx",show dimX')

1277− ,("cy",show dimY')] () ]

1278− let prstGeom = mknode "a:prstGeom" [("prst","rect")] $

1279− mknode "a:avLst" [] ()

1280− let ln = mknode "a:ln" [("w","9525")]

1281− [ mknode "a:noFill" [] ()

1282− , mknode "a:headEnd" [] ()

1283− , mknode "a:tailEnd" [] () ]

1284− let spPr = mknode "p:spPr" [("bwMode","auto")]

1285− [xfrm, prstGeom, mknode "a:noFill" [] (), ln]

1286−

1287− let picShape = mknode "p:pic" []

1288− [ nvPicPr

1289− , blipFill

1290− , spPr ]

1291−

1292− -- And now, maybe create the caption:

1293− if hasCaption

1294− then do cap <- createCaption ((x, y), (cx, cytmp)) alt

1295− return [picShape, cap]

1296− else return [picShape]

1297−

1298−-- Currently hardcoded, until I figure out how to make it dynamic.

1299−blockQuoteSize :: Pixels

1300−blockQuoteSize = 20

1301−

1302−noteSize :: Pixels

1303−noteSize = 18

1304−

1305−paraElemToElement :: PandocMonad m => ParaElem -> P m Element

1306−paraElemToElement Break = return $ mknode "a:br" [] ()

1307−paraElemToElement (Run rpr s) = do

1308− let sizeAttrs = case rPropForceSize rpr of

1309− Just n -> [("sz", (show $ n * 100))]

1310− Nothing -> []

1311− attrs = sizeAttrs ++

1312− if rPropCode rpr

1313− then []

1314− else (if rPropBold rpr then [("b", "1")] else []) ++

1315− (if rPropItalics rpr then [("i", "1")] else []) ++

1316− (case rStrikethrough rpr of

1317− Just NoStrike -> [("strike", "noStrike")]

1318− Just SingleStrike -> [("strike", "sngStrike")]

1319− Just DoubleStrike -> [("strike", "dblStrike")]

1320− Nothing -> []) ++

1321− (case rBaseline rpr of

1322− Just n -> [("baseline", show n)]

1323− Nothing -> []) ++

1324− (case rCap rpr of

1325− Just NoCapitals -> [("cap", "none")]

1326− Just SmallCapitals -> [("cap", "small")]

1327− Just AllCapitals -> [("cap", "all")]

1328− Nothing -> []) ++

1329− []

1330− linkProps <- case rLink rpr of

1331− Just link -> do

1332− idNum <- registerLink link

1333− -- first we have to make sure that if it's an

1334− -- anchor, it's in the anchor map. If not, there's

1335− -- no link.

1336− anchorMap <- gets stAnchorMap

1337− return $ case link of

1338− -- anchor with nothing in the map

1339− ('#':target, _) | Nothing <- M.lookup target anchorMap ->

1340− []

1341− -- anchor that is in the map

1342− ('#':_, _) ->

1343− let linkAttrs =

1344− [ ("r:id", "rId" ++ show idNum)

1345− , ("action", "ppaction://hlinksldjump")

1346− ]

1347− in [mknode "a:hlinkClick" linkAttrs ()]

1348− -- external

1349− _ ->

1350− let linkAttrs =

1351− [ ("r:id", "rId" ++ show idNum)

1352− ]

1353− in [mknode "a:hlinkClick" linkAttrs ()]

1354− Nothing -> return []

1355− let propContents = if rPropCode rpr

1356− then [mknode "a:latin" [("typeface", "Courier")] ()]

1357− else linkProps

1358− return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents

1359− , mknode "a:t" [] s

1360− ]

1361−paraElemToElement (MathElem mathType texStr) = do

1362− res <- convertMath writeOMML mathType (unTeXString texStr)

1363− case res of

1364− Right r -> return $ mknode "a14:m" [] $ addMathInfo r

1365− Left (Str s) -> paraElemToElement (Run def s)

1366− Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback"

1367−

1368−-- This is a bit of a kludge -- really requires adding an option to

1369−-- TeXMath, but since that's a different package, we'll do this one

1370−-- step at a time.

1371−addMathInfo :: Element -> Element

1372−addMathInfo element =

1373− let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns"))

1374− , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"

1375− }

1376− in add_attr mathspace element

1377−

1378−-- We look through the element to see if it contains an a14:m

1379−-- element. If so, we surround it. This is a bit ugly, but it seems

1380−-- more dependable than looking through shapes for math. Plus this is

1381−-- an xml implementation detail, so it seems to make sense to do it at

1382−-- the xml level.

1383−surroundWithMathAlternate :: Element -> Element

1384−surroundWithMathAlternate element =

1385− case findElement (QName "m" Nothing (Just "a14")) element of

1386− Just _ ->

1387− mknode "mc:AlternateContent"

1388− [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")

1389− ] [ mknode "mc:Choice"

1390− [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")

1391− , ("Requires", "a14")] [ element ]

1392− ]

1393− Nothing -> element

1394−

1395−paragraphToElement :: PandocMonad m => Paragraph -> P m Element

1396−paragraphToElement par = do

1397− let

1398− attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++

1399− (case pPropMarginLeft (paraProps par) of

1400− Just px -> [("marL", show $ 12700 * px), ("indent", "0")]

1401− Nothing -> []

1402− ) ++

1403− (case pPropAlign (paraProps par) of

1404− Just AlgnLeft -> [("algn", "l")]

1405− Just AlgnRight -> [("algn", "r")]

1406− Just AlgnCenter -> [("algn", "ctr")]

1407− Nothing -> []

1408− )

1409− props = [] ++

1410− (case pPropSpaceBefore $ paraProps par of

1411− Just px -> [mknode "a:spcBef" [] [

1412− mknode "a:spcPts" [("val", show $ 100 * px)] ()

1413− ]

1414− ]

1415− Nothing -> []

1416− ) ++

1417− (case pPropBullet $ paraProps par of

1418− Just Bullet -> []

1419− Just (AutoNumbering attrs') ->

1420− [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()]

1421− Nothing -> [mknode "a:buNone" [] ()]

1422− )

1423− paras <- mapM paraElemToElement (combineParaElems $ paraElems par)

1424− return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras

1425−

1426−shapeToElement :: PandocMonad m => Element -> Shape -> P m Element

1427−shapeToElement layout (TextBox paras)

1428− | ns <- elemToNameSpaces layout

1429− , Just cSld <- findChild (elemName ns "p" "cSld") layout

1430− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

1431− sp <- getContentShape ns spTree

1432− elements <- mapM paragraphToElement paras

1433− let txBody = mknode "p:txBody" [] $

1434− [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements

1435− emptySpPr = mknode "p:spPr" [] ()

1436− return $

1437− surroundWithMathAlternate $

1438− replaceNamedChildren ns "p" "txBody" [txBody] $

1439− replaceNamedChildren ns "p" "spPr" [emptySpPr] $

1440− sp

1441−-- GraphicFrame and Pic should never reach this.

1442−shapeToElement _ _ = return $ mknode "p:sp" [] ()

1443−

1444−shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]

1445−shapeToElements layout (Pic picProps fp attr alt) = do

1446− mInfo <- registerMedia fp alt

1447− case mInfoExt mInfo of

1448− Just _ -> do

1449− makePicElements layout picProps mInfo attr alt

1450− Nothing -> shapeToElements layout $ TextBox [Paragraph def alt]

1451−shapeToElements layout (GraphicFrame tbls cptn) =

1452− graphicFrameToElements layout tbls cptn

1453−shapeToElements layout shp = do

1454− element <- shapeToElement layout shp

1455− return [element]

1456−

1457−shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element]

1458−shapesToElements layout shps = do

1459− concat <$> mapM (shapeToElements layout) shps

1460−

1461−hardcodedTableMargin :: Integer

1462−hardcodedTableMargin = 36

1463−

1464−graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element]

1465−graphicFrameToElements layout tbls caption = do

1466− -- get the sizing

1467− master <- getMaster

1468− (pageWidth, pageHeight) <- asks envPresentationSize

1469− let ns = elemToNameSpaces layout

1470− ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master

1471− `catchError`

1472− (\_ -> return ((0, 0), (pageWidth, pageHeight)))

1473−

1474− let cy = if (not $ null caption) then cytmp - captionHeight else cytmp

1475−

1476− elements <- mapM graphicToElement tbls

1477− let graphicFrameElts =

1478− mknode "p:graphicFrame" [] $

1479− [ mknode "p:nvGraphicFramePr" [] $

1480− [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()

1481− , mknode "p:cNvGraphicFramePr" [] $

1482− [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]

1483− , mknode "p:nvPr" [] $

1484− [mknode "p:ph" [("idx", "1")] ()]

1485− ]

1486− , mknode "p:xfrm" [] $

1487− [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] ()

1488− , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] ()

1489− ]

1490− ] ++ elements

1491−

1492− if (not $ null caption)

1493− then do capElt <- createCaption ((x, y), (cx, cytmp)) caption

1494− return [graphicFrameElts, capElt]

1495− else return [graphicFrameElts]

1496−

1497−graphicToElement :: PandocMonad m => Graphic -> P m Element

1498−graphicToElement (Tbl tblPr colWidths hdrCells rows) = do

1499− let cellToOpenXML paras =

1500− do elements <- mapM paragraphToElement paras

1501− let elements' = if null elements

1502− then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]]

1503− else elements

1504− return $

1505− [mknode "a:txBody" [] $

1506− ([ mknode "a:bodyPr" [] ()

1507− , mknode "a:lstStyle" [] ()]

1508− ++ elements')]

1509− headers' <- mapM cellToOpenXML hdrCells

1510− rows' <- mapM (mapM cellToOpenXML) rows

1511− let borderProps = mknode "a:tcPr" [] ()

1512− let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]]

1513− let mkcell border contents = mknode "a:tc" []

1514− $ (if null contents

1515− then emptyCell

1516− else contents) ++ [ borderProps | border ]

1517− let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells

1518−

1519− let mkgridcol w = mknode "a:gridCol"

1520− [("w", show ((12700 * w) :: Integer))] ()

1521− let hasHeader = not (all null hdrCells)

1522− return $ mknode "a:graphic" [] $

1523− [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $

1524− [mknode "a:tbl" [] $

1525− [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0")

1526− , ("bandRow", if tblPrBandRow tblPr then "1" else "0")

1527− ] ()

1528− , mknode "a:tblGrid" [] (if all (==0) colWidths

1529− then []

1530− else map mkgridcol colWidths)

1531− ]

1532− ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows'

1533− ]

1534− ]

1535−

1536−getShapeByName :: NameSpaces -> Element -> String -> Maybe Element

1537−getShapeByName ns spTreeElem name

1538− | isElem ns "p" "spTree" spTreeElem =

1539− filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem

1540− | otherwise = Nothing

1541−

1542−-- getShapeById :: NameSpaces -> Element -> String -> Maybe Element

1543−-- getShapeById ns spTreeElem ident

1544−-- | isElem ns "p" "spTree" spTreeElem =

1545−-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTreeElem

1546−-- | otherwise = Nothing

1547−

1548−nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element

1549−nonBodyTextToElement layout shapeName paraElements

1550− | ns <- elemToNameSpaces layout

1551− , Just cSld <- findChild (elemName ns "p" "cSld") layout

1552− , Just spTree <- findChild (elemName ns "p" "spTree") cSld

1553− , Just sp <- getShapeByName ns spTree shapeName = do

1554− let hdrPara = Paragraph def paraElements

1555− element <- paragraphToElement hdrPara

1556− let txBody = mknode "p:txBody" [] $

1557− [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++

1558− [element]

1559− return $ replaceNamedChildren ns "p" "txBody" [txBody] sp

1560− -- XXX: TODO

1561− | otherwise = return $ mknode "p:sp" [] ()

1562−

1563−contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element

1564−contentToElement layout hdrShape shapes

1565− | ns <- elemToNameSpaces layout

1566− , Just cSld <- findChild (elemName ns "p" "cSld") layout

1567− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

1568− element <- nonBodyTextToElement layout "Title 1" hdrShape

1569− let hdrShapeElements = if null hdrShape

1570− then []

1571− else [element]

1572− contentElements <- local

1573− (\env -> env {envContentType = NormalContent})

1574− (shapesToElements layout shapes)

1575− return $

1576− replaceNamedChildren ns "p" "sp"

1577− (hdrShapeElements ++ contentElements)

1578− spTree

1579−contentToElement _ _ _ = return $ mknode "p:sp" [] ()

1580−

1581−twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element

1582−twoColumnToElement layout hdrShape shapesL shapesR

1583− | ns <- elemToNameSpaces layout

1584− , Just cSld <- findChild (elemName ns "p" "cSld") layout

1585− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

1586− element <- nonBodyTextToElement layout "Title 1" hdrShape

1587− let hdrShapeElements = if null hdrShape

1588− then []

1589− else [element]

1590− contentElementsL <- local

1591− (\env -> env {envContentType =TwoColumnLeftContent})

1592− (shapesToElements layout shapesL)

1593− contentElementsR <- local

1594− (\env -> env {envContentType =TwoColumnRightContent})

1595− (shapesToElements layout shapesR)

1596− -- let contentElementsL' = map (setIdx ns "1") contentElementsL

1597− -- contentElementsR' = map (setIdx ns "2") contentElementsR

1598− return $

1599− replaceNamedChildren ns "p" "sp"

1600− (hdrShapeElements ++ contentElementsL ++ contentElementsR)

1601− spTree

1602−twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] ()

1603−

1604−

1605−titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element

1606−titleToElement layout titleElems

1607− | ns <- elemToNameSpaces layout

1608− , Just cSld <- findChild (elemName ns "p" "cSld") layout

1609− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

1610− element <- nonBodyTextToElement layout "Title 1" titleElems

1611− let titleShapeElements = if null titleElems

1612− then []

1613− else [element]

1614− return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree

1615−titleToElement _ _ = return $ mknode "p:sp" [] ()

1616−

1617−metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element

1618−metadataToElement layout titleElems subtitleElems authorsElems dateElems

1619− | ns <- elemToNameSpaces layout

1620− , Just cSld <- findChild (elemName ns "p" "cSld") layout

1621− , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

1622− titleShapeElements <- if null titleElems

1623− then return []

1624− else sequence [nonBodyTextToElement layout "Title 1" titleElems]

1625− let combinedAuthorElems = intercalate [Break] authorsElems

1626− subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems]

1627− subtitleShapeElements <- if null subtitleAndAuthorElems

1628− then return []

1629− else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems]

1630− dateShapeElements <- if null dateElems

1631− then return []

1632− else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems]

1633− return $ replaceNamedChildren ns "p" "sp"

1634− (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements)

1635− spTree

1636−metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] ()

1637−

1638−slideToElement :: PandocMonad m => Slide -> P m Element

1639−slideToElement s@(ContentSlide hdrElems shapes) = do

1640− layout <- getLayout s

1641− spTree <- local (\env -> if null hdrElems

1642− then env

1643− else env{envSlideHasHeader=True}) $

1644− contentToElement layout hdrElems shapes

1645− return $ mknode "p:sld"

1646− [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

1647− ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

1648− ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

1649− ] [mknode "p:cSld" [] [spTree]]

1650−slideToElement s@(TwoColumnSlide hdrElems shapesL shapesR) = do

1651− layout <- getLayout s

1652− spTree <- local (\env -> if null hdrElems

1653− then env

1654− else env{envSlideHasHeader=True}) $

1655− twoColumnToElement layout hdrElems shapesL shapesR

1656− return $ mknode "p:sld"

1657− [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

1658− ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

1659− ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

1660− ] [mknode "p:cSld" [] [spTree]]

1661−slideToElement s@(TitleSlide hdrElems) = do

1662− layout <- getLayout s

1663− spTree <- titleToElement layout hdrElems

1664− return $ mknode "p:sld"

1665− [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

1666− ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

1667− ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

1668− ] [mknode "p:cSld" [] [spTree]]

1669−slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do

1670− layout <- getLayout s

1671− spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems

1672− return $ mknode "p:sld"

1673− [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

1674− ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

1675− ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

1676− ] [mknode "p:cSld" [] [spTree]]

1677−

1678−-----------------------------------------------------------------------

1679−

1680−slideToFilePath :: Slide -> Int -> FilePath

1681−slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"

1682−

1683−slideToSlideId :: Monad m => Slide -> Int -> P m String

1684−slideToSlideId _ idNum = do

1685− n <- asks envSlideIdOffset

1686− return $ "rId" ++ (show $ idNum + n)

1687−

1688−

1689−data Relationship = Relationship { relId :: Int

1690− , relType :: MimeType

1691− , relTarget :: FilePath

1692− } deriving (Show, Eq)

1693−

1694−elementToRel :: Element -> Maybe Relationship

1695−elementToRel element

1696− | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing =

1697− do rId <- findAttr (QName "Id" Nothing Nothing) element

1698− numStr <- stripPrefix "rId" rId

1699− num <- case reads numStr :: [(Int, String)] of

1700− (n, _) : _ -> Just n

1701− [] -> Nothing

1702− type' <- findAttr (QName "Type" Nothing Nothing) element

1703− target <- findAttr (QName "Target" Nothing Nothing) element

1704− return $ Relationship num type' target

1705− | otherwise = Nothing

1706−

1707−slideToPresRel :: Monad m => Slide -> Int -> P m Relationship

1708−slideToPresRel slide idNum = do

1709− n <- asks envSlideIdOffset

1710− let rId = idNum + n

1711− fp = "slides/" ++ slideToFilePath slide idNum

1712− return $ Relationship { relId = rId

1713− , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"

1714− , relTarget = fp

1715− }

1716−

1717−getRels :: PandocMonad m => P m [Relationship]

1718−getRels = do

1719− refArchive <- asks envRefArchive

1720− distArchive <- asks envDistArchive

1721− relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels"

1722− let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"

1723− let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem

1724− return $ mapMaybe elementToRel relElems

1725−

1726−presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]

1727−presentationToRels (Presentation slides) = do

1728− mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]

1729− rels <- getRels

1730− let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels

1731− -- We want to make room for the slides in the id space. The slides

1732− -- will start at Id2 (since Id1 is for the slide master). There are

1733− -- two slides in the data file, but that might change in the future,

1734− -- so we will do this:

1735− --

1736− -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is.

1737− -- 2. We add the difference between this and the number of slides to

1738− -- all relWithoutSlide rels (unless they're 1)

1739−

1740− let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of

1741− [] -> 0 -- doesn't matter in this case, since

1742− -- there will be nothing to map the

1743− -- function over

1744− l -> minimum l

1745−

1746− modifyRelNum :: Int -> Int

1747− modifyRelNum 1 = 1

1748− modifyRelNum n = n - minRelNotOne + 2 + length slides

1749−

1750− relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides

1751−

1752− return $ mySlideRels ++ relsWithoutSlides'

1753−

1754−relToElement :: Relationship -> Element

1755−relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel))

1756− , ("Type", relType rel)

1757− , ("Target", relTarget rel) ] ()

1758−

1759−relsToElement :: [Relationship] -> Element

1760−relsToElement rels = mknode "Relationships"

1761− [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]

1762− (map relToElement rels)

1763−

1764−presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry

1765−presentationToRelsEntry pres = do

1766− rels <- presentationToRels pres

1767− elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels

1768−

1769−elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry

1770−elemToEntry fp element = do

1771− epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime

1772− return $ toEntry fp epochtime $ renderXml element

1773−

1774−slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry

1775−slideToEntry slide idNum = do

1776− local (\env -> env{envCurSlideId = idNum}) $ do

1777− element <- slideToElement slide

1778− elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element

1779−

1780−slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry

1781−slideToSlideRelEntry slide idNum = do

1782− element <- slideToSlideRelElement slide idNum

1783− elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element

1784−

1785−linkRelElement :: PandocMonad m => Int -> (URL, String) -> P m (Maybe Element)

1786−linkRelElement idNum (url, _) = do

1787− anchorMap <- gets stAnchorMap

1788− case url of

1789− -- if it's an anchor in the map, we use the slide number for an

1790− -- internal link.

1791− '#' : anchor | Just num <- M.lookup anchor anchorMap ->

1792− return $ Just $

1793− mknode "Relationship" [ ("Id", "rId" ++ show idNum)

1794− , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")

1795− , ("Target", "slide" ++ show num ++ ".xml")

1796− ] ()

1797− -- if it's an anchor not in the map, we return nothing.

1798− '#' : _ -> return Nothing

1799− -- Anything else we treat as an external link

1800− _ ->

1801− return $ Just $

1802− mknode "Relationship" [ ("Id", "rId" ++ show idNum)

1803− , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")

1804− , ("Target", url)

1805− , ("TargetMode", "External")

1806− ] ()

1807−

1808−linkRelElements :: PandocMonad m => M.Map Int (URL, String) -> P m [Element]

1809−linkRelElements mp = catMaybes <$> mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)

1810−

1811−mediaRelElement :: MediaInfo -> Element

1812−mediaRelElement mInfo =

1813− let ext = case mInfoExt mInfo of

1814− Just e -> e

1815− Nothing -> ""

1816− in

1817− mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo))

1818− , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")

1819− , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)

1820− ] ()

1821−

1822−slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element

1823−slideToSlideRelElement slide idNum = do

1824− let target = case slide of

1825− (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml"

1826− (TitleSlide _) -> "../slideLayouts/slideLayout3.xml"

1827− (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml"

1828− (TwoColumnSlide _ _ _) -> "../slideLayouts/slideLayout4.xml"

1829−

1830− linkIds <- gets stLinkIds

1831− mediaIds <- gets stMediaIds

1832−

1833− linkRels <- case M.lookup idNum linkIds of

1834− Just mp -> linkRelElements mp

1835− Nothing -> return []

1836− let mediaRels = case M.lookup idNum mediaIds of

1837− Just mInfos -> map mediaRelElement mInfos

1838− Nothing -> []

1839−

1840− return $

1841− mknode "Relationships"

1842− [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]

1843− ([mknode "Relationship" [ ("Id", "rId1")

1844− , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")

1845− , ("Target", target)] ()

1846− ] ++ linkRels ++ mediaRels)

1847−

1848−slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element

1849−slideToSldIdElement slide idNum = do

1850− let id' = show $ idNum + 255

1851− rId <- slideToSlideId slide idNum

1852− return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()

1853−

1854−presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element

1855−presentationToSldIdLst (Presentation slides) = do

1856− ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])

1857− return $ mknode "p:sldIdLst" [] ids

1858−

1859−presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element

1860−presentationToPresentationElement pres = do

1861− refArchive <- asks envRefArchive

1862− distArchive <- asks envDistArchive

1863− element <- parseXml refArchive distArchive "ppt/presentation.xml"

1864− sldIdLst <- presentationToSldIdLst pres

1865−

1866− let modifySldIdLst :: Content -> Content

1867− modifySldIdLst (Elem e) = case elName e of

1868− (QName "sldIdLst" _ _) -> Elem sldIdLst

1869− _ -> Elem e

1870− modifySldIdLst ct = ct

1871−

1872− newContent = map modifySldIdLst $ elContent element

1873−

1874− return $ element{elContent = newContent}

1875−

1876−presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry

1877−presentationToPresEntry pres = presentationToPresentationElement pres >>=

1878− elemToEntry "ppt/presentation.xml"

1879−

1880−

1881−

1882−

1883−defaultContentTypeToElem :: DefaultContentType -> Element

1884−defaultContentTypeToElem dct =

1885− mknode "Default"

1886− [("Extension", defContentTypesExt dct),

1887− ("ContentType", defContentTypesType dct)]

1888− ()

1889−

1890−overrideContentTypeToElem :: OverrideContentType -> Element

1891−overrideContentTypeToElem oct =

1892− mknode "Override"

1893− [("PartName", overrideContentTypesPart oct),

1894− ("ContentType", overrideContentTypesType oct)]

1895− ()

1896−

1897−contentTypesToElement :: ContentTypes -> Element

1898−contentTypesToElement ct =

1899− let ns = "http://schemas.openxmlformats.org/package/2006/content-types"

1900− in

1901− mknode "Types" [("xmlns", ns)] $

1902− (map defaultContentTypeToElem $ contentTypesDefaults ct) ++

1903− (map overrideContentTypeToElem $ contentTypesOverrides ct)

1904−

1905−data DefaultContentType = DefaultContentType

1906− { defContentTypesExt :: String

1907− , defContentTypesType:: MimeType

1908− }

1909− deriving (Show, Eq)

1910−

1911−data OverrideContentType = OverrideContentType

1912− { overrideContentTypesPart :: FilePath

1913− , overrideContentTypesType :: MimeType

1914− }

1915− deriving (Show, Eq)

1916−

1917−data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType]

1918− , contentTypesOverrides :: [OverrideContentType]

1919− }

1920− deriving (Show, Eq)

1921−

1922−contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry

1923−contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct

1924−

1925−pathToOverride :: FilePath -> Maybe OverrideContentType

1926−pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)

1927−

1928−mediaFileContentType :: FilePath -> Maybe DefaultContentType

1929−mediaFileContentType fp = case takeExtension fp of

1930− '.' : ext -> Just $

1931− DefaultContentType { defContentTypesExt = ext

1932− , defContentTypesType =

1933− case getMimeType fp of

1934− Just mt -> mt

1935− Nothing -> "application/octet-stream"

1936− }

1937− _ -> Nothing

1938−

1939−mediaContentType :: MediaInfo -> Maybe DefaultContentType

1940−mediaContentType mInfo

1941− | Just ('.' : ext) <- mInfoExt mInfo =

1942− Just $ DefaultContentType { defContentTypesExt = ext

1943− , defContentTypesType =

1944− case mInfoMimeType mInfo of

1945− Just mt -> mt

1946− Nothing -> "application/octet-stream"

1947− }

1948− | otherwise = Nothing

1949−

1950−presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes

1951−presentationToContentTypes (Presentation slides) = do

1952− mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds

1953− filePaths <- patternsToFilePaths inheritedPatterns

1954− let mediaFps = filter (match (compile "ppt/media/image*")) filePaths

1955− let defaults = [ DefaultContentType "xml" "application/xml"

1956− , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"

1957− ]

1958− mediaDefaults = nub $

1959− (mapMaybe mediaContentType $ mediaInfos) ++

1960− (mapMaybe mediaFileContentType $ mediaFps)

1961−

1962− inheritedOverrides = mapMaybe pathToOverride filePaths

1963− presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]

1964− slideOverrides =

1965− mapMaybe

1966− (\(s, n) ->

1967− pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)

1968− (zip slides [1..])

1969− -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]

1970− return $ ContentTypes

1971− (defaults ++ mediaDefaults)

1972− (inheritedOverrides ++ presOverride ++ slideOverrides)

1973−

1974−presML :: String

1975−presML = "application/vnd.openxmlformats-officedocument.presentationml"

1976−

1977−noPresML :: String

1978−noPresML = "application/vnd.openxmlformats-officedocument"

1979−

1980−getContentType :: FilePath -> Maybe MimeType

1981−getContentType fp

1982− | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml"

1983− | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml"

1984− | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml"

1985− | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml"

1986− | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml"

1987− | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml"

1988− | "ppt" : "slideMasters" : f : [] <- splitDirectories fp

1989− , (_, ".xml") <- splitExtension f =

1990− Just $ presML ++ ".slideMaster+xml"

1991− | "ppt" : "slides" : f : [] <- splitDirectories fp

1992− , (_, ".xml") <- splitExtension f =

1993− Just $ presML ++ ".slide+xml"

1994− | "ppt" : "notesMasters" : f : [] <- splitDirectories fp

1995− , (_, ".xml") <- splitExtension f =

1996− Just $ presML ++ ".notesMaster+xml"

1997− | "ppt" : "notesSlides" : f : [] <- splitDirectories fp

1998− , (_, ".xml") <- splitExtension f =

1999− Just $ presML ++ ".notesSlide+xml"

2000− | "ppt" : "theme" : f : [] <- splitDirectories fp

2001− , (_, ".xml") <- splitExtension f =

2002− Just $ noPresML ++ ".theme+xml"

2003− | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp=

2004− Just $ presML ++ ".slideLayout+xml"

2005− | otherwise = Nothing

2006−

2007−-------------------------------------------------------

2008−

2009−combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem]

2010−combineParaElems' mbPElem [] = maybeToList mbPElem

2011−combineParaElems' Nothing (pElem : pElems) =

2012− combineParaElems' (Just pElem) pElems

2013−combineParaElems' (Just pElem') (pElem : pElems)

2014− | Run rPr' s' <- pElem'

2015− , Run rPr s <- pElem

2016− , rPr == rPr' =

2017− combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems

2018− | otherwise =

2019− pElem' : combineParaElems' (Just pElem) pElems

2020−

2021−combineParaElems :: [ParaElem] -> [ParaElem]

2022−combineParaElems = combineParaElems' Nothing

src/Text/Pandoc/Writers/Powerpoint/Output.hsnew file+1431

@@ -0,0 +1,1431 @@

1+{-# LANGUAGE PatternGuards #-}

3+{-

6+This program is free software; you can redistribute it and/or modify

7+it under the terms of the GNU General Public License as published by

8+the Free Software Foundation; either version 2 of the License, or

9+(at your option) any later version.

10+

11+This program is distributed in the hope that it will be useful,

12+but WITHOUT ANY WARRANTY; without even the implied warranty of

13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

14+GNU General Public License for more details.

15+

16+You should have received a copy of the GNU General Public License

17+along with this program; if not, write to the Free Software

18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

19+-}

20+

21+{- |

22+ Module : Text.Pandoc.Writers.Powerpoint.Output

24+ License : GNU GPL, version 2 or above

25+

26+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>

27+ Stability : alpha

28+ Portability : portable

29+

30+Conversion of Presentation datatype (defined in

31+Text.Pandoc.Writers.Powerpoint.Presentation) to a zip archive.

32+-}

33+

34+module Text.Pandoc.Writers.Powerpoint.Output ( presentationToArchive

35+ ) where

36+

37+import Control.Monad.Except (throwError, catchError)

38+import Control.Monad.Reader

39+import Control.Monad.State

40+import Codec.Archive.Zip

41+import Data.List (intercalate, stripPrefix, nub, union)

42+import Data.Default

43+import Data.Time.Clock (UTCTime)

44+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)

45+import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)

46+import Text.XML.Light

47+import Text.Pandoc.Definition

48+import qualified Text.Pandoc.UTF8 as UTF8

49+import Text.Pandoc.Class (PandocMonad)

50+import Text.Pandoc.Error (PandocError(..))

51+import qualified Text.Pandoc.Class as P

52+import Text.Pandoc.Options

53+import Text.Pandoc.MIME

54+import qualified Data.ByteString.Lazy as BL

55+import Text.Pandoc.Writers.OOXML

56+import qualified Data.Map as M

57+import Data.Maybe (mapMaybe, listToMaybe, catMaybes)

58+import Text.Pandoc.ImageSize

59+import Control.Applicative ((<|>))

60+import System.FilePath.Glob

61+import Text.TeXMath

62+import Text.Pandoc.Writers.Math (convertMath)

63+import Text.Pandoc.Writers.Powerpoint.Presentation

64+

65+-- This populates the global ids map with images already in the

66+-- template, so the ids won't be used by images introduced by the

67+-- user.

68+initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int

69+initialGlobalIds refArchive distArchive =

70+ let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive

71+ mediaPaths = filter (match (compile "ppt/media/image")) archiveFiles

72+

73+ go :: FilePath -> Maybe (FilePath, Int)

74+ go fp = do

75+ s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp

76+ (n, _) <- listToMaybe $ reads s

77+ return (fp, n)

78+ in

79+ M.fromList $ mapMaybe go mediaPaths

80+

81+getPresentationSize :: Archive -> Archive -> Maybe (Integer, Integer)

82+getPresentationSize refArchive distArchive = do

83+ entry <- findEntryByPath "ppt/presentation.xml" refArchive `mplus`

84+ findEntryByPath "ppt/presentation.xml" distArchive

85+ presElement <- parseXMLDoc $ UTF8.toStringLazy $ fromEntry entry

86+ let ns = elemToNameSpaces presElement

87+ sldSize <- findChild (elemName ns "p" "sldSz") presElement

88+ cxS <- findAttr (QName "cx" Nothing Nothing) sldSize

89+ cyS <- findAttr (QName "cy" Nothing Nothing) sldSize

90+ (cx, _) <- listToMaybe $ reads cxS :: Maybe (Integer, String)

91+ (cy, _) <- listToMaybe $ reads cyS :: Maybe (Integer, String)

92+ return (cx `div` 12700, cy `div` 12700)

93+

94+data WriterEnv = WriterEnv { envRefArchive :: Archive

95+ , envDistArchive :: Archive

96+ , envUTCTime :: UTCTime

97+ , envOpts :: WriterOptions

98+ , envPresentationSize :: (Integer, Integer)

99+ , envSlideHasHeader :: Bool

100+ , envInList :: Bool

101+ , envInNoteSlide :: Bool

102+ , envCurSlideId :: Int

103+ -- the difference between the number at

104+ -- the end of the slide file name and

105+ -- the rId number

106+ , envSlideIdOffset :: Int

107+ , envContentType :: ContentType

108+ }

109+ deriving (Show)

110+

111+instance Default WriterEnv where

112+ def = WriterEnv { envRefArchive = emptyArchive

113+ , envDistArchive = emptyArchive

114+ , envUTCTime = posixSecondsToUTCTime 0

115+ , envOpts = def

116+ , envPresentationSize = (720, 540)

117+ , envSlideHasHeader = False

118+ , envInList = False

119+ , envInNoteSlide = False

120+ , envCurSlideId = 1

121+ , envSlideIdOffset = 1

122+ , envContentType = NormalContent

123+ }

124+

125+data ContentType = NormalContent

126+ | TwoColumnLeftContent

127+ | TwoColumnRightContent

128+ deriving (Show, Eq)

129+

130+data MediaInfo = MediaInfo { mInfoFilePath :: FilePath

131+ , mInfoLocalId :: Int

132+ , mInfoGlobalId :: Int

133+ , mInfoMimeType :: Maybe MimeType

134+ , mInfoExt :: Maybe String

135+ , mInfoCaption :: Bool

136+ } deriving (Show, Eq)

137+

138+data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String))

139+ -- (FP, Local ID, Global ID, Maybe Mime)

140+ , stMediaIds :: M.Map Int [MediaInfo]

141+ , stMediaGlobalIds :: M.Map FilePath Int

142+ , stNoteIds :: M.Map Int [Block]

143+ -- associate anchors with slide id

144+ , stAnchorMap :: M.Map String Int

145+ -- media inherited from the template.

146+ , stTemplateMedia :: [FilePath]

147+ } deriving (Show, Eq)

148+

149+instance Default WriterState where

150+ def = WriterState { stLinkIds = mempty

151+ , stMediaIds = mempty

152+ , stMediaGlobalIds = mempty

153+ , stNoteIds = mempty

154+ , stAnchorMap= mempty

155+ , stTemplateMedia = []

156+ }

157+

158+type P m = ReaderT WriterEnv (StateT WriterState m)

159+

160+runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a

161+runP env st p = evalStateT (runReaderT p env) st

162+

163+--------------------------------------------------------------------

164+

165+copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive

166+copyFileToArchive arch fp = do

167+ refArchive <- asks envRefArchive

168+ distArchive <- asks envDistArchive

169+ case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of

170+ Nothing -> fail $ fp ++ " missing in reference file"

171+ Just e -> return $ addEntryToArchive e arch

172+

173+inheritedPatterns :: [Pattern]

174+inheritedPatterns = map compile [ "_rels/.rels"

175+ , "docProps/app.xml"

176+ , "docProps/core.xml"

177+ , "ppt/slideLayouts/slideLayout*.xml"

178+ , "ppt/slideLayouts/_rels/slideLayout*.xml.rels"

179+ , "ppt/slideMasters/slideMaster1.xml"

180+ , "ppt/slideMasters/_rels/slideMaster1.xml.rels"

181+ , "ppt/theme/theme1.xml"

182+ , "ppt/theme/_rels/theme1.xml.rels"

183+ , "ppt/presProps.xml"

184+ , "ppt/viewProps.xml"

185+ , "ppt/tableStyles.xml"

186+ , "ppt/media/image*"

187+ ]

188+

189+patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]

190+patternToFilePaths pat = do

191+ refArchive <- asks envRefArchive

192+ distArchive <- asks envDistArchive

193+

194+ let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive

195+ return $ filter (match pat) archiveFiles

196+

197+patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]

198+patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats

199+

200+-- Here are the files we'll require to make a Powerpoint document. If

201+-- any of these are missing, we should error out of our build.

202+requiredFiles :: [FilePath]

203+requiredFiles = [ "_rels/.rels"

204+ , "docProps/app.xml"

205+ , "docProps/core.xml"

206+ , "ppt/presProps.xml"

207+ , "ppt/slideLayouts/slideLayout1.xml"

208+ , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"

209+ , "ppt/slideLayouts/slideLayout2.xml"

210+ , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"

211+ , "ppt/slideLayouts/slideLayout3.xml"

212+ , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"

213+ , "ppt/slideLayouts/slideLayout4.xml"

214+ , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"

215+ , "ppt/slideMasters/slideMaster1.xml"

216+ , "ppt/slideMasters/_rels/slideMaster1.xml.rels"

217+ , "ppt/theme/theme1.xml"

218+ , "ppt/viewProps.xml"

219+ , "ppt/tableStyles.xml"

220+ ]

221+

222+

223+presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive

224+presentationToArchiveP p@(Presentation slides) = do

225+ filePaths <- patternsToFilePaths inheritedPatterns

226+

227+ -- make sure all required files are available:

228+ let missingFiles = filter (\fp -> not (fp `elem` filePaths)) requiredFiles

229+ unless (null missingFiles)

230+ (throwError $

231+ PandocSomeError $

232+ "The following required files are missing:\n" ++

233+ (unlines $ map (" " ++) missingFiles)

234+ )

235+

236+ newArch' <- foldM copyFileToArchive emptyArchive filePaths

237+ -- presentation entry and rels. We have to do the rels first to make

238+ -- sure we know the correct offset for the rIds.

239+ presEntry <- presentationToPresEntry p

240+ presRelsEntry <- presentationToRelsEntry p

241+ slideEntries <- mapM (\(s, n) -> slideToEntry s n) $ zip slides [1..]

242+ slideRelEntries <- mapM (\(s,n) -> slideToSlideRelEntry s n) $ zip slides [1..]

243+ -- These have to come after everything, because they need the info

244+ -- built up in the state.

245+ mediaEntries <- makeMediaEntries

246+ contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry

247+ -- fold everything into our inherited archive and return it.

248+ return $ foldr addEntryToArchive newArch' $

249+ slideEntries ++

250+ slideRelEntries ++

251+ mediaEntries ++

252+ [contentTypesEntry, presEntry, presRelsEntry]

253+

254+presentationToArchive :: PandocMonad m => WriterOptions -> Presentation -> m Archive

255+presentationToArchive opts pres = do

256+ distArchive <- (toArchive . BL.fromStrict) <$>

257+ P.readDefaultDataFile "reference.pptx"

258+ refArchive <- case writerReferenceDoc opts of

259+ Just f -> toArchive <$> P.readFileLazy f

260+ Nothing -> (toArchive . BL.fromStrict) <$>

261+ P.readDataFile "reference.pptx"

262+

263+ utctime <- P.getCurrentTime

264+

265+ presSize <- case getPresentationSize refArchive distArchive of

266+ Just sz -> return sz

267+ Nothing -> throwError $

268+ PandocSomeError $

269+ "Could not determine presentation size"

270+

271+ let env = def { envRefArchive = refArchive

272+ , envDistArchive = distArchive

273+ , envUTCTime = utctime

274+ , envOpts = opts

275+ , envPresentationSize = presSize

276+ }

277+

278+ let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive

279+ }

280+

281+ runP env st $ presentationToArchiveP pres

282+

283+

284+

285+--------------------------------------------------

286+

287+--------------------------------------------------

288+

289+getLayout :: PandocMonad m => Slide -> P m Element

290+getLayout slide = do

291+ let layoutpath = case slide of

292+ (MetadataSlide _ _ _ _) -> "ppt/slideLayouts/slideLayout1.xml"

293+ (TitleSlide _) -> "ppt/slideLayouts/slideLayout3.xml"

294+ (ContentSlide _ _) -> "ppt/slideLayouts/slideLayout2.xml"

295+ (TwoColumnSlide _ _ _) -> "ppt/slideLayouts/slideLayout4.xml"

296+ distArchive <- asks envDistArchive

297+ root <- case findEntryByPath layoutpath distArchive of

298+ Just e -> case parseXMLDoc $ UTF8.toStringLazy $ fromEntry e of

299+ Just element -> return $ element

300+ Nothing -> throwError $

301+ PandocSomeError $

302+ layoutpath ++ " corrupt in reference file"

303+ Nothing -> throwError $

304+ PandocSomeError $

305+ layoutpath ++ " missing in reference file"

306+ return root

307+

308+shapeHasName :: NameSpaces -> String -> Element -> Bool

309+shapeHasName ns name element

310+ | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element

311+ , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr

312+ , Just nm <- findAttr (QName "name" Nothing Nothing) cNvPr =

313+ nm == name

314+ | otherwise = False

315+

316+shapeHasId :: NameSpaces -> String -> Element -> Bool

317+shapeHasId ns ident element

318+ | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element

319+ , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr

320+ , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr =

321+ nm == ident

322+ | otherwise = False

323+

324+-- The content shape in slideLayout2 (Title/Content) has id=3 In

325+-- slideLayout4 (two column) the left column is id=3, and the right

326+-- column is id=4.

327+getContentShape :: PandocMonad m => NameSpaces -> Element -> P m Element

328+getContentShape ns spTreeElem

329+ | isElem ns "p" "spTree" spTreeElem = do

330+ contentType <- asks envContentType

331+ let ident = case contentType of

332+ NormalContent -> "3"

333+ TwoColumnLeftContent -> "3"

334+ TwoColumnRightContent -> "4"

335+ case filterChild

336+ (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e))

337+ spTreeElem

338+ of

339+ Just e -> return e

340+ Nothing -> throwError $

341+ PandocSomeError $

342+ "Could not find shape for Powerpoint content"

343+getContentShape _ _ = throwError $

344+ PandocSomeError $

345+ "Attempted to find content on non shapeTree"

346+

347+getShapeDimensions :: NameSpaces

348+ -> Element

349+ -> Maybe ((Integer, Integer), (Integer, Integer))

350+getShapeDimensions ns element

351+ | isElem ns "p" "sp" element = do

352+ spPr <- findChild (elemName ns "p" "spPr") element

353+ xfrm <- findChild (elemName ns "a" "xfrm") spPr

354+ off <- findChild (elemName ns "a" "off") xfrm

355+ xS <- findAttr (QName "x" Nothing Nothing) off

356+ yS <- findAttr (QName "y" Nothing Nothing) off

357+ ext <- findChild (elemName ns "a" "ext") xfrm

358+ cxS <- findAttr (QName "cx" Nothing Nothing) ext

359+ cyS <- findAttr (QName "cy" Nothing Nothing) ext

360+ (x, _) <- listToMaybe $ reads xS

361+ (y, _) <- listToMaybe $ reads yS

362+ (cx, _) <- listToMaybe $ reads cxS

363+ (cy, _) <- listToMaybe $ reads cyS

364+ return $ ((x `div` 12700, y `div` 12700), (cx `div` 12700, cy `div` 12700))

365+ | otherwise = Nothing

366+

367+

368+getMasterShapeDimensionsById :: String

369+ -> Element

370+ -> Maybe ((Integer, Integer), (Integer, Integer))

371+getMasterShapeDimensionsById ident master = do

372+ let ns = elemToNameSpaces master

373+ cSld <- findChild (elemName ns "p" "cSld") master

374+ spTree <- findChild (elemName ns "p" "spTree") cSld

375+ sp <- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTree

376+ getShapeDimensions ns sp

377+

378+getContentShapeSize :: PandocMonad m

379+ => NameSpaces

380+ -> Element

381+ -> Element

382+ -> P m ((Integer, Integer), (Integer, Integer))

383+getContentShapeSize ns layout master

384+ | isElem ns "p" "sldLayout" layout

385+ , Just cSld <- findChild (elemName ns "p" "cSld") layout

386+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

387+ sp <- getContentShape ns spTree

388+ case getShapeDimensions ns sp of

389+ Just sz -> return sz

390+ Nothing -> do let mbSz =

391+ findChild (elemName ns "p" "nvSpPr") sp >>=

392+ findChild (elemName ns "p" "cNvPr") >>=

393+ findAttr (QName "id" Nothing Nothing) >>=

394+ flip getMasterShapeDimensionsById master

395+ case mbSz of

396+ Just sz' -> return sz'

397+ Nothing -> throwError $

398+ PandocSomeError $

399+ "Couldn't find necessary content shape size"

400+getContentShapeSize _ _ _ = throwError $

401+ PandocSomeError $

402+ "Attempted to find content shape size in non-layout"

403+

404+replaceNamedChildren :: NameSpaces

405+ -> String

406+ -> String

407+ -> [Element]

408+ -> Element

409+ -> Element

410+replaceNamedChildren ns prefix name newKids element =

411+ element { elContent = concat $ fun True $ elContent element }

412+ where

413+ fun :: Bool -> [Content] -> [[Content]]

414+ fun _ [] = []

415+ fun switch ((Elem e) : conts) | isElem ns prefix name e =

416+ if switch

417+ then (map Elem $ newKids) : fun False conts

418+ else fun False conts

419+ fun switch (cont : conts) = [cont] : fun switch conts

420+

421+----------------------------------------------------------------

422+

423+registerLink :: PandocMonad m => (URL, String) -> P m Int

424+registerLink link = do

425+ curSlideId <- asks envCurSlideId

426+ linkReg <- gets stLinkIds

427+ mediaReg <- gets stMediaIds

428+ let maxLinkId = case M.lookup curSlideId linkReg of

429+ Just mp -> case M.keys mp of

430+ [] -> 1

431+ ks -> maximum ks

432+ Nothing -> 1

433+ maxMediaId = case M.lookup curSlideId mediaReg of

434+ Just [] -> 1

435+ Just mInfos -> maximum $ map mInfoLocalId mInfos

436+ Nothing -> 1

437+ maxId = max maxLinkId maxMediaId

438+ slideLinks = case M.lookup curSlideId linkReg of

439+ Just mp -> M.insert (maxId + 1) link mp

440+ Nothing -> M.singleton (maxId + 1) link

441+ modify $ \st -> st{ stLinkIds = M.insert curSlideId slideLinks linkReg}

442+ return $ maxId + 1

443+

444+registerMedia :: PandocMonad m => FilePath -> [ParaElem] -> P m MediaInfo

445+registerMedia fp caption = do

446+ curSlideId <- asks envCurSlideId

447+ linkReg <- gets stLinkIds

448+ mediaReg <- gets stMediaIds

449+ globalIds <- gets stMediaGlobalIds

450+ let maxLinkId = case M.lookup curSlideId linkReg of

451+ Just mp -> case M.keys mp of

452+ [] -> 1

453+ ks -> maximum ks

454+ Nothing -> 1

455+ maxMediaId = case M.lookup curSlideId mediaReg of

456+ Just [] -> 1

457+ Just mInfos -> maximum $ map mInfoLocalId mInfos

458+ Nothing -> 1

459+ maxLocalId = max maxLinkId maxMediaId

460+

461+ maxGlobalId = case M.elems globalIds of

462+ [] -> 0

463+ ids -> maximum ids

464+

465+ (imgBytes, mbMt) <- P.fetchItem fp

466+ let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x))

467+ <|>

468+ case imageType imgBytes of

469+ Just Png -> Just ".png"

470+ Just Jpeg -> Just ".jpeg"

471+ Just Gif -> Just ".gif"

472+ Just Pdf -> Just ".pdf"

473+ Just Eps -> Just ".eps"

474+ Just Svg -> Just ".svg"

475+ Nothing -> Nothing

476+

477+ let newGlobalId = case M.lookup fp globalIds of

478+ Just ident -> ident

479+ Nothing -> maxGlobalId + 1

480+

481+ let newGlobalIds = M.insert fp newGlobalId globalIds

482+

483+ let mediaInfo = MediaInfo { mInfoFilePath = fp

484+ , mInfoLocalId = maxLocalId + 1

485+ , mInfoGlobalId = newGlobalId

486+ , mInfoMimeType = mbMt

487+ , mInfoExt = imgExt

488+ , mInfoCaption = (not . null) caption

489+ }

490+

491+ let slideMediaInfos = case M.lookup curSlideId mediaReg of

492+ Just minfos -> mediaInfo : minfos

493+ Nothing -> [mediaInfo]

494+

495+

496+ modify $ \st -> st{ stMediaIds = M.insert curSlideId slideMediaInfos mediaReg

497+ , stMediaGlobalIds = newGlobalIds

498+ }

499+ return mediaInfo

500+

501+makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry

502+makeMediaEntry mInfo = do

503+ epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime

504+ (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)

505+ let ext = case mInfoExt mInfo of

506+ Just e -> e

507+ Nothing -> ""

508+ let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext

509+ return $ toEntry fp epochtime $ BL.fromStrict imgBytes

510+

511+makeMediaEntries :: PandocMonad m => P m [Entry]

512+makeMediaEntries = do

513+ mediaInfos <- gets stMediaIds

514+ let allInfos = mconcat $ M.elems mediaInfos

515+ mapM makeMediaEntry allInfos

516+

517+-- -- | Scales the image to fit the page

518+-- -- sizes are passed in emu

519+-- fitToPage' :: (Double, Double) -- image size in emu

520+-- -> Integer -- pageWidth

521+-- -> Integer -- pageHeight

522+-- -> (Integer, Integer) -- imagesize

523+-- fitToPage' (x, y) pageWidth pageHeight

524+-- -- Fixes width to the page width and scales the height

525+-- | x <= fromIntegral pageWidth && y <= fromIntegral pageHeight =

526+-- (floor x, floor y)

527+-- | x / fromIntegral pageWidth > y / fromIntegral pageWidth =

528+-- (pageWidth, floor $ ((fromIntegral pageWidth) / x) * y)

529+-- | otherwise =

530+-- (floor $ ((fromIntegral pageHeight) / y) * x, pageHeight)

531+

532+-- positionImage :: (Double, Double) -> Integer -> Integer -> (Integer, Integer)

533+-- positionImage (x, y) pageWidth pageHeight =

534+-- let (x', y') = fitToPage' (x, y) pageWidth pageHeight

535+-- in

536+-- ((pageWidth - x') `div` 2, (pageHeight - y') `div` 2)

537+

538+getMaster :: PandocMonad m => P m Element

539+getMaster = do

540+ refArchive <- asks envRefArchive

541+ distArchive <- asks envDistArchive

542+ parseXml refArchive distArchive "ppt/slideMasters/slideMaster1.xml"

543+

544+-- We want to get the header dimensions, so we can make sure that the

545+-- image goes underneath it. We only use this in a content slide if it

546+-- has a header.

547+

548+-- getHeaderSize :: PandocMonad m => P m ((Integer, Integer), (Integer, Integer))

549+-- getHeaderSize = do

550+-- master <- getMaster

551+-- let ns = elemToNameSpaces master

552+-- sps = [master] >>=

553+-- findChildren (elemName ns "p" "cSld") >>=

554+-- findChildren (elemName ns "p" "spTree") >>=

555+-- findChildren (elemName ns "p" "sp")

556+-- mbXfrm =

557+-- listToMaybe (filter (shapeHasName ns "Title Placeholder 1") sps) >>=

558+-- findChild (elemName ns "p" "spPr") >>=

559+-- findChild (elemName ns "a" "xfrm")

560+-- xoff = mbXfrm >>=

561+-- findChild (elemName ns "a" "off") >>=

562+-- findAttr (QName "x" Nothing Nothing) >>=

563+-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

564+-- yoff = mbXfrm >>=

565+-- findChild (elemName ns "a" "off") >>=

566+-- findAttr (QName "y" Nothing Nothing) >>=

567+-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

568+-- xext = mbXfrm >>=

569+-- findChild (elemName ns "a" "ext") >>=

570+-- findAttr (QName "cx" Nothing Nothing) >>=

571+-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

572+-- yext = mbXfrm >>=

573+-- findChild (elemName ns "a" "ext") >>=

574+-- findAttr (QName "cy" Nothing Nothing) >>=

575+-- (listToMaybe . (\s -> reads s :: [(Integer, String)]))

576+-- off = case xoff of

577+-- Just (xoff', _) | Just (yoff',_) <- yoff -> (xoff', yoff')

578+-- _ -> (1043490, 1027664)

579+-- ext = case xext of

580+-- Just (xext', _) | Just (yext',_) <- yext -> (xext', yext')

581+-- _ -> (7024744, 1143000)

582+-- return $ (off, ext)

583+

584+-- Hard-coded for now

585+-- captionPosition :: ((Integer, Integer), (Integer, Integer))

586+-- captionPosition = ((457200, 6061972), (8229600, 527087))

587+

588+captionHeight :: Integer

589+captionHeight = 40

590+

591+createCaption :: PandocMonad m

592+ => ((Integer, Integer), (Integer, Integer))

593+ -> [ParaElem]

594+ -> P m Element

595+createCaption contentShapeDimensions paraElements = do

596+ let para = Paragraph def{pPropAlign = Just AlgnCenter} paraElements

597+ elements <- mapM paragraphToElement [para]

598+ let ((x, y), (cx, cy)) = contentShapeDimensions

599+ let txBody = mknode "p:txBody" [] $

600+ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements

601+ return $

602+ mknode "p:sp" [] [ mknode "p:nvSpPr" []

603+ [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] ()

604+ , mknode "p:cNvSpPr" [("txBox", "1")] ()

605+ , mknode "p:nvPr" [] ()

606+ ]

607+ , mknode "p:spPr" []

608+ [ mknode "a:xfrm" []

609+ [ mknode "a:off" [("x", show $ 12700 * x),

610+ ("y", show $ 12700 * (y + cy - captionHeight))] ()

611+ , mknode "a:ext" [("cx", show $ 12700 * cx),

612+ ("cy", show $ 12700 * captionHeight)] ()

613+ ]

614+ , mknode "a:prstGeom" [("prst", "rect")]

615+ [ mknode "a:avLst" [] ()

616+ ]

617+ , mknode "a:noFill" [] ()

618+ ]

619+ , txBody

620+ ]

621+

622+makePicElements :: PandocMonad m

623+ => Element

624+ -> PicProps

625+ -> MediaInfo

626+ -> Text.Pandoc.Definition.Attr

627+ -> [ParaElem]

628+ -> P m [Element]

629+makePicElements layout picProps mInfo _ alt = do

630+ opts <- asks envOpts

631+ (pageWidth, pageHeight) <- asks envPresentationSize

632+ -- hasHeader <- asks envSlideHasHeader

633+ let hasCaption = mInfoCaption mInfo

634+ (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo)

635+ let (pxX, pxY) = case imageSize opts imgBytes of

636+ Right sz -> sizeInPixels $ sz

637+ Left _ -> sizeInPixels $ def

638+ master <- getMaster

639+ let ns = elemToNameSpaces layout

640+ ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master

641+ `catchError`

642+ (\_ -> return ((0, 0), (pageWidth, pageHeight)))

643+

644+ let cy = if hasCaption then cytmp - captionHeight else cytmp

645+

646+ let imgRatio = fromIntegral pxX / fromIntegral pxY :: Double

647+ boxRatio = fromIntegral cx / fromIntegral cy :: Double

648+ (dimX, dimY) = if imgRatio > boxRatio

649+ then (fromIntegral cx, fromIntegral cx / imgRatio)

650+ else (fromIntegral cy * imgRatio, fromIntegral cy)

651+

652+ (dimX', dimY') = (round dimX * 12700, round dimY * 12700) :: (Integer, Integer)

653+ (xoff, yoff) = (fromIntegral x + (fromIntegral cx - dimX) / 2,

654+ fromIntegral y + (fromIntegral cy - dimY) / 2)

655+ (xoff', yoff') = (round xoff * 12700, round yoff * 12700) :: (Integer, Integer)

656+

657+ let cNvPicPr = mknode "p:cNvPicPr" [] $

658+ mknode "a:picLocks" [("noGrp","1")

659+ ,("noChangeAspect","1")] ()

660+ -- cNvPr will contain the link information so we do that separately,

661+ -- and register the link if necessary.

662+ let cNvPrAttr = [("descr", mInfoFilePath mInfo), ("id","0"),("name","Picture 1")]

663+ cNvPr <- case picPropLink picProps of

664+ Just link -> do idNum <- registerLink link

665+ return $ mknode "p:cNvPr" cNvPrAttr $

666+ mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] ()

667+ Nothing -> return $ mknode "p:cNvPr" cNvPrAttr ()

668+ let nvPicPr = mknode "p:nvPicPr" []

669+ [ cNvPr

670+ , cNvPicPr

671+ , mknode "p:nvPr" [] ()]

672+ let blipFill = mknode "p:blipFill" []

673+ [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] ()

674+ , mknode "a:stretch" [] $

675+ mknode "a:fillRect" [] () ]

676+ let xfrm = mknode "a:xfrm" []

677+ [ mknode "a:off" [("x",show xoff'), ("y",show yoff')] ()

678+ , mknode "a:ext" [("cx",show dimX')

679+ ,("cy",show dimY')] () ]

680+ let prstGeom = mknode "a:prstGeom" [("prst","rect")] $

681+ mknode "a:avLst" [] ()

682+ let ln = mknode "a:ln" [("w","9525")]

683+ [ mknode "a:noFill" [] ()

684+ , mknode "a:headEnd" [] ()

685+ , mknode "a:tailEnd" [] () ]

686+ let spPr = mknode "p:spPr" [("bwMode","auto")]

687+ [xfrm, prstGeom, mknode "a:noFill" [] (), ln]

688+

689+ let picShape = mknode "p:pic" []

690+ [ nvPicPr

691+ , blipFill

692+ , spPr ]

693+

694+ -- And now, maybe create the caption:

695+ if hasCaption

696+ then do cap <- createCaption ((x, y), (cx, cytmp)) alt

697+ return [picShape, cap]

698+ else return [picShape]

699+

700+

701+paraElemToElement :: PandocMonad m => ParaElem -> P m Element

702+paraElemToElement Break = return $ mknode "a:br" [] ()

703+paraElemToElement (Run rpr s) = do

704+ let sizeAttrs = case rPropForceSize rpr of

705+ Just n -> [("sz", (show $ n * 100))]

706+ Nothing -> []

707+ attrs = sizeAttrs ++

708+ if rPropCode rpr

709+ then []

710+ else (if rPropBold rpr then [("b", "1")] else []) ++

711+ (if rPropItalics rpr then [("i", "1")] else []) ++

712+ (case rStrikethrough rpr of

713+ Just NoStrike -> [("strike", "noStrike")]

714+ Just SingleStrike -> [("strike", "sngStrike")]

715+ Just DoubleStrike -> [("strike", "dblStrike")]

716+ Nothing -> []) ++

717+ (case rBaseline rpr of

718+ Just n -> [("baseline", show n)]

719+ Nothing -> []) ++

720+ (case rCap rpr of

721+ Just NoCapitals -> [("cap", "none")]

722+ Just SmallCapitals -> [("cap", "small")]

723+ Just AllCapitals -> [("cap", "all")]

724+ Nothing -> []) ++

725+ []

726+ linkProps <- case rLink rpr of

727+ Just link -> do

728+ idNum <- registerLink link

729+ -- first we have to make sure that if it's an

730+ -- anchor, it's in the anchor map. If not, there's

731+ -- no link.

732+ anchorMap <- gets stAnchorMap

733+ return $ case link of

734+ -- anchor with nothing in the map

735+ ('#':target, _) | Nothing <- M.lookup target anchorMap ->

736+ []

737+ -- anchor that is in the map

738+ ('#':_, _) ->

739+ let linkAttrs =

740+ [ ("r:id", "rId" ++ show idNum)

741+ , ("action", "ppaction://hlinksldjump")

742+ ]

743+ in [mknode "a:hlinkClick" linkAttrs ()]

744+ -- external

745+ _ ->

746+ let linkAttrs =

747+ [ ("r:id", "rId" ++ show idNum)

748+ ]

749+ in [mknode "a:hlinkClick" linkAttrs ()]

750+ Nothing -> return []

751+ let propContents = if rPropCode rpr

752+ then [mknode "a:latin" [("typeface", "Courier")] ()]

753+ else linkProps

754+ return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents

755+ , mknode "a:t" [] s

756+ ]

757+paraElemToElement (MathElem mathType texStr) = do

758+ res <- convertMath writeOMML mathType (unTeXString texStr)

759+ case res of

760+ Right r -> return $ mknode "a14:m" [] $ addMathInfo r

761+ Left (Str s) -> paraElemToElement (Run def s)

762+ Left _ -> throwError $ PandocShouldNeverHappenError "non-string math fallback"

763+

764+-- This is a bit of a kludge -- really requires adding an option to

765+-- TeXMath, but since that's a different package, we'll do this one

766+-- step at a time.

767+addMathInfo :: Element -> Element

768+addMathInfo element =

769+ let mathspace = Attr { attrKey = (QName "m" Nothing (Just "xmlns"))

770+ , attrVal = "http://schemas.openxmlformats.org/officeDocument/2006/math"

771+ }

772+ in add_attr mathspace element

773+

774+-- We look through the element to see if it contains an a14:m

775+-- element. If so, we surround it. This is a bit ugly, but it seems

776+-- more dependable than looking through shapes for math. Plus this is

777+-- an xml implementation detail, so it seems to make sense to do it at

778+-- the xml level.

779+surroundWithMathAlternate :: Element -> Element

780+surroundWithMathAlternate element =

781+ case findElement (QName "m" Nothing (Just "a14")) element of

782+ Just _ ->

783+ mknode "mc:AlternateContent"

784+ [("xmlns:mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")

785+ ] [ mknode "mc:Choice"

786+ [ ("xmlns:a14", "http://schemas.microsoft.com/office/drawing/2010/main")

787+ , ("Requires", "a14")] [ element ]

788+ ]

789+ Nothing -> element

790+

791+paragraphToElement :: PandocMonad m => Paragraph -> P m Element

792+paragraphToElement par = do

793+ let

794+ attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++

795+ (case pPropMarginLeft (paraProps par) of

796+ Just px -> [("marL", show $ 12700 * px), ("indent", "0")]

797+ Nothing -> []

798+ ) ++

799+ (case pPropAlign (paraProps par) of

800+ Just AlgnLeft -> [("algn", "l")]

801+ Just AlgnRight -> [("algn", "r")]

802+ Just AlgnCenter -> [("algn", "ctr")]

803+ Nothing -> []

804+ )

805+ props = [] ++

806+ (case pPropSpaceBefore $ paraProps par of

807+ Just px -> [mknode "a:spcBef" [] [

808+ mknode "a:spcPts" [("val", show $ 100 * px)] ()

809+ ]

810+ ]

811+ Nothing -> []

812+ ) ++

813+ (case pPropBullet $ paraProps par of

814+ Just Bullet -> []

815+ Just (AutoNumbering attrs') ->

816+ [mknode "a:buAutoNum" [("type", autoNumberingToType attrs')] ()]

817+ Nothing -> [mknode "a:buNone" [] ()]

818+ )

819+ paras <- mapM paraElemToElement (paraElems par)

820+ return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras

821+

822+shapeToElement :: PandocMonad m => Element -> Shape -> P m Element

823+shapeToElement layout (TextBox paras)

824+ | ns <- elemToNameSpaces layout

825+ , Just cSld <- findChild (elemName ns "p" "cSld") layout

826+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

827+ sp <- getContentShape ns spTree

828+ elements <- mapM paragraphToElement paras

829+ let txBody = mknode "p:txBody" [] $

830+ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements

831+ emptySpPr = mknode "p:spPr" [] ()

832+ return $

833+ surroundWithMathAlternate $

834+ replaceNamedChildren ns "p" "txBody" [txBody] $

835+ replaceNamedChildren ns "p" "spPr" [emptySpPr] $

836+ sp

837+-- GraphicFrame and Pic should never reach this.

838+shapeToElement _ _ = return $ mknode "p:sp" [] ()

839+

840+shapeToElements :: PandocMonad m => Element -> Shape -> P m [Element]

841+shapeToElements layout (Pic picProps fp attr alt) = do

842+ mInfo <- registerMedia fp alt

843+ case mInfoExt mInfo of

844+ Just _ -> do

845+ makePicElements layout picProps mInfo attr alt

846+ Nothing -> shapeToElements layout $ TextBox [Paragraph def alt]

847+shapeToElements layout (GraphicFrame tbls cptn) =

848+ graphicFrameToElements layout tbls cptn

849+shapeToElements layout shp = do

850+ element <- shapeToElement layout shp

851+ return [element]

852+

853+shapesToElements :: PandocMonad m => Element -> [Shape] -> P m [Element]

854+shapesToElements layout shps = do

855+ concat <$> mapM (shapeToElements layout) shps

856+

857+hardcodedTableMargin :: Integer

858+hardcodedTableMargin = 36

859+

860+graphicFrameToElements :: PandocMonad m => Element -> [Graphic] -> [ParaElem] -> P m [Element]

861+graphicFrameToElements layout tbls caption = do

862+ -- get the sizing

863+ master <- getMaster

864+ (pageWidth, pageHeight) <- asks envPresentationSize

865+ let ns = elemToNameSpaces layout

866+ ((x, y), (cx, cytmp)) <- getContentShapeSize ns layout master

867+ `catchError`

868+ (\_ -> return ((0, 0), (pageWidth, pageHeight)))

869+

870+ let cy = if (not $ null caption) then cytmp - captionHeight else cytmp

871+

872+ elements <- mapM graphicToElement tbls

873+ let graphicFrameElts =

874+ mknode "p:graphicFrame" [] $

875+ [ mknode "p:nvGraphicFramePr" [] $

876+ [ mknode "p:cNvPr" [("id", "6"), ("name", "Content Placeholder 5")] ()

877+ , mknode "p:cNvGraphicFramePr" [] $

878+ [mknode "a:graphicFrameLocks" [("noGrp", "1")] ()]

879+ , mknode "p:nvPr" [] $

880+ [mknode "p:ph" [("idx", "1")] ()]

881+ ]

882+ , mknode "p:xfrm" [] $

883+ [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] ()

884+ , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] ()

885+ ]

886+ ] ++ elements

887+

888+ if (not $ null caption)

889+ then do capElt <- createCaption ((x, y), (cx, cytmp)) caption

890+ return [graphicFrameElts, capElt]

891+ else return [graphicFrameElts]

892+

893+graphicToElement :: PandocMonad m => Graphic -> P m Element

894+graphicToElement (Tbl tblPr hdrCells rows) = do

895+ (pageWidth, _) <- asks envPresentationSize

896+ let colWidths = if null hdrCells

897+ then case rows of

898+ r : _ | not (null r) -> replicate (length r) $

899+ (pageWidth - (2 * hardcodedTableMargin))`div` (toInteger $ length r)

900+ -- satisfy the compiler. This is the same as

901+ -- saying that rows is empty, but the compiler

902+ -- won't understand that `[]` exhausts the

903+ -- alternatives.

904+ _ -> []

905+ else replicate (length hdrCells) $

906+ (pageWidth - (2 * hardcodedTableMargin)) `div` (toInteger $ length hdrCells)

907+

908+ let cellToOpenXML paras =

909+ do elements <- mapM paragraphToElement paras

910+ let elements' = if null elements

911+ then [mknode "a:p" [] [mknode "a:endParaRPr" [] ()]]

912+ else elements

913+ return $

914+ [mknode "a:txBody" [] $

915+ ([ mknode "a:bodyPr" [] ()

916+ , mknode "a:lstStyle" [] ()]

917+ ++ elements')]

918+ headers' <- mapM cellToOpenXML hdrCells

919+ rows' <- mapM (mapM cellToOpenXML) rows

920+ let borderProps = mknode "a:tcPr" [] ()

921+ let emptyCell = [mknode "a:p" [] [mknode "a:pPr" [] ()]]

922+ let mkcell border contents = mknode "a:tc" []

923+ $ (if null contents

924+ then emptyCell

925+ else contents) ++ [ borderProps | border ]

926+ let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells

927+

928+ let mkgridcol w = mknode "a:gridCol"

929+ [("w", show ((12700 * w) :: Integer))] ()

930+ let hasHeader = not (all null hdrCells)

931+ return $ mknode "a:graphic" [] $

932+ [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $

933+ [mknode "a:tbl" [] $

934+ [ mknode "a:tblPr" [ ("firstRow", if tblPrFirstRow tblPr then "1" else "0")

935+ , ("bandRow", if tblPrBandRow tblPr then "1" else "0")

936+ ] ()

937+ , mknode "a:tblGrid" [] (if all (==0) colWidths

938+ then []

939+ else map mkgridcol colWidths)

940+ ]

941+ ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows'

942+ ]

943+ ]

944+

945+getShapeByName :: NameSpaces -> Element -> String -> Maybe Element

946+getShapeByName ns spTreeElem name

947+ | isElem ns "p" "spTree" spTreeElem =

948+ filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasName ns name e)) spTreeElem

949+ | otherwise = Nothing

950+

951+-- getShapeById :: NameSpaces -> Element -> String -> Maybe Element

952+-- getShapeById ns spTreeElem ident

953+-- | isElem ns "p" "spTree" spTreeElem =

954+-- filterChild (\e -> (isElem ns "p" "sp" e) && (shapeHasId ns ident e)) spTreeElem

955+-- | otherwise = Nothing

956+

957+nonBodyTextToElement :: PandocMonad m => Element -> String -> [ParaElem] -> P m Element

958+nonBodyTextToElement layout shapeName paraElements

959+ | ns <- elemToNameSpaces layout

960+ , Just cSld <- findChild (elemName ns "p" "cSld") layout

961+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld

962+ , Just sp <- getShapeByName ns spTree shapeName = do

963+ let hdrPara = Paragraph def paraElements

964+ element <- paragraphToElement hdrPara

965+ let txBody = mknode "p:txBody" [] $

966+ [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++

967+ [element]

968+ return $ replaceNamedChildren ns "p" "txBody" [txBody] sp

969+ -- XXX: TODO

970+ | otherwise = return $ mknode "p:sp" [] ()

971+

972+contentToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> P m Element

973+contentToElement layout hdrShape shapes

974+ | ns <- elemToNameSpaces layout

975+ , Just cSld <- findChild (elemName ns "p" "cSld") layout

976+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

977+ element <- nonBodyTextToElement layout "Title 1" hdrShape

978+ let hdrShapeElements = if null hdrShape

979+ then []

980+ else [element]

981+ contentElements <- local

982+ (\env -> env {envContentType = NormalContent})

983+ (shapesToElements layout shapes)

984+ return $

985+ replaceNamedChildren ns "p" "sp"

986+ (hdrShapeElements ++ contentElements)

987+ spTree

988+contentToElement _ _ _ = return $ mknode "p:sp" [] ()

989+

990+twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element

991+twoColumnToElement layout hdrShape shapesL shapesR

992+ | ns <- elemToNameSpaces layout

993+ , Just cSld <- findChild (elemName ns "p" "cSld") layout

994+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

995+ element <- nonBodyTextToElement layout "Title 1" hdrShape

996+ let hdrShapeElements = if null hdrShape

997+ then []

998+ else [element]

999+ contentElementsL <- local

1000+ (\env -> env {envContentType =TwoColumnLeftContent})

1001+ (shapesToElements layout shapesL)

1002+ contentElementsR <- local

1003+ (\env -> env {envContentType =TwoColumnRightContent})

1004+ (shapesToElements layout shapesR)

1005+ -- let contentElementsL' = map (setIdx ns "1") contentElementsL

1006+ -- contentElementsR' = map (setIdx ns "2") contentElementsR

1007+ return $

1008+ replaceNamedChildren ns "p" "sp"

1009+ (hdrShapeElements ++ contentElementsL ++ contentElementsR)

1010+ spTree

1011+twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] ()

1012+

1013+

1014+titleToElement :: PandocMonad m => Element -> [ParaElem] -> P m Element

1015+titleToElement layout titleElems

1016+ | ns <- elemToNameSpaces layout

1017+ , Just cSld <- findChild (elemName ns "p" "cSld") layout

1018+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

1019+ element <- nonBodyTextToElement layout "Title 1" titleElems

1020+ let titleShapeElements = if null titleElems

1021+ then []

1022+ else [element]

1023+ return $ replaceNamedChildren ns "p" "sp" titleShapeElements spTree

1024+titleToElement _ _ = return $ mknode "p:sp" [] ()

1025+

1026+metadataToElement :: PandocMonad m => Element -> [ParaElem] -> [ParaElem] -> [[ParaElem]] -> [ParaElem] -> P m Element

1027+metadataToElement layout titleElems subtitleElems authorsElems dateElems

1028+ | ns <- elemToNameSpaces layout

1029+ , Just cSld <- findChild (elemName ns "p" "cSld") layout

1030+ , Just spTree <- findChild (elemName ns "p" "spTree") cSld = do

1031+ titleShapeElements <- if null titleElems

1032+ then return []

1033+ else sequence [nonBodyTextToElement layout "Title 1" titleElems]

1034+ let combinedAuthorElems = intercalate [Break] authorsElems

1035+ subtitleAndAuthorElems = intercalate [Break, Break] [subtitleElems, combinedAuthorElems]

1036+ subtitleShapeElements <- if null subtitleAndAuthorElems

1037+ then return []

1038+ else sequence [nonBodyTextToElement layout "Subtitle 2" subtitleAndAuthorElems]

1039+ dateShapeElements <- if null dateElems

1040+ then return []

1041+ else sequence [nonBodyTextToElement layout "Date Placeholder 3" dateElems]

1042+ return $ replaceNamedChildren ns "p" "sp"

1043+ (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements)

1044+ spTree

1045+metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] ()

1046+

1047+slideToElement :: PandocMonad m => Slide -> P m Element

1048+slideToElement s@(ContentSlide hdrElems shapes) = do

1049+ layout <- getLayout s

1050+ spTree <- local (\env -> if null hdrElems

1051+ then env

1052+ else env{envSlideHasHeader=True}) $

1053+ contentToElement layout hdrElems shapes

1054+ return $ mknode "p:sld"

1055+ [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

1056+ ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

1057+ ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

1058+ ] [mknode "p:cSld" [] [spTree]]

1059+slideToElement s@(TwoColumnSlide hdrElems shapesL shapesR) = do

1060+ layout <- getLayout s

1061+ spTree <- local (\env -> if null hdrElems

1062+ then env

1063+ else env{envSlideHasHeader=True}) $

1064+ twoColumnToElement layout hdrElems shapesL shapesR

1065+ return $ mknode "p:sld"

1066+ [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

1067+ ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

1068+ ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

1069+ ] [mknode "p:cSld" [] [spTree]]

1070+slideToElement s@(TitleSlide hdrElems) = do

1071+ layout <- getLayout s

1072+ spTree <- titleToElement layout hdrElems

1073+ return $ mknode "p:sld"

1074+ [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

1075+ ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

1076+ ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

1077+ ] [mknode "p:cSld" [] [spTree]]

1078+slideToElement s@(MetadataSlide titleElems subtitleElems authorElems dateElems) = do

1079+ layout <- getLayout s

1080+ spTree <- metadataToElement layout titleElems subtitleElems authorElems dateElems

1081+ return $ mknode "p:sld"

1082+ [ ("xmlns:a", "http://schemas.openxmlformats.org/drawingml/2006/main"),

1083+ ("xmlns:r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships"),

1084+ ("xmlns:p", "http://schemas.openxmlformats.org/presentationml/2006/main")

1085+ ] [mknode "p:cSld" [] [spTree]]

1086+

1087+-----------------------------------------------------------------------

1088+

1089+slideToFilePath :: Slide -> Int -> FilePath

1090+slideToFilePath _ idNum = "slide" ++ (show $ idNum) ++ ".xml"

1091+

1092+slideToSlideId :: Monad m => Slide -> Int -> P m String

1093+slideToSlideId _ idNum = do

1094+ n <- asks envSlideIdOffset

1095+ return $ "rId" ++ (show $ idNum + n)

1096+

1097+

1098+data Relationship = Relationship { relId :: Int

1099+ , relType :: MimeType

1100+ , relTarget :: FilePath

1101+ } deriving (Show, Eq)

1102+

1103+elementToRel :: Element -> Maybe Relationship

1104+elementToRel element

1105+ | elName element == QName "Relationship" (Just "http://schemas.openxmlformats.org/package/2006/relationships") Nothing =

1106+ do rId <- findAttr (QName "Id" Nothing Nothing) element

1107+ numStr <- stripPrefix "rId" rId

1108+ num <- case reads numStr :: [(Int, String)] of

1109+ (n, _) : _ -> Just n

1110+ [] -> Nothing

1111+ type' <- findAttr (QName "Type" Nothing Nothing) element

1112+ target <- findAttr (QName "Target" Nothing Nothing) element

1113+ return $ Relationship num type' target

1114+ | otherwise = Nothing

1115+

1116+slideToPresRel :: Monad m => Slide -> Int -> P m Relationship

1117+slideToPresRel slide idNum = do

1118+ n <- asks envSlideIdOffset

1119+ let rId = idNum + n

1120+ fp = "slides/" ++ slideToFilePath slide idNum

1121+ return $ Relationship { relId = rId

1122+ , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide"

1123+ , relTarget = fp

1124+ }

1125+

1126+getRels :: PandocMonad m => P m [Relationship]

1127+getRels = do

1128+ refArchive <- asks envRefArchive

1129+ distArchive <- asks envDistArchive

1130+ relsElem <- parseXml refArchive distArchive "ppt/_rels/presentation.xml.rels"

1131+ let globalNS = "http://schemas.openxmlformats.org/package/2006/relationships"

1132+ let relElems = findChildren (QName "Relationship" (Just globalNS) Nothing) relsElem

1133+ return $ mapMaybe elementToRel relElems

1134+

1135+presentationToRels :: PandocMonad m => Presentation -> P m [Relationship]

1136+presentationToRels (Presentation slides) = do

1137+ mySlideRels <- mapM (\(s, n) -> slideToPresRel s n) $ zip slides [1..]

1138+ rels <- getRels

1139+ let relsWithoutSlides = filter (\r -> relType r /= "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") rels

1140+ -- We want to make room for the slides in the id space. The slides

1141+ -- will start at Id2 (since Id1 is for the slide master). There are

1142+ -- two slides in the data file, but that might change in the future,

1143+ -- so we will do this:

1144+ --

1145+ -- 1. We look to see what the minimum relWithoutSlide id (greater than 1) is.

1146+ -- 2. We add the difference between this and the number of slides to

1147+ -- all relWithoutSlide rels (unless they're 1)

1148+

1149+ let minRelNotOne = case filter (1<) $ map relId relsWithoutSlides of

1150+ [] -> 0 -- doesn't matter in this case, since

1151+ -- there will be nothing to map the

1152+ -- function over

1153+ l -> minimum l

1154+

1155+ modifyRelNum :: Int -> Int

1156+ modifyRelNum 1 = 1

1157+ modifyRelNum n = n - minRelNotOne + 2 + length slides

1158+

1159+ relsWithoutSlides' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWithoutSlides

1160+

1161+ return $ mySlideRels ++ relsWithoutSlides'

1162+

1163+relToElement :: Relationship -> Element

1164+relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel))

1165+ , ("Type", relType rel)

1166+ , ("Target", relTarget rel) ] ()

1167+

1168+relsToElement :: [Relationship] -> Element

1169+relsToElement rels = mknode "Relationships"

1170+ [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]

1171+ (map relToElement rels)

1172+

1173+presentationToRelsEntry :: PandocMonad m => Presentation -> P m Entry

1174+presentationToRelsEntry pres = do

1175+ rels <- presentationToRels pres

1176+ elemToEntry "ppt/_rels/presentation.xml.rels" $ relsToElement rels

1177+

1178+elemToEntry :: PandocMonad m => FilePath -> Element -> P m Entry

1179+elemToEntry fp element = do

1180+ epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime

1181+ return $ toEntry fp epochtime $ renderXml element

1182+

1183+slideToEntry :: PandocMonad m => Slide -> Int -> P m Entry

1184+slideToEntry slide idNum = do

1185+ local (\env -> env{envCurSlideId = idNum}) $ do

1186+ element <- slideToElement slide

1187+ elemToEntry ("ppt/slides/" ++ slideToFilePath slide idNum) element

1188+

1189+slideToSlideRelEntry :: PandocMonad m => Slide -> Int -> P m Entry

1190+slideToSlideRelEntry slide idNum = do

1191+ element <- slideToSlideRelElement slide idNum

1192+ elemToEntry ("ppt/slides/_rels/" ++ slideToFilePath slide idNum ++ ".rels") element

1193+

1194+linkRelElement :: PandocMonad m => Int -> (URL, String) -> P m (Maybe Element)

1195+linkRelElement idNum (url, _) = do

1196+ anchorMap <- gets stAnchorMap

1197+ case url of

1198+ -- if it's an anchor in the map, we use the slide number for an

1199+ -- internal link.

1200+ '#' : anchor | Just num <- M.lookup anchor anchorMap ->

1201+ return $ Just $

1202+ mknode "Relationship" [ ("Id", "rId" ++ show idNum)

1203+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide")

1204+ , ("Target", "slide" ++ show num ++ ".xml")

1205+ ] ()

1206+ -- if it's an anchor not in the map, we return nothing.

1207+ '#' : _ -> return Nothing

1208+ -- Anything else we treat as an external link

1209+ _ ->

1210+ return $ Just $

1211+ mknode "Relationship" [ ("Id", "rId" ++ show idNum)

1212+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink")

1213+ , ("Target", url)

1214+ , ("TargetMode", "External")

1215+ ] ()

1216+

1217+linkRelElements :: PandocMonad m => M.Map Int (URL, String) -> P m [Element]

1218+linkRelElements mp = catMaybes <$> mapM (\(n, lnk) -> linkRelElement n lnk) (M.toList mp)

1219+

1220+mediaRelElement :: MediaInfo -> Element

1221+mediaRelElement mInfo =

1222+ let ext = case mInfoExt mInfo of

1223+ Just e -> e

1224+ Nothing -> ""

1225+ in

1226+ mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo))

1227+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image")

1228+ , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext)

1229+ ] ()

1230+

1231+slideToSlideRelElement :: PandocMonad m => Slide -> Int -> P m Element

1232+slideToSlideRelElement slide idNum = do

1233+ let target = case slide of

1234+ (MetadataSlide _ _ _ _) -> "../slideLayouts/slideLayout1.xml"

1235+ (TitleSlide _) -> "../slideLayouts/slideLayout3.xml"

1236+ (ContentSlide _ _) -> "../slideLayouts/slideLayout2.xml"

1237+ (TwoColumnSlide _ _ _) -> "../slideLayouts/slideLayout4.xml"

1238+

1239+ linkIds <- gets stLinkIds

1240+ mediaIds <- gets stMediaIds

1241+

1242+ linkRels <- case M.lookup idNum linkIds of

1243+ Just mp -> linkRelElements mp

1244+ Nothing -> return []

1245+ let mediaRels = case M.lookup idNum mediaIds of

1246+ Just mInfos -> map mediaRelElement mInfos

1247+ Nothing -> []

1248+

1249+ return $

1250+ mknode "Relationships"

1251+ [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")]

1252+ ([mknode "Relationship" [ ("Id", "rId1")

1253+ , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout")

1254+ , ("Target", target)] ()

1255+ ] ++ linkRels ++ mediaRels)

1256+

1257+slideToSldIdElement :: PandocMonad m => Slide -> Int -> P m Element

1258+slideToSldIdElement slide idNum = do

1259+ let id' = show $ idNum + 255

1260+ rId <- slideToSlideId slide idNum

1261+ return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] ()

1262+

1263+presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element

1264+presentationToSldIdLst (Presentation slides) = do

1265+ ids <- mapM (\(s,n) -> slideToSldIdElement s n) (zip slides [1..])

1266+ return $ mknode "p:sldIdLst" [] ids

1267+

1268+presentationToPresentationElement :: PandocMonad m => Presentation -> P m Element

1269+presentationToPresentationElement pres = do

1270+ refArchive <- asks envRefArchive

1271+ distArchive <- asks envDistArchive

1272+ element <- parseXml refArchive distArchive "ppt/presentation.xml"

1273+ sldIdLst <- presentationToSldIdLst pres

1274+

1275+ let modifySldIdLst :: Content -> Content

1276+ modifySldIdLst (Elem e) = case elName e of

1277+ (QName "sldIdLst" _ _) -> Elem sldIdLst

1278+ _ -> Elem e

1279+ modifySldIdLst ct = ct

1280+

1281+ newContent = map modifySldIdLst $ elContent element

1282+

1283+ return $ element{elContent = newContent}

1284+

1285+presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry

1286+presentationToPresEntry pres = presentationToPresentationElement pres >>=

1287+ elemToEntry "ppt/presentation.xml"

1288+

1289+

1290+

1291+

1292+defaultContentTypeToElem :: DefaultContentType -> Element

1293+defaultContentTypeToElem dct =

1294+ mknode "Default"

1295+ [("Extension", defContentTypesExt dct),

1296+ ("ContentType", defContentTypesType dct)]

1297+ ()

1298+

1299+overrideContentTypeToElem :: OverrideContentType -> Element

1300+overrideContentTypeToElem oct =

1301+ mknode "Override"

1302+ [("PartName", overrideContentTypesPart oct),

1303+ ("ContentType", overrideContentTypesType oct)]

1304+ ()

1305+

1306+contentTypesToElement :: ContentTypes -> Element

1307+contentTypesToElement ct =

1308+ let ns = "http://schemas.openxmlformats.org/package/2006/content-types"

1309+ in

1310+ mknode "Types" [("xmlns", ns)] $

1311+ (map defaultContentTypeToElem $ contentTypesDefaults ct) ++

1312+ (map overrideContentTypeToElem $ contentTypesOverrides ct)

1313+

1314+data DefaultContentType = DefaultContentType

1315+ { defContentTypesExt :: String

1316+ , defContentTypesType:: MimeType

1317+ }

1318+ deriving (Show, Eq)

1319+

1320+data OverrideContentType = OverrideContentType

1321+ { overrideContentTypesPart :: FilePath

1322+ , overrideContentTypesType :: MimeType

1323+ }

1324+ deriving (Show, Eq)

1325+

1326+data ContentTypes = ContentTypes { contentTypesDefaults :: [DefaultContentType]

1327+ , contentTypesOverrides :: [OverrideContentType]

1328+ }

1329+ deriving (Show, Eq)

1330+

1331+contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry

1332+contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct

1333+

1334+pathToOverride :: FilePath -> Maybe OverrideContentType

1335+pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)

1336+

1337+mediaFileContentType :: FilePath -> Maybe DefaultContentType

1338+mediaFileContentType fp = case takeExtension fp of

1339+ '.' : ext -> Just $

1340+ DefaultContentType { defContentTypesExt = ext

1341+ , defContentTypesType =

1342+ case getMimeType fp of

1343+ Just mt -> mt

1344+ Nothing -> "application/octet-stream"

1345+ }

1346+ _ -> Nothing

1347+

1348+mediaContentType :: MediaInfo -> Maybe DefaultContentType

1349+mediaContentType mInfo

1350+ | Just ('.' : ext) <- mInfoExt mInfo =

1351+ Just $ DefaultContentType { defContentTypesExt = ext

1352+ , defContentTypesType =

1353+ case mInfoMimeType mInfo of

1354+ Just mt -> mt

1355+ Nothing -> "application/octet-stream"

1356+ }

1357+ | otherwise = Nothing

1358+

1359+presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes

1360+presentationToContentTypes (Presentation slides) = do

1361+ mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds

1362+ filePaths <- patternsToFilePaths inheritedPatterns

1363+ let mediaFps = filter (match (compile "ppt/media/image*")) filePaths

1364+ let defaults = [ DefaultContentType "xml" "application/xml"

1365+ , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"

1366+ ]

1367+ mediaDefaults = nub $

1368+ (mapMaybe mediaContentType $ mediaInfos) ++

1369+ (mapMaybe mediaFileContentType $ mediaFps)

1370+

1371+ inheritedOverrides = mapMaybe pathToOverride filePaths

1372+ presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]

1373+ slideOverrides =

1374+ mapMaybe

1375+ (\(s, n) ->

1376+ pathToOverride $ "ppt/slides/" ++ slideToFilePath s n)

1377+ (zip slides [1..])

1378+ -- propOverride = mapMaybe pathToOverride ["docProps/core.xml"]

1379+ return $ ContentTypes

1380+ (defaults ++ mediaDefaults)

1381+ (inheritedOverrides ++ presOverride ++ slideOverrides)

1382+

1383+presML :: String

1384+presML = "application/vnd.openxmlformats-officedocument.presentationml"

1385+

1386+noPresML :: String

1387+noPresML = "application/vnd.openxmlformats-officedocument"

1388+

1389+getContentType :: FilePath -> Maybe MimeType

1390+getContentType fp

1391+ | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml"

1392+ | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml"

1393+ | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml"

1394+ | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml"

1395+ | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml"

1396+ | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml"

1397+ | "ppt" : "slideMasters" : f : [] <- splitDirectories fp

1398+ , (_, ".xml") <- splitExtension f =

1399+ Just $ presML ++ ".slideMaster+xml"

1400+ | "ppt" : "slides" : f : [] <- splitDirectories fp

1401+ , (_, ".xml") <- splitExtension f =

1402+ Just $ presML ++ ".slide+xml"

1403+ | "ppt" : "notesMasters" : f : [] <- splitDirectories fp

1404+ , (_, ".xml") <- splitExtension f =

1405+ Just $ presML ++ ".notesMaster+xml"

1406+ | "ppt" : "notesSlides" : f : [] <- splitDirectories fp

1407+ , (_, ".xml") <- splitExtension f =

1408+ Just $ presML ++ ".notesSlide+xml"

1409+ | "ppt" : "theme" : f : [] <- splitDirectories fp

1410+ , (_, ".xml") <- splitExtension f =

1411+ Just $ noPresML ++ ".theme+xml"

1412+ | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp=

1413+ Just $ presML ++ ".slideLayout+xml"

1414+ | otherwise = Nothing

1415+

1416+autoNumberingToType :: ListAttributes -> String

1417+autoNumberingToType (_, numStyle, numDelim) =

1418+ typeString ++ delimString

1419+ where

1420+ typeString = case numStyle of

1421+ Decimal -> "arabic"

1422+ UpperAlpha -> "alphaUc"

1423+ LowerAlpha -> "alphaLc"

1424+ UpperRoman -> "romanUc"

1425+ LowerRoman -> "romanLc"

1426+ _ -> "arabic"

1427+ delimString = case numDelim of

1428+ Period -> "Period"

1429+ OneParen -> "ParenR"

1430+ TwoParens -> "ParenBoth"

1431+ _ -> "Period"

src/Text/Pandoc/Writers/Powerpoint/Presentation.hsnew file+701

@@ -0,0 +1,701 @@

1+{-# LANGUAGE PatternGuards #-}

3+{-

6+This program is free software; you can redistribute it and/or modify

7+it under the terms of the GNU General Public License as published by

8+the Free Software Foundation; either version 2 of the License, or

9+(at your option) any later version.

10+

11+This program is distributed in the hope that it will be useful,

12+but WITHOUT ANY WARRANTY; without even the implied warranty of

13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

14+GNU General Public License for more details.

15+

16+You should have received a copy of the GNU General Public License

17+along with this program; if not, write to the Free Software

18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

19+-}

20+

21+{- |

22+ Module : Text.Pandoc.Writers.Powerpoint.Presentation

24+ License : GNU GPL, version 2 or above

25+

26+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>

27+ Stability : alpha

28+ Portability : portable

29+

30+Definition of Presentation datatype, modeling a MS Powerpoint (pptx)

31+document, and functions for converting a Pandoc document to

32+Presentation.

33+-}

34+

35+module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation

36+ , Presentation(..)

37+ , Slide(..)

38+ , SlideElement(..)

39+ , Shape(..)

40+ , Graphic(..)

41+ , BulletType(..)

42+ , Algnment(..)

43+ , Paragraph(..)

44+ , ParaElem(..)

45+ , ParaProps(..)

46+ , RunProps(..)

47+ , TableProps(..)

48+ , Strikethrough(..)

49+ , Capitals(..)

50+ , PicProps(..)

51+ , URL

52+ , TeXString(..)

53+ ) where

54+

55+

56+import Control.Monad.Reader

57+import Control.Monad.State

58+import Data.List (intercalate)

59+import Data.Default

60+import Text.Pandoc.Definition

61+import Text.Pandoc.Class (PandocMonad)

62+import Text.Pandoc.Slides (getSlideLevel)

63+import qualified Text.Pandoc.Class as P

64+import Text.Pandoc.Options

65+import Text.Pandoc.Logging

66+import Text.Pandoc.Walk

67+import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"

68+import Text.Pandoc.Writers.Shared (metaValueToInlines)

69+import qualified Data.Map as M

70+import Data.Maybe (maybeToList)

71+

72+data WriterEnv = WriterEnv { envMetadata :: Meta

73+ , envRunProps :: RunProps

74+ , envParaProps :: ParaProps

75+ , envSlideLevel :: Int

76+ , envOpts :: WriterOptions

77+ , envSlideHasHeader :: Bool

78+ , envInList :: Bool

79+ , envInNoteSlide :: Bool

80+ , envCurSlideId :: Int

81+ -- the difference between the number at

82+ -- the end of the slide file name and

83+ -- the rId number

84+ , envSlideIdOffset :: Int

85+ }

86+ deriving (Show)

87+

88+instance Default WriterEnv where

89+ def = WriterEnv { envMetadata = mempty

90+ , envRunProps = def

91+ , envParaProps = def

92+ , envSlideLevel = 2

93+ , envOpts = def

94+ , envSlideHasHeader = False

95+ , envInList = False

96+ , envInNoteSlide = False

97+ , envCurSlideId = 1

98+ , envSlideIdOffset = 1

99+ }

100+

101+

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

103+ -- associate anchors with slide id

104+ , stAnchorMap :: M.Map String Int

105+ } deriving (Show, Eq)

106+

107+instance Default WriterState where

108+ def = WriterState { stNoteIds = mempty

109+ , stAnchorMap= mempty

110+ }

111+

112+type Pres m = ReaderT WriterEnv (StateT WriterState m)

113+

114+runPres :: Monad m => WriterEnv -> WriterState -> Pres m a -> m a

115+runPres env st p = evalStateT (runReaderT p env) st

116+

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

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

119+concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]

120+concatMapM f xs = liftM concat (mapM f xs)

121+

122+type Pixels = Integer

123+

124+data Presentation = Presentation [Slide]

125+ deriving (Show)

126+

127+data Slide = MetadataSlide { metadataSlideTitle :: [ParaElem]

128+ , metadataSlideSubtitle :: [ParaElem]

129+ , metadataSlideAuthors :: [[ParaElem]]

130+ , metadataSlideDate :: [ParaElem]

131+ }

132+ | TitleSlide { titleSlideHeader :: [ParaElem]}

133+ | ContentSlide { contentSlideHeader :: [ParaElem]

134+ , contentSlideContent :: [Shape]

135+ }

136+ | TwoColumnSlide { twoColumnSlideHeader :: [ParaElem]

137+ , twoColumnSlideLeft :: [Shape]

138+ , twoColumnSlideRight :: [Shape]

139+ }

140+ deriving (Show, Eq)

141+

142+data SlideElement = SlideElement Pixels Pixels Pixels Pixels Shape

143+ deriving (Show, Eq)

144+

145+data Shape = Pic PicProps FilePath Text.Pandoc.Definition.Attr [ParaElem]

146+ | GraphicFrame [Graphic] [ParaElem]

147+ | TextBox [Paragraph]

148+ deriving (Show, Eq)

149+

150+type Cell = [Paragraph]

151+

152+data TableProps = TableProps { tblPrFirstRow :: Bool

153+ , tblPrBandRow :: Bool

154+ } deriving (Show, Eq)

155+

156+data Graphic = Tbl TableProps [Cell] [[Cell]]

157+ deriving (Show, Eq)

158+

159+

160+data Paragraph = Paragraph { paraProps :: ParaProps

161+ , paraElems :: [ParaElem]

162+ } deriving (Show, Eq)

163+

164+

165+data BulletType = Bullet

166+ | AutoNumbering ListAttributes

167+ deriving (Show, Eq)

168+

169+data Algnment = AlgnLeft | AlgnRight | AlgnCenter

170+ deriving (Show, Eq)

171+

172+data ParaProps = ParaProps { pPropMarginLeft :: Maybe Pixels

173+ , pPropMarginRight :: Maybe Pixels

174+ , pPropLevel :: Int

175+ , pPropBullet :: Maybe BulletType

176+ , pPropAlign :: Maybe Algnment

177+ , pPropSpaceBefore :: Maybe Pixels

178+ } deriving (Show, Eq)

179+

180+instance Default ParaProps where

181+ def = ParaProps { pPropMarginLeft = Just 0

182+ , pPropMarginRight = Just 0

183+ , pPropLevel = 0

184+ , pPropBullet = Nothing

185+ , pPropAlign = Nothing

186+ , pPropSpaceBefore = Nothing

187+ }

188+

189+newtype TeXString = TeXString {unTeXString :: String}

190+ deriving (Eq, Show)

191+

192+data ParaElem = Break

193+ | Run RunProps String

194+ -- It would be more elegant to have native TeXMath

195+ -- Expressions here, but this allows us to use

196+ -- `convertmath` from T.P.Writers.Math. Will perhaps

197+ -- revisit in the future.

198+ | MathElem MathType TeXString

199+ deriving (Show, Eq)

200+

201+data Strikethrough = NoStrike | SingleStrike | DoubleStrike

202+ deriving (Show, Eq)

203+

204+data Capitals = NoCapitals | SmallCapitals | AllCapitals

205+ deriving (Show, Eq)

206+

207+type URL = String

208+

209+data RunProps = RunProps { rPropBold :: Bool

210+ , rPropItalics :: Bool

211+ , rStrikethrough :: Maybe Strikethrough

212+ , rBaseline :: Maybe Int

213+ , rCap :: Maybe Capitals

214+ , rLink :: Maybe (URL, String)

215+ , rPropCode :: Bool

216+ , rPropBlockQuote :: Bool

217+ , rPropForceSize :: Maybe Pixels

218+ } deriving (Show, Eq)

219+

220+instance Default RunProps where

221+ def = RunProps { rPropBold = False

222+ , rPropItalics = False

223+ , rStrikethrough = Nothing

224+ , rBaseline = Nothing

225+ , rCap = Nothing

226+ , rLink = Nothing

227+ , rPropCode = False

228+ , rPropBlockQuote = False

229+ , rPropForceSize = Nothing

230+ }

231+

232+data PicProps = PicProps { picPropLink :: Maybe (URL, String)

233+ } deriving (Show, Eq)

234+

235+instance Default PicProps where

236+ def = PicProps { picPropLink = Nothing

237+ }

238+

239+--------------------------------------------------

240+

241+inlinesToParElems :: Monad m => [Inline] -> Pres m [ParaElem]

242+inlinesToParElems ils = concatMapM inlineToParElems ils

243+

244+inlineToParElems :: Monad m => Inline -> Pres m [ParaElem]

245+inlineToParElems (Str s) = do

246+ pr <- asks envRunProps

247+ return [Run pr s]

248+inlineToParElems (Emph ils) =

249+ local (\r -> r{envRunProps = (envRunProps r){rPropItalics=True}}) $

250+ inlinesToParElems ils

251+inlineToParElems (Strong ils) =

252+ local (\r -> r{envRunProps = (envRunProps r){rPropBold=True}}) $

253+ inlinesToParElems ils

254+inlineToParElems (Strikeout ils) =

255+ local (\r -> r{envRunProps = (envRunProps r){rStrikethrough=Just SingleStrike}}) $

256+ inlinesToParElems ils

257+inlineToParElems (Superscript ils) =

258+ local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just 30000}}) $

259+ inlinesToParElems ils

260+inlineToParElems (Subscript ils) =

261+ local (\r -> r{envRunProps = (envRunProps r){rBaseline=Just (-25000)}}) $

262+ inlinesToParElems ils

263+inlineToParElems (SmallCaps ils) =

264+ local (\r -> r{envRunProps = (envRunProps r){rCap = Just SmallCapitals}}) $

265+ inlinesToParElems ils

266+inlineToParElems Space = inlineToParElems (Str " ")

267+inlineToParElems SoftBreak = inlineToParElems (Str " ")

268+inlineToParElems LineBreak = return [Break]

269+inlineToParElems (Link _ ils (url, title)) = do

270+ local (\r ->r{envRunProps = (envRunProps r){rLink = Just (url, title)}}) $

271+ inlinesToParElems ils

272+inlineToParElems (Code _ str) = do

273+ local (\r ->r{envRunProps = (envRunProps r){rPropCode = True}}) $

274+ inlineToParElems $ Str str

275+inlineToParElems (Math mathtype str) =

276+ return [MathElem mathtype (TeXString str)]

277+inlineToParElems (Note blks) = do

278+ notes <- gets stNoteIds

279+ let maxNoteId = case M.keys notes of

280+ [] -> 0

281+ lst -> maximum lst

282+ curNoteId = maxNoteId + 1

283+ modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes }

284+ inlineToParElems $ Superscript [Str $ show curNoteId]

285+inlineToParElems (Span _ ils) = concatMapM inlineToParElems ils

286+inlineToParElems (RawInline _ _) = return []

287+inlineToParElems _ = return []

288+

289+isListType :: Block -> Bool

290+isListType (OrderedList _ _) = True

291+isListType (BulletList _) = True

292+isListType (DefinitionList _) = True

293+isListType _ = False

294+

295+registerAnchorId :: PandocMonad m => String -> Pres m ()

296+registerAnchorId anchor = do

297+ anchorMap <- gets stAnchorMap

298+ slideId <- asks envCurSlideId

299+ unless (null anchor) $

300+ modify $ \st -> st {stAnchorMap = M.insert anchor slideId anchorMap}

301+

302+-- Currently hardcoded, until I figure out how to make it dynamic.

303+blockQuoteSize :: Pixels

304+blockQuoteSize = 20

305+

306+noteSize :: Pixels

307+noteSize = 18

308+

309+blockToParagraphs :: PandocMonad m => Block -> Pres m [Paragraph]

310+blockToParagraphs (Plain ils) = do

311+ parElems <- inlinesToParElems ils

312+ pProps <- asks envParaProps

313+ return [Paragraph pProps parElems]

314+blockToParagraphs (Para ils) = do

315+ parElems <- inlinesToParElems ils

316+ pProps <- asks envParaProps

317+ return [Paragraph pProps parElems]

318+blockToParagraphs (LineBlock ilsList) = do

319+ parElems <- inlinesToParElems $ intercalate [LineBreak] ilsList

320+ pProps <- asks envParaProps

321+ return [Paragraph pProps parElems]

322+-- TODO: work out the attributes

323+blockToParagraphs (CodeBlock attr str) =

324+ local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $

325+ blockToParagraphs $ Para [Code attr str]

326+-- We can't yet do incremental lists, but we should render a

327+-- (BlockQuote List) as a list to maintain compatibility with other

328+-- formats.

329+blockToParagraphs (BlockQuote (blk : blks)) | isListType blk = do

330+ ps <- blockToParagraphs blk

331+ ps' <- blockToParagraphs $ BlockQuote blks

332+ return $ ps ++ ps'

333+blockToParagraphs (BlockQuote blks) =

334+ local (\r -> r{ envParaProps = (envParaProps r){pPropMarginLeft = Just 100}

335+ , envRunProps = (envRunProps r){rPropForceSize = Just blockQuoteSize}})$

336+ concatMapM blockToParagraphs blks

337+-- TODO: work out the format

338+blockToParagraphs (RawBlock _ _) = return []

339+blockToParagraphs (Header _ (ident, _, _) ils) = do

340+ -- Note that this function only deals with content blocks, so it

341+ -- will only touch headers that are above the current slide level --

342+ -- slides at or below the slidelevel will be taken care of by

343+ -- `blocksToSlide'`. We have the register anchors in both of them.

344+ registerAnchorId ident

345+ -- we set the subeader to bold

346+ parElems <- local (\e->e{envRunProps = (envRunProps e){rPropBold=True}}) $

347+ inlinesToParElems ils

348+ -- and give it a bit of space before it.

349+ return [Paragraph def{pPropSpaceBefore = Just 30} parElems]

350+blockToParagraphs (BulletList blksLst) = do

351+ pProps <- asks envParaProps

352+ let lvl = pPropLevel pProps

353+ local (\env -> env{ envInList = True

354+ , envParaProps = pProps{ pPropLevel = lvl + 1

355+ , pPropBullet = Just Bullet

356+ , pPropMarginLeft = Nothing

357+ }}) $

358+ concatMapM multiParBullet blksLst

359+blockToParagraphs (OrderedList listAttr blksLst) = do

360+ pProps <- asks envParaProps

361+ let lvl = pPropLevel pProps

362+ local (\env -> env{ envInList = True

363+ , envParaProps = pProps{ pPropLevel = lvl + 1

364+ , pPropBullet = Just (AutoNumbering listAttr)

365+ , pPropMarginLeft = Nothing

366+ }}) $

367+ concatMapM multiParBullet blksLst

368+blockToParagraphs (DefinitionList entries) = do

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

370+ go (ils, blksLst) = do

371+ term <-blockToParagraphs $ Para [Strong ils]

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

373+ -- blockquote. We can extend this further later.

374+ definition <- concatMapM (blockToParagraphs . BlockQuote) blksLst

375+ return $ term ++ definition

376+ concatMapM go entries

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

378+blockToParagraphs (Div _ blks) = concatMapM blockToParagraphs blks

379+blockToParagraphs blk = do

380+ P.report $ BlockNotRendered blk

381+ return []

382+

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

384+multiParBullet :: PandocMonad m => [Block] -> Pres m [Paragraph]

385+multiParBullet [] = return []

386+multiParBullet (b:bs) = do

387+ pProps <- asks envParaProps

388+ p <- blockToParagraphs b

389+ ps <- local (\env -> env{envParaProps = pProps{pPropBullet = Nothing}}) $

390+ concatMapM blockToParagraphs bs

391+ return $ p ++ ps

392+

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

394+cellToParagraphs algn tblCell = do

395+ paras <- mapM (blockToParagraphs) tblCell

396+ let alignment = case algn of

397+ AlignLeft -> Just AlgnLeft

398+ AlignRight -> Just AlgnRight

399+ AlignCenter -> Just AlgnCenter

400+ AlignDefault -> Nothing

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

402+ return $ concat paras'

403+

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

405+rowToParagraphs algns tblCells = do

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

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

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

409+

410+blockToShape :: PandocMonad m => Block -> Pres m Shape

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

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

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

414+ Pic def url attr <$> (inlinesToParElems ils)

415+blockToShape (Plain (il:_)) | Link _ (il':_) target <- il

416+ , Image attr ils (url, _) <- il' =

417+ Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)

418+blockToShape (Para (il:_)) | Link _ (il':_) target <- il

419+ , Image attr ils (url, _) <- il' =

420+ Pic def{picPropLink = Just target} url attr <$> (inlinesToParElems ils)

421+blockToShape (Table caption algn _ hdrCells rows) = do

422+ caption' <- inlinesToParElems caption

423+ hdrCells' <- rowToParagraphs algn hdrCells

424+ rows' <- mapM (rowToParagraphs algn) rows

425+ let tblPr = if null hdrCells

426+ then TableProps { tblPrFirstRow = False

427+ , tblPrBandRow = True

428+ }

429+ else TableProps { tblPrFirstRow = True

430+ , tblPrBandRow = True

431+ }

432+

433+ return $ GraphicFrame [Tbl tblPr hdrCells' rows'] caption'

434+blockToShape blk = do paras <- blockToParagraphs blk

435+ let paras' = map (\par -> par{paraElems = combineParaElems $ paraElems par}) paras

436+ return $ TextBox paras'

437+

438+combineShapes :: [Shape] -> [Shape]

439+combineShapes [] = []

440+combineShapes (s : []) = [s]

441+combineShapes (pic@(Pic _ _ _ _) : ss) = pic : combineShapes ss

442+combineShapes ((TextBox []) : ss) = combineShapes ss

443+combineShapes (s : TextBox [] : ss) = combineShapes (s : ss)

444+combineShapes ((TextBox (p:ps)) : (TextBox (p':ps')) : ss) =

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

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

447+

448+blocksToShapes :: PandocMonad m => [Block] -> Pres m [Shape]

449+blocksToShapes blks = combineShapes <$> mapM blockToShape blks

450+

451+isImage :: Inline -> Bool

452+isImage (Image _ _ _) = True

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

454+isImage _ = False

455+

456+splitBlocks' :: Monad m => [Block] -> [[Block]] -> [Block] -> Pres m [[Block]]

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

458+splitBlocks' cur acc (HorizontalRule : blks) =

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

460+splitBlocks' cur acc (h@(Header n _ _) : blks) = do

461+ slideLevel <- asks envSlideLevel

462+ case compare n slideLevel of

463+ LT -> splitBlocks' [] (acc ++ (if null cur then [] else [cur]) ++ [[h]]) blks

464+ EQ -> splitBlocks' [h] (acc ++ (if null cur then [] else [cur])) blks

465+ GT -> splitBlocks' (cur ++ [h]) acc blks

466+-- `blockToParagraphs` treats Plain and Para the same, so we can save

467+-- some code duplication by treating them the same here.

468+splitBlocks' cur acc ((Plain ils) : blks) = splitBlocks' cur acc ((Para ils) : blks)

469+splitBlocks' cur acc ((Para (il:ils)) : blks) | isImage il = do

470+ slideLevel <- asks envSlideLevel

471+ case cur of

472+ (Header n _ _) : [] | n == slideLevel ->

473+ splitBlocks' []

474+ (acc ++ [cur ++ [Para [il]]])

475+ (if null ils then blks else (Para ils) : blks)

476+ _ -> splitBlocks' []

477+ (acc ++ (if null cur then [] else [cur]) ++ [[Para [il]]])

478+ (if null ils then blks else (Para ils) : blks)

479+splitBlocks' cur acc (tbl@(Table _ _ _ _ _) : blks) = do

480+ slideLevel <- asks envSlideLevel

481+ case cur of

482+ (Header n _ _) : [] | n == slideLevel ->

483+ splitBlocks' [] (acc ++ [cur ++ [tbl]]) blks

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

485+splitBlocks' cur acc (d@(Div (_, classes, _) _): blks) | "columns" `elem` classes = do

486+ slideLevel <- asks envSlideLevel

487+ case cur of

488+ (Header n _ _) : [] | n == slideLevel ->

489+ splitBlocks' [] (acc ++ [cur ++ [d]]) blks

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

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

492+

493+splitBlocks :: Monad m => [Block] -> Pres m [[Block]]

494+splitBlocks = splitBlocks' [] []

495+

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

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

498+ | n < lvl = do

499+ registerAnchorId ident

500+ hdr <- inlinesToParElems ils

501+ return $ TitleSlide {titleSlideHeader = hdr}

502+ | n == lvl = do

503+ registerAnchorId ident

504+ hdr <- inlinesToParElems ils

505+ -- Now get the slide without the header, and then add the header

506+ -- in.

507+ slide <- blocksToSlide' lvl blks

508+ return $ case slide of

509+ ContentSlide _ cont -> ContentSlide hdr cont

510+ TwoColumnSlide _ contL contR -> TwoColumnSlide hdr contL contR

511+ slide' -> slide'

512+blocksToSlide' _ (blk : blks)

513+ | Div (_, classes, _) divBlks <- blk

514+ , "columns" `elem` classes

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

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

517+ unless (null blks)

518+ (mapM (P.report . BlockNotRendered) blks >> return ())

519+ unless (null remaining)

520+ (mapM (P.report . BlockNotRendered) remaining >> return ())

521+ mbSplitBlksL <- splitBlocks blksL

522+ mbSplitBlksR <- splitBlocks blksR

523+ let blksL' = case mbSplitBlksL of

524+ bs : _ -> bs

525+ [] -> []

526+ let blksR' = case mbSplitBlksR of

527+ bs : _ -> bs

528+ [] -> []

529+ shapesL <- blocksToShapes blksL'

530+ shapesR <- blocksToShapes blksR'

531+ return $ TwoColumnSlide { twoColumnSlideHeader = []

532+ , twoColumnSlideLeft = shapesL

533+ , twoColumnSlideRight = shapesR

534+ }

535+blocksToSlide' _ (blk : blks) = do

536+ inNoteSlide <- asks envInNoteSlide

537+ shapes <- if inNoteSlide

538+ then forceFontSize noteSize $ blocksToShapes (blk : blks)

539+ else blocksToShapes (blk : blks)

540+ return $ ContentSlide { contentSlideHeader = []

541+ , contentSlideContent = shapes

542+ }

543+blocksToSlide' _ [] = return $ ContentSlide { contentSlideHeader = []

544+ , contentSlideContent = []

545+ }

546+

547+blocksToSlide :: PandocMonad m => [Block] -> Pres m Slide

548+blocksToSlide blks = do

549+ slideLevel <- asks envSlideLevel

550+ blocksToSlide' slideLevel blks

551+

552+makeNoteEntry :: Int -> [Block] -> [Block]

553+makeNoteEntry n blks =

554+ let enum = Str (show n ++ ".")

555+ in

556+ case blks of

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

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

559+

560+forceFontSize :: PandocMonad m => Pixels -> Pres m a -> Pres m a

561+forceFontSize px x = do

562+ rpr <- asks envRunProps

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

564+

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

566+-- the TOC.

567+makeNotesSlideBlocks :: PandocMonad m => Pres m [Block]

568+makeNotesSlideBlocks = do

569+ noteIds <- gets stNoteIds

570+ slideLevel <- asks envSlideLevel

571+ meta <- asks envMetadata

572+ -- Get identifiers so we can give the notes section a unique ident.

573+ anchorSet <- M.keysSet <$> gets stAnchorMap

574+ if M.null noteIds

575+ then return []

576+ else do let title = case lookupMeta "notes-title" meta of

577+ Just val -> metaValueToInlines val

578+ Nothing -> [Str "Notes"]

579+ ident = Shared.uniqueIdent title anchorSet

580+ hdr = Header slideLevel (ident, [], []) title

581+ blks <- return $

582+ concatMap (\(n, bs) -> makeNoteEntry n bs) $

583+ M.toList noteIds

584+ return $ hdr : blks

585+

586+getMetaSlide :: PandocMonad m => Pres m (Maybe Slide)

587+getMetaSlide = do

588+ meta <- asks envMetadata

589+ title <- inlinesToParElems $ docTitle meta

590+ subtitle <- inlinesToParElems $

591+ case lookupMeta "subtitle" meta of

592+ Just (MetaString s) -> [Str s]

593+ Just (MetaInlines ils) -> ils

594+ Just (MetaBlocks [Plain ils]) -> ils

595+ Just (MetaBlocks [Para ils]) -> ils

596+ _ -> []

597+ authors <- mapM inlinesToParElems $ docAuthors meta

598+ date <- inlinesToParElems $ docDate meta

599+ if null title && null subtitle && null authors && null date

600+ then return Nothing

601+ else return $ Just $ MetadataSlide { metadataSlideTitle = title

602+ , metadataSlideSubtitle = subtitle

603+ , metadataSlideAuthors = authors

604+ , metadataSlideDate = date

605+ }

606+-- adapted from the markdown writer

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

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

609+ opts <- asks envOpts

610+ let headerLink = if null ident

611+ then walk Shared.deNote headerText

612+ else [Link nullAttr (walk Shared.deNote headerText)

613+ ('#':ident, "")]

614+ listContents <- if null subsecs || lev >= writerTOCDepth opts

615+ then return []

616+ else mapM elementToListItem subsecs

617+ return [Plain headerLink, BulletList listContents]

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

619+

620+makeTOCSlide :: PandocMonad m => [Block] -> Pres m Slide

621+makeTOCSlide blks = do

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

623+ meta <- asks envMetadata

624+ slideLevel <- asks envSlideLevel

625+ let tocTitle = case lookupMeta "toc-title" meta of

626+ Just val -> metaValueToInlines val

627+ Nothing -> [Str "Table of Contents"]

628+ hdr = Header slideLevel nullAttr tocTitle

629+ sld <- blocksToSlide [hdr, contents]

630+ return sld

631+

632+combineParaElems' :: Maybe ParaElem -> [ParaElem] -> [ParaElem]

633+combineParaElems' mbPElem [] = maybeToList mbPElem

634+combineParaElems' Nothing (pElem : pElems) =

635+ combineParaElems' (Just pElem) pElems

636+combineParaElems' (Just pElem') (pElem : pElems)

637+ | Run rPr' s' <- pElem'

638+ , Run rPr s <- pElem

639+ , rPr == rPr' =

640+ combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems

641+ | otherwise =

642+ pElem' : combineParaElems' (Just pElem) pElems

643+

644+combineParaElems :: [ParaElem] -> [ParaElem]

645+combineParaElems = combineParaElems' Nothing

646+

647+blocksToPresentation :: PandocMonad m => [Block] -> Pres m Presentation

648+blocksToPresentation blks = do

649+ opts <- asks envOpts

650+ let metadataStartNum = 1

651+ metadataslides <- maybeToList <$> getMetaSlide

652+ let tocStartNum = metadataStartNum + length metadataslides

653+ -- As far as I can tell, if we want to have a variable-length toc in

654+ -- the future, we'll have to make it twice. Once to get the length,

655+ -- and a second time to include the notes slide. We can't make the

656+ -- notes slide before the body slides because we need to know if

657+ -- there are notes, and we can't make either before the toc slide,

658+ -- because we need to know its length to get slide numbers right.

659+ --

660+ -- For now, though, since the TOC slide is only length 1, if it

661+ -- exists, we'll just get the length, and then come back to make the

662+ -- slide later

663+ let tocSlidesLength = if writerTableOfContents opts then 1 else 0

664+ let bodyStartNum = tocStartNum + tocSlidesLength

665+ blksLst <- splitBlocks blks

666+ bodyslides <- mapM

667+ (\(bs, n) -> local (\st -> st{envCurSlideId = n}) (blocksToSlide bs))

668+ (zip blksLst [bodyStartNum..])

669+ let noteStartNum = bodyStartNum + length bodyslides

670+ notesSlideBlocks <- makeNotesSlideBlocks

671+ -- now we come back and make the real toc...

672+ tocSlides <- if writerTableOfContents opts

673+ then do toc <- makeTOCSlide $ blks ++ notesSlideBlocks

674+ return [toc]

675+ else return []

676+ -- ... and the notes slide. We test to see if the blocks are empty,

677+ -- because we don't want to make an empty slide.

678+ notesSlides <- if null notesSlideBlocks

679+ then return []

680+ else do notesSlide <- local

681+ (\env -> env { envCurSlideId = noteStartNum

682+ , envInNoteSlide = True

683+ })

684+ (blocksToSlide $ notesSlideBlocks)

685+ return [notesSlide]

686+ return $

687+ Presentation $

688+ metadataslides ++ tocSlides ++ bodyslides ++ notesSlides

689+

690+documentToPresentation :: PandocMonad m

691+ => WriterOptions

692+ -> Pandoc

693+ -> m Presentation

694+documentToPresentation opts (Pandoc meta blks) = do

695+ let env = def { envOpts = opts

696+ , envMetadata = meta

697+ , envSlideLevel = case writerSlideLevel opts of

698+ Just lvl -> lvl

699+ Nothing -> getSlideLevel blks

700+ }

701+ runPres env def $ blocksToPresentation blks